Artifacts stored for other jobs

1 files changed, 55 insertions, 11 deletions

diff --git a/src/Job.hs b/src/Job.hs
index db3f4d0..80dfa92 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -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
         }