From 6f1be3e881cc1d203607fdba28c0c694a06b352f Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 6 Mar 2022 13:58:42 +0100
Subject: server: websocket for updates & auto-reload

todo: find a better solution than writing javascript in haskell strings. SERIOUSLY.
---
 server/HtmlOrphans.hs | 43 +++++++++++++++++++++++++++++--------------
 1 file changed, 29 insertions(+), 14 deletions(-)

(limited to 'server/HtmlOrphans.hs')

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
 
-- 
cgit v1.2.3