diff options
Diffstat (limited to '')
| -rw-r--r-- | package.yaml | 23 | ||||
| -rw-r--r-- | server/Handlers.hs | 15 | ||||
| -rw-r--r-- | server/Main.hs | 54 | ||||
| -rw-r--r-- | walint.cabal | 49 |
4 files changed, 75 insertions, 66 deletions
diff --git a/package.yaml b/package.yaml index 8da74b1..4392187 100644 --- a/package.yaml +++ b/package.yaml @@ -50,31 +50,28 @@ executables: - aeson-pretty - template-haskell - process - server: + walint-server: main: Main.hs source-dirs: 'server' dependencies: + - walint + - base-compat - time + - directory + - filepath + - warp + - wai - servant - servant-server - - wai - - base-compat - - string-conversions - - http-media - - warp + - lucid + - servant-lucid + - http-types - cli-git - cli-extras - - filepath - - logging-effect - - process - extra - - directory - - walint - uuid - containers - microlens - microlens-th - tomland - - lucid - - servant-lucid - dotgen diff --git a/server/Handlers.hs b/server/Handlers.hs index d89d2c5..ce1eb9b 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where @@ -12,7 +13,7 @@ import CheckDir (recursiveCheckDir) import Cli.Extras (CliConfig, CliT, ProcessFailure, Severity (..), callProcessAndLogOutput, getCliConfig, prettyProcessFailure, - runCli) + putLog, runCli) import Control.Concurrent (MVar, ThreadId, forkIO, readMVar, withMVar) import Control.Monad.Extra (ifM) diff --git a/server/Main.hs b/server/Main.hs index ef47bbd..fa7d2bd 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -11,15 +11,23 @@ -- | simple server offering linting "as a service" module Main where -import Cli.Extras (mkDefaultCliConfig, runCli) +import Cli.Extras (CliConfig, Severity (..), + mkDefaultCliConfig, putLog, runCli) import Control.Concurrent (MVar, newMVar) +import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Lazy.Char8 as C8 +import Data.List (intersperse) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) import Data.UUID (UUID) import Handlers (App, adminOverviewImpl, relintImpl, statusImpl, submitImpl) import HtmlOrphans () -import Network.Wai.Handler.Warp (run) +import Network.HTTP.Types.Status (Status (..)) +import Network.Wai (Request, pathInfo, requestMethod) +import Network.Wai.Handler.Warp (defaultSettings, runSettings, + setLogger, setPort) import Servant (Application, Capture, Get, Handler, HasServer (ServerT), JSON, NoContent, Post, Proxy (Proxy), @@ -33,18 +41,7 @@ import Server (AdminOverview, Config (..), JobStatus, RemoteRef (..), State, defaultState, loadConfig) -{- -Needed: - - admin overview (perhaps on seperate port?) - - in json: - - submit a repository link & ref name, get back job id - - look up a lint status by job id - - in html - - look up a lint status, pretty-printed - - front page with overview & links - - possibly a "update & relint" button? - - links to documentation --} + -- | Main API type type API format = "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID @@ -74,20 +71,37 @@ server config state = :<|> serveDirectoryWebApp "./static" -- | make an application; convert any cli errors into a 500 -app :: Config True -> MVar State -> Application -app config = +app :: CliConfig -> Config True -> MVar State -> Application +app cliconfig config = serve api . hoistServer api conv . server config where api = Proxy @Routes conv :: App a -> Handler a conv m = do - config <- liftIO $ mkDefaultCliConfig ["-v"] - res <- runCli config m + res <- runCli cliconfig m case res of Right a -> pure a Left err -> throwError (err500 { errBody = C8.pack (show err) }) main :: IO () main = do - config' <- loadConfig "./config.toml" + cliconfig <- liftIO $ mkDefaultCliConfig ["-v"] + config <- loadConfig "./config.toml" state <- newMVar defaultState - run (port config') (app config' state) + let warpsettings = + setPort (port config) + . setLogger (logRequest cliconfig) + $ defaultSettings + + runSettings warpsettings (app cliconfig config state) + +-- TODO: at some point i should learn how to do these things properly, but +-- for now this works well enough i guess +logRequest :: CliConfig -> Request -> Status -> Maybe Integer -> IO () +logRequest cliconfig req status _size = void . runCli cliconfig $ + putLog Notice + $ "request: " + <> decodeUtf8 (requestMethod req) <> " " + <> parts <> " " + <> T.pack (show (statusCode status)) <> " " + <> decodeUtf8 (statusMessage status) + where parts = T.concat $ intersperse "/" (pathInfo req) diff --git a/walint.cabal b/walint.cabal index 397e317..1165a37 100644 --- a/walint.cabal +++ b/walint.cabal @@ -57,7 +57,28 @@ library , witherable default-language: Haskell2010 -executable server +executable walint + main-is: Main.hs + other-modules: + Version + Paths_walint + hs-source-dirs: + src + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors + build-depends: + aeson + , aeson-pretty + , base + , bytestring + , getopt-generics + , mtl + , process + , template-haskell + , text + , walint + default-language: Haskell2010 + +executable walint-server main-is: Main.hs other-modules: Handlers @@ -79,17 +100,14 @@ executable server , dotgen , extra , filepath - , http-media - , logging-effect + , http-types , lucid , microlens , microlens-th , mtl - , process , servant , servant-lucid , servant-server - , string-conversions , text , time , tomland @@ -98,24 +116,3 @@ executable server , walint , warp default-language: Haskell2010 - -executable walint - main-is: Main.hs - other-modules: - Version - Paths_walint - hs-source-dirs: - src - ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors - build-depends: - aeson - , aeson-pretty - , base - , bytestring - , getopt-generics - , mtl - , process - , template-haskell - , text - , walint - default-language: Haskell2010 |