From be1089008a941da8afe23ca36f8209e0a08f58d4 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sat, 12 Feb 2022 16:59:47 +0100
Subject: [PATCH] server: added (somewhat) sensible logging
it's not very sensible, but at least it exists
---
package.yaml | 23 +++++++++-----------
server/Handlers.hs | 15 +++++++------
server/Main.hs | 54 +++++++++++++++++++++++++++++-----------------
walint.cabal | 49 ++++++++++++++++++++---------------------
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 d4ffcf6..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
- 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
- hs-source-dirs:
- src
- default-language: Haskell2010
- other-modules:
- Version
- Paths_walint
--
GitLab