fully preserve input format of connect and disconnect commands
Just lifted the sim file as a DSL into the type level for that.
This commit is contained in:
Joey Hess
parent
f381b457f2
commit
7b931df475
3 changed files with 148 additions and 95 deletions
85
Annex/Sim.hs
85
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 $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
|
|
|||
Loading…
Reference in a new issue