diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command/Extract.hs | 4 | ||||
| -rw-r--r-- | src/Command/JobId.hs | 4 | ||||
| -rw-r--r-- | src/Command/Log.hs | 4 | ||||
| -rw-r--r-- | src/Command/Run.hs | 14 | ||||
| -rw-r--r-- | src/Command/Shell.hs | 4 | ||||
| -rw-r--r-- | src/Config.hs | 17 | ||||
| -rw-r--r-- | src/Eval.hs | 238 | ||||
| -rw-r--r-- | src/Job.hs | 12 | ||||
| -rw-r--r-- | src/Job/Types.hs | 2 |
9 files changed, 165 insertions, 134 deletions
diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs index 366128c..8dee537 100644 --- a/src/Command/Extract.hs +++ b/src/Command/Extract.hs @@ -6,7 +6,6 @@ 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 @@ -80,8 +79,7 @@ cmdExtract (ExtractCommand ExtractOptions {..} ExtractArguments {..}) = do _ -> return False forM_ extractArtifacts $ \( ref, aname ) -> do - [ jid ] <- either tfail (return . map jobId) =<< - return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< + jid <- either (tfail . textEvalError) (return . jobId) =<< liftIO (runEval (evalJobReference ref) einput) tpath <- if diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs index b349ebe..173f543 100644 --- a/src/Command/JobId.hs +++ b/src/Command/JobId.hs @@ -5,7 +5,6 @@ module Command.JobId ( import Control.Monad import Control.Monad.IO.Class -import Data.Bifunctor import Data.Text (Text) import Data.Text qualified as T @@ -53,8 +52,7 @@ cmdJobId :: JobIdCommand -> CommandExec () cmdJobId (JobIdCommand JobIdOptions {..} ref) = do einput <- getEvalInput out <- getOutput - [ JobId ids ] <- either tfail (return . map jobId) =<< - return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< + 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 438c25e..25bfc06 100644 --- a/src/Command/Log.hs +++ b/src/Command/Log.hs @@ -4,7 +4,6 @@ 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 @@ -38,8 +37,7 @@ instance Command LogCommand where cmdLog :: LogCommand -> CommandExec () cmdLog (LogCommand ref) = do einput <- getEvalInput - [ jid ] <- either tfail (return . map jobId) =<< - return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< + 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 982a07a..b299931 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -8,6 +8,7 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Data.Containers.ListUtils import Data.Either import Data.List import Data.Maybe @@ -168,29 +169,26 @@ argumentJobSource names = do Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found" jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do - fullSet <- evalJobSet (map ( Nothing, ) jobtree) JobSet + evalJobSetSelected names (map ( Nothing, ) jobtree) JobSet { jobsetId = () , jobsetConfig = Just config , jobsetCommit = jcommit , jobsetExplicitlyRequested = names , jobsetJobsEither = Right (configJobs config) } - let selectedSet = fullSet { jobsetJobsEither = fmap (filter ((`elem` names) . jobName)) (jobsetJobsEither fullSet) } - fillInDependencies selectedSet oneshotJobSource [ jset ] refJobSource :: [ JobRef ] -> CommandExec JobSource refJobSource [] = emptyJobSource refJobSource refs = do - jsets <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReference refs) - sets <- cmdEvalWith id $ do - forM jsets $ \jset -> do - fillInDependencies $ jset { jobsetExplicitlyRequested = either (const []) (map jobId) $ jobsetJobsEither jset } + sets <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReferenceToSet refs) oneshotJobSource sets where addJobToList :: [ JobSet ] -> JobSet -> [ JobSet ] addJobToList (cur : rest) jset - | jobsetId cur == jobsetId jset = cur { jobsetJobsEither = (++) <$> (fmap reverse $ jobsetJobsEither jset) <*> (jobsetJobsEither cur) } : rest + | jobsetId cur == jobsetId jset = cur { jobsetJobsEither = fmap (nubOrdOn jobId) $ (++) <$> (jobsetJobsEither cur) <*> (jobsetJobsEither jset) + , jobsetExplicitlyRequested = nubOrd $ jobsetExplicitlyRequested cur ++ jobsetExplicitlyRequested jset + } : rest | otherwise = cur : addJobToList rest jset addJobToList [] jset = [ jset ] diff --git a/src/Command/Shell.hs b/src/Command/Shell.hs index dfff50a..16f366e 100644 --- a/src/Command/Shell.hs +++ b/src/Command/Shell.hs @@ -5,7 +5,6 @@ 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 @@ -38,8 +37,7 @@ instance Command ShellCommand where cmdShell :: ShellCommand -> CommandExec () cmdShell (ShellCommand ref) = do einput <- getEvalInput - [ job ] <- either tfail return =<< - return . either (Left . textEvalError) (first T.pack . jobsetJobsEither) =<< + job <- either (tfail . textEvalError) return =<< 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 fb3a828..40eb1e5 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -117,18 +117,23 @@ parseSingleCheckout = withMap "checkout definition" $ \m -> do parseMultipleCheckouts :: Node Pos -> Parser [ JobCheckout Declared ] parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout -cabalJob :: Node Pos -> Parser [CreateProcess] +cabalJob :: Node Pos -> Parser [ Either CreateProcess Text ] cabalJob = withMap "cabal job" $ \m -> do ghcOptions <- m .:? "ghc-options" >>= \case Nothing -> return [] Just s -> withSeq "GHC option list" (mapM (withStr "GHC option" return)) s return - [ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ] - -shellJob :: Node Pos -> Parser [CreateProcess] -shellJob = withSeq "shell commands" $ \xs -> do - fmap (map shell) $ forM xs $ withStr "shell command" $ return . T.unpack + [ Left $ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ] + +shellJob :: Node Pos -> Parser [ Either CreateProcess Text ] +shellJob node = do + commands <- choice + [ withStr "shell commands" return node + , withSeq "shell commands" (\xs -> do + fmap T.unlines $ forM xs $ withStr "shell command" $ return) node + ] + return [ Right commands ] parseArtifacts :: Mapping Pos -> Parser [ ( ArtifactName, Pattern ) ] parseArtifacts m = do diff --git a/src/Eval.hs b/src/Eval.hs index b73f0f3..6680c44 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -3,12 +3,12 @@ module Eval ( EvalError(..), textEvalError, Eval, runEval, - evalJob, evalJobSet, + evalJobSetSelected, evalJobReference, + evalJobReferenceToSet, loadJobSetById, - fillInDependencies, ) where import Control.Monad @@ -17,7 +17,6 @@ import Control.Monad.Reader import Data.List import Data.Maybe -import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T @@ -54,6 +53,29 @@ commonPrefix :: Eq a => [ a ] -> [ a ] -> [ a ] commonPrefix (x : xs) (y : ys) | x == y = x : commonPrefix xs ys commonPrefix _ _ = [] +checkIfAlreadyHasDefaultRepoId :: Eval Bool +checkIfAlreadyHasDefaultRepoId = do + asks (any isDefaultRepoId . eiCurrentIdRev) + where + isDefaultRepoId (JobIdName _) = False + isDefaultRepoId (JobIdCommit rname _) = isNothing rname + isDefaultRepoId (JobIdTree rname _ _) = isNothing rname + +collectJobSetRepos :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval [ ( Maybe RepoName, Tree ) ] +collectJobSetRepos revisionOverrides dset = do + jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset + let someJobUsesDefaultRepo = any (any (isNothing . jcRepo) . jobCheckout) jobs + repos = + (if someJobUsesDefaultRepo then (Nothing :) else id) $ + map (Just . repoName) $ maybe [] configRepos $ jobsetConfig dset + forM repos $ \rname -> do + case lookup rname revisionOverrides of + Just tree -> return ( rname, tree ) + Nothing -> do + repo <- evalRepo rname + tree <- getCommitTree =<< readCommit repo "HEAD" + return ( rname, tree ) + collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), FilePath ) ] collectOtherRepos dset decl = do jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset @@ -69,10 +91,7 @@ collectOtherRepos dset decl = do job <- maybe (throwError $ OtherEvalError $ "job ‘" <> textJobName name <> "’ not found") return . find ((name ==) . jobName) $ jobs return $ jobCheckout job - let isDefaultRepoId (JobIdName _) = False - isDefaultRepoId (JobIdCommit rname _) = isNothing rname - isDefaultRepoId (JobIdTree rname _ _) = isNothing rname - alreadyHasDefaultRepoId <- asks (any isDefaultRepoId . eiCurrentIdRev) + alreadyHasDefaultRepoId <- checkIfAlreadyHasDefaultRepoId let checkouts = (if alreadyHasDefaultRepoId then filter (isJust . jcRepo) else id) $ concat dependencyRepos @@ -84,64 +103,100 @@ collectOtherRepos dset decl = do return $ concatMap getCheckoutsForName canonicalRepoOrder -evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> DeclaredJob -> Eval ( Job, JobSetId ) -evalJob revisionOverrides dset decl = do +evalJobs + :: [ DeclaredJob ] -> [ Either JobName Job ] + -> [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> [ JobName ] -> Eval [ Job ] +evalJobs _ _ _ JobSet { jobsetJobsEither = Left err } _ = throwError $ OtherEvalError $ T.pack err + +evalJobs [] evaluated repos dset@JobSet { jobsetJobsEither = Right decl } (req : reqs) + | any ((req ==) . either id jobName) evaluated + = evalJobs [] evaluated repos dset reqs + | Just d <- find ((req ==) . jobName) decl + = evalJobs [ d ] evaluated repos dset reqs + | otherwise + = throwError $ OtherEvalError $ "job ‘" <> textJobName req <> "’ not found in jobset" +evalJobs [] evaluated _ _ [] = return $ mapMaybe (either (const Nothing) Just) evaluated + +evalJobs (current : evaluating) evaluated repos dset reqs + | any ((jobName current ==) . jobName) evaluating = throwError $ OtherEvalError $ "cyclic dependency when evaluating job ‘" <> textJobName (jobName current) <> "’" + | any ((jobName current ==) . either id jobName) evaluated = evalJobs evaluating evaluated repos dset reqs + +evalJobs (current : evaluating) evaluated repos dset reqs + | Just missing <- find (`notElem` (jobName current : map (either id jobName) evaluated)) $ map fst $ jobRequiredArtifacts current + , d <- either (const Nothing) (find ((missing ==) . jobName)) (jobsetJobsEither dset) + = evalJobs (fromJust d : current : evaluating) evaluated repos dset reqs + +evalJobs (current : evaluating) evaluated repos dset reqs = do EvalInput {..} <- ask - otherRepos <- collectOtherRepos dset decl - 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 - - 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 - ] - } + otherRepos <- collectOtherRepos dset current + otherRepoTreesMb <- forM otherRepos $ \( mbrepo, commonPath ) -> do + Just tree <- return $ lookup (fst <$> mbrepo) repos + mbSubtree <- case snd =<< mbrepo of + Just revisionOverride -> return . Just =<< getCommitTree =<< readCommit (treeRepo tree) revisionOverride + Nothing + | treeSubdir tree == commonPath -> do + return $ Just tree + | splitDirectories (treeSubdir tree) `isPrefixOf` splitDirectories commonPath -> do + Just <$> getSubtree Nothing (makeRelative (treeSubdir tree) commonPath) tree + | otherwise -> do + return Nothing + return $ fmap (\subtree -> ( mbrepo, ( commonPath, subtree ) )) mbSubtree + let otherRepoTrees = catMaybes otherRepoTreesMb + if all isJust otherRepoTreesMb + then do + checkouts <- forM (jobCheckout current) $ \dcheckout -> do + return dcheckout + { jcRepo = + fromMaybe (error $ "expecting repo in either otherRepoTrees or repos: " <> show (textRepoName . fst <$> jcRepo dcheckout)) $ + msum + [ snd <$> lookup (jcRepo dcheckout) otherRepoTrees + , lookup (fst <$> jcRepo dcheckout) repos -- for containing repo if filtered from otherRepos + ] + } - destinations <- forM (jobPublish decl) $ \dpublish -> do - case lookup (jpDestination dpublish) eiDestinations of - Just dest -> return $ dpublish { jpDestination = dest } - Nothing -> throwError $ OtherEvalError $ "no url defined for destination ‘" <> textDestinationName (jpDestination dpublish) <> "’" - - let otherRepoIds = flip mapMaybe otherRepoTrees $ \case - ( repo, ( subtree, tree )) -> do - guard $ maybe True (isNothing . snd) repo -- use only checkouts without explicit revision in job id - Just $ JobIdTree (fst <$> repo) subtree (treeId tree) - return - ( Job - { jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId decl) : eiCurrentIdRev - , jobName = jobName decl - , jobCheckout = checkouts - , jobRecipe = jobRecipe decl - , jobArtifacts = jobArtifacts decl - , jobUses = jobUses decl - , jobPublish = destinations - } - , JobSetId $ reverse $ reverse otherRepoIds ++ eiCurrentIdRev - ) + destinations <- forM (jobPublish current) $ \dpublish -> do + case lookup (jpDestination dpublish) eiDestinations of + Just dest -> return $ dpublish { jpDestination = dest } + Nothing -> throwError $ OtherEvalError $ "no url defined for destination ‘" <> textDestinationName (jpDestination dpublish) <> "’" + + let otherRepoIds = flip mapMaybe otherRepoTrees $ \case + ( repo, ( subtree, tree )) -> do + guard $ maybe True (isNothing . snd) repo -- use only checkouts without explicit revision in job id + Just $ JobIdTree (fst <$> repo) subtree (treeId tree) + let job = Job + { jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId current) : eiCurrentIdRev + , jobName = jobName current + , jobCheckout = checkouts + , jobRecipe = jobRecipe current + , jobArtifacts = jobArtifacts current + , jobUses = jobUses current + , jobPublish = destinations + } + evalJobs evaluating (Right job : evaluated) repos dset reqs + else do + evalJobs evaluating (Left (jobName current) : evaluated) repos dset reqs evalJobSet :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet -evalJobSet revisionOverrides decl = do +evalJobSet revisionOverrides decl = evalJobSetSelected (either (const []) (map jobName) (jobsetJobsEither decl)) revisionOverrides decl + +evalJobSetSelected :: [ JobName ] -> [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet +evalJobSetSelected selected revisionOverrides decl = do EvalInput {..} <- ask - jobs <- fmap (fmap (map fst)) - $ either (return . Left) (handleToEither . mapM (evalJob revisionOverrides decl)) - $ jobsetJobsEither decl - let explicit = - case liftM2 zip (jobsetJobsEither decl) jobs of - Left _ -> [] - Right declEval -> catMaybes $ - map (\jid -> jobId . snd <$> find ((jid ==) . jobId . fst) declEval) $ jobsetExplicitlyRequested decl + repos <- collectJobSetRepos revisionOverrides decl + alreadyHasDefaultRepoId <- checkIfAlreadyHasDefaultRepoId + let addedRepoIds = + map (\( mbname, tree ) -> JobIdTree mbname (treeSubdir tree) (treeId tree)) $ + (if alreadyHasDefaultRepoId then filter (isJust . fst) else id) $ + repos + + evaluated <- handleToEither $ evalJobs [] [] repos decl selected + let jobs = case liftM2 (,) evaluated (jobsetJobsEither decl) of + Left err -> Left err + Right ( ejobs, djobs ) -> Right $ mapMaybe (\dj -> find ((jobName dj ==) . jobName) ejobs) djobs + + let explicit = mapMaybe (\name -> jobId <$> find ((name ==) . jobName) (either (const []) id jobs)) $ jobsetExplicitlyRequested decl return JobSet - { jobsetId = JobSetId $ reverse $ eiCurrentIdRev + { jobsetId = JobSetId $ reverse $ reverse addedRepoIds ++ eiCurrentIdRev , jobsetConfig = jobsetConfig decl , jobsetCommit = jobsetCommit decl , jobsetExplicitlyRequested = explicit @@ -162,7 +217,13 @@ evalRepo (Just name) = asks (lookup name . eiOtherRepos) >>= \case canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval JobSet canonicalJobName (r : rs) config mbDefaultRepo = do let name = JobName r - dset = JobSet () (Just config) Nothing [] $ Right $ configJobs config + dset = JobSet + { jobsetId = () + , jobsetConfig = Just config + , jobsetCommit = Nothing + , jobsetExplicitlyRequested = [ name ] + , jobsetJobsEither = Right $ configJobs config + } case find ((name ==) . jobName) (configJobs config) of Just djob -> do otherRepos <- collectOtherRepos dset djob @@ -177,14 +238,7 @@ canonicalJobName (r : rs) config mbDefaultRepo = do case rs' of (r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’" _ -> return () - ( job, sid ) <- evalJob (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset djob - return JobSet - { jobsetId = sid - , jobsetConfig = Just config - , jobsetCommit = Nothing - , jobsetExplicitlyRequested = [] - , jobsetJobsEither = Right [ job ] - } + evalJobSetSelected (jobsetExplicitlyRequested dset) (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found" canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name" @@ -204,14 +258,21 @@ canonicalCommitConfig rs repo = do local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $ canonicalJobName rs' config (Just tree) -evalJobReference :: JobRef -> Eval JobSet -evalJobReference (JobRef rs) = +evalJobReferenceToSet :: JobRef -> Eval JobSet +evalJobReferenceToSet (JobRef rs) = asks eiJobRoot >>= \case JobRootRepo defRepo -> do canonicalCommitConfig rs defRepo JobRootConfig config -> do canonicalJobName rs config Nothing +evalJobReference :: JobRef -> Eval Job +evalJobReference ref = do + jset <- evalJobReferenceToSet ref + jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither jset + [ name ] <- return $ jobsetExplicitlyRequested jset + maybe (error "missing job in evalJobReferenceToSet result") return $ find ((name ==) . jobId) jobs + jobsetFromConfig :: [ JobIdPart ] -> Config -> Maybe Tree -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] ) jobsetFromConfig sid config _ = do @@ -238,7 +299,7 @@ jobsetFromCommitConfig (JobIdTree name path tid : sid) repo = do throwError $ OtherEvalError $ "expected root commit or tree id" tree <- readTreeId repo path tid config <- either fail return =<< loadConfigForCommit tree - local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $ do + local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev ei }) $ do ( dset, idRev, otherRepos ) <- jobsetFromConfig sid config (Just tree) return ( dset, idRev, ( Nothing, tree ) : otherRepos ) @@ -246,7 +307,7 @@ jobsetFromCommitConfig (JobIdCommit name cid : sid) repo = do when (isJust name) $ do throwError $ OtherEvalError $ "expected default repo commit or tree id" tree <- getCommitTree =<< readCommitId repo cid - jobsetFromCommitConfig (JobIdTree name "" (treeId tree) : sid) repo + jobsetFromCommitConfig (JobIdTree name (treeSubdir tree) (treeId tree) : sid) repo jobsetFromCommitConfig (JobIdName name : _) _ = do throwError $ OtherEvalError $ "expected commit or tree id, not a job name ‘" <> textJobName name <> "’" @@ -261,36 +322,3 @@ loadJobSetById (JobSetId sid) = do jobsetFromCommitConfig sid defRepo JobRootConfig config -> do jobsetFromConfig sid config Nothing - -fillInDependencies :: JobSet -> Eval JobSet -fillInDependencies jset = do - ( dset, idRev, otherRepos ) <- local (\ei -> ei { eiCurrentIdRev = [] }) $ do - loadJobSetById (jobsetId jset) - origJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither jset - declJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset - deps <- gather declJobs S.empty (map jobName origJobs) - - jobs <- local (\ei -> ei { eiCurrentIdRev = idRev }) $ do - fmap catMaybes $ forM declJobs $ \djob -> if - | Just job <- find ((jobName djob ==) . jobName) origJobs - -> return (Just job) - - | jobName djob `S.member` deps - -> Just . fst <$> evalJob otherRepos dset djob - - | otherwise - -> return Nothing - - return $ jset { jobsetJobsEither = Right jobs } - where - gather djobs cur ( name : rest ) - | name `S.member` cur - = gather djobs cur rest - - | Just djob <- find ((name ==) . jobName) djobs - = gather djobs (S.insert name cur) $ map fst (jobUses djob) ++ map (fst . jpArtifact) (jobPublish djob) ++ rest - - | otherwise - = throwError $ OtherEvalError $ "dependency ‘" <> textJobName name <> "’ not found" - - gather _ cur [] = return cur @@ -38,6 +38,7 @@ import Data.Text qualified as T import Data.Text.IO qualified as T import System.Directory +import System.Environment import System.Exit import System.FilePath import System.FilePath.Glob @@ -424,14 +425,21 @@ runJob job uses checkoutPath jdir = do copyRecursive (aoutStorePath aout) target bracket (liftIO $ openFile (jdir </> "log") WriteMode) (liftIO . hClose) $ \logs -> do - forM_ (fromMaybe [] $ jobRecipe job) $ \p -> do + forM_ (fromMaybe [] $ jobRecipe job) $ \ep -> do + ( p, input ) <- case ep of + Left p -> return ( p, "" ) + Right script -> do + sh <- fromMaybe "/bin/sh" <$> liftIO (lookupEnv "SHELL") + return ( proc sh [], script ) (Just hin, _, _, hp) <- liftIO $ createProcess_ "" p { cwd = Just checkoutPath , std_in = CreatePipe , std_out = UseHandle logs , std_err = UseHandle logs } - liftIO $ hClose hin + liftIO $ void $ forkIO $ do + T.hPutStr hin input + hClose hin liftIO (waitForProcess hp) >>= \case ExitSuccess -> return () ExitFailure n diff --git a/src/Job/Types.hs b/src/Job/Types.hs index 5d3f0f3..262a267 100644 --- a/src/Job/Types.hs +++ b/src/Job/Types.hs @@ -20,7 +20,7 @@ data Job' d = Job { jobId :: JobId' d , jobName :: JobName , jobCheckout :: [ JobCheckout d ] - , jobRecipe :: Maybe [ CreateProcess ] + , jobRecipe :: Maybe [ Either CreateProcess Text ] , jobArtifacts :: [ ( ArtifactName, Pattern ) ] , jobUses :: [ ArtifactSpec ] , jobPublish :: [ JobPublish d ] |