sim: implement dropunwantedfrom
This commit is contained in:
Joey Hess
parent
eb5fad4e79
commit
b85965cb3c
4 changed files with 63 additions and 51 deletions
100
Annex/Sim.hs
100
Annex/Sim.hs
|
|
@ -447,49 +447,11 @@ getSimActionComponents (ActionSendWanted repo remote) st =
|
|||
addHistory st' $ CommandPresent (remoteNameToRepoName remote) f
|
||||
getSimActionComponents (ActionDropUnwanted repo Nothing) st =
|
||||
checkKnownRepo repo st $ \u ->
|
||||
Right $ Left (st, map (go u) $ M.toList $ simFiles st)
|
||||
where
|
||||
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
|
||||
|
||||
checkdrop u rst k st' =
|
||||
let numcopies = simNumCopies st'
|
||||
mincopies = simMinCopies 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 u k st'
|
||||
SafeDropCheckTime -> dodrop u k st'
|
||||
|
||||
dodrop u k = setPresentKey False u k u
|
||||
|
||||
remotes u = S.fromList $ mapMaybe
|
||||
(\remote -> M.lookup (remoteNameToRepoName remote) (simRepos st))
|
||||
(maybe mempty S.toList $ M.lookup u $ simConnections st)
|
||||
|
||||
verifypresent u k st' ru = do
|
||||
rst <- M.lookup ru (simRepoState st')
|
||||
if present ru rst k
|
||||
then if ru `S.member` remotes u
|
||||
then Just $ if simIsSpecialRemote rst
|
||||
then mkVerifiedCopy RecentlyVerifiedCopy ru
|
||||
else mkVerifiedCopy LockedCopy ru
|
||||
else case M.lookup ru (simTrustLevels st') of
|
||||
Just Trusted -> Just $
|
||||
mkVerifiedCopy TrustedCopy ru
|
||||
_ -> Nothing
|
||||
else Nothing
|
||||
getSimActionComponents (ActionDropUnwanted _repo (Just _remote)) _st =
|
||||
undefined -- TODO
|
||||
simulateDropUnwanted st u repo u
|
||||
getSimActionComponents (ActionDropUnwanted repo (Just remote)) st =
|
||||
checkKnownRepo repo st $ \u ->
|
||||
checkKnownRemote remote repo u st $ \ru ->
|
||||
simulateDropUnwanted st u (remoteNameToRepoName remote) ru
|
||||
getSimActionComponents (ActionGitPush repo remote) st =
|
||||
checkKnownRepo repo st $ \u ->
|
||||
checkKnownRemote remote repo u st $ \_ ->
|
||||
|
|
@ -602,6 +564,58 @@ simulateGitAnnexMerge src dest st =
|
|||
}
|
||||
_ -> Left $ "Unable to find " ++ fromRepoName src ++ " or " ++ fromRepoName dest ++ " in simRepos"
|
||||
|
||||
simulateDropUnwanted
|
||||
:: SimState SimRepo
|
||||
-> UUID
|
||||
-> RepoName
|
||||
-> UUID
|
||||
-> Either String (Either (SimState SimRepo, [SimState SimRepo -> Annex (SimState SimRepo)]) (SimState SimRepo))
|
||||
simulateDropUnwanted st u dropfromname dropfrom =
|
||||
Right $ Left (st, map go $ M.toList $ simFiles st)
|
||||
where
|
||||
go (f, k) st' = liftIO $ runSimRepo u st' $ \rst ->
|
||||
let af = AssociatedFile $ Just f
|
||||
in if present dropfrom rst k
|
||||
then ifM (wantDrop NoLiveUpdate False (Just dropfrom) (Just k) af Nothing)
|
||||
( return $ checkdrop rst k f st'
|
||||
, return st'
|
||||
)
|
||||
else return st'
|
||||
|
||||
present ru rst k = ru `S.member` getSimLocations rst k
|
||||
|
||||
checkdrop rst k f st' =
|
||||
let numcopies = simNumCopies st'
|
||||
mincopies = simMinCopies st'
|
||||
verifiedcopies = mapMaybe (verifypresent k st') $
|
||||
filter (/= dropfrom) $ S.toList $ getSimLocations rst k
|
||||
in case safeDropAnalysis numcopies mincopies verifiedcopies Nothing of
|
||||
UnsafeDrop -> st'
|
||||
SafeDrop -> dodrop k f st'
|
||||
SafeDropCheckTime -> dodrop k f st'
|
||||
|
||||
dodrop k f st' =
|
||||
setPresentKey False dropfrom k u $
|
||||
setPresentKey False dropfrom k dropfrom $
|
||||
addHistory st' $ CommandNotPresent dropfromname f
|
||||
|
||||
remotes = S.fromList $ mapMaybe
|
||||
(\remote -> M.lookup (remoteNameToRepoName remote) (simRepos st))
|
||||
(maybe mempty S.toList $ M.lookup u $ simConnections st)
|
||||
|
||||
verifypresent k st' ru = do
|
||||
rst <- M.lookup ru (simRepoState st')
|
||||
if present ru rst k
|
||||
then if ru `S.member` remotes || ru == u
|
||||
then Just $ if simIsSpecialRemote rst
|
||||
then mkVerifiedCopy RecentlyVerifiedCopy ru
|
||||
else mkVerifiedCopy LockedCopy ru
|
||||
else case M.lookup ru (simTrustLevels st') of
|
||||
Just Trusted -> Just $
|
||||
mkVerifiedCopy TrustedCopy ru
|
||||
_ -> Nothing
|
||||
else Nothing
|
||||
|
||||
checkNonexistantRepo :: RepoName -> SimState SimRepo -> Either String a -> Either String a
|
||||
checkNonexistantRepo reponame st a = case M.lookup reponame (simRepos st) of
|
||||
Nothing -> a
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@ formatAction (ActionSync (RepoName repo) (RemoteName remote)) =
|
|||
formatAction (ActionGetWanted (RepoName repo) (RemoteName remote)) =
|
||||
["action", repo, "getwanted", remote]
|
||||
formatAction (ActionDropUnwanted (RepoName repo) (Just (RemoteName remote))) =
|
||||
["action", repo, "dropunwanted", remote]
|
||||
["action", repo, "dropunwantedfrom", remote]
|
||||
formatAction (ActionDropUnwanted (RepoName repo) Nothing) =
|
||||
["action", repo, "dropunwanted"]
|
||||
formatAction (ActionSendWanted (RepoName repo) (RemoteName remote)) =
|
||||
|
|
@ -197,11 +197,11 @@ parseSimAction ("action":repo:"getwanted":remote:rest) =
|
|||
mkAction rest $ ActionGetWanted (RepoName repo) (RemoteName remote)
|
||||
parseSimAction ("action":repo:"sendwanted":remote:rest) =
|
||||
mkAction rest $ ActionSendWanted (RepoName repo) (RemoteName remote)
|
||||
parseSimAction ("action":repo:"dropunwanted":rest) =
|
||||
mkAction rest $ ActionDropUnwanted (RepoName repo) Nothing
|
||||
parseSimAction ("action":repo:"dropunwanted":remote:rest) =
|
||||
parseSimAction ("action":repo:"dropunwantedfrom":remote:rest) =
|
||||
mkAction rest $ ActionDropUnwanted (RepoName repo)
|
||||
(Just (RemoteName remote))
|
||||
parseSimAction ("action":repo:"dropunwanted":rest) =
|
||||
mkAction rest $ ActionDropUnwanted (RepoName repo) Nothing
|
||||
parseSimAction ("action":repo:"gitpush":remote:rest) =
|
||||
mkAction rest $ ActionGitPush (RepoName repo) (RemoteName remote)
|
||||
parseSimAction ("action":repo:"gitpull":remote:rest) =
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@ as passed to "git annex sim" while a simulation is running.
|
|||
Simulate the repository dropping files it does not want,
|
||||
when it is able to verify enough copies exist on remotes.
|
||||
|
||||
* `action repo dropunwanted remote`
|
||||
* `action repo dropunwantedfrom remote`
|
||||
|
||||
Simulate the repository dropping files from the remote that the remote
|
||||
does not want, when it is able to verify enouh copies exist.
|
||||
|
|
@ -217,7 +217,7 @@ as passed to "git annex sim" while a simulation is running.
|
|||
* `action repo push remote`
|
||||
|
||||
Simulate the equivilant of [[git-annex-push]](1) by combining
|
||||
the actions sendwanted, dropunwanted, and gitpush.
|
||||
the actions sendwanted, dropunwantedfrom, and gitpush.
|
||||
|
||||
* `action repo sync remote`
|
||||
|
||||
|
|
|
|||
|
|
@ -34,8 +34,6 @@ Planned schedule of work:
|
|||
|
||||
* sim: implement addtree
|
||||
|
||||
* sim: implement ActionDropUnwanted
|
||||
|
||||
## items deferred until later for balanced preferred content and maxsize tracking
|
||||
|
||||
* `git-annex assist --rebalance` of `balanced=foo:2`
|
||||
|
|
|
|||
Loading…
Reference in a new issue