1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
{- git-annex preferred content matcher configuration
-
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Logs.PreferredContent (
preferredContentSet,
requiredContentSet,
groupPreferredContentSet,
isPreferredContent,
isRequiredContent,
preferredContentMap,
preferredContentMapRaw,
requiredContentMap,
requiredContentMapRaw,
groupPreferredContentMapRaw,
checkPreferredContentExpression,
setStandardGroup,
defaultStandardGroup,
preferredRequiredMapsLoad,
preferredRequiredMapsLoad',
introspectPreferredRequiredContent,
prop_standardGroups_parse,
) where
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Either
import qualified Data.Attoparsec.ByteString.Lazy as A
import Annex.Common
import Logs.PreferredContent.Raw
import qualified Annex.Branch
import qualified Annex
import Logs
import Logs.UUIDBased
import Utility.Matcher
import Annex.FileMatcher
import Annex.UUID
import Types.Group
import Types.Remote (RemoteConfig)
import Logs.Group
import Logs.Remote
import Types.StandardGroups
import Limit
{- Checks if a file is preferred content (or required content) for the
- specified repository (or the current repository if none is specified). -}
isPreferredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
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
checkMap getmap mu notpresent mkey afile d = do
u <- maybe getUUID return mu
m <- getmap
case M.lookup u m of
Nothing -> return d
Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d)
{- Checks if the preferred or required content for the specified repository
- (or the current repository if none is specified) contains any terms
- that meet the condition. -}
introspectPreferredRequiredContent :: (MatchFiles Annex -> Bool) -> Maybe UUID -> Annex Bool
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
preferredContentMap :: Annex (FileMatcherMap Annex)
preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad preferredContentTokens) return
=<< Annex.getState Annex.preferredcontentmap
requiredContentMap :: Annex (FileMatcherMap Annex)
requiredContentMap = maybe (snd <$> preferredRequiredMapsLoad preferredContentTokens) return
=<< Annex.getState Annex.requiredcontentmap
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
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
preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (FileMatcher Annex)), M.Map UUID (Either String (FileMatcher Annex)))
preferredRequiredMapsLoad' mktokens = do
groupmap <- groupMap
configmap <- remoteConfigMap
let genmap l gm =
let mk u = makeMatcher groupmap configmap gm u mktokens
in simpleMap
. parseLogOldWithUUID (\u -> mk u . decodeBS <$> A.takeByteString)
<$> Annex.Branch.get l
gm <- groupPreferredContentMapRaw
pc <- genmap preferredContentLog gm
rc <- genmap requiredContentLog gm
-- 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
{- This intentionally never fails, even on unparsable expressions,
- because the configuration is shared among repositories and newer
- versions of git-annex may add new features. -}
makeMatcher
:: GroupMap
-> M.Map UUID RemoteConfig
-> M.Map Group PreferredContentExpression
-> UUID
-> (PreferredContentData -> [ParseToken (MatchFiles Annex)])
-> PreferredContentExpression
-> Either String (FileMatcher 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))
where
tokens = preferredContentParser (mktokens pcd) expr
pcd = PCD
{ matchStandard = matchstandard
, matchGroupWanted = matchgroupwanted
, getGroupMap = pure groupmap
, configMap = configmap
, repoUUID = Just u
}
matchstandard
| expandstandard = maybe (Right $ unknownMatcher u) (go False False)
(standardPreferredContent <$> getStandardGroup mygroups)
| otherwise = Right $ unknownMatcher u
matchgroupwanted
| expandgroupwanted = maybe (Right $ unknownMatcher u) (go True False)
(groupwanted mygroups)
| otherwise = Right $ unknownMatcher u
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
{- 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. -}
unknownMatcher :: UUID -> FileMatcher 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
where
tokens = preferredContentParser (preferredContentTokens pcd) expr
pcd = PCD
{ matchStandard = Right matchAll
, matchGroupWanted = Right matchAll
, getGroupMap = pure emptyGroupMap
, configMap = M.empty
, repoUUID = Nothing
}
{- Puts a UUID in a standard group, and sets its preferred content to use
- the standard expression for that group (unless preferred content is
- already set). -}
setStandardGroup :: UUID -> StandardGroup -> Annex ()
setStandardGroup u g = do
groupSet u $ S.singleton $ fromStandardGroup g
unlessM (isJust . M.lookup u <$> preferredContentMap) $
preferredContentSet u "standard"
{- 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
prop_standardGroups_parse :: Bool
prop_standardGroups_parse =
all (isNothing . checkPreferredContentExpression . standardPreferredContent)
[ minBound .. maxBound]
|
