diff --git a/Annex/Sim.hs b/Annex/Sim.hs index 05596b6363..17d98f7f24 100644 --- a/Annex/Sim.hs +++ b/Annex/Sim.hs @@ -153,12 +153,49 @@ newtype RemoteName = RemoteName { fromRemoteName :: String } remoteNameToRepoName :: RemoteName -> RepoName remoteNameToRepoName (RemoteName n) = RepoName n +repoNameToRemoteName :: RepoName -> RemoteName +repoNameToRemoteName (RepoName n) = RemoteName n + +data Connections + = RepoName :-> RemoteName + | RemoteName :<- RepoName + | RepoName :<-> RepoName + | RepoName :=> Connections + | RemoteName :<= Connections + | RepoName :<=> Connections + deriving (Show) + +leftSideOfConnection :: Connections -> RepoName +leftSideOfConnection (reponame :-> _) = reponame +leftSideOfConnection (remotename :<- _) = remoteNameToRepoName remotename +leftSideOfConnection (reponame :<-> _) = reponame +leftSideOfConnection (reponame :=> _) = reponame +leftSideOfConnection (remotename :<= _) = remoteNameToRepoName remotename +leftSideOfConnection (reponame :<=> _) = reponame + +getConnection :: Connections -> (RepoName, RemoteName, Maybe Connections) +getConnection (reponame :-> remotename) = (reponame, remotename, Nothing) +getConnection (remotename :<- reponame) = (reponame, remotename, Nothing) +getConnection (reponame1 :<-> reponame2) = + ( reponame1 + , repoNameToRemoteName reponame2 + , Just (reponame2 :-> repoNameToRemoteName reponame1) + ) +getConnection (reponame :=> c) = + (reponame, repoNameToRemoteName (leftSideOfConnection c), Just c) +getConnection (remotename :<= c) = (leftSideOfConnection c, remotename, Just c) +getConnection (reponame :<=> c) = + ( reponame + , repoNameToRemoteName (leftSideOfConnection c) + , Just (reponame :=> c) + ) + data SimCommand = CommandInit RepoName | CommandInitRemote RepoName | CommandUse RepoName String - | CommandConnect RepoName RemoteName - | CommandDisconnect RepoName RemoteName + | CommandConnect Connections + | CommandDisconnect Connections | CommandAddTree RepoName PreferredContentExpression | CommandAdd RawFilePath ByteSize [RepoName] | CommandStep Int @@ -234,22 +271,34 @@ applySimCommand' (CommandUse reponame s) st = Left msg -> Left $ "Unable to use a repository \"" ++ fromRepoName reponame ++ "\" in the simulation because " ++ msg -applySimCommand' (CommandConnect repo remote) st = - checkKnownRepo repo st $ \u -> Right $ Right $ st - { simConnections = - let s = case M.lookup u (simConnections st) of - Just cs -> S.insert remote cs - Nothing -> S.singleton remote - in M.insert u s (simConnections st) - } -applySimCommand' (CommandDisconnect repo remote) st = - checkKnownRepo repo st $ \u -> Right $ Right $ st - { simConnections = - let sc = case M.lookup u (simConnections st) of - Just s -> S.delete remote s - Nothing -> S.empty - in M.insert u sc (simConnections st) - } +applySimCommand' (CommandConnect connections) st = + let (repo, remote, mconnections) = getConnection connections + in checkKnownRepo repo st $ \u -> + let st' = st + { simConnections = + let s = case M.lookup u (simConnections st) of + Just cs -> S.insert remote cs + Nothing -> S.singleton remote + in M.insert u s (simConnections st) + } + in case mconnections of + Nothing -> Right $ Right st' + Just connections' -> + applySimCommand' (CommandConnect connections') st' +applySimCommand' (CommandDisconnect connections) st = + let (repo, remote, mconnections) = getConnection connections + in checkKnownRepo repo st $ \u -> + let st' = st + { simConnections = + let sc = case M.lookup u (simConnections st) of + Just s -> S.delete remote s + Nothing -> S.empty + in M.insert u sc (simConnections st) + } + in case mconnections of + Nothing -> Right $ Right $ st + Just connections' -> + applySimCommand' (CommandDisconnect connections') st' applySimCommand' (CommandAddTree repo expr) st = checkKnownRepo repo st $ const $ checkValidPreferredContentExpression expr $ Left $ diff --git a/Annex/Sim/File.hs b/Annex/Sim/File.hs index 068a346a96..47776bf4fb 100644 --- a/Annex/Sim/File.hs +++ b/Annex/Sim/File.hs @@ -20,15 +20,15 @@ import Text.Read parseSimFile :: String -> Either String [SimCommand] parseSimFile = go [] . lines where - go c [] = Right c - go c (l:ls) = case parseSimFileLine l of - Right cs -> go (c ++ cs) ls + go cs [] = Right (reverse cs) + go cs (l:ls) = case parseSimFileLine l of + Right command -> go (command:cs) ls Left err -> Left err -parseSimFileLine :: String -> Either String [SimCommand] +parseSimFileLine :: String -> Either String SimCommand parseSimFileLine s - | "#" `isPrefixOf` s = Right [CommandComment s] - | all isSpace s = Right [CommandBlank] + | "#" `isPrefixOf` s = Right (CommandComment s) + | all isSpace s = Right (CommandBlank) | otherwise = parseSimCommand (words s) generateSimFile :: [SimCommand] -> String @@ -41,10 +41,10 @@ generateSimFile = unlines . map unwords . go ["initremote", name] : go rest go (CommandUse (RepoName name) what : rest) = ["use", name, what] : go rest - go (CommandConnect (RepoName name) (RemoteName remote) : rest) = - handleconnect name remote rest - go (CommandDisconnect (RepoName name) (RemoteName remote) : rest) = - ["disconnect", name, "->", remote] : go rest + go (CommandConnect c : rest) = + ("connect":formatConnections c) : go rest + go (CommandDisconnect c : rest) = + ("disconnect":formatConnections c) : go rest go (CommandAddTree (RepoName name) expr : rest) = ["addtree", name, expr] : go rest go (CommandAdd f sz repos : rest) = @@ -98,117 +98,123 @@ generateSimFile = unlines . map unwords . go go (CommandBlank : rest) = [""] : go rest - handleconnect name remote (CommandConnect (RepoName name2) (RemoteName remote2) : rest) - | name == remote2 && name2 == remote = - let (chain, rest') = chainconnect remote rest - in (["connect", name, "<->", remote] ++ chain) : go rest' - handleconnect name remote rest = - ["connect", name, "->", remote] : go rest - - chainconnect name (CommandConnect (RepoName name2) (RemoteName remote2) : rest) - | name == name2 = case rest of - (CommandConnect (RepoName name3) (RemoteName remote3) : rest') - | remote2 == name3 -> - let (chain, rest'') = chainconnect remote3 rest' - in (["<->", remote2] ++ chain, rest'') - _ -> - let (chain, rest') = chainconnect remote2 rest - in (["->", remote2] ++ chain, rest') - chainconnect _ rest = ([], rest) - showsize = filter (not . isSpace) . preciseSize storageUnits True -parseSimCommand :: [String] -> Either String [SimCommand] +parseSimCommand :: [String] -> Either String SimCommand parseSimCommand ("init":name:[]) = - Right [CommandInit (RepoName name)] + Right $ CommandInit (RepoName name) parseSimCommand ("initremote":name:[]) = - Right [CommandInitRemote (RepoName name)] + Right $ CommandInitRemote (RepoName name) parseSimCommand ("use":name:rest) = - Right [CommandUse (RepoName name) (unwords rest)] -parseSimCommand ("connect":rest) = - parseConnect CommandConnect rest + Right $ CommandUse (RepoName name) (unwords rest) +parseSimCommand ("connect":rest) = + CommandConnect <$> parseConnections rest parseSimCommand ("disconnect":rest) = - parseConnect CommandDisconnect rest + CommandDisconnect <$> parseConnections rest parseSimCommand ("addtree":name:rest) = - Right [CommandAddTree(RepoName name) (unwords rest)] + Right $ CommandAddTree(RepoName name) (unwords rest) parseSimCommand ("add":filename:size:repos) = case readSize dataUnits size of - Just sz -> Right [CommandAdd (toRawFilePath filename) sz (map RepoName repos)] + Just sz -> Right $ CommandAdd + (toRawFilePath filename) + sz + (map RepoName repos) Nothing -> Left $ "Unable to parse file size \"" ++ size ++ "\"" parseSimCommand ("step":n:[]) = case readMaybe n of - Just n' -> Right [CommandStep n'] + Just n' -> Right $ CommandStep n' Nothing -> Left $ "Unable to parse step value \"" ++ n ++ "\"" parseSimCommand ("action":repo:"pull":remote:[]) = - Right [CommandAction (RepoName repo) (ActionPull (RemoteName remote))] + Right $ CommandAction (RepoName repo) + (ActionPull (RemoteName remote)) parseSimCommand ("action":repo:"push":remote:[]) = - Right [CommandAction (RepoName repo) (ActionPush (RemoteName remote))] + Right $ CommandAction (RepoName repo) + (ActionPush (RemoteName remote)) parseSimCommand ("action":repo:"getwanted":remote:[]) = - Right [CommandAction (RepoName repo) (ActionGetWanted (RemoteName remote))] + Right $ CommandAction (RepoName repo) + (ActionGetWanted (RemoteName remote)) parseSimCommand ("action":repo:"dropunwanted":[]) = - Right [CommandAction (RepoName repo) (ActionDropUnwanted Nothing)] + Right $ CommandAction (RepoName repo) + (ActionDropUnwanted Nothing) parseSimCommand ("action":repo:"dropunwanted":remote:[]) = - Right [CommandAction (RepoName repo) (ActionDropUnwanted (Just (RemoteName remote)))] + Right $ CommandAction (RepoName repo) + (ActionDropUnwanted (Just (RemoteName remote))) parseSimCommand ("action":repo:"gitpush":remote:[]) = - Right [CommandAction (RepoName repo) (ActionGitPush (RemoteName remote))] + Right $ CommandAction (RepoName repo) + (ActionGitPush (RemoteName remote)) parseSimCommand ("action":repo:"gitpull":remote:[]) = - Right [CommandAction (RepoName repo) (ActionGitPull (RemoteName remote))] + Right $ CommandAction (RepoName repo) + (ActionGitPull (RemoteName remote)) parseSimCommand ("seed":n:[]) = case readMaybe n of - Just n' -> Right [CommandSeed n'] + Just n' -> Right $ CommandSeed n' Nothing -> Left $ "Unable to parse seed value \"" ++ n ++ "\"" parseSimCommand ("present":repo:file:[]) = - Right [CommandPresent (RepoName repo) (toRawFilePath file)] + Right $ CommandPresent (RepoName repo) (toRawFilePath file) parseSimCommand ("notpresent":repo:file:[]) = - Right [CommandNotPresent (RepoName repo) (toRawFilePath file)] + Right $ CommandNotPresent (RepoName repo) (toRawFilePath file) parseSimCommand ("numcopies":n:[]) = case readMaybe n of - Just n' -> Right [CommandNumCopies n'] + Just n' -> Right $ CommandNumCopies n' Nothing -> Left $ "Unable to parse numcopies value \"" ++ n ++ "\"" parseSimCommand ("mincopies":n:[]) = case readMaybe n of - Just n' -> Right [CommandMinCopies n'] + Just n' -> Right $ CommandMinCopies n' Nothing -> Left $ "Unable to parse mincopies value \"" ++ n ++ "\"" parseSimCommand ("trustlevel":repo:s:[]) = case readTrustLevel s of - Just trustlevel -> Right [CommandTrustLevel (RepoName repo) trustlevel] + Just trustlevel -> Right $ + CommandTrustLevel (RepoName repo) trustlevel Nothing -> Left $ "Unknown trust level \"" ++ s ++ "\"." parseSimCommand ("group":repo:group:[]) = - Right [CommandGroup (RepoName repo) (toGroup group)] + Right $ CommandGroup (RepoName repo) (toGroup group) parseSimCommand ("ungroup":repo:group:[]) = - Right [CommandUngroup (RepoName repo) (toGroup group)] + Right $ CommandUngroup (RepoName repo) (toGroup group) parseSimCommand ("wanted":repo:expr) = - Right [CommandWanted (RepoName repo) (unwords expr)] + Right $ CommandWanted (RepoName repo) (unwords expr) parseSimCommand ("required":repo:expr) = - Right [CommandRequired (RepoName repo) (unwords expr)] + Right $ CommandRequired (RepoName repo) (unwords expr) parseSimCommand ("groupwanted":group:expr) = - Right [CommandGroupWanted (toGroup group) (unwords expr)] + Right $ CommandGroupWanted (toGroup group) (unwords expr) parseSimCommand ("maxsize":repo:size:[]) = case readSize dataUnits size of - Just sz -> Right [CommandMaxSize (RepoName repo) (MaxSize sz)] + Just sz -> Right $ CommandMaxSize (RepoName repo) (MaxSize sz) Nothing -> Left $ "Unable to parse maxsize \"" ++ size ++ "\"" parseSimCommand ("rebalance":onoff:[]) = case isTrueFalse onoff of - Just b -> Right [CommandRebalance b] + Just b -> Right $ CommandRebalance b Nothing -> Left $ "Unable to parse rebalance value \"" ++ onoff ++ "\"" parseSimCommand ws = Left $ "Unable to parse sim command: \"" ++ unwords ws ++ "\"" -parseConnect :: (RepoName -> RemoteName -> SimCommand) -> [String] -> Either String [SimCommand] -parseConnect mk = go [] +parseConnections :: [String] -> Either String Connections +parseConnections = go . reverse where - go c [] = Right (reverse c) - go c (r1:"->":r2:rest) = - go (mk (RepoName r1) (RemoteName r2):c) - (chain r2 rest) - go c (r1:"<-":r2:rest) = - go (mk (RepoName r2) (RemoteName r1):c) - (chain r2 rest) - go c (r1:"<->":r2:rest) = - go (mk (RepoName r2) (RemoteName r1) - : mk (RepoName r1) (RemoteName r2) - : c - ) - (chain r2 rest) - go _ rest = Left $ "Bad connect syntax near \"" ++ unwords rest ++ "\"" + go (r2:"->":r1:rest) = + chain (RepoName r1 :-> RemoteName r2) rest + go (r2:"<-":r1:rest) = + chain (RemoteName r1 :<- RepoName r2) rest + go (r2:"<->":r1:rest) = + chain (RepoName r1 :<-> RepoName r2) rest + go rest = bad rest - chain v rest = if null rest then rest else v:rest + chain c [] = Right c + chain c ("->":r:rest) = chain (RepoName r :=> c) rest + chain c ("<-":r:rest) = chain (RemoteName r :<= c) rest + chain c ("<->":r:rest) = chain (RepoName r :<=> c) rest + chain _ rest = bad rest + + bad rest = Left $ "Bad connect syntax near \"" ++ unwords rest ++ "\"" + +formatConnections :: Connections -> [String] +formatConnections (RepoName repo :-> RemoteName remote) = + [repo, "->", remote] +formatConnections (RemoteName remote :<- RepoName repo) = + [remote, "<-", repo] +formatConnections (RepoName repo1 :<-> RepoName repo2) = + [repo1, "<->", repo2] +formatConnections (RepoName repo :=> c) = + repo : "->" : formatConnections c +formatConnections (RemoteName remote :<= c) = + remote : "<-" : formatConnections c +formatConnections (RepoName repo :<=> c) = + repo : "<->" : formatConnections c diff --git a/Command/Sim.hs b/Command/Sim.hs index 3b629bc64d..9b812ed1d6 100644 --- a/Command/Sim.hs +++ b/Command/Sim.hs @@ -30,8 +30,6 @@ seek _ = do let st = emptySimState rng repobyname getpath st' <- runSimCommand (CommandInit (RepoName "foo")) st >>= runSimCommand (CommandUse (RepoName "bar") "here") - >>= runSimCommand (CommandConnect (RepoName "foo") (RemoteName "bar")) - >>= runSimCommand (CommandConnect (RepoName "bar") (RemoteName "foo")) >>= runSimCommand (CommandAdd "bigfile" 1000000 [RepoName "foo"]) >>= runSimCommand (CommandAction (RepoName "bar") (ActionGitPull (RemoteName "foo"))) >>= runSimCommand (CommandAction (RepoName "bar") (ActionGetWanted (RemoteName "foo")))