summaryrefslogtreecommitdiff
path: root/Annex/NumCopies.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Annex/NumCopies.hs')
-rw-r--r--Annex/NumCopies.hs38
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"