diff options
Diffstat (limited to '')
-rw-r--r-- | server/Worker.hs | 50 |
1 files changed, 32 insertions, 18 deletions
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 |