summaryrefslogtreecommitdiff
path: root/server/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'server/Main.hs')
-rw-r--r--server/Main.hs54
1 files changed, 34 insertions, 20 deletions
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)