From 7d27a8ea1a5597ac39a18d5a84b7e3a4b09b4b4b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 17 Sep 2024 09:33:55 -0400 Subject: [PATCH] sim concurrency --- Annex/Sim.hs | 213 +++++++++++++++++++++++------------------ Annex/Sim/File.hs | 100 ++++++++++--------- doc/git-annex-sim.mdwn | 18 +++- 3 files changed, 191 insertions(+), 140 deletions(-) diff --git a/Annex/Sim.hs b/Annex/Sim.hs index d1797188e0..c552388eb2 100644 --- a/Annex/Sim.hs +++ b/Annex/Sim.hs @@ -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 diff --git a/Annex/Sim/File.hs b/Annex/Sim/File.hs index 09d76623da..d987276710 100644 --- a/Annex/Sim/File.hs +++ b/Annex/Sim/File.hs @@ -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 diff --git a/doc/git-annex-sim.mdwn b/doc/git-annex-sim.mdwn index 3da4112935..b87befdf07 100644 --- a/doc/git-annex-sim.mdwn +++ b/doc/git-annex-sim.mdwn @@ -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`