diff options
| -rw-r--r-- | src/Expression.hs | 53 | ||||
| -rw-r--r-- | src/Repo.hs | 11 | ||||
| -rw-r--r-- | test/script/expression.et | 106 |
3 files changed, 164 insertions, 6 deletions
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 diff --git a/test/script/expression.et b/test/script/expression.et new file mode 100644 index 0000000..c92a09b --- /dev/null +++ b/test/script/expression.et @@ -0,0 +1,106 @@ +module expression + +import common + +asset scripts: + path: ../asset/run + + +test WatchTagList: + node n + shell on n as git_init: + git -c init.defaultBranch=master init -q + git -c user.name=test -c user.email=test commit -q --allow-empty -m 'initial commit' + cp "${scripts.path}/single.yaml" minici.yaml + git add minici.yaml + git -c user.name=test -c user.email=test commit -q -m 'minici.yaml' + git rev-parse HEAD + + touch a + git add a + git -c user.name=test -c user.email=test commit -q -m a + git rev-parse HEAD + git rev-parse HEAD^{tree} + + touch b + git add b + git -c user.name=test -c user.email=test commit -q -m b + git rev-parse HEAD + git rev-parse HEAD^{tree} + + touch c + git add c + git -c user.name=test -c user.email=test commit -q -m c + git rev-parse HEAD + git rev-parse HEAD^{tree} + + touch d + git add d + git -c user.name=test -c user.email=test commit -q -m d + git rev-parse HEAD + git rev-parse HEAD^{tree} + + touch e + git add e + git -c user.name=test -c user.email=test commit -q -m e + git rev-parse HEAD + git rev-parse HEAD^{tree} + + git reset --hard HEAD~5 + git rev-parse HEAD + + expect /([0-9a-f]+)/ from git_init capture c_init + expect /([0-9a-f]+)/ from git_init capture ca + expect /([0-9a-f]+)/ from git_init capture ta + expect /([0-9a-f]+)/ from git_init capture cb + expect /([0-9a-f]+)/ from git_init capture tb + expect /([0-9a-f]+)/ from git_init capture cc + expect /([0-9a-f]+)/ from git_init capture tc + expect /([0-9a-f]+)/ from git_init capture cd + expect /([0-9a-f]+)/ from git_init capture td + expect /([0-9a-f]+)/ from git_init capture ce + expect /([0-9a-f]+)/ from git_init capture te + expect /([0-9a-f]+)/ from git_init capture c_end + + guard (c_init == c_end) + + shell on n: + git -c user.name=test -c user.email=test tag -a -m . v1 $ca + git -c user.name=test -c user.email=test tag -a -m . x1 $cb + + local: + spawn on n as p args [ "run", "--rerun-all", "tags(v*)" ] + expect from p: + /job-enqueue $ta:single/ + /job-start $ta:single/ + /job-finish $ta:single done/ + expect /(.*)/ from p capture finish + guard (finish == "run-finish") + + local: + spawn on n as p args [ "run", "--rerun-all", "watch(tags(v*))" ] killwith SIGINT + expect from p: + /job-enqueue $ta:single/ + /job-start $ta:single/ + /job-finish $ta:single done/ + + shell on n: + git -c user.name=test -c user.email=test tag -a -m . v2 $cc + + expect from p: + /job-enqueue $tc:single/ + /job-start $tc:single/ + /job-finish $tc:single done/ + + shell on n: + git -c user.name=test -c user.email=test tag -a -m . x2 $cd + + shell on n: + git -c user.name=test -c user.email=test tag -a -m . v3 $ce + + local: + expect from p /job-enqueue ([0-9a-f]+):single/ capture tid + guard (tid == te) + expect from p: + /job-start $te:single/ + /job-finish $te:single done/ |