diff options
Diffstat (limited to 'src/Command/Run.hs')
| -rw-r--r-- | src/Command/Run.hs | 170 |
1 files changed, 129 insertions, 41 deletions
diff --git a/src/Command/Run.hs b/src/Command/Run.hs index 905204e..a80e15d 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -10,6 +10,7 @@ import Control.Monad.IO.Class import Data.Either import Data.List +import Data.Maybe import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T @@ -22,6 +23,8 @@ import Command import Config import Eval import Job +import Job.Types +import Output import Repo import Terminal @@ -123,26 +126,76 @@ mergeSources sources = do argumentJobSource :: [ JobName ] -> CommandExec JobSource argumentJobSource [] = emptyJobSource argumentJobSource names = do - config <- getConfig - einput <- getEvalInput - jobsetJobsEither <- fmap Right $ forM names $ \name -> + ( config, jcommit ) <- getJobRoot >>= \case + JobRootConfig config -> do + commit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo + return ( config, commit ) + JobRootRepo repo -> do + commit <- createWipCommit repo + config <- either fail return =<< loadConfigForCommit =<< getCommitTree commit + return ( config, Just commit ) + + jobtree <- case jcommit of + Just commit -> (: []) <$> getCommitTree commit + Nothing -> return [] + let cidPart = map (JobIdTree Nothing "" . treeId) jobtree + forM_ names $ \name -> case find ((name ==) . jobName) (configJobs config) of - Just job -> return job - Nothing -> tfail $ "job `" <> textJobName name <> "' not found" - jobsetCommit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo - oneshotJobSource [ evalJobSet einput JobSet {..} ] + Just _ -> return () + Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found" + + jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do + fullSet <- evalJobSet (map ( Nothing, ) jobtree) JobSet + { jobsetId = () + , jobsetCommit = jcommit + , jobsetJobsEither = Right (configJobs config) + } + let selectedSet = fullSet { jobsetJobsEither = fmap (filter ((`elem` names) . jobName)) (jobsetJobsEither fullSet) } + fillInDependencies selectedSet + oneshotJobSource [ jset ] + +refJobSource :: [ JobRef ] -> CommandExec JobSource +refJobSource [] = emptyJobSource +refJobSource refs = do + jobs <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReference refs) + sets <- cmdEvalWith id $ do + forM jobs $ \( sid, js ) -> do + fillInDependencies $ JobSet sid Nothing (Right $ reverse js) + oneshotJobSource sets + where + addJobToList :: [ ( JobSetId, [ Job ] ) ] -> ( Job, JobSetId ) -> [ ( JobSetId, [ Job ] ) ] + addJobToList (( sid, js ) : rest ) ( job, jsid ) + | sid == jsid = ( sid, job : js ) : rest + | otherwise = ( sid, js ) : addJobToList rest ( job, jsid ) + addJobToList [] ( job, jsid ) = [ ( jsid, [ job ] ) ] + +loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet +loadJobSetFromRoot root commit = case root of + JobRootRepo _ -> loadJobSetForCommit commit + JobRootConfig config -> return JobSet + { jobsetId = () + , jobsetCommit = Just commit + , jobsetJobsEither = Right $ configJobs config + } rangeSource :: Text -> Text -> CommandExec JobSource rangeSource base tip = do + root <- getJobRoot repo <- getDefaultRepo - einput <- getEvalInput commits <- listCommits repo (base <> ".." <> tip) - oneshotJobSource . map (evalJobSet einput) =<< mapM loadJobSetForCommit commits + jobsets <- forM commits $ \commit -> do + tree <- getCommitTree commit + cmdEvalWith (\ei -> ei + { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev ei + }) . evalJobSet [ ( Nothing, tree) ] =<< loadJobSetFromRoot root commit + oneshotJobSource jobsets + watchBranchSource :: Text -> CommandExec JobSource watchBranchSource branch = do + root <- getJobRoot repo <- getDefaultRepo - einput <- getEvalInput + einputBase <- getEvalInput getCurrentTip <- watchBranch repo branch let go prev tmvar = do cur <- atomically $ do @@ -153,7 +206,13 @@ watchBranchSource branch = do Nothing -> retry commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur)) - jobsets <- map (evalJobSet einput) <$> mapM loadJobSetForCommit commits + jobsets <- forM commits $ \commit -> do + tree <- getCommitTree commit + let einput = einputBase + { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase + } + either (fail . T.unpack . textEvalError) return =<< + flip runEval einput . evalJobSet [ ( Nothing, tree ) ] =<< loadJobSetFromRoot root commit nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar ) go cur nextvar @@ -164,20 +223,26 @@ watchBranchSource branch = do Just commit -> void $ forkIO $ go commit tmvar Nothing -> do - T.hPutStrLn stderr $ "Branch `" <> branch <> "' not found" + T.hPutStrLn stderr $ "Branch ‘" <> branch <> "’ not found" atomically $ putTMVar tmvar Nothing return $ JobSource tmvar watchTagSource :: Pattern -> CommandExec JobSource watchTagSource pat = do + root <- getJobRoot chan <- watchTags =<< getDefaultRepo - einput <- getEvalInput + einputBase <- getEvalInput let go tmvar = do tag <- atomically $ readTChan chan if match pat $ T.unpack $ tagTag tag then do - jobset <- evalJobSet einput <$> loadJobSetForCommit (tagObject tag) + tree <- getCommitTree $ tagObject tag + let einput = einputBase + { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase + } + jobset <- either (fail . T.unpack . textEvalError) return =<< + flip runEval einput . evalJobSet [ ( Nothing, tree ) ] =<< loadJobSetFromRoot root (tagObject tag) nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar ) go nextvar @@ -192,33 +257,41 @@ watchTagSource pat = do cmdRun :: RunCommand -> CommandExec () cmdRun (RunCommand RunOptions {..} args) = do CommonOptions {..} <- getCommonOptions - tout <- getTerminalOutput + output <- getOutput storageDir <- getStorageDir ( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence [ forM roRanges $ \range -> case T.splitOn ".." range of - [ base, tip ] -> return $ Left ( Just base, tip ) + [ base, tip ] + | not (T.null base) && not (T.null tip) + -> return $ Left ( Just base, tip ) _ -> tfail $ "invalid range: " <> range , forM roSinceUpstream $ return . Left . ( Nothing, ) , forM args $ \arg -> case T.splitOn ".." arg of - [ base, tip ] -> return $ Left ( Just base, tip ) - [ _ ] -> do - config <- getConfig - if any ((JobName arg ==) . jobName) (configJobs config) - then return $ Right $ JobName arg - else do - liftIO $ T.hPutStrLn stderr $ "standalone `" <> arg <> "' argument deprecated, use `--since-upstream=" <> arg <> "' instead" - return $ Left ( Nothing, arg ) + [ base, tip ] + | not (T.null base) && not (T.null tip) + -> return $ Left ( Just base, tip ) + [ _ ] -> return $ Right arg _ -> tfail $ "invalid argument: " <> arg ] - argumentJobs <- argumentJobSource jobOptions + let ( refOptions, nameOptions ) = partition (T.elem '.') jobOptions + + argumentJobs <- argumentJobSource $ map JobName nameOptions + refJobs <- refJobSource $ map parseJobRef refOptions - let rangeOptions' - | null rangeOptions, null roNewCommitsOn, null roNewTags, null jobOptions = [ ( Nothing, "HEAD" ) ] - | otherwise = rangeOptions + defaultSource <- getJobRoot >>= \case + _ | not (null rangeOptions && null roNewCommitsOn && null roNewTags && null jobOptions) -> do + emptyJobSource - ranges <- forM rangeOptions' $ \( mbBase, paramTip ) -> do + JobRootRepo repo -> do + Just base <- findUpstreamRef repo "HEAD" + rangeSource base "HEAD" + + JobRootConfig config -> do + argumentJobSource (jobName <$> configJobs config) + + ranges <- forM rangeOptions $ \( mbBase, paramTip ) -> do ( base, tip ) <- case mbBase of Just base -> return ( base, paramTip ) Nothing -> do @@ -232,8 +305,8 @@ cmdRun (RunCommand RunOptions {..} args) = do liftIO $ do mngr <- newJobManager storageDir optJobs - source <- mergeSources $ concat [ [ argumentJobs ], ranges, branches, tags ] - headerLine <- newLine tout "" + source <- mergeSources $ concat [ [ defaultSource, argumentJobs, refJobs ], ranges, branches, tags ] + mbHeaderLine <- mapM (flip newLine "") (outputTerminal output) threadCount <- newTVarIO (0 :: Int) let changeCount f = atomically $ do @@ -248,9 +321,10 @@ cmdRun (RunCommand RunOptions {..} args) = do loop pnames (Just ( jobset : rest, next )) = do let names = nub $ (pnames ++) $ map jobName $ jobsetJobs jobset when (names /= pnames) $ do - redrawLine headerLine $ T.concat $ - T.replicate (8 + 50) " " : - map ((" " <>) . fitToLength 7 . textJobName) names + forM_ mbHeaderLine $ \headerLine -> do + redrawLine headerLine $ T.concat $ + T.replicate (8 + 50) " " : + map ((" " <>) . fitToLength 7 . textJobName) names let commit = jobsetCommit jobset shortCid = T.pack $ take 7 $ maybe (repeat ' ') (showCommitId . commitId) commit @@ -258,23 +332,30 @@ cmdRun (RunCommand RunOptions {..} args) = do case jobsetJobsEither jobset of Right jobs -> do - outs <- runJobs mngr tout commit jobs + outs <- runJobs mngr output jobs let findJob name = snd <$> find ((name ==) . jobName . fst) outs - line <- newLine tout "" + statuses = map findJob names + forM_ (outputTerminal output) $ \tout -> do + line <- newLine tout "" + void $ forkIO $ do + displayStatusLine tout line shortCid (" " <> shortDesc) statuses mask $ \restore -> do changeCount (+ 1) - void $ forkIO $ (>> changeCount (subtract 1)) $ - try @SomeException $ restore $ do - displayStatusLine tout line shortCid (" " <> shortDesc) $ map findJob names + void $ forkIO $ do + void $ try @SomeException $ restore $ waitForJobStatuses statuses + changeCount (subtract 1) Left err -> do - void $ newLine tout $ + forM_ (outputTerminal output) $ flip newLine $ "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m" + outputEvent output $ TestMessage $ "jobset-fail " <> T.pack err + outputEvent output $ LogMessage $ "Jobset failed: " <> shortCid <> " " <> T.pack err loop names (Just ( rest, next )) handle @SomeException (\_ -> cancelAllJobs mngr) $ do loop [] =<< atomically (takeJobSource source) waitForJobs waitForJobs + outputEvent output $ TestMessage "run-finish" fitToLength :: Int -> Text -> Text @@ -288,7 +369,7 @@ showStatus blink = \case JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m" JobSkipped -> "\ESC[0m-\ESC[0m " JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m " - JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (show (footnoteNumber fnote)) <> "]") <> "\ESC[0m" + JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (maybe "?" (show . tfNumber) (footnoteTerminal fnote)) <> "]") <> "\ESC[0m" JobFailed -> "\ESC[91m✗\ESC[0m " JobCancelled -> "\ESC[0mC\ESC[0m " JobDone _ -> "\ESC[92m✓\ESC[0m " @@ -320,3 +401,10 @@ displayStatusLine tout line prefix1 prefix2 statuses = do if all (maybe True jobStatusFinished) ss then return () else go cur + +waitForJobStatuses :: [ Maybe (TVar (JobStatus a)) ] -> IO () +waitForJobStatuses mbstatuses = do + let statuses = catMaybes mbstatuses + atomically $ do + ss <- mapM readTVar statuses + when (any (not . jobStatusFinished) ss) retry |