From c1b4d76e6b9f00e470072a6db1c085608abced8c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Sep 2020 13:55:19 -0400 Subject: [PATCH] make MatchFiles introspectable matchNeedsFileContent is not used yet, but shows how to add information about terminals. That one would be needed for https://git-annex.branchable.com/todo/sync_fast_import/ Note the tricky bit in Annex.FileMatcher.call where it folds over the included matcher to propagate the information. This commit was sponsored by Svenne Krap on Patreon. --- Annex/FileMatcher.hs | 9 +- Command/MatchExpression.hs | 3 +- Limit.hs | 170 ++++++++++++------ Limit/Wanted.hs | 12 +- Types/FileMatcher.hs | 10 +- Utility/Matcher.hs | 6 +- ...rospect_preferred_content_expressions.mdwn | 2 + 7 files changed, 146 insertions(+), 66 deletions(-) diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index 2a265ae46b..f2eef0f59c 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -78,7 +78,7 @@ checkMatcher matcher mkey afile notpresent notconfigured d checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Bool checkMatcher' matcher mi notpresent = - matchMrun matcher $ \a -> a notpresent mi + matchMrun matcher $ \o -> matchAction o notpresent mi fileMatchInfo :: RawFilePath -> Annex MatchInfo fileMatchInfo file = do @@ -264,6 +264,9 @@ usev :: MkLimit Annex -> String -> ParseResult (MatchFiles Annex) usev a v = Operation <$> a v call :: Either String (FileMatcher Annex) -> ParseResult (MatchFiles Annex) -call (Right sub) = Right $ Operation $ \notpresent mi -> - matchMrun sub $ \a -> a notpresent mi +call (Right sub) = Right $ Operation $ MatchFiles + { matchAction = \notpresent mi -> + matchMrun sub $ \o -> matchAction o notpresent mi + , matchNeedsFileContent = any matchNeedsFileContent sub + } call (Left err) = Left err diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs index 1bacca3c6f..b48b822337 100644 --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -91,7 +91,8 @@ seek o = do , liftIO exitFailure ) where - checkmatcher matcher = matchMrun matcher $ \a -> a S.empty (matchinfo o) + checkmatcher matcher = matchMrun matcher $ \op -> + matchAction op S.empty (matchinfo o) bail :: String -> IO a bail s = do diff --git a/Limit.hs b/Limit.hs index 17965f2261..a5c9ada0aa 100644 --- a/Limit.hs +++ b/Limit.hs @@ -51,9 +51,12 @@ limited = (not . Utility.Matcher.isEmpty) <$> getMatcher' {- Gets a matcher for the user-specified limits. The matcher is cached for - speed; once it's obtained the user-specified limits can't change. -} getMatcher :: Annex (MatchInfo -> Annex Bool) -getMatcher = Utility.Matcher.matchM <$> getMatcher' +getMatcher = run <$> getMatcher' + where + run matcher i = Utility.Matcher.matchMrun matcher $ \o -> + matchAction o S.empty i -getMatcher' :: Annex (Utility.Matcher.Matcher (MatchInfo -> Annex Bool)) +getMatcher' :: Annex (Utility.Matcher.Matcher (MatchFiles Annex)) getMatcher' = go =<< Annex.getState Annex.limit where go (CompleteMatcher matcher) = return matcher @@ -64,10 +67,10 @@ getMatcher' = go =<< Annex.getState Annex.limit return matcher {- Adds something to the limit list, which is built up reversed. -} -add :: Utility.Matcher.Token (MatchInfo -> Annex Bool) -> Annex () +add :: Utility.Matcher.Token (MatchFiles Annex) -> Annex () add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s } where - prepend (BuildingMatcher ls) = BuildingMatcher $ l:ls + prepend (BuildingMatcher ls) = BuildingMatcher (l:ls) prepend _ = error "internal" {- Adds a new syntax token. -} @@ -76,21 +79,27 @@ addSyntaxToken = either error add . Utility.Matcher.syntaxToken {- Adds a new limit. -} addLimit :: Either String (MatchFiles Annex) -> Annex () -addLimit = either giveup (\l -> add $ Utility.Matcher.Operation $ l S.empty) +addLimit = either giveup (add . Utility.Matcher.Operation) {- Add a limit to skip files that do not match the glob. -} addInclude :: String -> Annex () addInclude = addLimit . limitInclude limitInclude :: MkLimit Annex -limitInclude glob = Right $ const $ matchGlobFile glob +limitInclude glob = Right $ MatchFiles + { matchAction = const $ matchGlobFile glob + , matchNeedsFileContent = False + } {- Add a limit to skip files that match the glob. -} addExclude :: String -> Annex () addExclude = addLimit . limitExclude limitExclude :: MkLimit Annex -limitExclude glob = Right $ const $ not <$$> matchGlobFile glob +limitExclude glob = Right $ MatchFiles + { matchAction = const $ not <$$> matchGlobFile glob + , matchNeedsFileContent = False + } matchGlobFile :: String -> MatchInfo -> Annex Bool matchGlobFile glob = go @@ -124,7 +133,11 @@ addMagicLimit limitname querymagic selectprovidedinfo glob = do Nothing -> querymagic magic f matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex -matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $ const go +matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = + Right $ MatchFiles + { matchAction = const go + , matchNeedsFileContent = True + } where cglob = compileGlob glob CaseSensative -- memoized go (MatchingKey _ _) = pure False @@ -137,10 +150,16 @@ matchMagic limitname _ _ Nothing _ = Left $ "unable to load magic database; \""++limitname++"\" cannot be used" addUnlocked :: Annex () -addUnlocked = addLimit $ Right $ const $ matchLockStatus False +addUnlocked = addLimit $ Right $ MatchFiles + { matchAction = const $ matchLockStatus False + , matchNeedsFileContent = False + } addLocked :: Annex () -addLocked = addLimit $ Right $ const $ matchLockStatus True +addLocked = addLimit $ Right $ MatchFiles + { matchAction = const $ matchLockStatus True + , matchNeedsFileContent = False + } matchLockStatus :: Bool -> MatchInfo -> Annex Bool matchLockStatus _ (MatchingKey _ _) = pure False @@ -163,7 +182,10 @@ addIn s = do else use (inuuid u) where (name, date) = separate (== '@') s - use a = Right $ checkKey . a + use a = Right $ MatchFiles + { matchAction = checkKey . a + , matchNeedsFileContent = False + } inuuid u notpresent key | null date = do us <- Remote.keyLocations key @@ -181,17 +203,23 @@ addIn s = do {- Limit to content that is currently present on a uuid. -} limitPresent :: Maybe UUID -> MatchFiles Annex -limitPresent u _ = checkKey $ \key -> do - hereu <- getUUID - if u == Just hereu || isNothing u - then inAnnex key - else do - us <- Remote.keyLocations key - return $ maybe False (`elem` us) u +limitPresent u = MatchFiles + { matchAction = const $ checkKey $ \key -> do + hereu <- getUUID + if u == Just hereu || isNothing u + then inAnnex key + else do + us <- Remote.keyLocations key + return $ maybe False (`elem` us) u + , matchNeedsFileContent = False + } {- Limit to content that is in a directory, anywhere in the repository tree -} limitInDir :: FilePath -> MatchFiles Annex -limitInDir dir = const go +limitInDir dir = MatchFiles + { matchAction = const go + , matchNeedsFileContent = False + } where go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi go (MatchingKey _ (AssociatedFile Nothing)) = return False @@ -216,8 +244,11 @@ limitCopies want = case splitc ':' want of where go num good = case readish num of Nothing -> Left "bad number for copies" - Just n -> Right $ \notpresent -> checkKey $ - go' n good notpresent + Just n -> Right $ MatchFiles + { matchAction = \notpresent -> checkKey $ + go' n good notpresent + , matchNeedsFileContent = False + } go' n good notpresent key = do us <- filter (`S.notMember` notpresent) <$> (filterM good =<< Remote.keyLocations key) @@ -234,8 +265,11 @@ addLackingCopies approx = addLimit . limitLackingCopies approx limitLackingCopies :: Bool -> MkLimit Annex limitLackingCopies approx want = case readish want of - Just needed -> Right $ \notpresent mi -> flip checkKey mi $ - go mi needed notpresent + Just needed -> Right $ MatchFiles + { matchAction = \notpresent mi -> flip checkKey mi $ + go mi needed notpresent + , matchNeedsFileContent = False + } Nothing -> Left "bad value for number of lacking copies" where go mi needed notpresent key = do @@ -257,19 +291,30 @@ limitLackingCopies approx want = case readish want of - its key is obviously not unused. -} limitUnused :: MatchFiles Annex -limitUnused _ (MatchingFile _) = return False -limitUnused _ (MatchingKey k _) = S.member k <$> unusedKeys -limitUnused _ (MatchingInfo p) = do - k <- getInfo (providedKey p) - S.member k <$> unusedKeys +limitUnused = MatchFiles + { matchAction = go + , matchNeedsFileContent = False + } + where + go _ (MatchingFile _) = return False + go _ (MatchingKey k _) = S.member k <$> unusedKeys + go _ (MatchingInfo p) = do + k <- getInfo (providedKey p) + S.member k <$> unusedKeys {- Limit that matches any version of any file or key. -} limitAnything :: MatchFiles Annex -limitAnything _ _ = return True +limitAnything = MatchFiles + { matchAction = \_ _ -> return True + , matchNeedsFileContent = False + } {- Limit that never matches. -} limitNothing :: MatchFiles Annex -limitNothing _ _ = return False +limitNothing = MatchFiles + { matchAction = \_ _ -> return False + , matchNeedsFileContent = False + } {- Adds a limit to skip files not believed to be present in all - repositories in the specified group. -} @@ -277,15 +322,18 @@ addInAllGroup :: String -> Annex () addInAllGroup groupname = addLimit $ limitInAllGroup groupMap groupname limitInAllGroup :: Annex GroupMap -> MkLimit Annex -limitInAllGroup getgroupmap groupname = Right $ \notpresent mi -> do - m <- getgroupmap - let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m - if S.null want - then return True - -- optimisation: Check if a wanted uuid is notpresent. - else if not (S.null (S.intersection want notpresent)) - then return False - else checkKey (check want) mi +limitInAllGroup getgroupmap groupname = Right $ MatchFiles + { matchAction = \notpresent mi -> do + m <- getgroupmap + let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m + if S.null want + then return True + -- optimisation: Check if a wanted uuid is notpresent. + else if not (S.null (S.intersection want notpresent)) + then return False + else checkKey (check want) mi + , matchNeedsFileContent = False + } where check want key = do present <- S.fromList <$> Remote.keyLocations key @@ -296,7 +344,10 @@ addInBackend :: String -> Annex () addInBackend = addLimit . limitInBackend limitInBackend :: MkLimit Annex -limitInBackend name = Right $ const $ checkKey check +limitInBackend name = Right $ MatchFiles + { matchAction = const $ checkKey check + , matchNeedsFileContent = False + } where check key = pure $ fromKey keyVariety key == variety variety = parseKeyVariety (encodeBS name) @@ -306,7 +357,10 @@ addSecureHash :: Annex () addSecureHash = addLimit $ Right limitSecureHash limitSecureHash :: MatchFiles Annex -limitSecureHash _ = checkKey isCryptographicallySecure +limitSecureHash = MatchFiles + { matchAction = const $ checkKey isCryptographicallySecure + , matchNeedsFileContent = False + } {- Adds a limit to skip files that are too large or too small -} addLargerThan :: String -> Annex () @@ -318,7 +372,10 @@ addSmallerThan = addLimit . limitSize LimitAnnexFiles (<) limitSize :: LimitBy -> (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex limitSize lb vs s = case readSize dataUnits s of Nothing -> Left "bad size" - Just sz -> Right $ go sz + Just sz -> Right $ MatchFiles + { matchAction = go sz + , matchNeedsFileContent = False + } where go sz _ (MatchingFile fi) = case lb of LimitAnnexFiles -> lookupFileKey fi >>= \case @@ -340,7 +397,10 @@ addMetaData = addLimit . limitMetaData limitMetaData :: MkLimit Annex limitMetaData s = case parseMetaDataMatcher s of Left e -> Left e - Right (f, matching) -> Right $ const $ checkKey (check f matching) + Right (f, matching) -> Right $ MatchFiles + { matchAction = const $ checkKey (check f matching) + , matchNeedsFileContent = False + } where check f matching k = not . S.null . S.filter matching @@ -350,19 +410,25 @@ addTimeLimit :: Duration -> Annex () addTimeLimit duration = do start <- liftIO getPOSIXTime let cutoff = start + durationToPOSIXTime duration - addLimit $ Right $ const $ const $ do - now <- liftIO getPOSIXTime - if now > cutoff - then do - warning $ "Time limit (" ++ fromDuration duration ++ ") reached!" - shutdown True - liftIO $ exitWith $ ExitFailure 101 - else return True + addLimit $ Right $ MatchFiles + { matchAction = const $ const $ do + now <- liftIO getPOSIXTime + if now > cutoff + then do + warning $ "Time limit (" ++ fromDuration duration ++ ") reached!" + shutdown True + liftIO $ exitWith $ ExitFailure 101 + else return True + , matchNeedsFileContent = False + } addAccessedWithin :: Duration -> Annex () addAccessedWithin duration = do now <- liftIO getPOSIXTime - addLimit $ Right $ const $ checkKey $ check now + addLimit $ Right $ MatchFiles + { matchAction = const $ checkKey $ check now + , matchNeedsFileContent = False + } where check now k = inAnnexCheck k $ \f -> liftIO $ catchDefaultIO False $ do diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs index adbcafbfba..2276a3a4ff 100644 --- a/Limit/Wanted.hs +++ b/Limit/Wanted.hs @@ -13,12 +13,16 @@ import Limit import Types.FileMatcher addWantGet :: Annex () -addWantGet = addLimit $ Right $ const $ checkWant $ - wantGet False Nothing +addWantGet = addLimit $ Right $ MatchFiles + { matchAction = const $ checkWant $ wantGet False Nothing + , matchNeedsFileContent = False + } addWantDrop :: Annex () -addWantDrop = addLimit $ Right $ const $ checkWant $ - wantDrop False Nothing Nothing +addWantDrop = addLimit $ Right $ MatchFiles + { matchAction = const $ checkWant $ wantDrop False Nothing Nothing + , matchNeedsFileContent = False + } checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi)) diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs index 114f96774f..8b5558f0e0 100644 --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -55,12 +55,16 @@ type MkLimit a = String -> Either String (MatchFiles a) type AssumeNotPresent = S.Set UUID -type MatchFiles a = AssumeNotPresent -> MatchInfo -> a Bool +data MatchFiles a = MatchFiles + { matchAction :: AssumeNotPresent -> MatchInfo -> a Bool + , matchNeedsFileContent :: Bool + -- ^ does the matchAction need the file content to be present? + } type FileMatcher a = Matcher (MatchFiles a) -- This is a matcher that can have tokens added to it while it's being -- built, and once complete is compiled to an unchangable matcher. data ExpandableMatcher a - = BuildingMatcher [Token (MatchInfo -> a Bool)] - | CompleteMatcher (Matcher (MatchInfo -> a Bool)) + = BuildingMatcher [Token (MatchFiles a)] + | CompleteMatcher (Matcher (MatchFiles a)) diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs index faf53c3e9a..b61565f98a 100644 --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -10,12 +10,12 @@ - Is forgiving about misplaced closing parens, so "foo and (bar or baz" - will be handled, as will "foo and ( bar or baz ) )" - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2020 Joey Hess - - License: BSD-2-clause -} -{-# LANGUAGE Rank2Types, KindSignatures #-} +{-# LANGUAGE Rank2Types, KindSignatures, DeriveFoldable #-} module Utility.Matcher ( Token(..), @@ -43,7 +43,7 @@ data Matcher op = MAny | MOr (Matcher op) (Matcher op) | MNot (Matcher op) | MOp op - deriving (Show, Eq) + deriving (Show, Eq, Foldable) {- Converts a word of syntax into a token. Doesn't handle operations. -} syntaxToken :: String -> Either String (Token op) diff --git a/doc/todo/introspect_preferred_content_expressions.mdwn b/doc/todo/introspect_preferred_content_expressions.mdwn index af13fb1c3c..2d176eef23 100644 --- a/doc/todo/introspect_preferred_content_expressions.mdwn +++ b/doc/todo/introspect_preferred_content_expressions.mdwn @@ -17,3 +17,5 @@ content term it's for. Or, perhaps, not the term, but the specific criteria needed by each such todo. + +> [[done]] --[[Joey]] -- 2.30.2