fix local dropping to not require extra locking of copies, but only that the local copy be locked for removal

11 files changed, 72 insertions, 48 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 40c78fd34..0dc47d9e2 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -13,7 +13,8 @@ module Annex.Content (
 	inAnnexSafe,
 	inAnnexCheck,
 	lockContentShared,
-	lockContentExclusive,
+	lockContentForRemoval,
+	ContentRemovalLock,
 	getViaTmp,
 	getViaTmp',
 	checkDiskSpaceToGet,
@@ -192,14 +193,12 @@ lockContentShared key a = lockContentUsing lock key $ do
 	lock = winLocker lockShared
 #endif
 
-newtype ContentLockExclusive = ContentLockExclusive Key
-
 {- Exclusively locks content, while performing an action that
  - might remove it.
  -}
-lockContentExclusive :: Key -> (ContentLockExclusive -> Annex a) -> Annex a
-lockContentExclusive key a = lockContentUsing lock key $ 
-	a (ContentLockExclusive key)
+lockContentForRemoval :: Key -> (ContentRemovalLock -> Annex a) -> Annex a
+lockContentForRemoval key a = lockContentUsing lock key $ 
+	a (ContentRemovalLock key)
   where
 #ifndef mingw32_HOST_OS
 	{- Since content files are stored with the write bit disabled, have
@@ -547,8 +546,8 @@ cleanObjectLoc key cleaner = do
  - In direct mode, deletes the associated files or files, and replaces
  - them with symlinks.
  -}
-removeAnnex :: ContentLockExclusive -> Annex ()
-removeAnnex (ContentLockExclusive key) = withObjectLoc key remove removedirect
+removeAnnex :: ContentRemovalLock -> Annex ()
+removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect
   where
 	remove file = cleanObjectLoc key $ do
 		secureErase file
diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs
index b51d3815b..2ddb460fd 100644
--- a/Annex/NumCopies.hs
+++ b/Annex/NumCopies.hs
@@ -104,12 +104,13 @@ 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.
+ - to safely drop it, running an action with a proof if so, and
+ - printing an informative message if not.
  -}
 verifyEnoughCopiesToDrop
 	:: String -- message to print when there are no known locations
 	-> Key
+	-> Maybe ContentRemovalLock
 	-> NumCopies
 	-> [UUID] -- repos to skip considering (generally untrusted remotes)
 	-> [VerifiedCopy] -- copies already verified to exist
@@ -117,19 +118,19 @@ verifyEnoughCopiesToDrop
 	-> (SafeDropProof -> Annex a) -- action to perform to drop
 	-> Annex a -- action to perform when unable to drop
 	-> Annex a
-verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction nodropaction = 
+verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction = 
 	helper [] [] preverified (nub tocheck)
   where
 	helper bad missing have [] = do
-		p <- liftIO $ mkSafeDropProof need have
+		p <- liftIO $ mkSafeDropProof need have removallock
 		case p of
 			Right proof -> dropaction proof
 			Left stillhave -> do
 				notEnoughCopies key need stillhave (skip++missing) bad nolocmsg
 				nodropaction
 	helper bad missing have (c:cs)
-		| isSafeDrop need have = do
-			p <- liftIO $ mkSafeDropProof need have
+		| isSafeDrop need have removallock = do
+			p <- liftIO $ mkSafeDropProof need have removallock
 			case p of
 				Right proof -> dropaction proof
 				Left stillhave -> helper bad missing stillhave (c:cs)
diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs
index c71604679..55a04c597 100644
--- a/Assistant/Unused.hs
+++ b/Assistant/Unused.hs
@@ -77,7 +77,7 @@ expireUnused duration = do
 	forM_ oldkeys $ \k -> do
 		debug ["removing old unused key", key2file k]
 		liftAnnex $ do
-			lockContentExclusive k removeAnnex
+			lockContentForRemoval k removeAnnex
 			logStatus k InfoMissing
   where
 	boundry = durationToPOSIXTime <$> duration
diff --git a/Command/Drop.hs b/Command/Drop.hs
index a2bca2204..d14cdad18 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -91,15 +91,11 @@ startRemote afile numcopies key remote = do
 	showStart' ("drop " ++ Remote.name remote) key afile
 	next $ performRemote key afile numcopies remote
 
--- Note that lockContentExclusive is called before checking if the key is
--- present on enough remotes to allow removal. This avoids a scenario where two
--- or more remotes are trying to remove a key at the same time, and each
--- sees the key is present on the other.
 performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
-performLocal key afile numcopies preverified = lockContentExclusive key $ \contentlock -> do
+performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do
 	u <- getUUID
 	(tocheck, verified) <- verifiableCopies key [u]
-	doDrop u key afile numcopies [] (preverified ++ verified) tocheck
+	doDrop u (Just contentlock) key afile numcopies [] (preverified ++ verified) tocheck
 		( \proof -> do
 			liftIO $ debugM "drop" $ unwords
 				[ "Dropping from here"
@@ -121,7 +117,7 @@ performRemote key afile numcopies remote = do
 	-- When the local repo has the key, that's one additional copy,
 	-- as long as the local repo is not untrusted.
 	(tocheck, verified) <- verifiableCopies key [uuid]
-	doDrop uuid key afile numcopies [uuid] verified tocheck
+	doDrop uuid Nothing key afile numcopies [uuid] verified tocheck
 		( \proof -> do 
 			liftIO $ debugM "drop" $ unwords
 				[ "Dropping from remote"
@@ -159,6 +155,7 @@ cleanupRemote key remote ok = do
  -}
 doDrop
 	:: UUID
+	-> Maybe ContentRemovalLock
 	-> Key
 	-> AssociatedFile
 	-> NumCopies
@@ -167,11 +164,12 @@ doDrop
 	-> [UnVerifiedCopy]
 	-> (Maybe SafeDropProof -> CommandPerform, CommandPerform)
 	-> CommandPerform
-doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) = 
+doDrop dropfrom contentlock key afile numcopies skip preverified check (dropaction, nodropaction) = 
 	ifM (Annex.getState Annex.force)
 		( dropaction Nothing
 		, ifM (checkRequiredContent dropfrom key afile)
-			( verifyEnoughCopiesToDrop nolocmsg key numcopies
+			( verifyEnoughCopiesToDrop nolocmsg key 
+				contentlock numcopies
 				skip preverified check
 					(dropaction . Just)
 					(forcehint nodropaction)
diff --git a/Command/DropKey.hs b/Command/DropKey.hs
index cdb19cabb..3dea4b4b7 100644
--- a/Command/DropKey.hs
+++ b/Command/DropKey.hs
@@ -31,7 +31,7 @@ start key = stopUnless (inAnnex key) $ do
 	next $ perform key
 
 perform :: Key -> CommandPerform
-perform key = lockContentExclusive key $ \contentlock -> do
+perform key = lockContentForRemoval key $ \contentlock -> do
 	removeAnnex contentlock
 	next $ cleanup key
 
diff --git a/Command/Import.hs b/Command/Import.hs
index 5ac050351..a96c08055 100644
--- a/Command/Import.hs
+++ b/Command/Import.hs
@@ -139,5 +139,5 @@ verifyExisting key destfile (yes, no) = do
 	need <- getFileNumCopies destfile
 
 	(tocheck, preverified) <- verifiableCopies key []
-	verifyEnoughCopiesToDrop [] key need [] preverified tocheck
+	verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck
 		(const yes) no
diff --git a/Command/Move.hs b/Command/Move.hs
index 072c00663..bd1b6dd92 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -123,7 +123,7 @@ toPerform dest move key afile fastcheck isthere =
 			finish
   where
 	finish
-		| move = lockContentExclusive key $ \contentlock -> do
+		| move = lockContentForRemoval key $ \contentlock -> do
 			removeAnnex contentlock
 			next $ Command.Drop.cleanupLocal key
 		| otherwise = next $ return True
diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs
index 3a44a1bde..be1b9a324 100644
--- a/Command/TestRemote.hs
+++ b/Command/TestRemote.hs
@@ -120,7 +120,7 @@ test st r k =
 	, check "storeKey when already present" store
 	, present True
 	, check "retrieveKeyFile" $ do
-		lockContentExclusive k removeAnnex
+		lockContentForRemoval k removeAnnex
 		get
 	, check "fsck downloaded object" fsck
 	, check "retrieveKeyFile resume from 33%" $ do
@@ -130,20 +130,20 @@ test st r k =
 			sz <- hFileSize h
 			L.hGet h $ fromInteger $ sz `div` 3
 		liftIO $ L.writeFile tmp partial
-		lockContentExclusive k removeAnnex
+		lockContentForRemoval k removeAnnex
 		get
 	, check "fsck downloaded object" fsck
 	, check "retrieveKeyFile resume from 0" $ do
 		tmp <- prepTmp k
 		liftIO $ writeFile tmp ""
-		lockContentExclusive k removeAnnex
+		lockContentForRemoval k removeAnnex
 		get
 	, check "fsck downloaded object" fsck
 	, check "retrieveKeyFile resume from end" $ do
 		loc <- Annex.calcRepo (gitAnnexLocation k)
 		tmp <- prepTmp k
 		void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp
-		lockContentExclusive k removeAnnex
+		lockContentForRemoval k removeAnnex
 		get
 	, check "fsck downloaded object" fsck
 	, check "removeKey when present" remove
@@ -189,7 +189,7 @@ testUnavailable st r k =
 cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup
 cleanup rs ks ok = do
 	forM_ rs $ \r -> forM_ ks (Remote.removeKey r)
-	forM_ ks $ \k -> lockContentExclusive k removeAnnex
+	forM_ ks $ \k -> lockContentForRemoval k removeAnnex
 	return ok
 
 chunkSizes :: Int -> Bool -> [Int]
diff --git a/Command/Uninit.hs b/Command/Uninit.hs
index 38e062002..cc237db5e 100644
--- a/Command/Uninit.hs
+++ b/Command/Uninit.hs
@@ -105,7 +105,7 @@ removeUnannexed = go []
 	go c [] = return c
 	go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks)
 		( do
-			lockContentExclusive k removeAnnex
+			lockContentForRemoval k removeAnnex
 			go c ks
 		, go (k:c) ks
 		)
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 5c429c93c..a6c4315ab 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -352,7 +352,7 @@ dropKey r key
 			commitOnCleanup r $ onLocal r $ do
 				ensureInitialized
 				whenM (Annex.Content.inAnnex key) $ do
-					Annex.Content.lockContentExclusive key
+					Annex.Content.lockContentForRemoval key
 						Annex.Content.removeAnnex
 					logStatus key InfoMissing
 					Annex.Content.saveState True
diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs
index bbd1b3831..60e0db580 100644
--- a/Types/NumCopies.hs
+++ b/Types/NumCopies.hs
@@ -19,9 +19,11 @@ module Types.NumCopies (
 	isSafeDrop,
 	SafeDropProof,
 	mkSafeDropProof,
+	ContentRemovalLock(..),
 ) where
 
 import Types.UUID
+import Types.Key
 import Utility.Exception (bracketIO)
 
 import qualified Data.Map as M
@@ -36,6 +38,11 @@ newtype NumCopies = NumCopies Int
 fromNumCopies :: NumCopies -> Int
 fromNumCopies (NumCopies n) = n
 
+-- Indicates that a key's content is exclusively
+-- locked locally, pending removal.
+newtype ContentRemovalLock = ContentRemovalLock Key
+	deriving (Show)
+
 -- A verification that a copy of a key exists in a repository.
 data VerifiedCopy
 	{- Represents a recent verification that a copy of an
@@ -48,7 +55,7 @@ data VerifiedCopy
  	{- The strongest proof of the existence of a copy.
 	 - Until its associated action is called to unlock it,
 	 - the copy is locked in the repository and is guaranteed
-	 - not to be dropped by any git-annex process. -}
+	 - not to be removed by any git-annex process. -}
 	| LockedCopy V
 	deriving (Show)
 
@@ -116,20 +123,39 @@ withVerifiedCopy mk u = bracketIO setup cleanup
 {- Check whether enough verification has been done of copies to allow
  - dropping content safely.
  -
- - Unless numcopies is 0, at least one LockedCopy or TrustedCopy
- - is required. A LockedCopy prevents races between concurrent
- - drops from dropping the last copy, no matter what.
+ - This is carefully balanced to prevent data loss when there are races
+ - between concurrent drops of the same content in different repos,
+ - without requiring impractical amounts of locking.
+ -
+ - In particular, concurrent drop races may cause the number of copies
+ - to fall below NumCopies, but it will never fall below 1.
+ -}
+isSafeDrop :: NumCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> Bool
+{- When a ContentRemovalLock is provided, the content is being
+ - dropped from the local repo. That lock will prevent other git repos
+ - that are concurrently dropping from using the local copy as a VerifiedCopy.
+ - So, no additional locking is needed; all we need is verifications
+ - of any kind of N other copies of the content. -}
+isSafeDrop (NumCopies n) l (Just (ContentRemovalLock _)) = 
+	length (deDupVerifiedCopies l) >= n
+{- Dropping from a remote repo.
+ -
+ - Unless numcopies is 0, at least one LockedCopy or TrustedCopy is required.
+ - A LockedCopy prevents races between concurrent drops from
+ - dropping the last copy, no matter what.
  -
  - The other N-1 copies can be less strong verifications, like
  - RecentlyVerifiedCopy. While those are subject to concurrent drop races,
  - and so could be dropped all at once, causing numcopies to be violated,
- - this is the best that can be done without requiring all special remotes
- - to support locking.
+ - this is the best that can be done without requiring that 
+ - all special remotes support locking.
  -}
-isSafeDrop :: NumCopies -> [VerifiedCopy] -> Bool
-isSafeDrop (NumCopies n) l
+isSafeDrop (NumCopies n) l Nothing
 	| n == 0 = True
-	| otherwise = length (deDupVerifiedCopies l) >= n && any fullVerification l
+	| otherwise = and
+		[ length (deDupVerifiedCopies l) >= n
+		, any fullVerification l
+		]
 
 fullVerification :: VerifiedCopy -> Bool
 fullVerification (LockedCopy _) = True
@@ -137,14 +163,14 @@ fullVerification (TrustedCopy _) = True
 fullVerification (RecentlyVerifiedCopy _) = False
 
 -- A proof that it's currently safe to drop an object.
-data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy]
+data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy] (Maybe ContentRemovalLock)
 	deriving (Show)
 
 -- Make sure that none of the VerifiedCopies have become invalidated
 -- before constructing proof.
-mkSafeDropProof :: NumCopies -> [VerifiedCopy] -> IO (Either [VerifiedCopy] SafeDropProof)
-mkSafeDropProof need have = do
+mkSafeDropProof :: NumCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> IO (Either [VerifiedCopy] SafeDropProof)
+mkSafeDropProof need have removallock = do
 	stillhave <- filterM checkVerifiedCopy have
-	return $ if isSafeDrop need stillhave
-		then Right (SafeDropProof need stillhave)
+	return $ if isSafeDrop need stillhave removallock
+		then Right (SafeDropProof need stillhave removallock)
 		else Left stillhave