summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Config.hs54
-rw-r--r--src/Job.hs66
-rw-r--r--src/Main.hs7
3 files changed, 95 insertions, 32 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 17:48:37 +0000