{-# 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 #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} -- | Module containing orphan instances of Lucid's ToHtml, used for rendering -- linter results as html module HtmlOrphans () where import Universum import CheckDir (DirResult (..), MissingAsset (MissingAsset), MissingDep (..), maximumLintLevel) import CheckMap (MapResult (..)) import Data.List.Extra (escapeJSON) import qualified Data.Map as M import qualified Data.Text as T import Handlers (AdminOverview (..)) import Lucid (HtmlT, ToHtml) import Lucid.Base (ToHtml (toHtml)) import Lucid.Html5 (a_, body_, button_, class_, code_, disabled_, div_, em_, h1_, h2_, h3_, h4_, head_, href_, html_, id_, li_, link_, main_, onclick_, p_, rel_, script_, span_, src_, title_, type_, ul_) import Server (JobStatus (..), Org (Org, orgBacklinkPrefix, orgContactMail, orgHowtoLink, orgSlug), RemoteRef (RemoteRef, reponame, reporef, repourl), prettySha, unState) import Types (Hint (Hint), Level (..)) import Fmt 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 (Org True, RemoteRef, JobStatus, Maybe JobStatus) where toHtml (org@Org{..}, ref@RemoteRef{..}, status, published) = htmldoc $ case status of Pending _ -> do h1_ "Pending …" autoReloadScript Linted res rev (pending, _) -> do h1_ $ do "Linter Result" if pending then button_ [class_ "btn btn-primary btn-disabled", disabled_ "true"] "pending …" else button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "Relint" whenJust orgHowtoLink $ \link -> a_ [class_ "btn btn-primary", href_ link] "Howto" a_ [class_ "btn btn-primary" , href_ ("mailto:" <> orgContactMail <> "?subject=[Help-walint] " <> reponame <> " " <> rev)] "Help?" p_ $ do "For commit "; code_ (toHtml $ T.take 7 rev); " of repository " code_ (toHtml repourl); " (on "; code_ (toHtml reporef); ")" p_ $ case published of Just (Linted _ rev _) -> do "Currently published commit: "; code_ (toHtml $ T.take 7 rev); "." _ -> "This Map has not yet been published." toHtml (org,ref,res) script_ "function relint() {\n\ \ var xhr = new XMLHttpRequest ();\n\ \ xhr.open('POST', 'relint', true);\n\ \ xhr.onreadystatechange = (e) => {if (xhr.status == 200) {\n\ \ console.log(e);\n\ \ }}\n\ \ xhr.send(null);\n\ \}" autoReloadScript Failed err -> do h1_ "System Error" p_ $ "error: " <> toHtml err p_ "you should probably ping an admin about this or sth" where autoReloadScript = script_ "let proto = window.location.protocol === 'https://' ? 'wss' : 'ws://';\ \let ws = new WebSocket(proto + window.location.host + window.location.pathname + 'realtime');\n\ \ws.onmessage = (event) => {\n\ \ let resp = JSON.parse(event.data);\n\ \ if (resp == 'RelintPending') {\n\ \ let btn = document.getElementById('relint_button');\n\ \ btn.innerText = 'pending …';\n\ \ btn.disabled = true;\n\ \ btn.class = 'btn btn-disabled';\n\ \ } else if (resp == 'Reload') {\n\ \ location.reload();\n\ \ }\n\ \}" instance ToHtml AdminOverview where toHtml (AdminOverview state) = htmldoc $ do h1_ "Map List" forM_ (view unState state) $ \(org, jobs) -> do h2_ (toHtml $ orgSlug org) if null jobs then em_ "(nothing yet)" else flip M.foldMapWithKey jobs $ \sha1 (ref, status, _lastvalid) -> li_ $ do case status of Pending _ -> badge Info "pending" (Linted res _ _) -> toHtml $ maximumLintLevel res (Failed _) -> badge Error "system error" " "; a_ [href_ ("/status/"+|orgSlug org|+"/"+|prettySha sha1|+"/")] $ 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" -- | pseudo-level badge when we don't even have an info lint -- (rare, but it does happen!) badgeHurray :: Monad m => HtmlT m() -> HtmlT m () badgeHurray = span_ [class_ "badge badge-success"] -- | Lint Levels directly render into badges instance ToHtml Level where toHtml level = do badge level (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? \ \But overall the map looks great!" Warning -> "The map is fine, but some things look like they might be mistakes; \ \perhaps you want to take a look at those?" Forbidden -> "While this map might work well with workadventure, it contains \ \things that are not allowed at this event. Please change those \ \so we can publish the map" Error -> "Your map currently contains errors. You will have to fix those before \ \we can publish your map." 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 (Org True, RemoteRef, DirResult a) where toHtml (Org {..}, RemoteRef {..}, res@DirResult { .. }) = do p_ $ do badge maxlevel "Linted:"; " "; headerText maxlevel h2_ "Exits" p_ $ do "Note: to link back to the lobby, please use " code_ $ toHtml $ orgBacklinkPrefix <> reponame " as exitUrl." -- 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().engine(\"fdp\")\n\ \ .dot(\"" <> toText (escapeJSON $ toString dirresultGraph) <> "\")\n\ \ .render()\n\ \" 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); "." 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" flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do h3_ (toHtml name) if null mapresultGeneral && null mapresultLayer && null mapresultTileset then ul_ $ li_ $ badgeHurray "All good!" else do ul_ $ forM_ mapresultGeneral $ \lint -> li_ (toHtml lint) unless (null mapresultLayer) $ do h4_ "Layers" ul_ (listMapWithKey mapresultLayer) unless (null mapresultTileset) $ do h4_ "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; ")"