summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2022-03-20 19:02:06 +0100
committerstuebinm2022-03-20 19:02:06 +0100
commitf72855ea8ade8f94474618c5dacda8dd30171740 (patch)
tree4f307cd839ade66250ef4e15128976320c2ae7e9
parent0032307c5868d56490ac1d968c986f8bab5a637b (diff)
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)
Diffstat (limited to '')
-rw-r--r--server/Handlers.hs14
-rw-r--r--server/HtmlOrphans.hs2
-rw-r--r--server/Server.hs39
-rw-r--r--server/Worker.hs50
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