server: admin interface

(for now, just a list of all maps and their current status)

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 ->