diff options
author | stuebinm | 2022-02-11 22:25:23 +0100 |
---|---|---|
committer | stuebinm | 2022-02-11 22:25:23 +0100 |
commit | 5e6a9d55217893144ba59305b9a90ad5c96663c1 (patch) | |
tree | 1d76c1f5477fc2508016abde11fee3bb87379a54 /server/HtmlOrphans.hs | |
parent | a50ad3901377b30c5188ff3ebd519f8b0457c5eb (diff) |
server: admin interface
(for now, just a list of all maps and their current status)
Diffstat (limited to '')
-rw-r--r-- | server/HtmlOrphans.hs (renamed from server/Orphans.hs) | 90 |
1 files changed, 67 insertions, 23 deletions
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 -> |