Use common checkout subdirectory in job ID

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
diff --git a/src/Job.hs b/src/Job.hs
index beed17d..61ddbb5 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -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