From f72855ea8ade8f94474618c5dacda8dd30171740 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 20 Mar 2022 19:02:06 +0100
Subject: server: keep (one) last good result per repo

(i.e. we want to still have a valid version of the map if new results
where introduced)
---
 server/Worker.hs | 50 ++++++++++++++++++++++++++++++++------------------
 1 file changed, 32 insertions(+), 18 deletions(-)

(limited to 'server/Worker.hs')

diff --git a/server/Worker.hs b/server/Worker.hs
index a5fab58..57b5b9f 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -11,7 +11,7 @@ module Worker (linterThread, Job(..)) where
 import           Universum
 
 import           CheckDir                      (recursiveCheckDir,
-                                                shrinkDirResult)
+                                                shrinkDirResult, resultIsFatal)
 import           Control.Concurrent.Async      (async, link)
 import           Control.Concurrent.STM        (writeTChan)
 import           Control.Concurrent.STM.TQueue
@@ -27,9 +27,9 @@ import           Server                        (Config, JobStatus (..),
                                                 Org (..),
                                                 RealtimeMsg (RelintPending, Reload),
                                                 RemoteRef (..), ServerState,
-                                                adjustedPath, getJobStatus,
+                                                adjustedPath,
                                                 newRealtimeChannel,
-                                                setJobStatus, tmpdir, toSha)
+                                                tmpdir, overJobStatus)
 import           System.Directory              (doesDirectoryExist)
 import           System.Exit                   (ExitCode (ExitFailure, ExitSuccess))
 import           System.FilePath               ((</>))
@@ -65,17 +65,20 @@ runJob config Job {..} done = do
   where
     lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef)
     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
+
+      -- set the "is being linted" flag in the assembly's state
+      -- (to show on the site even after reloads etc.)
+      oldstate <- overJobStatus done jobOrg jobRef $ \case
+        Just (ref, Linted res rev (_, realtime), oldstatus) ->
+          Just (ref, Linted res rev (True, realtime), oldstatus)
+        a -> a
+
+      -- send an update message to all connected websocket clients
+      maybeRealtime <- case oldstate of
+        Just (_, Linted _ _ (_, realtime), _) -> do
+          atomically $ writeTChan realtime RelintPending
+          pure (Just realtime)
+        _ -> pure Nothing
 
       ifM (doesDirectoryExist gitdir)
         -- TODO: these calls fail for dumb http, add some fallback!
@@ -114,16 +117,27 @@ runJob config Job {..} done = do
         Nothing ->
           newRealtimeChannel
 
-      setJobStatus done jobOrg jobRef $
-        Linted (shrinkDirResult res) rev (False, realtime)
-
+      -- the fact that `realtime` can't be defined in here is horrifying
+      void $ overJobStatus done jobOrg jobRef $ \maybeOld ->
+        let status = Linted (shrinkDirResult res) rev (False, realtime)
+            lastvalid = case maybeOld of
+              Just (_,_,lastvalid) -> lastvalid
+              Nothing -> Nothing
+        in Just ( jobRef
+                , status
+                , if resultIsFatal lintConfig res
+                  then lastvalid
+                  else Just status
+                )
 
     cleanup workdir = do
       callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
 
     whoops (error :: IOException) = runStdoutLoggingT $ do
       logErrorN (show error)
-      liftIO $ setJobStatus done jobOrg jobRef $ Failed (show error)
+      void $ liftIO $ overJobStatus done jobOrg jobRef $ \case
+        Nothing -> Just (jobRef, Failed (show error), Nothing)
+        Just (_,_,lastvalid) -> Just (jobRef, Failed (show error), lastvalid)
 
     url = repourl jobRef
     ref = reporef jobRef
-- 
cgit v1.2.3