From b100f6e64074c761327e1113a0c8afaf74091a23 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 25 Nov 2025 21:13:25 +0100 Subject: Add Config reference to JobSet --- src/Command/Extract.hs | 4 +++- src/Command/JobId.hs | 4 +++- src/Command/Log.hs | 4 +++- src/Command/Run.hs | 18 ++++++++++-------- src/Command/Shell.hs | 4 +++- src/Config.hs | 1 + src/Config.hs-boot | 3 +++ src/Eval.hs | 20 ++++++++++++++------ src/Job/Types.hs | 2 ++ 9 files changed, 42 insertions(+), 18 deletions(-) create mode 100644 src/Config.hs-boot diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs index 6828029..a9ab292 100644 --- a/src/Command/Extract.hs +++ b/src/Command/Extract.hs @@ -6,6 +6,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Data.Bifunctor import Data.Text qualified as T import System.Console.GetOpt @@ -79,7 +80,8 @@ cmdExtract (ExtractCommand ExtractOptions {..} ExtractArguments {..}) = do _ -> return False forM_ extractArtifacts $ \( ref, ArtifactName aname ) -> do - jid@(JobId ids) <- either (tfail . textEvalError) (return . jobId . fst) =<< + [ jid@(JobId ids) ] <- either tfail (return . map jobId) =<< + return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< 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 096ed56..b349ebe 100644 --- a/src/Command/JobId.hs +++ b/src/Command/JobId.hs @@ -5,6 +5,7 @@ module Command.JobId ( import Control.Monad import Control.Monad.IO.Class +import Data.Bifunctor import Data.Text (Text) import Data.Text qualified as T @@ -52,7 +53,8 @@ cmdJobId :: JobIdCommand -> CommandExec () cmdJobId (JobIdCommand JobIdOptions {..} ref) = do einput <- getEvalInput out <- getOutput - JobId ids <- either (tfail . textEvalError) (return . jobId . fst) =<< + [ JobId ids ] <- either tfail (return . map jobId) =<< + return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< liftIO (runEval (evalJobReference ref) einput) outputMessage out $ textJobId $ JobId ids diff --git a/src/Command/Log.hs b/src/Command/Log.hs index e48ce8f..438c25e 100644 --- a/src/Command/Log.hs +++ b/src/Command/Log.hs @@ -4,6 +4,7 @@ module Command.Log ( import Control.Monad.IO.Class +import Data.Bifunctor import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL @@ -37,7 +38,8 @@ instance Command LogCommand where cmdLog :: LogCommand -> CommandExec () cmdLog (LogCommand ref) = do einput <- getEvalInput - jid <- either (tfail . textEvalError) (return . jobId . fst) =<< + [ jid ] <- either tfail (return . map jobId) =<< + return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< liftIO (runEval (evalJobReference ref) einput) output <- getOutput storageDir <- getStorageDir diff --git a/src/Command/Run.hs b/src/Command/Run.hs index bd60bae..3bdfb4e 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -167,6 +167,7 @@ argumentJobSource names = do jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do fullSet <- evalJobSet (map ( Nothing, ) jobtree) JobSet { jobsetId = () + , jobsetConfig = Just config , jobsetCommit = jcommit , jobsetExplicitlyRequested = names , jobsetJobsEither = Right (configJobs config) @@ -178,23 +179,24 @@ argumentJobSource names = do refJobSource :: [ JobRef ] -> CommandExec JobSource refJobSource [] = emptyJobSource refJobSource refs = do - jobs <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReference refs) + jsets <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReference refs) sets <- cmdEvalWith id $ do - forM jobs $ \( sid, js ) -> do - fillInDependencies $ JobSet sid Nothing (map jobId js) (Right $ reverse js) + forM jsets $ \jset -> do + fillInDependencies $ jset { jobsetExplicitlyRequested = either (const []) (map jobId) $ jobsetJobsEither jset } oneshotJobSource sets where - addJobToList :: [ ( JobSetId, [ Job ] ) ] -> ( Job, JobSetId ) -> [ ( JobSetId, [ Job ] ) ] - addJobToList (( sid, js ) : rest ) ( job, jsid ) - | sid == jsid = ( sid, job : js ) : rest - | otherwise = ( sid, js ) : addJobToList rest ( job, jsid ) - addJobToList [] ( job, jsid ) = [ ( jsid, [ job ] ) ] + addJobToList :: [ JobSet ] -> JobSet -> [ JobSet ] + addJobToList (cur : rest) jset + | jobsetId cur == jobsetId jset = cur { jobsetJobsEither = (++) <$> (fmap reverse $ jobsetJobsEither jset) <*> (jobsetJobsEither cur) } : rest + | otherwise = cur : addJobToList rest jset + addJobToList [] jset = [ jset ] loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet loadJobSetFromRoot root commit = case root of JobRootRepo _ -> loadJobSetForCommit commit JobRootConfig config -> return JobSet { jobsetId = () + , jobsetConfig = Just config , jobsetCommit = Just commit , jobsetExplicitlyRequested = [] , jobsetJobsEither = Right $ configJobs config diff --git a/src/Command/Shell.hs b/src/Command/Shell.hs index 6e0d880..dfff50a 100644 --- a/src/Command/Shell.hs +++ b/src/Command/Shell.hs @@ -5,6 +5,7 @@ module Command.Shell ( import Control.Monad import Control.Monad.IO.Class +import Data.Bifunctor import Data.Maybe import Data.Text (Text) import Data.Text qualified as T @@ -37,7 +38,8 @@ instance Command ShellCommand where cmdShell :: ShellCommand -> CommandExec () cmdShell (ShellCommand ref) = do einput <- getEvalInput - job <- either (tfail . textEvalError) (return . fst) =<< + [ job ] <- either tfail return =<< + return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< liftIO (runEval (evalJobReference ref) einput) sh <- fromMaybe "/bin/sh" <$> liftIO (lookupEnv "SHELL") storageDir <- getStorageDir diff --git a/src/Config.hs b/src/Config.hs index 22bc89a..fb3a828 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -208,6 +208,7 @@ loadJobSetForCommit commit = return . toJobSet =<< loadConfigForCommit =<< getCo where toJobSet configEither = JobSet { jobsetId = () + , jobsetConfig = either (const Nothing) Just configEither , jobsetCommit = Just commit , jobsetExplicitlyRequested = [] , jobsetJobsEither = fmap configJobs configEither diff --git a/src/Config.hs-boot b/src/Config.hs-boot new file mode 100644 index 0000000..ee6b0d1 --- /dev/null +++ b/src/Config.hs-boot @@ -0,0 +1,3 @@ +module Config where + +data Config diff --git a/src/Eval.hs b/src/Eval.hs index 018d031..e98bb29 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -139,6 +139,7 @@ evalJobSet revisionOverrides decl = do map (\jid -> jobId . snd <$> find ((jid ==) . jobId . fst) declEval) $ jobsetExplicitlyRequested decl return JobSet { jobsetId = JobSetId $ reverse $ eiCurrentIdRev + , jobsetConfig = jobsetConfig decl , jobsetCommit = jobsetCommit decl , jobsetExplicitlyRequested = explicit , jobsetJobsEither = jobs @@ -155,10 +156,10 @@ evalRepo (Just name) = asks (lookup name . eiOtherRepos) >>= \case Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined" -canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval ( Job, JobSetId ) +canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval JobSet canonicalJobName (r : rs) config mbDefaultRepo = do let name = JobName r - dset = JobSet () Nothing [] $ Right $ configJobs config + dset = JobSet () (Just config) Nothing [] $ Right $ configJobs config case find ((name ==) . jobName) (configJobs config) of Just djob -> do otherRepos <- collectOtherRepos dset djob @@ -169,7 +170,14 @@ canonicalJobName (r : rs) config mbDefaultRepo = do case rs' of (r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’" _ -> return () - evalJob (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset djob + ( job, sid ) <- evalJob (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset djob + return JobSet + { jobsetId = sid + , jobsetConfig = Just config + , jobsetCommit = Nothing + , jobsetExplicitlyRequested = [] + , jobsetJobsEither = Right [ job ] + } Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found" canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name" @@ -182,14 +190,14 @@ 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 ( Job, JobSetId ) +canonicalCommitConfig :: [ Text ] -> Repo -> Eval JobSet 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 (Just tree) -evalJobReference :: JobRef -> Eval ( Job, JobSetId ) +evalJobReference :: JobRef -> Eval JobSet evalJobReference (JobRef rs) = asks eiJobRoot >>= \case JobRootRepo defRepo -> do @@ -201,7 +209,7 @@ evalJobReference (JobRef rs) = jobsetFromConfig :: [ JobIdPart ] -> Config -> Maybe Tree -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] ) jobsetFromConfig sid config _ = do EvalInput {..} <- ask - let dset = JobSet () Nothing [] $ Right $ configJobs config + let dset = JobSet () (Just config) Nothing [] $ Right $ configJobs config otherRepos <- forM sid $ \case JobIdName name -> do throwError $ OtherEvalError $ "expected tree id, not a job name ‘" <> textJobName name <> "’" diff --git a/src/Job/Types.hs b/src/Job/Types.hs index fd20e9a..8d02057 100644 --- a/src/Job/Types.hs +++ b/src/Job/Types.hs @@ -7,6 +7,7 @@ import Data.Text qualified as T import System.FilePath.Glob import System.Process +import {-# SOURCE #-} Config import Destination import Repo @@ -70,6 +71,7 @@ type ArtifactSpec = ( JobName, ArtifactName ) data JobSet' d = JobSet { jobsetId :: JobSetId' d + , jobsetConfig :: Maybe Config , jobsetCommit :: Maybe Commit , jobsetExplicitlyRequested :: [ JobId' d ] , jobsetJobsEither :: Either String [ Job' d ] -- cgit v1.2.3