diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Eval.hs | 39 | ||||
| -rw-r--r-- | src/Job.hs | 4 | ||||
| -rw-r--r-- | src/Repo.hs | 22 |
3 files changed, 36 insertions, 29 deletions
diff --git a/src/Eval.hs b/src/Eval.hs index 6413ecb..4e9f528 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -65,7 +65,7 @@ collectOtherRepos decl = do [ if missingDefault then map (( Nothing, Nothing ), ) $ jobContainingCheckout decl else [] , map (first (first Just)) $ jobOtherCheckout decl ] - let commonSubdir reporev = joinPath $ foldr commonPrefix [] $ + let commonSubdir reporev = joinPath $ foldr1 commonPrefix $ map (maybe [] splitDirectories . jcSubtree . snd) . filter ((reporev ==) . fst) $ checkouts return $ map (\r -> ( r, commonSubdir r )) . nub . map fst $ checkouts @@ -74,20 +74,21 @@ evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJob -> Eval Job evalJob revisionOverrides decl = do EvalInput {..} <- ask otherRepos <- collectOtherRepos decl - otherRepoIds <- forM otherRepos $ \(( mbname, mbrev ), _ ) -> do - tree <- case lookup mbname revisionOverrides of + otherRepoTrees <- forM otherRepos $ \(( mbname, mbrev ), commonPath ) -> do + ( mbname, ) <$> case lookup mbname revisionOverrides of Just tree -> return tree Nothing -> case maybe eiContainingRepo (flip lookup eiOtherRepos) mbname of - Just repo -> getCommitTree =<< readCommit repo (fromMaybe "HEAD" mbrev) + Just repo -> do + commit <- readCommit repo (fromMaybe "HEAD" mbrev) + getSubtree (Just commit) commonPath =<< getCommitTree commit Nothing -> throwError $ OtherEvalError $ "repo ‘" <> maybe "" textRepoName mbname <> "’ not defined" - return $ JobIdTree mbname $ treeId tree - otherCheckout <- forM (jobOtherCheckout decl) $ \(( name, revision ), checkout ) -> do - tree <- case lookup (Just name) revisionOverrides of + + otherCheckout <- forM (jobOtherCheckout decl) $ \(( name, _ ), checkout ) -> do + (, checkout ) <$> case lookup (Just name) otherRepoTrees of Just tree -> return tree - Nothing -> case lookup name eiOtherRepos of - Just repo -> getCommitTree =<< readCommit repo (fromMaybe "HEAD" revision) - Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined" - return ( tree, checkout ) + Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined" + + let otherRepoIds = map (uncurry JobIdTree . fmap treeId) otherRepoTrees return Job { jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId decl) : eiCurrentIdRev , jobName = jobName decl @@ -124,8 +125,8 @@ canonicalJobName (r : rs) config = do Just djob -> do otherRepos <- collectOtherRepos djob ( overrides, rs' ) <- (\f -> foldM f ( [], rs ) otherRepos) $ - \( overrides, crs ) (( mbname, _ ), _ ) -> do - ( tree, crs' ) <- readTreeFromIdRef crs =<< evalRepo mbname + \( overrides, crs ) (( mbname, _ ), path ) -> do + ( tree, crs' ) <- readTreeFromIdRef crs path =<< evalRepo mbname return ( ( mbname, tree ) : overrides, crs' ) case rs' of (r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’" @@ -134,18 +135,18 @@ canonicalJobName (r : rs) config = do Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found" canonicalJobName [] _ = throwError $ OtherEvalError "expected job name" -readTreeFromIdRef :: [ Text ] -> Repo -> Eval ( Tree, [ Text ] ) -readTreeFromIdRef (r : rs) repo = do +readTreeFromIdRef :: [ Text ] -> FilePath -> Repo -> Eval ( Tree, [ Text ] ) +readTreeFromIdRef (r : rs) subdir repo = do tryReadCommit repo r >>= \case - Just commit -> (, rs) <$> getCommitTree commit - Nothing -> tryReadTree repo r >>= \case + Just commit -> return . (, rs) =<< getSubtree (Just commit) subdir =<< getCommitTree commit + Nothing -> tryReadTree repo subdir r >>= \case Just tree -> return ( 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" +readTreeFromIdRef [] _ _ = throwError $ OtherEvalError $ "expected commit or tree reference" canonicalCommitConfig :: [ Text ] -> Repo -> Eval JobId canonicalCommitConfig rs repo = do - ( tree, rs' ) <- readTreeFromIdRef rs repo + ( tree, rs' ) <- readTreeFromIdRef rs "" repo config <- either fail return =<< loadConfigForCommit tree local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing (treeId tree) : eiCurrentIdRev ei }) $ canonicalJobName rs' config @@ -291,14 +291,14 @@ prepareJob dir mbCommit job inner = do Just commit -> do tree <- getCommitTree commit forM_ (jobContainingCheckout job) $ \(JobCheckout mbsub dest) -> do - subtree <- maybe return (getSubtree mbCommit) mbsub $ tree + subtree <- maybe return (getSubtree mbCommit . makeRelative (treeSubdir tree)) mbsub $ tree checkoutAt subtree $ checkoutPath </> fromMaybe "" dest Nothing -> do when (not $ null $ jobContainingCheckout job) $ do fail $ "no containing repository, can't do checkout" forM_ (jobOtherCheckout job) $ \( tree, JobCheckout mbsub dest ) -> do - subtree <- maybe return (getSubtree Nothing) mbsub $ tree + subtree <- maybe return (getSubtree Nothing . makeRelative (treeSubdir tree)) mbsub $ tree checkoutAt subtree $ checkoutPath </> fromMaybe "" dest let JobId jidParts = jobId job diff --git a/src/Repo.hs b/src/Repo.hs index dc88c4b..ce5d9ef 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -4,7 +4,7 @@ module Repo ( RepoName(..), textRepoName, showRepoName, Commit, commitId, CommitId, textCommitId, showCommitId, - Tree, treeId, treeRepo, + Tree, treeId, treeRepo, treeSubdir, TreeId, textTreeId, showTreeId, Tag(..), @@ -101,8 +101,9 @@ data CommitDetails = CommitDetails } data Tree = Tree - { treeRepo :: Repo - , treeId :: TreeId + { treeRepo :: Repo -- ^ Repository in which the tree is tored + , treeId :: TreeId -- ^ Tree ID + , treeSubdir :: FilePath -- ^ Subdirectory represented by this tree (from the repo root) } data Tag a = Tag @@ -177,12 +178,15 @@ readCommit repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadCommit rep tryReadCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Commit) tryReadCommit repo ref = sequence . fmap (mkCommit repo . CommitId) =<< tryReadObjectId repo "commit" ref -readTree :: (MonadIO m, MonadFail m) => Repo -> Text -> m Tree -readTree repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadTree repo ref +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 <> "'" -tryReadTree :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Tree) -tryReadTree repo ref = return . fmap (Tree repo . TreeId) =<< tryReadObjectId repo "tree" ref +tryReadTree :: (MonadIO m, MonadFail m) => Repo -> FilePath -> Text -> m (Maybe Tree) +tryReadTree treeRepo treeSubdir ref = do + fmap (fmap TreeId) (tryReadObjectId treeRepo "tree" ref) >>= \case + Just treeId -> return $ Just Tree {..} + Nothing -> return Nothing tryReadObjectId :: (MonadIO m, MonadFail m) => Repo -> Text -> Text -> m (Maybe ByteString) tryReadObjectId GitRepo {..} otype ref = do @@ -255,6 +259,7 @@ getCommitDetails Commit {..} = do Just treeId <- return $ TreeId . BC.pack <$> lookup "tree" info let treeRepo = commitRepo + treeSubdir = "" let commitTree = Tree {..} let commitTitle = T.pack title let commitMessage = T.pack $ unlines $ dropWhile null message @@ -275,11 +280,12 @@ 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 + 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 |