diff options
| -rw-r--r-- | src/Command/Run.hs | 2 | ||||
| -rw-r--r-- | src/Expression.hs | 69 | ||||
| -rw-r--r-- | test/script/expression.et | 100 |
3 files changed, 156 insertions, 15 deletions
diff --git a/src/Command/Run.hs b/src/Command/Run.hs index 85bc59d..f200738 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -276,7 +276,7 @@ watchExpressionSource expr = do watchBranchSource :: Text -> CommandExec JobSource watchBranchSource branch = do repo <- getDefaultRepo - expr <- evaluateDeclaredRange repo $ RangeExpression (WatchedRef branch) (StaticRef branch) + expr <- evaluateDeclaredRange repo $ RangeExpression (WatchedRef (TextRef branch)) (StaticRef (TextRef branch)) watchExpressionSource expr watchTagSource :: Pattern -> CommandExec JobSource diff --git a/src/Expression.hs b/src/Expression.hs index 536bf68..994912e 100644 --- a/src/Expression.hs +++ b/src/Expression.hs @@ -1,4 +1,5 @@ module Expression ( + DeclaredRef(..), StaticRef', WatchedRef(..), WatchedRef', @@ -22,7 +23,9 @@ import Control.Monad.IO.Class import Data.Bifunctor import Data.Char +import Data.Function import Data.Kind +import Data.List import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Proxy @@ -41,15 +44,20 @@ import Output import Repo +data DeclaredRef + = TextRef Text + | TagRef Pattern (Tag Commit -> Tag Commit -> Tag Commit) + type family StaticRef' d :: Type where - StaticRef' Declared = Text + StaticRef' Declared = DeclaredRef StaticRef' Evaluated = Commit data WatchedRef = BranchRef (STM (Maybe Commit)) + | WatchedTagRef (WatchedTags (Tag Commit)) type family WatchedRef' d :: Type where - WatchedRef' Declared = Text + WatchedRef' Declared = DeclaredRef WatchedRef' Evaluated = WatchedRef @@ -57,15 +65,16 @@ type family StaticTags' d :: Type where StaticTags' Declared = Pattern StaticTags' Evaluated = [ Tag Commit ] -data WatchedTags = WatchedTags +data WatchedTags a = WatchedTags { wtPattern :: Pattern - , wtList :: TVar [ Tag Commit ] + , wtUpdate :: Tag Commit -> a -> a + , wtValue :: TVar a , wtChan :: TChan (Tag Commit) } type family WatchedTags' d :: Type where WatchedTags' Declared = Pattern - WatchedTags' Evaluated = WatchedTags + WatchedTags' Evaluated = WatchedTags [ Tag Commit ] data RevisionExpression' d @@ -115,12 +124,25 @@ textCommitRef (CommitRef suffix cid) = textCommitId cid <> suffix evaluateDeclaredRevision :: (MonadIO m, MonadFail m, MonadOutput m) => Repo -> DeclaredRevisionExpression -> m RevisionExpression evaluateDeclaredRevision repo = \case - StaticRef ref -> StaticRef <$> readCommit repo ref - WatchedRef ref -> do + StaticRef (TextRef ref) -> StaticRef <$> readCommit repo ref + StaticRef (TagRef pat sel) -> do + filter (Glob.match pat . T.unpack . tagTag) <$> listTags repo >>= \case + [] -> fail $ "no tag matching " <> show (decompile pat) <> " found" + ts -> return $ StaticRef $ tagObject $ foldl1' sel ts + + WatchedRef (TextRef ref) -> do watched <- watchBranch repo ref output <- getOutput outputEvent output $ TestMessage $ "watch-branch-started " <> ref return $ WatchedRef $ BranchRef watched + WatchedRef (TagRef wtPattern wtUpdate) -> do + wtChan <- watchTags repo + value <- filter (Glob.match wtPattern . T.unpack . tagTag) <$> listTags repo >>= \case + [] -> fail $ "no tag matching " <> show (decompile wtPattern) <> " found" + ts -> return $ foldl1' wtUpdate ts + wtValue <- liftIO $ newTVarIO value + return $ WatchedRef $ WatchedTagRef WatchedTags {..} + ModifiedRevision suffix rev -> ModifiedRevision suffix <$> evaluateDeclaredRevision repo rev evaluateDeclaredRange :: (MonadIO m, MonadFail m, MonadOutput m) => Repo -> DeclaredRangeExpression -> m RangeExpression @@ -133,13 +155,15 @@ evaluateDeclaredRange repo = \case 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 + wtValue <- liftIO . newTVarIO . filter (Glob.match wtPattern . T.unpack . tagTag) =<< listTags repo + let wtUpdate = (:) return $ WatchedTagsExpression WatchedTags {..} evaluateRevision :: RevisionExpression -> STM (Maybe CommitRef) evaluateRevision = \case StaticRef commit -> return $ Just $ CommitRef "" $ commitId commit WatchedRef (BranchRef getter) -> fmap (CommitRef "" . commitId) <$> getter + WatchedRef (WatchedTagRef wt) -> Just . CommitRef "" . commitId . tagObject <$> updateWatchedTags wt ModifiedRevision suffix rev -> fmap (\(CommitRef suffix' ref) -> CommitRef (suffix' <> suffix) ref) <$> evaluateRevision rev @@ -204,13 +228,13 @@ isRevisionExpressionDynamic = \case WatchedRef _ -> True ModifiedRevision _ e -> isRevisionExpressionDynamic e -updateWatchedTags :: WatchedTags -> STM [ Tag Commit ] +updateWatchedTags :: WatchedTags a -> STM a updateWatchedTags wt@WatchedTags {..} = do tryReadTChan wtChan >>= \case - Nothing -> readTVar wtList + Nothing -> readTVar wtValue Just tag -> do when (Glob.match wtPattern $ T.unpack $ tagTag tag) $ do - writeTVar wtList . (tag :) =<< readTVar wtList + writeTVar wtValue . (wtUpdate tag) =<< readTVar wtValue updateWatchedTags wt @@ -249,12 +273,14 @@ parseRangeExpression = bimap errorBundlePretty id . runParser parser "" [ between (char '(') (char ')') $ do case tok of "watch" -> watchedRange <$> parseRange - "tags" -> StaticTagsExpression . compile . T.unpack <$> - takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '.', '[', ']', '*', '?' ]) + "tags" -> StaticTagsExpression <$> parseTagPattern + "highesttag" -> do + pat <- parseTagPattern + return $ SingleRevisionExpression $ StaticRef $ TagRef pat higherTag _ -> unexpected $ Tokens $ NE.fromList $ chunkToTokens @Text Proxy tok , do - return $ SingleRevisionExpression $ StaticRef tok + return $ SingleRevisionExpression $ StaticRef $ TextRef tok ] choice @@ -265,3 +291,18 @@ parseRangeExpression = bimap errorBundlePretty id . runParser parser "" , do return range ] + + parseTagPattern = compile . T.unpack <$> takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '.', '[', ']', '*', '?' ]) + + +higherTag :: Tag a -> Tag a -> Tag a +higherTag t t' + | components t < components t' = t' + | otherwise = t + where + components = map component . T.groupBy ((==) `on` isDigit) . tagTag + component s + | Just ( c, _ ) <- T.uncons s, isDigit c + = Left $ read @Integer $ T.unpack s + | otherwise + = Right s diff --git a/test/script/expression.et b/test/script/expression.et index 8fbaa03..bbb312a 100644 --- a/test/script/expression.et +++ b/test/script/expression.et @@ -260,3 +260,103 @@ test WatchTagList: expect from p: /job-start $te:single/ /job-finish $te:single done/ + + +test WatchHighestTag: + 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 . v3 $cb + git -c user.name=test -c user.email=test tag -a -m . v1 $cc + + local: + spawn on n as p args [ "run", "--rerun-all", "highesttag(v*)" ] + expect from p: + /job-enqueue $tb:single/ + /job-start $tb:single/ + /job-finish $tb:single done/ + expect /(.*)/ from p capture finish + guard (finish == "run-finish") + + local: + spawn on n as p args [ "run", "--rerun-all", "watch(highesttag(v*))" ] killwith SIGINT + expect from p: + /job-enqueue $tb:single/ + /job-start $tb:single/ + /job-finish $tb:single done/ + + shell on n: + git -c user.name=test -c user.email=test tag -a -m . v4 $ca + + 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 $ce + + shell on n: + git -c user.name=test -c user.email=test tag -a -m . v5 $cd + + local: + expect from p /job-enqueue ([0-9a-f]+):single/ capture tid + guard (tid == td) + expect from p: + /job-start $td:single/ + /job-finish $td:single done/ |