summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Command/Extract.hs4
-rw-r--r--src/Command/JobId.hs4
-rw-r--r--src/Command/Log.hs4
-rw-r--r--src/Command/Run.hs18
-rw-r--r--src/Command/Shell.hs4
-rw-r--r--src/Config.hs1
-rw-r--r--src/Config.hs-boot3
-rw-r--r--src/Eval.hs20
-rw-r--r--src/Job/Types.hs2
9 files changed, 42 insertions, 18 deletions
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 ]
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-08 22:33:39 +0000