From 5e6a9d55217893144ba59305b9a90ad5c96663c1 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Fri, 11 Feb 2022 22:25:23 +0100 Subject: server: admin interface (for now, just a list of all maps and their current status) --- server/Handlers.hs | 13 +++- server/HtmlOrphans.hs | 177 ++++++++++++++++++++++++++++++++++++++++++++++++++ server/Main.hs | 14 ++-- server/Orphans.hs | 133 ------------------------------------- server/Server.hs | 64 +++++++++--------- 5 files changed, 227 insertions(+), 174 deletions(-) create mode 100644 server/HtmlOrphans.hs delete mode 100644 server/Orphans.hs (limited to 'server') 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/HtmlOrphans.hs b/server/HtmlOrphans.hs new file mode 100644 index 0000000..bb4932d --- /dev/null +++ b/server/HtmlOrphans.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- the ToHtml class also provides a method without escaping which we don't use, +-- so it's safe to never define it +{-# OPTIONS_GHC -Wno-missing-methods #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Module containing orphan instances of Lucid's ToHtml, used for rendering +-- 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 (..)) + + +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 () +badge level = span_ [class_ badgetype] + where badgetype = case level of + Info -> "badge badge-info" + Suggestion -> "badge badge-info" + Warning -> "badge badge-warning" + Forbidden -> "badge badge-danger" + Error -> "badge badge-danger" + Fatal -> "badge badge-danger" + +-- | Lint Levels directly render into badges +instance ToHtml Level where + toHtml level = badge level (toHtml $ show level) + +-- | Hints are just text with a level +instance ToHtml Hint where + toHtml (Hint level msg) = do + toHtml level; " "; toHtml msg + + +headerText :: Monad m => Level -> HtmlT m () +headerText = \case + Info -> "Couldn't find a thing to complain about. Congratulations!" + Suggestion -> "There's a couple smaller nitpicks; maybe take a look at those?" + Warning -> "The map is fine, but some things look like they might be mistakes; \ + \perhaps you want to take a look at those?" + Forbidden -> "The map is fine in principle, but contains things that are not\ + \allowed at this event" + Error -> "Your map currently contains errors and should probably be fixed" + Fatal -> "Something broke while linting; if you're not sure why or how to make \ + \it work, feel free to tell an admin about it" + + +-- | The fully monky +instance ToHtml DirResult where + toHtml res@DirResult { .. } = do + + p_ $ do badge maxlevel "Linted:"; " "; headerText maxlevel + + h2_ "Exits" + unless (null dirresultDeps) $ ul_ $ + forM_ dirresultDeps $ \missing -> do + li_ $ do + -- TODO: the whole Maybe Bool thing is annoying; I think that was a + -- remnant of talking to python stuff and can probably be removed? + if depFatal missing == Just True + then do { toHtml Error; "Map " } + else do { toHtml Warning; "Entrypoint " } + code_ $ toHtml (entrypoint missing) + " does not exist" + unless (depFatal missing /= Just True) $ do + " (no layer with that name is a "; mono "startLayer"; ")" + ", but is used as "; mono "exitUrl"; " in " + placeList (neededBy missing); "." + + -- the exit graph thing + script_ [ src_ "/dot-wasm.js" ] (""::Text) + script_ [ src_ "/d3.js" ] (""::Text) + script_ [ src_ "/d3-graphviz.js" ] (""::Text) + div_ [ id_ "exitGraph" ] "" + script_ $ + "\ + \d3.select(\"#exitGraph\")\n\ + \ .graphviz()\n\ + \ .dot(\"" <> T.pack (escapeJSON $ showDot dirresultGraph) <> "\")\n\ + \ .render()\n\ + \" + + unless (null dirresultMissingAssets) $ do + h2_ [class_ "border-bottom"] "Assets" + ul_ $ forM_ dirresultMissingAssets $ + \(MissingAsset MissingDep { .. }) -> li_ $ do + toHtml Error; "File "; mono $ toHtml entrypoint + " does not exist, but is referenced in "; placeList neededBy; ")" + + unless (null dirresultMaps) $ do + h3_ "Maps" + flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do + h4_ (toHtml name) + ul_ $ forM_ mapresultGeneral $ \lint -> + li_ (toHtml lint) + h5_ "Layers" + ul_ (listMapWithKey mapresultLayer) + h5_ "Tilesets" + ul_ (listMapWithKey mapresultTileset) + + where + maxlevel = maximumLintLevel res + + placeList :: (Monad m, ToHtml a) => [a] -> HtmlT m () + placeList occurances = + sequence_ . intersperse ", " $ occurances <&> \place -> + code_ [class_ "small text-muted"] (toHtml place) + + listMapWithKey map = + flip M.foldMapWithKey map $ \lint places -> + li_ $ do toHtml lint; " (in "; placeList places; ")" 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/Orphans.hs b/server/Orphans.hs deleted file mode 100644 index c307520..0000000 --- a/server/Orphans.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- the ToHtml class also provides a method without escaping which we don't use, --- so it's safe to never define it -{-# OPTIONS_GHC -Wno-missing-methods #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | 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 (..)) - - - -badge :: Monad m => Level -> HtmlT m () -> HtmlT m () -badge level = span_ [class_ badgetype] - where badgetype = case level of - Info -> "badge badge-info" - Suggestion -> "badge badge-info" - Warning -> "badge badge-warning" - Forbidden -> "badge badge-danger" - Error -> "badge badge-danger" - Fatal -> "badge badge-danger" - --- | Lint Levels directly render into badges -instance ToHtml Level where - toHtml level = badge level (toHtml $ show level) - --- | Hints are just text with a level -instance ToHtml Hint where - toHtml (Hint level msg) = do - toHtml level; " "; toHtml msg - - -headerText :: Monad m => Level -> HtmlT m () -headerText = \case - Info -> "Couldn't find a thing to complain about. Congratulations!" - Suggestion -> "There's a couple smaller nitpicks; maybe take a look at those?" - Warning -> "The map is fine, but some things look like they might be mistakes; \ - \perhaps you want to take a look at those?" - Forbidden -> "The map is fine in principle, but contains things that are not\ - \allowed at this event" - Error -> "Your map currently contains errors and should probably be fixed" - Fatal -> "Something broke while linting; if you're not sure why or how to make \ - \it work, feel free to tell an admin about it" - - --- | The fully monky -instance ToHtml DirResult where - toHtml res@DirResult { .. } = do - - p_ $ do badge maxlevel "Linted:"; " "; headerText maxlevel - - h2_ "Exits" - unless (null dirresultDeps) $ ul_ $ - forM_ dirresultDeps $ \missing -> do - li_ $ do - -- TODO: the whole Maybe Bool thing is annoying; I think that was a - -- remnant of talking to python stuff and can probably be removed? - if depFatal missing == Just True - then do { toHtml Error; "Map " } - else do { toHtml Warning; "Entrypoint " } - code_ $ toHtml (entrypoint missing) - " does not exist" - unless (depFatal missing /= Just True) $ do - " (no layer with that name is a "; mono "startLayer"; ")" - ", but is used as "; mono "exitUrl"; " in " - placeList (neededBy missing); "." - - -- the exit graph thing - script_ [ src_ "/dot-wasm.js" ] (""::Text) - script_ [ src_ "/d3.js" ] (""::Text) - script_ [ src_ "/d3-graphviz.js" ] (""::Text) - div_ [ id_ "exitGraph" ] "" - script_ $ - "\ - \d3.select(\"#exitGraph\")\n\ - \ .graphviz()\n\ - \ .dot(\"" <> T.pack (escapeJSON $ showDot dirresultGraph) <> "\")\n\ - \ .render()\n\ - \" - - unless (null dirresultMissingAssets) $ do - h2_ [class_ "border-bottom"] "Assets" - ul_ $ forM_ dirresultMissingAssets $ - \(MissingAsset MissingDep { .. }) -> li_ $ do - toHtml Error; "File "; mono $ toHtml entrypoint - " does not exist, but is referenced in "; placeList neededBy; ")" - - unless (null dirresultMaps) $ do - h3_ "Maps" - flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do - h4_ (toHtml name) - forM_ mapresultGeneral $ \lint -> - li_ (toHtml lint) - h5_ "Layers" - ul_ (listMapWithKey mapresultLayer) - h5_ "Tilesets" - ul_ (listMapWithKey mapresultTileset) - - 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 -> - code_ [class_ "small text-muted"] (toHtml place) - - listMapWithKey map = - flip M.foldMapWithKey map $ \lint places -> - li_ $ do toHtml lint; " (in "; placeList places; ")" 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) -- cgit v1.2.3