almost finished with applySimCommand
Added checks that repo names are ones that have been added to the sim. Implemented preferred content etc setting. It does not need to parse the expression in applySimCommand, instead that can be done when running the sim. This keeps it pure. But, it can't be entirely pure because of CommandAddTree. So made it return an Annex action when necessary. Moved makeMatcher into Annex.FileMatcher in preparation for using it, but it's not used yet. Also moved checkPreferredContentExpression.
This commit is contained in:
Joey Hess
parent
710a199ce9
commit
8f8e35ac3b
3 changed files with 157 additions and 125 deletions
|
|
@ -13,10 +13,12 @@ module Annex.FileMatcher (
|
|||
checkFileMatcher',
|
||||
checkMatcher,
|
||||
checkMatcher',
|
||||
makeMatcher,
|
||||
matchAll,
|
||||
PreferredContentData(..),
|
||||
preferredContentTokens,
|
||||
preferredContentParser,
|
||||
checkPreferredContentExpression,
|
||||
ParseToken,
|
||||
parsedToMatcher,
|
||||
mkMatchExpressionParser,
|
||||
|
|
@ -41,6 +43,8 @@ import Annex.SpecialRemote.Config (preferreddirField)
|
|||
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
|
||||
|
|
@ -302,3 +306,56 @@ call desc (Right sub) = Right $ Operation $ MatchFiles
|
|||
, 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
|
||||
}
|
||||
|
|
|
|||
150
Annex/Sim.hs
150
Annex/Sim.hs
|
|
@ -11,13 +11,14 @@ module Annex.Sim where
|
|||
|
||||
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
|
||||
|
||||
|
|
@ -47,9 +48,9 @@ data SimState = SimState
|
|||
, 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
|
||||
|
|
@ -89,11 +90,6 @@ setPresentKey repo k rst = rst
|
|||
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)
|
||||
|
||||
|
|
@ -106,7 +102,7 @@ data SimCommand
|
|||
| CommandUse RepoName String
|
||||
| CommandConnect RepoName RepoName
|
||||
| CommandDisconnect RepoName RepoName
|
||||
| CommandAddTree RepoName Matcher
|
||||
| CommandAddTree RepoName PreferredContentExpression
|
||||
| CommandAdd FilePath ByteSize RepoName
|
||||
| CommandStep Int
|
||||
| CommandSeed Int
|
||||
|
|
@ -115,50 +111,58 @@ data SimCommand
|
|||
| 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 $
|
||||
|
|
@ -170,53 +174,79 @@ applySimCommand (CommandStep n) st
|
|||
| 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)
|
||||
|
|
@ -247,13 +277,11 @@ simUUIDNameSpace = U5.generateNamed U5.namespaceURL $
|
|||
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''
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- 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.
|
||||
-}
|
||||
|
|
@ -25,11 +25,6 @@ module Logs.PreferredContent (
|
|||
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
|
||||
|
|
@ -39,13 +34,15 @@ 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
|
||||
|
||||
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
|
||||
|
|
@ -99,7 +96,8 @@ preferredRequiredMapsLoad' matcherf mktokens = do
|
|||
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
|
||||
|
|
@ -115,46 +113,11 @@ preferredRequiredMapsLoad' matcherf mktokens = do
|
|||
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.
|
||||
-
|
||||
|
|
@ -165,22 +128,6 @@ 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 (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). -}
|
||||
|
|
|
|||
Loading…
Reference in a new issue