Evaluate jobs with all checkouts in the Eval monad

8 files changed, 71 insertions, 77 deletions

diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs
index 4336b29..8a0a035 100644
--- a/src/Command/Extract.hs
+++ b/src/Command/Extract.hs
@@ -78,7 +78,7 @@ cmdExtract (ExtractCommand ExtractOptions {..} ExtractArguments {..}) = do
             _     -> return False
 
     forM_ extractArtifacts $ \( ref, ArtifactName aname ) -> do
-        jid@(JobId ids) <- either (tfail . textEvalError) return =<<
+        jid@(JobId ids) <- either (tfail . textEvalError) (return . jobId) =<<
             liftIO (runEval (evalJobReference ref) einput)
 
         let jdir = joinPath $ (storageDir :) $ ("jobs" :) $ map (T.unpack . textJobIdPart) ids
diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs
index 429e2a0..173f543 100644
--- a/src/Command/JobId.hs
+++ b/src/Command/JobId.hs
@@ -52,7 +52,7 @@ cmdJobId :: JobIdCommand -> CommandExec ()
 cmdJobId (JobIdCommand JobIdOptions {..} ref) = do
     einput <- getEvalInput
     out <- getOutput
-    JobId ids <- either (tfail . textEvalError) return =<<
+    JobId ids <- either (tfail . textEvalError) (return . jobId) =<<
         liftIO (runEval (evalJobReference ref) einput)
 
     outputMessage out $ textJobId $ JobId ids
diff --git a/src/Command/Log.hs b/src/Command/Log.hs
index 5d8c9d4..25bfc06 100644
--- a/src/Command/Log.hs
+++ b/src/Command/Log.hs
@@ -37,7 +37,7 @@ instance Command LogCommand where
 cmdLog :: LogCommand -> CommandExec ()
 cmdLog (LogCommand ref) = do
     einput <- getEvalInput
-    jid <- either (tfail . textEvalError) return =<<
+    jid <- either (tfail . textEvalError) (return . jobId) =<<
         liftIO (runEval (evalJobReference ref) einput)
     output <- getOutput
     storageDir <- getStorageDir
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index ce1ea4a..c122cf6 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -135,16 +135,17 @@ argumentJobSource names = do
             config <- either fail return =<< loadConfigForCommit =<< getCommitTree commit
             return ( config, Just commit )
 
-    cidPart <- case jobsetCommit of
-        Just commit -> (: []) . JobIdTree Nothing "" . treeId <$> getCommitTree commit
+    jobtree <- case jobsetCommit of
+        Just commit -> (: []) <$> getCommitTree commit
         Nothing -> return []
+    let cidPart = map (JobIdTree Nothing "" . treeId) jobtree
     jobsetJobsEither <- fmap Right $ forM names $ \name ->
         case find ((name ==) . jobName) (configJobs config) of
             Just job -> return job
             Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found"
     oneshotJobSource . (: []) =<<
         cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei })
-        (evalJobSet [] JobSet {..})
+        (evalJobSet (map ( Nothing, ) jobtree) JobSet {..})
 
 loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet
 loadJobSetFromRoot root commit = case root of
@@ -163,7 +164,7 @@ rangeSource base tip = do
         tree <- getCommitTree commit
         cmdEvalWith (\ei -> ei
             { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev ei
-            }) . evalJobSet [] =<< loadJobSetFromRoot root commit
+            }) . evalJobSet [ ( Nothing, tree) ] =<< loadJobSetFromRoot root commit
     oneshotJobSource jobsets
 
 
@@ -188,7 +189,7 @@ watchBranchSource branch = do
                         { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase
                         }
                 either (fail . T.unpack . textEvalError) return =<<
-                    flip runEval einput . evalJobSet [] =<< loadJobSetFromRoot root commit
+                    flip runEval einput . evalJobSet [ ( Nothing, tree ) ] =<< loadJobSetFromRoot root commit
             nextvar <- newEmptyTMVarIO
             atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar )
             go cur nextvar
@@ -218,7 +219,7 @@ watchTagSource pat = do
                         { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase
                         }
                 jobset <- either (fail . T.unpack . textEvalError) return =<<
-                    flip runEval einput . evalJobSet [] =<< loadJobSetFromRoot root (tagObject tag)
+                    flip runEval einput . evalJobSet [ ( Nothing, tree ) ] =<< loadJobSetFromRoot root (tagObject tag)
                 nextvar <- newEmptyTMVarIO
                 atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar )
                 go nextvar
@@ -305,7 +306,7 @@ cmdRun (RunCommand RunOptions {..} args) = do
 
                 case jobsetJobsEither jobset of
                     Right jobs -> do
-                        outs <- runJobs mngr output commit jobs
+                        outs <- runJobs mngr output jobs
                         let findJob name = snd <$> find ((name ==) . jobName . fst) outs
                             statuses = map findJob names
                         forM_ (outputTerminal output) $ \tout -> do
diff --git a/src/Config.hs b/src/Config.hs
index ade2216..4327193 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -13,7 +13,6 @@ import Control.Monad.Combinators
 import Control.Monad.IO.Class
 
 import Data.ByteString.Lazy qualified as BS
-import Data.Either
 import Data.List
 import Data.Map qualified as M
 import Data.Maybe
@@ -79,11 +78,11 @@ parseJob :: Text -> Node Pos -> Parser DeclaredJob
 parseJob name node = flip (withMap "Job") node $ \j -> do
     let jobName = JobName name
         jobId = jobName
-    ( jobContainingCheckout, jobOtherCheckout ) <- partitionEithers <$> choice
+    jobCheckout <- choice
         [ parseSingleCheckout =<< j .: "checkout"
         , parseMultipleCheckouts =<< j .: "checkout"
         , withNull "no checkout" (return []) =<< j .: "checkout"
-        , return [ Left $ JobCheckout Nothing Nothing ]
+        , return [ JobCheckout Nothing Nothing Nothing ]
         ]
     jobRecipe <- choice
         [ cabalJob =<< j .: "cabal"
@@ -93,18 +92,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 [ JobCheckout Declared ]
 parseSingleCheckout = withMap "checkout definition" $ \m -> do
     jcSubtree <- fmap T.unpack <$> m .:? "subtree"
     jcDestination <- fmap T.unpack <$> m .:? "dest"
-    let checkout = JobCheckout {..}
-    m .:? "repo" >>= \case
-        Nothing -> return [ Left checkout ]
+    jcRepo <- m .:? "repo" >>= \case
+        Nothing -> return Nothing
         Just name -> do
             revision <- m .:? "revision"
-            return [ Right (( RepoName name, revision ), checkout ) ]
+            return $ Just ( RepoName name, revision )
+    return [ JobCheckout {..} ]
 
-parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, JobCheckout ) ]
+parseMultipleCheckouts :: Node Pos -> Parser [ JobCheckout Declared ]
 parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout
 
 cabalJob :: Node Pos -> Parser [CreateProcess]
diff --git a/src/Eval.hs b/src/Eval.hs
index 05381dd..97aba2f 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -12,7 +12,6 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 
-import Data.Bifunctor
 import Data.List
 import Data.Maybe
 import Data.Text (Text)
@@ -51,57 +50,62 @@ commonPrefix _        _                 = []
 
 isDefaultRepoMissingInId :: DeclaredJob -> Eval Bool
 isDefaultRepoMissingInId djob
-    | [] <- jobContainingCheckout djob = return False
+    | all (isJust . jcRepo) (jobCheckout djob) = return False
     | otherwise = asks (not . any matches . eiCurrentIdRev)
   where
     matches (JobIdName _) = False
     matches (JobIdCommit rname _) = isNothing rname
     matches (JobIdTree rname _ _) = isNothing rname
 
-collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ (( Maybe RepoName, Maybe Text ), FilePath ) ]
+collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), FilePath ) ]
 collectOtherRepos dset decl = do
     let dependencies = map fst $ jobUses decl
     dependencyRepos <- forM dependencies $ \name -> do
         jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset
         job <- maybe (throwError $ OtherEvalError $ "job ‘" <> textJobName name <> "’ not found") return . find ((name ==) . jobName) $ jobs
-        return $ jobOtherCheckout job
+        return $ jobCheckout job
 
     missingDefault <- isDefaultRepoMissingInId decl
 
-    let checkouts = concat
-            [ if missingDefault then map (( Nothing, Nothing ), ) $ jobContainingCheckout decl else []
-            , map (first (first Just)) $ jobOtherCheckout decl
-            , map (first (first Just)) $ concat dependencyRepos
-            ]
+    let checkouts =
+            (if missingDefault then id else (filter (isJust . jcRepo))) $
+            concat
+                [ jobCheckout decl
+                , concat dependencyRepos
+                ]
     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
+            map (maybe [] splitDirectories . jcSubtree) . filter ((reporev ==) . jcRepo) $ checkouts
+    return $ map (\r -> ( r, commonSubdir r )) . nub . map jcRepo $ checkouts
 
 
 evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> DeclaredJob -> Eval Job
 evalJob revisionOverrides dset decl = do
     EvalInput {..} <- ask
     otherRepos <- collectOtherRepos dset decl
-    otherRepoTrees <- forM otherRepos $ \(( mbname, mbrev ), commonPath ) -> do
-        ( mbname, ) . ( commonPath, ) <$> case lookup mbname revisionOverrides of
-            Just tree -> return tree
-            Nothing -> case maybe eiContainingRepo (flip lookup eiOtherRepos) mbname of
-                Just repo -> do
-                    commit <- readCommit repo (fromMaybe "HEAD" mbrev)
+    otherRepoTrees <- forM otherRepos $ \( mbrepo, commonPath ) -> do
+        ( mbrepo, ) . ( commonPath, ) <$> do
+            case lookup (fst <$> mbrepo) revisionOverrides of
+                Just tree -> return tree
+                Nothing -> do
+                    repo <- evalRepo (fst <$> mbrepo)
+                    commit <- readCommit repo (fromMaybe "HEAD" $ join $ snd <$> mbrepo)
                     getSubtree (Just commit) commonPath =<< getCommitTree commit
-                Nothing -> throwError $ OtherEvalError $ "repo ‘" <> maybe "" textRepoName mbname <> "’ not defined"
 
-    otherCheckout <- forM (jobOtherCheckout decl) $ \(( name, _ ), checkout ) -> do
-        (, checkout ) <$> case snd <$> lookup (Just name) otherRepoTrees of
-            Just tree -> return tree
-            Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined"
-
-    let otherRepoIds = map (\( name, ( subtree, tree )) -> JobIdTree name subtree (treeId tree)) otherRepoTrees
+    checkouts <- forM (jobCheckout decl) $ \dcheckout -> do
+        return dcheckout
+            { jcRepo =
+                fromMaybe (error $ "expecting repo in either otherRepoTrees or revisionOverrides: " <> show (textRepoName . fst <$> jcRepo dcheckout)) $
+                msum
+                    [ snd <$> lookup (jcRepo dcheckout) otherRepoTrees
+                    , lookup (fst <$> jcRepo dcheckout) revisionOverrides
+                    ]
+            }
+
+    let otherRepoIds = map (\( repo, ( subtree, tree )) -> JobIdTree (fst <$> repo) subtree (treeId tree)) otherRepoTrees
     return Job
         { jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId decl) : eiCurrentIdRev
         , jobName = jobName decl
-        , jobContainingCheckout = jobContainingCheckout decl
-        , jobOtherCheckout = otherCheckout
+        , jobCheckout = checkouts
         , jobRecipe = jobRecipe decl
         , jobArtifacts = jobArtifacts decl
         , jobUses = jobUses decl
@@ -126,23 +130,23 @@ evalRepo (Just name) = asks (lookup name . eiOtherRepos) >>= \case
     Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined"
 
 
-canonicalJobName :: [ Text ] -> Config -> Eval JobId
-canonicalJobName (r : rs) config = do
+canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval Job
+canonicalJobName (r : rs) config mbDefaultRepo = do
     let name = JobName r
         dset = JobSet Nothing $ Right $ configJobs config
     case find ((name ==) . jobName) (configJobs config) of
         Just djob -> do
             otherRepos <- collectOtherRepos dset djob
             ( overrides, rs' ) <- (\f -> foldM f ( [], rs ) otherRepos) $
-                \( overrides, crs ) (( mbname, _ ), path ) -> do
-                    ( tree, crs' ) <- readTreeFromIdRef crs path =<< evalRepo mbname
-                    return ( ( mbname, tree ) : overrides, crs' )
+                \( overrides, crs ) ( mbrepo, path ) -> do
+                    ( tree, crs' ) <- readTreeFromIdRef crs path =<< evalRepo (fst <$> mbrepo)
+                    return ( ( fst <$> mbrepo, tree ) : overrides, crs' )
             case rs' of
                 (r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’"
                 _ -> return ()
-            jobId <$> evalJob overrides dset djob
+            evalJob (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset djob
         Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found"
-canonicalJobName [] _ = throwError $ OtherEvalError "expected job name"
+canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name"
 
 readTreeFromIdRef :: [ Text ] -> FilePath -> Repo -> Eval ( Tree, [ Text ] )
 readTreeFromIdRef (r : rs) subdir repo = do
@@ -153,17 +157,17 @@ readTreeFromIdRef (r : rs) subdir repo = do
             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 :: [ Text ] -> Repo -> Eval Job
 canonicalCommitConfig rs repo = do
     ( tree, rs' ) <- readTreeFromIdRef rs "" repo
     config <- either fail return =<< loadConfigForCommit tree
     local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $
-        canonicalJobName rs' config
+        canonicalJobName rs' config (Just tree)
 
-evalJobReference :: JobRef -> Eval JobId
+evalJobReference :: JobRef -> Eval Job
 evalJobReference (JobRef rs) =
     asks eiJobRoot >>= \case
         JobRootRepo defRepo -> do
             canonicalCommitConfig rs defRepo
         JobRootConfig config -> do
-            canonicalJobName rs config
+            canonicalJobName rs config Nothing
diff --git a/src/Job.hs b/src/Job.hs
index cdb12b6..5435cbd 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -182,8 +182,8 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case
                             writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks
 
 
-runJobs :: JobManager -> Output -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
-runJobs mngr@JobManager {..} tout commit jobs = do
+runJobs :: JobManager -> Output -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
+runJobs mngr@JobManager {..} tout jobs = do
     results <- atomically $ do
         forM jobs $ \job -> do
             tid <- reserveTaskId mngr
@@ -221,7 +221,7 @@ runJobs mngr@JobManager {..} tout commit jobs = do
                         runManagedJob mngr tid (return JobCancelled) $ do
                             liftIO $ atomically $ writeTVar outVar JobRunning
                             liftIO $ outputEvent tout $ JobStarted (jobId job)
-                            prepareJob jmDataDir commit job $ \checkoutPath jdir -> do
+                            prepareJob jmDataDir job $ \checkoutPath jdir -> do
                                 updateStatusFile (jdir </> "status") outVar
                                 JobDone <$> runJob job uses checkoutPath jdir
 
@@ -288,20 +288,10 @@ updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing
 jobStorageSubdir :: JobId -> FilePath
 jobStorageSubdir (JobId jidParts) = "jobs" </> joinPath (map (T.unpack . textJobIdPart) (jidParts))
 
-prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Maybe Commit -> Job -> (FilePath -> FilePath -> m a) -> m a
-prepareJob dir mbCommit job inner = do
+prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Job -> (FilePath -> FilePath -> m a) -> m a
+prepareJob dir job inner = do
     withSystemTempDirectory "minici" $ \checkoutPath -> do
-        case mbCommit of
-            Just commit -> do
-                tree <- getCommitTree commit
-                forM_ (jobContainingCheckout job) $ \(JobCheckout mbsub dest) -> do
-                    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
+        forM_ (jobCheckout job) $ \(JobCheckout tree mbsub dest) -> do
             subtree <- maybe return (getSubtree Nothing . makeRelative (treeSubdir tree)) mbsub $ tree
             checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
 
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index 1ac329e..4024317 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -16,8 +16,7 @@ data Evaluated
 data Job' d = Job
     { jobId :: JobId' d
     , jobName :: JobName
-    , jobContainingCheckout :: [ JobCheckout ]
-    , jobOtherCheckout :: [ ( JobRepo d, JobCheckout ) ]
+    , jobCheckout :: [ JobCheckout d ]
     , jobRecipe :: [ CreateProcess ]
     , jobArtifacts :: [ ( ArtifactName, Pattern ) ]
     , jobUses :: [ ( JobName, ArtifactName ) ]
@@ -41,11 +40,12 @@ textJobName (JobName name) = name
 
 
 type family JobRepo d :: Type where
-    JobRepo Declared = ( RepoName, Maybe Text )
+    JobRepo Declared = Maybe ( RepoName, Maybe Text )
     JobRepo Evaluated = Tree
 
-data JobCheckout = JobCheckout
-    { jcSubtree :: Maybe FilePath
+data JobCheckout d = JobCheckout
+    { jcRepo :: JobRepo d
+    , jcSubtree :: Maybe FilePath
     , jcDestination :: Maybe FilePath
     }