From c831d87f4b7d1a44a556c5b9d00bb5b2c3ee508b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 24 Oct 2026 16:48:37 +0200 Subject: Tags watch expressions --- src/Expression.hs | 53 +++++++++++++++++++++++++++++++++++++++++++++++------ src/Repo.hs | 11 +++++++++++ 2 files changed, 58 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Expression.hs b/src/Expression.hs index 4ff7ddd..536bf68 100644 --- a/src/Expression.hs +++ b/src/Expression.hs @@ -17,6 +17,7 @@ module Expression ( ) where import Control.Concurrent.STM +import Control.Monad import Control.Monad.IO.Class import Data.Bifunctor @@ -32,6 +33,7 @@ import Data.Void import Text.Megaparsec import Text.Megaparsec.Char +import System.FilePath.Glob as Glob import System.IO.Error import Job.Types @@ -51,6 +53,21 @@ type family WatchedRef' d :: Type where WatchedRef' Evaluated = WatchedRef +type family StaticTags' d :: Type where + StaticTags' Declared = Pattern + StaticTags' Evaluated = [ Tag Commit ] + +data WatchedTags = WatchedTags + { wtPattern :: Pattern + , wtList :: TVar [ Tag Commit ] + , wtChan :: TChan (Tag Commit) + } + +type family WatchedTags' d :: Type where + WatchedTags' Declared = Pattern + WatchedTags' Evaluated = WatchedTags + + data RevisionExpression' d = StaticRef (StaticRef' d) | WatchedRef (WatchedRef' d) @@ -69,6 +86,8 @@ watchedRevision = \case data RangeExpression' d = SingleRevisionExpression (RevisionExpression' d) | RangeExpression (RevisionExpression' d) {- tip -} (RevisionExpression' d) {- except -} + | StaticTagsExpression (StaticTags' d) + | WatchedTagsExpression (WatchedTags' d) type RangeExpression = RangeExpression' Evaluated type DeclaredRangeExpression = RangeExpression' Declared @@ -77,6 +96,8 @@ watchedRange :: DeclaredRangeExpression -> DeclaredRangeExpression watchedRange = \case SingleRevisionExpression rev -> SingleRevisionExpression (watchedRevision rev) RangeExpression r1 r2 -> RangeExpression (watchedRevision r1) (watchedRevision r2) + StaticTagsExpression pat -> WatchedTagsExpression pat + WatchedTagsExpression pat -> WatchedTagsExpression pat data CommitRef = CommitRef Text {- suffix -} CommitId @@ -85,7 +106,7 @@ data CommitRef = CommitRef Text {- suffix -} CommitId data CommitRange = EmptyCommitRange | CommitRange CommitRef {- tip -} CommitRef {- except -} - | CommitSet [ CommitRef ] {- latest first -} + | CommitSet [ CommitRef ] deriving (Eq) textCommitRef :: CommitRef -> Text @@ -108,6 +129,12 @@ evaluateDeclaredRange repo = \case SingleRevisionExpression <$> evaluateDeclaredRevision repo a RangeExpression a b -> RangeExpression <$> evaluateDeclaredRevision repo a <*> evaluateDeclaredRevision repo b + StaticTagsExpression pat -> + StaticTagsExpression . filter (Glob.match pat . T.unpack . tagTag) <$> listTags repo + WatchedTagsExpression wtPattern -> do + wtChan <- watchTags repo + wtList <- liftIO . newTVarIO . filter (Glob.match wtPattern . T.unpack . tagTag) =<< listTags repo + return $ WatchedTagsExpression WatchedTags {..} evaluateRevision :: RevisionExpression -> STM (Maybe CommitRef) evaluateRevision = \case @@ -125,6 +152,10 @@ evaluateRange = \case tip <- evaluateRevision tipExpr except <- evaluateRevision exceptExpr return $ fromMaybe EmptyCommitRange $ CommitRange <$> tip <*> except + StaticTagsExpression tags -> do + return $ CommitSet $ map (CommitRef "" . commitId . tagObject) tags + WatchedTagsExpression wt -> do + CommitSet . map (CommitRef "" . commitId . tagObject) <$> updateWatchedTags wt getCommitIdFromRef :: MonadIO m => Repo -> CommitRef -> m (Maybe CommitId) getCommitIdFromRef repo = liftIO . fmap (fmap commitId) . tryReadCommit repo . textCommitRef @@ -164,6 +195,8 @@ isRangeExpressionDynamic :: RangeExpression -> Bool isRangeExpressionDynamic = \case SingleRevisionExpression x -> isRevisionExpressionDynamic x RangeExpression x y -> isRevisionExpressionDynamic x || isRevisionExpressionDynamic y + StaticTagsExpression {} -> False + WatchedTagsExpression {} -> True isRevisionExpressionDynamic :: RevisionExpression -> Bool isRevisionExpressionDynamic = \case @@ -171,6 +204,15 @@ isRevisionExpressionDynamic = \case WatchedRef _ -> True ModifiedRevision _ e -> isRevisionExpressionDynamic e +updateWatchedTags :: WatchedTags -> STM [ Tag Commit ] +updateWatchedTags wt@WatchedTags {..} = do + tryReadTChan wtChan >>= \case + Nothing -> readTVar wtList + Just tag -> do + when (Glob.match wtPattern $ T.unpack $ tagTag tag) $ do + writeTVar wtList . (tag :) =<< readTVar wtList + updateWatchedTags wt + type ExprParser = Parsec Void Text @@ -204,12 +246,11 @@ parseRangeExpression = bimap errorBundlePretty id . runParser parser "" ] range <- choice - [ do - _ <- char '(' - arg <- parseRange - _ <- char ')' + [ between (char '(') (char ')') $ do case tok of - "watch" -> return $ watchedRange arg + "watch" -> watchedRange <$> parseRange + "tags" -> StaticTagsExpression . compile . T.unpack <$> + takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '.', '[', ']', '*', '?' ]) _ -> unexpected $ Tokens $ NE.fromList $ chunkToTokens @Text Proxy tok , do diff --git a/src/Repo.hs b/src/Repo.hs index 78d0c60..b6ad8d4 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -16,6 +16,7 @@ module Repo ( readBranch, readTag, tryReadTag, listCommits, listCommitsFrom, + listTags, mergeBase, findUpstreamRef, @@ -287,6 +288,16 @@ listCommitsFrom commitRepo from except = liftIO $ do commitDetails <- newMVar Nothing return Commit {..} +listTags :: MonadIO m => Repo -> m [ Tag Commit ] +listTags repo = liftIO $ do + out <- runGitCommand repo + [ "for-each-ref", "refs/tags" + , "--format=%(objecttype) %(refname:short)" + ] + fmap catMaybes $ forM (map words $ lines out) $ \case + [ "tag", tname ] -> tryReadTag repo (T.pack tname) + _ -> return Nothing + mergeBase :: MonadIO m => Repo -> [ CommitId ] -> m [ Commit ] mergeBase commitRepo cids = liftIO $ do out <- runGitCommand commitRepo $ "merge-base" : "--all" : "--octopus" : map showCommitId cids -- cgit v1.2.3