summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Command.hs49
-rw-r--r--src/Command/Extract.hs107
-rw-r--r--src/Command/JobId.hs52
-rw-r--r--src/Command/Log.hs45
-rw-r--r--src/Command/Run.hs170
-rw-r--r--src/Command/Shell.hs46
-rw-r--r--src/Command/Subtree.hs47
-rw-r--r--src/Config.hs27
-rw-r--r--src/Eval.hs278
-rw-r--r--src/Job.hs110
-rw-r--r--src/Job/Types.hs57
-rw-r--r--src/Main.hs103
-rw-r--r--src/Output.hs117
-rw-r--r--src/Repo.hs59
-rw-r--r--src/Terminal.hs27
15 files changed, 1031 insertions, 263 deletions
diff --git a/src/Command.hs b/src/Command.hs
index 0d333e8..0b1c790 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,13 +27,12 @@ import Data.Text.IO qualified as T
import System.Console.GetOpt
import System.Exit
-import System.FilePath
import System.IO
import Config
import Eval
+import Output
import Repo
-import Terminal
data CommonOptions = CommonOptions
{ optJobs :: Int
@@ -100,34 +98,28 @@ 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
+ , 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 +132,19 @@ tryGetDefaultRepo = CommandExec $ asks ciContainingRepo
getEvalInput :: CommandExec EvalInput
getEvalInput = CommandExec $ do
+ eiJobRoot <- asks ciJobRoot
+ eiRootPath <- asks ciRootPath
+ eiCurrentIdRev <- return []
eiContainingRepo <- asks ciContainingRepo
eiOtherRepos <- asks ciOtherRepos
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..b21c63c
--- /dev/null
+++ b/src/Command/Extract.hs
@@ -0,0 +1,107 @@
+module Command.Extract (
+ ExtractCommand,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+
+import Data.Text qualified as T
+
+import System.Console.GetOpt
+import System.Directory
+import System.FilePath
+
+import Command
+import Eval
+import Job
+import Job.Types
+
+
+data ExtractCommand = ExtractCommand ExtractOptions ExtractArguments
+
+data ExtractArguments = ExtractArguments
+ { extractArtifacts :: [ ( JobRef, ArtifactName ) ]
+ , extractDestination :: FilePath
+ }
+
+instance CommandArgumentsType ExtractArguments where
+ argsFromStrings = \case
+ args@(_:_:_) -> do
+ extractArtifacts <- mapM toArtifactRef (init args)
+ extractDestination <- return (last args)
+ return ExtractArguments {..}
+ where
+ toArtifactRef tref = case T.breakOnEnd "." (T.pack tref) of
+ (jobref', aref) | Just ( jobref, '.' ) <- T.unsnoc jobref'
+ -> return ( parseJobRef jobref, ArtifactName aref )
+ _ -> throwError $ "too few parts in artifact ref ‘" <> tref <> "’"
+ _ -> throwError "too few arguments"
+
+data ExtractOptions = ExtractOptions
+ { extractForce :: Bool
+ }
+
+instance Command ExtractCommand where
+ commandName _ = "extract"
+ commandDescription _ = "Extract artifacts generated by jobs"
+
+ type CommandArguments ExtractCommand = ExtractArguments
+
+ commandUsage _ = T.pack $ unlines $
+ [ "Usage: minici jobid [<option>...] <job ref>.<artifact>... <destination>"
+ ]
+
+ type CommandOptions ExtractCommand = ExtractOptions
+ defaultCommandOptions _ = ExtractOptions
+ { extractForce = False
+ }
+
+ commandOptions _ =
+ [ Option [ 'f' ] [ "force" ]
+ (NoArg $ \opts -> opts { extractForce = True })
+ "owerwrite existing files"
+ ]
+
+ commandInit _ = ExtractCommand
+ commandExec = cmdExtract
+
+
+cmdExtract :: ExtractCommand -> CommandExec ()
+cmdExtract (ExtractCommand ExtractOptions {..} ExtractArguments {..}) = do
+ einput <- getEvalInput
+ storageDir <- getStorageDir
+
+ isdir <- liftIO (doesDirectoryExist extractDestination) >>= \case
+ True -> return True
+ False -> case extractArtifacts of
+ _:_:_ -> tfail $ "destination ‘" <> T.pack extractDestination <> "’ is not a directory"
+ _ -> return False
+
+ forM_ extractArtifacts $ \( ref, ArtifactName aname ) -> do
+ jid@(JobId ids) <- either (tfail . textEvalError) (return . jobId . fst) =<<
+ liftIO (runEval (evalJobReference ref) einput)
+
+ let jdir = joinPath $ (storageDir :) $ ("jobs" :) $ map (T.unpack . textJobIdPart) ids
+ adir = jdir </> "artifacts" </> T.unpack aname
+
+ liftIO (doesDirectoryExist jdir) >>= \case
+ True -> return ()
+ False -> tfail $ "job ‘" <> textJobId jid <> "’ not yet executed"
+
+ liftIO (doesDirectoryExist adir) >>= \case
+ True -> return ()
+ False -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
+
+ afile <- liftIO (listDirectory adir) >>= \case
+ [ file ] -> return file
+ [] -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
+ _:_:_ -> tfail $ "unexpected files in ‘" <> T.pack adir <> "’"
+
+ let tpath | isdir = extractDestination </> afile
+ | otherwise = extractDestination
+ when (not extractForce) $ do
+ liftIO (doesPathExist tpath) >>= \case
+ True -> tfail $ "destination ‘" <> T.pack tpath <> "’ already exists"
+ False -> return ()
+ liftIO $ copyRecursiveForce (adir </> afile) tpath
diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs
index 9f531d6..096ed56 100644
--- a/src/Command/JobId.hs
+++ b/src/Command/JobId.hs
@@ -2,18 +2,26 @@ module Command.JobId (
JobIdCommand,
) where
+import Control.Monad
import Control.Monad.IO.Class
import Data.Text (Text)
import Data.Text qualified as T
-import Data.Text.IO qualified as T
+
+import System.Console.GetOpt
import Command
import Eval
import Job.Types
+import Output
+import Repo
+
+data JobIdCommand = JobIdCommand JobIdOptions JobRef
-data JobIdCommand = JobIdCommand JobRef
+data JobIdOptions = JobIdOptions
+ { joVerbose :: Bool
+ }
instance Command JobIdCommand where
commandName _ = "jobid"
@@ -22,18 +30,44 @@ instance Command JobIdCommand where
type CommandArguments JobIdCommand = Text
commandUsage _ = T.pack $ unlines $
- [ "Usage: minici jobid <job ref>"
+ [ "Usage: minici jobid [<option>...] <job ref>"
+ ]
+
+ type CommandOptions JobIdCommand = JobIdOptions
+ defaultCommandOptions _ = JobIdOptions
+ { joVerbose = False
+ }
+
+ commandOptions _ =
+ [ Option [ 'v' ] [ "verbose" ]
+ (NoArg $ \opts -> opts { joVerbose = True })
+ "show detals of the ID"
]
- commandInit _ _ = JobIdCommand . JobRef . T.splitOn "."
+ commandInit _ opts = JobIdCommand opts . parseJobRef
commandExec = cmdJobId
cmdJobId :: JobIdCommand -> CommandExec ()
-cmdJobId (JobIdCommand ref) = do
- config <- getConfig
+cmdJobId (JobIdCommand JobIdOptions {..} ref) = do
einput <- getEvalInput
- JobId ids <- either (tfail . textEvalError) return =<<
- liftIO (runEval (evalJobReference config ref) einput)
+ out <- getOutput
+ JobId ids <- either (tfail . textEvalError) (return . jobId . fst) =<<
+ 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..e48ce8f
--- /dev/null
+++ b/src/Command/Log.hs
@@ -0,0 +1,45 @@
+module Command.Log (
+ LogCommand,
+) where
+
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+import Data.Text.Lazy.IO qualified as TL
+
+import System.FilePath
+
+import Command
+import Eval
+import Job
+import Job.Types
+import Output
+
+
+data LogCommand = LogCommand JobRef
+
+instance Command LogCommand where
+ commandName _ = "log"
+ commandDescription _ = "Show log for the given job"
+
+ type CommandArguments LogCommand = Text
+
+ commandUsage _ = T.pack $ unlines $
+ [ "Usage: minici log <job ref>"
+ ]
+
+ commandInit _ _ = LogCommand . parseJobRef
+ commandExec = cmdLog
+
+
+cmdLog :: LogCommand -> CommandExec ()
+cmdLog (LogCommand ref) = do
+ einput <- getEvalInput
+ jid <- either (tfail . textEvalError) (return . jobId . fst) =<<
+ 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..a80e15d 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -10,6 +10,7 @@ import Control.Monad.IO.Class
import Data.Either
import Data.List
+import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
@@ -22,6 +23,8 @@ import Command
import Config
import Eval
import Job
+import Job.Types
+import Output
import Repo
import Terminal
@@ -123,26 +126,76 @@ mergeSources sources = do
argumentJobSource :: [ JobName ] -> CommandExec JobSource
argumentJobSource [] = emptyJobSource
argumentJobSource names = do
- config <- getConfig
- einput <- getEvalInput
- jobsetJobsEither <- fmap Right $ forM names $ \name ->
+ ( config, jcommit ) <- getJobRoot >>= \case
+ JobRootConfig config -> do
+ commit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo
+ return ( config, commit )
+ JobRootRepo repo -> do
+ commit <- createWipCommit repo
+ config <- either fail return =<< loadConfigForCommit =<< getCommitTree commit
+ return ( config, Just commit )
+
+ jobtree <- case jcommit of
+ Just commit -> (: []) <$> getCommitTree commit
+ Nothing -> return []
+ let cidPart = map (JobIdTree Nothing "" . treeId) jobtree
+ forM_ names $ \name ->
case find ((name ==) . jobName) (configJobs config) of
- Just job -> return job
- Nothing -> tfail $ "job `" <> textJobName name <> "' not found"
- jobsetCommit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo
- oneshotJobSource [ evalJobSet einput JobSet {..} ]
+ Just _ -> return ()
+ Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found"
+
+ jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do
+ fullSet <- evalJobSet (map ( Nothing, ) jobtree) JobSet
+ { jobsetId = ()
+ , jobsetCommit = jcommit
+ , jobsetJobsEither = Right (configJobs config)
+ }
+ let selectedSet = fullSet { jobsetJobsEither = fmap (filter ((`elem` names) . jobName)) (jobsetJobsEither fullSet) }
+ fillInDependencies selectedSet
+ oneshotJobSource [ jset ]
+
+refJobSource :: [ JobRef ] -> CommandExec JobSource
+refJobSource [] = emptyJobSource
+refJobSource refs = do
+ jobs <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReference refs)
+ sets <- cmdEvalWith id $ do
+ forM jobs $ \( sid, js ) -> do
+ fillInDependencies $ JobSet sid Nothing (Right $ reverse js)
+ oneshotJobSource sets
+ where
+ addJobToList :: [ ( JobSetId, [ Job ] ) ] -> ( Job, JobSetId ) -> [ ( JobSetId, [ Job ] ) ]
+ addJobToList (( sid, js ) : rest ) ( job, jsid )
+ | sid == jsid = ( sid, job : js ) : rest
+ | otherwise = ( sid, js ) : addJobToList rest ( job, jsid )
+ addJobToList [] ( job, jsid ) = [ ( jsid, [ job ] ) ]
+
+loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet
+loadJobSetFromRoot root commit = case root of
+ JobRootRepo _ -> loadJobSetForCommit commit
+ JobRootConfig config -> return JobSet
+ { jobsetId = ()
+ , jobsetCommit = Just commit
+ , jobsetJobsEither = Right $ configJobs config
+ }
rangeSource :: Text -> Text -> CommandExec JobSource
rangeSource base tip = do
+ root <- getJobRoot
repo <- getDefaultRepo
- einput <- getEvalInput
commits <- listCommits repo (base <> ".." <> tip)
- oneshotJobSource . map (evalJobSet einput) =<< mapM loadJobSetForCommit commits
+ jobsets <- forM commits $ \commit -> do
+ tree <- getCommitTree commit
+ cmdEvalWith (\ei -> ei
+ { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev ei
+ }) . evalJobSet [ ( Nothing, tree) ] =<< loadJobSetFromRoot root commit
+ oneshotJobSource jobsets
+
watchBranchSource :: Text -> CommandExec JobSource
watchBranchSource branch = do
+ root <- getJobRoot
repo <- getDefaultRepo
- einput <- getEvalInput
+ einputBase <- getEvalInput
getCurrentTip <- watchBranch repo branch
let go prev tmvar = do
cur <- atomically $ do
@@ -153,7 +206,13 @@ watchBranchSource branch = do
Nothing -> retry
commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur))
- jobsets <- map (evalJobSet einput) <$> mapM loadJobSetForCommit commits
+ jobsets <- forM commits $ \commit -> do
+ tree <- getCommitTree commit
+ let einput = einputBase
+ { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase
+ }
+ either (fail . T.unpack . textEvalError) return =<<
+ flip runEval einput . evalJobSet [ ( Nothing, tree ) ] =<< loadJobSetFromRoot root commit
nextvar <- newEmptyTMVarIO
atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar )
go cur nextvar
@@ -164,20 +223,26 @@ watchBranchSource branch = do
Just commit ->
void $ forkIO $ go commit tmvar
Nothing -> do
- T.hPutStrLn stderr $ "Branch `" <> branch <> "' not found"
+ T.hPutStrLn stderr $ "Branch ‘" <> branch <> "’ not found"
atomically $ putTMVar tmvar Nothing
return $ JobSource tmvar
watchTagSource :: Pattern -> CommandExec JobSource
watchTagSource pat = do
+ root <- getJobRoot
chan <- watchTags =<< getDefaultRepo
- einput <- getEvalInput
+ einputBase <- getEvalInput
let go tmvar = do
tag <- atomically $ readTChan chan
if match pat $ T.unpack $ tagTag tag
then do
- jobset <- evalJobSet einput <$> loadJobSetForCommit (tagObject tag)
+ tree <- getCommitTree $ tagObject tag
+ let einput = einputBase
+ { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase
+ }
+ jobset <- either (fail . T.unpack . textEvalError) return =<<
+ flip runEval einput . evalJobSet [ ( Nothing, tree ) ] =<< loadJobSetFromRoot root (tagObject tag)
nextvar <- newEmptyTMVarIO
atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar )
go nextvar
@@ -192,33 +257,41 @@ watchTagSource pat = do
cmdRun :: RunCommand -> CommandExec ()
cmdRun (RunCommand RunOptions {..} args) = do
CommonOptions {..} <- getCommonOptions
- tout <- getTerminalOutput
+ output <- getOutput
storageDir <- getStorageDir
( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence
[ forM roRanges $ \range -> case T.splitOn ".." range of
- [ base, tip ] -> return $ Left ( Just base, tip )
+ [ base, tip ]
+ | not (T.null base) && not (T.null tip)
+ -> return $ Left ( Just base, tip )
_ -> tfail $ "invalid range: " <> range
, forM roSinceUpstream $ return . Left . ( Nothing, )
, forM args $ \arg -> case T.splitOn ".." arg of
- [ base, tip ] -> return $ Left ( Just base, tip )
- [ _ ] -> do
- config <- getConfig
- if any ((JobName arg ==) . jobName) (configJobs config)
- then return $ Right $ JobName arg
- else do
- liftIO $ T.hPutStrLn stderr $ "standalone `" <> arg <> "' argument deprecated, use `--since-upstream=" <> arg <> "' instead"
- return $ Left ( Nothing, arg )
+ [ base, tip ]
+ | not (T.null base) && not (T.null tip)
+ -> return $ Left ( Just base, tip )
+ [ _ ] -> return $ Right arg
_ -> tfail $ "invalid argument: " <> arg
]
- argumentJobs <- argumentJobSource jobOptions
+ let ( refOptions, nameOptions ) = partition (T.elem '.') jobOptions
+
+ argumentJobs <- argumentJobSource $ map JobName nameOptions
+ refJobs <- refJobSource $ map parseJobRef refOptions
- let rangeOptions'
- | null rangeOptions, null roNewCommitsOn, null roNewTags, null jobOptions = [ ( Nothing, "HEAD" ) ]
- | otherwise = rangeOptions
+ defaultSource <- getJobRoot >>= \case
+ _ | not (null rangeOptions && null roNewCommitsOn && null roNewTags && null jobOptions) -> do
+ emptyJobSource
- ranges <- forM rangeOptions' $ \( mbBase, paramTip ) -> do
+ JobRootRepo repo -> do
+ Just base <- findUpstreamRef repo "HEAD"
+ rangeSource base "HEAD"
+
+ JobRootConfig config -> do
+ argumentJobSource (jobName <$> configJobs config)
+
+ ranges <- forM rangeOptions $ \( mbBase, paramTip ) -> do
( base, tip ) <- case mbBase of
Just base -> return ( base, paramTip )
Nothing -> do
@@ -232,8 +305,8 @@ cmdRun (RunCommand RunOptions {..} args) = do
liftIO $ do
mngr <- newJobManager storageDir optJobs
- source <- mergeSources $ concat [ [ argumentJobs ], ranges, branches, tags ]
- headerLine <- newLine tout ""
+ source <- mergeSources $ concat [ [ defaultSource, argumentJobs, refJobs ], ranges, branches, tags ]
+ mbHeaderLine <- mapM (flip newLine "") (outputTerminal output)
threadCount <- newTVarIO (0 :: Int)
let changeCount f = atomically $ do
@@ -248,9 +321,10 @@ cmdRun (RunCommand RunOptions {..} args) = do
loop pnames (Just ( jobset : rest, next )) = do
let names = nub $ (pnames ++) $ map jobName $ jobsetJobs jobset
when (names /= pnames) $ do
- redrawLine headerLine $ T.concat $
- T.replicate (8 + 50) " " :
- map ((" " <>) . fitToLength 7 . textJobName) names
+ forM_ mbHeaderLine $ \headerLine -> do
+ redrawLine headerLine $ T.concat $
+ T.replicate (8 + 50) " " :
+ map ((" " <>) . fitToLength 7 . textJobName) names
let commit = jobsetCommit jobset
shortCid = T.pack $ take 7 $ maybe (repeat ' ') (showCommitId . commitId) commit
@@ -258,23 +332,30 @@ cmdRun (RunCommand RunOptions {..} args) = do
case jobsetJobsEither jobset of
Right jobs -> do
- outs <- runJobs mngr tout commit jobs
+ outs <- runJobs mngr output jobs
let findJob name = snd <$> find ((name ==) . jobName . fst) outs
- line <- newLine tout ""
+ statuses = map findJob names
+ forM_ (outputTerminal output) $ \tout -> do
+ line <- newLine tout ""
+ void $ forkIO $ do
+ displayStatusLine tout line shortCid (" " <> shortDesc) statuses
mask $ \restore -> do
changeCount (+ 1)
- void $ forkIO $ (>> changeCount (subtract 1)) $
- try @SomeException $ restore $ do
- displayStatusLine tout line shortCid (" " <> shortDesc) $ map findJob names
+ void $ forkIO $ do
+ void $ try @SomeException $ restore $ waitForJobStatuses statuses
+ changeCount (subtract 1)
Left err -> do
- void $ newLine tout $
+ forM_ (outputTerminal output) $ flip newLine $
"\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m"
+ outputEvent output $ TestMessage $ "jobset-fail " <> T.pack err
+ outputEvent output $ LogMessage $ "Jobset failed: " <> shortCid <> " " <> T.pack err
loop names (Just ( rest, next ))
handle @SomeException (\_ -> cancelAllJobs mngr) $ do
loop [] =<< atomically (takeJobSource source)
waitForJobs
waitForJobs
+ outputEvent output $ TestMessage "run-finish"
fitToLength :: Int -> Text -> Text
@@ -288,7 +369,7 @@ showStatus blink = \case
JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
JobSkipped -> "\ESC[0m-\ESC[0m "
JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m "
- JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (show (footnoteNumber fnote)) <> "]") <> "\ESC[0m"
+ JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (maybe "?" (show . tfNumber) (footnoteTerminal fnote)) <> "]") <> "\ESC[0m"
JobFailed -> "\ESC[91m✗\ESC[0m "
JobCancelled -> "\ESC[0mC\ESC[0m "
JobDone _ -> "\ESC[92m✓\ESC[0m "
@@ -320,3 +401,10 @@ displayStatusLine tout line prefix1 prefix2 statuses = do
if all (maybe True jobStatusFinished) ss
then return ()
else go cur
+
+waitForJobStatuses :: [ Maybe (TVar (JobStatus a)) ] -> IO ()
+waitForJobStatuses mbstatuses = do
+ let statuses = catMaybes mbstatuses
+ atomically $ do
+ ss <- mapM readTVar statuses
+ when (any (not . jobStatusFinished) ss) retry
diff --git a/src/Command/Shell.hs b/src/Command/Shell.hs
new file mode 100644
index 0000000..4cd2b7e
--- /dev/null
+++ b/src/Command/Shell.hs
@@ -0,0 +1,46 @@
+module Command.Shell (
+ ShellCommand,
+) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+
+import Data.Maybe
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import System.Environment
+import System.Process hiding (ShellCommand)
+
+import Command
+import Eval
+import Job
+import Job.Types
+
+
+data ShellCommand = ShellCommand JobRef
+
+instance Command ShellCommand where
+ commandName _ = "shell"
+ commandDescription _ = "Open a shell prepared for given job"
+
+ type CommandArguments ShellCommand = Text
+
+ commandUsage _ = T.unlines $
+ [ "Usage: minici shell <job ref>"
+ ]
+
+ commandInit _ _ = ShellCommand . parseJobRef
+ commandExec = cmdShell
+
+
+cmdShell :: ShellCommand -> CommandExec ()
+cmdShell (ShellCommand ref) = do
+ einput <- getEvalInput
+ job <- either (tfail . textEvalError) (return . fst) =<<
+ 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..ea2907c 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
@@ -34,6 +34,11 @@ configFileName :: FilePath
configFileName = "minici.yaml"
+data JobRoot
+ = JobRootRepo Repo
+ | JobRootConfig Config
+
+
data Config = Config
{ configJobs :: [ DeclaredJob ]
, configRepos :: [ DeclaredRepo ]
@@ -72,11 +77,12 @@ instance FromYAML Config where
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
+ jobCheckout <- choice
[ parseSingleCheckout =<< j .: "checkout"
, parseMultipleCheckouts =<< j .: "checkout"
, withNull "no checkout" (return []) =<< j .: "checkout"
- , return [ Left $ JobCheckout Nothing Nothing ]
+ , return [ JobCheckout Nothing Nothing Nothing ]
]
jobRecipe <- choice
[ cabalJob =<< j .: "cabal"
@@ -86,18 +92,18 @@ parseJob name node = flip (withMap "Job") node $ \j -> do
jobUses <- maybe (return []) parseUses =<< j .:? "uses"
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]
@@ -167,6 +173,7 @@ loadJobSetForCommit :: (MonadIO m, MonadFail m) => Commit -> m DeclaredJobSet
loadJobSetForCommit commit = return . toJobSet =<< loadConfigForCommit =<< getCommitTree commit
where
toJobSet configEither = JobSet
- { jobsetCommit = Just commit
+ { jobsetId = ()
+ , jobsetCommit = Just commit
, jobsetJobsEither = fmap configJobs configEither
}
diff --git a/src/Eval.hs b/src/Eval.hs
index 1828468..67fea8d 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -6,23 +6,32 @@ 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 Job.Types
import Repo
data EvalInput = EvalInput
- { eiContainingRepo :: Maybe Repo
+ { eiJobRoot :: JobRoot
+ , eiRootPath :: FilePath
+ , eiCurrentIdRev :: [ JobIdPart ]
+ , eiContainingRepo :: Maybe Repo
, eiOtherRepos :: [ ( RepoName, Repo ) ]
}
@@ -39,73 +48,220 @@ 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 _ _ = []
+
+isDefaultRepoMissingInId :: DeclaredJob -> Eval Bool
+isDefaultRepoMissingInId djob
+ | all (isJust . jcRepo) (jobCheckout djob) = return False
+ | otherwise = asks (not . any matches . eiCurrentIdRev)
+ where
+ matches (JobIdName _) = False
+ matches (JobIdCommit rname _) = isNothing rname
+ matches (JobIdTree rname _ _) = isNothing rname
+
+collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), FilePath ) ]
+collectOtherRepos dset decl = do
+ let dependencies = map fst $ jobUses decl
+ dependencyRepos <- forM dependencies $ \name -> do
+ jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset
+ job <- maybe (throwError $ OtherEvalError $ "job ‘" <> textJobName name <> "’ not found") return . find ((name ==) . jobName) $ jobs
+ return $ jobCheckout job
+
+ missingDefault <- isDefaultRepoMissingInId decl
+
+ let checkouts =
+ (if missingDefault then id else (filter (isJust . jcRepo))) $
+ concat
+ [ jobCheckout decl
+ , concat dependencyRepos
+ ]
+ let commonSubdir reporev = joinPath $ foldr1 commonPrefix $
+ map (maybe [] splitDirectories . jcSubtree) . filter ((reporev ==) . jcRepo) $ checkouts
+ return $ map (\r -> ( r, commonSubdir r )) . nub . map jcRepo $ checkouts
+
-evalJobSet :: EvalInput -> DeclaredJobSet -> JobSet
-evalJobSet ei decl = do
- JobSet
- { jobsetCommit = jobsetCommit decl
- , jobsetJobsEither = join $
- fmap (sequence . map (runExceptStr . evalJob ei)) $
- jobsetJobsEither decl
+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
+ ]
+ }
+
+ let otherRepoIds = map (\( repo, ( subtree, tree )) -> JobIdTree (fst <$> repo) subtree (treeId tree)) otherRepoTrees
+ 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
+ }
+ , JobSetId $ reverse $ reverse otherRepoIds ++ eiCurrentIdRev
+ )
+
+evalJobSet :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet
+evalJobSet revisionOverrides decl = do
+ EvalInput {..} <- ask
+ jobs <- fmap (fmap (map fst))
+ $ either (return . Left) (handleToEither . mapM (evalJob revisionOverrides decl))
+ $ jobsetJobsEither decl
+ return JobSet
+ { jobsetId = JobSetId $ reverse $ eiCurrentIdRev
+ , jobsetCommit = jobsetCommit decl
+ , 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 ( Job, JobSetId )
+canonicalJobName (r : rs) config mbDefaultRepo = do
let name = JobName r
+ dset = JobSet () Nothing $ 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 ) -> 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 ()
+ evalJob (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset djob
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 ( Job, JobSetId )
+canonicalCommitConfig rs repo = do
+ ( tree, rs' ) <- readTreeFromIdRef rs "" repo
+ config <- either fail return =<< loadConfigForCommit tree
+ local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $
+ canonicalJobName rs' config (Just tree)
+
+evalJobReference :: JobRef -> Eval ( Job, JobSetId )
+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 () 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
- (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 }) $ 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)
+ origJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither jset
+ declJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset
+ deps <- gather declJobs S.empty (map jobName origJobs)
+
+ jobs <- local (\ei -> ei { eiCurrentIdRev = idRev }) $ do
+ fmap catMaybes $ forM declJobs $ \djob -> if
+ | Just job <- find ((jobName djob ==) . jobName) origJobs
+ -> return (Just job)
+
+ | jobName djob `S.member` deps
+ -> Just . fst <$> evalJob otherRepos dset djob
+
+ | otherwise
+ -> return 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) ++ rest
+
+ | otherwise
+ = throwError $ OtherEvalError $ "dependency ‘" <> textJobName name <> "’ not found"
+
+ gather _ cur [] = return cur
diff --git a/src/Job.hs b/src/Job.hs
index a9effba..21d878c 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -8,6 +8,11 @@ module Job (
jobStatusFinished, jobStatusFailed,
JobManager(..), newJobManager, cancelAllJobs,
runJobs,
+ prepareJob,
+ jobStorageSubdir,
+
+ copyRecursive,
+ copyRecursiveForce,
) where
import Control.Concurrent
@@ -38,8 +43,8 @@ import System.Posix.Signals
import System.Process
import Job.Types
+import Output
import Repo
-import Terminal
data JobOutput = JobOutput
@@ -61,7 +66,7 @@ data JobStatus a = JobQueued
| JobWaiting [JobName]
| JobRunning
| JobSkipped
- | JobError TerminalFootnote
+ | JobError OutputFootnote
| JobFailed
| JobCancelled
| JobDone a
@@ -89,11 +94,16 @@ textJobStatus = \case
JobWaiting _ -> "waiting"
JobRunning -> "running"
JobSkipped -> "skipped"
- JobError err -> "error\n" <> footnoteText err
+ JobError _ -> "error"
JobFailed -> "failed"
JobCancelled -> "cancelled"
JobDone _ -> "done"
+textJobStatusDetails :: JobStatus a -> Text
+textJobStatusDetails = \case
+ JobError err -> footnoteText err <> "\n"
+ _ -> ""
+
data JobManager = JobManager
{ jmSemaphore :: TVar Int
@@ -181,30 +191,30 @@ 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 ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
+runJobs mngr@JobManager {..} tout jobs = 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
+ outputEvent tout $ JobFinished (jobId job) (textJobStatus status)
handle handler $ do
res <- runExceptT $ do
duplicate <- liftIO $ atomically $ do
@@ -219,7 +229,8 @@ runJobs mngr@JobManager {..} tout commit jobs = 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
+ liftIO $ outputEvent tout $ JobStarted (jobId job)
+ prepareJob jmDataDir job $ \checkoutPath jdir -> do
updateStatusFile (jdir </> "status") outVar
JobDone <$> runJob job uses checkoutPath jdir
@@ -239,17 +250,18 @@ runJobs mngr@JobManager {..} tout commit jobs = do
liftIO wait
atomically $ writeTVar outVar $ either id id res
+ outputEvent tout $ JobFinished (jobId job) (textJobStatus $ either id id res)
return $ map (\( job, _, var ) -> ( job, var )) results
waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>
- TerminalOutput ->
+ Output ->
Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ]
waitForUsedArtifacts tout job results outVar = do
origState <- liftIO $ atomically $ readTVar outVar
ujobs <- forM (jobUses job) $ \(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
@@ -268,7 +280,7 @@ waitForUsedArtifacts tout job results outVar = 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")
+ Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found")
_ -> throwError JobSkipped
updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m ()
@@ -279,34 +291,21 @@ updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing
status <- readTVar outVar
when (Just status == prev) retry
return status
- T.writeFile path $ textJobStatus status <> "\n"
+ T.writeFile path $ textJobStatus status <> "\n" <> textJobStatusDetails status
when (not (jobStatusFinished status)) $ loop $ Just status
-prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Maybe Commit -> Job -> (FilePath -> FilePath -> m a) -> m a
-prepareJob dir mbCommit job inner = do
+jobStorageSubdir :: JobId -> FilePath
+jobStorageSubdir (JobId jidParts) = "jobs" </> joinPath (map (T.unpack . textJobIdPart) (jidParts))
+
+prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Job -> (FilePath -> 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 jdir
runJob :: Job -> [ArtifactOutput] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput
@@ -314,7 +313,7 @@ runJob job uses checkoutPath jdir = do
liftIO $ forM_ 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
@@ -337,13 +336,13 @@ runJob job uses checkoutPath jdir = do
[ 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
liftIO $ do
createDirectoryIfMissing True $ takeDirectory target
- copyFile path target
+ copyRecursiveForce path target
return $ ArtifactOutput
{ aoutName = name
, aoutWorkPath = makeRelative checkoutPath path
@@ -354,3 +353,22 @@ runJob job uses checkoutPath jdir = do
{ outName = jobName job
, outArtifacts = artifacts
}
+
+
+copyRecursive :: FilePath -> FilePath -> IO ()
+copyRecursive from to = do
+ doesDirectoryExist from >>= \case
+ False -> do
+ copyFile 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/Types.hs b/src/Job/Types.hs
index 0447615..ad575a1 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -1,5 +1,6 @@
module Job.Types where
+import Data.Kind
import Data.Text (Text)
import Data.Text qualified as T
@@ -13,9 +14,9 @@ data Declared
data Evaluated
data Job' d = Job
- { jobName :: JobName
- , jobContainingCheckout :: [ JobCheckout ]
- , jobOtherCheckout :: [ ( JobRepo d, Maybe Text, JobCheckout ) ]
+ { jobId :: JobId' d
+ , jobName :: JobName
+ , jobCheckout :: [ JobCheckout d ]
, jobRecipe :: [ CreateProcess ]
, jobArtifacts :: [ ( ArtifactName, Pattern ) ]
, jobUses :: [ ( JobName, ArtifactName ) ]
@@ -24,6 +25,10 @@ data Job' d = Job
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)
@@ -34,12 +39,13 @@ textJobName :: JobName -> Text
textJobName (JobName name) = name
-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
}
@@ -49,13 +55,18 @@ data ArtifactName = ArtifactName Text
data JobSet' d = JobSet
- { jobsetCommit :: Maybe Commit
+ { jobsetId :: JobSetId' d
+ , jobsetCommit :: Maybe Commit
, 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 +74,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 +89,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..83b0ab3 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,15 @@ 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 Output
import Repo
-import Terminal
import Version
data CmdlineOptions = CmdlineOptions
@@ -31,6 +37,7 @@ data CmdlineOptions = CmdlineOptions
, optShowVersion :: Bool
, optCommon :: CommonOptions
, optStorage :: Maybe FilePath
+ , optOutput :: Maybe [ OutputType ]
}
defaultCmdlineOptions :: CmdlineOptions
@@ -39,6 +46,7 @@ defaultCmdlineOptions = CmdlineOptions
, optShowVersion = False
, optCommon = defaultCommonOptions
, optStorage = Nothing
+ , optOutput = Nothing
}
options :: [ OptDescr (CmdlineOptions -> Except String CmdlineOptions) ]
@@ -60,12 +68,21 @@ options =
{ optRepo = DeclaredRepo (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 [] [ "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 +91,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 +106,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 +122,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 +148,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 +163,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 +191,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,14 +236,12 @@ 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
@@ -203,19 +249,24 @@ runSomeCommand ciConfigPath gopts (SC tproxy) args = do
Just repo -> return ( repoName decl, 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 (repoName decl) <> "’ at " <> repoPath decl <> " (" <> 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 -> openDeclaredRepo (takeDirectory ciRootPath) decl
_ -> return []
let ciOtherRepos = configRepos ++ cmdlineRepos
- ciTerminalOutput <- initTerminalOutput
- flip runReaderT CommandInput {..} exec
+ 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..64704ec
--- /dev/null
+++ b/src/Output.hs
@@ -0,0 +1,117 @@
+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
+
+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)
+
+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..09e577b 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,6 +67,9 @@ data Repo
instance Show Repo where
show GitRepo {..} = gitDir
+getRepoWorkDir :: Repo -> FilePath
+getRepoWorkDir GitRepo {..} = takeDirectory gitDir
+
data DeclaredRepo = DeclaredRepo
{ repoName :: RepoName
, repoPath :: FilePath
@@ -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-07-10 04:30:08 +0000