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.

6 files changed, 81 insertions, 43 deletions

diff --git a/config.toml b/config.toml
index b0b99b9..d48953a 100644
--- a/config.toml
+++ b/config.toml
@@ -25,6 +25,9 @@ webdir = "/tmp/var/www/divoc"
 # (part of urls for linted maps; allows indefinite browser caching)
 generation = 1
 
+backlink_prefix = "world://lobby#start_"
+contact_mail = "world@muc.hacc.space"
+
 # linter's config for this org
 lintconfig = "./config.json"
 # map's entrypoint (only maps reachable from here are included)
diff --git a/server/Handlers.hs b/server/Handlers.hs
index 987b6df..d42e74d 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -30,9 +30,9 @@ import           Network.WebSockets     (PendingConnection, acceptRequest,
                                          withPingThread)
 import           Servant                (Handler, err404, throwError)
 import           Server                 (JobStatus (..), Org (orgUrl),
-                                         RemoteRef (RemoteRef, reponame),
-                                         ServerState, Sha1, adjustedPath,
-                                         getJobStatus, unState)
+                                         RemoteRef (reponame), ServerState,
+                                         Sha1, adjustedPath, getJobStatus,
+                                         unState)
 import           Worker                 (Job (Job))
 
 
@@ -64,12 +64,12 @@ instance ToJSON MapService where
 
 
 
-statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler JobStatus
+statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler (Org True, RemoteRef, JobStatus, Maybe JobStatus)
 statusImpl state orgslug sha1 = do
    status <- liftIO $ getJobStatus state orgslug sha1
    case status of
-     Just (_,_,jobstatus,_) -> pure jobstatus
-     Nothing                -> throwError err404
+     Just stuff -> pure stuff
+     Nothing    -> throwError err404
 
 -- | since there are multiple apis that just get state information …
 stateImpl
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)
diff --git a/server/Main.hs b/server/Main.hs
index 6806ee7..0aafd65 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -44,11 +44,11 @@ import           Servant.HTML.Lucid                   (HTML)
 import           Servant.Server.StaticFiles           (serveDirectoryWebApp)
 import           Server                               (CliOptions (..),
                                                        JobStatus, Org (..),
-                                                       ServerState, Sha1,
-                                                       emptyState, exneuland,
-                                                       interval, loadConfig,
-                                                       orgs, port, token,
-                                                       verbose)
+                                                       RemoteRef, ServerState,
+                                                       Sha1, emptyState,
+                                                       exneuland, interval,
+                                                       loadConfig, orgs, port,
+                                                       token, verbose)
 import           Worker                               (Job (Job), linterThread)
 
 import           Control.Monad.Logger                 (logInfoN,
@@ -57,8 +57,7 @@ import           Servant.API                          (Header)
 import           Servant.API.WebSocket                (WebSocketPending)
 import           Servant.Client                       (ClientM, client,
                                                        mkClientEnv, runClientM)
-import           Universum.Bool.Reexport              (Bool)
-import           WithCli                              (HasArguments, withCli)
+import           WithCli                              (withCli)
 
 type family PolyEndpoint method format payload where
   PolyEndpoint Get format payload =
@@ -72,7 +71,7 @@ type MapServiceAPI method =
 
 -- | abstract api
 type API format =
-       "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] JobStatus
+       "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] (Org True, RemoteRef, JobStatus, Maybe JobStatus)
   :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "relint" :> Post '[format] Text
   :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "realtime" :> WebSocketPending
   :<|> "admin" :> "overview" :> Get '[format] AdminOverview
diff --git a/server/Server.hs b/server/Server.hs
index 3081997..48a7170 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -92,13 +92,15 @@ toSha ref = Sha1
   $ (show ref :: Text)
 
 data Org (loaded :: Bool) = Org
-  { orgSlug       :: Text
-  , orgLintconfig :: ConfigRes loaded (LintConfig Skeleton)
-  , orgEntrypoint :: FilePath
-  , orgGeneration :: Int
-  , orgRepos      :: [RemoteRef]
-  , orgUrl        :: Text
-  , orgWebdir     :: Text
+  { orgSlug           :: Text
+  , orgLintconfig     :: ConfigRes loaded (LintConfig Skeleton)
+  , orgEntrypoint     :: FilePath
+  , orgGeneration     :: Int
+  , orgRepos          :: [RemoteRef]
+  , orgUrl            :: Text
+  , orgWebdir         :: Text
+  , orgBacklinkPrefix :: Text
+  , orgContactMail    :: Text
   } deriving (Generic)
 
 instance NFData (LintConfig Skeleton) => NFData (Org True)
@@ -160,6 +162,8 @@ orgCodec = Org
   <*> T.list remoteCodec "repo" .= orgRepos
   <*> T.text "url" .= orgUrl
   <*> T.text "webdir" .= orgWebdir
+  <*> T.text "backlink_prefix" .= orgBacklinkPrefix
+  <*> T.text "contact_mail" .= orgContactMail
 
 -- why exactly does everything in tomland need to be invertable
 urlBimap :: TomlBiMap BaseUrl String
diff --git a/static/style.css b/static/style.css
index 7a84ea6..c2846ce 100644
--- a/static/style.css
+++ b/static/style.css
@@ -15,6 +15,11 @@ body {
     font-family: Ubuntu, sans-serif;
 }
 
+.btn {
+    margin-left: 2em;
+    font-family: Ubuntu;
+}
+
 .main-content {
     padding: 2em;
     border-radius: 1em;