From 048529bcb06601ee4ff91190b823ba00beba1a6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 19 Jan 2023 23:10:32 +0100 Subject: Artifacts stored for other jobs --- src/Config.hs | 54 +++++++++++++++++++++++++++++++----------------- src/Job.hs | 66 +++++++++++++++++++++++++++++++++++++++++++++++++---------- src/Main.hs | 7 +++++-- 3 files changed, 95 insertions(+), 32 deletions(-) (limited to 'src') 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 -- cgit v1.2.3