From be1089008a941da8afe23ca36f8209e0a08f58d4 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 12 Feb 2022 16:59:47 +0100
Subject: server: added (somewhat) sensible logging

it's not very sensible, but at least it exists
---
 server/Main.hs | 54 ++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 34 insertions(+), 20 deletions(-)

(limited to 'server/Main.hs')

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)
-- 
cgit v1.2.3