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
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''
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue