server: switch to universum prelude, some cleanup

it's slightly less of a mess than it was before

4 files changed, 129 insertions, 138 deletions

diff --git a/server/Handlers.hs b/server/Handlers.hs
index ce1eb9b..e590cb7 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,50 +1,45 @@
 {-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications  #-}
 
 module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where
 
-import           Bindings.Cli.Git       (gitProc)
-import           CheckDir               (recursiveCheckDir)
-import           Cli.Extras             (CliConfig, CliT, ProcessFailure,
-                                         Severity (..), callProcessAndLogOutput,
-                                         getCliConfig, prettyProcessFailure,
-                                         putLog, runCli)
-import           Control.Concurrent     (MVar, ThreadId, forkIO, readMVar,
-                                         withMVar)
-import           Control.Monad.Extra    (ifM)
-import           Control.Monad.IO.Class (liftIO)
-import           Control.Monad.Trans    (lift)
-import qualified Data.Map               as M
-import qualified Data.Text              as T
-import           Data.UUID              (UUID)
-import qualified Data.UUID              as UUID
-import qualified Data.UUID.V4           as UUID
-import           Lens.Micro.Extras      (view)
-import           Servant                (Handler, NoContent (NoContent), err404,
-                                         err500, throwError)
-import           Server                 (AdminOverview (AdminOverview),
-                                         Config (entrypoint, lintconfig, tmpdir),
-                                         JobStatus (..),
-                                         RemoteRef (reporef, repourl), State,
-                                         jobs, registry, setJobStatus,
-                                         setRegistry)
-import           System.Directory       (doesDirectoryExist)
-import           System.FilePath        ((</>))
+import           Universum
+
+import           Bindings.Cli.Git        (gitProc)
+import           CheckDir                (recursiveCheckDir)
+import           Cli.Extras              (CliConfig, CliT, ProcessFailure,
+                                          Severity (..),
+                                          callProcessAndLogOutput, getCliConfig,
+                                          prettyProcessFailure, runCli)
+import           Control.Concurrent      (ThreadId, forkIO)
+import           Control.Concurrent.MVar (withMVar)
+import qualified Data.Map                as M
+import qualified Data.Text               as T
+import           Data.UUID               (UUID)
+import qualified Data.UUID               as UUID
+import qualified Data.UUID.V4            as UUID
+import           Servant                 (Handler, NoContent (NoContent),
+                                          err404, err500, throwError)
+import           Server                  (AdminOverview (AdminOverview),
+                                          Config (entrypoint, lintconfig, tmpdir),
+                                          JobStatus (..),
+                                          RemoteRef (reporef, repourl),
+                                          ServerState, jobs, registry,
+                                          setJobStatus, setRegistry)
+import           System.Directory        (doesDirectoryExist)
+import           System.FilePath         ((</>))
 
 -- | this servant app can run cli programs!
 type App = CliT ProcessFailure Handler
 
 -- | annoying (and afaik unused), but has to be here for type system reasons
 instance MonadFail Handler where
-  fail _ = throwError $ err500
+  fail _ = throwError err500
 
 -- | someone submitted a map; lint it (synchronously for now)
-submitImpl :: Config True -> MVar State -> RemoteRef -> App UUID
+submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
 submitImpl config state ref = do
   jobid <- liftIO UUID.nextRandom
   -- TODO: these two should really be atomic
@@ -56,7 +51,7 @@ submitImpl config state ref = do
   -- the submission itself can't really fail or return anything useful
   pure jobid
 
-relintImpl :: Config True -> MVar State -> UUID -> App NoContent
+relintImpl :: Config True -> MVar ServerState -> UUID -> App NoContent
 relintImpl config state uuid = do
   mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry)
   case mref of
@@ -66,7 +61,7 @@ relintImpl config state uuid = do
       _ <- checkRef config cliconfig state ref
       pure NoContent
 
-statusImpl :: MVar State -> UUID -> App JobStatus
+statusImpl :: MVar ServerState -> UUID -> App JobStatus
 statusImpl state uuid = do
    status <- liftIO $ withMVar state $ \state ->
      case M.lookup uuid (view registry state) of
@@ -77,28 +72,28 @@ statusImpl state uuid = do
      Nothing  -> lift $ throwError err404
 
 
-adminOverviewImpl :: MVar State -> App AdminOverview
+adminOverviewImpl :: MVar ServerState -> App AdminOverview
 adminOverviewImpl state = do
-  state <- liftIO $ readMVar state
+  state <- readMVar state
   pure (AdminOverview state)
 
 -- | the actual check function. forks, calls out to git to update the
 -- repository, create a new worktree, lints it, then tells git to
 -- delete that tree again
-checkRef :: Config True -> CliConfig -> MVar State -> RemoteRef -> App ThreadId
+checkRef :: Config True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId
 checkRef config cliconfig state ref = liftIO $ forkIO $ do
     res <- liftIO $ runCli cliconfig $ do
       ifM (liftIO $ doesDirectoryExist gitdir)
         -- TODO: these calls fail for dumb http, add some fallback!
         (callgit gitdir
-         [ "fetch", "origin", T.unpack (reporef ref), "--depth", "1" ])
+         [ "fetch", "origin", toString (reporef ref), "--depth", "1" ])
         (callgit gitdir
-         [ "clone", T.unpack $ repourl ref, "--bare"
-         , "--depth", "1", "-b", T.unpack (reporef ref)])
+         [ "clone", toString $ repourl ref, "--bare"
+         , "--depth", "1", "-b", toString (reporef ref)])
       rand <- liftIO UUID.nextRandom
       let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
       callgit gitdir [ "worktree", "add", workdir ]
-      callgit workdir [ "checkout", T.unpack (reporef ref) ]
+      callgit workdir [ "checkout", toString (reporef ref) ]
       res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config)
       callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
       pure res
@@ -107,7 +102,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do
       Left err  -> Failed (prettyProcessFailure err)
   where
     callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
-    gitdir = tmpdir config </> hashedname
-    hashedname = fmap escapeSlash . T.unpack . repourl $ ref
+    gitdir = tmpdir config </> toString hashedname
+    hashedname = T.map escapeSlash . repourl $ ref
     escapeSlash = \case { '/' -> '-'; a -> a }
 
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index bb4932d..4d03234 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -12,29 +12,23 @@
 -- linter results as html
 module HtmlOrphans () where
 
-
-import           CheckDir          (DirResult (..), MissingAsset (MissingAsset),
-                                    MissingDep (..), maximumLintLevel)
-import           CheckMap          (MapResult (..))
-import           Control.Monad     (forM_, unless)
-import           Data.Functor      ((<&>))
-import           Data.List         (intersperse)
-import           Data.List.Extra   (escapeJSON)
-import qualified Data.Map          as M
-import           Data.Text         (Text)
-import qualified Data.Text         as T
-import           Lens.Micro.Extras (view)
-import           Lucid             (HtmlT, ToHtml)
-import           Lucid.Base        (ToHtml (toHtml))
-import           Lucid.Html5       (a_, body_, class_, code_, div_, em_, h1_,
-                                    h2_, h3_, h4_, h5_, head_, href_, html_,
-                                    id_, li_, link_, main_, p_, rel_, script_,
-                                    span_, src_, title_, type_, ul_)
-import           Server            (AdminOverview (..), JobStatus (..),
-                                    RemoteRef (reporef, repourl), jobs,
-                                    registry)
-import           Text.Dot          (showDot)
-import           Types             (Hint (Hint), Level (..))
+import           Universum
+
+import           CheckDir        (DirResult (..), MissingAsset (MissingAsset),
+                                  MissingDep (..), maximumLintLevel)
+import           CheckMap        (MapResult (..))
+import           Data.List.Extra (escapeJSON)
+import qualified Data.Map        as M
+import           Lucid           (HtmlT, ToHtml)
+import           Lucid.Base      (ToHtml (toHtml))
+import           Lucid.Html5     (a_, body_, class_, code_, div_, em_, h1_, h2_,
+                                  h3_, h4_, h5_, head_, href_, html_, id_, li_,
+                                  link_, main_, p_, rel_, script_, span_, src_,
+                                  title_, type_, ul_)
+import           Server          (AdminOverview (..), JobStatus (..),
+                                  RemoteRef (reporef, repourl), jobs, registry)
+import           Text.Dot        (showDot)
+import           Types           (Hint (Hint), Level (..))
 
 
 mono :: Monad m => HtmlT m () -> HtmlT m ()
@@ -74,7 +68,7 @@ instance ToHtml AdminOverview where
             Just (Linted res) -> toHtml $ maximumLintLevel res
             Just (Failed _)   -> badge Error "system error"
             Nothing           -> toHtml Fatal
-          " "; a_ [href_ (T.pack $ "/status/"<>show uuid)] $ do
+          " "; a_ [href_ ("/status/"<>show uuid)] $ do
             mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref
 
 
@@ -90,7 +84,7 @@ badge level = span_ [class_ badgetype]
 
 -- | Lint Levels directly render into badges
 instance ToHtml Level where
-  toHtml level = badge level (toHtml $ show level)
+  toHtml level = badge level (toHtml (show level :: Text))
 
 -- | Hints are just text with a level
 instance ToHtml Hint where
@@ -142,7 +136,7 @@ instance ToHtml DirResult where
       "\
       \d3.select(\"#exitGraph\")\n\
       \  .graphviz()\n\
-      \  .dot(\"" <> T.pack (escapeJSON $ showDot dirresultGraph) <> "\")\n\
+      \  .dot(\"" <> toText (escapeJSON $ showDot dirresultGraph) <> "\")\n\
       \  .render()\n\
       \"
 
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
diff --git a/server/Server.hs b/server/Server.hs
index d7205bc..8014053 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -5,7 +5,6 @@
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TemplateHaskell            #-}
@@ -13,25 +12,28 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
 
-module Server (loadConfig, Config(..), RemoteRef(..), State, registry, jobs, JobStatus(..),
-                    setJobStatus,defaultState,setRegistry, AdminOverview(..)) where
+module Server ( loadConfig
+              , Config(..)
+              , RemoteRef(..)
+              , ServerState, registry, jobs, defaultState
+              , JobStatus(..)
+              , setJobStatus
+              , setRegistry
+              , AdminOverview(..)
+              ) where
+
+import           Universum
 
 import           CheckDir             (DirResult)
-import           Control.Concurrent   (MVar, modifyMVar_)
+import           Control.Concurrent   (modifyMVar_)
 import           Data.Aeson           (FromJSON, ToJSON (toJSON), eitherDecode,
                                        (.=))
 import qualified Data.Aeson           as A
 import qualified Data.ByteString.Lazy as LB
-import           Data.Map             (Map)
 import qualified Data.Map             as M
-import           Data.Text            (Text)
 import           Data.UUID            (UUID)
-import           GHC.Generics         (Generic)
-import           Lens.Micro           (over)
-import           Lens.Micro.Extras    (view)
 import           Lens.Micro.TH
 import           LintConfig           (LintConfig')
-import           System.Exit.Compat   (exitFailure)
 import           Toml                 (TomlCodec)
 import qualified Toml                 as T
 
@@ -50,6 +52,7 @@ data Config (loaded :: Bool) = Config
   { tmpdir     :: FilePath
   -- ^ dir to clone git things in
   , port       :: Int
+  , verbose    :: Bool
   -- ^ port to bind to
   , entrypoint :: FilePath
   , lintconfig :: ConfigRes loaded LintConfig'
@@ -59,6 +62,7 @@ configCodec :: TomlCodec (Config False)
 configCodec = Config
     <$> T.string "tmpdir" T..= tmpdir
     <*> T.int "port" T..= port
+    <*> T.bool "verbose" T..= verbose
     <*> T.string "entrypoint" T..= entrypoint
     <*> T.string "lintconfig" T..= lintconfig
 
@@ -68,17 +72,17 @@ data JobStatus =
   deriving (Generic, ToJSON)
 
 -- | the server's global state
-data State = State
+data ServerState = ServerState
   { _jobs     :: Map RemoteRef JobStatus
   , _registry :: Map UUID RemoteRef
   }
-makeLenses ''State
+makeLenses ''ServerState
 
-defaultState :: State
-defaultState = State mempty mempty
+defaultState :: ServerState
+defaultState = ServerState mempty mempty
 
 newtype AdminOverview =
-  AdminOverview { unAdminOverview :: State }
+  AdminOverview { unAdminOverview :: ServerState }
 
 instance ToJSON AdminOverview where
   toJSON (AdminOverview state) =
@@ -103,15 +107,15 @@ loadConfig' :: Config False -> IO (Config True)
 loadConfig' config = do
   loaded <- LB.readFile (lintconfig config) >>= \res ->
       case eitherDecode res :: Either String LintConfig' of
-        Left err   -> error $ "config file invalid: " <> err
+        Left err   -> error $ "config file invalid: " <> show err
         Right file -> pure file
   pure $ config { lintconfig = loaded }
 
 
-setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
+setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO ()
 setJobStatus mvar !ref !status = modifyMVar_ mvar
   $ pure . over jobs (M.insert ref status)
 
-setRegistry :: MVar State -> UUID -> RemoteRef -> IO ()
+setRegistry :: MVar ServerState -> UUID -> RemoteRef -> IO ()
 setRegistry mvar !uuid !ref = modifyMVar_ mvar
   $ pure . over registry (M.insert uuid ref)