diff options
Diffstat (limited to '')
| -rw-r--r-- | server/Handlers.hs | 14 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs | 2 | ||||
| -rw-r--r-- | server/Server.hs | 39 | ||||
| -rw-r--r-- | server/Worker.hs | 50 |
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 |