Artifacts stored for other jobs

4 files changed, 97 insertions, 33 deletions

diff --git a/minici.cabal b/minici.cabal
index 692dafe..be83193 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -21,7 +21,7 @@ maintainer:         roman.smrz@seznam.cz
 
 executable minici
     main-is:          Main.hs
-    ghc-options:      -Wall
+    ghc-options:      -Wall -threaded
 
     -- Modules included in this executable, other than Main.
     other-modules:      Config
@@ -51,6 +51,7 @@ executable minici
                     , mtl >=2.2 && <2.3
                     , parser-combinators >=1.3 && <1.4
                     , process >=1.6 && <1.7
+                    , stm >=2.5 && <2.6
                     , text >=1.2 && <1.3
     hs-source-dirs:   src
     default-language: Haskell2010
diff --git a/src/Config.hs b/src/Config.hs
index f9acac4..d5f80fc 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -45,33 +45,49 @@ instance FromYAML Config where
                            (Anchor pos _ _, _) -> pos
         jobs <- fmap catMaybes $ forM (sortBy (comparing $ posLine . getpos) $ M.assocs m) $ \case
             (Scalar _ (SStr tag), node) | ["job", name] <- T.words tag -> do
-                flip (withMap "Job") node $ \j -> Just <$> choice
-                    [ cabalJob name =<< j .: "cabal"
-                    , shellJob name =<< j .: "shell"
-                    ]
+                Just <$> parseJob name node
             _ -> return Nothing
         return $ Config jobs
 
-cabalJob :: Text -> Node Pos -> Parser Job
-cabalJob name = withMap "cabal job" $ \m -> do
+parseJob :: Text -> Node Pos -> Parser Job
+parseJob name node = flip (withMap "Job") node $ \j -> Job
+    <$> pure (JobName name)
+    <*> choice
+        [ cabalJob =<< j .: "cabal"
+        , shellJob =<< j .: "shell"
+        ]
+    <*> parseArtifacts j
+    <*> (maybe (return []) parseUses =<< j .:? "uses")
+
+cabalJob :: Node Pos -> Parser [CreateProcess]
+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 Job
-        { jobName = JobName name
-        , jobRecipe = [ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ]
-        , jobArtifacts = map (\(ArtifactName aname) -> (ArtifactName "bin", proc "cabal" ["list-bin", T.unpack aname])) []
-        }
+    return
+        [ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ]
 
-shellJob :: Text -> Node Pos -> Parser Job
-shellJob name = withSeq "shell commands" $ \xs -> do
-    recipe <- forM xs $ withStr "shell command" $ return . T.unpack
-    return Job
-        { jobName = JobName name
-        , jobRecipe = map shell recipe
-        , jobArtifacts = []
-        }
+shellJob :: Node Pos -> Parser [CreateProcess]
+shellJob = withSeq "shell commands" $ \xs -> do
+    fmap (map shell) $ forM xs $ withStr "shell command" $ return . T.unpack
+
+parseArtifacts :: Mapping Pos -> Parser [(ArtifactName, CreateProcess)]
+parseArtifacts m = do
+    fmap catMaybes $ forM (M.assocs m) $ \case
+        (Scalar _ (SStr tag), node) | ["artifact", name] <- T.words tag -> do
+            Just <$> parseArtifact name node
+        _ -> return Nothing
+  where
+    parseArtifact name = withMap "Artifact" $ \am -> do
+        path <- am .: "path"
+        return (ArtifactName name, proc "echo" [ T.unpack path ])
+
+parseUses :: Node Pos -> Parser [(JobName, ArtifactName)]
+parseUses = withSeq "Uses list" $ mapM $
+    withStr "Artifact reference" $ \text -> do
+        [job, art] <- return $ T.split (== '.') text
+        return (JobName job, ArtifactName art)
 
 findConfig :: IO (Maybe FilePath)
 findConfig = go "."
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
         }
diff --git a/src/Main.hs b/src/Main.hs
index da3c0d8..8ba28d1 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,7 @@
 module Main (main) where
 
+import Control.Concurrent.STM
+
 import Control.Monad
 
 import System.IO
@@ -30,10 +32,11 @@ main = do
         let shortCid = take 7 cid
         putStr $ shortCid <> " " <> fitToLength 50 desc
         hFlush stdout
-        results <- forM (configJobs config) $ \job -> do
+        outs <- runJobs "./.minici" cid $ configJobs config
+        results <- forM outs $ \outVar -> do
             putStr " "
             hFlush stdout
-            out <- runJob "./.minici" cid job
+            out <- atomically $ maybe retry return =<< readTVar outVar
             if | outStatus out -> do
                     putStr "\ESC[92m✓\ESC[0m      "
                | otherwise -> do