Track other used repos in job ID

5 files changed, 109 insertions, 73 deletions

diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index 0535955..9370eca 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -134,7 +134,7 @@ argumentJobSource names = do
             return ( config, Just commit )
 
     cidPart <- case jobsetCommit of
-        Just commit -> (: []) . JobIdTree . treeId <$> getCommitTree commit
+        Just commit -> (: []) . JobIdTree Nothing . treeId <$> getCommitTree commit
         Nothing -> return []
     jobsetJobsEither <- fmap Right $ forM names $ \name ->
         case find ((name ==) . jobName) (configJobs config) of
@@ -142,7 +142,7 @@ argumentJobSource names = do
             Nothing -> tfail $ "job `" <> textJobName name <> "' not found"
     oneshotJobSource . (: []) =<<
         cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei })
-        (evalJobSet JobSet {..})
+        (evalJobSet [] JobSet {..})
 
 loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet
 loadJobSetFromRoot root commit = case root of
@@ -160,8 +160,8 @@ rangeSource base tip = do
     jobsets <- forM commits $ \commit -> do
         tree <- getCommitTree commit
         cmdEvalWith (\ei -> ei
-            { eiCurrentIdRev = JobIdTree (treeId tree) : eiCurrentIdRev ei
-            }) . evalJobSet =<< loadJobSetFromRoot root commit
+            { eiCurrentIdRev = JobIdTree Nothing (treeId tree) : eiCurrentIdRev ei
+            }) . evalJobSet [] =<< loadJobSetFromRoot root commit
     oneshotJobSource jobsets
 
 
@@ -183,10 +183,10 @@ watchBranchSource branch = do
             jobsets <- forM commits $ \commit -> do
                 tree <- getCommitTree commit
                 let einput = einputBase
-                        { eiCurrentIdRev = JobIdTree (treeId tree) : eiCurrentIdRev einputBase
+                        { eiCurrentIdRev = JobIdTree Nothing (treeId tree) : eiCurrentIdRev einputBase
                         }
                 either (fail . T.unpack . textEvalError) return =<<
-                    flip runEval einput . evalJobSet =<< loadJobSetFromRoot root commit
+                    flip runEval einput . evalJobSet [] =<< loadJobSetFromRoot root commit
             nextvar <- newEmptyTMVarIO
             atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar )
             go cur nextvar
@@ -213,10 +213,10 @@ watchTagSource pat = do
               then do
                 tree <- getCommitTree $ tagObject tag
                 let einput = einputBase
-                        { eiCurrentIdRev = JobIdTree (treeId tree) : eiCurrentIdRev einputBase
+                        { eiCurrentIdRev = JobIdTree Nothing (treeId tree) : eiCurrentIdRev einputBase
                         }
                 jobset <- either (fail . T.unpack . textEvalError) return =<<
-                    flip runEval einput . evalJobSet =<< loadJobSetFromRoot root (tagObject tag)
+                    flip runEval einput . evalJobSet [] =<< loadJobSetFromRoot root (tagObject tag)
                 nextvar <- newEmptyTMVarIO
                 atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar )
                 go nextvar
diff --git a/src/Config.hs b/src/Config.hs
index fb9a527..ade2216 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -93,7 +93,7 @@ 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, Maybe Text, JobCheckout ) ]
+parseSingleCheckout :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, JobCheckout ) ]
 parseSingleCheckout = withMap "checkout definition" $ \m -> do
     jcSubtree <- fmap T.unpack <$> m .:? "subtree"
     jcDestination <- fmap T.unpack <$> m .:? "dest"
@@ -102,9 +102,9 @@ parseSingleCheckout = withMap "checkout definition" $ \m -> do
         Nothing -> return [ Left checkout ]
         Just name -> do
             revision <- m .:? "revision"
-            return [ Right ( RepoName name, revision, checkout ) ]
+            return [ Right (( RepoName name, revision ), checkout ) ]
 
-parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]
+parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, 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 1278c6f..6413ecb 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -12,11 +12,14 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 
+import Data.Bifunctor
 import Data.List
 import Data.Maybe
 import Data.Text (Text)
 import Data.Text qualified as T
 
+import System.FilePath
+
 import Config
 import Job.Types
 import Repo
@@ -42,15 +45,51 @@ runEval :: Eval a -> EvalInput -> IO (Either EvalError a)
 runEval action einput = runExceptT $ flip runReaderT einput action
 
 
-evalJob :: DeclaredJob -> Eval Job
-evalJob decl = do
+commonPrefix :: Eq a => [ a ] -> [ a ] -> [ a ]
+commonPrefix (x : xs) (y : ys) | x == y = x : commonPrefix xs ys
+commonPrefix _        _                 = []
+
+isDefaultRepoMissingInId :: DeclaredJob -> Eval Bool
+isDefaultRepoMissingInId djob
+    | [] <- jobContainingCheckout djob = return False
+    | otherwise = asks (not . any matches . eiCurrentIdRev)
+  where
+    matches (JobIdName _) = False
+    matches (JobIdCommit rname _) = isNothing rname
+    matches (JobIdTree rname _) = isNothing rname
+
+collectOtherRepos :: DeclaredJob -> Eval [ (( Maybe RepoName, Maybe Text ), FilePath ) ]
+collectOtherRepos decl = do
+    missingDefault <- isDefaultRepoMissingInId decl
+    let checkouts = concat
+            [ if missingDefault then map (( Nothing, Nothing ), ) $ jobContainingCheckout decl else []
+            , map (first (first Just)) $ jobOtherCheckout decl
+            ]
+    let commonSubdir reporev = joinPath $ foldr commonPrefix [] $
+            map (maybe [] splitDirectories . jcSubtree . snd) . filter ((reporev ==) . fst) $ checkouts
+    return $ map (\r -> ( r, commonSubdir r )) . nub . map fst $ checkouts
+
+
+evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJob -> Eval Job
+evalJob revisionOverrides decl = do
     EvalInput {..} <- ask
-    otherCheckout <- forM (jobOtherCheckout decl) $ \( name, revision, checkout ) -> do
-        repo <- maybe (throwError $ OtherEvalError $ "repo `" <> textRepoName name <> "' not defined") return $
-            lookup name eiOtherRepos
-        return ( repo, revision, checkout )
+    otherRepos <- collectOtherRepos decl
+    otherRepoIds <- forM otherRepos $ \(( mbname, mbrev ), _ ) -> do
+        tree <- 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)
+                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
+            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 )
     return Job
-        { jobId = JobId $ reverse $ JobIdName (jobId decl) : eiCurrentIdRev
+        { jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId decl) : eiCurrentIdRev
         , jobName = jobName decl
         , jobContainingCheckout = jobContainingCheckout decl
         , jobOtherCheckout = otherCheckout
@@ -59,9 +98,9 @@ evalJob decl = do
         , jobUses = jobUses decl
         }
 
-evalJobSet :: DeclaredJobSet -> Eval JobSet
-evalJobSet decl = do
-    jobs <- either (return . Left) (handleToEither . mapM evalJob) $ jobsetJobsEither decl
+evalJobSet :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet
+evalJobSet revisionOverrides decl = do
+    jobs <- either (return . Left) (handleToEither . mapM (evalJob revisionOverrides)) $ jobsetJobsEither decl
     return JobSet
         { jobsetCommit = jobsetCommit decl
         , jobsetJobsEither = jobs
@@ -69,51 +108,52 @@ evalJobSet decl = do
   where
     handleToEither = handleError (return . Left . T.unpack . textEvalError) . fmap Right
 
+evalRepo :: Maybe RepoName -> Eval Repo
+evalRepo Nothing = asks eiContainingRepo >>= \case
+    Just repo -> return repo
+    Nothing -> throwError $ OtherEvalError $ "no default repo"
+evalRepo (Just name) = asks (lookup name . eiOtherRepos) >>= \case
+    Just repo -> return repo
+    Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined"
+
 
-canonicalJobName :: [ Text ] -> Maybe Tree -> Config -> Eval [ JobIdPart ]
-canonicalJobName (r : rs) mbTree config = do
+canonicalJobName :: [ Text ] -> Config -> Eval JobId
+canonicalJobName (r : rs) config = do
     let name = JobName r
     case find ((name ==) . jobName) (configJobs config) of
         Just djob -> do
-            job <- evalJob djob
-            repos <- concat <$> sequence
-                [ case mbTree of
-                    Just _ -> return []
-                    Nothing -> maybeToList <$> asks eiContainingRepo
-                , return $ nub $ map (\( repo, _, _ ) -> repo) $ jobOtherCheckout job
-                ]
-            (JobIdName name :) <$> canonicalOtherCheckouts rs repos
+            otherRepos <- collectOtherRepos djob
+            ( overrides, rs' ) <- (\f -> foldM f ( [], rs ) otherRepos) $
+                \( overrides, crs ) (( mbname, _ ), _ ) -> do
+                    ( tree, crs' ) <- readTreeFromIdRef crs =<< evalRepo mbname
+                    return ( ( mbname, tree ) : overrides, crs' )
+            case rs' of
+                (r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’"
+                _ -> return ()
+            jobId <$> evalJob overrides djob
         Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found"
-canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name"
+canonicalJobName [] _ = throwError $ OtherEvalError "expected job name"
 
-canonicalOtherCheckouts :: [ Text ] -> [ Repo ] -> Eval [ JobIdPart ]
-canonicalOtherCheckouts (r : rs) (repo : repos) = do
-    tree <- tryReadCommit repo r >>= \case
-        Just commit -> getCommitTree commit
+readTreeFromIdRef :: [ Text ] -> Repo -> Eval ( Tree, [ Text ] )
+readTreeFromIdRef (r : rs) repo = do
+    tryReadCommit repo r >>= \case
+        Just commit -> (, rs) <$> getCommitTree commit
         Nothing -> tryReadTree repo r >>= \case
-            Just tree -> return tree
-            Nothing -> throwError $ OtherEvalError $ "failed to resolve ‘" <> r <> "’ to a commit or tree in " <> T.pack (show repo)
-    (JobIdTree (treeId tree) :) <$> canonicalOtherCheckouts rs repos
-canonicalOtherCheckouts []       []       = return []
-canonicalOtherCheckouts []       (_ : _ ) = throwError $ OtherEvalError $ "expected commit or tree reference"
-canonicalOtherCheckouts (r : _)  []       = throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r <> "’"
-
-canonicalCommitConfig :: [ Text ] -> Repo -> Eval [ JobIdPart ]
-canonicalCommitConfig (r : rs) repo = do
-    tree <- tryReadCommit repo r >>= \case
-        Just commit -> getCommitTree commit
-        Nothing -> tryReadTree repo r >>= \case
-            Just tree -> return tree
+            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"
+
+canonicalCommitConfig :: [ Text ] -> Repo -> Eval JobId
+canonicalCommitConfig rs repo = do
+    ( tree, rs' ) <- readTreeFromIdRef rs repo
     config <- either fail return =<< loadConfigForCommit tree
-    (JobIdTree (treeId tree) :) <$> canonicalJobName rs (Just tree) config
-canonicalCommitConfig [] _ = throwError $ OtherEvalError "expected commit or tree reference"
+    local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing (treeId tree) : eiCurrentIdRev ei }) $
+        canonicalJobName rs' config
 
 evalJobReference :: JobRef -> Eval JobId
 evalJobReference (JobRef rs) =
-    JobId <$> do
-        asks eiJobRoot >>= \case
-            JobRootRepo defRepo -> do
-                canonicalCommitConfig rs defRepo
-            JobRootConfig config -> do
-                canonicalJobName rs Nothing config
+    asks eiJobRoot >>= \case
+        JobRootRepo defRepo -> do
+            canonicalCommitConfig rs defRepo
+        JobRootConfig config -> do
+            canonicalJobName rs config
diff --git a/src/Job.hs b/src/Job.hs
index 5a4cf7e..afc9f91 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -183,19 +183,17 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case
 
 runJobs :: JobManager -> TerminalOutput -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
 runJobs mngr@JobManager {..} tout commit jobs = do
-    tree <- sequence $ fmap getCommitTree commit
     results <- atomically $ do
         forM jobs $ \job -> do
-            let jid = JobId $ concat [ JobIdTree . treeId <$> maybeToList tree, [ JobIdName (jobName job) ] ]
             tid <- reserveTaskId mngr
             managed <- readTVar jmJobs
-            ( job, tid, ) <$> case M.lookup jid managed of
+            ( job, tid, ) <$> case M.lookup (jobId job) managed of
                 Just origVar -> do
-                    newTVar . JobDuplicate jid =<< readTVar origVar
+                    newTVar . JobDuplicate (jobId job) =<< readTVar origVar
 
                 Nothing -> do
                     statusVar <- newTVar JobQueued
-                    writeTVar jmJobs $ M.insert jid statusVar managed
+                    writeTVar jmJobs $ M.insert (jobId job) statusVar managed
                     return statusVar
 
     forM_ results $ \( job, tid, outVar ) -> void $ forkIO $ do
@@ -297,10 +295,8 @@ prepareJob dir mbCommit job inner = do
                     fail $ "no containing repository, can't do checkout"
                 return $ stringJobName (jobName job)
 
-        jdirOther <- forM (jobOtherCheckout job) $ \( repo, revision, JobCheckout mbsub dest ) -> do
-            commit <- readCommit repo $ fromMaybe "HEAD" revision
-            tree <- getCommitTree commit
-            subtree <- maybe return (getSubtree (Just commit)) mbsub $ tree
+        jdirOther <- forM (jobOtherCheckout job) $ \( tree, JobCheckout mbsub dest ) -> do
+            subtree <- maybe return (getSubtree Nothing) mbsub $ tree
             checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
             return $ showTreeId (treeId tree)
 
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index 19cf560..b5d05fb 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -17,7 +17,7 @@ data Job' d = Job
     { jobId :: JobId' d
     , jobName :: JobName
     , jobContainingCheckout :: [ JobCheckout ]
-    , jobOtherCheckout :: [ ( JobRepo d, Maybe Text, JobCheckout ) ]
+    , jobOtherCheckout :: [ ( JobRepo d, JobCheckout ) ]
     , jobRecipe :: [ CreateProcess ]
     , jobArtifacts :: [ ( ArtifactName, Pattern ) ]
     , jobUses :: [ ( JobName, ArtifactName ) ]
@@ -41,8 +41,8 @@ textJobName (JobName name) = name
 
 
 type family JobRepo d :: Type where
-    JobRepo Declared = RepoName
-    JobRepo Evaluated = Repo
+    JobRepo Declared = ( RepoName, Maybe Text )
+    JobRepo Evaluated = Tree
 
 data JobCheckout = JobCheckout
     { jcSubtree :: Maybe FilePath
@@ -71,8 +71,8 @@ newtype JobId = JobId [ JobIdPart ]
 
 data JobIdPart
     = JobIdName JobName
-    | JobIdCommit CommitId
-    | JobIdTree TreeId
+    | JobIdCommit (Maybe RepoName) CommitId
+    | JobIdTree (Maybe RepoName) TreeId
     deriving (Eq, Ord)
 
 newtype JobRef = JobRef [ Text ]
@@ -81,8 +81,8 @@ newtype JobRef = JobRef [ Text ]
 textJobIdPart :: JobIdPart -> Text
 textJobIdPart = \case
     JobIdName name -> textJobName name
-    JobIdCommit cid -> textCommitId cid
-    JobIdTree tid -> textTreeId tid
+    JobIdCommit _ cid -> textCommitId cid
+    JobIdTree _ tid -> textTreeId tid
 
 textJobId :: JobId -> Text
 textJobId (JobId ids) = T.intercalate "." $ map textJobIdPart ids