diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Handlers.hs | 12 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs | 71 | ||||
| -rw-r--r-- | server/Main.hs | 15 | ||||
| -rw-r--r-- | server/Server.hs | 18 |
4 files changed, 73 insertions, 43 deletions
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 |