diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Handlers.hs | 13 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs (renamed from server/Orphans.hs) | 90 | ||||
| -rw-r--r-- | server/Main.hs | 14 | ||||
| -rw-r--r-- | server/Server.hs | 64 |
4 files changed, 117 insertions, 64 deletions
diff --git a/server/Handlers.hs b/server/Handlers.hs index 382af64..d89d2c5 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -5,7 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} -module Handlers (App, submitImpl,statusImpl,relintImpl) where +module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where import Bindings.Cli.Git (gitProc) import CheckDir (recursiveCheckDir) @@ -13,7 +13,8 @@ import Cli.Extras (CliConfig, CliT, ProcessFailure, Severity (..), callProcessAndLogOutput, getCliConfig, prettyProcessFailure, runCli) -import Control.Concurrent (MVar, ThreadId, forkIO, withMVar) +import Control.Concurrent (MVar, ThreadId, forkIO, readMVar, + withMVar) import Control.Monad.Extra (ifM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans (lift) @@ -25,7 +26,8 @@ import qualified Data.UUID.V4 as UUID import Lens.Micro.Extras (view) import Servant (Handler, NoContent (NoContent), err404, err500, throwError) -import Server (Config (entrypoint, lintconfig, tmpdir), +import Server (AdminOverview (AdminOverview), + Config (entrypoint, lintconfig, tmpdir), JobStatus (..), RemoteRef (reporef, repourl), State, jobs, registry, setJobStatus, @@ -74,6 +76,11 @@ statusImpl state uuid = do Nothing -> lift $ throwError err404 +adminOverviewImpl :: MVar State -> App AdminOverview +adminOverviewImpl state = do + state <- liftIO $ 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 diff --git a/server/Orphans.hs b/server/HtmlOrphans.hs index c307520..bb4932d 100644 --- a/server/Orphans.hs +++ b/server/HtmlOrphans.hs @@ -10,26 +10,72 @@ -- | Module containing orphan instances of Lucid's ToHtml, used for rendering -- linter results as html -module Orphans () 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 Lucid (HtmlT, ToHtml) -import Lucid.Base (ToHtml (toHtml)) -import Lucid.Html5 (class_, code_, div_, h2_, h3_, h4_, h5_, id_, - li_, p_, script_, span_, src_, ul_) -import Text.Dot (showDot) -import Types (Hint (Hint), Level (..)) - +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 (..)) + + +mono :: Monad m => HtmlT m () -> HtmlT m () +mono = code_ [class_ "small text-muted"] + + +htmldoc :: Monad m => HtmlT m () -> HtmlT m () +htmldoc inner = html_ $ do + head_ $ do + title_ "Job Status" + link_ [rel_ "stylesheet", type_ "text/css", href_ "/bootstrap.min.css" ] + link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css" ] + body_ $ main_ [class_ "main-content"] inner + +instance ToHtml JobStatus where + toHtml status = htmldoc $ case status of + Pending -> do + h1_ "Pending …" + p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)" + Linted res -> do + h1_ "Linter Result" + toHtml res + Failed err -> do + h1_ "System Error" + p_ $ "error: " <> toHtml err + p_ "you should probably ping an admin about this or sth" + +instance ToHtml AdminOverview where + toHtml (AdminOverview state) = htmldoc $ do + h1_ "Map List" + if null (view registry state) + then em_ "(nothing yet)" + else ul_ . flip M.foldMapWithKey (view registry state) + $ \uuid ref -> li_ $ do + case M.lookup ref (view jobs state) of + Just Pending -> badge Info "pending" + Just (Linted res) -> toHtml $ maximumLintLevel res + Just (Failed _) -> badge Error "system error" + Nothing -> toHtml Fatal + " "; a_ [href_ (T.pack $ "/status/"<>show uuid)] $ do + mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref badge :: Monad m => Level -> HtmlT m () -> HtmlT m () @@ -111,7 +157,7 @@ instance ToHtml DirResult where h3_ "Maps" flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do h4_ (toHtml name) - forM_ mapresultGeneral $ \lint -> + ul_ $ forM_ mapresultGeneral $ \lint -> li_ (toHtml lint) h5_ "Layers" ul_ (listMapWithKey mapresultLayer) @@ -121,8 +167,6 @@ instance ToHtml DirResult where where maxlevel = maximumLintLevel res - mono text = code_ [class_ "small text-muted"] text - placeList :: (Monad m, ToHtml a) => [a] -> HtmlT m () placeList occurances = sequence_ . intersperse ", " $ occurances <&> \place -> diff --git a/server/Main.hs b/server/Main.hs index 00b4689..0f142de 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -16,8 +16,9 @@ import Control.Concurrent (MVar, newMVar) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Lazy.Char8 as C8 import Data.UUID (UUID) -import Handlers (App, relintImpl, statusImpl, - submitImpl) +import Handlers (App, adminOverviewImpl, relintImpl, + statusImpl, submitImpl) +import HtmlOrphans () import Network.Wai.Handler.Warp (run) import Servant (Application, Capture, Get, Handler, HasServer (ServerT), JSON, @@ -28,9 +29,10 @@ import Servant (Application, Capture, Get, Handler, type (:<|>) (..), type (:>)) import Servant.HTML.Lucid (HTML) import Servant.Server.StaticFiles (serveDirectoryWebApp) -import Server (Config (..), JobStatus, - RemoteRef (..), State, +import Server (AdminOverview, Config (..), + JobStatus, RemoteRef (..), State, defaultState, loadConfig) + {- Needed: - admin overview (perhaps on seperate port?) @@ -48,10 +50,12 @@ type API format = "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent + :<|> "admin" :> "overview" :> Get '[format] AdminOverview type Routes = "api" :> API JSON :<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus + :<|> "admin" :> "overview" :> Get '[HTML] AdminOverview :<|> Raw -- | API's implementation @@ -60,11 +64,13 @@ jsonAPI config state = submitImpl config state :<|> statusImpl state :<|> relintImpl config state + :<|> adminOverviewImpl state server :: Config True -> MVar State -> ServerT Routes App server config state = jsonAPI config state :<|> statusImpl state + :<|> adminOverviewImpl state :<|> serveDirectoryWebApp "./static" -- | make an application; convert any cli errors into a 500 diff --git a/server/Server.hs b/server/Server.hs index ac79237..d7205bc 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -13,11 +14,13 @@ {-# LANGUAGE TypeOperators #-} module Server (loadConfig, Config(..), RemoteRef(..), State, registry, jobs, JobStatus(..), - setJobStatus,defaultState,setRegistry) where + setJobStatus,defaultState,setRegistry, AdminOverview(..)) where import CheckDir (DirResult) import Control.Concurrent (MVar, modifyMVar_) -import Data.Aeson (FromJSON, ToJSON, eitherDecode) +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 @@ -25,21 +28,18 @@ 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 Lucid (ToHtml (..)) -import Lucid.Html5 -import Orphans () import System.Exit.Compat (exitFailure) import Toml (TomlCodec) -import qualified Toml -import Toml.Codec ((.=)) +import qualified Toml as T -- | a reference in a remote git repository data RemoteRef = RemoteRef { repourl :: Text , reporef :: Text - } deriving (Generic, FromJSON, Eq, Ord) + } deriving (Generic, FromJSON, ToJSON, Eq, Ord) type family ConfigRes (b :: Bool) a where ConfigRes True a = a @@ -57,46 +57,42 @@ data Config (loaded :: Bool) = Config configCodec :: TomlCodec (Config False) configCodec = Config - <$> Toml.string "tmpdir" .= tmpdir - <*> Toml.int "port" .= port - <*> Toml.string "entrypoint" .= entrypoint - <*> Toml.string "lintconfig" .= lintconfig + <$> T.string "tmpdir" T..= tmpdir + <*> T.int "port" T..= port + <*> T.string "entrypoint" T..= entrypoint + <*> T.string "lintconfig" T..= lintconfig +-- | a job status (of a specific uuid) data JobStatus = Pending | Linted DirResult | Failed Text deriving (Generic, ToJSON) +-- | the server's global state data State = State { _jobs :: Map RemoteRef JobStatus , _registry :: Map UUID RemoteRef } - -instance ToHtml JobStatus where - toHtml status = html_ $ do - head_ $ do - title_ "Job Status" - link_ [rel_ "stylesheet", type_ "text/css", href_ "/bootstrap.min.css" ] - link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css" ] - body_ $ main_ [class_ "main-content"] $ case status of - Pending -> do - h1_ "Pending …" - p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)" - Linted res -> do - h1_ "Linter Result" - toHtml res - Failed err -> do - h1_ "System Error" - p_ $ "error: " <> toHtml err - p_ "you should probably ping an admin about this or sth" - makeLenses ''State defaultState :: State defaultState = State mempty mempty +newtype AdminOverview = + AdminOverview { unAdminOverview :: State } + +instance ToJSON AdminOverview where + toJSON (AdminOverview state) = + toJSON . flip M.mapWithKey (view registry state) $ \uuid ref -> + A.object [ "reference" .= uuid + , "remote" .= ref + , "status" .= M.lookup ref (view jobs state) + ] + + + loadConfig :: FilePath -> IO (Config True) loadConfig path = do - res <- Toml.decodeFileEither configCodec path + res <- T.decodeFileEither configCodec path case res of Right config -> loadConfig' config Left err -> do @@ -113,9 +109,9 @@ loadConfig' config = do setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO () -setJobStatus mvar ref status = modifyMVar_ mvar +setJobStatus mvar !ref !status = modifyMVar_ mvar $ pure . over jobs (M.insert ref status) setRegistry :: MVar State -> UUID -> RemoteRef -> IO () -setRegistry mvar uuid ref = modifyMVar_ mvar +setRegistry mvar !uuid !ref = modifyMVar_ mvar $ pure . over registry (M.insert uuid ref) |