server: admin interface

(for now, just a list of all maps and their current status)

1 files changed, 0 insertions, 133 deletions

diff --git a/server/Orphans.hs b/server/Orphans.hs
deleted file mode 100644
index c307520..0000000
--- a/server/Orphans.hs
+++ /dev/null
@@ -1,133 +0,0 @@
-{-# 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 (..))
-
-
-
-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)
-        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; ")"