diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index a11ed0be8d..ca3afa6a77 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -1,6 +1,6 @@ {- git-annex file matching - - - Copyright 2012-2019 Joey Hess + - Copyright 2012-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -50,6 +50,7 @@ import Annex.Magic import Data.Either import qualified Data.Set as S +import Control.Monad.Writer type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex) @@ -69,7 +70,7 @@ checkFileMatcher' getmatcher file notconfigured = do checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool checkMatcher matcher mkey afile notpresent notconfigured d - | isEmpty matcher = notconfigured + | isEmpty (fst matcher) = notconfigured | otherwise = case (mkey, afile) of (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file mkey @@ -88,8 +89,13 @@ checkMatcher matcher mkey afile notpresent notconfigured d go mi = checkMatcher' matcher mi notpresent checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Bool -checkMatcher' matcher mi notpresent = - matchMrun matcher $ \o -> matchAction o notpresent mi +checkMatcher' (matcher, (MatcherDesc matcherdesc)) mi notpresent = do + (matches, desc) <- runWriterT $ matchMrun' matcher $ \op -> + matchAction op notpresent mi + explain (mkActionItem mi) $ UnquotedString <$> + describeMatchResult matchDesc desc + ((if matches then "matches " else "does not match ") ++ matcherdesc ++ ": ") + return matches fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo fileMatchInfo file mkey = do @@ -100,12 +106,12 @@ fileMatchInfo file mkey = do , matchKey = mkey } -matchAll :: FileMatcher Annex +matchAll :: Matcher (MatchFiles Annex) matchAll = generate [] -parsedToMatcher :: [ParseResult (MatchFiles Annex)] -> Either String (FileMatcher Annex) -parsedToMatcher parsed = case partitionEithers parsed of - ([], vs) -> Right $ generate vs +parsedToMatcher :: MatcherDesc -> [ParseResult (MatchFiles Annex)] -> Either String (FileMatcher Annex) +parsedToMatcher matcherdesc parsed = case partitionEithers parsed of + ([], vs) -> Right (generate vs, matcherdesc) (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es data ParseToken t @@ -149,8 +155,8 @@ commonKeyedTokens = ] data PreferredContentData = PCD - { matchStandard :: Either String (FileMatcher Annex) - , matchGroupWanted :: Either String (FileMatcher Annex) + { matchStandard :: Either String (Matcher (MatchFiles Annex)) + , matchGroupWanted :: Either String (Matcher (MatchFiles Annex)) , getGroupMap :: Annex GroupMap , configMap :: M.Map UUID RemoteConfig , repoUUID :: Maybe UUID @@ -227,6 +233,7 @@ mkMatchExpressionParser = do largeFilesMatcher :: Annex GetFileMatcher largeFilesMatcher = go =<< getGitConfigVal' annexLargeFiles where + matcherdesc = MatcherDesc "annex.largefiles" go (HasGitConfig (Just expr)) = do matcher <- mkmatcher expr "git config" return $ const $ return matcher @@ -236,34 +243,38 @@ largeFilesMatcher = go =<< getGitConfigVal' annexLargeFiles then case v of HasGlobalConfig (Just expr') -> mkmatcher expr' "git-annex config" - _ -> return matchAll + _ -> return (matchAll, matcherdesc) else mkmatcher expr "gitattributes" mkmatcher expr cfgfrom = do parser <- mkMatchExpressionParser - either (badexpr cfgfrom) return $ parsedToMatcher $ parser expr + either (badexpr cfgfrom) return $ parsedToMatcher matcherdesc $ parser expr + badexpr cfgfrom e = giveup $ "bad annex.largefiles configuration in " ++ cfgfrom ++ ": " ++ e newtype AddUnlockedMatcher = AddUnlockedMatcher (FileMatcher Annex) addUnlockedMatcher :: Annex AddUnlockedMatcher -addUnlockedMatcher = AddUnlockedMatcher <$> +addUnlockedMatcher = AddUnlockedMatcher <$> (go =<< getGitConfigVal' annexAddUnlocked) where go (HasGitConfig (Just expr)) = mkmatcher expr "git config" go (HasGlobalConfig (Just expr)) = mkmatcher expr "git annex config" go _ = matchalways False + matcherdesc = MatcherDesc "annex.addunlocked" + mkmatcher :: String -> String -> Annex (FileMatcher Annex) mkmatcher expr cfgfrom = case Git.Config.isTrueFalse expr of Just b -> matchalways b Nothing -> do parser <- mkMatchExpressionParser - either (badexpr cfgfrom) return $ parsedToMatcher $ parser expr + either (badexpr cfgfrom) return $ parsedToMatcher matcherdesc $ parser expr + badexpr cfgfrom e = giveup $ "bad annex.addunlocked configuration in " ++ cfgfrom ++ ": " ++ e - matchalways True = return $ MOp limitAnything - matchalways False = return $ MOp limitNothing + matchalways True = return (MOp limitAnything, matcherdesc) + matchalways False = return (MOp limitNothing, matcherdesc) checkAddUnlockedMatcher :: AddUnlockedMatcher -> MatchInfo -> Annex Bool checkAddUnlockedMatcher (AddUnlockedMatcher matcher) mi = @@ -275,7 +286,7 @@ simply = Right . Operation usev :: MkLimit Annex -> String -> ParseResult (MatchFiles Annex) usev a v = Operation <$> a v -call :: String -> Either String (FileMatcher Annex) -> ParseResult (MatchFiles Annex) +call :: String -> Either String (Matcher (MatchFiles Annex)) -> ParseResult (MatchFiles Annex) call desc (Right sub) = Right $ Operation $ MatchFiles { matchAction = \notpresent mi -> matchMrun sub $ \o -> matchAction o notpresent mi diff --git a/Annex/Import.hs b/Annex/Import.hs index b42ad9606b..1dbb50d4aa 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -762,7 +762,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec warning (UnquotedString (show e)) return Nothing - importordownload cidmap (loc, (cid, sz)) largematcher= do + importordownload cidmap (loc, (cid, sz)) largematcher = do f <- locworktreefile loc matcher <- largematcher f -- When importing a key is supported, always use it rather @@ -771,7 +771,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec let act = if importcontent then case Remote.importKey ia of Nothing -> dodownload - Just _ -> if Utility.Matcher.introspect matchNeedsFileContent matcher + Just _ -> if Utility.Matcher.introspect matchNeedsFileContent (fst matcher) then dodownload else doimport else doimport @@ -781,7 +781,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec case Remote.importKey ia of Nothing -> error "internal" -- checked earlier Just importkey -> do - when (Utility.Matcher.introspect matchNeedsFileContent matcher) $ + when (Utility.Matcher.introspect matchNeedsFileContent (fst matcher)) $ giveup "annex.largefiles configuration examines file contents, so cannot import without content." let mi = MatchingInfo ProvidedInfo { providedFilePath = Just f @@ -994,14 +994,15 @@ addBackExportExcluded remote importtree = -} makeImportMatcher :: Remote -> Annex (Either String (FileMatcher Annex)) makeImportMatcher r = load preferredContentKeylessTokens >>= \case - Nothing -> return $ Right matchAll - Just (Right v) -> return $ Right v + Nothing -> return $ Right (matchAll, matcherdesc) + Just (Right v) -> return $ Right (v, matcherdesc) Just (Left err) -> load preferredContentTokens >>= \case Just (Left err') -> return $ Left err' _ -> return $ Left $ "The preferred content expression contains terms that cannot be checked when importing: " ++ err where load t = M.lookup (Remote.uuid r) . fst <$> preferredRequiredMapsLoad' t + matcherdesc = MatcherDesc "preferred content" {- Gets the ImportableContents from the remote. - diff --git a/CHANGELOG b/CHANGELOG index d2fcbb21d6..b04e4f2b5b 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,7 +1,9 @@ git-annex (10.20230627) UNRELEASED; urgency=medium * --explain: New option to display explanations of what git-annex - takes into account when deciding what to do. + takes into account when deciding what to do. Including explaining + matching of preferred content expressions, annex.largefiles, and + annex.addunlocked. * satisfy: New command that gets/sends/drops content to satisfy preferred content settings. This is like to the --content part of git-annex sync. diff --git a/Command/Export.hs b/Command/Export.hs index 3739bc95e3..779d300ff9 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -491,8 +491,8 @@ filterExport :: Remote -> Git.Ref -> Annex (ExportFiltered Git.Ref) filterExport r tree = logExportExcluded (uuid r) $ \logwriter -> do m <- preferredContentMap case M.lookup (uuid r) m of - Just matcher | not (isEmpty matcher) -> - ExportFiltered <$> go (Just matcher) logwriter + Just (matcher, matcherdesc) | not (isEmpty matcher) -> + ExportFiltered <$> go (Just (matcher, matcherdesc)) logwriter _ -> ExportFiltered <$> go Nothing logwriter where go mmatcher logwriter = do diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs index 737cc21c9d..7ab0bd4d3a 100644 --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2016 Joey Hess + - Copyright 2016-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,7 +10,6 @@ module Command.MatchExpression where import Command import Annex.FileMatcher import Utility.DataUnits -import Utility.Matcher import Annex.UUID import Logs.Group @@ -84,15 +83,14 @@ seek o = do , configMap = M.empty , repoUUID = Just u } - case parsedToMatcher $ parser ((matchexpr o)) of + case parsedToMatcher (MatcherDesc "provided expression") $ parser ((matchexpr o)) of Left e -> liftIO $ bail $ "bad expression: " ++ e Right matcher -> ifM (checkmatcher matcher) ( liftIO exitSuccess , liftIO exitFailure ) where - checkmatcher matcher = matchMrun matcher $ \op -> - matchAction op S.empty (matchinfo o) + checkmatcher matcher = checkMatcher' matcher (matchinfo o) S.empty bail :: String -> IO a bail s = do diff --git a/Limit.hs b/Limit.hs index 1c70e52267..d11cbf28ac 100644 --- a/Limit.hs +++ b/Limit.hs @@ -65,16 +65,11 @@ getMatcher = run <$> getMatcher' (match, desc) <- runWriterT $ Utility.Matcher.matchMrun' matcher $ \o -> matchAction o S.empty i - explain (getfile i) $ UnquotedString $ unwords - [ if match then "matches:" else "does not match:" - , Utility.Matcher.describeMatchResult matchDesc desc - ] + explain (mkActionItem i) $ UnquotedString <$> + Utility.Matcher.describeMatchResult matchDesc desc + (if match then "matches:" else "does not match:") return match - getfile (MatchingFile f) = Just (matchFile f) - getfile (MatchingInfo p) = providedFilePath p - getfile (MatchingUserInfo _) = Nothing - getMatcher' :: Annex (Utility.Matcher.Matcher (MatchFiles Annex)) getMatcher' = go =<< Annex.getState Annex.limit where diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 1391bde4ce..9d2b30a907 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -1,6 +1,6 @@ {- git-annex preferred content matcher configuration - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -70,7 +70,7 @@ introspectPreferredRequiredContent c mu = do u <- maybe getUUID return mu check u preferredContentMap <||> check u requiredContentMap where - check u mk = mk >>= return . maybe False (any c) . M.lookup u + check u mk = mk >>= return . maybe False (any c . fst) . M.lookup u preferredContentMap :: Annex (FileMatcherMap Annex) preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad preferredContentTokens) return @@ -83,18 +83,18 @@ requiredContentMap = maybe (snd <$> preferredRequiredMapsLoad preferredContentTo preferredRequiredMapsLoad :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (FileMatcherMap Annex, FileMatcherMap Annex) preferredRequiredMapsLoad mktokens = do (pc, rc) <- preferredRequiredMapsLoad' mktokens - let pc' = handleunknown pc - let rc' = handleunknown rc + let pc' = handleunknown (MatcherDesc "preferred content") pc + let rc' = handleunknown (MatcherDesc "required content") rc Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just pc' , Annex.requiredcontentmap = Just rc' } return (pc', rc') where - handleunknown = M.mapWithKey $ \u -> - either (const $ unknownMatcher u) id + handleunknown matcherdesc = M.mapWithKey $ \u v -> + (either (const $ unknownMatcher u) id v, matcherdesc) -preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (FileMatcher Annex)), M.Map UUID (Either String (FileMatcher Annex))) +preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (Matcher (MatchFiles Annex))), M.Map UUID (Either String (Matcher (MatchFiles Annex)))) preferredRequiredMapsLoad' mktokens = do groupmap <- groupMap configmap <- remoteConfigMap @@ -125,12 +125,12 @@ makeMatcher -> UUID -> (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> PreferredContentExpression - -> Either String (FileMatcher Annex) + -> Either String (Matcher (MatchFiles Annex)) makeMatcher groupmap configmap groupwantedmap u mktokens = go True True where go expandstandard expandgroupwanted expr | null (lefts tokens) = Right $ generate $ rights tokens - | otherwise = Left (unwords (lefts tokens)) + | otherwise = Left $ unwords $ lefts tokens where tokens = preferredContentParser (mktokens pcd) expr pcd = PCD @@ -159,16 +159,17 @@ makeMatcher groupmap configmap groupwantedmap u mktokens = go True True - - This avoid unwanted/expensive changes to the content, until the problem - is resolved. -} -unknownMatcher :: UUID -> FileMatcher Annex +unknownMatcher :: UUID -> Matcher (MatchFiles Annex) unknownMatcher u = generate [present] where present = Operation $ limitPresent (Just u) {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: PreferredContentExpression -> Maybe String -checkPreferredContentExpression expr = case parsedToMatcher tokens of - Left e -> Just e - Right _ -> Nothing +checkPreferredContentExpression expr = + case parsedToMatcher (MatcherDesc mempty) tokens of + Left e -> Just e + Right _ -> Nothing where tokens = preferredContentParser (preferredContentTokens pcd) expr pcd = PCD diff --git a/Messages.hs b/Messages.hs index 4930f27588..9559341b70 100644 --- a/Messages.hs +++ b/Messages.hs @@ -300,13 +300,14 @@ jsonOutputEnabled = withMessageState $ \s -> return $ JSONOutput _ -> True _ -> False -explain :: Maybe RawFilePath -> StringContainingQuotedPath -> Annex () -explain Nothing _ = return () -explain (Just f) msg = do +explain :: ActionItem -> Maybe StringContainingQuotedPath -> Annex () +explain ai (Just msg) = do rd <- Annex.getRead id when (Annex.explainenabled rd) $ - outputMessage JSON.none id $ - "[" <> QuotedPath f <> " " <> msg <> "]\n" + let d = actionItemDesc ai + in outputMessage JSON.none id $ + "[" <> (if d == mempty then "" else (d <> " ")) <> msg <> "]\n" +explain _ _ = return () {- Prevents any concurrent console access while running an action, so - that the action is the only thing using the console, and can eg prompt diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs index 052b74a0d6..8ba52b1107 100644 --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -15,6 +15,7 @@ module Types.ActionItem ( import Key import Types.Transfer import Types.UUID +import Types.FileMatcher import Git.FilePath import Git.Quote (StringContainingQuotedPath(..)) import Utility.FileSystemEncoding @@ -60,6 +61,15 @@ instance MkActionItem (BranchFilePath, Key) where instance MkActionItem (Transfer, TransferInfo) where mkActionItem = uncurry ActionItemFailedTransfer +instance MkActionItem MatchInfo where + mkActionItem (MatchingFile i) = ActionItemTreeFile (matchFile i) + mkActionItem (MatchingInfo i) = case providedFilePath i of + Just f -> ActionItemTreeFile f + Nothing -> case providedKey i of + Just k -> ActionItemKey k + Nothing -> ActionItemOther Nothing + mkActionItem (MatchingUserInfo _) = ActionItemOther Nothing + actionItemDesc :: ActionItem -> StringContainingQuotedPath actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = QuotedPath f diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs index b6e06f76d3..e76192488c 100644 --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -76,6 +76,8 @@ getUserInfo :: MonadIO m => UserInfo a -> m a getUserInfo (Right i) = return i getUserInfo (Left e) = liftIO e +newtype MatcherDesc = MatcherDesc String + type FileMatcherMap a = M.Map UUID (FileMatcher a) type MkLimit a = String -> Either String (MatchFiles a) @@ -97,7 +99,7 @@ data MatchFiles a = MatchFiles -- ^ displayed to the user to describe whether it matched or not } -type FileMatcher a = Matcher (MatchFiles a) +type FileMatcher a = (Matcher (MatchFiles a), MatcherDesc) -- This is a matcher that can have tokens added to it while it's being -- built, and once complete is compiled to an unchangeable matcher. diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs index f846c35637..ac9df58e2b 100644 --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -215,9 +215,12 @@ introspect :: (a -> Bool) -> Matcher a -> Bool introspect = any {- Converts a [MatchResult] into a description of what matched and didn't - - match. -} -describeMatchResult :: (op -> Bool -> MatchDesc) -> [MatchResult op] -> String -describeMatchResult descop = unwords . go . simplify True + - match. Returns Nothing when the matcher didn't contain any operations + - and so matched by default. -} +describeMatchResult :: (op -> Bool -> MatchDesc) -> [MatchResult op] -> String -> Maybe String +describeMatchResult _ [] _ = Nothing +describeMatchResult descop l prefix = Just $ + prefix ++ unwords (go $ simplify True l) where go [] = [] go (MatchedOperation b op:rest) = diff --git a/doc/git-annex-matchexpression.mdwn b/doc/git-annex-matchexpression.mdwn index 810f3260d4..0b11bb3fde 100644 --- a/doc/git-annex-matchexpression.mdwn +++ b/doc/git-annex-matchexpression.mdwn @@ -53,6 +53,11 @@ For example, this will exit 0: Tell what the mime encoding of the file is. Only needed when using --largefiles with a mimeencoding= expression. +* `--explain` + + Display explanation of what parts of the preferred content expression + match, and which parts don't match. + * Also the [[git-annex-common-options]](1) can be used. # SEE ALSO