From 358305b196e41ca88155fd0d71516cefe7e2732d Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Tue, 15 Feb 2022 22:28:24 +0100
Subject: server: switch to universum prelude, some cleanup

it's slightly less of a mess than it was before
---
 server/Main.hs | 100 ++++++++++++++++++++++++++++-----------------------------
 1 file changed, 49 insertions(+), 51 deletions(-)

(limited to 'server/Main.hs')

diff --git a/server/Main.hs b/server/Main.hs
index fa7d2bd..fd66ad3 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,6 +1,4 @@
 {-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE KindSignatures    #-}
-{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE TypeApplications  #-}
@@ -11,35 +9,40 @@
 -- | simple server offering linting "as a service"
 module Main where
 
-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.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),
-                                             Raw, ReqBody,
-                                             ServerError (errBody), err500,
-                                             hoistServer, serve, throwError,
-                                             type (:<|>) (..), type (:>))
-import           Servant.HTML.Lucid         (HTML)
-import           Servant.Server.StaticFiles (serveDirectoryWebApp)
-import           Server                     (AdminOverview, Config (..),
-                                             JobStatus, RemoteRef (..), State,
-                                             defaultState, loadConfig)
+import           Universum
+
+import           Cli.Extras                           (CliConfig,
+                                                       mkDefaultCliConfig,
+                                                       runCli)
+import qualified Data.ByteString.Lazy.Char8           as C8
+import           Data.UUID                            (UUID)
+import           Handlers                             (App, adminOverviewImpl,
+                                                       relintImpl, statusImpl,
+                                                       submitImpl)
+import           HtmlOrphans                          ()
+import           Network.Wai.Handler.Warp             (defaultSettings,
+                                                       runSettings, setPort)
+import           Network.Wai.Middleware.Gzip          (def)
+import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
+                                                       RequestLoggerSettings (..),
+                                                       mkRequestLogger)
+import           Servant                              (Application, Capture,
+                                                       Get, Handler,
+                                                       HasServer (ServerT),
+                                                       JSON, NoContent, Post,
+                                                       Raw, ReqBody,
+                                                       ServerError (errBody),
+                                                       err500, hoistServer,
+                                                       serve, throwError,
+                                                       type (:<|>) (..),
+                                                       type (:>))
+import           Servant.HTML.Lucid                   (HTML)
+import           Servant.Server.StaticFiles           (serveDirectoryWebApp)
+import           Server                               (AdminOverview,
+                                                       Config (..), JobStatus,
+                                                       RemoteRef (..),
+                                                       ServerState,
+                                                       defaultState, loadConfig)
 
 
 -- | Main API type
@@ -56,14 +59,14 @@ type Routes =
   :<|> Raw
 
 -- | API's implementation
-jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App
+jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App
 jsonAPI config state =
   submitImpl config state
   :<|> statusImpl state
   :<|> relintImpl config state
   :<|> adminOverviewImpl state
 
-server :: Config True -> MVar State -> ServerT Routes App
+server :: Config True -> MVar ServerState -> ServerT Routes App
 server config state =
   jsonAPI config state
   :<|> statusImpl state
@@ -71,7 +74,7 @@ server config state =
   :<|> serveDirectoryWebApp "./static"
 
 -- | make an application; convert any cli errors into a 500
-app :: CliConfig -> Config True -> MVar State -> Application
+app :: CliConfig -> Config True -> MVar ServerState -> Application
 app cliconfig config =
   serve api . hoistServer api conv . server config
   where api = Proxy @Routes
@@ -82,26 +85,21 @@ app cliconfig config =
             Right a  -> pure a
             Left err -> throwError (err500 { errBody = C8.pack (show err) })
 
+
 main :: IO ()
 main = do
-  cliconfig <- liftIO $ mkDefaultCliConfig ["-v"]
   config <- loadConfig "./config.toml"
   state <- newMVar defaultState
-  let warpsettings =
-        setPort (port config)
-        . setLogger (logRequest cliconfig)
-        $ defaultSettings
+  -- TODO: i really don't like all this cli logging stuff, replace it with
+  -- fast-logger at some point …
+  cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | verbose config]
+  loggerMiddleware <- mkRequestLogger
+    $ def { outputFormat = Detailed (verbose config) }
 
-  runSettings warpsettings (app cliconfig config state)
+  let warpsettings =
+       setPort (port config)
+       defaultSettings
 
--- 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)
+  runSettings warpsettings
+    . loggerMiddleware
+    $ app cliconfig config state
-- 
cgit v1.2.3