diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command/Checkout.hs | 10 | ||||
| -rw-r--r-- | src/Config.hs | 13 | ||||
| -rw-r--r-- | src/Eval.hs | 4 | ||||
| -rw-r--r-- | src/Job.hs | 15 | ||||
| -rw-r--r-- | src/Job/Types.hs | 2 | ||||
| -rw-r--r-- | src/Repo.hs | 8 |
6 files changed, 30 insertions, 22 deletions
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 @@ -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 () |