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)

4 files changed, 64 insertions, 41 deletions

diff --git a/server/Handlers.hs b/server/Handlers.hs
index 0e30d2f..987b6df 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -52,9 +52,9 @@ instance ToJSON MapService where
         . mapMaybe worldObject
         $ M.elems statuses
        where
-        worldObject (RemoteRef {..}, job) = case job of
-          Linted res rev _ ->
-            Just (A.fromText reponame .=
+        worldObject (remote,  _current, result) = case result of
+          Just (Linted res rev _) ->
+            Just (A.fromText (reponame remote) .=
                     M.mapWithKey (mapInfo rev) (dirresultMaps res))
           _ -> Nothing
         mapInfo rev mappath MapResult { .. } = A.object
@@ -68,8 +68,8 @@ statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler JobStatus
 statusImpl state orgslug sha1 = do
    status <- liftIO $ getJobStatus state orgslug sha1
    case status of
-     Just (_,_,jobstatus) -> pure jobstatus
-     Nothing              -> throwError err404
+     Just (_,_,jobstatus,_) -> pure jobstatus
+     Nothing                -> throwError err404
 
 -- | since there are multiple apis that just get state information …
 stateImpl
@@ -83,7 +83,7 @@ relintImpl :: TQueue Job -> MVar ServerState -> Text -> Sha1 -> Handler Text
 relintImpl queue state orgslug sha1 =
   liftIO $ getJobStatus state orgslug sha1 >>= \case
     Nothing -> pure "there isn't a job here to restart"
-    Just (org, ref, _oldjob) -> do
+    Just (org, ref, _oldjob, _veryoldjob) -> do
       atomically $ writeTQueue queue (Job ref org)
       pure "hello"
 
@@ -91,7 +91,7 @@ relintImpl queue state orgslug sha1 =
 realtimeImpl :: MVar ServerState -> Text -> Sha1 -> PendingConnection -> Handler ()
 realtimeImpl state orgslug sha1 pending =
   liftIO (getJobStatus state orgslug sha1) >>= \case
-    Just (_org, _ref, Linted _ _ (_, realtime)) -> do
+    Just (_org, _ref, Linted _ _ (_, realtime), _) -> do
       conn <- liftIO $ acceptRequest pending
       incoming <- atomically $ dupTChan realtime
       liftIO $ withPingThread conn 30 pass $ forever $ do
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index aec6fe2..412961b 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -97,7 +97,7 @@ instance ToHtml AdminOverview where
     forM_ (view unState state) $ \(org, jobs) -> do
       h2_ (toHtml $ orgSlug org)
       if null jobs then em_ "(nothing yet)"
-      else flip M.foldMapWithKey jobs $ \sha1 (ref, status) -> li_ $ do
+      else flip M.foldMapWithKey jobs $ \sha1 (ref, status, _lastvalid) -> li_ $ do
         case status of
           Pending _          -> badge Info "pending"
           (Linted res rev _) -> toHtml $ maximumLintLevel res
diff --git a/server/Server.hs b/server/Server.hs
index da2e73d..3d783d7 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -27,15 +27,15 @@ module Server ( loadConfig
               , RemoteRef(..)
               , ServerState, emptyState, unState
               , JobStatus(..)
-              , setJobStatus
-              , prettySha,getJobStatus,adjustedPath,RealtimeMsg(..),newRealtimeChannel) where
+              , prettySha,getJobStatus,overJobStatus
+              , adjustedPath,RealtimeMsg(..),newRealtimeChannel) where
 
 import           Universum
 
 import           CheckDir                     (DirResult)
 import           CheckMap                     (ResultKind (Shrunk))
 import           Control.Arrow                ((>>>))
-import           Control.Concurrent           (modifyMVar_, withMVar)
+import           Control.Concurrent           (modifyMVar, withMVar)
 import           Control.Concurrent.STM.TChan (TChan, newBroadcastTChan)
 import           Crypto.Hash.SHA1             (hash)
 import           Data.Aeson                   (FromJSON, ToJSON, ToJSONKey (..),
@@ -209,7 +209,7 @@ instance TS.Show JobStatus where
 -- | the server's global state; might eventually end up with more
 -- stuff in here, hence the newtype
 newtype ServerState = ServerState
-  { _unState :: Map Text (Org True, Map Sha1 (RemoteRef, JobStatus)) }
+  { _unState :: Map Text (Org True, Map Sha1 (RemoteRef, JobStatus, Maybe JobStatus)) }
   deriving Generic
 
 -- instance NFData LintConfig' => NFData ServerState
@@ -223,23 +223,32 @@ emptyState config = ServerState
   $ M.fromList $ map (\org -> (orgSlug org, (org, mempty))) (view orgs config)
 
 -- | NOTE: this does not create the org if it does not yet exist!
-setJobStatus :: MVar ServerState -> Org True -> RemoteRef -> JobStatus -> IO ()
-setJobStatus mvar !org !ref !status = do
-  modifyMVar_ mvar $ \state -> do
+overJobStatus
+  :: MVar ServerState
+  -> Org True
+  -> RemoteRef
+  -> (Maybe (RemoteRef, JobStatus, Maybe JobStatus) ->
+      Maybe (RemoteRef, JobStatus, Maybe JobStatus))
+  -> IO (Maybe (RemoteRef, JobStatus, Maybe JobStatus))
+overJobStatus mvar !org !ref overState = do
+  modifyMVar mvar $ \state -> do
     -- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict
     -- even in its strict variety. for some reason it also doesn't work when
     -- moved inside the `over` though …
-    _ <- evaluateWHNF (view (unState . ix (orgSlug org) . _2) state)
-    pure $ over (unState . ix (orgSlug org) . _2 .  at (toSha ref))
-                (const $ Just (ref, status)) state
+    bla <- evaluateWHNF (view (unState . ix (orgSlug org) . _2) state)
+    let thing = state & (unState . ix (orgSlug org) . _2 .  at (toSha ref)) %~ overState
+    pure (thing, view (at (toSha ref)) bla)
 
-getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (Org True, RemoteRef, JobStatus))
+
+getJobStatus
+  :: MVar ServerState
+  -> Text
+  -> Sha1
+  -> IO (Maybe (Org True, RemoteRef, JobStatus, Maybe JobStatus))
 getJobStatus mvar orgslug sha = withMVar mvar $ \state -> pure $ do
   (org, jobs) <- view (unState . at orgslug) state
-  (ref, status) <- M.lookup sha jobs
-  Just (org, ref, status)
-    -- pure $ second (M.lookup sha) orgIndex
-  -- pure (M.lookup sha (view (unState . ix orgslug) state))
+  (ref, status, rev) <- M.lookup sha jobs
+  Just (org, ref, status, rev)
 
 
 -- | the path (relative to a baseurl / webdir) where an adjusted
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