From 5756e4582648794e9603fbd8e84df25221fb7ff5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 18 Jul 2026 15:44:02 +0200 Subject: Tag and commit support in job id parts --- src/Eval.hs | 180 +++++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 123 insertions(+), 57 deletions(-) (limited to 'src/Eval.hs') 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 <> "’" -- cgit v1.2.3