improve drop proof code

Annex/NumCopies.hs

@@ -15,7 +15,7 @@ module Annex.NumCopies (
 	defaultNumCopies,
 	numCopiesCheck,
 	numCopiesCheck',
-	verifyEnoughCopies,
+	verifyEnoughCopiesToDrop,
 	knownCopies,
 ) where
 
@@ -93,31 +93,35 @@ numCopiesCheck' file vs have = do
 	return $ length have `vs` needed
 
 {- Verifies that enough copies of a key exist amoung the listed remotes,
- - printing an informative message if not.
+ - running an action with a proof if so, and printing an informative
+ - message if not.
  -}
-verifyEnoughCopies 
+verifyEnoughCopiesToDrop
 	:: String -- message to print when there are no known locations
 	-> Key
 	-> NumCopies
 	-> [UUID] -- repos to skip considering (generally untrusted remotes)
 	-> [VerifiedCopy] -- copies already verified to exist
-	-> [Remote] -- remotes to check to see if they have it
+	-> [Remote] -- remotes to check to see if they have copies
-	-> Annex Bool
+	-> (SafeDropProof -> Annex a) -- action to perform to drop
-verifyEnoughCopies nolocmsg key need skip preverified tocheck = 
+	-> Annex a -- action to perform when unable to drop
+	-> Annex a
+verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction nodropaction = 
 	helper [] [] preverified (nub tocheck)
   where
-	helper bad missing have []
+	helper bad missing have [] = do
-		| NumCopies (length have) >= need = return True
+		p <- liftIO $ mkSafeDropProof need have
-		| otherwise = do
+		case p of
-			notEnoughCopies key need have (skip++missing) bad nolocmsg
+			Right proof -> dropaction proof
-			return False
+			Left stillhave -> do
+				notEnoughCopies key need stillhave (skip++missing) bad nolocmsg
+				nodropaction
 	helper bad missing have (r:rs)
-		| verifiedEnoughCopies need have = do
+		| isSafeDrop need have = do
-			stillhave <- liftIO $ filterM checkVerifiedCopy have
+			p <- liftIO $ mkSafeDropProof need have
-			if verifiedEnoughCopies need stillhave
+			case p of
-				then return True
+				Right proof -> dropaction proof
-				else helper bad missing stillhave (r:rs)
+				Left stillhave -> helper bad missing stillhave (r:rs)
-		| any safeVerification have = helper bad missing have rs
 		| otherwise = do
 			haskey <- Remote.hasKey r key
 			case haskey of
@@ -125,29 +129,6 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck =
 				Left _      -> helper (r:bad) missing have rs
 				Right False -> helper bad (Remote.uuid r:missing) have rs
 
-{- Check whether enough verification has been done of copies to allow
- - dropping content safely.
- -
- - Unless numcopies is 0, at least one VerifiedCopyLock or TrustedCopy
- - is required. A VerifiedCopyLock 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.
- -}
-verifiedEnoughCopies :: NumCopies -> [VerifiedCopy] -> Bool
-verifiedEnoughCopies (NumCopies n) l
-	| n == 0 = True
-	| otherwise = length (deDupVerifiedCopies l) >= n && any safeVerification l
-
-safeVerification :: VerifiedCopy -> Bool
-safeVerification (VerifiedCopyLock _) = True
-safeVerification (TrustedCopy _) = True
-safeVerification (RecentlyVerifiedCopy _) = False
-
 notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex ()
 notEnoughCopies key need have skip bad nolocmsg = do
 	showNote "unsafe"

Command/Drop.hs

@@ -99,12 +99,12 @@ performLocal key afile numcopies preverified = lockContentExclusive key $ \conte
 	untrusteduuids <- trustGet UnTrusted
 	let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids)
 	u <- getUUID
-	ifM (canDrop u key afile numcopies [] preverified' tocheck)
+	doDrop u key afile numcopies [] preverified' tocheck
 		( do
 			removeAnnex contentlock
 			notifyDrop afile True
 			next $ cleanupLocal key
-		, do
+		, do 
 			notifyDrop afile False
 			stop
 		)
@@ -121,9 +121,12 @@ performRemote key afile numcopies remote = do
 	untrusteduuids <- trustGet UnTrusted
 	let tocheck = filter (/= remote) $
 		Remote.remotesWithoutUUID remotes (trusted++untrusteduuids)
-	stopUnless (canDrop uuid key afile numcopies [uuid] preverified tocheck) $ do
+	doDrop uuid key afile numcopies [uuid] preverified tocheck
-		ok <- Remote.removeKey remote key
+		( do 
-		next $ cleanupRemote key remote ok
+			ok <- Remote.removeKey remote key
+			next $ cleanupRemote key remote ok
+		, stop
+		)
   where
 	uuid = Remote.uuid remote
 
@@ -138,29 +141,29 @@ cleanupRemote key remote ok = do
 		Remote.logStatus remote key InfoMissing
 	return ok
 
-{- Checks specified remotes to verify that enough copies of a key exist to
+{- Before running the dropaction, checks specified remotes to
- - allow it to be safely removed (with no data loss).
+ - verify that enough copies of a key exist to allow it to be
+ - safely removed (with no data loss).
  -
  - Also checks if it's required content, and refuses to drop if so.
  -
  - --force overrides and always allows dropping.
  -}
-canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> Annex Bool
+doDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> (CommandPerform, CommandPerform) -> CommandPerform
-canDrop dropfrom key afile numcopies skip preverified check = 
+doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) = 
 	ifM (Annex.getState Annex.force)
-		( return True
+		( dropaction
-			, ifM (checkRequiredContent dropfrom key afile
+		, ifM (checkRequiredContent dropfrom key afile)
-				<&&> verifyEnoughCopies nolocmsg key numcopies skip preverified check
+			( verifyEnoughCopiesToDrop nolocmsg key numcopies
-				)
+				skip preverified check (const dropaction) (forcehint nodropaction)
-				( return True
+			, stop
-				, do
+			)
-					hint
-					return False
-				)
 		)
   where
 	nolocmsg = "Rather than dropping this file, try using: git annex move"
-	hint = showLongNote "(Use --force to override this check, or adjust numcopies.)"
+	forcehint a = do
+		showLongNote "(Use --force to override this check, or adjust numcopies.)"
+		a
 
 checkRequiredContent :: UUID -> Key -> AssociatedFile -> Annex Bool
 checkRequiredContent u k afile =

Command/Import.hs

@@ -83,7 +83,7 @@ start mode (srcfile, destfile) =
   where
 	deletedup k = do
 		showNote $ "duplicate of " ++ key2file k
-		ifM (verifiedExisting k destfile)
+		verifyExisting k destfile
 			( do
 				liftIO $ removeFile srcfile
 				next $ return True
@@ -134,8 +134,8 @@ start mode (srcfile, destfile) =
 		SkipDuplicates -> checkdup Nothing (Just importfile)
 		_ -> return (Just importfile)
 
-verifiedExisting :: Key -> FilePath -> Annex Bool
+verifyExisting :: Key -> FilePath -> (CommandPerform, CommandPerform) -> CommandPerform
-verifiedExisting key destfile = do
+verifyExisting key destfile (yes, no) = do
 	-- Look up the numcopies setting for the file that it would be
 	-- imported to, if it were imported.
 	need <- getFileNumCopies destfile
@@ -143,4 +143,6 @@ verifiedExisting key destfile = do
 	(remotes, trusteduuids) <- knownCopies key
 	untrusteduuids <- trustGet UnTrusted
 	let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
-	verifyEnoughCopies [] key need [] (map (mkVerifiedCopy TrustedCopy) trusteduuids) tocheck
+	let preverified = map (mkVerifiedCopy TrustedCopy) trusteduuids
+	verifyEnoughCopiesToDrop [] key need [] preverified tocheck
+		(const yes) no

Types/NumCopies.hs

@@ -16,6 +16,9 @@ module Types.NumCopies (
 	mkVerifiedCopy,
 	invalidatableVerifiedCopy,
 	withVerifiedCopy,
+	isSafeDrop,
+	SafeDropProof,
+	mkSafeDropProof,
 ) where
 
 import Types.UUID
@@ -25,6 +28,7 @@ import qualified Data.Map as M
 import Control.Concurrent.MVar
 import Control.Monad.Catch (MonadMask)
 import Control.Monad.IO.Class (MonadIO)
+import Control.Monad
 
 newtype NumCopies = NumCopies Int
 	deriving (Ord, Eq)
@@ -108,3 +112,38 @@ withVerifiedCopy mk u = bracketIO setup cleanup
   where
 	setup = invalidatableVerifiedCopy mk u
 	cleanup = invalidateVerifiedCopy
+
+{- Check whether enough verification has been done of copies to allow
+ - dropping content safely.
+ -
+ - Unless numcopies is 0, at least one VerifiedCopyLock or TrustedCopy
+ - is required. A VerifiedCopyLock 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.
+ -}
+isSafeDrop :: NumCopies -> [VerifiedCopy] -> Bool
+isSafeDrop (NumCopies n) l
+	| n == 0 = True
+	| otherwise = length (deDupVerifiedCopies l) >= n && any fullVerification l
+
+fullVerification :: VerifiedCopy -> Bool
+fullVerification (VerifiedCopyLock _) = True
+fullVerification (TrustedCopy _) = True
+fullVerification (RecentlyVerifiedCopy _) = False
+
+-- A proof that it's currently safe to drop an object.
+data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy]
+
+-- Make sure that none of the VerifiedCopies have become invalidated
+-- before constructing proof.
+mkSafeDropProof :: NumCopies -> [VerifiedCopy] -> IO (Either [VerifiedCopy] SafeDropProof)
+mkSafeDropProof need have = do
+	stillhave <- filterM checkVerifiedCopy have
+	return $ if isSafeDrop need stillhave
+		then Right (SafeDropProof need stillhave)
+		else Left stillhave

debian/changelog

@@ -20,9 +20,16 @@ git-annex (5.20150931) UNRELEASED; urgency=medium
     and stop recommending bittornado | bittorrent.
   * Debian: Remove dependency on transformers library, as it is now
     included in ghc.
+  * Fix a longstanding bug, where dropping a file from a remote
+    could race with other drops of the same file, and result in
+    all copies of its content being lost.
   * git-annex-shell: Added lockcontent command, to prevent dropping of
-    key's content.
+    a key's content. This is necessary due to the above bugfix.
-
+  * When a remote uses an old version of git-annex-shell without the
+    new lockcontent command, git-annex may not trust the remote enough
+    to be able to drop content.
+    Solution: Upgrade git-annex-shell to this version.
+    
  -- Joey Hess <id@joeyh.name>  Thu, 01 Oct 2015 12:42:56 -0400
 
 git-annex (5.20150930) unstable; urgency=medium