Option to run jobs for new tags

2 files changed, 64 insertions, 12 deletions

diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index b998a60..f93e619 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -17,6 +17,7 @@ import System.Console.GetOpt
 import System.Directory
 import System.Exit
 import System.FilePath
+import System.FilePath.Glob
 import System.IO
 import System.Process
 
@@ -32,6 +33,7 @@ data RunCommand = RunCommand RunOptions [ Text ]
 data RunOptions = RunOptions
     { roRanges :: [ Text ]
     , roNewCommitsOn :: [ Text ]
+    , roNewTags :: [ Pattern ]
     }
 
 instance Command RunCommand where
@@ -55,6 +57,7 @@ instance Command RunCommand where
     defaultCommandOptions _ = RunOptions
         { roRanges = []
         , roNewCommitsOn = []
+        , roNewTags = []
         }
 
     commandOptions _ =
@@ -64,6 +67,9 @@ instance Command RunCommand where
         , 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
@@ -136,6 +142,25 @@ watchBranchSource repo branch = do
             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 RunOptions {..} args) = do
     CommonOptions {..} <- getCommonOptions
@@ -165,10 +190,11 @@ cmdRun (RunCommand RunOptions {..} args) = do
             rangeSource repo base tip
 
         branches <- mapM (watchBranchSource repo) roNewCommitsOn
+        tags <- mapM (watchTagSource repo) roNewTags
 
         mngr <- newJobManager (baseDir </> ".minici") optJobs
 
-        source <- mergeSources $ concat [ ranges, branches ]
+        source <- mergeSources $ concat [ ranges, branches, tags ]
         headerLine <- newLine tout ""
 
         threadCount <- newTVarIO (0 :: Int)
diff --git a/src/Repo.hs b/src/Repo.hs
index fbcd2ed..43f6923 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -2,6 +2,7 @@ module Repo (
     Repo, Commit, commitId,
     CommitId, textCommitId, showCommitId,
     TreeId, textTreeId, showTreeId,
+    Tag(..),
 
     openRepo,
     readBranch,
@@ -47,7 +48,7 @@ data Repo
     = GitRepo
         { gitDir :: FilePath
         , gitLock :: MVar ()
-        , gitInotify :: MVar (Maybe ( INotify, TChan Text ))
+        , gitInotify :: MVar (Maybe ( INotify, TChan (Tag Commit) ))
         , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ])
         }
 
@@ -66,6 +67,12 @@ data CommitDetails = CommitDetails
     , commitMessage :: Text
     }
 
+data Tag a = Tag
+    { tagTag :: Text
+    , tagObject :: a
+    , tagMessage :: Text
+    }
+
 instance Eq Repo where
     (==) = (==) `on` gitLock
 
@@ -114,21 +121,39 @@ openRepo path = do
                 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 commitRepo@GitRepo {..} path = liftIO $ do
+readCommitFromFile repo@GitRepo {..} path = liftIO $ do
     try @IOException (BC.readFile $ gitDir </> path) >>= \case
         Right content | (cid : _) <- BC.lines content -> do
-            let commitId_ = CommitId cid
-            commitDetails <- newMVar Nothing
-            return $ Just Commit {..}
+            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 Commit)
-readTag repo tag = readCommitFromFile repo ("refs/tags" </> T.unpack tag)
+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
@@ -204,7 +229,7 @@ readCommittedFile Commit {..} path = do
             | otherwise -> error "createProcess must return stdout handle"
 
 
-repoInotify :: Repo -> IO ( INotify, TChan Text )
+repoInotify :: Repo -> IO ( INotify, TChan (Tag Commit) )
 repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case
     cur@(Just info) ->
         return ( cur, info )
@@ -222,8 +247,9 @@ repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case
                     mapM_ (`writeTVar` commit) tvars
 
         _ <- addWatch inotify [ MoveIn ] (BC.pack tagsDir) $ \event -> do
-            let tag = decodeUtf8 $ filePath event
-            atomically $ writeTChan tagsChan tag
+            readTag repo (decodeUtf8 $ filePath event) >>= \case
+                Just tag -> atomically $ writeTChan tagsChan tag
+                Nothing  -> return ()
 
         return ( Just info, info )
   where
@@ -237,7 +263,7 @@ watchBranch repo@GitRepo {..} branch = do
     modifyMVar_ gitWatchedBranches $ return . M.insertWith (++) branch [ var ]
     return $ readTVar var
 
-watchTags :: Repo -> IO (TChan Text)
+watchTags :: Repo -> IO (TChan (Tag Commit))
 watchTags repo = do
     tagsChan <- snd <$> repoInotify repo
     atomically $ dupTChan tagsChan