minici 0.1.2 → 0.1.3
raw patch · 11 files changed
+909/−127 lines, 11 filesdep +Globdep +hinotifydep +unixdep ~basedep ~template-haskell
Dependencies added: Glob, hinotify, unix
Dependency ranges changed: base, template-haskell
Files
- CHANGELOG.md +9/−0
- README.md +17/−2
- minici.cabal +11/−4
- src/Command.hs +50/−2
- src/Command/Run.hs +219/−46
- src/Config.hs +30/−11
- src/Job.hs +183/−56
- src/Job/Types.hs +48/−0
- src/Main.hs +17/−6
- src/Repo.hs +269/−0
- src/Terminal.hs +56/−0
CHANGELOG.md view
@@ -1,5 +1,14 @@ # Revision history for MiniCI +## 0.1.3 -- 2025-01-25++* Run jobs based on configuration in associated commit+* Configurable number of concurrently running jobs (using `-j` option)+* Concurrently run jobs for multiple commits+* Properly cancel and clean up jobs on user interrupt+* Added `--new-commits-on` and `--new-tags` options for `run` command to dynamically generate jobs based on branch/tags changes+* Support for GHC up to 9.12+ ## 0.1.2 -- 2024-07-30 * Explicit run command
README.md view
@@ -11,7 +11,7 @@ -------------- The top-level elements of the YAML file are `job <name>` defining steps to-perform the job and potentially listing artefacts produced or required.+perform the job and potentially listing artifacts produced or required. Example: @@ -52,12 +52,27 @@ minici run <commit>..<commit> ``` +or:+```+minici run --range=<commit>..<commit>+```+ To run jobs for commits that are in local `<branch>`, but not yet in its upstream: ``` minici run <branch> ``` -For currently branch, the name can be omitted:+For current branch, the name can be omitted: ``` minici run+```++To watch changes on given `<branch>` and run jobs for each new commit:+```+minici run --new-commits-on=<branch>+```++To watch new tags and run jobs for each tag matching given pattern:+```+minici run --new-tags=<pattern> ```
minici.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: minici-version: 0.1.2+version: 0.1.3 synopsis: Minimalist CI framework to run checks on local machine description: Runs defined jobs, for example to build and test a project, for each git@@ -30,7 +30,7 @@ source-repository head type: git- location: git://erebosprotocol.net/minici+ location: https://code.erebosprotocol.net/minici executable minici main-is: Main.hs@@ -51,7 +51,10 @@ Command.Run Config Job+ Job.Types Paths_minici+ Repo+ Terminal Version Version.Git autogen-modules:@@ -69,6 +72,7 @@ MultiParamTypeClasses MultiWayIf OverloadedStrings+ RecordWildCards ScopedTypeVariables TupleSections TypeApplications@@ -79,20 +83,23 @@ TemplateHaskell build-depends:- base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 },+ base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, bytestring ^>= { 0.10, 0.11, 0.12 }, containers ^>= { 0.6, 0.7 }, directory ^>= { 1.3 }, exceptions ^>= { 0.10 }, filepath ^>= { 1.4, 1.5 },+ Glob ^>= { 0.10.2 },+ hinotify ^>= { 0.4 }, HsYAML ^>= { 0.2 }, mtl ^>= { 2.2, 2.3 }, parser-combinators ^>= { 1.3 }, process ^>= { 1.6 }, stm ^>= { 2.5 },- template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 },+ template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 }, text ^>= { 1.2, 2.0, 2.1 }, th-compat ^>= { 0.1 },+ unix ^>= { 2.7.3, 2.8.6 }, hs-source-dirs: src default-language: Haskell2010
src/Command.hs view
@@ -1,9 +1,16 @@ module Command (+ CommonOptions(..),+ defaultCommonOptions,+ Command(..), CommandArgumentsType(..), CommandExec(..),+ CommandInput(..),+ getCommonOptions,+ getConfigPath, getConfig,+ getTerminalOutput, ) where import Control.Monad.Except@@ -14,9 +21,21 @@ import Data.Text qualified as T import System.Console.GetOpt+import System.Exit+import System.IO import Config+import Terminal +data CommonOptions = CommonOptions+ { optJobs :: Int+ }++defaultCommonOptions :: CommonOptions+defaultCommonOptions = CommonOptions+ { optJobs = 2+ }+ class CommandArgumentsType (CommandArguments c) => Command c where commandName :: proxy c -> String commandDescription :: proxy c -> String@@ -53,9 +72,38 @@ argsFromStrings [str] = return $ Just (T.pack str) argsFromStrings _ = throwError "expected at most one argument" +instance CommandArgumentsType [ Text ] where+ argsFromStrings strs = return $ map T.pack strs -newtype CommandExec a = CommandExec (ReaderT Config IO a)++newtype CommandExec a = CommandExec (ReaderT CommandInput IO a) deriving (Functor, Applicative, Monad, MonadIO) +data CommandInput = CommandInput+ { ciOptions :: CommonOptions+ , ciConfigPath :: Maybe FilePath+ , ciConfig :: Either String Config+ , ciTerminalOutput :: TerminalOutput+ }++getCommonOptions :: CommandExec CommonOptions+getCommonOptions = CommandExec (asks ciOptions)++getConfigPath :: CommandExec FilePath+getConfigPath = CommandExec $ do+ asks ciConfigPath >>= \case+ Nothing -> liftIO $ do+ hPutStrLn stderr "no config file found"+ exitFailure+ Just path -> return path+ getConfig :: CommandExec Config-getConfig = CommandExec ask+getConfig = CommandExec $ do+ asks ciConfig >>= \case+ Left err -> liftIO $ do+ hPutStrLn stderr err+ exitFailure+ Right config -> return config++getTerminalOutput :: CommandExec TerminalOutput+getTerminalOutput = CommandExec (asks ciTerminalOutput)
src/Command/Run.hs view
@@ -4,29 +4,43 @@ import Control.Concurrent import Control.Concurrent.STM+import Control.Exception import Control.Monad import Control.Monad.Reader -import Data.Maybe+import Data.List import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T +import System.Console.GetOpt+import System.Directory import System.Exit+import System.FilePath+import System.FilePath.Glob import System.IO import System.Process import Command import Config import Job+import Repo+import Terminal -data RunCommand = RunCommand Text +data RunCommand = RunCommand RunOptions [ Text ]++data RunOptions = RunOptions+ { roRanges :: [ Text ]+ , roNewCommitsOn :: [ Text ]+ , roNewTags :: [ Pattern ]+ }+ instance Command RunCommand where commandName _ = "run" commandDescription _ = "Execude jobs per minici.yaml for given commits" - type CommandArguments RunCommand = Maybe Text+ type CommandArguments RunCommand = [ Text ] commandUsage _ = T.pack $ unlines $ [ "Usage: minici run"@@ -35,40 +49,196 @@ , " run jobs for commits on <ref> not yet in its upstream ref" , " or: minici run <commit>..<commit>" , " run jobs for commits in given range"+ , " or: minici run <option>..."+ , " run jobs based on given options (see below)" ] - commandInit _ _ = RunCommand . fromMaybe "HEAD"+ type CommandOptions RunCommand = RunOptions+ defaultCommandOptions _ = RunOptions+ { roRanges = []+ , roNewCommitsOn = []+ , roNewTags = []+ }++ commandOptions _ =+ [ Option [] [ "range" ]+ (ReqArg (\val opts -> opts { roRanges = T.pack val : roRanges opts }) "<range>")+ "run jobs for commits in given range"+ , Option [] [ "new-commits-on" ]+ (ReqArg (\val opts -> opts { roNewCommitsOn = T.pack val : roNewCommitsOn opts }) "<branch>")+ "run jobs for new commits on given branch"+ , Option [] [ "new-tags" ]+ (ReqArg (\val opts -> opts { roNewTags = compile val : roNewTags opts }) "<pattern>")+ "run jobs for new annotated tags matching pattern"+ ]++ commandInit _ = RunCommand commandExec = cmdRun ++data JobSource = JobSource (TMVar (Maybe ( [ JobSet ], JobSource )))++takeJobSource :: JobSource -> STM (Maybe ( [ JobSet ], JobSource ))+takeJobSource (JobSource tmvar) = takeTMVar tmvar++mergeSources :: [ JobSource ] -> IO JobSource+mergeSources sources = do+ let go tmvar [] = do+ atomically (putTMVar tmvar Nothing)+ go tmvar cur = do+ ( jobsets, next ) <- atomically (select cur)+ if null next+ then do+ go tmvar next+ else do+ nextvar <- newEmptyTMVarIO+ atomically $ putTMVar tmvar (Just ( jobsets, JobSource nextvar ))+ go nextvar next++ tmvar <- newEmptyTMVarIO+ void $ forkIO $ go tmvar sources+ return $ JobSource tmvar++ where+ select :: [ JobSource ] -> STM ( [ JobSet ], [ JobSource ] )+ select [] = retry+ select (x@(JobSource tmvar) : xs) = do+ tryTakeTMVar tmvar >>= \case+ Nothing -> fmap (x :) <$> select xs+ Just Nothing -> return ( [], xs )+ Just (Just ( jobsets, x' )) -> return ( jobsets, x' : xs )+++rangeSource :: Repo -> Text -> Text -> IO JobSource+rangeSource repo base tip = do+ commits <- listCommits repo (base <> ".." <> tip)+ jobsets <- mapM loadJobSetForCommit commits+ next <- JobSource <$> newTMVarIO Nothing+ JobSource <$> newTMVarIO (Just ( jobsets, next ))++watchBranchSource :: Repo -> Text -> IO JobSource+watchBranchSource repo branch = do+ getCurrentTip <- watchBranch repo branch+ let go prev tmvar = do+ cur <- atomically $ do+ getCurrentTip >>= \case+ Just cur -> do+ when (cur == prev) retry+ return cur+ Nothing -> retry++ commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur))+ jobsets <- mapM loadJobSetForCommit commits+ nextvar <- newEmptyTMVarIO+ atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar )+ go cur nextvar++ tmvar <- newEmptyTMVarIO+ atomically getCurrentTip >>= \case+ Just commit -> + void $ forkIO $ go commit tmvar+ Nothing -> do+ T.hPutStrLn stderr $ "Branch `" <> branch <> "' not found"+ atomically $ putTMVar tmvar Nothing+ return $ JobSource tmvar++watchTagSource :: Repo -> Pattern -> IO JobSource+watchTagSource repo pat = do+ chan <- watchTags repo++ let go tmvar = do+ tag <- atomically $ readTChan chan+ if match pat $ T.unpack $ tagTag tag+ then do+ jobset <- loadJobSetForCommit $ tagObject tag+ nextvar <- newEmptyTMVarIO+ atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar )+ go nextvar+ else do+ go tmvar++ tmvar <- newEmptyTMVarIO+ void $ forkIO $ go tmvar+ return $ JobSource tmvar+ cmdRun :: RunCommand -> CommandExec ()-cmdRun (RunCommand changeset) = do- config <- getConfig- ( base, tip ) <- case T.splitOn (T.pack "..") changeset of- base : tip : _ -> return ( T.unpack base, T.unpack tip )- [ param ] -> liftIO $ do- [ deref ] <- readProcessWithExitCode "git" [ "symbolic-ref", "--quiet", T.unpack param ] "" >>= \case- ( ExitSuccess, out, _ ) -> return $ lines out- ( _, _, _ ) -> return [ T.unpack param ]- [ _, tip ] : _ <- fmap words . lines <$> readProcess "git" [ "show-ref", deref ] ""- [ base ] <- lines <$> readProcess "git" [ "for-each-ref", "--format=%(upstream)", tip ] ""- return ( base, tip )- [] -> error "splitOn should not return empty list"+cmdRun (RunCommand RunOptions {..} args) = do+ CommonOptions {..} <- getCommonOptions+ tout <- getTerminalOutput+ configPath <- getConfigPath+ let baseDir = takeDirectory configPath liftIO $ do- commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>- readProcess "git" [ "log", "--pretty=oneline", "--first-parent", "--reverse", base <> ".." <> tip ] ""+ repo <- openRepo baseDir >>= \case+ Just repo -> return repo+ Nothing -> do+ absPath <- makeAbsolute baseDir+ T.hPutStrLn stderr $ "No repository found at `" <> T.pack absPath <> "'"+ exitFailure - putStr $ replicate (8 + 50) ' '- forM_ (configJobs config) $ \job -> do- T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job- putStrLn ""+ ranges <- forM (args ++ roRanges) $ \changeset -> do+ ( base, tip ) <- case T.splitOn ".." changeset of+ base : tip : _ -> return ( base, tip )+ [ param ] -> liftIO $ do+ [ deref ] <- readProcessWithExitCode "git" [ "symbolic-ref", "--quiet", T.unpack param ] "" >>= \case+ ( ExitSuccess, out, _ ) -> return $ lines out+ ( _, _, _ ) -> return [ T.unpack param ]+ [ _, tip ] : _ <- fmap words . lines <$> readProcess "git" [ "show-ref", deref ] ""+ [ base ] <- lines <$> readProcess "git" [ "for-each-ref", "--format=%(upstream)", tip ] ""+ return ( T.pack base, T.pack tip )+ [] -> error "splitOn should not return empty list"+ rangeSource repo base tip - forM_ commits $ \(cid, desc) -> do- let shortCid = T.pack $ take 7 cid- outs <- runJobs "./.minici" cid $ configJobs config- displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs+ branches <- mapM (watchBranchSource repo) roNewCommitsOn+ tags <- mapM (watchTagSource repo) roNewTags + mngr <- newJobManager (baseDir </> ".minici") optJobs + source <- mergeSources $ concat [ ranges, branches, tags ]+ headerLine <- newLine tout ""++ threadCount <- newTVarIO (0 :: Int)+ let changeCount f = atomically $ do+ writeTVar threadCount . f =<< readTVar threadCount+ let waitForJobs = atomically $ do+ flip when retry . (0 <) =<< readTVar threadCount++ let loop _ Nothing = return ()+ loop names (Just ( [], next )) = do+ loop names =<< atomically (takeJobSource next)++ loop pnames (Just ( jobset : rest, next )) = do+ let names = nub $ (pnames ++) $ map jobName $ jobsetJobs jobset+ when (names /= pnames) $ do+ redrawLine headerLine $ T.concat $+ T.replicate (8 + 50) " " :+ map ((" " <>) . fitToLength 7 . textJobName) names++ let commit = jobsetCommit jobset+ shortCid = T.pack $ take 7 $ showCommitId $ commitId commit+ shortDesc <- fitToLength 50 <$> getCommitTitle commit++ case jobsetJobsEither jobset of+ Right jobs -> do+ outs <- runJobs mngr commit jobs+ let findJob name = snd <$> find ((name ==) . jobName . fst) outs+ line <- newLine tout ""+ mask $ \restore -> do+ changeCount (+ 1)+ void $ forkIO $ (>> changeCount (subtract 1)) $+ try @SomeException $ restore $ do+ displayStatusLine tout line shortCid (" " <> shortDesc) $ map findJob names+ Left err -> do+ void $ newLine tout $+ "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m"+ loop names (Just ( rest, next ))++ handle @SomeException (\_ -> cancelAllJobs mngr) $ do+ loop [] =<< atomically (takeJobSource source)+ waitForJobs+ waitForJobs++ fitToLength :: Int -> Text -> Text fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " " | otherwise = T.take (maxlen - 1) str <> "…"@@ -82,30 +252,33 @@ JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m " JobError _ -> "\ESC[91m!!\ESC[0m " JobFailed -> "\ESC[91m✗\ESC[0m "+ JobCancelled -> "\ESC[0mC\ESC[0m " JobDone _ -> "\ESC[92m✓\ESC[0m " -displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO ()-displayStatusLine prefix1 prefix2 statuses = do- blinkVar <- newTVarIO False- t <- forkIO $ forever $ do- threadDelay 500000- atomically $ writeTVar blinkVar . not =<< readTVar blinkVar- go blinkVar ""- killThread t+ JobDuplicate _ s -> case s of+ JobQueued -> "\ESC[94m^\ESC[0m "+ JobWaiting _ -> "\ESC[94m^\ESC[0m "+ JobSkipped -> "\ESC[0m-\ESC[0m "+ JobRunning -> "\ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m "+ _ -> showStatus blink s++displayStatusLine :: TerminalOutput -> TerminalLine -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO ()+displayStatusLine tout line prefix1 prefix2 statuses = do+ go "\0" where- go blinkVar prev = do+ go prev = do (ss, cur) <- atomically $ do- ss <- mapM readTVar statuses- blink <- readTVar blinkVar- let cur = T.concat $ map ((" " <>) . showStatus blink) ss+ ss <- mapM (sequence . fmap readTVar) statuses+ blink <- terminalBlinkStatus tout+ let cur = T.concat $ map (maybe " " ((" " <>) . showStatus blink)) ss when (cur == prev) retry return (ss, cur)- when (not $ T.null prev) $ putStr "\r"- let prefix1' = if any jobStatusFailed ss then "\ESC[91m" <> prefix1 <> "\ESC[0m"- else prefix1- T.putStr $ prefix1' <> prefix2 <> cur- hFlush stdout - if all jobStatusFinished ss- then T.putStrLn ""- else go blinkVar cur+ let prefix1' = if any (maybe False jobStatusFailed) ss+ then "\ESC[91m" <> prefix1 <> "\ESC[0m"+ else prefix1+ redrawLine line $ prefix1' <> prefix2 <> cur++ if all (maybe True jobStatusFinished) ss+ then return ()+ else go cur
src/Config.hs view
@@ -2,6 +2,9 @@ Config(..), findConfig, parseConfig,++ loadConfigForCommit,+ loadJobSetForCommit, ) where import Control.Monad@@ -17,12 +20,17 @@ import Data.YAML import System.Directory-import System.Exit import System.FilePath import System.Process -import Job+import Job.Types+import Repo ++configFileName :: FilePath+configFileName = "minici.yaml"++ data Config = Config { configJobs :: [Job] }@@ -92,10 +100,9 @@ findConfig :: IO (Maybe FilePath) findConfig = go "." where- name = "minici.yaml" go path = do- doesFileExist (path </> name) >>= \case- True -> return $ Just $ path </> name+ doesFileExist (path </> configFileName) >>= \case+ True -> return $ Just $ path </> configFileName False -> doesDirectoryExist (path </> "..") >>= \case True -> do parent <- canonicalizePath $ path </> ".."@@ -103,11 +110,23 @@ else return Nothing False -> return Nothing -parseConfig :: FilePath -> IO Config-parseConfig path = do- contents <- BS.readFile path+parseConfig :: BS.ByteString -> Either String Config+parseConfig contents = do case decode1 contents of Left (pos, err) -> do- putStr $ prettyPosWithSource pos contents err- exitFailure- Right conf -> return conf+ Left $ prettyPosWithSource pos contents err+ Right conf -> Right conf++loadConfigForCommit :: Commit -> IO (Either String Config)+loadConfigForCommit commit = do+ readCommittedFile commit configFileName >>= return . \case+ Just content -> either (\_ -> Left $ "failed to parse " <> configFileName) Right $ parseConfig content+ Nothing -> Left $ configFileName <> " not found"++loadJobSetForCommit :: Commit -> IO JobSet+loadJobSetForCommit commit = toJobSet <$> loadConfigForCommit commit+ where+ toJobSet configEither = JobSet+ { jobsetCommit = commit+ , jobsetJobsEither = fmap configJobs configEither+ }
src/Job.hs view
@@ -1,10 +1,12 @@ module Job ( Job(..),+ JobSet(..), jobsetJobs, JobOutput(..), JobName(..), stringJobName, textJobName, ArtifactName(..), JobStatus(..), jobStatusFinished, jobStatusFailed,+ JobManager(..), newJobManager, cancelAllJobs, runJobs, ) where @@ -17,6 +19,10 @@ import Control.Monad.IO.Class import Data.List+import Data.Map (Map)+import Data.Map qualified as M+import Data.Set (Set)+import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T@@ -25,33 +31,19 @@ import System.Exit import System.FilePath import System.IO+import System.Posix.Signals import System.Process -data Job = Job- { jobName :: JobName- , jobRecipe :: [CreateProcess]- , jobArtifacts :: [(ArtifactName, CreateProcess)]- , jobUses :: [(JobName, ArtifactName)]- }+import Job.Types+import Repo + data JobOutput = JobOutput { outName :: JobName , outArtifacts :: [ArtifactOutput] } deriving (Eq) -data JobName = JobName Text- deriving (Eq, Ord, Show)--stringJobName :: JobName -> String-stringJobName (JobName name) = T.unpack name--textJobName :: JobName -> Text-textJobName (JobName name) = name--data ArtifactName = ArtifactName Text- deriving (Eq, Ord, Show)- data ArtifactOutput = ArtifactOutput { aoutName :: ArtifactName , aoutWorkPath :: FilePath@@ -61,63 +53,198 @@ data JobStatus a = JobQueued+ | JobDuplicate JobId (JobStatus a) | JobWaiting [JobName] | JobRunning | JobSkipped | JobError Text | JobFailed+ | JobCancelled | JobDone a deriving (Eq) jobStatusFinished :: JobStatus a -> Bool jobStatusFinished = \case- JobQueued {} -> False- JobWaiting {} -> False- JobRunning {} -> False- _ -> True+ JobQueued {} -> False+ JobDuplicate _ s -> jobStatusFinished s+ JobWaiting {} -> False+ JobRunning {} -> False+ _ -> True jobStatusFailed :: JobStatus a -> Bool jobStatusFailed = \case- JobError {} -> True- JobFailed {} -> True- _ -> False+ JobDuplicate _ s -> jobStatusFailed s+ JobError {} -> True+ JobFailed {} -> True+ _ -> False textJobStatus :: JobStatus a -> Text textJobStatus = \case JobQueued -> "queued"+ JobDuplicate {} -> "duplicate" JobWaiting _ -> "waiting" JobRunning -> "running" JobSkipped -> "skipped" JobError err -> "error\n" <> err JobFailed -> "failed"+ JobCancelled -> "cancelled" JobDone _ -> "done" -runJobs :: FilePath -> String -> [Job] -> IO [TVar (JobStatus JobOutput)]-runJobs dir cid jobs = do- results <- forM jobs $ \job -> (job,) <$> newTVarIO JobQueued- gitLock <- newMVar ()- forM_ results $ \(job, outVar) -> void $ forkIO $ do- res <- runExceptT $ do- uses <- waitForUsedArtifacts job results outVar- liftIO $ atomically $ writeTVar outVar JobRunning- prepareJob gitLock dir cid job $ \checkoutPath jdir -> do- updateStatusFile (jdir </> "status") outVar- runJob job uses checkoutPath jdir+data JobManager = JobManager+ { jmSemaphore :: TVar Int+ , jmDataDir :: FilePath+ , jmJobs :: TVar (Map JobId (TVar (JobStatus JobOutput)))+ , jmNextTaskId :: TVar TaskId+ , jmNextTask :: TVar (Maybe TaskId)+ , jmReadyTasks :: TVar (Set TaskId)+ , jmRunningTasks :: TVar (Map TaskId ThreadId)+ , jmCancelled :: TVar Bool+ } - case res of- Left (JobError err) -> T.putStrLn err- _ -> return ()+newtype TaskId = TaskId Int+ deriving (Eq, Ord) - atomically $ writeTVar outVar $ either id JobDone res- return $ map snd results+data JobCancelledException = JobCancelledException+ deriving (Show) +instance Exception JobCancelledException+++newJobManager :: FilePath -> Int -> IO JobManager+newJobManager jmDataDir queueLen = do+ jmSemaphore <- newTVarIO queueLen+ jmJobs <- newTVarIO M.empty+ jmNextTaskId <- newTVarIO (TaskId 0)+ jmNextTask <- newTVarIO Nothing+ jmReadyTasks <- newTVarIO S.empty+ jmRunningTasks <- newTVarIO M.empty+ jmCancelled <- newTVarIO False+ return JobManager {..}++cancelAllJobs :: JobManager -> IO ()+cancelAllJobs JobManager {..} = do+ threads <- atomically $ do+ writeTVar jmCancelled True+ M.elems <$> readTVar jmRunningTasks++ mapM_ (`throwTo` JobCancelledException) threads++reserveTaskId :: JobManager -> STM TaskId+reserveTaskId JobManager {..} = do+ tid@(TaskId n) <- readTVar jmNextTaskId+ writeTVar jmNextTaskId (TaskId (n + 1))+ return tid++runManagedJob :: (MonadIO m, MonadMask m) => JobManager -> TaskId -> m a -> m a -> m a+runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case+ True -> cancel+ False -> job+ where+ acquire = liftIO $ do+ atomically $ do+ writeTVar jmReadyTasks . S.insert tid =<< readTVar jmReadyTasks+ trySelectNext+ threadId <- myThreadId+ atomically $ do+ readTVar jmCancelled >>= \case+ True -> return True+ False -> readTVar jmNextTask >>= \case+ Just tid' | tid' == tid -> do+ writeTVar jmNextTask Nothing+ writeTVar jmRunningTasks . M.insert tid threadId =<< readTVar jmRunningTasks+ return False+ _ -> retry++ release False = liftIO $ atomically $ do+ free <- readTVar jmSemaphore+ writeTVar jmSemaphore $ free + 1+ trySelectNext+ release True = return ()++ trySelectNext = do+ readTVar jmNextTask >>= \case+ Just _ -> return ()+ Nothing -> do+ readTVar jmSemaphore >>= \case+ 0 -> return ()+ sem -> (S.minView <$> readTVar jmReadyTasks) >>= \case+ Nothing -> return ()+ Just ( tid', ready ) -> do+ writeTVar jmReadyTasks ready+ writeTVar jmSemaphore (sem - 1)+ writeTVar jmNextTask (Just tid')+ writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks+++runJobs :: JobManager -> Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]+runJobs mngr@JobManager {..} commit jobs = do+ treeId <- getTreeId commit+ results <- atomically $ do+ forM jobs $ \job -> do+ let jid = JobId [ JobIdTree treeId, JobIdName (jobName job) ]+ tid <- reserveTaskId mngr+ managed <- readTVar jmJobs+ ( job, tid, ) <$> case M.lookup jid managed of+ Just origVar -> do+ newTVar . JobDuplicate jid =<< readTVar origVar++ Nothing -> do+ statusVar <- newTVar JobQueued+ writeTVar jmJobs $ M.insert jid statusVar managed+ return statusVar++ forM_ results $ \( job, tid, outVar ) -> void $ forkIO $ do+ let handler e = atomically $ writeTVar outVar $ if+ | Just JobCancelledException <- fromException e -> JobCancelled+ | otherwise -> JobError (T.pack $ displayException e)+ handle handler $ do+ res <- runExceptT $ do+ duplicate <- liftIO $ atomically $ do+ readTVar outVar >>= \case+ JobDuplicate jid _ -> do+ fmap ( jid, ) . M.lookup jid <$> readTVar jmJobs+ _ -> do+ return Nothing++ case duplicate of+ Nothing -> do+ uses <- waitForUsedArtifacts job results outVar+ runManagedJob mngr tid (return JobCancelled) $ do+ liftIO $ atomically $ writeTVar outVar JobRunning+ prepareJob jmDataDir commit job $ \checkoutPath jdir -> do+ updateStatusFile (jdir </> "status") outVar+ JobDone <$> runJob job uses checkoutPath jdir++ Just ( jid, origVar ) -> do+ let wait = do+ status <- atomically $ do+ status <- readTVar origVar+ out <- readTVar outVar+ if status == out+ then retry+ else do+ writeTVar outVar $ JobDuplicate jid status+ return status+ if jobStatusFinished status+ then return $ JobDuplicate jid status+ else wait+ liftIO wait++ case res of+ Left (JobError err) -> T.putStrLn err+ _ -> return ()++ atomically $ writeTVar outVar $ either id id res+ return $ map (\( job, _, var ) -> ( job, var )) results+ waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>- Job -> [(Job, TVar (JobStatus JobOutput))] -> TVar (JobStatus JobOutput) -> m [ArtifactOutput]+ Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ] waitForUsedArtifacts job results outVar = do+ origState <- liftIO $ atomically $ readTVar outVar ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do- case find ((==ujobName) . jobName . fst) results of- Just (_, var) -> return (var, (ujobName, uartName))+ case find (\( j, _, _ ) -> jobName j == ujobName) results of+ Just ( _, _, var ) -> return ( var, ( ujobName, uartName )) Nothing -> throwError $ JobError $ "Job '" <> tjobName <> "' not found" let loop prev = do@@ -125,7 +252,8 @@ ustatuses <- forM ujobs $ \(uoutVar, uartName) -> do (,uartName) <$> readTVar uoutVar when (Just (map fst ustatuses) == prev) retry- writeTVar outVar $ JobWaiting $ map (fst . snd) $ filter (not . jobStatusFinished . fst) ustatuses+ let remains = map (fst . snd) $ filter (not . jobStatusFinished . fst) ustatuses+ writeTVar outVar $ if null remains then origState else JobWaiting remains return ustatuses if all (jobStatusFinished . fst) ustatuses then return ustatuses@@ -150,18 +278,16 @@ T.writeFile path $ textJobStatus status <> "\n" when (not (jobStatusFinished status)) $ loop $ Just status -prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => MVar () -> FilePath -> String -> Job -> (FilePath -> FilePath -> m a) -> m a-prepareJob gitLock dir cid job inner = do+prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Commit -> Job -> (FilePath -> FilePath -> m a) -> m a+prepareJob dir commit job inner = do [checkoutPath] <- fmap lines $ liftIO $ readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] "" flip finally (liftIO $ removeDirectoryRecursive checkoutPath) $ do- tid <- liftIO $ withMVar gitLock $ \_ -> do- "" <- readProcess "git" ["--work-tree=" <> checkoutPath, "restore", "--source=" <> cid, "--", "."] ""- ["tree", tid]:_ <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] ""- return tid+ checkoutAt commit checkoutPath+ tid <- getTreeId commit - let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job)+ let jdir = dir </> "jobs" </> showTreeId tid </> stringJobName (jobName job) liftIO $ createDirectoryIfMissing True jdir inner checkoutPath jdir@@ -182,10 +308,11 @@ , std_err = UseHandle logs } liftIO $ hClose hin- exit <- liftIO $ waitForProcess hp-- when (exit /= ExitSuccess) $- throwError JobFailed+ liftIO (waitForProcess hp) >>= \case+ ExitSuccess -> return ()+ ExitFailure n+ | fromIntegral n == -sigINT -> throwError JobCancelled+ | otherwise -> throwError JobFailed let adir = jdir </> "artifacts" artifacts <- forM (jobArtifacts job) $ \(name@(ArtifactName tname), pathCmd) -> liftIO $ do
+ src/Job/Types.hs view
@@ -0,0 +1,48 @@+module Job.Types where++import Data.Text (Text)+import Data.Text qualified as T++import System.Process++import Repo+++data Job = Job+ { jobName :: JobName+ , jobRecipe :: [ CreateProcess ]+ , jobArtifacts :: [ ( ArtifactName, CreateProcess ) ]+ , jobUses :: [ ( JobName, ArtifactName ) ]+ }++data JobName = JobName Text+ deriving (Eq, Ord, Show)++stringJobName :: JobName -> String+stringJobName (JobName name) = T.unpack name++textJobName :: JobName -> Text+textJobName (JobName name) = name+++data ArtifactName = ArtifactName Text+ deriving (Eq, Ord, Show)+++data JobSet = JobSet+ { jobsetCommit :: Commit+ , jobsetJobsEither :: Either String [ Job ]+ }++jobsetJobs :: JobSet -> [ Job ]+jobsetJobs = either (const []) id . jobsetJobsEither+++newtype JobId = JobId [ JobIdPart ]+ deriving (Eq, Ord)++data JobIdPart+ = JobIdName JobName+ | JobIdCommit CommitId+ | JobIdTree TreeId+ deriving (Eq, Ord)
src/Main.hs view
@@ -4,6 +4,7 @@ import Control.Monad.Except import Control.Monad.Reader +import Data.ByteString.Lazy qualified as BL import Data.List import Data.Proxy import Data.Text qualified as T@@ -16,17 +17,20 @@ import Command import Command.Run import Config+import Terminal import Version data CmdlineOptions = CmdlineOptions { optShowHelp :: Bool , optShowVersion :: Bool+ , optCommon :: CommonOptions } defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optShowHelp = False , optShowVersion = False+ , optCommon = defaultCommonOptions } options :: [OptDescr (CmdlineOptions -> CmdlineOptions)]@@ -37,6 +41,9 @@ , Option ['V'] ["version"] (NoArg $ \opts -> opts { optShowVersion = True }) "show version and exit"+ , Option ['j'] ["jobs"]+ (ReqArg (\num opts -> opts { optCommon = (optCommon opts) { optJobs = read num }}) "<num>")+ ("number of jobs to run simultaneously (default " <> show (optJobs defaultCommonOptions) <> ")") ] data SomeCommandType = forall c. Command c => SC (Proxy c)@@ -91,7 +98,7 @@ ] exitFailure - runSomeCommand ncmd cargs+ runSomeCommand (optCommon opts) ncmd cargs data FullCommandOptions c = FullCommandOptions { fcoSpecific :: CommandOptions c@@ -113,8 +120,8 @@ "show this help and exit" ] -runSomeCommand :: SomeCommandType -> [ String ] -> IO ()-runSomeCommand (SC tproxy) args = do+runSomeCommand :: CommonOptions -> SomeCommandType -> [ String ] -> IO ()+runSomeCommand ciOptions (SC tproxy) args = do let exitWithErrors errs = do hPutStrLn stderr $ concat errs <> "Try `minici " <> commandName tproxy <> " --help' for more information." exitFailure@@ -131,8 +138,12 @@ putStr $ usageInfo (T.unpack $ commandUsage tproxy) (fullCommandOptions tproxy) exitSuccess - Just configPath <- findConfig- config <- parseConfig configPath+ ciConfigPath <- findConfig+ ciConfig <- case ciConfigPath of+ Just path -> parseConfig <$> BL.readFile path+ Nothing -> return $ Left "no config file found"+ let cmd = commandInit tproxy (fcoSpecific opts) cmdargs let CommandExec exec = commandExec cmd- flip runReaderT config exec+ ciTerminalOutput <- initTerminalOutput+ flip runReaderT CommandInput {..} exec
+ src/Repo.hs view
@@ -0,0 +1,269 @@+module Repo (+ Repo, Commit, commitId,+ CommitId, textCommitId, showCommitId,+ TreeId, textTreeId, showTreeId,+ Tag(..),++ openRepo,+ readBranch,+ readTag,+ listCommits,++ getTreeId,+ getCommitTitle,+ getCommitMessage,++ checkoutAt,+ readCommittedFile,++ watchBranch,+ watchTags,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BC+import Data.ByteString.Lazy qualified as BL+import Data.Function+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding++import System.Directory+import System.Exit+import System.FilePath+import System.INotify+import System.Process+++data Repo+ = GitRepo+ { gitDir :: FilePath+ , gitLock :: MVar ()+ , gitInotify :: MVar (Maybe ( INotify, TChan (Tag Commit) ))+ , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ])+ }++data Commit = Commit+ { commitRepo :: Repo+ , commitId_ :: CommitId+ , commitDetails :: MVar (Maybe CommitDetails)+ }++commitId :: Commit -> CommitId+commitId = commitId_++data CommitDetails = CommitDetails+ { commitTreeId :: TreeId+ , commitTitle :: Text+ , commitMessage :: Text+ }++data Tag a = Tag+ { tagTag :: Text+ , tagObject :: a+ , tagMessage :: Text+ }++instance Eq Repo where+ (==) = (==) `on` gitLock++instance Eq Commit where+ x == y = commitRepo x == commitRepo y &&+ commitId_ x == commitId_ y+++newtype CommitId = CommitId ByteString+ deriving (Eq, Ord)++textCommitId :: CommitId -> Text+textCommitId (CommitId cid) = decodeUtf8 cid++showCommitId :: CommitId -> String+showCommitId (CommitId cid) = BC.unpack cid++newtype TreeId = TreeId ByteString+ deriving (Eq, Ord)++textTreeId :: TreeId -> Text+textTreeId (TreeId tid) = decodeUtf8 tid++showTreeId :: TreeId -> String+showTreeId (TreeId tid) = BC.unpack tid+++openRepo :: FilePath -> IO (Maybe Repo)+openRepo path = do+ findGitDir >>= \case+ Just gitDir -> do+ gitLock <- newMVar ()+ gitInotify <- newMVar Nothing+ gitWatchedBranches <- newMVar M.empty+ return $ Just GitRepo {..}+ Nothing -> do+ return Nothing+ where+ tryGitDir gpath = readProcessWithExitCode "git" [ "rev-parse", "--resolve-git-dir", gpath ] "" >>= \case+ ( ExitSuccess, out, _ ) | dir : _ <- lines out -> return (Just dir)+ _ -> return Nothing+ findGitDir = do+ tryGitDir path >>= \case+ Just dir -> return (Just dir)+ Nothing -> tryGitDir (path </> ".git") >>= \case+ Just dir -> return (Just dir)+ _ -> return Nothing++mkCommit :: Repo -> CommitId -> IO Commit+mkCommit commitRepo commitId_ = do+ commitDetails <- newMVar Nothing+ return $ Commit {..}++readCommitFromFile :: MonadIO m => Repo -> FilePath -> m (Maybe Commit)+readCommitFromFile repo@GitRepo {..} path = liftIO $ do+ try @IOException (BC.readFile $ gitDir </> path) >>= \case+ Right content | (cid : _) <- BC.lines content -> do+ Just <$> mkCommit repo (CommitId cid)+ _ -> do+ return Nothing++readBranch :: MonadIO m => Repo -> Text -> m (Maybe Commit)+readBranch repo branch = readCommitFromFile repo ("refs/heads" </> T.unpack branch)++readTag :: MonadIO m => Repo -> Text -> m (Maybe (Tag Commit))+readTag repo@GitRepo {..} tag = do+ ( infoPart, message ) <-+ fmap (fmap (drop 1) . span (not . null) . lines) $+ liftIO $ withMVar gitLock $ \_ -> do+ readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "tag", T.unpack tag ] ""+ let info = map (fmap (drop 1) . span (/= ' ')) infoPart++ sequence $ do+ otype <- lookup "type" info+ guard (otype == "commit")+ tagTag <- T.pack <$> lookup "tag" info+ cid <- CommitId . BC.pack <$> lookup "object" info+ let tagMessage = T.pack $ unlines $ dropWhile null message+ Just $ do+ tagObject <- liftIO $ mkCommit repo cid+ return Tag {..}++listCommits :: MonadIO m => Repo -> Text -> m [ Commit ]+listCommits commitRepo range = liftIO $ do+ out <- readProcess "git" [ "log", "--pretty=%H", "--first-parent", "--reverse", T.unpack range ] ""+ forM (lines out) $ \cid -> do+ let commitId_ = CommitId (BC.pack cid)+ commitDetails <- newMVar Nothing+ return Commit {..}+++getCommitDetails :: (MonadIO m, MonadFail m) => Commit -> m CommitDetails+getCommitDetails Commit {..} = do+ let GitRepo {..} = commitRepo+ liftIO $ do+ modifyMVar commitDetails $ \case+ cur@(Just details) -> do+ return ( cur, details )+ Nothing -> do+ ( infoPart, _ : title : message ) <-+ fmap (span (not . null) . lines) $+ withMVar gitLock $ \_ -> do+ readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "commit", showCommitId commitId_ ] ""+ let info = map (fmap (drop 1) . span (/= ' ')) infoPart++ Just commitTreeId <- return $ TreeId . BC.pack <$> lookup "tree" info+ let commitTitle = T.pack title+ let commitMessage = T.pack $ unlines $ dropWhile null message++ let details = CommitDetails {..}+ return ( Just details, details )++getTreeId :: (MonadIO m, MonadFail m) => Commit -> m TreeId+getTreeId = fmap commitTreeId . getCommitDetails++getCommitTitle :: (MonadIO m, MonadFail m) => Commit -> m Text+getCommitTitle = fmap commitTitle . getCommitDetails++getCommitMessage :: (MonadIO m, MonadFail m) => Commit -> m Text+getCommitMessage = fmap commitMessage . getCommitDetails+++checkoutAt :: (MonadIO m, MonadFail m) => Commit -> FilePath -> m ()+checkoutAt Commit {..} dest = do+ let GitRepo {..} = commitRepo+ liftIO $ withMVar gitLock $ \_ -> do+ "" <- readProcess "git" [ "clone", "--quiet", "--shared", "--no-checkout", gitDir, dest ] ""+ "" <- readProcess "git" [ "-C", dest, "restore", "--worktree", "--source=" <> showCommitId commitId_, "--", "." ] ""+ removeDirectoryRecursive $ dest </> ".git"+++readCommittedFile :: Commit -> FilePath -> IO (Maybe BL.ByteString)+readCommittedFile Commit {..} path = do+ let GitRepo {..} = commitRepo+ liftIO $ withMVar gitLock $ \_ -> do+ let cmd = (proc "git" [ "--git-dir=" <> gitDir, "cat-file", "blob", showCommitId commitId_ <> ":" <> path ])+ { std_in = NoStream+ , std_out = CreatePipe+ }+ createProcess cmd >>= \( _, mbstdout, _, ph ) -> if+ | Just stdout <- mbstdout -> do+ content <- BL.hGetContents stdout++ -- check if there will be some output:+ case BL.uncons content of+ Just (c, _) -> c `seq` return ()+ Nothing -> return ()++ getProcessExitCode ph >>= \case+ Just code | code /= ExitSuccess ->+ return Nothing+ _ ->+ return (Just content)+ | otherwise -> error "createProcess must return stdout handle"+++repoInotify :: Repo -> IO ( INotify, TChan (Tag Commit) )+repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case+ cur@(Just info) ->+ return ( cur, info )+ Nothing -> do+ inotify <- initINotify+ tagsChan <- newBroadcastTChanIO+ let info = ( inotify, tagsChan )++ _ <- addWatch inotify [ MoveIn ] (BC.pack headsDir) $ \event -> do+ let branch = decodeUtf8 $ filePath event+ tvars <- fromMaybe [] . M.lookup branch <$> readMVar gitWatchedBranches+ when (not $ null tvars) $ do+ commit <- readBranch repo branch+ atomically $ do+ mapM_ (`writeTVar` commit) tvars++ _ <- addWatch inotify [ MoveIn ] (BC.pack tagsDir) $ \event -> do+ readTag repo (decodeUtf8 $ filePath event) >>= \case+ Just tag -> atomically $ writeTChan tagsChan tag+ Nothing -> return ()++ return ( Just info, info )+ where+ headsDir = gitDir </> "refs/heads"+ tagsDir = gitDir </> "refs/tags"++watchBranch :: Repo -> Text -> IO (STM (Maybe Commit))+watchBranch repo@GitRepo {..} branch = do+ var <- newTVarIO =<< readBranch repo branch+ void $ repoInotify repo+ modifyMVar_ gitWatchedBranches $ return . M.insertWith (++) branch [ var ]+ return $ readTVar var++watchTags :: Repo -> IO (TChan (Tag Commit))+watchTags repo = do+ tagsChan <- snd <$> repoInotify repo+ atomically $ dupTChan tagsChan
+ src/Terminal.hs view
@@ -0,0 +1,56 @@+module Terminal (+ TerminalOutput,+ TerminalLine,+ initTerminalOutput,+ newLine,+ redrawLine,+ terminalBlinkStatus,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad++import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T++import System.IO+++data TerminalOutput = TerminalOutput+ { outNumLines :: MVar Int+ , outBlinkVar :: TVar Bool+ }++data TerminalLine = TerminalLine+ { lineOutput :: TerminalOutput+ , lineNum :: Int+ }++initTerminalOutput :: IO TerminalOutput+initTerminalOutput = do+ outNumLines <- newMVar 0+ outBlinkVar <- newTVarIO False+ void $ forkIO $ forever $ do+ threadDelay 500000+ atomically $ writeTVar outBlinkVar . not =<< readTVar outBlinkVar+ return TerminalOutput {..}++newLine :: TerminalOutput -> Text -> IO TerminalLine+newLine lineOutput@TerminalOutput {..} text = do+ modifyMVar outNumLines $ \lineNum -> do+ T.putStrLn text+ hFlush stdout+ return ( lineNum + 1, TerminalLine {..} )++redrawLine :: TerminalLine -> Text -> IO ()+redrawLine TerminalLine {..} text = do+ let TerminalOutput {..} = lineOutput+ withMVar outNumLines $ \total -> do+ let moveBy = total - lineNum+ T.putStr $ "\ESC[s\ESC[" <> T.pack (show moveBy) <> "F" <> text <> "\ESC[u"+ hFlush stdout++terminalBlinkStatus :: TerminalOutput -> STM Bool+terminalBlinkStatus TerminalOutput {..} = readTVar outBlinkVar