summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Command.hs56
-rw-r--r--src/Command/Extract.hs101
-rw-r--r--src/Command/JobId.hs54
-rw-r--r--src/Command/Log.hs47
-rw-r--r--src/Command/Run.hs237
-rw-r--r--src/Command/Shell.hs48
-rw-r--r--src/Command/Subtree.hs47
-rw-r--r--src/Config.hs77
-rw-r--r--src/Config.hs-boot3
-rw-r--r--src/Destination.hs54
-rw-r--r--src/Eval.hs335
-rw-r--r--src/FileUtils.c18
-rw-r--r--src/FileUtils.hs69
-rw-r--r--src/Job.hs279
-rw-r--r--src/Job/Types.hs82
-rw-r--r--src/Main.hs153
-rw-r--r--src/Output.hs132
-rw-r--r--src/Repo.hs61
-rw-r--r--src/Terminal.hs27
19 files changed, 1551 insertions, 329 deletions
diff --git a/src/Command.hs b/src/Command.hs
index 0d333e8..1ef52ed 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -9,11 +9,10 @@ module Command (
tfail,
CommandInput(..),
getCommonOptions,
- getConfigPath,
- getConfig,
+ getRootPath, getJobRoot,
getRepo, getDefaultRepo, tryGetDefaultRepo,
- getEvalInput,
- getTerminalOutput,
+ getEvalInput, cmdEvalWith,
+ getOutput,
getStorageDir,
) where
@@ -28,23 +27,25 @@ import Data.Text.IO qualified as T
import System.Console.GetOpt
import System.Exit
-import System.FilePath
import System.IO
import Config
+import Destination
import Eval
+import Output
import Repo
-import Terminal
data CommonOptions = CommonOptions
{ optJobs :: Int
- , optRepo :: [ DeclaredRepo ]
+ , optRepo :: [ ( RepoName, FilePath ) ]
+ , optDestination :: [ ( DestinationName, Text ) ]
}
defaultCommonOptions :: CommonOptions
defaultCommonOptions = CommonOptions
{ optJobs = 2
, optRepo = []
+ , optDestination = []
}
class CommandArgumentsType (CommandArguments c) => Command c where
@@ -100,34 +101,29 @@ tfail err = liftIO $ do
data CommandInput = CommandInput
{ ciOptions :: CommonOptions
- , ciConfigPath :: Maybe FilePath
- , ciConfig :: Either String Config
+ , ciRootPath :: FilePath
+ , ciJobRoot :: JobRoot
, ciContainingRepo :: Maybe Repo
, ciOtherRepos :: [ ( RepoName, Repo ) ]
- , ciTerminalOutput :: TerminalOutput
- , ciStorageDir :: Maybe FilePath
+ , ciDestinations :: [ ( DestinationName, Destination ) ]
+ , ciOutput :: Output
+ , ciStorageDir :: FilePath
}
getCommonOptions :: CommandExec CommonOptions
getCommonOptions = CommandExec (asks ciOptions)
-getConfigPath :: CommandExec FilePath
-getConfigPath = do
- CommandExec (asks ciConfigPath) >>= \case
- Nothing -> tfail $ "no job file found"
- Just path -> return path
+getRootPath :: CommandExec FilePath
+getRootPath = CommandExec (asks ciRootPath)
-getConfig :: CommandExec Config
-getConfig = do
- CommandExec (asks ciConfig) >>= \case
- Left err -> fail err
- Right config -> return config
+getJobRoot :: CommandExec JobRoot
+getJobRoot = CommandExec (asks ciJobRoot)
getRepo :: RepoName -> CommandExec Repo
getRepo name = do
CommandExec (asks (lookup name . ciOtherRepos)) >>= \case
Just repo -> return repo
- Nothing -> tfail $ "repo `" <> textRepoName name <> "' not declared"
+ Nothing -> tfail $ "repo ‘" <> textRepoName name <> "’ not declared"
getDefaultRepo :: CommandExec Repo
getDefaultRepo = do
@@ -140,14 +136,20 @@ tryGetDefaultRepo = CommandExec $ asks ciContainingRepo
getEvalInput :: CommandExec EvalInput
getEvalInput = CommandExec $ do
+ eiJobRoot <- asks ciJobRoot
+ eiRootPath <- asks ciRootPath
+ eiCurrentIdRev <- return []
eiContainingRepo <- asks ciContainingRepo
eiOtherRepos <- asks ciOtherRepos
+ eiDestinations <- asks ciDestinations
return EvalInput {..}
-getTerminalOutput :: CommandExec TerminalOutput
-getTerminalOutput = CommandExec (asks ciTerminalOutput)
+cmdEvalWith :: (EvalInput -> EvalInput) -> Eval a -> CommandExec a
+cmdEvalWith f ev = do
+ either (tfail . textEvalError) return =<< liftIO . runEval ev . f =<< getEvalInput
+
+getOutput :: CommandExec Output
+getOutput = CommandExec (asks ciOutput)
getStorageDir :: CommandExec FilePath
-getStorageDir = CommandExec (asks ciStorageDir) >>= \case
- Just dir -> return dir
- Nothing -> ((</> ".minici") . takeDirectory) <$> getConfigPath
+getStorageDir = CommandExec (asks ciStorageDir)
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)
diff --git a/src/Config.hs b/src/Config.hs
index 5631179..fb3a828 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,4 +1,5 @@
module Config (
+ JobRoot(..),
Config(..),
findConfig,
parseConfig,
@@ -12,7 +13,6 @@ import Control.Monad.Combinators
import Control.Monad.IO.Class
import Data.ByteString.Lazy qualified as BS
-import Data.Either
import Data.List
import Data.Map qualified as M
import Data.Maybe
@@ -26,6 +26,7 @@ import System.FilePath
import System.FilePath.Glob
import System.Process
+import Destination
import Job.Types
import Repo
@@ -34,21 +35,29 @@ configFileName :: FilePath
configFileName = "minici.yaml"
+data JobRoot
+ = JobRootRepo Repo
+ | JobRootConfig Config
+
+
data Config = Config
{ configJobs :: [ DeclaredJob ]
, configRepos :: [ DeclaredRepo ]
+ , configDestinations :: [ DeclaredDestination ]
}
instance Semigroup Config where
a <> b = Config
{ configJobs = configJobs a ++ configJobs b
, configRepos = configRepos a ++ configRepos b
+ , configDestinations = configDestinations a ++ configDestinations b
}
instance Monoid Config where
mempty = Config
{ configJobs = []
, configRepos = []
+ , configDestinations = []
}
instance FromYAML Config where
@@ -67,37 +76,45 @@ instance FromYAML Config where
| [ "repo", name ] <- T.words tag -> do
repo <- parseRepo name node
return $ config { configRepos = configRepos config ++ [ repo ] }
+ | [ "destination", name ] <- T.words tag -> do
+ destination <- parseDestination name node
+ return $ config { configDestinations = configDestinations config ++ [ destination ] }
_ -> return config
parseJob :: Text -> Node Pos -> Parser DeclaredJob
parseJob name node = flip (withMap "Job") node $ \j -> do
let jobName = JobName name
- ( jobContainingCheckout, jobOtherCheckout ) <- partitionEithers <$> choice
+ jobId = jobName
+ jobRecipe <- choice
+ [ fmap Just $ cabalJob =<< j .: "cabal"
+ , fmap Just $ shellJob =<< j .: "shell"
+ , return Nothing
+ ]
+ jobCheckout <- choice
[ parseSingleCheckout =<< j .: "checkout"
, parseMultipleCheckouts =<< j .: "checkout"
, withNull "no checkout" (return []) =<< j .: "checkout"
- , return [ Left $ JobCheckout Nothing Nothing ]
- ]
- jobRecipe <- choice
- [ cabalJob =<< j .: "cabal"
- , shellJob =<< j .: "shell"
+ , return $ if isJust jobRecipe
+ then [ JobCheckout Nothing Nothing Nothing ]
+ else []
]
jobArtifacts <- parseArtifacts j
jobUses <- maybe (return []) parseUses =<< j .:? "uses"
+ jobPublish <- maybe (return []) (parsePublish jobName) =<< j .:? "publish"
return Job {..}
-parseSingleCheckout :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]
+parseSingleCheckout :: Node Pos -> Parser [ JobCheckout Declared ]
parseSingleCheckout = withMap "checkout definition" $ \m -> do
jcSubtree <- fmap T.unpack <$> m .:? "subtree"
jcDestination <- fmap T.unpack <$> m .:? "dest"
- let checkout = JobCheckout {..}
- m .:? "repo" >>= \case
- Nothing -> return [ Left checkout ]
+ jcRepo <- m .:? "repo" >>= \case
+ Nothing -> return Nothing
Just name -> do
revision <- m .:? "revision"
- return [ Right ( DeclaredJobRepo (RepoName name), revision, checkout ) ]
+ return $ Just ( RepoName name, revision )
+ return [ JobCheckout {..} ]
-parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]
+parseMultipleCheckouts :: Node Pos -> Parser [ JobCheckout Declared ]
parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout
cabalJob :: Node Pos -> Parser [CreateProcess]
@@ -130,11 +147,34 @@ parseUses = withSeq "Uses list" $ mapM $
[job, art] <- return $ T.split (== '.') text
return (JobName job, ArtifactName art)
+parsePublish :: JobName -> Node Pos -> Parser [ JobPublish Declared ]
+parsePublish ownName = withSeq "Publish list" $ mapM $
+ withMap "Publish specification" $ \m -> do
+ artifact <- m .: "artifact"
+ jpArtifact <- case T.split (== '.') artifact of
+ [ job, art ] -> return ( JobName job, ArtifactName art )
+ [ art ] -> return ( ownName, ArtifactName art )
+ _ -> mzero
+ jpDestination <- DestinationName <$> m .: "to"
+ jpPath <- fmap T.unpack <$> m .:? "path"
+ return JobPublish {..}
+
parseRepo :: Text -> Node Pos -> Parser DeclaredRepo
-parseRepo name node = flip (withMap "Repo") node $ \r -> DeclaredRepo
- <$> pure (RepoName name)
- <*> (T.unpack <$> r .: "path")
+parseRepo name node = choice
+ [ flip (withNull "Repo") node $ return $ DeclaredRepo (RepoName name) Nothing
+ , flip (withMap "Repo") node $ \r -> DeclaredRepo
+ <$> pure (RepoName name)
+ <*> (fmap T.unpack <$> r .:? "path")
+ ]
+
+parseDestination :: Text -> Node Pos -> Parser DeclaredDestination
+parseDestination name node = choice
+ [ flip (withNull "Destination") node $ return $ DeclaredDestination (DestinationName name) Nothing
+ , flip (withMap "Destination") node $ \r -> DeclaredDestination
+ <$> pure (DestinationName name)
+ <*> (r .:? "url")
+ ]
findConfig :: IO (Maybe FilePath)
@@ -167,6 +207,9 @@ loadJobSetForCommit :: (MonadIO m, MonadFail m) => Commit -> m DeclaredJobSet
loadJobSetForCommit commit = return . toJobSet =<< loadConfigForCommit =<< getCommitTree commit
where
toJobSet configEither = JobSet
- { jobsetCommit = Just commit
+ { jobsetId = ()
+ , jobsetConfig = either (const Nothing) Just configEither
+ , jobsetCommit = Just commit
+ , jobsetExplicitlyRequested = []
, jobsetJobsEither = fmap configJobs configEither
}
diff --git a/src/Config.hs-boot b/src/Config.hs-boot
new file mode 100644
index 0000000..ee6b0d1
--- /dev/null
+++ b/src/Config.hs-boot
@@ -0,0 +1,3 @@
+module Config where
+
+data Config
diff --git a/src/Destination.hs b/src/Destination.hs
new file mode 100644
index 0000000..4fd8cd8
--- /dev/null
+++ b/src/Destination.hs
@@ -0,0 +1,54 @@
+module Destination (
+ Destination,
+ DeclaredDestination(..),
+ DestinationName(..), textDestinationName, showDestinationName,
+
+ openDestination,
+ copyToDestination,
+
+ copyRecursive,
+ copyRecursiveForce,
+) where
+
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import System.FilePath
+import System.Directory
+
+import FileUtils
+
+
+data Destination
+ = FilesystemDestination FilePath
+
+data DeclaredDestination = DeclaredDestination
+ { destinationName :: DestinationName
+ , destinationUrl :: Maybe Text
+ }
+
+
+newtype DestinationName = DestinationName Text
+ deriving (Eq, Ord, Show)
+
+textDestinationName :: DestinationName -> Text
+textDestinationName (DestinationName text) = text
+
+showDestinationName :: DestinationName -> String
+showDestinationName = T.unpack . textDestinationName
+
+
+openDestination :: FilePath -> Text -> IO Destination
+openDestination baseDir url = do
+ let path = baseDir </> T.unpack url
+ createDirectoryIfMissing True path
+ return $ FilesystemDestination path
+
+copyToDestination :: MonadIO m => FilePath -> Destination -> FilePath -> m ()
+copyToDestination source (FilesystemDestination base) inner = do
+ let target = base </> dropWhile isPathSeparator inner
+ liftIO $ do
+ createDirectoryIfMissing True $ takeDirectory target
+ copyRecursiveForce source target
diff --git a/src/Eval.hs b/src/Eval.hs
index 1828468..1b0d7dd 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -6,24 +6,35 @@ module Eval (
evalJob,
evalJobSet,
evalJobReference,
+
+ loadJobSetById,
+ fillInDependencies,
) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
-import Data.Bifunctor
import Data.List
+import Data.Maybe
+import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
+import System.FilePath
+
import Config
+import Destination
import Job.Types
import Repo
data EvalInput = EvalInput
- { eiContainingRepo :: Maybe Repo
+ { eiJobRoot :: JobRoot
+ , eiRootPath :: FilePath
+ , eiCurrentIdRev :: [ JobIdPart ]
+ , eiContainingRepo :: Maybe Repo
, eiOtherRepos :: [ ( RepoName, Repo ) ]
+ , eiDestinations :: [ ( DestinationName, Destination ) ]
}
data EvalError
@@ -39,73 +50,275 @@ runEval :: Eval a -> EvalInput -> IO (Either EvalError a)
runEval action einput = runExceptT $ flip runReaderT einput action
-evalJob :: EvalInput -> DeclaredJob -> Except EvalError Job
-evalJob EvalInput {..} decl = do
- otherCheckout <- forM (jobOtherCheckout decl) $ \( DeclaredJobRepo name, revision, checkout ) -> do
- repo <- maybe (throwError $ OtherEvalError $ "repo `" <> textRepoName name <> "' not defined") return $
- lookup name eiOtherRepos
- return ( EvaluatedJobRepo repo, revision, checkout )
- return Job
- { jobName = jobName decl
- , jobContainingCheckout = jobContainingCheckout decl
- , jobOtherCheckout = otherCheckout
- , jobRecipe = jobRecipe decl
- , jobArtifacts = jobArtifacts decl
- , jobUses = jobUses decl
- }
+commonPrefix :: Eq a => [ a ] -> [ a ] -> [ a ]
+commonPrefix (x : xs) (y : ys) | x == y = x : commonPrefix xs ys
+commonPrefix _ _ = []
+
+checkIfAlreadyHasDefaultRepoId :: Eval Bool
+checkIfAlreadyHasDefaultRepoId = do
+ asks (any isDefaultRepoId . eiCurrentIdRev)
+ where
+ isDefaultRepoId (JobIdName _) = False
+ isDefaultRepoId (JobIdCommit rname _) = isNothing rname
+ isDefaultRepoId (JobIdTree rname _ _) = isNothing rname
+
+collectJobSetRepos :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval [ ( Maybe RepoName, Tree ) ]
+collectJobSetRepos revisionOverrides dset = do
+ jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset
+ let someJobUsesDefaultRepo = any (any (isNothing . jcRepo) . jobCheckout) jobs
+ repos =
+ (if someJobUsesDefaultRepo then (Nothing :) else id) $
+ map (Just . repoName) $ maybe [] configRepos $ jobsetConfig dset
+ forM repos $ \rname -> do
+ case lookup rname revisionOverrides of
+ Just tree -> return ( rname, tree )
+ Nothing -> do
+ repo <- evalRepo rname
+ tree <- getCommitTree =<< readCommit repo "HEAD"
+ return ( rname, tree )
+
+collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), FilePath ) ]
+collectOtherRepos dset decl = do
+ jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset
+ let gatherDependencies seen (d : ds)
+ | d `elem` seen = gatherDependencies seen ds
+ | Just job <- find ((d ==) . jobName) jobs
+ = gatherDependencies (d : seen) (map fst (jobRequiredArtifacts job) ++ ds)
+ | otherwise = gatherDependencies (d : seen) ds
+ gatherDependencies seen [] = seen
+
+ let dependencies = gatherDependencies [] [ jobName decl ]
+ dependencyRepos <- forM dependencies $ \name -> do
+ job <- maybe (throwError $ OtherEvalError $ "job ‘" <> textJobName name <> "’ not found") return . find ((name ==) . jobName) $ jobs
+ return $ jobCheckout job
+
+ alreadyHasDefaultRepoId <- checkIfAlreadyHasDefaultRepoId
+ let checkouts =
+ (if alreadyHasDefaultRepoId then filter (isJust . jcRepo) else id) $
+ concat dependencyRepos
-evalJobSet :: EvalInput -> DeclaredJobSet -> JobSet
-evalJobSet ei decl = do
- JobSet
- { jobsetCommit = jobsetCommit decl
- , jobsetJobsEither = join $
- fmap (sequence . map (runExceptStr . evalJob ei)) $
- jobsetJobsEither decl
+ let commonSubdir reporev = joinPath $ foldr1 commonPrefix $
+ map (maybe [] splitDirectories . jcSubtree) . filter ((reporev ==) . jcRepo) $ checkouts
+ let canonicalRepoOrder = Nothing : maybe [] (map (Just . repoName) . configRepos) (jobsetConfig dset)
+ getCheckoutsForName rname = map (\r -> ( r, commonSubdir r )) $ nub $ filter ((rname ==) . fmap fst) $ map jcRepo checkouts
+ return $ concatMap getCheckoutsForName canonicalRepoOrder
+
+
+evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> DeclaredJob -> Eval ( Job, JobSetId )
+evalJob revisionOverrides dset decl = do
+ EvalInput {..} <- ask
+ otherRepos <- collectOtherRepos dset decl
+ otherRepoTrees <- forM otherRepos $ \( mbrepo, commonPath ) -> do
+ ( mbrepo, ) . ( commonPath, ) <$> do
+ case lookup (fst <$> mbrepo) revisionOverrides of
+ Just tree -> return tree
+ Nothing -> do
+ repo <- evalRepo (fst <$> mbrepo)
+ commit <- readCommit repo (fromMaybe "HEAD" $ join $ snd <$> mbrepo)
+ getSubtree (Just commit) commonPath =<< getCommitTree commit
+
+ checkouts <- forM (jobCheckout decl) $ \dcheckout -> do
+ return dcheckout
+ { jcRepo =
+ fromMaybe (error $ "expecting repo in either otherRepoTrees or revisionOverrides: " <> show (textRepoName . fst <$> jcRepo dcheckout)) $
+ msum
+ [ snd <$> lookup (jcRepo dcheckout) otherRepoTrees
+ , lookup (fst <$> jcRepo dcheckout) revisionOverrides
+ ]
+ }
+
+ destinations <- forM (jobPublish decl) $ \dpublish -> do
+ case lookup (jpDestination dpublish) eiDestinations of
+ Just dest -> return $ dpublish { jpDestination = dest }
+ Nothing -> throwError $ OtherEvalError $ "no url defined for destination ‘" <> textDestinationName (jpDestination dpublish) <> "’"
+
+ let otherRepoIds = flip mapMaybe otherRepoTrees $ \case
+ ( repo, ( subtree, tree )) -> do
+ guard $ maybe True (isNothing . snd) repo -- use only checkouts without explicit revision in job id
+ Just $ JobIdTree (fst <$> repo) subtree (treeId tree)
+ return
+ ( Job
+ { jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId decl) : eiCurrentIdRev
+ , jobName = jobName decl
+ , jobCheckout = checkouts
+ , jobRecipe = jobRecipe decl
+ , jobArtifacts = jobArtifacts decl
+ , jobUses = jobUses decl
+ , jobPublish = destinations
+ }
+ , JobSetId $ reverse $ reverse otherRepoIds ++ eiCurrentIdRev
+ )
+
+evalJobSet :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet
+evalJobSet revisionOverrides decl = do
+ EvalInput {..} <- ask
+ repos <- collectJobSetRepos revisionOverrides decl
+ alreadyHasDefaultRepoId <- checkIfAlreadyHasDefaultRepoId
+ let addedRepoIds =
+ map (\( mbname, tree ) -> JobIdTree mbname "" (treeId tree)) $
+ (if alreadyHasDefaultRepoId then filter (isJust . fst) else id) $
+ repos
+
+ jobs <- fmap (fmap (map fst))
+ $ either (return . Left) (handleToEither . mapM (evalJob revisionOverrides decl))
+ $ jobsetJobsEither decl
+ let explicit =
+ case liftM2 zip (jobsetJobsEither decl) jobs of
+ Left _ -> []
+ Right declEval -> catMaybes $
+ map (\jid -> jobId . snd <$> find ((jid ==) . jobId . fst) declEval) $ jobsetExplicitlyRequested decl
+ return JobSet
+ { jobsetId = JobSetId $ reverse $ reverse addedRepoIds ++ eiCurrentIdRev
+ , jobsetConfig = jobsetConfig decl
+ , jobsetCommit = jobsetCommit decl
+ , jobsetExplicitlyRequested = explicit
+ , jobsetJobsEither = jobs
}
where
- runExceptStr = first (T.unpack . textEvalError) . runExcept
+ handleToEither = flip catchError (return . Left . T.unpack . textEvalError) . fmap Right
+
+evalRepo :: Maybe RepoName -> Eval Repo
+evalRepo Nothing = asks eiContainingRepo >>= \case
+ Just repo -> return repo
+ Nothing -> throwError $ OtherEvalError $ "no default repo"
+evalRepo (Just name) = asks (lookup name . eiOtherRepos) >>= \case
+ Just repo -> return repo
+ Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined"
-canonicalJobName :: [ Text ] -> Config -> Eval [ JobIdPart ]
-canonicalJobName (r : rs) config = do
- einput <- ask
+canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval JobSet
+canonicalJobName (r : rs) config mbDefaultRepo = do
let name = JobName r
+ dset = JobSet
+ { jobsetId = ()
+ , jobsetConfig = Just config
+ , jobsetCommit = Nothing
+ , jobsetExplicitlyRequested = []
+ , jobsetJobsEither = Right $ configJobs config
+ }
case find ((name ==) . jobName) (configJobs config) of
Just djob -> do
- job <- either throwError return $ runExcept $ evalJob einput djob
- let repos = nub $ map (\( EvaluatedJobRepo repo, _, _ ) -> repo) $ jobOtherCheckout job
- (JobIdName name :) <$> canonicalOtherCheckouts rs repos
+ otherRepos <- collectOtherRepos dset djob
+ ( overrides, rs' ) <- (\f -> foldM f ( [], rs ) otherRepos) $
+ \( overrides, crs ) ( mbrepo, path ) -> if
+ | Just ( _, Just _ ) <- mbrepo -> do
+ -- use only checkouts without explicit revision in job id
+ return ( overrides, crs )
+ | otherwise -> do
+ ( tree, crs' ) <- readTreeFromIdRef crs path =<< evalRepo (fst <$> mbrepo)
+ return ( ( fst <$> mbrepo, tree ) : overrides, crs' )
+ case rs' of
+ (r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’"
+ _ -> return ()
+ eset <- evalJobSet (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset
+ return eset { jobsetJobsEither = fmap (filter ((name ==) . jobName)) $ jobsetJobsEither eset }
Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found"
-canonicalJobName [] _ = throwError $ OtherEvalError "expected job name"
-
-canonicalOtherCheckouts :: [ Text ] -> [ Repo ] -> Eval [ JobIdPart ]
-canonicalOtherCheckouts (r : rs) (repo : repos) = do
- tree <- tryReadCommit repo r >>= \case
- Just commit -> getCommitTree commit
- Nothing -> tryReadTree repo r >>= \case
- Just tree -> return tree
- Nothing -> throwError $ OtherEvalError $ "failed to resolve ‘" <> r <> "’ to a commit or tree in " <> T.pack (show repo)
- (JobIdTree (treeId tree) :) <$> canonicalOtherCheckouts rs repos
-canonicalOtherCheckouts [] [] = return []
-canonicalOtherCheckouts [] (_ : _ ) = throwError $ OtherEvalError $ "expected commit or tree reference"
-canonicalOtherCheckouts (r : _) [] = throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r <> "’"
-
-canonicalCommitConfig :: [ Text ] -> Repo -> Eval [ JobIdPart ]
-canonicalCommitConfig (r : rs) repo = do
- tree <- tryReadCommit repo r >>= \case
- Just commit -> getCommitTree commit
- Nothing -> tryReadTree repo r >>= \case
- Just tree -> return tree
+canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name"
+
+readTreeFromIdRef :: [ Text ] -> FilePath -> Repo -> Eval ( Tree, [ Text ] )
+readTreeFromIdRef (r : rs) subdir repo = do
+ tryReadCommit repo r >>= \case
+ Just commit -> return . (, rs) =<< getSubtree (Just commit) subdir =<< getCommitTree commit
+ Nothing -> tryReadTree repo subdir r >>= \case
+ Just tree -> return ( tree, rs )
Nothing -> throwError $ OtherEvalError $ "failed to resolve ‘" <> r <> "’ to a commit or tree in " <> T.pack (show repo)
+readTreeFromIdRef [] _ _ = throwError $ OtherEvalError $ "expected commit or tree reference"
+
+canonicalCommitConfig :: [ Text ] -> Repo -> Eval JobSet
+canonicalCommitConfig rs repo = do
+ ( tree, rs' ) <- readTreeFromIdRef rs "" repo
config <- either fail return =<< loadConfigForCommit tree
- (JobIdTree (treeId tree) :) <$> canonicalJobName rs config
-canonicalCommitConfig [] _ = throwError $ OtherEvalError "expected commit or tree reference"
-
-evalJobReference :: Config -> JobRef -> Eval JobId
-evalJobReference config (JobRef rs) =
- fmap JobId $ do
- asks eiContainingRepo >>= \case
- Just defRepo -> do
- canonicalCommitConfig rs defRepo
- Nothing -> do
- canonicalJobName rs config
+ local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $
+ canonicalJobName rs' config (Just tree)
+
+evalJobReference :: JobRef -> Eval JobSet
+evalJobReference (JobRef rs) =
+ asks eiJobRoot >>= \case
+ JobRootRepo defRepo -> do
+ canonicalCommitConfig rs defRepo
+ JobRootConfig config -> do
+ canonicalJobName rs config Nothing
+
+
+jobsetFromConfig :: [ JobIdPart ] -> Config -> Maybe Tree -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] )
+jobsetFromConfig sid config _ = do
+ EvalInput {..} <- ask
+ let dset = JobSet () (Just config) Nothing [] $ Right $ configJobs config
+ otherRepos <- forM sid $ \case
+ JobIdName name -> do
+ throwError $ OtherEvalError $ "expected tree id, not a job name ‘" <> textJobName name <> "’"
+ JobIdCommit name cid -> do
+ repo <- evalRepo name
+ tree <- getCommitTree =<< readCommitId repo cid
+ return ( name, tree )
+ JobIdTree name path tid -> do
+ repo <- evalRepo name
+ tree <- readTreeId repo path tid
+ return ( name, tree )
+ return ( dset, eiCurrentIdRev, otherRepos )
+
+jobsetFromCommitConfig :: [ JobIdPart ] -> Repo -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] )
+jobsetFromCommitConfig (JobIdTree name path tid : sid) repo = do
+ when (isJust name) $ do
+ throwError $ OtherEvalError $ "expected default repo commit or tree id"
+ when (not (null path)) $ do
+ throwError $ OtherEvalError $ "expected root commit or tree id"
+ tree <- readTreeId repo path tid
+ config <- either fail return =<< loadConfigForCommit tree
+ local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $ do
+ ( dset, idRev, otherRepos ) <- jobsetFromConfig sid config (Just tree)
+ return ( dset, idRev, ( Nothing, tree ) : otherRepos )
+
+jobsetFromCommitConfig (JobIdCommit name cid : sid) repo = do
+ when (isJust name) $ do
+ throwError $ OtherEvalError $ "expected default repo commit or tree id"
+ tree <- getCommitTree =<< readCommitId repo cid
+ jobsetFromCommitConfig (JobIdTree name "" (treeId tree) : sid) repo
+
+jobsetFromCommitConfig (JobIdName name : _) _ = do
+ throwError $ OtherEvalError $ "expected commit or tree id, not a job name ‘" <> textJobName name <> "’"
+
+jobsetFromCommitConfig [] _ = do
+ throwError $ OtherEvalError $ "expected commit or tree id"
+
+loadJobSetById :: JobSetId -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] )
+loadJobSetById (JobSetId sid) = do
+ asks eiJobRoot >>= \case
+ JobRootRepo defRepo -> do
+ jobsetFromCommitConfig sid defRepo
+ JobRootConfig config -> do
+ jobsetFromConfig sid config Nothing
+
+fillInDependencies :: JobSet -> Eval JobSet
+fillInDependencies jset = do
+ ( dset, idRev, otherRepos ) <- local (\ei -> ei { eiCurrentIdRev = [] }) $ do
+ loadJobSetById (jobsetId jset)
+ eset <- local (\ei -> ei { eiCurrentIdRev = idRev }) $ do
+ evalJobSet otherRepos dset
+ origJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither jset
+ allJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither eset
+ deps <- gather allJobs S.empty (map jobName origJobs)
+
+ let jobs = catMaybes $ flip map allJobs $ \ejob -> if
+ | Just job <- find ((jobName ejob ==) . jobName) origJobs
+ -> Just job
+
+ | jobName ejob `S.member` deps
+ -> Just ejob
+
+ | otherwise
+ -> Nothing
+
+ return $ jset { jobsetJobsEither = Right jobs }
+ where
+ gather djobs cur ( name : rest )
+ | name `S.member` cur
+ = gather djobs cur rest
+
+ | Just djob <- find ((name ==) . jobName) djobs
+ = gather djobs (S.insert name cur) $ map fst (jobUses djob) ++ map (fst . jpArtifact) (jobPublish djob) ++ rest
+
+ | otherwise
+ = throwError $ OtherEvalError $ "dependency ‘" <> textJobName name <> "’ not found"
+
+ gather _ cur [] = return cur
diff --git a/src/FileUtils.c b/src/FileUtils.c
new file mode 100644
index 0000000..3cf2997
--- /dev/null
+++ b/src/FileUtils.c
@@ -0,0 +1,18 @@
+#include <fcntl.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+int minici_fd_open_read( const char * from )
+{
+ return open( from, O_RDONLY | O_CLOEXEC );
+}
+
+int minici_fd_create_write( const char * from, int fd_perms )
+{
+ struct stat st;
+ mode_t mode = 0600;
+ if( fstat( fd_perms, & st ) == 0 )
+ mode = st.st_mode;
+
+ return open( from, O_CREAT | O_WRONLY | O_TRUNC | O_CLOEXEC, mode );
+}
diff --git a/src/FileUtils.hs b/src/FileUtils.hs
new file mode 100644
index 0000000..a59548f
--- /dev/null
+++ b/src/FileUtils.hs
@@ -0,0 +1,69 @@
+module FileUtils where
+
+import Control.Monad
+import Control.Monad.Catch
+
+import Data.ByteString (useAsCString)
+import Data.Text qualified as T
+import Data.Text.Encoding
+
+import Foreign.C.Error
+import Foreign.C.String
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+
+import System.Directory
+import System.FilePath
+import System.Posix.IO.ByteString
+import System.Posix.Types
+
+
+-- As of directory-1.3.9 and file-io-0.1.5, the provided copyFile creates a
+-- temporary file without O_CLOEXEC, sometimes leaving the write descriptor
+-- open in child processes.
+safeCopyFile :: FilePath -> FilePath -> IO ()
+safeCopyFile from to = do
+ allocaBytes (fromIntegral bufferSize) $ \buf ->
+ useAsCString (encodeUtf8 $ T.pack from) $ \cfrom ->
+ useAsCString (encodeUtf8 $ T.pack to) $ \cto ->
+ bracket (throwErrnoPathIfMinus1 "open" from $ c_fd_open_read cfrom) closeFd $ \fromFd ->
+ bracket (throwErrnoPathIfMinus1 "open" to $ c_fd_create_write cto fromFd) closeFd $ \toFd -> do
+ let goRead = do
+ count <- throwErrnoIfMinus1Retry ("read " <> from) $ fdReadBuf fromFd buf bufferSize
+ when (count > 0) $ do
+ goWrite count 0
+ goWrite count written
+ | written < count = do
+ written' <- throwErrnoIfMinus1Retry ("write " <> to) $
+ fdWriteBuf toFd (buf `plusPtr` fromIntegral written) (count - written)
+ goWrite count (written + written')
+ | otherwise = do
+ goRead
+ goRead
+ where
+ bufferSize = 131072
+
+-- Custom open(2) wrappers using O_CLOEXEC. The `cloexec` in `OpenFileFlags` is
+-- available only since unix-2.8.0.0
+foreign import ccall "minici_fd_open_read" c_fd_open_read :: CString -> IO Fd
+foreign import ccall "minici_fd_create_write" c_fd_create_write :: CString -> Fd -> IO Fd
+
+
+copyRecursive :: FilePath -> FilePath -> IO ()
+copyRecursive from to = do
+ doesDirectoryExist from >>= \case
+ False -> do
+ safeCopyFile from to
+ True -> do
+ createDirectory to
+ content <- listDirectory from
+ forM_ content $ \name -> do
+ copyRecursive (from </> name) (to </> name)
+
+copyRecursiveForce :: FilePath -> FilePath -> IO ()
+copyRecursiveForce from to = do
+ doesDirectoryExist to >>= \case
+ False -> return ()
+ True -> removeDirectoryRecursive to
+ copyRecursive from to
diff --git a/src/Job.hs b/src/Job.hs
index a9effba..5a22d63 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -7,7 +7,16 @@ module Job (
JobStatus(..),
jobStatusFinished, jobStatusFailed,
JobManager(..), newJobManager, cancelAllJobs,
- runJobs,
+ runJobs, waitForRemainingTasks,
+
+ prepareJob,
+ getArtifactWorkPath,
+ copyArtifact,
+
+ jobStorageSubdir,
+
+ copyRecursive,
+ copyRecursiveForce,
) where
import Control.Concurrent
@@ -37,14 +46,14 @@ import System.IO.Temp
import System.Posix.Signals
import System.Process
+import Destination
import Job.Types
+import Output
import Repo
-import Terminal
data JobOutput = JobOutput
- { outName :: JobName
- , outArtifacts :: [ArtifactOutput]
+ { outArtifacts :: [ArtifactOutput]
}
deriving (Eq)
@@ -58,10 +67,11 @@ data ArtifactOutput = ArtifactOutput
data JobStatus a = JobQueued
| JobDuplicate JobId (JobStatus a)
+ | JobPreviousStatus (JobStatus a)
| JobWaiting [JobName]
| JobRunning
| JobSkipped
- | JobError TerminalFootnote
+ | JobError OutputFootnote
| JobFailed
| JobCancelled
| JobDone a
@@ -69,31 +79,58 @@ data JobStatus a = JobQueued
jobStatusFinished :: JobStatus a -> Bool
jobStatusFinished = \case
- JobQueued {} -> False
- JobDuplicate _ s -> jobStatusFinished s
- JobWaiting {} -> False
- JobRunning {} -> False
- _ -> True
+ JobQueued {} -> False
+ JobDuplicate _ s -> jobStatusFinished s
+ JobPreviousStatus s -> jobStatusFinished s
+ JobWaiting {} -> False
+ JobRunning {} -> False
+ _ -> True
jobStatusFailed :: JobStatus a -> Bool
jobStatusFailed = \case
- JobDuplicate _ s -> jobStatusFailed s
- JobError {} -> True
- JobFailed {} -> True
- _ -> False
+ JobDuplicate _ s -> jobStatusFailed s
+ JobPreviousStatus s -> jobStatusFailed s
+ JobError {} -> True
+ JobFailed {} -> True
+ _ -> False
+
+jobResult :: JobStatus a -> Maybe a
+jobResult = \case
+ JobDone x -> Just x
+ JobDuplicate _ s -> jobResult s
+ JobPreviousStatus s -> jobResult s
+ _ -> Nothing
textJobStatus :: JobStatus a -> Text
textJobStatus = \case
JobQueued -> "queued"
JobDuplicate {} -> "duplicate"
+ JobPreviousStatus s -> textJobStatus s
JobWaiting _ -> "waiting"
JobRunning -> "running"
JobSkipped -> "skipped"
- JobError err -> "error\n" <> footnoteText err
+ JobError _ -> "error"
JobFailed -> "failed"
JobCancelled -> "cancelled"
JobDone _ -> "done"
+readJobStatus :: (MonadIO m) => Output -> Text -> m a -> m (Maybe (JobStatus a))
+readJobStatus tout text readResult = case T.lines text of
+ "queued" : _ -> return (Just JobQueued)
+ "running" : _ -> return (Just JobRunning)
+ "skipped" : _ -> return (Just JobSkipped)
+ "error" : note : _ -> Just . JobError <$> liftIO (outputFootnote tout note)
+ "failed" : _ -> return (Just JobFailed)
+ "cancelled" : _ -> return (Just JobCancelled)
+ "done" : _ -> Just . JobDone <$> readResult
+ _ -> return Nothing
+
+textJobStatusDetails :: JobStatus a -> Text
+textJobStatusDetails = \case
+ JobError err -> footnoteText err <> "\n"
+ JobPreviousStatus s -> textJobStatusDetails s
+ _ -> ""
+
data JobManager = JobManager
{ jmSemaphore :: TVar Int
@@ -104,6 +141,7 @@ data JobManager = JobManager
, jmReadyTasks :: TVar (Set TaskId)
, jmRunningTasks :: TVar (Map TaskId ThreadId)
, jmCancelled :: TVar Bool
+ , jmOpenStatusUpdates :: TVar Int
}
newtype TaskId = TaskId Int
@@ -124,6 +162,7 @@ newJobManager jmDataDir queueLen = do
jmReadyTasks <- newTVarIO S.empty
jmRunningTasks <- newTVarIO M.empty
jmCancelled <- newTVarIO False
+ jmOpenStatusUpdates <- newTVarIO 0
return JobManager {..}
cancelAllJobs :: JobManager -> IO ()
@@ -181,30 +220,32 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case
writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks
-runJobs :: JobManager -> TerminalOutput -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
-runJobs mngr@JobManager {..} tout commit jobs = do
- tree <- sequence $ fmap getCommitTree commit
+runJobs :: JobManager -> Output -> [ Job ]
+ -> (JobId -> JobStatus JobOutput -> Bool) -- ^ Rerun condition
+ -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
+runJobs mngr@JobManager {..} tout jobs rerun = do
results <- atomically $ do
forM jobs $ \job -> do
- let jid = JobId $ concat [ JobIdTree . treeId <$> maybeToList tree, [ JobIdName (jobName job) ] ]
tid <- reserveTaskId mngr
managed <- readTVar jmJobs
- ( job, tid, ) <$> case M.lookup jid managed of
+ ( job, tid, ) <$> case M.lookup (jobId job) managed of
Just origVar -> do
- newTVar . JobDuplicate jid =<< readTVar origVar
+ newTVar . JobDuplicate (jobId job) =<< readTVar origVar
Nothing -> do
statusVar <- newTVar JobQueued
- writeTVar jmJobs $ M.insert jid statusVar managed
+ writeTVar jmJobs $ M.insert (jobId job) statusVar managed
return statusVar
forM_ results $ \( job, tid, outVar ) -> void $ forkIO $ do
- let handler e = if
- | Just JobCancelledException <- fromException e -> do
- atomically $ writeTVar outVar $ JobCancelled
- | otherwise -> do
- footnote <- newFootnote tout $ T.pack $ displayException e
- atomically $ writeTVar outVar $ JobError footnote
+ let handler e = do
+ status <- if
+ | Just JobCancelledException <- fromException e -> do
+ return JobCancelled
+ | otherwise -> do
+ JobError <$> outputFootnote tout (T.pack $ displayException e)
+ atomically $ writeTVar outVar status
+ outputJobFinishedEvent tout job status
handle handler $ do
res <- runExceptT $ do
duplicate <- liftIO $ atomically $ do
@@ -216,12 +257,22 @@ runJobs mngr@JobManager {..} tout commit jobs = do
case duplicate of
Nothing -> do
- uses <- waitForUsedArtifacts tout job results outVar
- runManagedJob mngr tid (return JobCancelled) $ do
- liftIO $ atomically $ writeTVar outVar JobRunning
- prepareJob jmDataDir commit job $ \checkoutPath jdir -> do
- updateStatusFile (jdir </> "status") outVar
- JobDone <$> runJob job uses checkoutPath jdir
+ let jdir = jmDataDir </> jobStorageSubdir (jobId job)
+ readStatusFile tout job jdir >>= \case
+ Just status | status /= JobCancelled && not (rerun (jobId job) status) -> do
+ let status' = JobPreviousStatus status
+ liftIO $ atomically $ writeTVar outVar status'
+ return status'
+ mbStatus -> do
+ when (isJust mbStatus) $ do
+ liftIO $ removeDirectoryRecursive jdir
+ uses <- waitForUsedArtifacts tout job results outVar
+ runManagedJob mngr tid (return JobCancelled) $ do
+ liftIO $ atomically $ writeTVar outVar JobRunning
+ liftIO $ outputEvent tout $ JobStarted (jobId job)
+ prepareJob jmDataDir job $ \checkoutPath -> do
+ updateStatusFile mngr jdir outVar
+ JobDone <$> runJob job uses checkoutPath jdir
Just ( jid, origVar ) -> do
let wait = do
@@ -239,17 +290,33 @@ runJobs mngr@JobManager {..} tout commit jobs = do
liftIO wait
atomically $ writeTVar outVar $ either id id res
+ outputJobFinishedEvent tout job $ either id id res
return $ map (\( job, _, var ) -> ( job, var )) results
-waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>
- TerminalOutput ->
- Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ]
+waitForRemainingTasks :: JobManager -> IO ()
+waitForRemainingTasks JobManager {..} = do
+ atomically $ do
+ remainingStatusUpdates <- readTVar jmOpenStatusUpdates
+ when (remainingStatusUpdates > 0) retry
+
+waitForUsedArtifacts
+ :: (MonadIO m, MonadError (JobStatus JobOutput) m)
+ => Output -> Job
+ -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ]
+ -> TVar (JobStatus JobOutput)
+ -> m [ ( ArtifactSpec, ArtifactOutput ) ]
waitForUsedArtifacts tout job results outVar = do
origState <- liftIO $ atomically $ readTVar outVar
- ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do
+ let ( selfSpecs, artSpecs ) = partition ((jobName job ==) . fst) $ jobRequiredArtifacts job
+
+ forM_ selfSpecs $ \( _, artName@(ArtifactName tname) ) -> do
+ when (not (artName `elem` map fst (jobArtifacts job))) $ do
+ throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact ‘" <> tname <> "’ not produced by the job")
+
+ ujobs <- forM artSpecs $ \(ujobName@(JobName tjobName), uartName) -> do
case find (\( j, _, _ ) -> jobName j == ujobName) results of
Just ( _, _, var ) -> return ( var, ( ujobName, uartName ))
- Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Job '" <> tjobName <> "' not found")
+ Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Job '" <> tjobName <> "' not found")
let loop prev = do
ustatuses <- atomically $ do
@@ -264,60 +331,100 @@ waitForUsedArtifacts tout job results outVar = do
else loop $ Just $ map fst ustatuses
ustatuses <- liftIO $ loop Nothing
- forM ustatuses $ \(ustatus, (JobName tjobName, uartName@(ArtifactName tartName))) -> do
- case ustatus of
- JobDone out -> case find ((==uartName) . aoutName) $ outArtifacts out of
- Just art -> return art
- Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found")
+ forM ustatuses $ \(ustatus, spec@( JobName tjobName, uartName@(ArtifactName tartName)) ) -> do
+ case jobResult ustatus of
+ Just out -> case find ((==uartName) . aoutName) $ outArtifacts out of
+ Just art -> return ( spec, art )
+ Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found")
_ -> throwError JobSkipped
-updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m ()
-updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing
+outputJobFinishedEvent :: Output -> Job -> JobStatus a -> IO ()
+outputJobFinishedEvent tout job = \case
+ JobDuplicate _ s -> outputEvent tout $ JobIsDuplicate (jobId job) (textJobStatus s)
+ JobPreviousStatus s -> outputEvent tout $ JobPreviouslyFinished (jobId job) (textJobStatus s)
+ JobSkipped -> outputEvent tout $ JobWasSkipped (jobId job)
+ s -> outputEvent tout $ JobFinished (jobId job) (textJobStatus s)
+
+readStatusFile :: (MonadIO m, MonadCatch m) => Output -> Job -> FilePath -> m (Maybe (JobStatus JobOutput))
+readStatusFile tout job jdir = do
+ handleIOError (\_ -> return Nothing) $ do
+ text <- liftIO $ T.readFile (jdir </> "status")
+ readJobStatus tout text $ do
+ artifacts <- forM (jobArtifacts job) $ \( aoutName@(ArtifactName tname), _ ) -> do
+ let adir = jdir </> "artifacts" </> T.unpack tname
+ aoutStorePath = adir </> "data"
+ aoutWorkPath <- fmap T.unpack $ liftIO $ T.readFile (adir </> "path")
+ return ArtifactOutput {..}
+
+ return JobOutput
+ { outArtifacts = artifacts
+ }
+
+updateStatusFile :: MonadIO m => JobManager -> FilePath -> TVar (JobStatus JobOutput) -> m ()
+updateStatusFile JobManager {..} jdir outVar = liftIO $ do
+ atomically $ writeTVar jmOpenStatusUpdates . (+ 1) =<< readTVar jmOpenStatusUpdates
+ void $ forkIO $ loop Nothing
where
loop prev = do
status <- atomically $ do
status <- readTVar outVar
when (Just status == prev) retry
return status
- T.writeFile path $ textJobStatus status <> "\n"
- when (not (jobStatusFinished status)) $ loop $ Just status
+ T.writeFile (jdir </> "status") $ textJobStatus status <> "\n" <> textJobStatusDetails status
+ if (not (jobStatusFinished status))
+ then loop $ Just status
+ else atomically $ writeTVar jmOpenStatusUpdates . (subtract 1) =<< readTVar jmOpenStatusUpdates
+
+jobStorageSubdir :: JobId -> FilePath
+jobStorageSubdir (JobId jidParts) = "jobs" </> joinPath (map (T.unpack . textJobIdPart) (jidParts))
-prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Maybe Commit -> Job -> (FilePath -> FilePath -> m a) -> m a
-prepareJob dir mbCommit job inner = do
+
+prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Job -> (FilePath -> m a) -> m a
+prepareJob dir job inner = do
withSystemTempDirectory "minici" $ \checkoutPath -> do
- jdirCommit <- case mbCommit of
- Just commit -> do
- tree <- getCommitTree commit
- forM_ (jobContainingCheckout job) $ \(JobCheckout mbsub dest) -> do
- subtree <- maybe return (getSubtree mbCommit) mbsub $ tree
- checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
- return $ showTreeId (treeId tree) </> stringJobName (jobName job)
- Nothing -> do
- when (not $ null $ jobContainingCheckout job) $ do
- fail $ "no containing repository, can't do checkout"
- return $ stringJobName (jobName job)
-
- jdirOther <- forM (jobOtherCheckout job) $ \( EvaluatedJobRepo repo, revision, JobCheckout mbsub dest ) -> do
- commit <- readCommit repo $ fromMaybe "HEAD" revision
- tree <- getCommitTree commit
- subtree <- maybe return (getSubtree (Just commit)) mbsub $ tree
+ forM_ (jobCheckout job) $ \(JobCheckout tree mbsub dest) -> do
+ subtree <- maybe return (getSubtree Nothing . makeRelative (treeSubdir tree)) mbsub $ tree
checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
- return $ showTreeId (treeId tree)
- let jdir = dir </> "jobs" </> jdirCommit </> joinPath jdirOther
+ let jdir = dir </> jobStorageSubdir (jobId job)
liftIO $ createDirectoryIfMissing True jdir
+ inner checkoutPath
+
+getArtifactStoredPath :: (MonadIO m, MonadError Text m) => FilePath -> JobId -> ArtifactName -> m FilePath
+getArtifactStoredPath storageDir jid@(JobId ids) (ArtifactName aname) = do
+ let jdir = joinPath $ (storageDir :) $ ("jobs" :) $ map (T.unpack . textJobIdPart) ids
+ adir = jdir </> "artifacts" </> T.unpack aname
+
+ liftIO (doesDirectoryExist jdir) >>= \case
+ True -> return ()
+ False -> throwError $ "job ‘" <> textJobId jid <> "’ not yet executed"
+
+ liftIO (doesDirectoryExist adir) >>= \case
+ True -> return ()
+ False -> throwError $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
- inner checkoutPath jdir
+ return adir
-runJob :: Job -> [ArtifactOutput] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput
+getArtifactWorkPath :: (MonadIO m, MonadError Text m) => FilePath -> JobId -> ArtifactName -> m FilePath
+getArtifactWorkPath storageDir jid aname = do
+ adir <- getArtifactStoredPath storageDir jid aname
+ liftIO $ readFile (adir </> "path")
+
+copyArtifact :: (MonadIO m, MonadError Text m) => FilePath -> JobId -> ArtifactName -> FilePath -> m ()
+copyArtifact storageDir jid aname tpath = do
+ adir <- getArtifactStoredPath storageDir jid aname
+ liftIO $ copyRecursive (adir </> "data") tpath
+
+
+runJob :: Job -> [ ( ArtifactSpec, ArtifactOutput) ] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput
runJob job uses checkoutPath jdir = do
- liftIO $ forM_ uses $ \aout -> do
+ liftIO $ forM_ (filter ((`elem` jobUses job) . fst) uses) $ \( _, aout ) -> do
let target = checkoutPath </> aoutWorkPath aout
createDirectoryIfMissing True $ takeDirectory target
- copyFile (aoutStorePath aout) target
+ copyRecursive (aoutStorePath aout) target
bracket (liftIO $ openFile (jdir </> "log") WriteMode) (liftIO . hClose) $ \logs -> do
- forM_ (jobRecipe job) $ \p -> do
+ forM_ (fromMaybe [] $ jobRecipe job) $ \p -> do
(Just hin, _, _, hp) <- liftIO $ createProcess_ "" p
{ cwd = Just checkoutPath
, std_in = CreatePipe
@@ -331,26 +438,36 @@ runJob job uses checkoutPath jdir = do
| fromIntegral n == -sigINT -> throwError JobCancelled
| otherwise -> throwError JobFailed
- let adir = jdir </> "artifacts"
artifacts <- forM (jobArtifacts job) $ \( name@(ArtifactName tname), pathPattern ) -> do
+ let adir = jdir </> "artifacts" </> T.unpack tname
path <- liftIO (globDir1 pathPattern checkoutPath) >>= \case
[ path ] -> return path
found -> do
liftIO $ hPutStrLn logs $
- (if null found then "no file" else "multiple files") <> " found matching pattern `" <>
- decompile pathPattern <> "' for artifact `" <> T.unpack tname <> "'"
+ (if null found then "no file" else "multiple files") <> " found matching pattern ‘" <>
+ decompile pathPattern <> "’ for artifact ‘" <> T.unpack tname <> "’"
throwError JobFailed
- let target = adir </> T.unpack tname </> takeFileName path
+ let target = adir </> "data"
+ workPath = makeRelative checkoutPath path
liftIO $ do
createDirectoryIfMissing True $ takeDirectory target
- copyFile path target
+ copyRecursiveForce path target
+ T.writeFile (adir </> "path") $ T.pack workPath
return $ ArtifactOutput
{ aoutName = name
- , aoutWorkPath = makeRelative checkoutPath path
+ , aoutWorkPath = workPath
, aoutStorePath = target
}
+ forM_ (jobPublish job) $ \pub -> do
+ Just aout <- return $ lookup (jpArtifact pub) $ map (\aout -> ( ( jobName job, aoutName aout ), aout )) artifacts ++ uses
+ let ppath = case jpPath pub of
+ Just path
+ | hasTrailingPathSeparator path -> path </> takeFileName (aoutWorkPath aout)
+ | otherwise -> path
+ Nothing -> aoutWorkPath aout
+ copyToDestination (aoutStorePath aout) (jpDestination pub) ppath
+
return JobOutput
- { outName = jobName job
- , outArtifacts = artifacts
+ { outArtifacts = artifacts
}
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index 0447615..5d3f0f3 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -1,11 +1,15 @@
module Job.Types where
+import Data.Containers.ListUtils
+import Data.Kind
import Data.Text (Text)
import Data.Text qualified as T
import System.FilePath.Glob
import System.Process
+import {-# SOURCE #-} Config
+import Destination
import Repo
@@ -13,17 +17,22 @@ data Declared
data Evaluated
data Job' d = Job
- { jobName :: JobName
- , jobContainingCheckout :: [ JobCheckout ]
- , jobOtherCheckout :: [ ( JobRepo d, Maybe Text, JobCheckout ) ]
- , jobRecipe :: [ CreateProcess ]
+ { jobId :: JobId' d
+ , jobName :: JobName
+ , jobCheckout :: [ JobCheckout d ]
+ , jobRecipe :: Maybe [ CreateProcess ]
, jobArtifacts :: [ ( ArtifactName, Pattern ) ]
- , jobUses :: [ ( JobName, ArtifactName ) ]
+ , jobUses :: [ ArtifactSpec ]
+ , jobPublish :: [ JobPublish d ]
}
type Job = Job' Evaluated
type DeclaredJob = Job' Declared
+type family JobId' d :: Type where
+ JobId' Declared = JobName
+ JobId' Evaluated = JobId
+
data JobName = JobName Text
deriving (Eq, Ord, Show)
@@ -33,29 +42,52 @@ stringJobName (JobName name) = T.unpack name
textJobName :: JobName -> Text
textJobName (JobName name) = name
+jobRequiredArtifacts :: Job' d -> [ ArtifactSpec ]
+jobRequiredArtifacts job = nubOrd $ jobUses job ++ (map jpArtifact $ jobPublish job)
+
-data JobRepo d where
- DeclaredJobRepo :: RepoName -> JobRepo Declared
- EvaluatedJobRepo :: Repo -> JobRepo Evaluated
+type family JobRepo d :: Type where
+ JobRepo Declared = Maybe ( RepoName, Maybe Text )
+ JobRepo Evaluated = Tree
-data JobCheckout = JobCheckout
- { jcSubtree :: Maybe FilePath
+data JobCheckout d = JobCheckout
+ { jcRepo :: JobRepo d
+ , jcSubtree :: Maybe FilePath
, jcDestination :: Maybe FilePath
}
+type family JobDestination d :: Type where
+ JobDestination Declared = DestinationName
+ JobDestination Evaluated = Destination
+
+data JobPublish d = JobPublish
+ { jpArtifact :: ArtifactSpec
+ , jpDestination :: JobDestination d
+ , jpPath :: Maybe FilePath
+ }
+
data ArtifactName = ArtifactName Text
deriving (Eq, Ord, Show)
+type ArtifactSpec = ( JobName, ArtifactName )
+
data JobSet' d = JobSet
- { jobsetCommit :: Maybe Commit
+ { jobsetId :: JobSetId' d
+ , jobsetConfig :: Maybe Config
+ , jobsetCommit :: Maybe Commit
+ , jobsetExplicitlyRequested :: [ JobId' d ]
, jobsetJobsEither :: Either String [ Job' d ]
}
type JobSet = JobSet' Evaluated
type DeclaredJobSet = JobSet' Declared
+type family JobSetId' d :: Type where
+ JobSetId' Declared = ()
+ JobSetId' Evaluated = JobSetId
+
jobsetJobs :: JobSet -> [ Job ]
jobsetJobs = either (const []) id . jobsetJobsEither
@@ -63,10 +95,13 @@ jobsetJobs = either (const []) id . jobsetJobsEither
newtype JobId = JobId [ JobIdPart ]
deriving (Eq, Ord)
+newtype JobSetId = JobSetId [ JobIdPart ]
+ deriving (Eq, Ord)
+
data JobIdPart
= JobIdName JobName
- | JobIdCommit CommitId
- | JobIdTree TreeId
+ | JobIdCommit (Maybe RepoName) CommitId
+ | JobIdTree (Maybe RepoName) FilePath TreeId
deriving (Eq, Ord)
newtype JobRef = JobRef [ Text ]
@@ -75,5 +110,22 @@ newtype JobRef = JobRef [ Text ]
textJobIdPart :: JobIdPart -> Text
textJobIdPart = \case
JobIdName name -> textJobName name
- JobIdCommit cid -> textCommitId cid
- JobIdTree tid -> textTreeId tid
+ JobIdCommit _ cid -> textCommitId cid
+ JobIdTree _ _ tid -> textTreeId tid
+
+textJobId :: JobId -> Text
+textJobId (JobId ids) = T.intercalate "." $ map textJobIdPart ids
+
+parseJobRef :: Text -> JobRef
+parseJobRef = JobRef . go 0 ""
+ where
+ go :: Int -> Text -> Text -> [ Text ]
+ go plevel cur s = do
+ let bchars | plevel > 0 = [ '(', ')' ]
+ | otherwise = [ '.', '(', ')' ]
+ let ( part, rest ) = T.break (`elem` bchars) s
+ case T.uncons rest of
+ Just ( '.', rest' ) -> (cur <> part) : go plevel "" rest'
+ Just ( '(', rest' ) -> go (plevel + 1) (cur <> part) rest'
+ Just ( ')', rest' ) -> go (plevel - 1) (cur <> part) rest'
+ _ -> [ cur <> part ]
diff --git a/src/Main.hs b/src/Main.hs
index 9e9214f..647231d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -7,9 +7,11 @@ import Control.Monad.Reader
import Data.ByteString.Lazy qualified as BL
import Data.List
import Data.List.NonEmpty qualified as NE
+import Data.Maybe
import Data.Proxy
import Data.Text qualified as T
+import System.Console.ANSI
import System.Console.GetOpt
import System.Directory
import System.Environment
@@ -19,11 +21,16 @@ import System.IO
import Command
import Command.Checkout
+import Command.Extract
import Command.JobId
+import Command.Log
import Command.Run
+import Command.Shell
+import Command.Subtree
import Config
+import Destination
+import Output
import Repo
-import Terminal
import Version
data CmdlineOptions = CmdlineOptions
@@ -31,6 +38,7 @@ data CmdlineOptions = CmdlineOptions
, optShowVersion :: Bool
, optCommon :: CommonOptions
, optStorage :: Maybe FilePath
+ , optOutput :: Maybe [ OutputType ]
}
defaultCmdlineOptions :: CmdlineOptions
@@ -39,6 +47,7 @@ defaultCmdlineOptions = CmdlineOptions
, optShowVersion = False
, optCommon = defaultCommonOptions
, optStorage = Nothing
+ , optOutput = Nothing
}
options :: [ OptDescr (CmdlineOptions -> Except String CmdlineOptions) ]
@@ -57,15 +66,35 @@ options =
case span (/= ':') value of
( repo, ':' : path ) -> return opts
{ optCommon = (optCommon opts)
- { optRepo = DeclaredRepo (RepoName $ T.pack repo) path : optRepo (optCommon opts)
+ { optRepo = ( RepoName $ T.pack repo, path ) : optRepo (optCommon opts)
}
}
- _ -> throwError $ "--repo: invalid value `" <> value <> "'"
+ _ -> throwError $ "--repo: invalid value ‘" <> value <> "’"
) "<repo>:<path>")
("override or declare repo path")
+ , Option [] [ "destination" ]
+ (ReqArg (\value opts ->
+ case span (/= ':') value of
+ ( dest, ':' : url ) -> return opts
+ { optCommon = (optCommon opts)
+ { optDestination = ( DestinationName $ T.pack dest, T.pack url ) : optDestination (optCommon opts)
+ }
+ }
+ _ -> throwError $ "--repo: invalid value ‘" <> value <> "’"
+ ) "<destination>:<url>")
+ ("override or declare destination")
, Option [] [ "storage" ]
(ReqArg (\value opts -> return opts { optStorage = Just value }) "<path>")
"set storage path"
+ , Option [] [ "terminal-output" ]
+ (NoArg $ \opts -> return opts { optOutput = Just $ TerminalOutput : fromMaybe [] (optOutput opts) })
+ "use terminal-style output (default if standard output is terminal)"
+ , Option [] [ "log-output" ]
+ (OptArg (\value opts -> return opts { optOutput = Just $ LogOutput (fromMaybe "-" value) : fromMaybe [] (optOutput opts) }) "<path>")
+ "use log-style output to <path> or standard output"
+ , Option [] [ "test-output" ]
+ (OptArg (\value opts -> return opts { optOutput = Just $ TestOutput (fromMaybe "-" value) : fromMaybe [] (optOutput opts) }) "<path>")
+ "use test-style output to <path> or standard output"
]
data SomeCommandType = forall c. Command c => SC (Proxy c)
@@ -74,7 +103,11 @@ commands :: NE.NonEmpty SomeCommandType
commands =
( SC $ Proxy @RunCommand) NE.:|
[ SC $ Proxy @CheckoutCommand
+ , SC $ Proxy @ExtractCommand
, SC $ Proxy @JobIdCommand
+ , SC $ Proxy @LogCommand
+ , SC $ Proxy @ShellCommand
+ , SC $ Proxy @SubtreeCommand
]
lookupCommand :: String -> Maybe SomeCommandType
@@ -85,9 +118,10 @@ lookupCommand name = find p commands
main :: IO ()
main = do
args <- getArgs
- let ( mbConfigPath, args' ) = case args of
+ let isPathArgument path = maybe False (/= '-') (listToMaybe path) && any isPathSeparator path
+ let ( mbRootPath, args' ) = case args of
(path : rest)
- | any isPathSeparator path -> ( Just path, rest )
+ | isPathArgument path -> ( Just path, rest )
_ -> ( Nothing, args )
(opts, cmdargs) <- case getOpt RequireOrder options args' of
@@ -100,10 +134,10 @@ main = do
case foldl merge ( [], defaultCmdlineOptions ) os of
( [], opts ) -> return ( opts , cmdargs )
( errs, _ ) -> do
- hPutStrLn stderr $ unlines (reverse errs) <> "Try `minici --help' for more information."
+ hPutStrLn stderr $ unlines (reverse errs) <> "Try ‘minici --help’ for more information."
exitFailure
(_, _, errs) -> do
- hPutStrLn stderr $ concat errs <> "Try `minici --help' for more information."
+ hPutStrLn stderr $ concat errs <> "Try ‘minici --help’ for more information."
exitFailure
when (optShowHelp opts) $ do
@@ -126,13 +160,13 @@ main = do
putStrLn versionLine
exitSuccess
- ( configPath, cmdargs' ) <- case ( mbConfigPath, cmdargs ) of
+ ( rootPath, cmdargs' ) <- case ( mbRootPath, cmdargs ) of
( Just path, _ )
-> return ( Just path, cmdargs )
( _, path : rest )
- | any isPathSeparator path
+ | isPathArgument path
-> return ( Just path, rest )
- _ -> ( , cmdargs ) <$> findConfig
+ _ -> return ( Nothing , cmdargs )
( ncmd, cargs ) <- case cmdargs' of
[] -> return ( NE.head commands, [] )
@@ -141,12 +175,12 @@ main = do
| Just nc <- lookupCommand cname -> return (nc, cargs)
| otherwise -> do
hPutStr stderr $ unlines
- [ "Unknown command `" <> cname <> "'."
- , "Try `minici --help' for more information."
+ [ "Unknown command ‘" <> cname <> "’."
+ , "Try ‘minici --help’ for more information."
]
exitFailure
- runSomeCommand configPath opts ncmd cargs
+ runSomeCommand rootPath opts ncmd cargs
data FullCommandOptions c = FullCommandOptions
{ fcoSpecific :: CommandOptions c
@@ -169,11 +203,37 @@ fullCommandOptions proxy =
]
runSomeCommand :: Maybe FilePath -> CmdlineOptions -> SomeCommandType -> [ String ] -> IO ()
-runSomeCommand ciConfigPath gopts (SC tproxy) args = do
+runSomeCommand rootPath gopts (SC tproxy) args = do
+ let reportFailure err = hPutStrLn stderr err >> exitFailure
+ ( ciRootPath, ciJobRoot ) <- case rootPath of
+ Just path -> do
+ doesFileExist path >>= \case
+ True -> BL.readFile path >>= return . parseConfig >>= \case
+ Right config -> return ( path, JobRootConfig config )
+ Left err -> reportFailure $ "Failed to parse job file ‘" <> path <> "’:" <> err
+ False -> doesDirectoryExist path >>= \case
+ True -> openRepo path >>= \case
+ Just repo -> return ( path, JobRootRepo repo )
+ Nothing -> reportFailure $ "Failed to open repository ‘" <> path <> "’"
+ False -> reportFailure $ "File or directory ‘" <> path <> "’ not found"
+ Nothing -> do
+ openRepo "." >>= \case
+ Just repo -> return ( ".", JobRootRepo repo )
+ Nothing -> findConfig >>= \case
+ Just path -> BL.readFile path >>= return . parseConfig >>= \case
+ Right config -> return ( path, JobRootConfig config )
+ Left err -> reportFailure $ "Failed to parse job file ‘" <> path <> "’:" <> err
+ Nothing -> reportFailure $ "No job file or repository found"
+
+ let storageFileName = ".minici"
+ ciStorageDir = case ( optStorage gopts, ciRootPath, ciJobRoot ) of
+ ( Just path, _ , _ ) -> path
+ ( Nothing , path, JobRootConfig {} ) -> takeDirectory path </> storageFileName
+ ( Nothing , _ , JobRootRepo repo ) -> getRepoWorkDir repo </> storageFileName
+
let ciOptions = optCommon gopts
- ciStorageDir = optStorage gopts
let exitWithErrors errs = do
- hPutStrLn stderr $ concat errs <> "Try `minici " <> commandName tproxy <> " --help' for more information."
+ hPutStrLn stderr $ concat errs <> "Try ‘minici " <> commandName tproxy <> " --help’ for more information."
exitFailure
(opts, cmdargs) <- case getOpt Permute (fullCommandOptions tproxy) args of
@@ -188,34 +248,65 @@ runSomeCommand ciConfigPath gopts (SC tproxy) args = do
putStr $ usageInfo (T.unpack $ commandUsage tproxy) (fullCommandOptions tproxy)
exitSuccess
- ciConfig <- case ciConfigPath of
- Just path -> parseConfig <$> BL.readFile path
- Nothing -> return $ Left "no job file found"
-
let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
let CommandExec exec = commandExec cmd
- ciContainingRepo <- maybe (return Nothing) (openRepo . takeDirectory) ciConfigPath
+ ciContainingRepo <- case ciJobRoot of
+ JobRootRepo repo -> return (Just repo)
+ JobRootConfig _ -> openRepo $ takeDirectory ciRootPath
- let openDeclaredRepo dir decl = do
- let path = dir </> repoPath decl
+ let openDeclaredRepo dir ( name, dpath ) = do
+ let path = dir </> dpath
openRepo path >>= \case
- Just repo -> return ( repoName decl, repo )
+ Just repo -> return ( name, repo )
Nothing -> do
absPath <- makeAbsolute path
- hPutStrLn stderr $ "Failed to open repo `" <> showRepoName (repoName decl) <> "' at " <> repoPath decl <> " (" <> absPath <> ")"
+ hPutStrLn stderr $ "Failed to open repo ‘" <> showRepoName name <> "’ at " <> dpath <> " (" <> absPath <> ")"
exitFailure
cmdlineRepos <- forM (optRepo ciOptions) (openDeclaredRepo "")
- configRepos <- case ( ciConfigPath, ciConfig ) of
- ( Just path, Right config ) ->
+ configRepos <- case ciJobRoot of
+ JobRootConfig config ->
forM (configRepos config) $ \decl -> do
case lookup (repoName decl) cmdlineRepos of
Just repo -> return ( repoName decl, repo )
- Nothing -> openDeclaredRepo (takeDirectory path) decl
+ Nothing
+ | Just path <- repoPath decl
+ -> openDeclaredRepo (takeDirectory ciRootPath) ( repoName decl, path )
+
+ | otherwise
+ -> do
+ hPutStrLn stderr $ "No path defined for repo ‘" <> showRepoName (repoName decl) <> "’"
+ exitFailure
_ -> return []
- let ciOtherRepos = configRepos ++ cmdlineRepos
+ let openDeclaredDestination dir ( name, url ) = do
+ dest <- openDestination dir url
+ return ( name, dest )
+
+ cmdlineDestinations <- forM (optDestination ciOptions) (openDeclaredDestination "")
+ cfgDestinations <- case ciJobRoot of
+ JobRootConfig config -> do
+ forM (configDestinations config) $ \decl -> do
+ case lookup (destinationName decl) cmdlineDestinations of
+ Just dest -> return ( destinationName decl, dest )
+ Nothing
+ | Just url <- destinationUrl decl
+ -> openDeclaredDestination (takeDirectory ciRootPath) ( destinationName decl, url )
+
+ | otherwise
+ -> do
+ hPutStrLn stderr $ "No url defined for destination ‘" <> showDestinationName (destinationName decl) <> "’"
+ exitFailure
+ _ -> return []
- ciTerminalOutput <- initTerminalOutput
- flip runReaderT CommandInput {..} exec
+ let ciOtherRepos = configRepos ++ cmdlineRepos
+ ciDestinations = cfgDestinations ++ cmdlineDestinations
+
+ outputTypes <- case optOutput gopts of
+ Just types -> return types
+ Nothing -> hSupportsANSI stdout >>= return . \case
+ True -> [ TerminalOutput ]
+ False -> [ LogOutput "-" ]
+ withOutput outputTypes $ \ciOutput -> do
+ flip runReaderT CommandInput {..} exec
diff --git a/src/Output.hs b/src/Output.hs
new file mode 100644
index 0000000..5fa2f81
--- /dev/null
+++ b/src/Output.hs
@@ -0,0 +1,132 @@
+module Output (
+ Output,
+ OutputType(..),
+ OutputEvent(..),
+ OutputFootnote(..),
+
+ withOutput,
+ outputTerminal,
+ outputMessage,
+ outputEvent,
+ outputFootnote,
+) where
+
+import Control.Concurrent.MVar
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import Data.Text.IO qualified as T
+
+import System.IO
+
+import Job.Types
+import Terminal
+
+
+data Output = Output
+ { outLock :: MVar ()
+ , outTerminal :: Maybe TerminalOutput
+ , outLogs :: [ Handle ]
+ , outTest :: [ Handle ]
+ }
+
+data OutputType
+ = TerminalOutput
+ | LogOutput FilePath
+ | TestOutput FilePath
+ deriving (Eq, Ord)
+
+data OutputEvent
+ = OutputMessage Text
+ | TestMessage Text
+ | LogMessage Text
+ | JobStarted JobId
+ | JobFinished JobId Text
+ | JobIsDuplicate JobId Text
+ | JobPreviouslyFinished JobId Text
+ | JobWasSkipped JobId
+
+data OutputFootnote = OutputFootnote
+ { footnoteText :: Text
+ , footnoteTerminal :: Maybe TerminalFootnote
+ }
+ deriving (Eq)
+
+
+withOutput :: [ OutputType ] -> (Output -> IO a) -> IO a
+withOutput types inner = do
+ lock <- newMVar ()
+ go types (Output lock Nothing [] [])
+ where
+ go (TerminalOutput : ts) out = do
+ term <- initTerminalOutput
+ go ts out { outTerminal = Just term }
+ go (LogOutput path : ts) out = withOutputFile path $ \h -> do
+ go ts out { outLogs = h : outLogs out }
+ go (TestOutput path : ts) out = withOutputFile path $ \h -> do
+ go ts out { outTest = h : outTest out }
+ go [] out = inner out
+
+ withOutputFile "-" f = hSetBuffering stdout LineBuffering >> f stdout
+ withOutputFile path f = bracket (openFile' path) hClose f
+ openFile' path = do
+ h <- openFile path WriteMode
+ hSetBuffering h LineBuffering
+ return h
+
+
+outputTerminal :: Output -> Maybe TerminalOutput
+outputTerminal = outTerminal
+
+outStrLn :: Output -> Handle -> Text -> IO ()
+outStrLn Output {..} h text
+ | Just tout <- outTerminal, terminalHandle tout == h = do
+ void $ newLine tout text
+ | otherwise = do
+ withMVar outLock $ \_ -> do
+ T.hPutStrLn h text
+
+outputMessage :: MonadIO m => Output -> Text -> m ()
+outputMessage out msg = outputEvent out (OutputMessage msg)
+
+outputEvent :: MonadIO m => Output -> OutputEvent -> m ()
+outputEvent out@Output {..} = liftIO . \case
+ OutputMessage msg -> do
+ forM_ outTerminal $ \term -> void $ newLine term msg
+ forM_ outLogs $ \h -> outStrLn out h msg
+ forM_ outTest $ \h -> outStrLn out h ("msg " <> msg)
+
+ TestMessage msg -> do
+ forM_ outTest $ \h -> outStrLn out h msg
+
+ LogMessage msg -> do
+ forM_ outLogs $ \h -> outStrLn out h msg
+
+ JobStarted jid -> do
+ forM_ outLogs $ \h -> outStrLn out h ("Started " <> textJobId jid)
+ forM_ outTest $ \h -> outStrLn out h ("job-start " <> textJobId jid)
+
+ JobFinished jid status -> do
+ forM_ outLogs $ \h -> outStrLn out h ("Finished " <> textJobId jid <> " (" <> status <> ")")
+ forM_ outTest $ \h -> outStrLn out h ("job-finish " <> textJobId jid <> " " <> status)
+
+ JobIsDuplicate jid status -> do
+ forM_ outLogs $ \h -> outStrLn out h ("Duplicate " <> textJobId jid <> " (" <> status <> ")")
+ forM_ outTest $ \h -> outStrLn out h ("job-duplicate " <> textJobId jid <> " " <> status)
+
+ JobPreviouslyFinished jid status -> do
+ forM_ outLogs $ \h -> outStrLn out h ("Previously finished " <> textJobId jid <> " (" <> status <> ")")
+ forM_ outTest $ \h -> outStrLn out h ("job-previous " <> textJobId jid <> " " <> status)
+
+ JobWasSkipped jid -> do
+ forM_ outLogs $ \h -> outStrLn out h ("Skipped " <> textJobId jid)
+ forM_ outTest $ \h -> outStrLn out h ("job-skip " <> textJobId jid)
+
+outputFootnote :: Output -> Text -> IO OutputFootnote
+outputFootnote out@Output {..} footnoteText = do
+ footnoteTerminal <- forM outTerminal $ \term -> newFootnote term footnoteText
+ forM_ outLogs $ \h -> outStrLn out h footnoteText
+ forM_ outTest $ \h -> outStrLn out h ("note " <> footnoteText)
+ return OutputFootnote {..}
diff --git a/src/Repo.hs b/src/Repo.hs
index f22b211..c878b1e 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -1,16 +1,16 @@
module Repo (
- Repo,
+ Repo, getRepoWorkDir,
DeclaredRepo(..),
RepoName(..), textRepoName, showRepoName,
Commit, commitId,
CommitId, textCommitId, showCommitId,
- Tree, treeId, treeRepo,
+ Tree, treeId, treeRepo, treeSubdir,
TreeId, textTreeId, showTreeId,
Tag(..),
openRepo,
- readCommit, tryReadCommit,
- readTree, tryReadTree,
+ readCommit, readCommitId, tryReadCommit,
+ readTree, readTreeId, tryReadTree,
readBranch,
readTag,
listCommits,
@@ -67,9 +67,12 @@ data Repo
instance Show Repo where
show GitRepo {..} = gitDir
+getRepoWorkDir :: Repo -> FilePath
+getRepoWorkDir GitRepo {..} = takeDirectory gitDir
+
data DeclaredRepo = DeclaredRepo
{ repoName :: RepoName
- , repoPath :: FilePath
+ , repoPath :: Maybe FilePath
}
newtype RepoName = RepoName Text
@@ -98,8 +101,9 @@ data CommitDetails = CommitDetails
}
data Tree = Tree
- { treeRepo :: Repo
- , treeId :: TreeId
+ { treeRepo :: Repo -- ^ Repository in which the tree is tored
+ , treeId :: TreeId -- ^ Tree ID
+ , treeSubdir :: FilePath -- ^ Subdirectory represented by this tree (from the repo root)
}
data Tag a = Tag
@@ -169,17 +173,26 @@ mkCommit commitRepo commitId_ = do
readCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m Commit
readCommit repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadCommit repo ref
- where err = "revision `" <> T.unpack ref <> "' not found in `" <> gitDir <> "'"
+ where err = "revision ‘" <> T.unpack ref <> "’ not found in ‘" <> gitDir <> "’"
+
+readCommitId :: (MonadIO m, MonadFail m) => Repo -> CommitId -> m Commit
+readCommitId repo cid = readCommit repo (textCommitId cid)
tryReadCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Commit)
tryReadCommit repo ref = sequence . fmap (mkCommit repo . CommitId) =<< tryReadObjectId repo "commit" ref
-readTree :: (MonadIO m, MonadFail m) => Repo -> Text -> m Tree
-readTree repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadTree repo ref
- where err = "tree `" <> T.unpack ref <> "' not found in `" <> gitDir <> "'"
+readTree :: (MonadIO m, MonadFail m) => Repo -> FilePath -> Text -> m Tree
+readTree repo@GitRepo {..} subdir ref = maybe (fail err) return =<< tryReadTree repo subdir ref
+ where err = "tree ‘" <> T.unpack ref <> "’ not found in ‘" <> gitDir <> "’"
+
+readTreeId :: (MonadIO m, MonadFail m) => Repo -> FilePath -> TreeId -> m Tree
+readTreeId repo subdir tid = readTree repo subdir $ textTreeId tid
-tryReadTree :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Tree)
-tryReadTree repo ref = return . fmap (Tree repo . TreeId) =<< tryReadObjectId repo "tree" ref
+tryReadTree :: (MonadIO m, MonadFail m) => Repo -> FilePath -> Text -> m (Maybe Tree)
+tryReadTree treeRepo treeSubdir ref = do
+ fmap (fmap TreeId) (tryReadObjectId treeRepo "tree" ref) >>= \case
+ Just treeId -> return $ Just Tree {..}
+ Nothing -> return Nothing
tryReadObjectId :: (MonadIO m, MonadFail m) => Repo -> Text -> Text -> m (Maybe ByteString)
tryReadObjectId GitRepo {..} otype ref = do
@@ -252,6 +265,7 @@ getCommitDetails Commit {..} = do
Just treeId <- return $ TreeId . BC.pack <$> lookup "tree" info
let treeRepo = commitRepo
+ treeSubdir = ""
let commitTree = Tree {..}
let commitTitle = T.pack title
let commitMessage = T.pack $ unlines $ dropWhile null message
@@ -272,14 +286,19 @@ getCommitMessage = fmap commitMessage . getCommitDetails
getSubtree :: (MonadIO m, MonadFail m) => Maybe Commit -> FilePath -> Tree -> m Tree
getSubtree mbCommit path tree = liftIO $ do
let GitRepo {..} = treeRepo tree
- readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", showTreeId (treeId tree) <> ":" <> path ] "" >>= \case
- ( ExitSuccess, out, _ ) | tid : _ <- lines out -> do
- return Tree
- { treeRepo = treeRepo tree
- , treeId = TreeId (BC.pack tid)
- }
- _ -> do
- fail $ "subtree `" <> path <> "' not found" <> maybe "" (("in revision `" <>) . (<> "'") . showCommitId . commitId) mbCommit
+ dirs = dropWhile (`elem` [ ".", "/" ]) $ splitDirectories path
+
+ case dirs of
+ [] -> return tree
+ _ -> readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", showTreeId (treeId tree) <> ":" <> joinPath dirs ] "" >>= \case
+ ( ExitSuccess, out, _ ) | tid : _ <- lines out -> do
+ return Tree
+ { treeRepo = treeRepo tree
+ , treeId = TreeId (BC.pack tid)
+ , treeSubdir = joinPath $ treeSubdir tree : dirs
+ }
+ _ -> do
+ fail $ "subtree ‘" <> path <> "’ not found" <> maybe "" ((" in revision ‘" <>) . (<> "’") . showCommitId . commitId) mbCommit
checkoutAt :: (MonadIO m, MonadFail m) => Tree -> FilePath -> m ()
diff --git a/src/Terminal.hs b/src/Terminal.hs
index aa7335c..1e71559 100644
--- a/src/Terminal.hs
+++ b/src/Terminal.hs
@@ -6,6 +6,7 @@ module Terminal (
newLine,
redrawLine,
newFootnote,
+ terminalHandle,
terminalBlinkStatus,
) where
@@ -22,7 +23,8 @@ import System.IO
data TerminalOutput = TerminalOutput
- { outNumLines :: MVar Int
+ { outHandle :: Handle
+ , outNumLines :: MVar Int
, outNextFootnote :: MVar Int
, outBlinkVar :: TVar Bool
}
@@ -37,14 +39,14 @@ data TerminalLine = TerminalLine
deriving (Eq)
data TerminalFootnote = TerminalFootnote
- { footnoteLine :: TerminalLine
- , footnoteNumber :: Int
- , footnoteText :: Text
+ { tfLine :: TerminalLine
+ , tfNumber :: Int
}
deriving (Eq)
initTerminalOutput :: IO TerminalOutput
initTerminalOutput = do
+ outHandle <- return stdout
outNumLines <- newMVar 0
outNextFootnote <- newMVar 1
outBlinkVar <- newTVarIO False
@@ -57,7 +59,7 @@ newLine :: TerminalOutput -> Text -> IO TerminalLine
newLine lineOutput@TerminalOutput {..} text = do
modifyMVar outNumLines $ \lineNum -> do
T.putStrLn text
- hFlush stdout
+ hFlush outHandle
return ( lineNum + 1, TerminalLine {..} )
redrawLine :: TerminalLine -> Text -> IO ()
@@ -66,14 +68,17 @@ redrawLine TerminalLine {..} text = do
withMVar outNumLines $ \total -> do
let moveBy = total - lineNum
T.putStr $ "\ESC[s\ESC[" <> T.pack (show moveBy) <> "F" <> text <> "\ESC[u"
- hFlush stdout
+ hFlush outHandle
newFootnote :: TerminalOutput -> Text -> IO TerminalFootnote
-newFootnote tout@TerminalOutput {..} footnoteText = do
- modifyMVar outNextFootnote $ \footnoteNumber -> do
- footnoteLine <- newLine tout $ "[" <> T.pack (show footnoteNumber) <> "] " <> footnoteText
- hFlush stdout
- return ( footnoteNumber + 1, TerminalFootnote {..} )
+newFootnote tout@TerminalOutput {..} text = do
+ modifyMVar outNextFootnote $ \tfNumber -> do
+ tfLine <- newLine tout $ "[" <> T.pack (show tfNumber) <> "] " <> text
+ hFlush outHandle
+ return ( tfNumber + 1, TerminalFootnote {..} )
+
+terminalHandle :: TerminalOutput -> Handle
+terminalHandle = outHandle
terminalBlinkStatus :: TerminalOutput -> STM Bool
terminalBlinkStatus TerminalOutput {..} = readTVar outBlinkVar
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-12 18:24:20 +0000