server: present lint results in pretty html

(this is mostly a rewrite / translation of the django templates built
into rc3's hub)

2 files changed, 124 insertions, 47 deletions

diff --git a/server/Orphans.hs b/server/Orphans.hs
index b46f728..c307520 100644
--- a/server/Orphans.hs
+++ b/server/Orphans.hs
@@ -1,57 +1,133 @@
-
+{-# 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 (..))
 
-module Orphans where
 
 
-import           Control.Monad (forM_, unless)
-import qualified Data.Map      as M
-import           Data.Text     (Text)
-import           Lucid         (ToHtml)
-import           Lucid.Base    (ToHtml (toHtml))
-import           Lucid.Html5
+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"
 
-import           CheckDir
-import           CheckMap
-import           Types
-import           Util          (prettyprint)
+-- | 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 l m) = do
-    span_ [class_ "level"] $ toHtml (show l)
-    toHtml m
+  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
-    h3_ $ toHtml (show $ maximumLintLevel res)
-    unless (null dirresultMissingAssets && null dirresultDeps) $ do
-      h2_ "Dependencies"
-      ul_ $ do
-        forM_ dirresultMissingAssets $ \(MissingAsset missing) -> do
-          li_ $ toHtml (prettyprint missing)
-        forM_ dirresultDeps $ \missing -> do
-          li_ $ toHtml (prettyprint missing)
+
+    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
-      h2_ "Maps"
+      h3_ "Maps"
       flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do
-        h3_ (toHtml name)
-        ul_ $ do
-          forM_ mapresultGeneral $ \lint ->
-            li_ (toHtml lint)
-          flip M.foldMapWithKey mapresultLayer $ \lint layers ->
-            li_ $ do
-              toHtml lint
-              toHtml ("(in layer" :: Text)
-              forM_ layers $ \layer ->
-                span_ [class_ "layer"] (toHtml layer)
-              toHtml (")" :: Text)
-          flip M.foldMapWithKey mapresultTileset $ \lint tilesets ->
-            li_ $ do
-              toHtml lint
-              toHtml ("( in layer" :: Text)
-              forM_ tilesets $ \tileset ->
-                span_ [class_ "tileset"] (toHtml tileset)
-              toHtml (")" :: Text)
+        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 536350f..ac79237 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -75,16 +75,17 @@ instance ToHtml JobStatus where
   toHtml status = html_ $ do
     head_ $ do
       title_ "Job Status"
-      link_ [rel_ "stylesheet", type_ "text/css", href_ "/styles.css"]
-    body_ $ div_ [class_ "main-content"] $ case status of
+      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
-        h2_ "Pending …"
+        h1_ "Pending …"
         p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
       Linted res -> do
-        p_ "Linted"
+        h1_ "Linter Result"
         toHtml res
       Failed err -> do
-        h2_ "System Error"
+        h1_ "System Error"
         p_ $ "error: " <> toHtml err
         p_ "you should probably ping an admin about this or sth"