diff --git a/Annex/Sim.hs b/Annex/Sim.hs index 00742adb2b..6ac44e6664 100644 --- a/Annex/Sim.hs +++ b/Annex/Sim.hs @@ -19,6 +19,7 @@ import Annex (Annex) import Backend.Hash (genTestKey) import Annex.UUID import Utility.FileSystemEncoding +import qualified Remote import System.Random import Data.Word @@ -51,11 +52,12 @@ data SimState = SimState , simGroupWanted :: M.Map GroupName Matcher , simMaxSize :: M.Map RepoName MaxSize , simRebalance :: Bool + , simExistingRepoByName :: ExistingRepoByName } deriving (Show) -emptySimState :: Int -> SimState -emptySimState rngseed = SimState +emptySimState :: Int -> ExistingRepoByName -> SimState +emptySimState rngseed repobyname = SimState { simRepos = mempty , simSpecialRemotes = mempty , simRepoState = mempty @@ -69,6 +71,7 @@ emptySimState rngseed = SimState , simGroupWanted = mempty , simMaxSize = mempty , simRebalance = False + , simExistingRepoByName = repobyname } -- State that can vary between different repos in the simulation. @@ -130,7 +133,14 @@ applySimCommand (CommandInitRemote reponame) st = in Right $ st' { simSpecialRemotes = M.insert reponame u (simSpecialRemotes st') } -applySimCommand (CommandUse reponame s) st = error "TODO" -- XXX +applySimCommand (CommandUse reponame s) st = + case existingRepoByName (simExistingRepoByName st) reponame of + (u:[], _) -> 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 @@ -235,3 +245,15 @@ genSimUUID st (RepoName reponame) = simRandom st (randomWords 1024) simUUIDNameSpace :: U.UUID simUUIDNameSpace = U5.generateNamed U5.namespaceURL $ B.unpack "http://git-annex.branchable.com/git-annex-sim/" + +newtype ExistingRepoByName = ExistingRepoByName + { existingRepoByName :: RepoName -> ([UUID], String) + } + +instance Show ExistingRepoByName where + show _ = "ExistingRepoByName" + +mkExistingRepoByName :: Annex ExistingRepoByName +mkExistingRepoByName = do + f <- Remote.nameToUUID'' + return $ ExistingRepoByName $ f . fromRepoName diff --git a/Remote.hs b/Remote.hs index 9e41f8ae83..0f19d7a880 100644 --- a/Remote.hs +++ b/Remote.hs @@ -52,6 +52,7 @@ module Remote ( remoteLocations, nameToUUID, nameToUUID', + nameToUUID'', showTriedRemotes, listRemoteNames, showLocations, @@ -148,8 +149,11 @@ byNameWithUUID = checkuuid <=< byName | otherwise = return $ Just r byName' :: RemoteName -> Annex (Either String Remote) -byName' "" = return $ Left "no repository name specified" -byName' n = go . filter matching <$> remoteList +byName' n = byName'' n <$> remoteList + +byName'' :: RemoteName -> [Remote] -> Either String Remote +byName'' "" _ = Left "no repository name specified" +byName'' n remotelist = go $ filter matching remotelist where go [] = Left $ "there is no available git remote named \"" ++ n ++ "\"" go (match:_) = Right match @@ -182,20 +186,31 @@ nameToUUID n = nameToUUID' n >>= \case (_, msg) -> giveup msg nameToUUID' :: RemoteName -> Annex ([UUID], String) -nameToUUID' n +nameToUUID' n = do + f <- nameToUUID'' + return (f n) + +nameToUUID'' :: Annex (RemoteName -> ([UUID], String)) +nameToUUID'' = do + l <- remoteList + u <- getUUID + m <- uuidDescMap + return $ \n -> nameToUUID''' n l u m + +nameToUUID''' :: RemoteName -> [Remote] -> UUID -> UUIDDescMap -> ([UUID], String) +nameToUUID''' n remotelist hereu m | n == "." = currentrepo | n == "here" = currentrepo - | otherwise = byName' n >>= go + | otherwise = go (byName'' n remotelist) where - currentrepo = mkone <$> getUUID + currentrepo = mkone hereu - go (Right r) = return $ case uuid r of + go (Right r) = case uuid r of NoUUID -> ([], noRemoteUUIDMsg r) u -> mkone u - go (Left e) = do - m <- uuidDescMap + go (Left e) = let descn = UUIDDesc (encodeBS n) - return $ case M.keys (M.filter (== descn) m) of + in case M.keys (M.filter (== descn) m) of [] -> let u = toUUID n in case M.keys (M.filterWithKey (\k _ -> k == u) m) of