diff options
Diffstat (limited to 'Annex/NumCopies.hs')
| -rw-r--r-- | Annex/NumCopies.hs | 38 |
1 files changed, 35 insertions, 3 deletions
diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 7874fb0e9..be1db4be8 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} + module Annex.NumCopies ( module Types.NumCopies, module Logs.NumCopies, @@ -30,6 +32,10 @@ import qualified Types.Remote as Remote import Annex.UUID import Annex.Content +import Control.Exception +import qualified Control.Monad.Catch as M +import Data.Typeable + defaultNumCopies :: NumCopies defaultNumCopies = NumCopies 1 @@ -124,10 +130,31 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n 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 - Just lockcontent -> lockcontent key $ \v -> case v of - Nothing -> fallback - Just vc -> helper bad missing (vc : have) rs where fallback = do haskey <- Remote.hasKey r key @@ -136,6 +163,11 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n Left _ -> helper (r:bad) missing have rs Right False -> helper bad (Remote.uuid r:missing) have rs +data DropException = DropException SomeException + deriving (Typeable, Show) + +instance Exception DropException + notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do showNote "unsafe" |