diff options
Diffstat (limited to 'src/Job.hs')
| -rw-r--r-- | src/Job.hs | 66 |
1 files changed, 55 insertions, 11 deletions
@@ -3,12 +3,16 @@ module Job ( JobOutput(..), JobName(..), stringJobName, ArtifactName(..), - runJob, + runJobs, ) where +import Control.Concurrent +import Control.Concurrent.STM + import Control.Monad import Control.Monad.Except +import Data.List import Data.Text (Text) import Data.Text qualified as T @@ -22,14 +26,14 @@ data Job = Job { jobName :: JobName , jobRecipe :: [CreateProcess] , jobArtifacts :: [(ArtifactName, CreateProcess)] + , jobUses :: [(JobName, ArtifactName)] } data JobOutput = JobOutput { outName :: JobName , outStatus :: Bool - , outArtifacts :: [(ArtifactName, FilePath)] + , outArtifacts :: [ArtifactOutput] } - deriving (Show) data JobName = JobName Text deriving (Eq, Ord, Show) @@ -40,22 +44,49 @@ stringJobName (JobName name) = T.unpack name data ArtifactName = ArtifactName Text deriving (Eq, Ord, Show) +data ArtifactOutput = ArtifactOutput + { aoutName :: ArtifactName + , aoutWorkPath :: FilePath + , aoutStorePath :: FilePath + } -runJob :: FilePath -> String -> Job -> IO JobOutput -runJob dir cid job = do - [path] <- lines <$> readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] "" - "" <- readProcess "git" ["--work-tree=" <> path, "restore", "--source=" <> cid, "--", "."] "" - ["tree", tid]:_ <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] "" +runJobs :: FilePath -> String -> [Job] -> IO [TVar (Maybe JobOutput)] +runJobs dir cid jobs = do + results <- forM jobs $ \job -> (job,) <$> newTVarIO Nothing + gitLock <- newMVar () + forM_ results $ \(job, outVar) -> void $ forkIO $ do + uses <- forM (jobUses job) $ \(ujobName, uartName) -> do + Just (_, uoutVar) <- return $ find ((==ujobName) . jobName . fst) results + uout <- atomically $ maybe retry return =<< readTVar uoutVar + Just uart <- return $ find ((==uartName) . aoutName) $ outArtifacts uout + return uart + out <- runJob gitLock dir cid job uses + atomically $ writeTVar outVar $ Just out + return $ map snd results + +runJob :: MVar () -> FilePath -> String -> Job -> [ArtifactOutput] -> IO JobOutput +runJob gitLock dir cid job uses = do + [checkoutPath] <- lines <$> readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] "" + + tid <- withMVar gitLock $ \_ -> do + "" <- readProcess "git" ["--work-tree=" <> checkoutPath, "restore", "--source=" <> cid, "--", "."] "" + ["tree", tid]:_ <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] "" + return tid let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job) createDirectoryIfMissing True jdir logs <- openFile (jdir </> "log") WriteMode + forM_ uses $ \aout -> do + let target = checkoutPath </> aoutWorkPath aout + createDirectoryIfMissing True $ takeDirectory target + copyFile (aoutStorePath aout) target + res <- runExceptT $ do forM_ (jobRecipe job) $ \p -> do (Just hin, _, _, hp) <- liftIO $ createProcess_ "" p - { cwd = Just path + { cwd = Just checkoutPath , std_in = CreatePipe , std_out = UseHandle logs , std_err = UseHandle logs @@ -67,13 +98,26 @@ runJob dir cid job = do throwError () hClose logs - removeDirectoryRecursive $ path writeFile (jdir </> "status") $ if res == Right () then "success\n" else "failure\n" + let adir = jdir </> "artifacts" + artifacts <- forM (jobArtifacts job) $ \(name@(ArtifactName tname), pathCmd) -> do + [path] <- lines <$> readCreateProcess pathCmd { cwd = Just checkoutPath } "" + let target = adir </> T.unpack tname + createDirectoryIfMissing True adir + copyFile (checkoutPath </> path) target + return $ ArtifactOutput + { aoutName = name + , aoutWorkPath = path + , aoutStorePath = target + } + + removeDirectoryRecursive checkoutPath + return JobOutput { outName = jobName job , outStatus = res == Right () - , outArtifacts = [] + , outArtifacts = artifacts } |