diff options
| -rw-r--r-- | Annex/NumCopies.hs | 38 | ||||
| -rw-r--r-- | Remote/Git.hs | 13 | ||||
| -rw-r--r-- | Types/NumCopies.hs | 2 | ||||
| -rw-r--r-- | Types/Remote.hs | 7 |
4 files changed, 52 insertions, 8 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" diff --git a/Remote/Git.hs b/Remote/Git.hs index 725b302b8..9fa7158e5 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -53,6 +53,7 @@ import Annex.Path import Creds import Annex.CatFile import Messages.Progress +import Types.NumCopies import Control.Concurrent import Control.Concurrent.MSampleVar @@ -142,7 +143,7 @@ gen r u c gc , retrieveKeyFile = copyFromRemote new , retrieveKeyFileCheap = copyFromRemoteCheap new , removeKey = dropKey new - , lockContent = Nothing + , lockContent = Just (lockKey new) , checkPresent = inAnnex new , checkPresentCheap = repoCheap r , whereisKey = Nothing @@ -359,6 +360,16 @@ dropKey r key | Git.repoIsHttp (repo r) = error "dropping from http remote not supported" | otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key +lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r +lockKey r key a + | not $ Git.repoIsUrl (repo r) = + guardUsable (repo r) cantlock $ + onLocal r $ Annex.Content.lockContentShared key a + | Git.repoIsHttp (repo r) = cantlock + | otherwise = error "TODO" + where + cantlock = error "can't lock content" + {- Tries to copy a key's content from a remote's annex to a file. -} copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) copyFromRemote r key file dest p = parallelMetered (Just p) key file $ diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 23df6610a..476c33058 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -1,6 +1,6 @@ {- git-annex numcopies types - - - Copyright 2014 Joey Hess <id@joeyh.name> + - Copyright 2014-2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Types/Remote.hs b/Types/Remote.hs index 511a85afa..a39324163 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -78,10 +78,11 @@ data RemoteA a = Remote { -- Removes a key's contents (succeeds if the contents are not present) removeKey :: Key -> a Bool, -- Uses locking to prevent removal of a key's contents, - -- thus producing a VerifiedCopy. - -- The action must be run whether or not the locking succeeds. + -- thus producing a VerifiedCopy, which is passed to the callback. + -- If unable to lock, does not run the callback, and throws an + -- error. -- This is optional; remotes do not have to support locking. - lockContent :: forall r. Maybe (Key -> (Maybe VerifiedCopy -> a r) -> a r), + lockContent :: forall r. Maybe (Key -> (VerifiedCopy -> a r) -> a r), -- Checks if a key is present in the remote. -- Throws an exception if the remote cannot be accessed. checkPresent :: Key -> a Bool, |