server: show helpful information for result

This includes the backlink to the lobby (auto-generated only for now)
and a "help!"-button for sending mails. Also general info regarding
which commit was linted / published.

1 files changed, 49 insertions, 22 deletions

diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index 02bca23..dad2954 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -7,6 +7,8 @@
 -- 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
@@ -19,6 +21,7 @@ import           CheckDir        (DirResult (..), MissingAsset (MissingAsset),
 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))
@@ -27,9 +30,10 @@ import           Lucid.Html5     (a_, body_, button_, class_, code_, disabled_,
                                   href_, html_, id_, li_, link_, main_,
                                   onclick_, p_, rel_, script_, span_, src_,
                                   title_, type_, ul_)
-import           Server          (JobStatus (..), Org (orgSlug),
-                                  RemoteRef (reporef, repourl), prettySha,
-                                  unState)
+import           Server          (JobStatus (..),
+                                  Org (Org, orgBacklinkPrefix, orgContactMail, orgSlug),
+                                  RemoteRef (RemoteRef, reponame, reporef, repourl),
+                                  prettySha, unState)
 import           Types           (Hint (Hint), Level (..))
 
 
@@ -47,20 +51,29 @@ htmldoc inner = html_ $ do
       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
+instance ToHtml (Org True, RemoteRef, JobStatus, Maybe JobStatus) where
+  toHtml (org@Org{..}, ref@RemoteRef{..}, status, published) = 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)"
         autoReloadScript
-      Linted res _rev (pending, _) -> do
-        h1_ "Linter Result"
-        p_ $ do
-          "your map will be re-linted periodically. "
+      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 now"
-        toHtml res
+          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\
@@ -128,25 +141,39 @@ instance ToHtml Hint where
 
 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"
+  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 (DirResult a) where
-  toHtml res@DirResult { .. } = do
+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)