diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Eval.hs | 30 | ||||
| -rw-r--r-- | src/Job.hs | 27 | ||||
| -rw-r--r-- | src/Job/Types.hs | 15 |
3 files changed, 48 insertions, 24 deletions
diff --git a/src/Eval.hs b/src/Eval.hs index 6680c44..1b7c3e2 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -144,6 +144,12 @@ evalJobs (current : evaluating) evaluated repos dset reqs = do let otherRepoTrees = catMaybes otherRepoTreesMb if all isJust otherRepoTreesMb then do + 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 currentJobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId current) : eiCurrentIdRev + checkouts <- forM (jobCheckout current) $ \dcheckout -> do return dcheckout { jcRepo = @@ -154,22 +160,32 @@ evalJobs (current : evaluating) evaluated repos dset reqs = do ] } + uses <- forM (jobUses current) $ \( jname, aname ) -> do + Just (Right job) <- return $ find ((jname ==) . either id jobName) evaluated + return ( jobId job, aname ) + destinations <- forM (jobPublish current) $ \dpublish -> do + let ( jname, _ ) = jpArtifact dpublish + jid <- if + | jname == jobName current -> return currentJobId + | otherwise -> do + Just (Right job) <- return $ find ((jname ==) . either id jobName) evaluated + return $ jobId job + case lookup (jpDestination dpublish) eiDestinations of - Just dest -> return $ dpublish { jpDestination = dest } + Just dest -> return dpublish + { jpArtifact = ( jid, snd (jpArtifact 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 + { jobId = currentJobId , jobName = jobName current , jobCheckout = checkouts , jobRecipe = jobRecipe current , jobArtifacts = jobArtifacts current - , jobUses = jobUses current + , jobUses = uses , jobPublish = destinations } evalJobs evaluating (Right job : evaluated) repos dset reqs @@ -305,26 +305,27 @@ waitForUsedArtifacts => Output -> Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) - -> m [ ( ArtifactSpec, ArtifactOutput ) ] + -> m [ ( ArtifactSpec Evaluated, ArtifactOutput ) ] waitForUsedArtifacts tout job results outVar = do origState <- liftIO $ atomically $ readTVar outVar - let ( selfSpecs, artSpecs ) = partition ((jobName job ==) . fst) $ jobRequiredArtifacts job + let ( selfSpecs, artSpecs ) = partition ((jobId job ==) . fst) $ jobRequiredArtifacts job forM_ selfSpecs $ \( _, artName@(ArtifactName tname) ) -> do when (not (artName `elem` map fst (jobArtifacts job))) $ do throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact ‘" <> tname <> "’ not produced by the job") - ujobs <- forM artSpecs $ \(ujobName@(JobName tjobName), uartName) -> do - case find (\( j, _, _ ) -> jobName j == ujobName) results of - Just ( _, _, var ) -> return ( var, ( ujobName, uartName )) - Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Job '" <> tjobName <> "' not found") + ujobs <- forM artSpecs $ \( ujobId, uartName ) -> do + case find (\( j, _, _ ) -> jobId j == ujobId) results of + Just ( _, _, var ) -> return ( var, ( ujobId, uartName )) + Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Job ‘" <> textJobId ujobId <> "’ not found") let loop prev = do ustatuses <- atomically $ do - ustatuses <- forM ujobs $ \(uoutVar, uartName) -> do - (,uartName) <$> readTVar uoutVar + ustatuses <- forM ujobs $ \( uoutVar, uartSpec ) -> do + (, uartSpec) <$> readTVar uoutVar when (Just (map fst ustatuses) == prev) retry - let remains = map (fst . snd) $ filter (not . jobStatusFinished . fst) ustatuses + let remains = map (fromMaybe (JobName "?") . lastJobNameId . fst . snd) $ + filter (not . jobStatusFinished . fst) ustatuses writeTVar outVar $ if null remains then origState else JobWaiting remains return ustatuses if all (jobStatusFinished . fst) ustatuses @@ -332,11 +333,11 @@ waitForUsedArtifacts tout job results outVar = do else loop $ Just $ map fst ustatuses ustatuses <- liftIO $ loop Nothing - forM ustatuses $ \(ustatus, spec@( JobName tjobName, uartName@(ArtifactName tartName)) ) -> do + forM ustatuses $ \( ustatus, spec@( tjobId, uartName@(ArtifactName tartName)) ) -> do case jobResult ustatus of Just out -> case find ((==uartName) . aoutName) $ outArtifacts out of Just art -> return ( spec, art ) - Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found") + Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact ‘" <> textJobId tjobId <> "." <> tartName <> "’ not found") _ -> throwError JobSkipped outputJobFinishedEvent :: Output -> Job -> JobStatus a -> IO () @@ -417,7 +418,7 @@ copyArtifact storageDir jid aname tpath = do liftIO $ copyRecursive (adir </> "data") tpath -runJob :: Job -> [ ( ArtifactSpec, ArtifactOutput) ] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput +runJob :: Job -> [ ( ArtifactSpec Evaluated, ArtifactOutput) ] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput runJob job uses checkoutPath jdir = do liftIO $ forM_ (filter ((`elem` jobUses job) . fst) uses) $ \( _, aout ) -> do let target = checkoutPath </> aoutWorkPath aout @@ -468,7 +469,7 @@ runJob job uses checkoutPath jdir = do } forM_ (jobPublish job) $ \pub -> do - Just aout <- return $ lookup (jpArtifact pub) $ map (\aout -> ( ( jobName job, aoutName aout ), aout )) artifacts ++ uses + Just aout <- return $ lookup (jpArtifact pub) $ map (\aout -> ( ( jobId job, aoutName aout ), aout )) artifacts ++ uses let ppath = case jpPath pub of Just path | hasTrailingPathSeparator path -> path </> takeFileName (aoutWorkPath aout) diff --git a/src/Job/Types.hs b/src/Job/Types.hs index 262a267..f4dd55a 100644 --- a/src/Job/Types.hs +++ b/src/Job/Types.hs @@ -22,7 +22,7 @@ data Job' d = Job , jobCheckout :: [ JobCheckout d ] , jobRecipe :: Maybe [ Either CreateProcess Text ] , jobArtifacts :: [ ( ArtifactName, Pattern ) ] - , jobUses :: [ ArtifactSpec ] + , jobUses :: [ ArtifactSpec d ] , jobPublish :: [ JobPublish d ] } @@ -42,7 +42,7 @@ stringJobName (JobName name) = T.unpack name textJobName :: JobName -> Text textJobName (JobName name) = name -jobRequiredArtifacts :: Job' d -> [ ArtifactSpec ] +jobRequiredArtifacts :: Ord (JobId' d) => Job' d -> [ ArtifactSpec d ] jobRequiredArtifacts job = nubOrd $ jobUses job ++ (map jpArtifact $ jobPublish job) @@ -61,7 +61,7 @@ type family JobDestination d :: Type where JobDestination Evaluated = Destination data JobPublish d = JobPublish - { jpArtifact :: ArtifactSpec + { jpArtifact :: ArtifactSpec d , jpDestination :: JobDestination d , jpPath :: Maybe FilePath } @@ -70,7 +70,7 @@ data JobPublish d = JobPublish data ArtifactName = ArtifactName Text deriving (Eq, Ord, Show) -type ArtifactSpec = ( JobName, ArtifactName ) +type ArtifactSpec d = ( JobId' d, ArtifactName ) data JobSet' d = JobSet @@ -129,3 +129,10 @@ parseJobRef = JobRef . go 0 "" Just ( '(', rest' ) -> go (plevel + 1) (cur <> part) rest' Just ( ')', rest' ) -> go (plevel - 1) (cur <> part) rest' _ -> [ cur <> part ] + +lastJobNameId :: JobId -> Maybe JobName +lastJobNameId (JobId ids) = go Nothing ids + where + go _ (JobIdName name : rest) = go (Just name) rest + go cur (_ : rest) = go cur rest + go cur [] = cur |