diff options
| -rw-r--r-- | src/Command/Run.hs | 16 | ||||
| -rw-r--r-- | src/Config.hs | 6 | ||||
| -rw-r--r-- | src/Eval.hs | 132 | ||||
| -rw-r--r-- | src/Job.hs | 14 | ||||
| -rw-r--r-- | src/Job/Types.hs | 14 |
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 @@ -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 |