content locking during drop working for local git remotes

Only ssh remotes lack locking now

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,