server: websocket for updates & auto-reload

todo: find a better solution than writing javascript in haskell strings. SERIOUSLY.

1 files changed, 26 insertions, 2 deletions

diff --git a/server/Worker.hs b/server/Worker.hs
index 6092c78..8b3903c 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -13,6 +13,7 @@ import           Universum
 import           CheckDir                      (recursiveCheckDir,
                                                 shrinkDirResult)
 import           Control.Concurrent.Async      (async, link)
+import           Control.Concurrent.STM        (writeTChan)
 import           Control.Concurrent.STM.TQueue
 import           Control.Exception             (IOException, handle)
 import           Control.Monad.Logger          (logError, logErrorN, logInfoN,
@@ -23,9 +24,12 @@ import qualified Data.UUID.V4                  as UUID
 import           Fmt                           ((+|), (|+))
 import           Server                        (Config, JobStatus (..),
                                                 Org (..),
+                                                RealtimeMsg (RelintPending, Reload),
                                                 RemoteRef (reporef, repourl),
                                                 ServerState, adjustedPath,
-                                                setJobStatus, tmpdir)
+                                                getJobStatus,
+                                                newRealtimeChannel,
+                                                setJobStatus, tmpdir, toSha)
 import           System.Directory              (doesDirectoryExist)
 import           System.Exit                   (ExitCode (ExitFailure, ExitSuccess))
 import           System.FilePath               ((</>))
@@ -60,6 +64,18 @@ runJob config Job {..} done = do
     $ finally (lint workdir) (cleanup workdir)
   where
     lint workdir = do
+      maybeRealtime <- getJobStatus done (orgSlug jobOrg) (toSha jobRef) >>= \case
+        Nothing -> pure Nothing
+        Just (org, ref, jobstatus) -> case jobstatus of
+          Linted res rev (_, realtime) -> do
+            setJobStatus done org ref (Linted res rev (True, realtime))
+            pure $ Just realtime
+          Pending realtime -> pure $ Just realtime
+          _ -> pure Nothing
+
+      whenJust maybeRealtime $ \realtime ->
+        atomically $ writeTChan realtime RelintPending
+
       ifM (doesDirectoryExist gitdir)
         -- TODO: these calls fail for dumb http, add some fallback!
         (callgit gitdir
@@ -90,8 +106,16 @@ runJob config Job {..} done = do
           -- writeAdjustedRepository does not return other codes
           $(logError) "wtf, this is impossible"
 
+      realtime <- case maybeRealtime of
+        Just realtime -> do
+          atomically $ writeTChan realtime Reload
+          pure realtime
+        Nothing ->
+          newRealtimeChannel
+
       setJobStatus done jobOrg jobRef $
-        Linted (shrinkDirResult res) rev
+        Linted (shrinkDirResult res) rev (False, realtime)
+
 
     cleanup workdir = do
       callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]