--explain for preferred/required content matching

And annex.largefiles and annex.addunlocked.

Also git-annex matchexpression --explain explains why its input
expression matches or fails to match.

When there is no limit, avoid explaining why the lack of limit
matches. This is also done when no preferred content expression is set,
although in a few cases it defaults to a non-empty matcher, which will
be explained.

Sponsored-by: Dartmouth College's DANDI project
This commit is contained in:
Joey Hess 2023-07-26 14:34:21 -04:00
parent ba1c222912
commit 518a51a8a0
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
12 changed files with 89 additions and 60 deletions

View file

@ -1,6 +1,6 @@
{- git-annex file matching
-
- Copyright 2012-2019 Joey Hess <id@joeyh.name>
- Copyright 2012-2023 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -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.
-

View file

@ -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.

View file

@ -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

View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2016 Joey Hess <id@joeyh.name>
- Copyright 2016-2023 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -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

View file

@ -1,6 +1,6 @@
{- git-annex preferred content matcher configuration
-
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
- Copyright 2012-2023 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -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

View file

@ -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

View file

@ -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.

View file

@ -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) =

View file

@ -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