diff options
| -rw-r--r-- | minici.cabal | 3 | ||||
| -rw-r--r-- | src/Config.hs | 54 | ||||
| -rw-r--r-- | src/Job.hs | 66 | ||||
| -rw-r--r-- | src/Main.hs | 7 |
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 "." @@ -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 |