diff options
| -rw-r--r-- | Annex/NumCopies.hs | 114 | ||||
| -rw-r--r-- | Command/Drop.hs | 27 | ||||
| -rw-r--r-- | Command/Import.hs | 5 | ||||
| -rw-r--r-- | Remote.hs | 33 |
4 files changed, 93 insertions, 86 deletions
diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index be1db4be8..f6ce05230 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -18,7 +18,8 @@ module Annex.NumCopies ( numCopiesCheck, numCopiesCheck', verifyEnoughCopiesToDrop, - knownCopies, + verifiableCopies, + UnVerifiedCopy, ) where import Common.Annex @@ -29,8 +30,8 @@ import Logs.Trust import Annex.CheckAttr import qualified Remote import qualified Types.Remote as Remote -import Annex.UUID import Annex.Content +import Annex.UUID import Control.Exception import qualified Control.Monad.Catch as M @@ -99,6 +100,9 @@ numCopiesCheck' file vs have = do NumCopies needed <- getFileNumCopies file return $ length have `vs` needed +data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere + deriving (Ord, Eq) + {- Verifies that enough copies of a key exist amoung the listed remotes, - running an action with a proof if so, and printing an informative - message if not. @@ -109,7 +113,7 @@ verifyEnoughCopiesToDrop -> NumCopies -> [UUID] -- repos to skip considering (generally untrusted remotes) -> [VerifiedCopy] -- copies already verified to exist - -> [Remote] -- remotes to check to see if they have copies + -> [UnVerifiedCopy] -- places to check to see if they have copies -> (SafeDropProof -> Annex a) -- action to perform to drop -> Annex a -- action to perform when unable to drop -> Annex a @@ -123,45 +127,45 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n Left stillhave -> do notEnoughCopies key need stillhave (skip++missing) bad nolocmsg nodropaction - helper bad missing have (r:rs) + helper bad missing have (c:cs) | isSafeDrop need have = do p <- liftIO $ mkSafeDropProof need have case p of Right proof -> dropaction proof - Left stillhave -> helper bad missing stillhave (r:rs) - | otherwise = case Remote.lockContent r of - Just lockcontent -> do - -- The remote's lockContent will throw - -- an exception if it is unable to lock, - -- in which case the fallback should be - -- run. - -- - -- On the other hand, the callback passed - -- to the lockContent could itself throw an - -- exception (ie, the eventual drop - -- action fails), and in this case we don't - -- want to use the fallback since part - -- of the drop action may have already been - -- performed. - -- - -- Differentiate between these two sorts - -- of exceptions by using DropException. - let a = lockcontent key $ \vc -> - helper bad missing (vc : have) rs - `catchNonAsync` (throw . DropException) - a `M.catches` - [ M.Handler (\ (e :: AsyncException) -> throwM e) - , M.Handler (\ (DropException e') -> throwM e') - , M.Handler (\ (_e :: SomeException) -> fallback) - ] - Nothing -> fallback - where - fallback = do + Left stillhave -> helper bad missing stillhave (c:cs) + | otherwise = case c of + UnVerifiedHere -> lockContentShared key contverified + UnVerifiedRemote r -> checkremote r contverified $ do haskey <- Remote.hasKey r key case haskey of - Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) rs - Left _ -> helper (r:bad) missing have rs - Right False -> helper bad (Remote.uuid r:missing) have rs + Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs + Left _ -> helper (r:bad) missing have cs + Right False -> helper bad (Remote.uuid r:missing) have cs + where + contverified vc = helper bad missing (vc : have) cs + + checkremote r cont fallback = case Remote.lockContent r of + Just lockcontent -> do + -- The remote's lockContent will throw an exception + -- when it is unable to lock, in which case the + -- fallback should be run. + -- + -- On the other hand, the continuation could itself + -- throw an exception (ie, the eventual drop action + -- fails), and in this case we don't want to run the + -- fallback since part of the drop action may have + -- already been performed. + -- + -- Differentiate between these two sorts + -- of exceptions by using DropException. + let a = lockcontent key $ \v -> + cont v `catchNonAsync` (throw . DropException) + a `M.catches` + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (DropException e') -> throwM e') + , M.Handler (\ (_e :: SomeException) -> fallback) + ] + Nothing -> fallback data DropException = DropException SomeException deriving (Typeable, Show) @@ -178,19 +182,31 @@ notEnoughCopies key need have skip bad nolocmsg = do Remote.showTriedRemotes bad Remote.showLocations True key (map toUUID have++skip) nolocmsg -{- Cost ordered lists of remotes that the location log indicates - - may have a key. +{- Finds locations of a key that can be used to get VerifiedCopies, + - in order to allow dropping the key. + - + - Provide a list of UUIDs that the key is being dropped from. + - The returned lists will exclude any of those UUIDs. + - + - The return lists also exclude any repositories that are untrusted, + - since those should not be used for verification. - - - Also returns a list of UUIDs that are trusted to have the key - - (some may not have configured remotes). If the current repository - - currently has the key, and is not untrusted, it is included in this list. + - The UnVerifiedCopy list is cost ordered. + - The VerifiedCopy list contains repositories that are trusted to + - contain the key. -} -knownCopies :: Key -> Annex ([Remote], [UUID]) -knownCopies key = do - (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key +verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy]) +verifiableCopies key exclude = do + locs <- Remote.keyLocations key + (remotes, trusteduuids) <- Remote.remoteLocations locs + =<< trustGet Trusted + untrusteduuids <- trustGet UnTrusted + let exclude' = exclude ++ untrusteduuids + let remotes' = Remote.remotesWithoutUUID remotes (exclude' ++ trusteduuids) + let verified = map (mkVerifiedCopy TrustedCopy) $ + filter (`notElem` exclude') trusteduuids u <- getUUID - trusteduuids' <- ifM (inAnnex key <&&> (<= SemiTrusted) <$> lookupTrust u) - ( pure (u:trusteduuids) - , pure trusteduuids - ) - return (remotes, trusteduuids') + let herec = if u `elem` locs && u `notElem` exclude' + then [UnVerifiedHere] + else [] + return (herec ++ map UnVerifiedRemote remotes', verified) diff --git a/Command/Drop.hs b/Command/Drop.hs index 43dc51d74..a2bca2204 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -97,12 +97,9 @@ startRemote afile numcopies key remote = do -- sees the key is present on the other. performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform performLocal key afile numcopies preverified = lockContentExclusive key $ \contentlock -> do - (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key - let preverified' = preverified ++ map (mkVerifiedCopy TrustedCopy) trusteduuids - untrusteduuids <- trustGet UnTrusted - let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids) u <- getUUID - doDrop u key afile numcopies [] preverified' tocheck + (tocheck, verified) <- verifiableCopies key [u] + doDrop u key afile numcopies [] (preverified ++ verified) tocheck ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from here" @@ -123,13 +120,8 @@ performRemote key afile numcopies remote = do -- places assumed to have the key, and places to check. -- When the local repo has the key, that's one additional copy, -- as long as the local repo is not untrusted. - (remotes, trusteduuids) <- knownCopies key - let trusted = filter (/= uuid) trusteduuids - let preverified = map (mkVerifiedCopy TrustedCopy) trusted - untrusteduuids <- trustGet UnTrusted - let tocheck = filter (/= remote) $ - Remote.remotesWithoutUUID remotes (trusted++untrusteduuids) - doDrop uuid key afile numcopies [uuid] preverified tocheck + (tocheck, verified) <- verifiableCopies key [uuid] + doDrop uuid key afile numcopies [uuid] verified tocheck ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from remote" @@ -165,7 +157,16 @@ cleanupRemote key remote ok = do - - --force overrides and always allows dropping. -} -doDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform +doDrop + :: UUID + -> Key + -> AssociatedFile + -> NumCopies + -> [UUID] + -> [VerifiedCopy] + -> [UnVerifiedCopy] + -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) + -> CommandPerform doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) = ifM (Annex.getState Annex.force) ( dropaction Nothing diff --git a/Command/Import.hs b/Command/Import.hs index f486da7c5..313339371 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -140,9 +140,6 @@ verifyExisting key destfile (yes, no) = do -- imported to, if it were imported. need <- getFileNumCopies destfile - (remotes, trusteduuids) <- knownCopies key - untrusteduuids <- trustGet UnTrusted - let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids) - let preverified = map (mkVerifiedCopy TrustedCopy) trusteduuids + (tocheck, preverified) <- verifiableCopies key [] verifyEnoughCopiesToDrop [] key need [] preverified tocheck (const yes) no @@ -40,7 +40,7 @@ module Remote ( remotesWithoutUUID, keyLocations, keyPossibilities, - keyPossibilitiesTrusted, + remoteLocations, nameToUUID, nameToUUID', showTriedRemotes, @@ -260,33 +260,26 @@ keyLocations key = trustExclude DeadTrusted =<< loggedLocations key - may have a key. -} keyPossibilities :: Key -> Annex [Remote] -keyPossibilities key = fst <$> keyPossibilities' key [] - -{- Cost ordered lists of remotes that the location log indicates - - may have a key. - - - - Also returns a list of UUIDs that are trusted to have the key - - (some may not have configured remotes). - -} -keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID]) -keyPossibilitiesTrusted key = keyPossibilities' key =<< trustGet Trusted - -keyPossibilities' :: Key -> [UUID] -> Annex ([Remote], [UUID]) -keyPossibilities' key trusted = do +keyPossibilities key = do u <- getUUID - -- uuids of all remotes that are recorded to have the key - validuuids <- filter (/= u) <$> keyLocations key + locations <- filter (/= u) <$> keyLocations key + fst <$> remoteLocations locations [] - -- note that validuuids is assumed to not have dups - let validtrusteduuids = validuuids `intersect` trusted +{- Given a list of locations of a key, and a list of all + - trusted repositories, generates a cost-ordered list of + - remotes that contain the key, and a list of trusted locations of the key. + -} +remoteLocations :: [UUID] -> [UUID] -> Annex ([Remote], [UUID]) +remoteLocations locations trusted = do + let validtrustedlocations = nub locations `intersect` trusted -- remotes that match uuids that have the key allremotes <- filter (not . remoteAnnexIgnore . gitconfig) <$> remoteList - let validremotes = remotesWithUUID allremotes validuuids + let validremotes = remotesWithUUID allremotes locations - return (sortBy (comparing cost) validremotes, validtrusteduuids) + return (sortBy (comparing cost) validremotes, validtrustedlocations) {- Displays known locations of a key. -} showLocations :: Bool -> Key -> [UUID] -> String -> Annex () |