summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2026-07-18 15:44:02 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2026-07-18 23:12:49 +0200
commit5756e4582648794e9603fbd8e84df25221fb7ff5 (patch)
treefa8bf733a2a34054155e57bc2716c1952c09879f
parentbb7b28a9e8a1a05d6d9af0f943a158a03a148190 (diff)
Tag and commit support in job id partsHEADmaster
-rw-r--r--src/Command/JobId.hs9
-rw-r--r--src/Command/Run.hs18
-rw-r--r--src/Eval.hs180
-rw-r--r--src/Job/Types.hs44
-rw-r--r--src/Repo.hs35
5 files changed, 206 insertions, 80 deletions
diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs
index 173f543..3a119fa 100644
--- a/src/Command/JobId.hs
+++ b/src/Command/JobId.hs
@@ -60,14 +60,19 @@ cmdJobId (JobIdCommand JobIdOptions {..} ref) = do
outputMessage out ""
forM_ ids $ \case
JobIdName name -> outputMessage out $ textJobName name <> " (job name)"
- JobIdCommit mbrepo cid -> outputMessage out $ T.concat
+ JobIdRepo mbrepo (JobIdCommit cid) -> outputMessage out $ T.concat
[ textCommitId cid, " (commit"
, maybe "" (\name -> " from ‘" <> textRepoName name <> "’ repo") mbrepo
, ")"
]
- JobIdTree mbrepo subtree cid -> outputMessage out $ T.concat
+ JobIdRepo mbrepo (JobIdTree 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 ""
, ")"
]
+ JobIdRepo mbrepo (JobIdTag cid tid) -> outputMessage out $ T.concat
+ [ textCommitId cid, "^", textTagId tid, " (commit following tag"
+ , maybe "" (\name -> " from ‘" <> textRepoName name <> "’ repo") mbrepo
+ , ")"
+ ]
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index 34a32d6..ccd4bfa 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -166,14 +166,14 @@ argumentJobSource names = do
Nothing -> return []
let cidPart = case jobRoot of
JobRootConfig {} -> []
- JobRootRepo {} -> map (JobIdTree Nothing "" . treeId) jobtree
+ JobRootRepo {} -> map (JobIdRepo Nothing . JobIdTree "" . treeId) jobtree
forM_ names $ \name ->
case find ((name ==) . jobName) (configJobs config) of
Just _ -> return ()
Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found"
jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do
- evalJobSetSelected names (map ( Nothing, ) jobtree) JobSet
+ evalJobSetSelected names (map (( Nothing , ) . RepoRefTree) jobtree) JobSet
{ jobsetId = ()
, jobsetConfig = Just config
, jobsetCommit = jcommit
@@ -215,8 +215,8 @@ rangeSource base tip = do
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
+ { eiCurrentIdRev = JobIdRepo Nothing (JobIdTree (treeSubdir tree) (treeId tree)) : eiCurrentIdRev ei
+ }) . evalJobSet [ ( Nothing, RepoRefTree tree ) ] =<< loadJobSetFromRoot root commit
oneshotJobSource jobsets
@@ -236,17 +236,17 @@ watchExpressionSource expr = do
jobsets <- forM commits $ \commit -> do
tree <- getCommitTree commit
let einput = einputBase
- { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase
+ { eiCurrentIdRev = JobIdRepo Nothing (JobIdTree (treeSubdir tree) (treeId tree)) : eiCurrentIdRev einputBase
}
jsiJobSet <- either (fail . T.unpack . textEvalError) return =<<
- flip runEval einput . evalJobSet [ ( Nothing, tree ) ] =<< loadJobSetFromRoot root commit
+ flip runEval einput . evalJobSet [ ( Nothing, RepoRefTree tree ) ] =<< loadJobSetFromRoot root commit
jsiCancelAction <- Just <$> newEmptyMVar
return JobSourceItem {..}
obsolete <- getAddedRangeCommits repo cur prev
obsoleteIds <- forM obsolete $ \commit -> do
tree <- getCommitTree commit
- return $ JobSetId $ JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase
+ return $ JobSetId $ JobIdRepo Nothing (JobIdTree (treeSubdir tree) (treeId tree)) : eiCurrentIdRev einputBase
let ( cancel, keep ) = span ((`elem` obsoleteIds) . jobsetId . jsiJobSet) running
mapM_ (mapM_ (join . readMVar) . jsiCancelAction) cancel
@@ -282,10 +282,10 @@ watchTagSource pat = do
then do
tree <- getCommitTree $ tagObject tag
let einput = einputBase
- { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase
+ { eiCurrentIdRev = JobIdRepo Nothing (JobIdTree (treeSubdir tree) (treeId tree)) : eiCurrentIdRev einputBase
}
jsiJobSet <- either (fail . T.unpack . textEvalError) return =<<
- flip runEval einput . evalJobSet [ ( Nothing, tree ) ] =<< loadJobSetFromRoot root (tagObject tag)
+ flip runEval einput . evalJobSet [ ( Nothing, RepoRefTree tree ) ] =<< loadJobSetFromRoot root (tagObject tag)
let jsiCancelAction = Nothing
nextvar <- newEmptyTMVarIO
atomically $ putTMVar tmvar $ Just ( [ JobSourceItem {..} ], JobSource nextvar )
diff --git a/src/Eval.hs b/src/Eval.hs
index 1b7c3e2..92c0c22 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -2,6 +2,7 @@ module Eval (
EvalInput(..),
EvalError(..), textEvalError,
Eval, runEval,
+ RepoRef(..),
evalJobSet,
evalJobSetSelected,
@@ -49,19 +50,59 @@ runEval :: Eval a -> EvalInput -> IO (Either EvalError a)
runEval action einput = runExceptT $ flip runReaderT einput action
-commonPrefix :: Eq a => [ a ] -> [ a ] -> [ a ]
-commonPrefix (x : xs) (y : ys) | x == y = x : commonPrefix xs ys
-commonPrefix _ _ = []
+data RepoRef
+ = RepoRefTree Tree
+ | RepoRefCommit Commit
+ | RepoRefTag Commit (Tag Commit)
+
+repoRefRepo :: RepoRef -> Repo
+repoRefRepo = \case
+ RepoRefTree tree -> treeRepo tree
+ RepoRefCommit commit -> commitRepo commit
+ RepoRefTag commit _ -> commitRepo commit
+
+repoRefTree :: (MonadIO m, MonadFail m) => RepoRef -> m Tree
+repoRefTree = \case
+ RepoRefTree tree -> return tree
+ RepoRefCommit commit -> getCommitTree commit
+ RepoRefTag commit _ -> getCommitTree commit
+
+repoRefToIdPart :: MonadIO m => RepoRef -> m JobIdRepoPart
+repoRefToIdPart = \case
+ RepoRefTree tree -> return $ JobIdTree (treeSubdir tree) (treeId tree)
+ RepoRefCommit commit -> return $ JobIdCommit (commitId commit)
+ RepoRefTag commit tag -> return $ JobIdTag (commitId commit) (tagId tag)
+
+repoRefLimit :: RepoDepLevel -> RepoRef -> Eval RepoRef
+repoRefLimit (RepoDepSubtree path) rref = do
+ tree <- repoRefTree rref
+ if | treeSubdir tree == path -> do
+ return $ RepoRefTree tree
+ | splitDirectories (treeSubdir tree) `isPrefixOf` splitDirectories path -> do
+ tree' <- getSubtree Nothing (makeRelative (treeSubdir tree) path) tree
+ return $ RepoRefTree tree'
+ | otherwise -> do
+ throwError $ OtherEvalError $ "Can't get subtree ‘" <> T.pack path <> "’ from ‘" <> T.pack (treeSubdir tree) <> "’"
+
+repoRefLimit RepoDepCommit rref = case rref of
+ RepoRefTree _ -> throwError $ OtherEvalError $ "Can't get commit from subtree ref"
+ RepoRefCommit commit -> return $ RepoRefCommit commit
+ RepoRefTag commit _ -> return $ RepoRefCommit commit
+
+repoRefLimit RepoDepTag rref = case rref of
+ RepoRefTree _ -> throwError $ OtherEvalError $ "Can't get tag from subtree ref"
+ RepoRefCommit _ -> throwError $ OtherEvalError $ "Can't get tag from commit ref"
+ RepoRefTag commit tag -> return $ RepoRefTag commit tag
+
checkIfAlreadyHasDefaultRepoId :: Eval Bool
checkIfAlreadyHasDefaultRepoId = do
asks (any isDefaultRepoId . eiCurrentIdRev)
where
isDefaultRepoId (JobIdName _) = False
- isDefaultRepoId (JobIdCommit rname _) = isNothing rname
- isDefaultRepoId (JobIdTree rname _ _) = isNothing rname
+ isDefaultRepoId (JobIdRepo rname _) = isNothing rname
-collectJobSetRepos :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval [ ( Maybe RepoName, Tree ) ]
+collectJobSetRepos :: [ ( Maybe RepoName, RepoRef ) ] -> DeclaredJobSet -> Eval [ ( Maybe RepoName, RepoRef ) ]
collectJobSetRepos revisionOverrides dset = do
jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset
let someJobUsesDefaultRepo = any (any (isNothing . jcRepo) . jobCheckout) jobs
@@ -73,10 +114,10 @@ collectJobSetRepos revisionOverrides dset = do
Just tree -> return ( rname, tree )
Nothing -> do
repo <- evalRepo rname
- tree <- getCommitTree =<< readCommit repo "HEAD"
- return ( rname, tree )
+ commit <- readCommit repo "HEAD"
+ return ( rname, RepoRefCommit commit )
-collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), FilePath ) ]
+collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), RepoDepLevel ) ]
collectOtherRepos dset decl = do
jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset
let gatherDependencies seen (d : ds)
@@ -96,8 +137,8 @@ collectOtherRepos dset decl = do
(if alreadyHasDefaultRepoId then filter (isJust . jcRepo) else id) $
concat dependencyRepos
- let commonSubdir reporev = joinPath $ foldr1 commonPrefix $
- map (maybe [] splitDirectories . jcSubtree) . filter ((reporev ==) . jcRepo) $ checkouts
+ let commonSubdir reporev = foldr1 (<>) $
+ map (RepoDepSubtree . fromMaybe "" . jcSubtree) . filter ((reporev ==) . jcRepo) $ checkouts
let canonicalRepoOrder = Nothing : maybe [] (map (Just . repoName) . configRepos) (jobsetConfig dset)
getCheckoutsForName rname = map (\r -> ( r, commonSubdir r )) $ nub $ filter ((rname ==) . fmap fst) $ map jcRepo checkouts
return $ concatMap getCheckoutsForName canonicalRepoOrder
@@ -105,7 +146,7 @@ collectOtherRepos dset decl = do
evalJobs
:: [ DeclaredJob ] -> [ Either JobName Job ]
- -> [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> [ JobName ] -> Eval [ Job ]
+ -> [ ( Maybe RepoName, RepoRef ) ] -> DeclaredJobSet -> [ JobName ] -> Eval [ Job ]
evalJobs _ _ _ JobSet { jobsetJobsEither = Left err } _ = throwError $ OtherEvalError $ T.pack err
evalJobs [] evaluated repos dset@JobSet { jobsetJobsEither = Right decl } (req : reqs)
@@ -129,35 +170,51 @@ evalJobs (current : evaluating) evaluated repos dset reqs
evalJobs (current : evaluating) evaluated repos dset reqs = do
EvalInput {..} <- ask
otherRepos <- collectOtherRepos dset current
- otherRepoTreesMb <- forM otherRepos $ \( mbrepo, commonPath ) -> do
- Just tree <- return $ lookup (fst <$> mbrepo) repos
+ otherRepoTreesMb <- forM otherRepos $ \( mbrepo, deplevel ) -> do
+ Just repoRef <- return $ lookup (fst <$> mbrepo) repos
+ let repo = repoRefRepo repoRef
mbSubtree <- case snd =<< mbrepo of
- Just revisionOverride -> return . Just =<< getCommitTree =<< readCommit (treeRepo tree) revisionOverride
+ Just revisionOverride
+ | RepoDepSubtree path <- deplevel
+ -> do
+ tree <- getCommitTree =<< readCommit repo revisionOverride
+ return $ Just ( JobIdTree path $ treeId tree, tree )
+ | RepoDepCommit <- deplevel
+ -> do
+ commit <- readCommit repo revisionOverride
+ tree <- getCommitTree commit
+ return $ Just ( JobIdCommit $ commitId commit, tree )
+ | RepoDepTag <- deplevel
+ -> do
+ [ cid, tid ] <- return $ T.split (== '^') revisionOverride
+ commit <- readCommit repo cid
+ tag <- readTag repo tid
+ tree <- getCommitTree commit
+ return $ Just ( JobIdTag (commitId commit) (tagId tag), tree )
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
+ -> do
+ repoRef' <- repoRefLimit deplevel repoRef
+ idpart <- repoRefToIdPart repoRef'
+ tree <- repoRefTree repoRef'
+ return $ Just ( idpart, tree )
+ return $ fmap (\subtree -> ( mbrepo, subtree )) mbSubtree
let otherRepoTrees = catMaybes otherRepoTreesMb
if all isJust otherRepoTreesMb
then do
let otherRepoIds = flip mapMaybe otherRepoTrees $ \case
- ( repo, ( subtree, tree )) -> do
+ ( repo, ( idpart, _ ) ) -> do
guard $ maybe True (isNothing . snd) repo -- use only checkouts without explicit revision in job id
- Just $ JobIdTree (fst <$> repo) subtree (treeId tree)
+ Just $ JobIdRepo (fst <$> repo) idpart
let currentJobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId current) : eiCurrentIdRev
checkouts <- forM (jobCheckout current) $ \dcheckout -> do
+ mbTree <- sequence $ msum
+ [ return . snd <$> lookup (jcRepo dcheckout) otherRepoTrees
+ , repoRefTree <$> lookup (fst <$> jcRepo dcheckout) repos -- for containing repo if filtered from otherRepos
+ ]
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
- ]
+ fromMaybe (error $ "expecting repo in either otherRepoTrees or repos: " <> show (textRepoName . fst <$> jcRepo dcheckout)) $ mbTree
}
uses <- forM (jobUses current) $ \( jname, aname ) -> do
@@ -192,18 +249,18 @@ evalJobs (current : evaluating) evaluated repos dset reqs = do
else do
evalJobs evaluating (Left (jobName current) : evaluated) repos dset reqs
-evalJobSet :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet
+evalJobSet :: [ ( Maybe RepoName, RepoRef ) ] -> DeclaredJobSet -> Eval JobSet
evalJobSet revisionOverrides decl = evalJobSetSelected (either (const []) (map jobName) (jobsetJobsEither decl)) revisionOverrides decl
-evalJobSetSelected :: [ JobName ] -> [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet
+evalJobSetSelected :: [ JobName ] -> [ ( Maybe RepoName, RepoRef ) ] -> 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
+ addedRepoIds <-
+ mapM (\( mbname, ref ) -> JobIdRepo mbname <$> repoRefToIdPart ref) $
+ (if alreadyHasDefaultRepoId then filter (isJust . fst) else id) $
+ repos
evaluated <- handleToEither $ evalJobs [] [] repos decl selected
let jobs = case liftM2 (,) evaluated (jobsetJobsEither decl) of
@@ -230,7 +287,7 @@ evalRepo (Just name) = asks (lookup name . eiOtherRepos) >>= \case
Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined"
-canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval JobSet
+canonicalJobName :: [ Text ] -> Config -> Maybe RepoRef -> Eval JobSet
canonicalJobName (r : rs) config mbDefaultRepo = do
let name = JobName r
dset = JobSet
@@ -244,13 +301,14 @@ canonicalJobName (r : rs) config mbDefaultRepo = do
Just djob -> do
otherRepos <- collectOtherRepos dset djob
( overrides, rs' ) <- (\f -> foldM f ( [], rs ) otherRepos) $
- \( overrides, crs ) ( mbrepo, path ) -> if
+ \( overrides, crs ) ( mbrepo, deplevel ) -> 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' )
+ ( repoRef, crs' ) <- readRepoRefFromIdRef crs (repoDepPath deplevel) =<< evalRepo (fst <$> mbrepo)
+ ref' <- repoRefLimit deplevel repoRef
+ return ( ( fst <$> mbrepo, ref' ) : overrides, crs' )
case rs' of
(r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’"
_ -> return ()
@@ -258,21 +316,24 @@ canonicalJobName (r : rs) config mbDefaultRepo = do
Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found"
canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name"
-readTreeFromIdRef :: [ Text ] -> FilePath -> Repo -> Eval ( Tree, [ Text ] )
-readTreeFromIdRef (r : rs) subdir repo = do
+readRepoRefFromIdRef :: [ Text ] -> FilePath -> Repo -> Eval ( RepoRef, [ Text ] )
+readRepoRefFromIdRef (r : rs) subdir repo = do
tryReadCommit repo r >>= \case
- Just commit -> return . (, rs) =<< getSubtree (Just commit) subdir =<< getCommitTree commit
+ Just commit
+ | subdir == "" -> return ( RepoRefCommit commit, rs )
+ | otherwise -> return . ( , rs ) . RepoRefTree =<< getSubtree (Just commit) subdir =<< getCommitTree commit
Nothing -> tryReadTree repo subdir r >>= \case
- Just tree -> return ( tree, rs )
+ Just tree -> return ( RepoRefTree 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"
+readRepoRefFromIdRef [] _ _ = throwError $ OtherEvalError $ "expected commit or tree reference"
canonicalCommitConfig :: [ Text ] -> Repo -> Eval JobSet
canonicalCommitConfig rs repo = do
- ( tree, rs' ) <- readTreeFromIdRef rs "" repo
+ ( rref, rs' ) <- readRepoRefFromIdRef rs "" repo
+ tree <- repoRefTree rref
config <- either fail return =<< loadConfigForCommit tree
- local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $
- canonicalJobName rs' config (Just tree)
+ local (\ei -> ei { eiCurrentIdRev = JobIdRepo Nothing (JobIdTree "" (treeId tree)) : eiCurrentIdRev ei }) $
+ canonicalJobName rs' config (Just rref)
evalJobReferenceToSet :: JobRef -> Eval JobSet
evalJobReferenceToSet (JobRef rs) =
@@ -297,33 +358,38 @@ jobsetFromConfig sid config _ = do
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
+ JobIdRepo name repoId -> do
repo <- evalRepo name
- tree <- readTreeId repo path tid
+ tree <- case repoId of
+ JobIdTree path tid -> readTreeId repo path tid
+ JobIdCommit cid -> getCommitTree =<< readCommitId repo cid
+ JobIdTag cid _ -> getCommitTree =<< readCommitId repo cid
return ( name, tree )
return ( dset, eiCurrentIdRev, otherRepos )
jobsetFromCommitConfig :: [ JobIdPart ] -> Repo -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] )
-jobsetFromCommitConfig (JobIdTree name path tid : sid) repo = do
+jobsetFromCommitConfig (JobIdRepo name (JobIdTree 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
+ local (\ei -> ei { eiCurrentIdRev = JobIdRepo Nothing (JobIdTree (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
+jobsetFromCommitConfig (JobIdRepo name (JobIdCommit cid) : sid) repo = do
+ when (isJust name) $ do
+ throwError $ OtherEvalError $ "expected default repo commit or tree id"
+ tree <- getCommitTree =<< readCommitId repo cid
+ jobsetFromCommitConfig (JobIdRepo name (JobIdTree (treeSubdir tree) (treeId tree)) : sid) repo
+
+jobsetFromCommitConfig (JobIdRepo name (JobIdTag 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 (JobIdRepo name (JobIdTree (treeSubdir tree) (treeId tree)) : sid) repo
jobsetFromCommitConfig (JobIdName name : _) _ = do
throwError $ OtherEvalError $ "expected commit or tree id, not a job name ‘" <> textJobName name <> "’"
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index f4dd55a..6b436b5 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -5,6 +5,7 @@ import Data.Kind
import Data.Text (Text)
import Data.Text qualified as T
+import System.FilePath
import System.FilePath.Glob
import System.Process
@@ -100,8 +101,13 @@ newtype JobSetId = JobSetId [ JobIdPart ]
data JobIdPart
= JobIdName JobName
- | JobIdCommit (Maybe RepoName) CommitId
- | JobIdTree (Maybe RepoName) FilePath TreeId
+ | JobIdRepo (Maybe RepoName) JobIdRepoPart
+ deriving (Eq, Ord)
+
+data JobIdRepoPart
+ = JobIdTree FilePath TreeId
+ | JobIdCommit CommitId
+ | JobIdTag CommitId TagId
deriving (Eq, Ord)
newtype JobRef = JobRef [ Text ]
@@ -110,8 +116,9 @@ newtype JobRef = JobRef [ Text ]
textJobIdPart :: JobIdPart -> Text
textJobIdPart = \case
JobIdName name -> textJobName name
- JobIdCommit _ cid -> textCommitId cid
- JobIdTree _ _ tid -> textTreeId tid
+ JobIdRepo _ (JobIdTree _ tid) -> textTreeId tid
+ JobIdRepo _ (JobIdCommit cid) -> textCommitId cid
+ JobIdRepo _ (JobIdTag cid tid) -> textCommitId cid <> "^" <> textTagId tid
textJobId :: JobId -> Text
textJobId (JobId ids) = T.intercalate "." $ map textJobIdPart ids
@@ -136,3 +143,32 @@ lastJobNameId (JobId ids) = go Nothing ids
go _ (JobIdName name : rest) = go (Just name) rest
go cur (_ : rest) = go cur rest
go cur [] = cur
+
+
+data JobSetDep
+ = SiblingJobDependency JobName
+ | RepoDependency RepoName RepoDepLevel
+
+data RepoDepLevel
+ = RepoDepSubtree FilePath
+ | RepoDepCommit
+ | RepoDepTag
+
+instance Semigroup RepoDepLevel where
+ RepoDepTag <> _ = RepoDepTag
+ _ <> RepoDepTag = RepoDepTag
+
+ RepoDepCommit <> _ = RepoDepCommit
+ _ <> RepoDepCommit = RepoDepCommit
+
+ RepoDepSubtree path <> RepoDepSubtree path' = RepoDepSubtree $
+ joinPath $ commonPrefix (splitDirectories path) (splitDirectories path')
+ where
+ commonPrefix (x : xs) (y : ys) | x == y = x : commonPrefix xs ys
+ commonPrefix _ _ = []
+
+repoDepPath :: RepoDepLevel -> FilePath
+repoDepPath = \case
+ RepoDepSubtree path -> path
+ RepoDepCommit -> ""
+ RepoDepTag -> ""
diff --git a/src/Repo.hs b/src/Repo.hs
index 4222f2f..2093a9a 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -2,17 +2,18 @@ module Repo (
Repo, getRepoWorkDir,
DeclaredRepo(..),
RepoName(..), textRepoName, showRepoName,
- Commit, commitId,
+ Commit, commitId, commitRepo,
CommitId, textCommitId, showCommitId,
Tree, treeId, treeRepo, treeSubdir,
TreeId, textTreeId, showTreeId,
Tag(..),
+ TagId, textTagId, showTagId,
openRepo,
readCommit, readCommitId, tryReadCommit,
readTree, readTreeId, tryReadTree,
readBranch,
- readTag,
+ readTag, tryReadTag,
listCommits, listCommitsFrom,
mergeBase,
findUpstreamRef,
@@ -109,6 +110,7 @@ data Tree = Tree
data Tag a = Tag
{ tagTag :: Text
+ , tagId :: TagId
, tagObject :: a
, tagMessage :: Text
}
@@ -139,6 +141,15 @@ textTreeId (TreeId tid) = decodeUtf8 tid
showTreeId :: TreeId -> String
showTreeId (TreeId tid) = BC.unpack tid
+newtype TagId = TagId ByteString
+ deriving (Eq, Ord)
+
+textTagId :: TagId -> Text
+textTagId (TagId tid) = decodeUtf8 tid
+
+showTagId :: TagId -> String
+showTagId (TagId tid) = BC.unpack tid
+
runGitCommand :: MonadIO m => Repo -> [ String ] -> m String
runGitCommand GitRepo {..} args = liftIO $ do
@@ -213,14 +224,22 @@ readCommitFromFile repo@GitRepo {..} path = liftIO $ do
readBranch :: MonadIO m => Repo -> Text -> m (Maybe Commit)
readBranch repo branch = readCommitFromFile repo ("refs/heads" </> T.unpack branch)
-readTag :: MonadIO m => Repo -> Text -> m (Maybe (Tag Commit))
-readTag repo tag = do
- ( infoPart, message ) <-
+readTag :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Tag Commit)
+readTag repo@GitRepo {..} tag = maybe (fail err) return =<< tryReadTag repo tag
+ where err = "tag ‘" <> T.unpack tag <> "’ not found in ‘" <> gitDir <> "’"
+
+tryReadTag :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe (Tag Commit))
+tryReadTag repo tag = do
+ mbTagId <- fmap TagId <$> tryReadObjectId repo "tag" tag
+ mbCat <- forM mbTagId $ \tid ->
fmap (fmap (drop 1) . span (not . null) . lines) $
- runGitCommand repo [ "cat-file", "tag", T.unpack tag ]
- let info = map (fmap (drop 1) . span (/= ' ')) infoPart
+ runGitCommand repo [ "cat-file", "tag", showTagId tid ]
sequence $ do
+ tagId <- mbTagId
+ ( infoPart, message ) <- mbCat
+ let info = map (fmap (drop 1) . span (/= ' ')) infoPart
+
otype <- lookup "type" info
guard (otype == "commit")
tagTag <- T.pack <$> lookup "tag" info
@@ -428,7 +447,7 @@ repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case
mapM_ (`writeTVar` commit) tvars
_ <- addWatch inotify [ MoveIn ] (BC.pack tagsDir) $ \event -> do
- readTag repo (decodeUtf8 $ filePath event) >>= \case
+ tryReadTag repo (decodeUtf8 $ filePath event) >>= \case
Just tag -> atomically $ writeTChan tagsChan tag
Nothing -> return ()