diff options
author | stuebinm | 2022-02-10 18:12:06 +0100 |
---|---|---|
committer | stuebinm | 2022-02-11 22:25:09 +0100 |
commit | a50ad3901377b30c5188ff3ebd519f8b0457c5eb (patch) | |
tree | 568c45f71cb047d5f50d82e3452998b9d2dd8dec /server | |
parent | 485af1d460be0979b7093da307f379ef088a98db (diff) |
server: present lint results in pretty html
(this is mostly a rewrite / translation of the django templates built
into rc3's hub)
Diffstat (limited to 'server')
-rw-r--r-- | server/Orphans.hs | 160 | ||||
-rw-r--r-- | server/Server.hs | 11 |
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" |