summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
authorstuebinm2022-02-15 22:28:24 +0100
committerstuebinm2022-02-15 22:28:24 +0100
commit358305b196e41ca88155fd0d71516cefe7e2732d (patch)
tree15b7348ec5e1683ccac141ea0ebebef56c996a1b /server
parentf228c99fd04d539b1aa0c84504b1d6e3f87aa2fe (diff)
server: switch to universum prelude, some cleanup
it's slightly less of a mess than it was before
Diffstat (limited to '')
-rw-r--r--server/Handlers.hs81
-rw-r--r--server/HtmlOrphans.hs46
-rw-r--r--server/Main.hs100
-rw-r--r--server/Server.hs40
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)