diff options
Diffstat (limited to 'src/Command')
| -rw-r--r-- | src/Command/Extract.hs | 99 | ||||
| -rw-r--r-- | src/Command/JobId.hs | 57 | ||||
| -rw-r--r-- | src/Command/Log.hs | 45 | ||||
| -rw-r--r-- | src/Command/Run.hs | 340 | ||||
| -rw-r--r-- | src/Command/Shell.hs | 46 | ||||
| -rw-r--r-- | src/Command/Subtree.hs | 47 |
6 files changed, 534 insertions, 100 deletions
diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs new file mode 100644 index 0000000..8dee537 --- /dev/null +++ b/src/Command/Extract.hs @@ -0,0 +1,99 @@ +module Command.Extract ( + ExtractCommand, +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class + +import Data.Text qualified as T + +import System.Console.GetOpt +import System.Directory +import System.FilePath + +import Command +import Eval +import Job +import Job.Types + + +data ExtractCommand = ExtractCommand ExtractOptions ExtractArguments + +data ExtractArguments = ExtractArguments + { extractArtifacts :: [ ( JobRef, ArtifactName ) ] + , extractDestination :: FilePath + } + +instance CommandArgumentsType ExtractArguments where + argsFromStrings = \case + args@(_:_:_) -> do + extractArtifacts <- mapM toArtifactRef (init args) + extractDestination <- return (last args) + return ExtractArguments {..} + where + toArtifactRef tref = case T.breakOnEnd "." (T.pack tref) of + (jobref', aref) | Just ( jobref, '.' ) <- T.unsnoc jobref' + -> return ( parseJobRef jobref, ArtifactName aref ) + _ -> throwError $ "too few parts in artifact ref ‘" <> tref <> "’" + _ -> throwError "too few arguments" + +data ExtractOptions = ExtractOptions + { extractForce :: Bool + } + +instance Command ExtractCommand where + commandName _ = "extract" + commandDescription _ = "Extract artifacts generated by jobs" + + type CommandArguments ExtractCommand = ExtractArguments + + commandUsage _ = T.pack $ unlines $ + [ "Usage: minici jobid [<option>...] <job ref>.<artifact>... <destination>" + ] + + type CommandOptions ExtractCommand = ExtractOptions + defaultCommandOptions _ = ExtractOptions + { extractForce = False + } + + commandOptions _ = + [ Option [ 'f' ] [ "force" ] + (NoArg $ \opts -> opts { extractForce = True }) + "owerwrite existing files" + ] + + commandInit _ = ExtractCommand + commandExec = cmdExtract + + +cmdExtract :: ExtractCommand -> CommandExec () +cmdExtract (ExtractCommand ExtractOptions {..} ExtractArguments {..}) = do + einput <- getEvalInput + storageDir <- getStorageDir + + isdir <- liftIO (doesDirectoryExist extractDestination) >>= \case + True -> return True + False -> case extractArtifacts of + _:_:_ -> tfail $ "destination ‘" <> T.pack extractDestination <> "’ is not a directory" + _ -> return False + + forM_ extractArtifacts $ \( ref, aname ) -> do + jid <- either (tfail . textEvalError) (return . jobId) =<< + liftIO (runEval (evalJobReference ref) einput) + + tpath <- if + | isdir -> do + wpath <- either tfail return =<< runExceptT (getArtifactWorkPath storageDir jid aname) + return $ extractDestination </> takeFileName wpath + | otherwise -> return extractDestination + + liftIO (doesPathExist tpath) >>= \case + True + | extractForce -> liftIO (doesDirectoryExist tpath) >>= \case + True -> liftIO $ removeDirectoryRecursive tpath + False -> liftIO $ removeFile tpath + | otherwise -> tfail $ "destination ‘" <> T.pack tpath <> "’ already exists" + False -> return () + + either tfail return =<< runExceptT (copyArtifact storageDir jid aname tpath) diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs index 9f531d6..3a119fa 100644 --- a/src/Command/JobId.hs +++ b/src/Command/JobId.hs @@ -2,18 +2,26 @@ module Command.JobId ( JobIdCommand, ) where +import Control.Monad import Control.Monad.IO.Class import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T + +import System.Console.GetOpt import Command import Eval import Job.Types +import Output +import Repo + +data JobIdCommand = JobIdCommand JobIdOptions JobRef -data JobIdCommand = JobIdCommand JobRef +data JobIdOptions = JobIdOptions + { joVerbose :: Bool + } instance Command JobIdCommand where commandName _ = "jobid" @@ -22,18 +30,49 @@ instance Command JobIdCommand where type CommandArguments JobIdCommand = Text commandUsage _ = T.pack $ unlines $ - [ "Usage: minici jobid <job ref>" + [ "Usage: minici jobid [<option>...] <job ref>" + ] + + type CommandOptions JobIdCommand = JobIdOptions + defaultCommandOptions _ = JobIdOptions + { joVerbose = False + } + + commandOptions _ = + [ Option [ 'v' ] [ "verbose" ] + (NoArg $ \opts -> opts { joVerbose = True }) + "show detals of the ID" ] - commandInit _ _ = JobIdCommand . JobRef . T.splitOn "." + commandInit _ opts = JobIdCommand opts . parseJobRef commandExec = cmdJobId cmdJobId :: JobIdCommand -> CommandExec () -cmdJobId (JobIdCommand ref) = do - config <- getConfig +cmdJobId (JobIdCommand JobIdOptions {..} ref) = do einput <- getEvalInput - JobId ids <- either (tfail . textEvalError) return =<< - liftIO (runEval (evalJobReference config ref) einput) + out <- getOutput + JobId ids <- either (tfail . textEvalError) (return . jobId) =<< + liftIO (runEval (evalJobReference ref) einput) - liftIO $ T.putStrLn $ T.intercalate "." $ map textJobIdPart ids + outputMessage out $ textJobId $ JobId ids + when joVerbose $ do + outputMessage out "" + forM_ ids $ \case + JobIdName name -> outputMessage out $ textJobName name <> " (job name)" + JobIdRepo mbrepo (JobIdCommit cid) -> outputMessage out $ T.concat + [ textCommitId cid, " (commit" + , maybe "" (\name -> " from ‘" <> textRepoName name <> "’ repo") mbrepo + , ")" + ] + JobIdRepo mbrepo (JobIdTree subtree cid) -> outputMessage out $ T.concat + [ textTreeId cid, " (tree" + , maybe "" (\name -> " from ‘" <> textRepoName name <> "’ repo") mbrepo + , if not (null subtree) then ", subtree ‘" <> T.pack subtree <> "’" else "" + , ")" + ] + JobIdRepo mbrepo (JobIdTag cid tid) -> outputMessage out $ T.concat + [ textCommitId cid, "^", textTagId tid, " (commit following tag" + , maybe "" (\name -> " from ‘" <> textRepoName name <> "’ repo") mbrepo + , ")" + ] diff --git a/src/Command/Log.hs b/src/Command/Log.hs new file mode 100644 index 0000000..25bfc06 --- /dev/null +++ b/src/Command/Log.hs @@ -0,0 +1,45 @@ +module Command.Log ( + LogCommand, +) where + +import Control.Monad.IO.Class + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.IO qualified as TL + +import System.FilePath + +import Command +import Eval +import Job +import Job.Types +import Output + + +data LogCommand = LogCommand JobRef + +instance Command LogCommand where + commandName _ = "log" + commandDescription _ = "Show log for the given job" + + type CommandArguments LogCommand = Text + + commandUsage _ = T.pack $ unlines $ + [ "Usage: minici log <job ref>" + ] + + commandInit _ _ = LogCommand . parseJobRef + commandExec = cmdLog + + +cmdLog :: LogCommand -> CommandExec () +cmdLog (LogCommand ref) = do + einput <- getEvalInput + jid <- either (tfail . textEvalError) (return . jobId) =<< + liftIO (runEval (evalJobReference ref) einput) + output <- getOutput + storageDir <- getStorageDir + liftIO $ mapM_ (outputEvent output . OutputMessage . TL.toStrict) . TL.lines =<< + TL.readFile (storageDir </> jobStorageSubdir jid </> "log") diff --git a/src/Command/Run.hs b/src/Command/Run.hs index 905204e..ccd4bfa 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -8,20 +8,23 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class -import Data.Either +import Data.Char +import Data.Containers.ListUtils import Data.List +import Data.Maybe import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T import System.Console.GetOpt import System.FilePath.Glob -import System.IO import Command import Config import Eval +import Expression import Job +import Job.Types +import Output import Repo import Terminal @@ -29,12 +32,19 @@ import Terminal data RunCommand = RunCommand RunOptions [ Text ] data RunOptions = RunOptions - { roRanges :: [ Text ] + { roRerun :: RerunOption + , roRanges :: [ Text ] , roSinceUpstream :: [ Text ] , roNewCommitsOn :: [ Text ] , roNewTags :: [ Pattern ] } +data RerunOption + = RerunExplicit + | RerunFailed + | RerunAll + | RerunNone + instance Command RunCommand where commandName _ = "run" commandDescription _ = "Execude jobs per minici.yaml for given commits" @@ -54,14 +64,27 @@ instance Command RunCommand where type CommandOptions RunCommand = RunOptions defaultCommandOptions _ = RunOptions - { roRanges = [] + { roRerun = RerunExplicit + , roRanges = [] , roSinceUpstream = [] , roNewCommitsOn = [] , roNewTags = [] } commandOptions _ = - [ Option [] [ "range" ] + [ Option [] [ "rerun-explicit" ] + (NoArg (\opts -> opts { roRerun = RerunExplicit })) + "rerun jobs given explicitly on command line and their failed dependencies (default)" + , Option [] [ "rerun-failed" ] + (NoArg (\opts -> opts { roRerun = RerunFailed })) + "rerun failed jobs only" + , Option [] [ "rerun-all" ] + (NoArg (\opts -> opts { roRerun = RerunAll })) + "rerun all jobs" + , Option [] [ "rerun-none" ] + (NoArg (\opts -> opts { roRerun = RerunNone })) + "do not rerun any job" + , Option [] [ "range" ] (ReqArg (\val opts -> opts { roRanges = T.pack val : roRanges opts }) "<range>") "run jobs for commits in given range" , Option [] [ "since-upstream" ] @@ -79,7 +102,12 @@ instance Command RunCommand where commandExec = cmdRun -data JobSource = JobSource (TMVar (Maybe ( [ JobSet ], JobSource ))) +data JobSource = JobSource (TMVar (Maybe ( [ JobSourceItem ], JobSource ))) + +data JobSourceItem = JobSourceItem + { jsiJobSet :: JobSet + , jsiCancelAction :: Maybe (MVar (IO ())) + } emptyJobSource :: MonadIO m => m JobSource emptyJobSource = JobSource <$> liftIO (newTMVarIO Nothing) @@ -87,9 +115,9 @@ emptyJobSource = JobSource <$> liftIO (newTMVarIO Nothing) oneshotJobSource :: MonadIO m => [ JobSet ] -> m JobSource oneshotJobSource jobsets = do next <- emptyJobSource - JobSource <$> liftIO (newTMVarIO (Just ( jobsets, next ))) + JobSource <$> liftIO (newTMVarIO (Just ( map (`JobSourceItem` Nothing) jobsets, next ))) -takeJobSource :: JobSource -> STM (Maybe ( [ JobSet ], JobSource )) +takeJobSource :: JobSource -> STM (Maybe ( [ JobSourceItem ], JobSource )) takeJobSource (JobSource tmvar) = takeTMVar tmvar mergeSources :: [ JobSource ] -> IO JobSource @@ -111,7 +139,7 @@ mergeSources sources = do return $ JobSource tmvar where - select :: [ JobSource ] -> STM ( [ JobSet ], [ JobSource ] ) + select :: [ JobSource ] -> STM ( [ JobSourceItem ], [ JobSource ] ) select [] = retry select (x@(JobSource tmvar) : xs) = do tryTakeTMVar tmvar >>= \case @@ -123,63 +151,144 @@ mergeSources sources = do argumentJobSource :: [ JobName ] -> CommandExec JobSource argumentJobSource [] = emptyJobSource argumentJobSource names = do - config <- getConfig - einput <- getEvalInput - jobsetJobsEither <- fmap Right $ forM names $ \name -> + jobRoot <- getJobRoot + ( config, jcommit ) <- case jobRoot of + 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 = case jobRoot of + JobRootConfig {} -> [] + JobRootRepo {} -> map (JobIdRepo Nothing . JobIdTree "" . 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 + evalJobSetSelected names (map (( Nothing , ) . RepoRefTree) jobtree) JobSet + { jobsetId = () + , jobsetConfig = Just config + , jobsetCommit = jcommit + , jobsetExplicitlyRequested = names + , jobsetJobsEither = Right (configJobs config) + } + oneshotJobSource [ jset ] + +refJobSource :: [ JobRef ] -> CommandExec JobSource +refJobSource [] = emptyJobSource +refJobSource refs = do + sets <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReferenceToSet refs) + oneshotJobSource sets + where + addJobToList :: [ JobSet ] -> JobSet -> [ JobSet ] + addJobToList (cur : rest) jset + | jobsetId cur == jobsetId jset = cur { jobsetJobsEither = fmap (nubOrdOn jobId) $ (++) <$> (jobsetJobsEither cur) <*> (jobsetJobsEither jset) + , jobsetExplicitlyRequested = nubOrd $ jobsetExplicitlyRequested cur ++ jobsetExplicitlyRequested jset + } : rest + | otherwise = cur : addJobToList rest jset + addJobToList [] jset = [ jset ] + +loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet +loadJobSetFromRoot root commit = case root of + JobRootRepo _ -> loadJobSetForCommit commit + JobRootConfig config -> return JobSet + { jobsetId = () + , jobsetConfig = Just config + , jobsetCommit = Just commit + , jobsetExplicitlyRequested = [] + , 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 = JobIdRepo Nothing (JobIdTree (treeSubdir tree) (treeId tree)) : eiCurrentIdRev ei + }) . evalJobSet [ ( Nothing, RepoRefTree tree ) ] =<< loadJobSetFromRoot root commit + oneshotJobSource jobsets -watchBranchSource :: Text -> CommandExec JobSource -watchBranchSource branch = do + +watchExpressionSource :: RangeExpression -> CommandExec JobSource +watchExpressionSource expr = do + root <- getJobRoot repo <- getDefaultRepo - einput <- getEvalInput - getCurrentTip <- watchBranch repo branch - let go prev tmvar = do + einputBase <- getEvalInput + let loop = isRangeExpressionDynamic expr + let go running prev tmvar = do cur <- atomically $ do - getCurrentTip >>= \case - Just cur -> do - when (cur == prev) retry - return cur - Nothing -> retry - - commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur)) - jobsets <- map (evalJobSet einput) <$> mapM loadJobSetForCommit commits + cur <- evaluateRange expr + when (cur == prev) retry + return cur + + commits <- getAddedRangeCommits repo prev cur + jobsets <- forM commits $ \commit -> do + tree <- getCommitTree commit + let einput = einputBase + { eiCurrentIdRev = JobIdRepo Nothing (JobIdTree (treeSubdir tree) (treeId tree)) : eiCurrentIdRev einputBase + } + jsiJobSet <- either (fail . T.unpack . textEvalError) return =<< + flip runEval einput . evalJobSet [ ( Nothing, RepoRefTree tree ) ] =<< loadJobSetFromRoot root commit + jsiCancelAction <- Just <$> newEmptyMVar + return JobSourceItem {..} + + obsolete <- getAddedRangeCommits repo cur prev + obsoleteIds <- forM obsolete $ \commit -> do + tree <- getCommitTree commit + return $ JobSetId $ JobIdRepo Nothing (JobIdTree (treeSubdir tree) (treeId tree)) : eiCurrentIdRev einputBase + + let ( cancel, keep ) = span ((`elem` obsoleteIds) . jobsetId . jsiJobSet) running + mapM_ (mapM_ (join . readMVar) . jsiCancelAction) cancel + nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar ) - go cur nextvar + if loop + then do + go (reverse jobsets ++ keep) cur nextvar + else do + atomically $ putTMVar nextvar Nothing liftIO $ do tmvar <- newEmptyTMVarIO - atomically getCurrentTip >>= \case - Just commit -> - void $ forkIO $ go commit tmvar - Nothing -> do - T.hPutStrLn stderr $ "Branch `" <> branch <> "' not found" - atomically $ putTMVar tmvar Nothing + void $ forkIO $ go [] EmptyCommitRange tmvar return $ JobSource tmvar +watchBranchSource :: Text -> CommandExec JobSource +watchBranchSource branch = do + repo <- getDefaultRepo + expr <- evaluateDeclaredRange repo $ RangeExpression (WatchedRef branch) (StaticRef branch) + watchExpressionSource expr + 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 = JobIdRepo Nothing (JobIdTree (treeSubdir tree) (treeId tree)) : eiCurrentIdRev einputBase + } + jsiJobSet <- either (fail . T.unpack . textEvalError) return =<< + flip runEval einput . evalJobSet [ ( Nothing, RepoRefTree tree ) ] =<< loadJobSetFromRoot root (tagObject tag) + let jsiCancelAction = Nothing nextvar <- newEmptyTMVarIO - atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar ) + atomically $ putTMVar tmvar $ Just ( [ JobSourceItem {..} ], JobSource nextvar ) go nextvar else do go tmvar @@ -192,33 +301,44 @@ watchTagSource pat = do cmdRun :: RunCommand -> CommandExec () cmdRun (RunCommand RunOptions {..} args) = do CommonOptions {..} <- getCommonOptions - tout <- getTerminalOutput + output <- getOutput storageDir <- getStorageDir - ( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence + rangeOptions <- 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 ( 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 ) - _ -> tfail $ "invalid argument: " <> arg + , forM roSinceUpstream $ return . ( Nothing, ) ] - argumentJobs <- argumentJobSource jobOptions + let ( nameOptions, jobOptions ) = partition (T.all $ \c -> isAlphaNum c || c == '_') args + ( refOptions, exprOptions ) = partition (\r -> "." `T.isInfixOf` r && not (".." `T.isInfixOf` r)) 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 + exprJobs <- forM exprOptions $ \trange -> + case parseRangeExpression trange of + Left err -> fail err + Right expr -> do + repo <- getDefaultRepo + range <- evaluateDeclaredRange repo expr + watchExpressionSource range - ranges <- forM rangeOptions' $ \( mbBase, paramTip ) -> do + defaultSource <- getJobRoot >>= \case + _ | not (null rangeOptions && null roNewCommitsOn && null roNewTags && null args) -> do + emptyJobSource + + 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,49 +352,76 @@ 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 ], exprJobs, ranges, branches, tags ] + mbHeaderLine <- mapM (flip newLine "") (outputTerminal output) threadCount <- newTVarIO (0 :: Int) let changeCount f = atomically $ do writeTVar threadCount . f =<< readTVar threadCount - let waitForJobs = atomically $ do - flip when retry . (0 <) =<< readTVar threadCount + let waitForJobs = do + atomically $ do + flip when retry . (0 <) =<< readTVar threadCount + waitForRemainingTasks mngr let loop _ Nothing = return () loop names (Just ( [], next )) = do loop names =<< atomically (takeJobSource next) - loop pnames (Just ( jobset : rest, next )) = do - let names = nub $ (pnames ++) $ map jobName $ jobsetJobs jobset + loop pnames (Just ( JobSourceItem {..} : rest, next )) = do + let names = nub $ (pnames ++) $ map jobName $ jobsetJobs jsiJobSet 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 + let commit = jobsetCommit jsiJobSet shortCid = T.pack $ take 7 $ maybe (repeat ' ') (showCommitId . commitId) commit shortDesc <- fitToLength 50 <$> maybe (return "") getCommitTitle commit - case jobsetJobsEither jobset of + case jobsetJobsEither jsiJobSet of Right jobs -> do - outs <- runJobs mngr tout commit jobs - let findJob name = snd <$> find ((name ==) . jobName . fst) outs - line <- newLine tout "" + tasks <- runJobs mngr output jobs $ case roRerun of + RerunExplicit -> \jid status -> jid `elem` jobsetExplicitlyRequested jsiJobSet || jobStatusFailed status + RerunFailed -> \_ status -> jobStatusFailed status + RerunAll -> \_ _ -> True + RerunNone -> \_ _ -> False + let findJob name = taskStatus <$> find ((name ==) . jobName . taskJob) tasks + 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) + case jsiCancelAction of + Just var -> putMVar var $ mapM_ cancelTask tasks + Nothing -> return () Left err -> do - void $ newLine tout $ + case jsiCancelAction of + Just var -> putMVar var $ return () + Nothing -> return () + 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 + handle @SomeException + (\e -> do + if | Just UserInterrupt <- fromException e + -> outputEvent output RunInterruptedByUser + | otherwise + -> outputMessage output $ "exception in run loop: " <> T.pack (show e) + cancelAllJobs mngr + ) $ do loop [] =<< atomically (takeJobSource source) waitForJobs waitForJobs + outputEvent output $ TestMessage "run-finish" fitToLength :: Int -> Text -> Text @@ -284,22 +431,26 @@ fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " " showStatus :: Bool -> JobStatus a -> Text showStatus blink = \case - JobQueued -> "\ESC[94m…\ESC[0m " + JobQueued -> " \ESC[94m…\ESC[0m " 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" - JobFailed -> "\ESC[91m✗\ESC[0m " - JobCancelled -> "\ESC[0mC\ESC[0m " - JobDone _ -> "\ESC[92m✓\ESC[0m " + JobSkipped -> " \ESC[0m-\ESC[0m " + JobRunning -> " \ESC[96m" <> (if blink then "*" else "•") <> "\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 " JobDuplicate _ s -> case s of - JobQueued -> "\ESC[94m^\ESC[0m " - JobWaiting _ -> "\ESC[94m^\ESC[0m " - JobSkipped -> "\ESC[0m-\ESC[0m " - JobRunning -> "\ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m " + JobQueued -> " \ESC[94m^\ESC[0m " + JobWaiting _ -> " \ESC[94m^\ESC[0m " + JobSkipped -> " \ESC[0m-\ESC[0m " + JobRunning -> " \ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m " _ -> showStatus blink s + JobPreviousStatus (JobDone _) -> "\ESC[90m«\ESC[32m✓\ESC[0m " + JobPreviousStatus (JobFailed) -> "\ESC[90m«\ESC[31m✗\ESC[0m " + JobPreviousStatus s -> "\ESC[90m«" <> T.init (showStatus blink s) + displayStatusLine :: TerminalOutput -> TerminalLine -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO () displayStatusLine tout line prefix1 prefix2 statuses = do go "\0" @@ -320,3 +471,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 diff --git a/src/Command/Shell.hs b/src/Command/Shell.hs new file mode 100644 index 0000000..16f366e --- /dev/null +++ b/src/Command/Shell.hs @@ -0,0 +1,46 @@ +module Command.Shell ( + ShellCommand, +) where + +import Control.Monad +import Control.Monad.IO.Class + +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as T + +import System.Environment +import System.Process hiding (ShellCommand) + +import Command +import Eval +import Job +import Job.Types + + +data ShellCommand = ShellCommand JobRef + +instance Command ShellCommand where + commandName _ = "shell" + commandDescription _ = "Open a shell prepared for given job" + + type CommandArguments ShellCommand = Text + + commandUsage _ = T.unlines $ + [ "Usage: minici shell <job ref>" + ] + + commandInit _ _ = ShellCommand . parseJobRef + commandExec = cmdShell + + +cmdShell :: ShellCommand -> CommandExec () +cmdShell (ShellCommand ref) = do + einput <- getEvalInput + job <- either (tfail . textEvalError) return =<< + liftIO (runEval (evalJobReference ref) einput) + sh <- fromMaybe "/bin/sh" <$> liftIO (lookupEnv "SHELL") + storageDir <- getStorageDir + prepareJob storageDir job $ \checkoutPath -> do + liftIO $ withCreateProcess (proc sh []) { cwd = Just checkoutPath } $ \_ _ _ ph -> do + void $ waitForProcess ph diff --git a/src/Command/Subtree.hs b/src/Command/Subtree.hs new file mode 100644 index 0000000..15cb2db --- /dev/null +++ b/src/Command/Subtree.hs @@ -0,0 +1,47 @@ +module Command.Subtree ( + SubtreeCommand, +) where + +import Data.Text (Text) +import Data.Text qualified as T + +import Command +import Output +import Repo + + +data SubtreeCommand = SubtreeCommand SubtreeOptions [ Text ] + +data SubtreeOptions = SubtreeOptions + +instance Command SubtreeCommand where + commandName _ = "subtree" + commandDescription _ = "Resolve subdirectory of given repo tree" + + type CommandArguments SubtreeCommand = [ Text ] + + commandUsage _ = T.pack $ unlines $ + [ "Usage: minici subtree <tree> <path>" + ] + + type CommandOptions SubtreeCommand = SubtreeOptions + defaultCommandOptions _ = SubtreeOptions + + commandInit _ opts = SubtreeCommand opts + commandExec = cmdSubtree + + +cmdSubtree :: SubtreeCommand -> CommandExec () +cmdSubtree (SubtreeCommand SubtreeOptions args) = do + [ treeParam, path ] <- return args + out <- getOutput + repo <- getDefaultRepo + + let ( tree, subdir ) = + case T.splitOn "(" treeParam of + (t : param : _) -> ( t, T.unpack $ T.takeWhile (/= ')') param ) + _ -> ( treeParam, "" ) + + subtree <- getSubtree Nothing (T.unpack path) =<< readTree repo subdir tree + outputMessage out $ textTreeId $ treeId subtree + outputEvent out $ TestMessage $ "path " <> T.pack (treeSubdir subtree) |