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/Server.hs | 39 ++++++++++++++++++++++++---------------
 1 file changed, 24 insertions(+), 15 deletions(-)

(limited to 'server/Server.hs')

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