2012-10-04 19:48:59 +00:00
|
|
|
{- git-annex preferred content matcher configuration
|
|
|
|
-
|
convert old uuid-based log parsers to attoparsec
This preserves the workaround for the old bug that caused NoUUID items
to be stored in the log, prefixing log lines with " ". It's now handled
implicitly, by using takeWhile1 (/= ' ') to get the uuid.
There is a behavior change from the old parser, which split the value
into words and then recombined it. That meant that "foo bar" and "foo\tbar"
came out as "foo bar". That behavior was not documented, and seems
surprising; it meant that after a git-annex describe here "foo bar",
you wouldn't get that same string back out when git-annex displayed repo
descriptions.
Otoh, some other parsers relied on the old behavior, and the attoparsec
rewrites had to deal with the issue themselves...
For group.log, there are some edge cases around the user providing a
group name with a leading or trailing space. The old parser would ignore
such excess whitespace. The new parser does too, because the alternative
is to refuse to parse something like " group1 group2 " due to excess
whitespace, which would be even more confusing behavior.
The only git-annex branch log file that is not converted to attoparsec
and bytestring-builder now is transitions.log.
2019-01-10 18:39:36 +00:00
|
|
|
- Copyright 2012-2019 Joey Hess <id@joeyh.name>
|
2012-10-04 19:48:59 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2012-10-04 19:48:59 +00:00
|
|
|
-}
|
|
|
|
|
|
|
|
module Logs.PreferredContent (
|
|
|
|
preferredContentSet,
|
2014-03-29 19:20:55 +00:00
|
|
|
requiredContentSet,
|
2014-03-15 20:17:01 +00:00
|
|
|
groupPreferredContentSet,
|
2012-10-08 17:16:53 +00:00
|
|
|
isPreferredContent,
|
2014-03-29 19:20:55 +00:00
|
|
|
isRequiredContent,
|
2012-10-04 19:48:59 +00:00
|
|
|
preferredContentMap,
|
|
|
|
preferredContentMapRaw,
|
2014-03-29 19:20:55 +00:00
|
|
|
requiredContentMap,
|
|
|
|
requiredContentMapRaw,
|
2014-03-15 20:17:01 +00:00
|
|
|
groupPreferredContentMapRaw,
|
2012-10-04 19:48:59 +00:00
|
|
|
checkPreferredContentExpression,
|
2012-10-10 19:35:10 +00:00
|
|
|
setStandardGroup,
|
2014-05-30 18:03:04 +00:00
|
|
|
defaultStandardGroup,
|
2014-03-29 19:20:55 +00:00
|
|
|
preferredRequiredMapsLoad,
|
2019-05-21 18:38:00 +00:00
|
|
|
preferredRequiredMapsLoad',
|
2015-06-17 17:44:19 +00:00
|
|
|
prop_standardGroups_parse,
|
2012-10-04 19:48:59 +00:00
|
|
|
) where
|
|
|
|
|
|
|
|
import qualified Data.Map as M
|
2012-10-10 17:52:24 +00:00
|
|
|
import qualified Data.Set as S
|
2012-10-04 19:48:59 +00:00
|
|
|
import Data.Either
|
convert old uuid-based log parsers to attoparsec
This preserves the workaround for the old bug that caused NoUUID items
to be stored in the log, prefixing log lines with " ". It's now handled
implicitly, by using takeWhile1 (/= ' ') to get the uuid.
There is a behavior change from the old parser, which split the value
into words and then recombined it. That meant that "foo bar" and "foo\tbar"
came out as "foo bar". That behavior was not documented, and seems
surprising; it meant that after a git-annex describe here "foo bar",
you wouldn't get that same string back out when git-annex displayed repo
descriptions.
Otoh, some other parsers relied on the old behavior, and the attoparsec
rewrites had to deal with the issue themselves...
For group.log, there are some edge cases around the user providing a
group name with a leading or trailing space. The old parser would ignore
such excess whitespace. The new parser does too, because the alternative
is to refuse to parse something like " group1 group2 " due to excess
whitespace, which would be even more confusing behavior.
The only git-annex branch log file that is not converted to attoparsec
and bytestring-builder now is transitions.log.
2019-01-10 18:39:36 +00:00
|
|
|
import qualified Data.Attoparsec.ByteString.Lazy as A
|
2012-10-04 19:48:59 +00:00
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
2014-01-02 00:12:20 +00:00
|
|
|
import Logs.PreferredContent.Raw
|
2012-10-04 19:48:59 +00:00
|
|
|
import qualified Annex.Branch
|
|
|
|
import qualified Annex
|
2013-08-29 22:51:22 +00:00
|
|
|
import Logs
|
2012-10-04 19:48:59 +00:00
|
|
|
import Logs.UUIDBased
|
2019-05-14 17:08:51 +00:00
|
|
|
import Utility.Matcher
|
2013-03-29 20:17:13 +00:00
|
|
|
import Annex.FileMatcher
|
2012-10-08 17:16:53 +00:00
|
|
|
import Annex.UUID
|
2012-10-08 19:18:58 +00:00
|
|
|
import Types.Group
|
2013-04-26 03:44:55 +00:00
|
|
|
import Types.Remote (RemoteConfig)
|
2012-10-08 19:18:58 +00:00
|
|
|
import Logs.Group
|
2013-04-26 03:44:55 +00:00
|
|
|
import Logs.Remote
|
2012-10-10 20:04:28 +00:00
|
|
|
import Types.StandardGroups
|
2014-03-20 04:10:12 +00:00
|
|
|
import Limit
|
2012-10-04 19:48:59 +00:00
|
|
|
|
2012-10-08 17:16:53 +00:00
|
|
|
{- Checks if a file is preferred content for the specified repository
|
|
|
|
- (or the current repository if none is specified). -}
|
2014-01-23 20:37:08 +00:00
|
|
|
isPreferredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
|
2014-03-29 19:20:55 +00:00
|
|
|
isPreferredContent = checkMap preferredContentMap
|
|
|
|
|
|
|
|
isRequiredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
|
|
|
|
isRequiredContent = checkMap requiredContentMap
|
|
|
|
|
|
|
|
checkMap :: Annex (FileMatcherMap Annex) -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
|
2015-01-28 20:11:28 +00:00
|
|
|
checkMap getmap mu notpresent mkey afile d = do
|
2012-10-08 17:16:53 +00:00
|
|
|
u <- maybe getUUID return mu
|
2014-03-29 19:20:55 +00:00
|
|
|
m <- getmap
|
2012-10-08 17:16:53 +00:00
|
|
|
case M.lookup u m of
|
2015-10-06 21:28:20 +00:00
|
|
|
Nothing -> return d
|
2018-08-27 18:47:17 +00:00
|
|
|
Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d)
|
2012-10-08 17:16:53 +00:00
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
preferredContentMap :: Annex (FileMatcherMap Annex)
|
2019-05-14 18:01:09 +00:00
|
|
|
preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad preferredContentTokens) return
|
add ConfigMonitor thread
Monitors git-annex branch for changes, which are noticed by the Merger
thread whenever the branch ref is changed (either due to an incoming push,
or a local change), and refreshes cached config values for modified config
files.
Rate limited to run no more often than once per minute. This is important
because frequent git-annex branch changes happen when files are being
added, or transferred, etc.
A primary use case is that, when preferred content changes are made,
and get pushed to remotes, the remotes start honoring those settings.
Other use cases include propigating repository description and trust
changes to remotes, and learning when a remote has added a new special
remote, so the webapp can present the GUI to enable that special remote
locally.
Also added a uuid.log cache. All other config files already had caches.
2012-10-20 20:37:06 +00:00
|
|
|
=<< Annex.getState Annex.preferredcontentmap
|
|
|
|
|
2014-03-29 19:20:55 +00:00
|
|
|
requiredContentMap :: Annex (FileMatcherMap Annex)
|
2019-05-14 18:01:09 +00:00
|
|
|
requiredContentMap = maybe (snd <$> preferredRequiredMapsLoad preferredContentTokens) return
|
2014-03-29 19:20:55 +00:00
|
|
|
=<< Annex.getState Annex.requiredcontentmap
|
|
|
|
|
2019-05-14 18:01:09 +00:00
|
|
|
preferredRequiredMapsLoad :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (FileMatcherMap Annex, FileMatcherMap Annex)
|
|
|
|
preferredRequiredMapsLoad mktokens = do
|
2019-05-21 18:38:00 +00:00
|
|
|
(pc, rc) <- preferredRequiredMapsLoad' mktokens
|
|
|
|
let pc' = handleunknown pc
|
|
|
|
let rc' = handleunknown rc
|
|
|
|
Annex.changeState $ \s -> s
|
|
|
|
{ Annex.preferredcontentmap = Just pc'
|
|
|
|
, Annex.requiredcontentmap = Just rc'
|
|
|
|
}
|
|
|
|
return (pc', rc')
|
|
|
|
where
|
2019-05-23 16:44:27 +00:00
|
|
|
handleunknown = M.mapWithKey $ \u ->
|
|
|
|
either (const $ unknownMatcher u) id
|
2019-05-21 18:38:00 +00:00
|
|
|
|
|
|
|
preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (FileMatcher Annex)), M.Map UUID (Either String (FileMatcher Annex)))
|
|
|
|
preferredRequiredMapsLoad' mktokens = do
|
2012-10-08 19:18:58 +00:00
|
|
|
groupmap <- groupMap
|
2013-04-26 03:44:55 +00:00
|
|
|
configmap <- readRemoteLog
|
2019-05-14 18:59:03 +00:00
|
|
|
let genmap l gm =
|
2019-05-21 18:38:00 +00:00
|
|
|
let mk u = makeMatcher groupmap configmap gm u mktokens
|
2019-05-14 18:59:03 +00:00
|
|
|
in simpleMap
|
|
|
|
. parseLogOldWithUUID (\u -> mk u . decodeBS <$> A.takeByteString)
|
|
|
|
<$> Annex.Branch.get l
|
2020-04-28 17:31:26 +00:00
|
|
|
gm <- groupPreferredContentMapRaw
|
|
|
|
pc <- genmap preferredContentLog gm
|
|
|
|
rc <- genmap requiredContentLog gm
|
2019-05-21 18:38:00 +00:00
|
|
|
-- Required content is implicitly also preferred content, so combine.
|
|
|
|
let pc' = M.unionWith combiner pc rc
|
|
|
|
return (pc', rc)
|
|
|
|
where
|
|
|
|
combiner (Right a) (Right b) = Right (combineMatchers a b)
|
|
|
|
combiner (Left a) (Left b) = Left (a ++ " " ++ b)
|
|
|
|
combiner (Left a) (Right _) = Left a
|
|
|
|
combiner (Right _) (Left b) = Left b
|
2012-10-04 19:48:59 +00:00
|
|
|
|
|
|
|
{- This intentionally never fails, even on unparsable expressions,
|
2013-12-19 09:57:50 +00:00
|
|
|
- because the configuration is shared among repositories and newer
|
2014-03-20 04:10:12 +00:00
|
|
|
- versions of git-annex may add new features. -}
|
|
|
|
makeMatcher
|
|
|
|
:: GroupMap
|
|
|
|
-> M.Map UUID RemoteConfig
|
|
|
|
-> M.Map Group PreferredContentExpression
|
|
|
|
-> UUID
|
2019-05-14 18:01:09 +00:00
|
|
|
-> (PreferredContentData -> [ParseToken (MatchFiles Annex)])
|
2014-03-20 04:10:12 +00:00
|
|
|
-> PreferredContentExpression
|
2019-05-14 18:59:03 +00:00
|
|
|
-> Either String (FileMatcher Annex)
|
2019-05-14 18:01:09 +00:00
|
|
|
makeMatcher groupmap configmap groupwantedmap u mktokens = go True True
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
2014-03-15 21:08:55 +00:00
|
|
|
go expandstandard expandgroupwanted expr
|
2019-05-14 18:59:03 +00:00
|
|
|
| null (lefts tokens) = Right $ generate $ rights tokens
|
|
|
|
| otherwise = Left (unwords (lefts tokens))
|
2014-03-14 19:04:33 +00:00
|
|
|
where
|
2019-05-14 18:01:09 +00:00
|
|
|
tokens = preferredContentParser (mktokens pcd) expr
|
|
|
|
pcd = PCD
|
|
|
|
{ matchStandard = matchstandard
|
|
|
|
, matchGroupWanted = matchgroupwanted
|
|
|
|
, getGroupMap = pure groupmap
|
|
|
|
, configMap = configmap
|
|
|
|
, repoUUID = Just u
|
|
|
|
}
|
2014-03-14 19:04:33 +00:00
|
|
|
matchstandard
|
2019-05-14 18:59:03 +00:00
|
|
|
| expandstandard = maybe (Right $ unknownMatcher u) (go False False)
|
2014-03-15 21:08:55 +00:00
|
|
|
(standardPreferredContent <$> getStandardGroup mygroups)
|
2019-05-14 18:59:03 +00:00
|
|
|
| otherwise = Right $ unknownMatcher u
|
2014-03-15 21:08:55 +00:00
|
|
|
matchgroupwanted
|
2019-05-14 18:59:03 +00:00
|
|
|
| expandgroupwanted = maybe (Right $ unknownMatcher u) (go True False)
|
2014-03-15 21:08:55 +00:00
|
|
|
(groupwanted mygroups)
|
2019-05-14 18:59:03 +00:00
|
|
|
| otherwise = Right $ unknownMatcher u
|
2014-03-15 21:08:55 +00:00
|
|
|
mygroups = fromMaybe S.empty (u `M.lookup` groupsByUUID groupmap)
|
|
|
|
groupwanted s = case M.elems $ M.filterWithKey (\k _ -> S.member k s) groupwantedmap of
|
|
|
|
[pc] -> Just pc
|
|
|
|
_ -> Nothing
|
2012-10-10 19:15:56 +00:00
|
|
|
|
2014-03-20 04:10:12 +00:00
|
|
|
{- When a preferred content expression cannot be parsed, but is already
|
|
|
|
- in the log (eg, put there by a newer version of git-annex),
|
|
|
|
- the fallback behavior is to match only files that are currently present.
|
|
|
|
-
|
|
|
|
- This avoid unwanted/expensive changes to the content, until the problem
|
|
|
|
- is resolved. -}
|
2014-03-29 18:43:34 +00:00
|
|
|
unknownMatcher :: UUID -> FileMatcher Annex
|
|
|
|
unknownMatcher u = generate [present]
|
2014-03-20 04:10:12 +00:00
|
|
|
where
|
2016-02-03 17:23:34 +00:00
|
|
|
present = Operation $ limitPresent (Just u)
|
2014-03-20 04:10:12 +00:00
|
|
|
|
2012-10-04 19:48:59 +00:00
|
|
|
{- Checks if an expression can be parsed, if not returns Just error -}
|
2014-01-01 23:58:02 +00:00
|
|
|
checkPreferredContentExpression :: PreferredContentExpression -> Maybe String
|
2014-03-14 19:04:33 +00:00
|
|
|
checkPreferredContentExpression expr = case parsedToMatcher tokens of
|
|
|
|
Left e -> Just e
|
|
|
|
Right _ -> Nothing
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
2019-05-14 18:01:09 +00:00
|
|
|
tokens = preferredContentParser (preferredContentTokens pcd) expr
|
|
|
|
pcd = PCD
|
2019-05-14 18:59:03 +00:00
|
|
|
{ matchStandard = Right matchAll
|
|
|
|
, matchGroupWanted = Right matchAll
|
2019-05-14 18:01:09 +00:00
|
|
|
, getGroupMap = pure emptyGroupMap
|
|
|
|
, configMap = M.empty
|
|
|
|
, repoUUID = Nothing
|
|
|
|
}
|
2012-10-10 19:35:10 +00:00
|
|
|
|
|
|
|
{- Puts a UUID in a standard group, and sets its preferred content to use
|
2014-05-30 18:03:04 +00:00
|
|
|
- the standard expression for that group (unless preferred content is
|
|
|
|
- already set). -}
|
2012-10-10 19:35:10 +00:00
|
|
|
setStandardGroup :: UUID -> StandardGroup -> Annex ()
|
|
|
|
setStandardGroup u g = do
|
|
|
|
groupSet u $ S.singleton $ fromStandardGroup g
|
2014-05-30 18:03:04 +00:00
|
|
|
unlessM (isJust . M.lookup u <$> preferredContentMap) $
|
2012-10-10 19:35:10 +00:00
|
|
|
preferredContentSet u "standard"
|
2014-05-30 18:03:04 +00:00
|
|
|
|
|
|
|
{- Avoids overwriting the UUID's standard group or preferred content
|
|
|
|
- when it's already been configured. -}
|
|
|
|
defaultStandardGroup :: UUID -> StandardGroup -> Annex ()
|
|
|
|
defaultStandardGroup u g =
|
|
|
|
unlessM (hasgroup <||> haspc) $
|
|
|
|
setStandardGroup u g
|
|
|
|
where
|
|
|
|
hasgroup = not . S.null <$> lookupGroups u
|
|
|
|
haspc = isJust . M.lookup u <$> preferredContentMap
|
2015-06-17 17:44:19 +00:00
|
|
|
|
|
|
|
prop_standardGroups_parse :: Bool
|
|
|
|
prop_standardGroups_parse =
|
|
|
|
all (isNothing . checkPreferredContentExpression . standardPreferredContent)
|
|
|
|
[ minBound .. maxBound]
|