summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Command.hs7
-rw-r--r--src/Command/Extract.hs43
-rw-r--r--src/Command/Run.hs106
-rw-r--r--src/Command/Shell.hs46
-rw-r--r--src/Command/Subtree.hs47
-rw-r--r--src/Config.hs72
-rw-r--r--src/Config.hs-boot3
-rw-r--r--src/Destination.hs54
-rw-r--r--src/Eval.hs271
-rw-r--r--src/FileUtils.c18
-rw-r--r--src/FileUtils.hs69
-rw-r--r--src/Job.hs233
-rw-r--r--src/Job/Types.hs35
-rw-r--r--src/Main.hs56
-rw-r--r--src/Output.hs15
-rw-r--r--src/Repo.hs34
16 files changed, 911 insertions, 198 deletions
diff --git a/src/Command.hs b/src/Command.hs
index 0b1c790..1ef52ed 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -30,19 +30,22 @@ import System.Exit
import System.IO
import Config
+import Destination
import Eval
import Output
import Repo
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
@@ -102,6 +105,7 @@ data CommandInput = CommandInput
, ciJobRoot :: JobRoot
, ciContainingRepo :: Maybe Repo
, ciOtherRepos :: [ ( RepoName, Repo ) ]
+ , ciDestinations :: [ ( DestinationName, Destination ) ]
, ciOutput :: Output
, ciStorageDir :: FilePath
}
@@ -137,6 +141,7 @@ getEvalInput = CommandExec $ do
eiCurrentIdRev <- return []
eiContainingRepo <- asks ciContainingRepo
eiOtherRepos <- asks ciOtherRepos
+ eiDestinations <- asks ciDestinations
return EvalInput {..}
cmdEvalWith :: (EvalInput -> EvalInput) -> Eval a -> CommandExec a
diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs
index 8a0a035..8dee537 100644
--- a/src/Command/Extract.hs
+++ b/src/Command/Extract.hs
@@ -14,6 +14,7 @@ import System.FilePath
import Command
import Eval
+import Job
import Job.Types
@@ -77,30 +78,22 @@ cmdExtract (ExtractCommand ExtractOptions {..} ExtractArguments {..}) = do
_:_:_ -> tfail $ "destination ‘" <> T.pack extractDestination <> "’ is not a directory"
_ -> return False
- forM_ extractArtifacts $ \( ref, ArtifactName aname ) -> do
- jid@(JobId ids) <- either (tfail . textEvalError) (return . jobId) =<<
+ forM_ extractArtifacts $ \( ref, aname ) -> do
+ jid <- either (tfail . textEvalError) (return . jobId) =<<
liftIO (runEval (evalJobReference ref) einput)
- let jdir = joinPath $ (storageDir :) $ ("jobs" :) $ map (T.unpack . textJobIdPart) ids
- adir = jdir </> "artifacts" </> T.unpack aname
-
- liftIO (doesDirectoryExist jdir) >>= \case
- True -> return ()
- False -> tfail $ "job ‘" <> textJobId jid <> "’ not yet executed"
-
- liftIO (doesDirectoryExist adir) >>= \case
- True -> return ()
- False -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
-
- afile <- liftIO (listDirectory adir) >>= \case
- [ file ] -> return file
- [] -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
- _:_:_ -> tfail $ "unexpected files in ‘" <> T.pack adir <> "’"
-
- let tpath | isdir = extractDestination </> afile
- | otherwise = extractDestination
- when (not extractForce) $ do
- liftIO (doesPathExist tpath) >>= \case
- True -> tfail $ "destination ‘" <> T.pack tpath <> "’ already exists"
- False -> return ()
- liftIO $ copyFile (adir </> afile) tpath
+ tpath <- if
+ | isdir -> do
+ wpath <- either tfail return =<< runExceptT (getArtifactWorkPath storageDir jid aname)
+ return $ extractDestination </> takeFileName wpath
+ | otherwise -> return extractDestination
+
+ liftIO (doesPathExist tpath) >>= \case
+ True
+ | extractForce -> liftIO (doesDirectoryExist tpath) >>= \case
+ True -> liftIO $ removeDirectoryRecursive tpath
+ False -> liftIO $ removeFile tpath
+ | otherwise -> tfail $ "destination ‘" <> T.pack tpath <> "’ already exists"
+ False -> return ()
+
+ either tfail return =<< runExceptT (copyArtifact storageDir jid aname tpath)
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index 9652529..b299931 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -8,6 +8,7 @@ import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
+import Data.Containers.ListUtils
import Data.Either
import Data.List
import Data.Maybe
@@ -32,12 +33,19 @@ import Terminal
data RunCommand = RunCommand RunOptions [ Text ]
data RunOptions = RunOptions
- { roRanges :: [ Text ]
+ { roRerun :: RerunOption
+ , roRanges :: [ Text ]
, roSinceUpstream :: [ Text ]
, roNewCommitsOn :: [ Text ]
, roNewTags :: [ Pattern ]
}
+data RerunOption
+ = RerunExplicit
+ | RerunFailed
+ | RerunAll
+ | RerunNone
+
instance Command RunCommand where
commandName _ = "run"
commandDescription _ = "Execude jobs per minici.yaml for given commits"
@@ -57,14 +65,27 @@ instance Command RunCommand where
type CommandOptions RunCommand = RunOptions
defaultCommandOptions _ = RunOptions
- { roRanges = []
+ { roRerun = RerunExplicit
+ , roRanges = []
, roSinceUpstream = []
, roNewCommitsOn = []
, roNewTags = []
}
commandOptions _ =
- [ Option [] [ "range" ]
+ [ Option [] [ "rerun-explicit" ]
+ (NoArg (\opts -> opts { roRerun = RerunExplicit }))
+ "rerun jobs given explicitly on command line and their failed dependencies (default)"
+ , Option [] [ "rerun-failed" ]
+ (NoArg (\opts -> opts { roRerun = RerunFailed }))
+ "rerun failed jobs only"
+ , Option [] [ "rerun-all" ]
+ (NoArg (\opts -> opts { roRerun = RerunAll }))
+ "rerun all jobs"
+ , Option [] [ "rerun-none" ]
+ (NoArg (\opts -> opts { roRerun = RerunNone }))
+ "do not rerun any job"
+ , Option [] [ "range" ]
(ReqArg (\val opts -> opts { roRanges = T.pack val : roRanges opts }) "<range>")
"run jobs for commits in given range"
, Option [] [ "since-upstream" ]
@@ -126,7 +147,8 @@ mergeSources sources = do
argumentJobSource :: [ JobName ] -> CommandExec JobSource
argumentJobSource [] = emptyJobSource
argumentJobSource names = do
- ( config, jobsetCommit ) <- getJobRoot >>= \case
+ jobRoot <- getJobRoot
+ ( config, jcommit ) <- case jobRoot of
JobRootConfig config -> do
commit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo
return ( config, commit )
@@ -135,29 +157,49 @@ argumentJobSource names = do
config <- either fail return =<< loadConfigForCommit =<< getCommitTree commit
return ( config, Just commit )
- jobtree <- case jobsetCommit of
+ jobtree <- case jcommit of
Just commit -> (: []) <$> getCommitTree commit
Nothing -> return []
- let cidPart = map (JobIdTree Nothing "" . treeId) jobtree
- jobsetJobsEither <- fmap Right $ forM names $ \name ->
+ let cidPart = case jobRoot of
+ JobRootConfig {} -> []
+ JobRootRepo {} -> map (JobIdTree Nothing "" . treeId) jobtree
+ forM_ names $ \name ->
case find ((name ==) . jobName) (configJobs config) of
- Just job -> return job
+ Just _ -> return ()
Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found"
- oneshotJobSource . (: []) =<<
- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei })
- (evalJobSet (map ( Nothing, ) jobtree) JobSet {..})
+
+ jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do
+ evalJobSetSelected names (map ( Nothing, ) jobtree) JobSet
+ { jobsetId = ()
+ , jobsetConfig = Just config
+ , jobsetCommit = jcommit
+ , jobsetExplicitlyRequested = names
+ , jobsetJobsEither = Right (configJobs config)
+ }
+ oneshotJobSource [ jset ]
refJobSource :: [ JobRef ] -> CommandExec JobSource
refJobSource [] = emptyJobSource
refJobSource refs = do
- jobs <- cmdEvalWith id $ mapM evalJobReference refs
- oneshotJobSource . map (JobSet Nothing . Right . (: [])) $ jobs
+ sets <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReferenceToSet refs)
+ oneshotJobSource sets
+ where
+ addJobToList :: [ JobSet ] -> JobSet -> [ JobSet ]
+ addJobToList (cur : rest) jset
+ | jobsetId cur == jobsetId jset = cur { jobsetJobsEither = fmap (nubOrdOn jobId) $ (++) <$> (jobsetJobsEither cur) <*> (jobsetJobsEither jset)
+ , jobsetExplicitlyRequested = nubOrd $ jobsetExplicitlyRequested cur ++ jobsetExplicitlyRequested jset
+ } : rest
+ | otherwise = cur : addJobToList rest jset
+ addJobToList [] jset = [ jset ]
loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet
loadJobSetFromRoot root commit = case root of
JobRootRepo _ -> loadJobSetForCommit commit
JobRootConfig config -> return JobSet
- { jobsetCommit = Just commit
+ { jobsetId = ()
+ , jobsetConfig = Just config
+ , jobsetCommit = Just commit
+ , jobsetExplicitlyRequested = []
, jobsetJobsEither = Right $ configJobs config
}
@@ -294,8 +336,10 @@ cmdRun (RunCommand RunOptions {..} args) = do
threadCount <- newTVarIO (0 :: Int)
let changeCount f = atomically $ do
writeTVar threadCount . f =<< readTVar threadCount
- let waitForJobs = atomically $ do
- flip when retry . (0 <) =<< readTVar threadCount
+ let waitForJobs = do
+ atomically $ do
+ flip when retry . (0 <) =<< readTVar threadCount
+ waitForRemainingTasks mngr
let loop _ Nothing = return ()
loop names (Just ( [], next )) = do
@@ -315,7 +359,11 @@ cmdRun (RunCommand RunOptions {..} args) = do
case jobsetJobsEither jobset of
Right jobs -> do
- outs <- runJobs mngr output jobs
+ outs <- runJobs mngr output jobs $ case roRerun of
+ RerunExplicit -> \jid status -> jid `elem` jobsetExplicitlyRequested jobset || jobStatusFailed status
+ RerunFailed -> \_ status -> jobStatusFailed status
+ RerunAll -> \_ _ -> True
+ RerunNone -> \_ _ -> False
let findJob name = snd <$> find ((name ==) . jobName . fst) outs
statuses = map findJob names
forM_ (outputTerminal output) $ \tout -> do
@@ -348,22 +396,26 @@ fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " "
showStatus :: Bool -> JobStatus a -> Text
showStatus blink = \case
- JobQueued -> "\ESC[94m…\ESC[0m "
+ JobQueued -> " \ESC[94m…\ESC[0m "
JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
- JobSkipped -> "\ESC[0m-\ESC[0m "
- JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m "
+ JobSkipped -> " \ESC[0m-\ESC[0m "
+ JobRunning -> " \ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m "
JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (maybe "?" (show . tfNumber) (footnoteTerminal fnote)) <> "]") <> "\ESC[0m"
- JobFailed -> "\ESC[91m✗\ESC[0m "
- JobCancelled -> "\ESC[0mC\ESC[0m "
- JobDone _ -> "\ESC[92m✓\ESC[0m "
+ JobFailed -> " \ESC[91m✗\ESC[0m "
+ JobCancelled -> " \ESC[0mC\ESC[0m "
+ JobDone _ -> " \ESC[92m✓\ESC[0m "
JobDuplicate _ s -> case s of
- JobQueued -> "\ESC[94m^\ESC[0m "
- JobWaiting _ -> "\ESC[94m^\ESC[0m "
- JobSkipped -> "\ESC[0m-\ESC[0m "
- JobRunning -> "\ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m "
+ JobQueued -> " \ESC[94m^\ESC[0m "
+ JobWaiting _ -> " \ESC[94m^\ESC[0m "
+ JobSkipped -> " \ESC[0m-\ESC[0m "
+ JobRunning -> " \ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m "
_ -> showStatus blink s
+ JobPreviousStatus (JobDone _) -> "\ESC[90m«\ESC[32m✓\ESC[0m "
+ JobPreviousStatus (JobFailed) -> "\ESC[90m«\ESC[31m✗\ESC[0m "
+ JobPreviousStatus s -> "\ESC[90m«" <> T.init (showStatus blink s)
+
displayStatusLine :: TerminalOutput -> TerminalLine -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO ()
displayStatusLine tout line prefix1 prefix2 statuses = do
go "\0"
diff --git a/src/Command/Shell.hs b/src/Command/Shell.hs
new file mode 100644
index 0000000..16f366e
--- /dev/null
+++ b/src/Command/Shell.hs
@@ -0,0 +1,46 @@
+module Command.Shell (
+ ShellCommand,
+) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+
+import Data.Maybe
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import System.Environment
+import System.Process hiding (ShellCommand)
+
+import Command
+import Eval
+import Job
+import Job.Types
+
+
+data ShellCommand = ShellCommand JobRef
+
+instance Command ShellCommand where
+ commandName _ = "shell"
+ commandDescription _ = "Open a shell prepared for given job"
+
+ type CommandArguments ShellCommand = Text
+
+ commandUsage _ = T.unlines $
+ [ "Usage: minici shell <job ref>"
+ ]
+
+ commandInit _ _ = ShellCommand . parseJobRef
+ commandExec = cmdShell
+
+
+cmdShell :: ShellCommand -> CommandExec ()
+cmdShell (ShellCommand ref) = do
+ einput <- getEvalInput
+ job <- either (tfail . textEvalError) return =<<
+ liftIO (runEval (evalJobReference ref) einput)
+ sh <- fromMaybe "/bin/sh" <$> liftIO (lookupEnv "SHELL")
+ storageDir <- getStorageDir
+ prepareJob storageDir job $ \checkoutPath -> do
+ liftIO $ withCreateProcess (proc sh []) { cwd = Just checkoutPath } $ \_ _ _ ph -> do
+ void $ waitForProcess ph
diff --git a/src/Command/Subtree.hs b/src/Command/Subtree.hs
new file mode 100644
index 0000000..15cb2db
--- /dev/null
+++ b/src/Command/Subtree.hs
@@ -0,0 +1,47 @@
+module Command.Subtree (
+ SubtreeCommand,
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Command
+import Output
+import Repo
+
+
+data SubtreeCommand = SubtreeCommand SubtreeOptions [ Text ]
+
+data SubtreeOptions = SubtreeOptions
+
+instance Command SubtreeCommand where
+ commandName _ = "subtree"
+ commandDescription _ = "Resolve subdirectory of given repo tree"
+
+ type CommandArguments SubtreeCommand = [ Text ]
+
+ commandUsage _ = T.pack $ unlines $
+ [ "Usage: minici subtree <tree> <path>"
+ ]
+
+ type CommandOptions SubtreeCommand = SubtreeOptions
+ defaultCommandOptions _ = SubtreeOptions
+
+ commandInit _ opts = SubtreeCommand opts
+ commandExec = cmdSubtree
+
+
+cmdSubtree :: SubtreeCommand -> CommandExec ()
+cmdSubtree (SubtreeCommand SubtreeOptions args) = do
+ [ treeParam, path ] <- return args
+ out <- getOutput
+ repo <- getDefaultRepo
+
+ let ( tree, subdir ) =
+ case T.splitOn "(" treeParam of
+ (t : param : _) -> ( t, T.unpack $ T.takeWhile (/= ')') param )
+ _ -> ( treeParam, "" )
+
+ subtree <- getSubtree Nothing (T.unpack path) =<< readTree repo subdir tree
+ outputMessage out $ textTreeId $ treeId subtree
+ outputEvent out $ TestMessage $ "path " <> T.pack (treeSubdir subtree)
diff --git a/src/Config.hs b/src/Config.hs
index 4327193..40eb1e5 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -26,6 +26,7 @@ import System.FilePath
import System.FilePath.Glob
import System.Process
+import Destination
import Job.Types
import Repo
@@ -42,18 +43,21 @@ data JobRoot
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
@@ -72,24 +76,31 @@ 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
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 [ JobCheckout Nothing 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 [ JobCheckout Declared ]
@@ -106,18 +117,23 @@ parseSingleCheckout = withMap "checkout definition" $ \m -> do
parseMultipleCheckouts :: Node Pos -> Parser [ JobCheckout Declared ]
parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout
-cabalJob :: Node Pos -> Parser [CreateProcess]
+cabalJob :: Node Pos -> Parser [ Either CreateProcess Text ]
cabalJob = withMap "cabal job" $ \m -> do
ghcOptions <- m .:? "ghc-options" >>= \case
Nothing -> return []
Just s -> withSeq "GHC option list" (mapM (withStr "GHC option" return)) s
return
- [ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ]
-
-shellJob :: Node Pos -> Parser [CreateProcess]
-shellJob = withSeq "shell commands" $ \xs -> do
- fmap (map shell) $ forM xs $ withStr "shell command" $ return . T.unpack
+ [ Left $ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ]
+
+shellJob :: Node Pos -> Parser [ Either CreateProcess Text ]
+shellJob node = do
+ commands <- choice
+ [ withStr "shell commands" return node
+ , withSeq "shell commands" (\xs -> do
+ fmap T.unlines $ forM xs $ withStr "shell command" $ return) node
+ ]
+ return [ Right commands ]
parseArtifacts :: Mapping Pos -> Parser [ ( ArtifactName, Pattern ) ]
parseArtifacts m = do
@@ -136,11 +152,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)
@@ -173,6 +212,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 f064cb1..6680c44 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -3,9 +3,12 @@ module Eval (
EvalError(..), textEvalError,
Eval, runEval,
- evalJob,
evalJobSet,
+ evalJobSetSelected,
evalJobReference,
+ evalJobReferenceToSet,
+
+ loadJobSetById,
) where
import Control.Monad
@@ -20,6 +23,7 @@ import Data.Text qualified as T
import System.FilePath
import Config
+import Destination
import Job.Types
import Repo
@@ -29,6 +33,7 @@ data EvalInput = EvalInput
, eiCurrentIdRev :: [ JobIdPart ]
, eiContainingRepo :: Maybe Repo
, eiOtherRepos :: [ ( RepoName, Repo ) ]
+ , eiDestinations :: [ ( DestinationName, Destination ) ]
}
data EvalError
@@ -48,74 +53,153 @@ 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)
+checkIfAlreadyHasDefaultRepoId :: Eval Bool
+checkIfAlreadyHasDefaultRepoId = do
+ asks (any isDefaultRepoId . eiCurrentIdRev)
where
- matches (JobIdName _) = False
- matches (JobIdCommit rname _) = isNothing rname
- matches (JobIdTree rname _ _) = isNothing rname
+ 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
- let dependencies = map fst $ jobUses decl
+ 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
- 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
-
+ alreadyHasDefaultRepoId <- checkIfAlreadyHasDefaultRepoId
let checkouts =
- (if missingDefault then id else (filter (isJust . jcRepo))) $
- concat
- [ jobCheckout decl
- , concat dependencyRepos
- ]
+ (if alreadyHasDefaultRepoId then filter (isJust . jcRepo) else id) $
+ 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
+ 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
+
+
+evalJobs
+ :: [ DeclaredJob ] -> [ Either JobName Job ]
+ -> [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> [ JobName ] -> Eval [ Job ]
+evalJobs _ _ _ JobSet { jobsetJobsEither = Left err } _ = throwError $ OtherEvalError $ T.pack err
+
+evalJobs [] evaluated repos dset@JobSet { jobsetJobsEither = Right decl } (req : reqs)
+ | any ((req ==) . either id jobName) evaluated
+ = evalJobs [] evaluated repos dset reqs
+ | Just d <- find ((req ==) . jobName) decl
+ = evalJobs [ d ] evaluated repos dset reqs
+ | otherwise
+ = throwError $ OtherEvalError $ "job ‘" <> textJobName req <> "’ not found in jobset"
+evalJobs [] evaluated _ _ [] = return $ mapMaybe (either (const Nothing) Just) evaluated
+evalJobs (current : evaluating) evaluated repos dset reqs
+ | any ((jobName current ==) . jobName) evaluating = throwError $ OtherEvalError $ "cyclic dependency when evaluating job ‘" <> textJobName (jobName current) <> "’"
+ | any ((jobName current ==) . either id jobName) evaluated = evalJobs evaluating evaluated repos dset reqs
-evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> DeclaredJob -> Eval Job
-evalJob revisionOverrides dset decl = do
+evalJobs (current : evaluating) evaluated repos dset reqs
+ | Just missing <- find (`notElem` (jobName current : map (either id jobName) evaluated)) $ map fst $ jobRequiredArtifacts current
+ , d <- either (const Nothing) (find ((missing ==) . jobName)) (jobsetJobsEither dset)
+ = evalJobs (fromJust d : current : evaluating) evaluated repos dset reqs
+
+evalJobs (current : evaluating) evaluated repos dset reqs = 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
- ]
- }
+ otherRepos <- collectOtherRepos dset current
+ otherRepoTreesMb <- forM otherRepos $ \( mbrepo, commonPath ) -> do
+ Just tree <- return $ lookup (fst <$> mbrepo) repos
+ mbSubtree <- case snd =<< mbrepo of
+ Just revisionOverride -> return . Just =<< getCommitTree =<< readCommit (treeRepo tree) revisionOverride
+ Nothing
+ | treeSubdir tree == commonPath -> do
+ return $ Just tree
+ | splitDirectories (treeSubdir tree) `isPrefixOf` splitDirectories commonPath -> do
+ Just <$> getSubtree Nothing (makeRelative (treeSubdir tree) commonPath) tree
+ | otherwise -> do
+ return Nothing
+ return $ fmap (\subtree -> ( mbrepo, ( commonPath, subtree ) )) mbSubtree
+ let otherRepoTrees = catMaybes otherRepoTreesMb
+ if all isJust otherRepoTreesMb
+ then do
+ checkouts <- forM (jobCheckout current) $ \dcheckout -> do
+ return dcheckout
+ { jcRepo =
+ fromMaybe (error $ "expecting repo in either otherRepoTrees or repos: " <> show (textRepoName . fst <$> jcRepo dcheckout)) $
+ msum
+ [ snd <$> lookup (jcRepo dcheckout) otherRepoTrees
+ , lookup (fst <$> jcRepo dcheckout) repos -- for containing repo if filtered from otherRepos
+ ]
+ }
- 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
- }
+ destinations <- forM (jobPublish current) $ \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)
+ let job = Job
+ { jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId current) : eiCurrentIdRev
+ , jobName = jobName current
+ , jobCheckout = checkouts
+ , jobRecipe = jobRecipe current
+ , jobArtifacts = jobArtifacts current
+ , jobUses = jobUses current
+ , jobPublish = destinations
+ }
+ evalJobs evaluating (Right job : evaluated) repos dset reqs
+ else do
+ evalJobs evaluating (Left (jobName current) : evaluated) repos dset reqs
evalJobSet :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet
-evalJobSet revisionOverrides decl = do
- jobs <- either (return . Left) (handleToEither . mapM (evalJob revisionOverrides decl)) $ jobsetJobsEither decl
+evalJobSet revisionOverrides decl = evalJobSetSelected (either (const []) (map jobName) (jobsetJobsEither decl)) revisionOverrides decl
+
+evalJobSetSelected :: [ JobName ] -> [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet
+evalJobSetSelected selected revisionOverrides decl = do
+ EvalInput {..} <- ask
+ repos <- collectJobSetRepos revisionOverrides decl
+ alreadyHasDefaultRepoId <- checkIfAlreadyHasDefaultRepoId
+ let addedRepoIds =
+ map (\( mbname, tree ) -> JobIdTree mbname (treeSubdir tree) (treeId tree)) $
+ (if alreadyHasDefaultRepoId then filter (isJust . fst) else id) $
+ repos
+
+ evaluated <- handleToEither $ evalJobs [] [] repos decl selected
+ let jobs = case liftM2 (,) evaluated (jobsetJobsEither decl) of
+ Left err -> Left err
+ Right ( ejobs, djobs ) -> Right $ mapMaybe (\dj -> find ((jobName dj ==) . jobName) ejobs) djobs
+
+ let explicit = mapMaybe (\name -> jobId <$> find ((name ==) . jobName) (either (const []) id jobs)) $ jobsetExplicitlyRequested decl
return JobSet
- { jobsetCommit = jobsetCommit decl
+ { jobsetId = JobSetId $ reverse $ reverse addedRepoIds ++ eiCurrentIdRev
+ , jobsetConfig = jobsetConfig decl
+ , jobsetCommit = jobsetCommit decl
+ , jobsetExplicitlyRequested = explicit
, jobsetJobsEither = jobs
}
where
@@ -130,21 +214,31 @@ evalRepo (Just name) = asks (lookup name . eiOtherRepos) >>= \case
Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined"
-canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval Job
+canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval JobSet
canonicalJobName (r : rs) config mbDefaultRepo = do
let name = JobName r
- dset = JobSet Nothing $ Right $ configJobs config
+ dset = JobSet
+ { jobsetId = ()
+ , jobsetConfig = Just config
+ , jobsetCommit = Nothing
+ , jobsetExplicitlyRequested = [ name ]
+ , jobsetJobsEither = Right $ configJobs config
+ }
case find ((name ==) . jobName) (configJobs config) of
Just djob -> do
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' )
+ \( 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 ()
- evalJob (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset djob
+ evalJobSetSelected (jobsetExplicitlyRequested dset) (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset
Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found"
canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name"
@@ -157,17 +251,74 @@ readTreeFromIdRef (r : rs) subdir repo = do
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
+canonicalCommitConfig :: [ Text ] -> Repo -> Eval JobSet
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
-evalJobReference (JobRef rs) =
+evalJobReferenceToSet :: JobRef -> Eval JobSet
+evalJobReferenceToSet (JobRef rs) =
asks eiJobRoot >>= \case
JobRootRepo defRepo -> do
canonicalCommitConfig rs defRepo
JobRootConfig config -> do
canonicalJobName rs config Nothing
+
+evalJobReference :: JobRef -> Eval Job
+evalJobReference ref = do
+ jset <- evalJobReferenceToSet ref
+ jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither jset
+ [ name ] <- return $ jobsetExplicitlyRequested jset
+ maybe (error "missing job in evalJobReferenceToSet result") return $ find ((name ==) . jobId) jobs
+
+
+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 (treeSubdir tree) (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 (treeSubdir tree) (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
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 5435cbd..3fe75e6 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -7,8 +7,16 @@ module Job (
JobStatus(..),
jobStatusFinished, jobStatusFailed,
JobManager(..), newJobManager, cancelAllJobs,
- runJobs,
+ runJobs, waitForRemainingTasks,
+
+ prepareJob,
+ getArtifactWorkPath,
+ copyArtifact,
+
jobStorageSubdir,
+
+ copyRecursive,
+ copyRecursiveForce,
) where
import Control.Concurrent
@@ -30,6 +38,7 @@ import Data.Text qualified as T
import Data.Text.IO qualified as T
import System.Directory
+import System.Environment
import System.Exit
import System.FilePath
import System.FilePath.Glob
@@ -38,14 +47,14 @@ import System.IO.Temp
import System.Posix.Signals
import System.Process
+import Destination
import Job.Types
import Output
import Repo
data JobOutput = JobOutput
- { outName :: JobName
- , outArtifacts :: [ArtifactOutput]
+ { outArtifacts :: [ArtifactOutput]
}
deriving (Eq)
@@ -59,6 +68,7 @@ data ArtifactOutput = ArtifactOutput
data JobStatus a = JobQueued
| JobDuplicate JobId (JobStatus a)
+ | JobPreviousStatus (JobStatus a)
| JobWaiting [JobName]
| JobRunning
| JobSkipped
@@ -70,31 +80,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
@@ -105,6 +142,7 @@ data JobManager = JobManager
, jmReadyTasks :: TVar (Set TaskId)
, jmRunningTasks :: TVar (Map TaskId ThreadId)
, jmCancelled :: TVar Bool
+ , jmOpenStatusUpdates :: TVar Int
}
newtype TaskId = TaskId Int
@@ -125,6 +163,7 @@ newJobManager jmDataDir queueLen = do
jmReadyTasks <- newTVarIO S.empty
jmRunningTasks <- newTVarIO M.empty
jmCancelled <- newTVarIO False
+ jmOpenStatusUpdates <- newTVarIO 0
return JobManager {..}
cancelAllJobs :: JobManager -> IO ()
@@ -182,8 +221,10 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case
writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks
-runJobs :: JobManager -> Output -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
-runJobs mngr@JobManager {..} tout jobs = do
+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
tid <- reserveTaskId mngr
@@ -205,7 +246,7 @@ runJobs mngr@JobManager {..} tout jobs = do
| otherwise -> do
JobError <$> outputFootnote tout (T.pack $ displayException e)
atomically $ writeTVar outVar status
- outputEvent tout $ JobFinished (jobId job) (textJobStatus status)
+ outputJobFinishedEvent tout job status
handle handler $ do
res <- runExceptT $ do
duplicate <- liftIO $ atomically $ do
@@ -217,13 +258,22 @@ runJobs mngr@JobManager {..} tout jobs = do
case duplicate of
Nothing -> do
- 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 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
@@ -241,15 +291,30 @@ runJobs mngr@JobManager {..} tout jobs = do
liftIO wait
atomically $ writeTVar outVar $ either id id res
- outputEvent tout $ JobFinished (jobId job) (textJobStatus $ 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) =>
- Output ->
- 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 (outputFootnote tout $ "Job '" <> tjobName <> "' not found")
@@ -267,28 +332,55 @@ 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
+ 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 -> Job -> (FilePath -> FilePath -> m a) -> m a
+
+prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Job -> (FilePath -> m a) -> m a
prepareJob dir job inner = do
withSystemTempDirectory "minici" $ \checkoutPath -> do
forM_ (jobCheckout job) $ \(JobCheckout tree mbsub dest) -> do
@@ -297,32 +389,65 @@ prepareJob dir job inner = do
let jdir = dir </> jobStorageSubdir (jobId job)
liftIO $ createDirectoryIfMissing True jdir
- inner checkoutPath 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"
+
+ 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) $ \ep -> do
+ ( p, input ) <- case ep of
+ Left p -> return ( p, "" )
+ Right script -> do
+ sh <- fromMaybe "/bin/sh" <$> liftIO (lookupEnv "SHELL")
+ return ( proc sh [], script )
(Just hin, _, _, hp) <- liftIO $ createProcess_ "" p
{ cwd = Just checkoutPath
, std_in = CreatePipe
, std_out = UseHandle logs
, std_err = UseHandle logs
}
- liftIO $ hClose hin
+ liftIO $ void $ forkIO $ do
+ T.hPutStr hin input
+ hClose hin
liftIO (waitForProcess hp) >>= \case
ExitSuccess -> return ()
ExitFailure n
| 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
@@ -330,17 +455,27 @@ runJob job uses checkoutPath jdir = do
(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 4024317..262a267 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -1,5 +1,6 @@
module Job.Types where
+import Data.Containers.ListUtils
import Data.Kind
import Data.Text (Text)
import Data.Text qualified as T
@@ -7,6 +8,8 @@ import Data.Text qualified as T
import System.FilePath.Glob
import System.Process
+import {-# SOURCE #-} Config
+import Destination
import Repo
@@ -17,9 +20,10 @@ data Job' d = Job
{ jobId :: JobId' d
, jobName :: JobName
, jobCheckout :: [ JobCheckout d ]
- , jobRecipe :: [ CreateProcess ]
+ , jobRecipe :: Maybe [ Either CreateProcess Text ]
, jobArtifacts :: [ ( ArtifactName, Pattern ) ]
- , jobUses :: [ ( JobName, ArtifactName ) ]
+ , jobUses :: [ ArtifactSpec ]
+ , jobPublish :: [ JobPublish d ]
}
type Job = Job' Evaluated
@@ -38,6 +42,9 @@ 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)
+
type family JobRepo d :: Type where
JobRepo Declared = Maybe ( RepoName, Maybe Text )
@@ -49,19 +56,38 @@ data JobCheckout d = JobCheckout
, 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
@@ -69,6 +95,9 @@ jobsetJobs = either (const []) id . jobsetJobsEither
newtype JobId = JobId [ JobIdPart ]
deriving (Eq, Ord)
+newtype JobSetId = JobSetId [ JobIdPart ]
+ deriving (Eq, Ord)
+
data JobIdPart
= JobIdName JobName
| JobIdCommit (Maybe RepoName) CommitId
diff --git a/src/Main.hs b/src/Main.hs
index e273715..647231d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -25,7 +25,10 @@ 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 Version
@@ -63,12 +66,23 @@ 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 <> "’"
) "<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"
@@ -92,6 +106,8 @@ commands =
, SC $ Proxy @ExtractCommand
, SC $ Proxy @JobIdCommand
, SC $ Proxy @LogCommand
+ , SC $ Proxy @ShellCommand
+ , SC $ Proxy @SubtreeCommand
]
lookupCommand :: String -> Maybe SomeCommandType
@@ -239,13 +255,13 @@ runSomeCommand rootPath gopts (SC tproxy) args = do
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 "")
@@ -254,10 +270,38 @@ runSomeCommand rootPath gopts (SC tproxy) args = do
forM (configRepos config) $ \decl -> do
case lookup (repoName decl) cmdlineRepos of
Just repo -> return ( repoName decl, repo )
- Nothing -> openDeclaredRepo (takeDirectory ciRootPath) 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 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 []
let ciOtherRepos = configRepos ++ cmdlineRepos
+ ciDestinations = cfgDestinations ++ cmdlineDestinations
outputTypes <- case optOutput gopts of
Just types -> return types
diff --git a/src/Output.hs b/src/Output.hs
index 64704ec..5fa2f81 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -44,6 +44,9 @@ data OutputEvent
| LogMessage Text
| JobStarted JobId
| JobFinished JobId Text
+ | JobIsDuplicate JobId Text
+ | JobPreviouslyFinished JobId Text
+ | JobWasSkipped JobId
data OutputFootnote = OutputFootnote
{ footnoteText :: Text
@@ -109,6 +112,18 @@ outputEvent out@Output {..} = liftIO . \case
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
diff --git a/src/Repo.hs b/src/Repo.hs
index 98178e6..c878b1e 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -9,8 +9,8 @@ module Repo (
Tag(..),
openRepo,
- readCommit, tryReadCommit,
- readTree, tryReadTree,
+ readCommit, readCommitId, tryReadCommit,
+ readTree, readTreeId, tryReadTree,
readBranch,
readTag,
listCommits,
@@ -72,7 +72,7 @@ getRepoWorkDir GitRepo {..} = takeDirectory gitDir
data DeclaredRepo = DeclaredRepo
{ repoName :: RepoName
- , repoPath :: FilePath
+ , repoPath :: Maybe FilePath
}
newtype RepoName = RepoName Text
@@ -175,6 +175,9 @@ 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 <> "’"
+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
@@ -182,6 +185,9 @@ 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 -> FilePath -> Text -> m (Maybe Tree)
tryReadTree treeRepo treeSubdir ref = do
fmap (fmap TreeId) (tryReadObjectId treeRepo "tree" ref) >>= \case
@@ -280,15 +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)
- , treeSubdir = treeSubdir tree </> path
- }
- _ -> 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 ()
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-16 19:35:11 +0000