From 52dca5dc0e60d4d84aa5ecf280a45b24f1111dda Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 15 Mar 2025 15:29:01 +0100
Subject: Checkout referenced repos when preparing job
---
src/Command/Checkout.hs | 10 +++-------
src/Config.hs | 13 +++++++------
src/Eval.hs | 4 ++--
src/Job.hs | 15 +++++++++++++--
src/Job/Types.hs | 2 +-
src/Repo.hs | 8 ++++----
6 files changed, 30 insertions(+), 22 deletions(-)
(limited to 'src')
diff --git a/src/Command/Checkout.hs b/src/Command/Checkout.hs
index 3667e76..7cba593 100644
--- a/src/Command/Checkout.hs
+++ b/src/Command/Checkout.hs
@@ -52,11 +52,7 @@ instance Command CheckoutCommand where
cmdCheckout :: CheckoutCommand -> CommandExec ()
cmdCheckout (CheckoutCommand CheckoutOptions {..} name mbrev) = do
repo <- maybe getDefaultRepo getRepo name
- root <- getCommitTree =<< case mbrev of
- Just revision -> readCommit repo revision
- Nothing -> createWipCommit repo
- tree <- case coSubtree of
- Nothing -> return root
- Just subtree -> maybe (fail $ "subtree `" <> subtree <> "' not found in " <> maybe "current worktree" (("revision `" <>) . (<> "'") . T.unpack) mbrev) return =<<
- getSubtree subtree root
+ mbCommit <- sequence $ fmap (readCommit repo) mbrev
+ root <- getCommitTree =<< maybe (createWipCommit repo) return mbCommit
+ tree <- maybe return (getSubtree mbCommit) coSubtree $ root
checkoutAt tree $ maybe "." id coDestination
diff --git a/src/Config.hs b/src/Config.hs
index 68db57d..13be619 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -85,17 +85,18 @@ parseJob name node = flip (withMap "Job") node $ \j -> do
jobUses <- maybe (return []) parseUses =<< j .:? "uses"
return Job {..}
-parseSingleCheckout :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, JobCheckout ) ]
+parseSingleCheckout :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]
parseSingleCheckout = withMap "checkout definition" $ \m -> do
- mbName <- m .:? "repo"
jcSubtree <- fmap T.unpack <$> m .:? "subtree"
jcDestination <- fmap T.unpack <$> m .:? "dest"
let checkout = JobCheckout {..}
- return $ (: []) $ case mbName of
- Nothing -> Left checkout
- Just name -> Right ( DeclaredJobRepo (RepoName name), checkout )
+ m .:? "repo" >>= \case
+ Nothing -> return [ Left checkout ]
+ Just name -> do
+ revision <- m .:? "revision"
+ return [ Right ( DeclaredJobRepo (RepoName name), revision, checkout ) ]
-parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, JobCheckout ) ]
+parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]
parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout
cabalJob :: Node Pos -> Parser [CreateProcess]
diff --git a/src/Eval.hs b/src/Eval.hs
index 9130dd3..b263a19 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -28,10 +28,10 @@ textEvalError (OtherEvalError text) = text
evalJob :: EvalInput -> DeclaredJob -> Except EvalError Job
evalJob EvalInput {..} decl = do
- otherCheckout <- forM (jobOtherCheckout decl) $ \( DeclaredJobRepo name, checkout ) -> do
+ otherCheckout <- forM (jobOtherCheckout decl) $ \( DeclaredJobRepo name, revision, checkout ) -> do
repo <- maybe (throwError $ OtherEvalError $ "repo `" <> textRepoName name <> "' not defined") return $
lookup name eiOtherRepos
- return ( EvaluatedJobRepo repo, checkout )
+ return ( EvaluatedJobRepo repo, revision, checkout )
return Job
{ jobName = jobName decl
, jobContainingCheckout = jobContainingCheckout decl
diff --git a/src/Job.hs b/src/Job.hs
index 1d30489..820f5e5 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -286,12 +286,23 @@ prepareJob dir mbCommit job inner = do
jdirCommit <- case mbCommit of
Just commit -> do
tree <- getCommitTree commit
- checkoutAt tree checkoutPath
+ forM_ (jobContainingCheckout job) $ \(JobCheckout mbsub dest) -> do
+ subtree <- maybe return (getSubtree mbCommit) mbsub $ tree
+ checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
return $ showTreeId (treeId tree) </> stringJobName (jobName job)
Nothing -> do
+ when (not $ null $ jobContainingCheckout job) $ do
+ fail $ "no containing repository, can't do checkout"
return $ stringJobName (jobName job)
- let jdir = dir </> "jobs" </> jdirCommit
+ jdirOther <- forM (jobOtherCheckout job) $ \( EvaluatedJobRepo repo, revision, JobCheckout mbsub dest ) -> do
+ commit <- readCommit repo $ fromMaybe "HEAD" revision
+ tree <- getCommitTree commit
+ subtree <- maybe return (getSubtree (Just commit)) mbsub $ tree
+ checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
+ return $ showTreeId (treeId tree)
+
+ let jdir = dir </> "jobs" </> jdirCommit </> joinPath jdirOther
liftIO $ createDirectoryIfMissing True jdir
inner checkoutPath jdir
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index a16ba1d..4de9ef9 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -14,7 +14,7 @@ data Evaluated
data Job' d = Job
{ jobName :: JobName
, jobContainingCheckout :: [ JobCheckout ]
- , jobOtherCheckout :: [ ( JobRepo d, JobCheckout ) ]
+ , jobOtherCheckout :: [ ( JobRepo d, Maybe Text, JobCheckout ) ]
, jobRecipe :: [ CreateProcess ]
, jobArtifacts :: [ ( ArtifactName, CreateProcess ) ]
, jobUses :: [ ( JobName, ArtifactName ) ]
diff --git a/src/Repo.hs b/src/Repo.hs
index 2568fff..702f09d 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -250,17 +250,17 @@ getCommitMessage :: (MonadIO m, MonadFail m) => Commit -> m Text
getCommitMessage = fmap commitMessage . getCommitDetails
-getSubtree :: MonadIO m => FilePath -> Tree -> m (Maybe Tree)
-getSubtree path tree = liftIO $ do
+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 $ Just Tree
+ return Tree
{ treeRepo = treeRepo tree
, treeId = TreeId (BC.pack tid)
}
_ -> do
- return Nothing
+ fail $ "subtree `" <> path <> "' not found" <> maybe "" (("in revision `" <>) . (<> "'") . showCommitId . commitId) mbCommit
checkoutAt :: (MonadIO m, MonadFail m) => Tree -> FilePath -> m ()
--
cgit v1.2.3