summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/Orphans.hs160
-rw-r--r--server/Server.hs11
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 16:05:59 +0000