summaryrefslogtreecommitdiff
path: root/server/HtmlOrphans.hs
diff options
context:
space:
mode:
authorstuebinm2022-03-06 13:58:42 +0100
committerstuebinm2022-03-06 13:58:42 +0100
commite495931e6126896b09a5e95db8ba6f56fda42808 (patch)
treebb4ce4bb076f894ebef193c143f200c396cfb3d9 /server/HtmlOrphans.hs
parentad7343815cc89d34c68f7d38239882bd3d36a577 (diff)
server: websocket for updates & auto-reload
todo: find a better solution than writing javascript in haskell strings. SERIOUSLY.
Diffstat (limited to 'server/HtmlOrphans.hs')
-rw-r--r--server/HtmlOrphans.hs43
1 files changed, 29 insertions, 14 deletions
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index 9475045..b90ea6d 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -20,11 +20,12 @@ import CheckMap (MapResult (..))
import Data.List.Extra (escapeJSON)
import qualified Data.Map as M
import Handlers (AdminOverview (..))
-import Lucid (HtmlT, ToHtml, button_, onclick_)
+import Lucid (HtmlT, ToHtml)
import Lucid.Base (ToHtml (toHtml))
-import Lucid.Html5 (a_, body_, class_, code_, div_, em_, h1_, h2_,
- h3_, h4_, h5_, head_, href_, html_, id_, li_,
- link_, main_, p_, rel_, script_, span_, src_,
+import Lucid.Html5 (a_, body_, button_, class_, code_, disabled_,
+ div_, em_, h1_, h2_, h3_, h4_, h5_, head_,
+ href_, html_, id_, li_, link_, main_,
+ onclick_, p_, rel_, script_, span_, src_,
title_, type_, ul_)
import Server (JobStatus (..), Org (orgSlug),
RemoteRef (reporef, repourl), prettySha,
@@ -48,12 +49,15 @@ htmldoc inner = html_ $ do
instance ToHtml JobStatus where
toHtml status = htmldoc $ case status of
- Pending -> do
+ Pending _ -> do
h1_ "Pending …"
p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
- Linted res _rev -> do
+ autoReloadScript
+ Linted res _rev (pending, _) -> do
h1_ "Linter Result"
- button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "relint"
+ 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"
toHtml res
script_
"function relint() {\n\
@@ -61,17 +65,28 @@ instance ToHtml JobStatus where
\ xhr.open('POST', 'relint', true);\n\
\ xhr.onreadystatechange = (e) => {if (xhr.status == 200) {\n\
\ console.log(e);\n\
- \ let btn = document.getElementById('relint_button');\n\
- \ btn.innerText = 'pending … (please reload)';\n\
- \ btn.disabled = true;\n\
- \ btn.class = 'btn btn-disabled';\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 ws = new WebSocket('ws://localhost:8080' + 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
@@ -81,9 +96,9 @@ instance ToHtml AdminOverview where
if null jobs then em_ "(nothing yet)"
else flip M.foldMapWithKey jobs $ \sha1 (ref, status) -> li_ $ do
case status of
- Pending -> badge Info "pending"
- (Linted res rev) -> toHtml $ maximumLintLevel res
- (Failed _) -> badge Error "system error"
+ Pending _ -> badge Info "pending"
+ (Linted res rev _) -> 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