checkFileMatcher',
checkMatcher,
checkMatcher',
+ makeMatcher,
matchAll,
PreferredContentData(..),
preferredContentTokens,
preferredContentParser,
+ checkPreferredContentExpression,
ParseToken,
parsedToMatcher,
mkMatchExpressionParser,
import Git.FilePath
import Types.Remote (RemoteConfig)
import Types.ProposedAccepted
+import Types.StandardGroups
+import Logs.Group
import Annex.CheckAttr
import Annex.RepoSize.LiveUpdate
import qualified Git.Config
, matchDesc = matchDescSimple desc
}
call _ (Left err) = Left err
+
+makeMatcher
+ :: GroupMap
+ -> M.Map UUID RemoteConfig
+ -> M.Map Group PreferredContentExpression
+ -> UUID
+ -> (Matcher (MatchFiles Annex) -> Matcher (MatchFiles Annex))
+ -> (PreferredContentData -> [ParseToken (MatchFiles Annex)])
+ -> Either String (Matcher (MatchFiles Annex))
+ -> PreferredContentExpression
+ -> Either String (Matcher (MatchFiles Annex))
+makeMatcher groupmap configmap groupwantedmap u matcherf mktokens unknownmatcher = go True True
+ where
+ go expandstandard expandgroupwanted expr
+ | null (lefts tokens) = Right $ matcherf $ 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 unknownmatcher (go False False)
+ (standardPreferredContent <$> getStandardGroup mygroups)
+ | otherwise = unknownmatcher
+ matchgroupwanted
+ | expandgroupwanted = maybe unknownmatcher (go True False)
+ (groupwanted mygroups)
+ | otherwise = unknownmatcher
+ 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
+
+{- Checks if an expression can be parsed, if not returns Just error -}
+checkPreferredContentExpression :: PreferredContentExpression -> Maybe String
+checkPreferredContentExpression expr =
+ case parsedToMatcher (MatcherDesc mempty) 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
+ }
import Utility.DataUnits
import Types.NumCopies
-import Types.FileMatcher
import Types.RepoSize
import Types.Key
import Types.UUID
+import Types.StandardGroups
import Annex (Annex)
import Backend.Hash (genTestKey)
import Annex.UUID
+import Annex.FileMatcher
import Utility.FileSystemEncoding
import qualified Remote
, simRng :: StdGen
, simNumCopies :: NumCopies
, simGroups :: M.Map RepoName (S.Set GroupName)
- , simWanted :: M.Map RepoName Matcher
- , simRequired :: M.Map RepoName Matcher
- , simGroupWanted :: M.Map GroupName Matcher
+ , simWanted :: M.Map RepoName PreferredContentExpression
+ , simRequired :: M.Map RepoName PreferredContentExpression
+ , simGroupWanted :: M.Map GroupName PreferredContentExpression
, simMaxSize :: M.Map RepoName MaxSize
, simRebalance :: Bool
, simExistingRepoByName :: ExistingRepoByName
M.insertWith S.union k (S.singleton repo) (simLocations rst)
}
-data Matcher = Matcher String (FileMatcher Annex)
-
-instance Show Matcher where
- show (Matcher s _) = s
-
newtype RepoName = RepoName { fromRepoName :: String }
deriving (Show, Eq, Ord)
| CommandUse RepoName String
| CommandConnect RepoName RepoName
| CommandDisconnect RepoName RepoName
- | CommandAddTree RepoName Matcher
+ | CommandAddTree RepoName PreferredContentExpression
| CommandAdd FilePath ByteSize RepoName
| CommandStep Int
| CommandSeed Int
| CommandNumCopies Int
| CommandGroup RepoName GroupName
| CommandUngroup RepoName GroupName
- | CommandWanted RepoName String
- | CommandRequired RepoName String
- | CommandGroupWanted GroupName String
+ | CommandWanted RepoName PreferredContentExpression
+ | CommandRequired RepoName PreferredContentExpression
+ | CommandGroupWanted GroupName PreferredContentExpression
| CommandMaxSize RepoName MaxSize
| CommandRebalance Bool
deriving (Show)
-applySimCommand :: SimCommand -> SimState -> Either String SimState
+applySimCommand
+ :: SimCommand
+ -> SimState
+ -> Either String (Either (Annex SimState) SimState)
applySimCommand (CommandInit reponame) st =
let (u, st') = genSimUUID st reponame
- in Right $ st'
+ in Right $ Right $ st'
{ simRepos = M.insert reponame u (simRepos st')
}
applySimCommand (CommandInitRemote reponame) st =
let (u, st') = genSimUUID st reponame
- in Right $ st'
+ in Right $ Right $ st'
{ simSpecialRemotes = M.insert reponame u (simSpecialRemotes st')
}
applySimCommand (CommandUse reponame s) st =
- case existingRepoByName (simExistingRepoByName st) reponame of
- (u:[], _) -> Right $ st
+ case existingRepoByName (simExistingRepoByName st) s of
+ (u:[], _) -> Right $ Right $ st
{ simSpecialRemotes = M.insert reponame u (simSpecialRemotes st)
}
(_, msg) -> Left $ "Unable to use a repository \""
++ fromRepoName reponame
++ "\" in the simulation because " ++ msg
-applySimCommand (CommandConnect repo remote) st = Right $ st
- { simConnections =
- let s = case M.lookup repo (simConnections st) of
- Just s -> S.insert remote s
- Nothing -> S.singleton remote
- in M.insert repo s (simConnections st)
- }
-applySimCommand (CommandDisconnect repo remote) st = Right $ st
- { simConnections =
- let sc = case M.lookup repo (simConnections st) of
- Just s -> S.delete remote s
- Nothing -> S.empty
- in M.insert repo sc (simConnections st)
- }
-applySimCommand (CommandAddTree repo matcher) st = error "TODO" -- XXX
-applySimCommand (CommandAdd file sz repo) st =
+applySimCommand (CommandConnect repo remote) st =
+ checkKnownRepo repo st $ checkKnownRepo remote st $ Right $ Right $ st
+ { simConnections =
+ let s = case M.lookup repo (simConnections st) of
+ Just cs -> S.insert remote cs
+ Nothing -> S.singleton remote
+ in M.insert repo s (simConnections st)
+ }
+applySimCommand (CommandDisconnect repo remote) st =
+ checkKnownRepo repo st $ checkKnownRepo remote st $ Right $ Right $ st
+ { simConnections =
+ let sc = case M.lookup repo (simConnections st) of
+ Just s -> S.delete remote s
+ Nothing -> S.empty
+ in M.insert repo sc (simConnections st)
+ }
+applySimCommand (CommandAddTree repo expr) st =
+ checkKnownRepo repo st $
+ checkValidPreferredContentExpression expr $ Left $
+ error "TODO" -- XXX
+applySimCommand (CommandAdd file sz repo) st = checkKnownRepo repo st $
let (k, st') = genSimKey sz st
- in Right $ st'
+ in Right $ Right $ st'
{ simFiles = M.insert file k (simFiles st')
, simRepoState =
let rst = fromMaybe emptySimRepoState $
| n > 0 = applySimCommand
(CommandStep (pred n))
(fst $ stepSimulation st)
- | otherwise = Right st
-applySimCommand (CommandSeed rngseed) st = Right $ st
+ | otherwise = Right $ Right st
+applySimCommand (CommandSeed rngseed) st = Right $ Right $ st
{ simRng = mkStdGen rngseed
}
-applySimCommand (CommandPresent repo file) st =
+applySimCommand (CommandPresent repo file) st = checkKnownRepo repo st $
case (M.lookup file (simFiles st), M.lookup repo (simRepoState st)) of
(Just k, Just rst) -> case M.lookup k (simLocations rst) of
- Just locs | S.member repo locs -> Right st
+ Just locs | S.member repo locs -> Right $ Right st
_ -> missing
- (Just k, Nothing) -> missing
+ (Just _, Nothing) -> missing
(Nothing, _) -> Left $ "Expected " ++ file
++ " to be present in " ++ fromRepoName repo
++ ", but the simulation does not include that file."
where
missing = Left $ "Expected " ++ file ++ " to be present in "
++ fromRepoName repo ++ ", but it is not."
-applySimCommand (CommandNotPresent repo file) st =
+applySimCommand (CommandNotPresent repo file) st = checkKnownRepo repo st $
case (M.lookup file (simFiles st), M.lookup repo (simRepoState st)) of
(Just k, Just rst) -> case M.lookup k (simLocations rst) of
- Just locs | S.notMember repo locs -> Right st
+ Just locs | S.notMember repo locs -> Right $ Right st
_ -> present
- (Just k, Nothing) -> present
+ (Just _, Nothing) -> present
(Nothing, _) -> Left $ "Expected " ++ file
++ " to not be present in " ++ fromRepoName repo
++ ", but the simulation does not include that file."
where
present = Left $ "Expected " ++ file ++ " not to be present in "
++ fromRepoName repo ++ ", but it is present."
-applySimCommand (CommandNumCopies n) st = Right $ st
+applySimCommand (CommandNumCopies n) st = Right $ Right $ st
{ simNumCopies = configuredNumCopies n
}
-applySimCommand (CommandGroup repo group) st = Right $ st
- { simGroups = M.insertWith S.union repo (S.singleton group) (simGroups st)
- }
-applySimCommand (CommandUngroup repo group) st = Right $ st
- { simGroups = M.adjust (S.delete group) repo (simGroups st)
- }
-applySimCommand (CommandWanted repo expr) st = undefined -- XXX
-applySimCommand (CommandRequired repo expr) st = undefined -- XXX
-applySimCommand (CommandGroupWanted group expr) st = undefined -- XXX
-applySimCommand (CommandMaxSize repo sz) st = Right $ st
- { simMaxSize = M.insert repo sz (simMaxSize st)
- }
-applySimCommand (CommandRebalance b) st = Right $ st
+applySimCommand (CommandGroup repo group) st = checkKnownRepo repo st $
+ Right $ Right $ st
+ { simGroups = M.insertWith S.union repo
+ (S.singleton group)
+ (simGroups st)
+ }
+applySimCommand (CommandUngroup repo group) st = checkKnownRepo repo st $
+ Right $ Right $ st
+ { simGroups = M.adjust (S.delete group) repo (simGroups st)
+ }
+applySimCommand (CommandWanted repo expr) st = checkKnownRepo repo st $
+ checkValidPreferredContentExpression expr $ Right $ st
+ { simWanted = M.insert repo expr (simWanted st)
+ }
+applySimCommand (CommandRequired repo expr) st = checkKnownRepo repo st $
+ checkValidPreferredContentExpression expr $ Right $ st
+ { simRequired = M.insert repo expr (simRequired st)
+ }
+applySimCommand (CommandGroupWanted group expr) st =
+ checkValidPreferredContentExpression expr $ Right $ st
+ { simGroupWanted = M.insert group expr (simGroupWanted st)
+ }
+applySimCommand (CommandMaxSize repo sz) st = checkKnownRepo repo st $
+ Right $ Right $ st
+ { simMaxSize = M.insert repo sz (simMaxSize st)
+ }
+applySimCommand (CommandRebalance b) st = Right $ Right $ st
{ simRebalance = b
}
+checkKnownRepo :: RepoName -> SimState -> Either String a -> Either String a
+checkKnownRepo reponame st a = case M.lookup reponame (simRepos st) of
+ Just _ -> a
+ Nothing -> Left $ "No repository in the simulation is named \""
+ ++ fromRepoName reponame ++ "\"."
+
+checkValidPreferredContentExpression :: PreferredContentExpression -> v -> Either String v
+checkValidPreferredContentExpression expr v =
+ case checkPreferredContentExpression expr of
+ Nothing -> Right v
+ Just e -> Left $ "Failed parsing \"" ++ expr ++ "\": " ++ e
+
simRandom :: SimState -> (StdGen -> (v, StdGen)) -> (v -> r) -> (r, SimState)
simRandom st mk f =
let (v, rng) = mk (simRng st)
B.unpack "http://git-annex.branchable.com/git-annex-sim/"
newtype ExistingRepoByName = ExistingRepoByName
- { existingRepoByName :: RepoName -> ([UUID], String)
+ { existingRepoByName :: String -> ([UUID], String)
}
instance Show ExistingRepoByName where
show _ = "ExistingRepoByName"
mkExistingRepoByName :: Annex ExistingRepoByName
-mkExistingRepoByName = do
- f <- Remote.nameToUUID''
- return $ ExistingRepoByName $ f . fromRepoName
+mkExistingRepoByName = ExistingRepoByName <$> Remote.nameToUUID''
{- git-annex preferred content matcher configuration
-
- - Copyright 2012-2023 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
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 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
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified Data.Attoparsec.ByteString.Lazy as A
+
{- Checks if a file is preferred content (or required content) for the
- specified repository (or the current repository if none is specified). -}
isPreferredContent :: LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
groupmap <- groupMap
configmap <- remoteConfigMap
let genmap l gm =
- let mk u = makeMatcher groupmap configmap gm u matcherf mktokens
+ let mk u = makeMatcher groupmap configmap
+ gm u matcherf mktokens (Right (unknownMatcher u))
in simpleMap
. parseLogOldWithUUID (\u -> mk u . decodeBS <$> A.takeByteString)
<$> Annex.Branch.get l
combiner (Left a) (Right _) = Left a
combiner (Right _) (Left b) = Left b
-{- This intentionally never fails, even on unparsable expressions,
+{- Parsing preferred content expressions intentionally never fails,
- 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
- -> (Matcher (MatchFiles Annex) -> Matcher (MatchFiles Annex))
- -> (PreferredContentData -> [ParseToken (MatchFiles Annex)])
- -> PreferredContentExpression
- -> Either String (Matcher (MatchFiles Annex))
-makeMatcher groupmap configmap groupwantedmap u matcherf mktokens = go True True
- where
- go expandstandard expandgroupwanted expr
- | null (lefts tokens) = Right $ matcherf $ 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
+ - versions of git-annex may add new features.
+ -
+ - 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.
-
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 (MatcherDesc mempty) 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). -}
projects / git-annex.git / commitdiff