summaryrefslogtreecommitdiff
path: root/src/Command
diff options
context:
space:
mode:
Diffstat (limited to 'src/Command')
-rw-r--r--src/Command/Extract.hs43
-rw-r--r--src/Command/Run.hs106
-rw-r--r--src/Command/Shell.hs46
-rw-r--r--src/Command/Subtree.hs47
4 files changed, 190 insertions, 52 deletions
diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs
index 8a0a035..8dee537 100644
--- a/src/Command/Extract.hs
+++ b/src/Command/Extract.hs
@@ -14,6 +14,7 @@ import System.FilePath
import Command
import Eval
+import Job
import Job.Types
@@ -77,30 +78,22 @@ cmdExtract (ExtractCommand ExtractOptions {..} ExtractArguments {..}) = do
_:_:_ -> tfail $ "destination ‘" <> T.pack extractDestination <> "’ is not a directory"
_ -> return False
- forM_ extractArtifacts $ \( ref, ArtifactName aname ) -> do
- jid@(JobId ids) <- either (tfail . textEvalError) (return . jobId) =<<
+ forM_ extractArtifacts $ \( ref, aname ) -> do
+ jid <- either (tfail . textEvalError) (return . jobId) =<<
liftIO (runEval (evalJobReference ref) einput)
- let jdir = joinPath $ (storageDir :) $ ("jobs" :) $ map (T.unpack . textJobIdPart) ids
- adir = jdir </> "artifacts" </> T.unpack aname
-
- liftIO (doesDirectoryExist jdir) >>= \case
- True -> return ()
- False -> tfail $ "job ‘" <> textJobId jid <> "’ not yet executed"
-
- liftIO (doesDirectoryExist adir) >>= \case
- True -> return ()
- False -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
-
- afile <- liftIO (listDirectory adir) >>= \case
- [ file ] -> return file
- [] -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
- _:_:_ -> tfail $ "unexpected files in ‘" <> T.pack adir <> "’"
-
- let tpath | isdir = extractDestination </> afile
- | otherwise = extractDestination
- when (not extractForce) $ do
- liftIO (doesPathExist tpath) >>= \case
- True -> tfail $ "destination ‘" <> T.pack tpath <> "’ already exists"
- False -> return ()
- liftIO $ copyFile (adir </> afile) tpath
+ 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/Run.hs b/src/Command/Run.hs
index 9652529..b299931 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -8,6 +8,7 @@ import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
+import Data.Containers.ListUtils
import Data.Either
import Data.List
import Data.Maybe
@@ -32,12 +33,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"
@@ -57,14 +65,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" ]
@@ -126,7 +147,8 @@ mergeSources sources = do
argumentJobSource :: [ JobName ] -> CommandExec JobSource
argumentJobSource [] = emptyJobSource
argumentJobSource names = do
- ( config, jobsetCommit ) <- getJobRoot >>= \case
+ jobRoot <- getJobRoot
+ ( config, jcommit ) <- case jobRoot of
JobRootConfig config -> do
commit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo
return ( config, commit )
@@ -135,29 +157,49 @@ argumentJobSource names = do
config <- either fail return =<< loadConfigForCommit =<< getCommitTree commit
return ( config, Just commit )
- jobtree <- case jobsetCommit of
+ jobtree <- case jcommit of
Just commit -> (: []) <$> getCommitTree commit
Nothing -> return []
- let cidPart = map (JobIdTree Nothing "" . treeId) jobtree
- jobsetJobsEither <- fmap Right $ forM names $ \name ->
+ 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
+ Just _ -> return ()
Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found"
- oneshotJobSource . (: []) =<<
- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei })
- (evalJobSet (map ( Nothing, ) jobtree) JobSet {..})
+
+ jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do
+ evalJobSetSelected names (map ( Nothing, ) 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
- jobs <- cmdEvalWith id $ mapM evalJobReference refs
- oneshotJobSource . map (JobSet Nothing . Right . (: [])) $ jobs
+ 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
- { jobsetCommit = Just commit
+ { jobsetId = ()
+ , jobsetConfig = Just config
+ , jobsetCommit = Just commit
+ , jobsetExplicitlyRequested = []
, jobsetJobsEither = Right $ configJobs config
}
@@ -294,8 +336,10 @@ cmdRun (RunCommand RunOptions {..} args) = do
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
@@ -315,7 +359,11 @@ cmdRun (RunCommand RunOptions {..} args) = do
case jobsetJobsEither jobset of
Right jobs -> do
- outs <- runJobs mngr output 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
statuses = map findJob names
forM_ (outputTerminal output) $ \tout -> do
@@ -348,22 +396,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 "
+ 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 "
+ 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"
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)
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-16 19:35:10 +0000