diff options
Diffstat (limited to '')
| -rw-r--r-- | server/Server.hs | 39 |
1 files changed, 24 insertions, 15 deletions
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 |