1 files changed, 177 insertions, 0 deletions
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; ")"