From aa113848a5884f95d543c2acecb55321db23b3ba Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 19 Jan 2025 14:06:29 +0100
Subject: Option to run tasks for new commits on branch
---
src/Command.hs | 3 ++
src/Command/Run.hs | 156 ++++++++++++++++++++++++++++++++++++++++++++---------
src/Repo.hs | 14 +++--
3 files changed, 144 insertions(+), 29 deletions(-)
diff --git a/src/Command.hs b/src/Command.hs
index c602ba8..c765cfd 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -69,6 +69,9 @@ instance CommandArgumentsType (Maybe Text) where
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 CommandInput IO a)
deriving (Functor, Applicative, Monad, MonadIO)
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index 14341cd..52b70f3 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -9,11 +9,13 @@ import Control.Monad
import Control.Monad.Reader
import Data.List
-import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import System.Console.GetOpt
import System.Exit
+import System.IO
import System.Process
import Command
@@ -23,13 +25,18 @@ import Repo
import Terminal
-data RunCommand = RunCommand Text
+data RunCommand = RunCommand RunOptions [ Text ]
+
+data RunOptions = RunOptions
+ { roRanges :: [ Text ]
+ , roNewCommitsOn :: [ Text ]
+ }
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"
@@ -38,36 +45,121 @@ instance Command RunCommand where
, " 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)"
+ ]
+
+ type CommandOptions RunCommand = RunOptions
+ defaultCommandOptions _ = RunOptions
+ { roRanges = []
+ , roNewCommitsOn = []
+ }
+
+ 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"
]
- commandInit _ _ = RunCommand . fromMaybe "HEAD"
+ 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
+
cmdRun :: RunCommand -> CommandExec ()
-cmdRun (RunCommand changeset) = do
+cmdRun (RunCommand RunOptions {..} args) = do
CommonOptions {..} <- getCommonOptions
- ( 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"
-
tout <- getTerminalOutput
+
liftIO $ do
- mngr <- newJobManager "./.minici" optJobs
Just repo <- openRepo "."
- commits <- listCommits repo (base <> ".." <> tip)
- jobssets <- mapM loadJobSetForCommit commits
- let names = nub $ map jobName $ concatMap jobsetJobs jobssets
+ 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
+
+ branches <- mapM (watchBranchSource repo) roNewCommitsOn
- void $ newLine tout $ T.concat $
- T.replicate (8 + 50) " " :
- map ((" "<>) . fitToLength 7 . textJobName) names
+ mngr <- newJobManager "./.minici" optJobs
+
+ source <- mergeSources $ concat [ ranges, branches ]
+ headerLine <- newLine tout ""
threadCount <- newTVarIO (0 :: Int)
let changeCount f = atomically $ do
@@ -75,11 +167,21 @@ cmdRun (RunCommand changeset) = do
let waitForJobs = atomically $ do
flip when retry . (0 <) =<< readTVar threadCount
- handle @SomeException (\_ -> cancelAllJobs mngr) $ do
- forM_ jobssets $ \jobset -> do
+ 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
@@ -93,6 +195,10 @@ cmdRun (RunCommand changeset) = do
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
diff --git a/src/Repo.hs b/src/Repo.hs
index caa8a20..fbcd2ed 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -1,7 +1,7 @@
module Repo (
Repo, Commit, commitId,
- CommitId, showCommitId,
- TreeId, showTreeId,
+ CommitId, textCommitId, showCommitId,
+ TreeId, textTreeId, showTreeId,
openRepo,
readBranch,
@@ -77,12 +77,18 @@ instance Eq Commit where
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
@@ -124,9 +130,9 @@ readBranch repo branch = readCommitFromFile repo ("refs/heads" </> T.unpack bran
readTag :: MonadIO m => Repo -> Text -> m (Maybe Commit)
readTag repo tag = readCommitFromFile repo ("refs/tags" </> T.unpack tag)
-listCommits :: MonadIO m => Repo -> String -> m [ Commit ]
+listCommits :: MonadIO m => Repo -> Text -> m [ Commit ]
listCommits commitRepo range = liftIO $ do
- out <- readProcess "git" [ "log", "--pretty=%H", "--first-parent", "--reverse", range ] ""
+ 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
--
cgit v1.2.3