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