summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--config.toml3
-rw-r--r--server/Handlers.hs12
-rw-r--r--server/HtmlOrphans.hs71
-rw-r--r--server/Main.hs15
-rw-r--r--server/Server.hs18
-rw-r--r--static/style.css5
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;
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 13:07:01 +0000