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/Handlers.hs | 81 +++++++++++++++++++--------------------- server/HtmlOrphans.hs | 46 ++++++++++------------- server/Main.hs | 100 +++++++++++++++++++++++++------------------------- server/Server.hs | 40 +++++++++++--------- 4 files changed, 129 insertions(+), 138 deletions(-) (limited to 'server') 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) -- cgit v1.2.3