sim concurrency

This commit is contained in:
Joey Hess 2024-09-17 09:33:55 -04:00
parent 3b7e3cb2f4
commit 7d27a8ea1a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 191 additions and 140 deletions

View file

@ -200,7 +200,7 @@ data SimCommand
| CommandAddTree RepoName PreferredContentExpression
| CommandAdd RawFilePath ByteSize [RepoName]
| CommandStep Int
| CommandAction RepoName SimAction
| CommandAction SimAction
| CommandSeed Int
| CommandPresent RepoName RawFilePath
| CommandNotPresent RepoName RawFilePath
@ -219,44 +219,45 @@ data SimCommand
deriving (Show, Read)
data SimAction
= ActionPull RemoteName
| ActionPush RemoteName
| ActionSync RemoteName
| ActionGetWanted RemoteName
| ActionDropUnwanted (Maybe RemoteName)
| ActionSendWanted RemoteName
| ActionGitPush RemoteName
| ActionGitPull RemoteName
= ActionPull RepoName RemoteName
| ActionPush RepoName RemoteName
| ActionSync RepoName RemoteName
| ActionGetWanted RepoName RemoteName
| ActionDropUnwanted RepoName (Maybe RemoteName)
| ActionSendWanted RepoName RemoteName
| ActionGitPush RepoName RemoteName
| ActionGitPull RepoName RemoteName
| ActionWhile SimAction SimAction
deriving (Show, Read)
runSimCommand :: SimCommand -> GetExistingRepoByName -> SimState SimRepo -> Annex (SimState SimRepo)
runSimCommand (CommandStep n) repobyname st
| n > 0 = case randomRepo st of
(Just (repo, u), st') ->
let (act, st'') = randomAction u st'
in runSimCommand (CommandAction repo act) repobyname st''
let (act, st'') = randomAction repo u st'
in runSimCommand (CommandAction act) repobyname st''
>>= runSimCommand (CommandStep (pred n)) repobyname
(Nothing, st') -> return st'
| otherwise = return st
runSimCommand (CommandAction reponame (ActionPull remote)) repobyname st =
runSimCommand (CommandAction (ActionPull repo remote)) repobyname st =
runCompoundSimAction repobyname
[ CommandAction reponame (ActionGitPull remote)
, CommandAction reponame (ActionGetWanted remote)
, CommandAction reponame (ActionDropUnwanted Nothing)
[ CommandAction (ActionGitPull repo remote)
, CommandAction (ActionGetWanted repo remote)
, CommandAction (ActionDropUnwanted repo Nothing)
] st
runSimCommand (CommandAction reponame (ActionPush remote)) repobyname st =
runSimCommand (CommandAction (ActionPush repo remote)) repobyname st =
runCompoundSimAction repobyname
[ CommandAction reponame (ActionSendWanted remote)
, CommandAction reponame (ActionDropUnwanted (Just remote))
, CommandAction reponame (ActionGitPush remote)
[ CommandAction (ActionSendWanted repo remote)
, CommandAction (ActionDropUnwanted repo (Just remote))
, CommandAction (ActionGitPush repo remote)
] st
runSimCommand (CommandAction reponame (ActionSync remote)) repobyname st =
runSimCommand (CommandAction (ActionSync repo remote)) repobyname st =
runCompoundSimAction repobyname
[ CommandAction reponame (ActionGitPull remote)
, CommandAction reponame (ActionGetWanted remote)
, CommandAction reponame (ActionSendWanted remote)
, CommandAction reponame (ActionDropUnwanted (Just remote))
, CommandAction reponame (ActionGitPush remote)
[ CommandAction (ActionGitPull repo remote)
, CommandAction (ActionGetWanted repo remote)
, CommandAction (ActionSendWanted repo remote)
, CommandAction (ActionDropUnwanted repo (Just remote))
, CommandAction (ActionGitPush repo remote)
] st
runSimCommand cmd repobyname st =
case applySimCommand cmd st repobyname of
@ -344,9 +345,14 @@ applySimCommand' (CommandAdd file sz repos) st _ =
}
in go k st'' rest
applySimCommand' (CommandStep _) _ _ = error "applySimCommand' CommandStep"
applySimCommand' (CommandAction repo act) st _ =
checkKnownRepo repo st $ \u ->
applySimAction repo u act st
applySimCommand' (CommandAction act) st _ =
case getSimActionComponents act st of
Left err -> Left err
Right (Right st') -> Right (Right st')
Right (Left (st', l)) -> Right $ Left $ go l st'
where
go [] st' = return st'
go (a:as) st' = a st' >>= go as
applySimCommand' (CommandSeed rngseed) st _ =
Right $ Right $ st
{ simRng = rngseed
@ -431,63 +437,63 @@ applySimCommand' (CommandRebalance b) st _ =
applySimCommand' (CommandComment _) st _ = Right $ Right st
applySimCommand' CommandBlank st _ = Right $ Right st
applySimAction
:: RepoName
-> UUID
-> SimAction
getSimActionComponents
:: SimAction
-> SimState SimRepo
-> Either String (Either (Annex (SimState SimRepo)) (SimState SimRepo))
applySimAction r u (ActionGetWanted remote) st =
overFilesRemote r u remote S.member wanted go st
-> Either String (Either (SimState SimRepo, [SimState SimRepo -> Annex (SimState SimRepo)]) (SimState SimRepo))
getSimActionComponents (ActionGetWanted repo remote) st =
checkKnownRepo repo st $ \u ->
let go _remoteu f k _r st' = setPresentKey True u k u $
addHistory st' $ CommandPresent repo f
in overFilesRemote repo u remote S.member wanted go st
where
wanted k f _ = wantGet NoLiveUpdate False k f
go _remoteu f k _r st' = setPresentKey True u k u $
addHistory st' $ CommandPresent r f
applySimAction r u (ActionSendWanted remote) st =
overFilesRemote r u remote S.notMember wanted go st
getSimActionComponents (ActionSendWanted repo remote) st =
checkKnownRepo repo st $ \u ->
overFilesRemote repo u remote S.notMember wanted (go u) st
where
wanted = wantGetBy NoLiveUpdate False
go remoteu f k _r st' =
go u remoteu f k _r st' =
-- Sending to a remote updates the location log
-- of both the repository sending and the remote.
setPresentKey True remoteu k remoteu $
setPresentKey True remoteu k u $
addHistory st' $ CommandPresent (remoteNameToRepoName remote) f
applySimAction _r u (ActionDropUnwanted Nothing) st =
Right $ Left $ liftIO $ runSimRepo u st $ \rst ->
go rst (M.toList $ M.filter (present rst) $ simFiles st) st
getSimActionComponents (ActionDropUnwanted repo Nothing) st =
checkKnownRepo repo st $ \u ->
Right $ Left (st, map (go u) $ M.toList $ simFiles st)
where
present rst k = u `S.member` getSimLocations rst k
go u (f, k) st' = liftIO $ runSimRepo u st' $ \rst ->
let af = AssociatedFile $ Just f
in if present u rst k
then ifM (wantDrop NoLiveUpdate False Nothing (Just k) af Nothing)
( return $ checkdrop u rst k st'
, return st'
)
else return st'
present u rst k = u `S.member` getSimLocations rst k
go _ [] st' = return st'
go rst ((f, k):rest) st' = do
ifM (wantDrop NoLiveUpdate False Nothing (Just k) af Nothing)
( go rst rest $ checkdrop rst k st'
, go rst rest st'
)
where
af = AssociatedFile $ Just f
checkdrop rst k st' =
checkdrop u rst k st' =
let numcopies = simNumCopies st'
mincopies = simMinCopies st'
verifiedcopies = mapMaybe (verifypresent k st') $
verifiedcopies = mapMaybe (verifypresent u k st') $
filter (/= u) $ S.toList $ getSimLocations rst k
in case safeDropAnalysis numcopies mincopies verifiedcopies Nothing of
UnsafeDrop -> st'
SafeDrop -> dodrop k st'
SafeDropCheckTime -> dodrop k st'
SafeDrop -> dodrop u k st'
SafeDropCheckTime -> dodrop u k st'
dodrop k = setPresentKey False u k u
dodrop u k = setPresentKey False u k u
remotes = S.fromList $ mapMaybe
remotes u = S.fromList $ mapMaybe
(\remote -> M.lookup (remoteNameToRepoName remote) (simRepos st))
(maybe mempty S.toList $ M.lookup u $ simConnections st)
verifypresent k st' ru = do
verifypresent u k st' ru = do
rst <- M.lookup ru (simRepoState st')
if present rst k
then if ru `S.member` remotes
if present u rst k
then if ru `S.member` remotes u
then Just $ if simIsSpecialRemote rst
then mkVerifiedCopy RecentlyVerifiedCopy ru
else mkVerifiedCopy LockedCopy ru
@ -496,17 +502,39 @@ applySimAction _r u (ActionDropUnwanted Nothing) st =
mkVerifiedCopy TrustedCopy ru
_ -> Nothing
else Nothing
applySimAction _r _u (ActionDropUnwanted (Just _remote)) _st = undefined -- TODO
applySimAction r u (ActionGitPush remote) st =
checkKnownRemote remote r u st $ \_ ->
simulateGitAnnexMerge r (remoteNameToRepoName remote) st
applySimAction r u (ActionGitPull remote) st =
checkKnownRemote remote r u st $ \_ ->
simulateGitAnnexMerge (remoteNameToRepoName remote) r st
getSimActionComponents (ActionDropUnwanted _repo (Just _remote)) _st =
undefined -- TODO
getSimActionComponents (ActionGitPush repo remote) st =
checkKnownRepo repo st $ \u ->
checkKnownRemote remote repo u st $ \_ ->
simulateGitAnnexMerge repo (remoteNameToRepoName remote) st
getSimActionComponents (ActionGitPull repo remote) st =
checkKnownRepo repo st $ \u ->
checkKnownRemote remote repo u st $ \_ ->
simulateGitAnnexMerge (remoteNameToRepoName remote) repo st
getSimActionComponents (ActionWhile a b) st =
case getSimActionComponents a st of
Left err -> Left err
Right (Right st') -> getSimActionComponents b st'
Right (Left (st', as)) ->
case getSimActionComponents b st' of
Left err -> Left err
Right (Right st'') -> Right $ Left (st'', as)
Right (Left (st'', bs)) ->
Right $ Left $ mingle as bs st'' []
where
mingle [] subbs st' c = (st', reverse c ++ subbs)
mingle subas [] st' c = (st', reverse c ++ subas)
mingle (suba:subas) (subb:subbs) st' c =
let (coinflip, st'') = simRandom st' random id
in if coinflip
then mingle subas (subb:subbs) st'' (suba:c)
else mingle (suba:subas) subbs st'' (subb:c)
-- These are handled by runSimCommand
applySimAction _r _u (ActionPull _remote) _st = error "applySimAction ActionPull"
applySimAction _r _u (ActionPush _remote) _st = error "applySimAction ActionPush"
applySimAction _r _u (ActionSync _remote) _st = error "applySimAction ActionSync"
-- XXX move to here
getSimActionComponents (ActionPull _ _) _st = error "applySimAction ActionPull"
getSimActionComponents (ActionPush _ _) _st = error "applySimAction ActionPush"
getSimActionComponents (ActionSync _ _) _st = error "applySimAction ActionSync"
overFilesRemote
:: RepoName
@ -516,25 +544,20 @@ overFilesRemote
-> (Maybe Key -> AssociatedFile -> UUID -> Annex Bool)
-> (UUID -> RawFilePath -> Key -> RepoName -> SimState SimRepo -> SimState SimRepo)
-> SimState SimRepo
-> Either String (Either (Annex (SimState SimRepo)) (SimState SimRepo))
-> Either String (Either (SimState SimRepo, [SimState SimRepo -> Annex (SimState SimRepo)]) (SimState SimRepo))
overFilesRemote r u remote remotepred checkwant handlewanted st =
checkKnownRemote remote r u st $ \remoteu ->
Right $ Left $ liftIO $
runSimRepo u st $ \rst -> do
let l = M.toList $
M.filter (checkremotepred remoteu rst) $
simFiles st
go remoteu l st
Right (Left (st, map (go remoteu) $ M.toList $ simFiles st))
where
go _ [] st' = return st'
go remoteu ((f, k):rest) st' = do
ifM (checkwant (Just k) af remoteu)
( go remoteu rest $ handlewanted remoteu f k r st'
, go remoteu rest st'
)
where
af = AssociatedFile $ Just f
go remoteu (f, k) st' =
let af = AssociatedFile $ Just f
in liftIO $ runSimRepo u st' $ \rst ->
if checkremotepred remoteu rst k
then ifM (checkwant (Just k) af remoteu)
( return $ handlewanted remoteu f k r st'
, return st'
)
else return st'
checkremotepred remoteu rst k =
remotepred remoteu (getSimLocations rst k)
@ -542,7 +565,7 @@ simulateGitAnnexMerge
:: RepoName
-> RepoName
-> SimState SimRepo
-> Either String (Either (Annex (SimState SimRepo)) (SimState SimRepo))
-> Either String (Either a (SimState SimRepo))
simulateGitAnnexMerge src dest st =
case (M.lookup src (simRepos st), M.lookup dest (simRepos st)) of
(Just srcu, Just destu) -> case M.lookup destu (simRepoState st) of
@ -607,24 +630,24 @@ randomRepo st
where
repolist = M.keys (simRepos st)
randomAction :: UUID -> SimState SimRepo -> (SimAction, SimState SimRepo)
randomAction u st = case M.lookup u (simConnections st) of
randomAction :: RepoName -> UUID -> SimState SimRepo -> (SimAction, SimState SimRepo)
randomAction repo u st = case M.lookup u (simConnections st) of
Just cs | not (S.null cs) ->
let (mkact, st') = simRandom st (randomR (0, length mkactions - 1))
(mkactions !!)
(remote, st'') = simRandom st' (randomR (0, S.size cs - 1))
(`S.elemAt` cs)
in (mkact remote, st'')
in (mkact repo remote, st'')
-- When there are no remotes, this is the only possible action.
_ -> (ActionDropUnwanted Nothing, st)
_ -> (ActionDropUnwanted repo Nothing, st)
where
mkactions =
[ ActionPull
, ActionPush
, ActionSync
, ActionGetWanted
, ActionDropUnwanted . Just
, const (ActionDropUnwanted Nothing)
, \repo' remote -> ActionDropUnwanted repo' (Just remote)
, \repo' _remote -> ActionDropUnwanted repo' Nothing
, ActionSendWanted
, ActionGitPush
, ActionGitPull

View file

@ -51,24 +51,7 @@ generateSimFile = unlines . map unwords . go
(["add", fromRawFilePath f, showsize sz] ++ map fromRepoName repos) : go rest
go (CommandStep n : rest) =
["step", show n] : go rest
go (CommandAction (RepoName repo) (ActionPull (RemoteName remote)) : rest) =
["action", repo, "pull", remote] : go rest
go (CommandAction (RepoName repo) (ActionPush (RemoteName remote)) : rest) =
["action", repo, "push", remote] : go rest
go (CommandAction (RepoName repo) (ActionSync (RemoteName remote)) : rest) =
["action", repo, "sync", remote] : go rest
go (CommandAction (RepoName repo) (ActionGetWanted (RemoteName remote)) : rest) =
["action", repo, "getwanted", remote] : go rest
go (CommandAction (RepoName repo) (ActionDropUnwanted (Just (RemoteName remote))) : rest) =
["action", repo, "dropunwanted", remote] : go rest
go (CommandAction (RepoName repo) (ActionDropUnwanted Nothing) : rest) =
["action", repo, "dropunwanted"] : go rest
go (CommandAction (RepoName repo) (ActionSendWanted (RemoteName remote)) : rest) =
["action", repo, "sendwanted", remote] : go rest
go (CommandAction (RepoName repo) (ActionGitPush (RemoteName remote)) : rest) =
["action", repo, "gitpush", remote] : go rest
go (CommandAction (RepoName repo) (ActionGitPull (RemoteName remote)) : rest) =
["action", repo, "gitpull", remote] : go rest
go (CommandAction act : rest) = formatAction act : go rest
go (CommandSeed n : rest) =
["seed", show n] : go rest
go (CommandPresent (RepoName repo) f : rest) =
@ -102,6 +85,28 @@ generateSimFile = unlines . map unwords . go
showsize = filter (not . isSpace) . preciseSize storageUnits True
formatAction :: SimAction -> [String]
formatAction (ActionPull (RepoName repo) (RemoteName remote)) =
["action", repo, "pull", remote]
formatAction (ActionPush (RepoName repo) (RemoteName remote)) =
["action", repo, "push", remote]
formatAction (ActionSync (RepoName repo) (RemoteName remote)) =
["action", repo, "sync", remote]
formatAction (ActionGetWanted (RepoName repo) (RemoteName remote)) =
["action", repo, "getwanted", remote]
formatAction (ActionDropUnwanted (RepoName repo) (Just (RemoteName remote))) =
["action", repo, "dropunwanted", remote]
formatAction (ActionDropUnwanted (RepoName repo) Nothing) =
["action", repo, "dropunwanted"]
formatAction (ActionSendWanted (RepoName repo) (RemoteName remote)) =
["action", repo, "sendwanted", remote]
formatAction (ActionGitPush (RepoName repo) (RemoteName remote)) =
["action", repo, "gitpush", remote]
formatAction (ActionGitPull (RepoName repo) (RemoteName remote)) =
["action", repo, "gitpull", remote]
formatAction (ActionWhile a b) =
formatAction a ++ ["while"] ++ formatAction b
parseSimCommand :: [String] -> Either String SimCommand
parseSimCommand ("init":name:[]) =
Right $ CommandInit (RepoName name)
@ -126,30 +131,9 @@ parseSimCommand ("step":n:[]) =
case readMaybe n of
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))
parseSimCommand ("action":repo:"push":remote:[]) =
Right $ CommandAction (RepoName repo)
(ActionPush (RemoteName remote))
parseSimCommand ("action":repo:"sync":remote:[]) =
Right $ CommandAction (RepoName repo)
(ActionSync (RemoteName remote))
parseSimCommand ("action":repo:"getwanted":remote:[]) =
Right $ CommandAction (RepoName repo)
(ActionGetWanted (RemoteName remote))
parseSimCommand ("action":repo:"dropunwanted":[]) =
Right $ CommandAction (RepoName repo)
(ActionDropUnwanted Nothing)
parseSimCommand ("action":repo:"dropunwanted":remote:[]) =
Right $ CommandAction (RepoName repo)
(ActionDropUnwanted (Just (RemoteName remote)))
parseSimCommand ("action":repo:"gitpush":remote:[]) =
Right $ CommandAction (RepoName repo)
(ActionGitPush (RemoteName remote))
parseSimCommand ("action":repo:"gitpull":remote:[]) =
Right $ CommandAction (RepoName repo)
(ActionGitPull (RemoteName remote))
parseSimCommand l@("action":_) = case parseSimAction l of
Right act -> Right $ CommandAction act
Left err -> Left err
parseSimCommand ("seed":n:[]) =
case readMaybe n of
Just n' -> Right $ CommandSeed n'
@ -188,7 +172,37 @@ parseSimCommand ("maxsize":repo:size:[]) =
parseSimCommand ("rebalance":onoff:[]) = case isTrueFalse onoff of
Just b -> Right $ CommandRebalance b
Nothing -> Left $ "Unable to parse rebalance value \"" ++ onoff ++ "\""
parseSimCommand ws = Left $ "Unable to parse sim command: \"" ++ unwords ws ++ "\""
parseSimCommand ws = parseError ws
parseSimAction :: [String] -> Either String SimAction
parseSimAction ("action":repo:"pull":remote:rest) =
mkAction rest $ ActionPull (RepoName repo) (RemoteName remote)
parseSimAction ("action":repo:"push":remote:rest) =
mkAction rest $ ActionPush (RepoName repo) (RemoteName remote)
parseSimAction ("action":repo:"sync":remote:rest) =
mkAction rest $ ActionSync (RepoName repo) (RemoteName remote)
parseSimAction ("action":repo:"getwanted":remote:rest) =
mkAction rest $ ActionGetWanted (RepoName repo) (RemoteName remote)
parseSimAction ("action":repo:"dropunwanted":rest) =
mkAction rest $ ActionDropUnwanted (RepoName repo) Nothing
parseSimAction ("action":repo:"dropunwanted":remote:rest) =
mkAction rest $ ActionDropUnwanted (RepoName repo)
(Just (RemoteName remote))
parseSimAction ("action":repo:"gitpush":remote:rest) =
mkAction rest $ ActionGitPush (RepoName repo) (RemoteName remote)
parseSimAction ("action":repo:"gitpull":remote:rest) =
mkAction rest $ ActionGitPull (RepoName repo) (RemoteName remote)
parseSimAction ws = parseError ws
mkAction :: [String] -> SimAction -> Either String SimAction
mkAction [] a = Right a
mkAction ("while":rest) a = case parseSimAction rest of
Right b -> Right (ActionWhile a b)
Left err -> Left err
mkAction ws _ = parseError ws
parseError :: [String] -> Either String a
parseError ws = Left $ "Unable to parse sim command: \"" ++ unwords ws ++ "\""
parseConnections :: [String] -> Either String Connections
parseConnections = go . reverse

View file

@ -204,12 +204,26 @@ as passed to "git annex sim" while a simulation is running.
Simulate the equivilant of [[git-annex-sync]](1) by combining
the actions gitpull, getwanted, sendwanted, dropunwanted, and gitpush.
* `action [...] while action [...]`
Simulate running the two actions concurrently. While the simulation only
actually simulates one thing happening at a time, when the actions each
operate on multiple files, they will be interleaved randomly.
Any number of actions can be combined this way.
For example:
action foo dropunwanted while action bar getwanted foo
In this example, bar may or may not get a file before foo drops it.
* `seed N`
Sets the random seed to a given number. Using this should make the
results of the simulation deterministic. The output sim file
always has the random seed included in it, so usually you don't need to
specify this.
always has the random seed included in it, so it can be used to replay
the simulation.
* `present repo file`