From 89ccd9e970fe1c736cd68ad6f1def666e5275e6b Mon Sep 17 00:00:00 2001 From: stuebinm Date: Fri, 11 Feb 2022 22:25:23 +0100 Subject: server: admin interface (for now, just a list of all maps and their current status) --- server/HtmlOrphans.hs | 177 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 177 insertions(+) create mode 100644 server/HtmlOrphans.hs (limited to 'server/HtmlOrphans.hs') 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; ")" -- cgit v1.2.3