diff options
Diffstat (limited to 'src/Command')
| -rw-r--r-- | src/Command/Extract.hs | 101 | ||||
| -rw-r--r-- | src/Command/JobId.hs | 54 | ||||
| -rw-r--r-- | src/Command/Log.hs | 47 | ||||
| -rw-r--r-- | src/Command/Run.hs | 237 | ||||
| -rw-r--r-- | src/Command/Shell.hs | 48 | ||||
| -rw-r--r-- | src/Command/Subtree.hs | 47 |
6 files changed, 469 insertions, 65 deletions
diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs new file mode 100644 index 0000000..366128c --- /dev/null +++ b/src/Command/Extract.hs @@ -0,0 +1,101 @@ +module Command.Extract ( + ExtractCommand, +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class + +import Data.Bifunctor +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 (return . map jobId) =<< + return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< + 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..b349ebe 100644 --- a/src/Command/JobId.hs +++ b/src/Command/JobId.hs @@ -2,18 +2,27 @@ module Command.JobId ( JobIdCommand, ) where +import Control.Monad import Control.Monad.IO.Class +import Data.Bifunctor 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 +31,45 @@ 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 (return . map jobId) =<< + return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< + 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)" + JobIdCommit mbrepo cid -> outputMessage out $ T.concat + [ textCommitId cid, " (commit" + , maybe "" (\name -> " from ‘" <> textRepoName name <> "’ repo") mbrepo + , ")" + ] + JobIdTree mbrepo 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 "" + , ")" + ] diff --git a/src/Command/Log.hs b/src/Command/Log.hs new file mode 100644 index 0000000..438c25e --- /dev/null +++ b/src/Command/Log.hs @@ -0,0 +1,47 @@ +module Command.Log ( + LogCommand, +) where + +import Control.Monad.IO.Class + +import Data.Bifunctor +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 (return . map jobId) =<< + return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< + 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..982a07a 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 @@ -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" ] @@ -123,26 +146,83 @@ 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 (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 = () + , jobsetConfig = Just config + , jobsetCommit = jcommit + , jobsetExplicitlyRequested = names + , 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 + jsets <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReference refs) + sets <- cmdEvalWith id $ do + forM jsets $ \jset -> do + fillInDependencies $ jset { jobsetExplicitlyRequested = either (const []) (map jobId) $ jobsetJobsEither jset } + oneshotJobSource sets + where + addJobToList :: [ JobSet ] -> JobSet -> [ JobSet ] + addJobToList (cur : rest) jset + | jobsetId cur == jobsetId jset = cur { jobsetJobsEither = (++) <$> (fmap reverse $ jobsetJobsEither jset) <*> (jobsetJobsEither cur) } : 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 = 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 +233,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 +250,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 +284,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,14 +332,16 @@ 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 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 @@ -248,9 +350,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 +361,34 @@ cmdRun (RunCommand RunOptions {..} args) = do case jobsetJobsEither jobset of Right jobs -> do - outs <- runJobs mngr tout commit jobs + outs <- runJobs mngr output jobs $ case roRerun of + RerunExplicit -> \jid status -> jid `elem` jobsetExplicitlyRequested jobset || jobStatusFailed status + RerunFailed -> \_ status -> jobStatusFailed status + RerunAll -> \_ _ -> True + RerunNone -> \_ _ -> False 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 @@ -284,22 +398,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 +438,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..dfff50a --- /dev/null +++ b/src/Command/Shell.hs @@ -0,0 +1,48 @@ +module Command.Shell ( + ShellCommand, +) where + +import Control.Monad +import Control.Monad.IO.Class + +import Data.Bifunctor +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 return =<< + return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< + 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) |