server: added (somewhat) sensible logging

it's not very sensible, but at least it exists

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