Merge branch 'dropproof'

Annex.hs

@@ -13,6 +13,7 @@ module Annex (
 	new,
 	run,
 	eval,
+	makeRunner,
 	getState,
 	changeState,
 	withState,
@@ -203,6 +204,13 @@ eval s a = do
 	mvar <- newMVar s
 	runReaderT (runAnnex a) mvar
 
+{- Makes a runner action, that allows diving into IO and from inside
+ - the IO action, running an Annex action. -}
+makeRunner :: Annex (Annex a -> IO a)
+makeRunner = do
+	mvar <- ask
+	return $ \a -> runReaderT (runAnnex a) mvar
+
 getState :: (AnnexState -> v) -> Annex v
 getState selector = do
 	mvar <- ask

Annex/Content.hs

@@ -12,7 +12,9 @@ module Annex.Content (
 	inAnnex',
 	inAnnexSafe,
 	inAnnexCheck,
-	lockContent,
+	lockContentShared,
+	lockContentForRemoval,
+	ContentRemovalLock,
 	getViaTmp,
 	getViaTmp',
 	checkDiskSpaceToGet,
@@ -66,6 +68,8 @@ import Messages.Progress
 import qualified Types.Remote
 import qualified Types.Backend
 import qualified Backend
+import Types.NumCopies
+import Annex.UUID
 
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
@@ -165,57 +169,102 @@ contentLockFile key = ifM isDirect
 contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key)
 #endif
 
-newtype ContentLock = ContentLock Key
+{- Prevents the content from being removed while the action is running.
-
+ - Uses a shared lock.
-{- Content is exclusively locked while running an action that might remove
+ -
- - it. (If the content is not present, no locking is done.)
+ - Does not actually check if the content is present. Use inAnnex for that.
+ - However, since the contentLockFile is the content file in indirect mode,
+ - if the content is not present, locking it will fail.
+ -
+ - If locking fails, throws an exception rather than running the action.
+ -
+ - Note that, in direct mode, nothing prevents the user from directly
+ - editing or removing the content, even while it's locked by this.
  -}
-lockContent :: Key -> (ContentLock -> Annex a) -> Annex a
+lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a
-lockContent key a = do
+lockContentShared key a = lockContentUsing lock key $ do
+	u <- getUUID
+	withVerifiedCopy LockedCopy u (return True) a
+  where
+#ifndef mingw32_HOST_OS
+	lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile
+	lock _ (Just lockfile) = posixLocker tryLockShared lockfile
+#else
+	lock = winLocker lockShared
+#endif
+
+{- Exclusively locks content, while performing an action that
+ - might remove it.
+ -}
+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
+	 - to fiddle with permissions to open for an exclusive lock. -}
+	lock contentfile Nothing = bracket_
+		(thawContent contentfile)
+		(freezeContent contentfile)
+		(liftIO $ tryLockExclusive Nothing contentfile)
+	lock _ (Just lockfile) = posixLocker tryLockExclusive lockfile
+#else
+	lock = winLocker lockExclusive
+#endif
+
+{- Passed the object content file, and maybe a separate lock file to use,
+ - when the content file itself should not be locked. -}
+type ContentLocker = FilePath -> Maybe LockFile -> Annex (Maybe LockHandle)
+
+#ifndef mingw32_HOST_OS
+posixLocker :: (Maybe FileMode -> LockFile -> IO (Maybe LockHandle)) -> LockFile -> Annex (Maybe LockHandle)
+posixLocker takelock lockfile = do
+	mode <- annexFileMode
+	modifyContent lockfile $
+		liftIO $ takelock (Just mode) lockfile
+	
+#else
+winLocker :: (LockFile -> IO (Maybe LockHandle)) -> ContentLocker
+winLocker takelock _ (Just lockfile) = do
+	modifyContent lockfile $
+		void $ liftIO $ tryIO $
+			writeFile lockfile ""
+	liftIO $ takelock lockfile
+-- never reached; windows always uses a separate lock file
+winLocker _ _ Nothing = return Nothing
+#endif
+
+lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a
+lockContentUsing locker key a = do
 	contentfile <- calcRepo $ gitAnnexLocation key
 	lockfile <- contentLockFile key
 	bracket
 		(lock contentfile lockfile)
 		(unlock lockfile)
-		(const $ a $ ContentLock key )
+		(const a)
   where
 	alreadylocked = error "content is locked"
-	cleanuplockfile lockfile = modifyContent lockfile $
+	failedtolock e = error $ "failed to lock content: " ++ show e
-		void $ liftIO $ tryIO $
+
-			nukeFile lockfile
+	lock contentfile lockfile =
-#ifndef mingw32_HOST_OS
-	{- Since content files are stored with the write bit disabled, have
-	 - to fiddle with permissions to open for an exclusive lock. -}
-	lock contentfile Nothing = trylock $ bracket_
-		(thawContent contentfile)
-		(freezeContent contentfile)
 		(maybe alreadylocked return 
-			=<< liftIO (tryLockExclusive Nothing contentfile))
+			=<< locker contentfile lockfile)
-	lock _ (Just lockfile) = trylock $ do
+		`catchIO` failedtolock
-		mode <- annexFileMode
+
-		maybe alreadylocked return 
+#ifndef mingw32_HOST_OS
-			=<< modifyContent lockfile
-				(liftIO $ tryLockExclusive (Just mode) lockfile)
 	unlock mlockfile lck = do
 		maybe noop cleanuplockfile mlockfile
 		liftIO $ dropLock lck
-	
-	failedtolock e = error $ "failed to lock content: " ++ show e
-	trylock locker = locker `catchIO` failedtolock
 #else
-	lock _ (Just lockfile) = do
-		modifyContent lockfile $
-			void $ liftIO $ tryIO $
-				writeFile lockfile ""
-		maybe alreadylocked (return . Just)
-			=<< liftIO (lockExclusive lockfile)
-	-- never reached; windows always uses a separate lock file
-	lock _ Nothing = return Nothing
 	unlock mlockfile mlockhandle = do
 		liftIO $ maybe noop dropLock mlockhandle
 		maybe noop cleanuplockfile mlockfile
 #endif
 
+	cleanuplockfile lockfile = modifyContent lockfile $
+		void $ liftIO $ tryIO $
+			nukeFile lockfile
+
 {- Runs an action, passing it the temp file to get,
  - and if the action succeeds, verifies the file matches
  - the key and moves the file into the annex as a key's content. -}
@@ -497,8 +546,8 @@ cleanObjectLoc key cleaner = do
  - In direct mode, deletes the associated files or files, and replaces
  - them with symlinks.
  -}
-removeAnnex :: ContentLock -> Annex ()
+removeAnnex :: ContentRemovalLock -> Annex ()
-removeAnnex (ContentLock key) = withObjectLoc key remove removedirect
+removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect
   where
 	remove file = cleanObjectLoc key $ do
 		secureErase file

Annex/Drop.hs

@@ -32,9 +32,8 @@ type Reason = String
  - only ones that match the UUIDs will be dropped from.
  - If allowed to drop fromhere, that drop will be tried first.
  -
- - A remote can be specified that is known to have the key. This can be
+ - A VerifiedCopy can be provided as an optimisation when eg, a key
- - used an an optimisation when eg, a key has just been uploaded to a
+ - has just been uploaded to a remote.
- - remote.
  -
  - In direct mode, all associated files are checked, and only if all
  - of them are unwanted are they dropped.
@@ -42,8 +41,8 @@ type Reason = String
  - The runner is used to run commands, and so can be either callCommand
  - or commandAction.
  -}
-handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> (CommandStart -> CommandCleanup) -> Annex ()
+handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
-handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
+handleDropsFrom locs rs reason fromhere key afile preverified runner = do
 	fs <- ifM isDirect
 		( do
 			l <- associatedFilesRelative key
@@ -112,7 +111,7 @@ handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
 			)
 
 	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
-		Command.Drop.startLocal afile numcopies key knownpresentremote
+		Command.Drop.startLocal afile numcopies key preverified
 
 	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
 		Command.Drop.startRemote afile numcopies key r

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,
@@ -15,8 +17,9 @@ module Annex.NumCopies (
 	defaultNumCopies,
 	numCopiesCheck,
 	numCopiesCheck',
-	verifyEnoughCopies,
+	verifyEnoughCopiesToDrop,
-	knownCopies,
+	verifiableCopies,
+	UnVerifiedCopy(..),
 ) where
 
 import Common.Annex
@@ -26,8 +29,13 @@ import Logs.NumCopies
 import Logs.Trust
 import Annex.CheckAttr
 import qualified Remote
-import Annex.UUID
+import qualified Types.Remote as Remote
 import Annex.Content
+import Annex.UUID
+
+import Control.Exception
+import qualified Control.Monad.Catch as M
+import Data.Typeable
 
 defaultNumCopies :: NumCopies
 defaultNumCopies = NumCopies 1
@@ -77,7 +85,11 @@ getFileNumCopies' file = maybe getGlobalNumCopies (return . Just) =<< getattr
 
 {- Checks if numcopies are satisfied for a file by running a comparison
  - between the number of (not untrusted) copies that are
- - belived to exist, and the configured value. -}
+ - belived to exist, and the configured value.
+ -
+ - This is good enough for everything except dropping the file, which
+ - requires active verification of the copies.
+ -}
 numCopiesCheck :: FilePath -> Key -> (Int -> Int -> v) -> Annex v
 numCopiesCheck file key vs = do
 	have <- trustExclude UnTrusted =<< Remote.keyLocations key
@@ -88,60 +100,118 @@ numCopiesCheck' file vs have = do
 	NumCopies needed <- getFileNumCopies file
 	return $ length have `vs` needed
 
+data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere
+	deriving (Ord, Eq)
+
 {- Verifies that enough copies of a key exist amoung the listed remotes,
- - priting an informative message if not.
+ - to safely drop it, 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
+	-> Maybe ContentRemovalLock
 	-> NumCopies
 	-> [UUID] -- repos to skip considering (generally untrusted remotes)
-	-> [UUID] -- repos that are trusted or already verified to have it
+	-> [VerifiedCopy] -- copies already verified to exist
-	-> [Remote] -- remotes to check to see if they have it
+	-> [UnVerifiedCopy] -- places to check to see if they have copies
-	-> Annex Bool
+	-> (SafeDropProof -> Annex a) -- action to perform the drop
-verifyEnoughCopies nolocmsg key need skip trusted tocheck = 
+	-> Annex a -- action to perform when unable to drop
-	helper [] [] (nub trusted) (nub tocheck)
+	-> Annex a
+verifyEnoughCopiesToDrop nolocmsg key removallock 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 removallock
-		| otherwise = do
+		case p of
-			notEnoughCopies key need have (skip++missing) bad nolocmsg
+			Right proof -> dropaction proof
-			return False
+			Left stillhave -> do
-	helper bad missing have (r:rs)
+				notEnoughCopies key need stillhave (skip++missing) bad nolocmsg
-		| NumCopies (length have) >= need = return True
+				nodropaction
-		| otherwise = do
+	helper bad missing have (c:cs)
-			let u = Remote.uuid r
+		| isSafeDrop need have removallock = do
-			let duplicate = u `elem` have
+			p <- liftIO $ mkSafeDropProof need have removallock
-			haskey <- Remote.hasKey r key
+			case p of
-			case (duplicate, haskey) of
+				Right proof -> dropaction proof
-				(False, Right True)  -> helper bad missing (u:have) rs
+				Left stillhave -> helper bad missing stillhave (c:cs)
-				(False, Left _)      -> helper (r:bad) missing have rs
+		| otherwise = case c of
-				(False, Right False) -> helper bad (u:missing) have rs
+			UnVerifiedHere -> lockContentShared key contverified
-				_                    -> helper bad missing have rs
+			UnVerifiedRemote r -> checkremote r contverified $ do
+				haskey <- Remote.hasKey r key
+				case haskey of
+					Right True  -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs
+					Left _      -> helper (r:bad) missing have cs
+					Right False -> helper bad (Remote.uuid r:missing) have cs
+		  where
+			contverified vc = helper bad missing (vc : have) cs
 
-notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> String -> Annex ()
+	checkremote r cont fallback = case Remote.lockContent r of
+		Just lockcontent -> do
+			-- The remote's lockContent will throw an exception
+			-- when it is unable to lock, in which case the
+			-- fallback should be run. 
+			--
+			-- On the other hand, the continuation could itself
+			-- throw an exception (ie, the eventual drop action
+			-- fails), and in this case we don't want to run 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 $ \v -> 
+				cont v `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
+
+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"
-	showLongNote $
+	if length have < fromNumCopies need
-		"Could only verify the existence of " ++
+		then showLongNote $
-		show (length have) ++ " out of " ++ show (fromNumCopies need) ++ 
+			"Could only verify the existence of " ++
-		" necessary copies"
+			show (length have) ++ " out of " ++ show (fromNumCopies need) ++ 
+			" necessary copies"
+		else do
+			showLongNote "Unable to lock down 1 copy of file that is required to safely drop it."
+			showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)"
 	Remote.showTriedRemotes bad
-	Remote.showLocations True key (have++skip) nolocmsg
+	Remote.showLocations True key (map toUUID have++skip) nolocmsg
 
-{- Cost ordered lists of remotes that the location log indicates
+{- Finds locations of a key that can be used to get VerifiedCopies,
- - may have a key.
+ - in order to allow dropping the key.
  -
- - Also returns a list of UUIDs that are trusted to have the key
+ - Provide a list of UUIDs that the key is being dropped from.
- - (some may not have configured remotes). If the current repository
+ - The returned lists will exclude any of those UUIDs.
- - currently has the key, and is not untrusted, it is included in this list.
+ -
+ - The return lists also exclude any repositories that are untrusted,
+ - since those should not be used for verification.
+ -
+ - The UnVerifiedCopy list is cost ordered.
+ - The VerifiedCopy list contains repositories that are trusted to
+ - contain the key.
  -}
-knownCopies :: Key -> Annex ([Remote], [UUID])
+verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy])
-knownCopies key = do
+verifiableCopies key exclude = do
-	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+	locs <- Remote.keyLocations key
+	(remotes, trusteduuids) <- Remote.remoteLocations locs
+		=<< trustGet Trusted
+	untrusteduuids <- trustGet UnTrusted
+	let exclude' = exclude ++ untrusteduuids
+	let remotes' = Remote.remotesWithoutUUID remotes (exclude' ++ trusteduuids)
+	let verified = map (mkVerifiedCopy TrustedCopy) $
+		filter (`notElem` exclude') trusteduuids
 	u <- getUUID
-	trusteduuids' <- ifM (inAnnex key <&&> (<= SemiTrusted) <$> lookupTrust u)
+	let herec = if u `elem` locs && u `notElem` exclude'
-		( pure (u:trusteduuids)
+		then [UnVerifiedHere]
-		, pure trusteduuids
+		else []
-		)
+	return (herec ++ map UnVerifiedRemote remotes', verified)
-	return (remotes, trusteduuids')

Annex/Perms.hs

@@ -24,8 +24,6 @@ import Git.SharedRepository
 import qualified Annex
 import Config
 
-import System.Posix.Types
-
 withShared :: (SharedRepository -> Annex a) -> Annex a
 withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
 

Assistant/Drop.hs

@@ -15,11 +15,12 @@ import Assistant.DaemonStatus
 import Annex.Drop (handleDropsFrom, Reason)
 import Logs.Location
 import CmdLine.Action
+import Types.NumCopies
 
 {- Drop from local and/or remote when allowed by the preferred content and
  - numcopies settings. -}
-handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
+handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> Assistant ()
-handleDrops reason fromhere key f knownpresentremote = do
+handleDrops reason fromhere key f preverified = do
 	syncrs <- syncDataRemotes <$> getDaemonStatus
 	locs <- liftAnnex $ loggedLocations key
-	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommandAction
+	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f preverified callCommandAction

Assistant/Threads/Committer.hs

@@ -479,7 +479,7 @@ checkChangeContent change@(Change { changeInfo = i }) =
 			void $ if present
 				then queueTransfers "new file created" Next k (Just f) Upload
 				else queueTransfers "new or renamed file wanted" Next k (Just f) Download
-			handleDrops "file renamed" present k (Just f) Nothing
+			handleDrops "file renamed" present k (Just f) []
   where
 	f = changeFile change
 checkChangeContent _ = noop

Assistant/Threads/SanityChecker.hs

@@ -191,7 +191,7 @@ dailyCheck urlrenderer = do
 	void $ liftAnnex $ setUnusedKeys unused
 	forM_ unused $ \k -> do
 		unlessM (queueTransfers "unused" Later k Nothing Upload) $
-			handleDrops "unused" True k Nothing Nothing
+			handleDrops "unused" True k Nothing []
 
 	return True
   where

Assistant/Threads/TransferScanner.hs

@@ -157,7 +157,7 @@ expensiveScan urlrenderer rs = batch <~> do
 		present <- liftAnnex $ inAnnex key
 		liftAnnex $ handleDropsFrom locs syncrs
 			"expensive scan found too many copies of object"
-			present key (Just f) Nothing callCommandAction
+			present key (Just f) [] callCommandAction
 		liftAnnex $ do
 			let slocs = S.fromList locs
 			let use a = return $ mapMaybe (a key slocs) syncrs

Assistant/TransferSlots.hs

@@ -30,6 +30,7 @@ import Annex.Content
 import Annex.Wanted
 import Annex.Path
 import Utility.Batch
+import Types.NumCopies
 
 import qualified Data.Map as M 
 import qualified Control.Exception as E
@@ -160,7 +161,7 @@ genTransfer t info = case transferRemote info of
 					("object uploaded to " ++ show remote)
 					True (transferKey t)
 					(associatedFile info)
-					(Just remote)
+					[mkVerifiedCopy RecentlyVerifiedCopy remote]
 			void recordCommit
 		, whenM (liftAnnex $ isNothing <$> checkTransfer t) $
 			void $ removeTransfer t
@@ -225,7 +226,7 @@ finishedTransfer t (Just info)
   where
 	dodrops fromhere = handleDrops
 		("drop wanted after " ++ describeTransfer t info)
-		fromhere (transferKey t) (associatedFile info) Nothing
+		fromhere (transferKey t) (associatedFile info) []
 finishedTransfer _ _ = noop
 
 {- Pause a running transfer. -}

Assistant/Unused.hs

@@ -77,7 +77,7 @@ expireUnused duration = do
 	forM_ oldkeys $ \k -> do
 		debug ["removing old unused key", key2file k]
 		liftAnnex $ do
-			lockContent k removeAnnex
+			lockContentForRemoval k removeAnnex
 			logStatus k InfoMissing
   where
 	boundry = durationToPOSIXTime <$> duration

Assistant/Upgrade.hs

@@ -97,7 +97,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
 		, transferKey = k
 		}
 	cleanup = liftAnnex $ do
-		lockContent k removeAnnex
+		lockContentForRemoval k removeAnnex
 		setUrlMissing webUUID k u
 		logStatus k InfoMissing
 

CmdLine/GitAnnexShell.hs

@@ -20,6 +20,7 @@ import Remote.GCrypt (getGCryptUUID)
 
 import qualified Command.ConfigList
 import qualified Command.InAnnex
+import qualified Command.LockContent
 import qualified Command.DropKey
 import qualified Command.RecvKey
 import qualified Command.SendKey
@@ -32,6 +33,7 @@ cmds_readonly :: [Command]
 cmds_readonly =
 	[ Command.ConfigList.cmd
 	, gitAnnexShellCheck Command.InAnnex.cmd
+	, gitAnnexShellCheck Command.LockContent.cmd
 	, gitAnnexShellCheck Command.SendKey.cmd
 	, gitAnnexShellCheck Command.TransferInfo.cmd
 	, gitAnnexShellCheck Command.NotifyChanges.cmd

Command/Drop.hs

@@ -20,6 +20,7 @@ import Annex.Content
 import Annex.Wanted
 import Annex.Notification
 
+import System.Log.Logger (debugM)
 import qualified Data.Set as S
 
 cmd :: Command
@@ -64,11 +65,11 @@ start' o key afile = do
 	checkDropAuto (autoMode o) from afile key $ \numcopies ->
 		stopUnless (want from) $
 			case from of
-				Nothing -> startLocal afile numcopies key Nothing
+				Nothing -> startLocal afile numcopies key []
 				Just remote -> do
 					u <- getUUID
 					if Remote.uuid remote == u
-						then startLocal afile numcopies key Nothing
+						then startLocal afile numcopies key []
 						else startRemote afile numcopies key remote
 	  where
 		want from
@@ -78,35 +79,31 @@ start' o key afile = do
 startKeys :: DropOptions -> Key -> CommandStart
 startKeys o key = start' o key Nothing
 
-startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart
+startLocal :: AssociatedFile -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart
-startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do
+startLocal afile numcopies key preverified = stopUnless (inAnnex key) $ do
 	showStart' "drop" key afile
-	next $ performLocal key afile numcopies knownpresentremote
+	next $ performLocal key afile numcopies preverified
 
 startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart
 startRemote afile numcopies key remote = do
 	showStart' ("drop " ++ Remote.name remote) key afile
 	next $ performRemote key afile numcopies remote
 
--- Note that lockContent is called before checking if the key is present
+performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
--- on enough remotes to allow removal. This avoids a scenario where two
+performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do
--- or more remotes are trying to remove a key at the same time, and each
--- see the key is present on the other.
-performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform
-performLocal key afile numcopies knownpresentremote = lockContent key $ \contentlock -> do
-	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
-	let trusteduuids' = case knownpresentremote of
-		Nothing -> trusteduuids
-		Just r -> Remote.uuid r:trusteduuids
-	untrusteduuids <- trustGet UnTrusted
-	let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids)
 	u <- getUUID
-	ifM (canDrop u key afile numcopies trusteduuids' tocheck [])
+	(tocheck, verified) <- verifiableCopies key [u]
-		( do
+	doDrop u (Just contentlock) key afile numcopies [] (preverified ++ verified) tocheck
+		( \proof -> do
+			liftIO $ debugM "drop" $ unwords
+				[ "Dropping from here"
+				, "proof:"
+				, show proof
+				]
 			removeAnnex contentlock
 			notifyDrop afile True
 			next $ cleanupLocal key
-		, do
+		, do 
 			notifyDrop afile False
 			stop
 		)
@@ -117,14 +114,19 @@ performRemote key afile numcopies remote = do
 	-- places assumed to have the key, and places to check.
 	-- When the local repo has the key, that's one additional copy,
 	-- as long as the local repo is not untrusted.
-	(remotes, trusteduuids) <- knownCopies key
+	(tocheck, verified) <- verifiableCopies key [uuid]
-	let have = filter (/= uuid) trusteduuids
+	doDrop uuid Nothing key afile numcopies [uuid] verified tocheck
-	untrusteduuids <- trustGet UnTrusted
+		( \proof -> do 
-	let tocheck = filter (/= remote) $
+			liftIO $ debugM "drop" $ unwords
-		Remote.remotesWithoutUUID remotes (have++untrusteduuids)
+				[ "Dropping from remote"
-	stopUnless (canDrop uuid key afile numcopies have tocheck [uuid]) $ do
+				, show remote
-		ok <- Remote.removeKey remote key
+				, "proof:"
-		next $ cleanupRemote key remote ok
+				, show proof
+				]
+			ok <- Remote.removeKey remote key
+			next $ cleanupRemote key remote ok
+		, stop
+		)
   where
 	uuid = Remote.uuid remote
 
@@ -139,30 +141,42 @@ 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). Can be provided with
+ - verify that enough copies of a key exist to allow it to be
- - some locations where the key is known/assumed to be present.
+ - 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] -> [Remote] -> [UUID] -> Annex Bool
+doDrop
-canDrop dropfrom key afile numcopies have check skip = 
+	:: UUID
+	-> Maybe ContentRemovalLock
+	-> Key
+	-> AssociatedFile
+	-> NumCopies
+	-> [UUID]
+	-> [VerifiedCopy]
+	-> [UnVerifiedCopy]
+	-> (Maybe SafeDropProof -> CommandPerform, CommandPerform)
+	-> CommandPerform
+doDrop dropfrom contentlock key afile numcopies skip preverified check (dropaction, nodropaction) = 
 	ifM (Annex.getState Annex.force)
-		( return True
+		( dropaction Nothing
-			, ifM (checkRequiredContent dropfrom key afile
+		, ifM (checkRequiredContent dropfrom key afile)
-				<&&> verifyEnoughCopies nolocmsg key numcopies skip have check
+			( verifyEnoughCopiesToDrop nolocmsg key 
-				)
+				contentlock numcopies
-				( return True
+				skip preverified check
-				, do
+					(dropaction . Just)
-					hint
+					(forcehint nodropaction)
-					return False
+			, stop
-				)
+			)
 		)
   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/DropKey.hs

@@ -31,7 +31,7 @@ start key = stopUnless (inAnnex key) $ do
 	next $ perform key
 
 perform :: Key -> CommandPerform
-perform key = lockContent key $ \contentlock -> do
+perform key = lockContentForRemoval key $ \contentlock -> do
 	removeAnnex contentlock
 	next $ cleanup key
 

Command/DropUnused.hs

@@ -44,7 +44,7 @@ perform from numcopies key = case from of
 	Just r -> do
 		showAction $ "from " ++ Remote.name r
 		Command.Drop.performRemote key Nothing numcopies r
-	Nothing -> Command.Drop.performLocal key Nothing numcopies Nothing
+	Nothing -> Command.Drop.performLocal key Nothing numcopies []
 
 performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
 performOther filespec key = do

Command/Import.hs

@@ -19,8 +19,6 @@ import Types.KeySource
 import Types.Key
 import Annex.CheckIgnore
 import Annex.NumCopies
-import Types.TrustLevel
-import Logs.Trust
 
 cmd :: Command
 cmd = withGlobalOptions fileMatchingOptions $ notBareRepo $
@@ -83,7 +81,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,13 +132,12 @@ 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
 
-	(remotes, trusteduuids) <- knownCopies key
+	(tocheck, preverified) <- verifiableCopies key []
-	untrusteduuids <- trustGet UnTrusted
+	verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck
-	let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
+		(const yes) no
-	verifyEnoughCopies [] key need [] trusteduuids tocheck

Command/LockContent.hs

@@ -0,0 +1,46 @@
+{- git-annex-shell command
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.LockContent where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Types.Key
+import Remote.Helper.Ssh (contentLockedMarker)
+
+cmd :: Command
+cmd = noCommit $ 
+	command "lockcontent" SectionPlumbing 
+		"locks key's content in the annex, preventing it being dropped"
+		paramKey
+		(withParams seek)
+
+seek :: CmdParams -> CommandSeek
+seek = withWords start
+
+-- First, lock the content. Then, make sure the content is actually
+-- present, and print out a "1". Wait for the caller to send a line before
+-- dropping the lock.
+start :: [String] -> CommandStart
+start [ks] = do
+	ok <- lockContentShared k (const locksuccess)
+		`catchNonAsync` (const $ return False)
+	liftIO $ if ok
+		then exitSuccess
+		else exitFailure
+  where
+	k = fromMaybe (error "bad key") (file2key ks)
+	locksuccess = ifM (inAnnex k)
+		( liftIO $ do
+			putStrLn contentLockedMarker
+			hFlush stdout
+			_ <- getLine
+			return True
+		, return False
+		)
+start _ = error "Specify exactly 1 key."

Command/Mirror.hs

@@ -65,7 +65,7 @@ startKey o afile key = case fromToOptions o of
 			Right False -> ifM (inAnnex key)
 				( do
 					numcopies <- getnumcopies
-					Command.Drop.startLocal afile numcopies key Nothing
+					Command.Drop.startLocal afile numcopies key []
 				, stop
 				)
   where

Command/Move.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -16,6 +16,9 @@ import qualified Remote
 import Annex.UUID
 import Annex.Transfer
 import Logs.Presence
+import Annex.NumCopies
+
+import System.Log.Logger (debugM)
 
 cmd :: Command
 cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $
@@ -123,7 +126,7 @@ toPerform dest move key afile fastcheck isthere =
 			finish
   where
 	finish
-		| move = lockContent key $ \contentlock -> do
+		| move = lockContentForRemoval key $ \contentlock -> do
 			removeAnnex contentlock
 			next $ Command.Drop.cleanupLocal key
 		| otherwise = next $ return True
@@ -170,6 +173,18 @@ fromPerform src move key afile = ifM (inAnnex key)
 				Remote.retrieveKeyFile src key afile t p
 	dispatch _ False = stop -- failed
 	dispatch False True = next $ return True -- copy complete
-	dispatch True True = do -- finish moving
+	-- Finish by dropping from remote, taking care to verify that
+	-- the copy here has not been lost somehow. 
+	-- (NumCopies is 1 since we're moving.)
+	dispatch True True = verifyEnoughCopiesToDrop "" key Nothing
+		(NumCopies 1) [] [] [UnVerifiedHere] dropremote faileddropremote
+	dropremote proof = do
+		liftIO $ debugM "drop" $ unwords
+			[ "Dropping from remote"
+			, show src
+			, "proof:"
+			, show proof
+			]
 		ok <- Remote.removeKey src key
 		next $ Command.Drop.cleanupRemote key src ok
+	faileddropremote = error "Unable to drop from remote."

Command/Sync.hs

@@ -460,8 +460,8 @@ syncFile ebloom rs af k = do
 		-- includeCommandAction for drops,
 		-- because a failure to drop does not mean
 		-- the sync failed.
-		handleDropsFrom locs' rs "unwanted" True k af
+		handleDropsFrom locs' rs "unwanted" True k af []
-			Nothing callCommandAction
+			callCommandAction
 	
 	return (got || not (null putrs))
   where

Command/TestRemote.hs

@@ -120,7 +120,7 @@ test st r k =
 	, check "storeKey when already present" store
 	, present True
 	, check "retrieveKeyFile" $ do
-		lockContent 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
-		lockContent k removeAnnex
+		lockContentForRemoval k removeAnnex
 		get
 	, check "fsck downloaded object" fsck
 	, check "retrieveKeyFile resume from 0" $ do
 		tmp <- prepTmp k
 		liftIO $ writeFile tmp ""
-		lockContent 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
-		lockContent 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 -> lockContent k removeAnnex
+	forM_ ks $ \k -> lockContentForRemoval k removeAnnex
 	return ok
 
 chunkSizes :: Int -> Bool -> [Int]

Command/Uninit.hs

@@ -105,7 +105,7 @@ removeUnannexed = go []
 	go c [] = return c
 	go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks)
 		( do
-			lockContent k removeAnnex
+			lockContentForRemoval k removeAnnex
 			go c ks
 		, go (k:c) ks
 		)

Remote.hs

@@ -40,7 +40,7 @@ module Remote (
 	remotesWithoutUUID,
 	keyLocations,
 	keyPossibilities,
-	keyPossibilitiesTrusted,
+	remoteLocations,
 	nameToUUID,
 	nameToUUID',
 	showTriedRemotes,
@@ -260,33 +260,26 @@ keyLocations key = trustExclude DeadTrusted =<< loggedLocations key
  - may have a key.
  -}
 keyPossibilities :: Key -> Annex [Remote]
-keyPossibilities key = fst <$> keyPossibilities' key []
+keyPossibilities key = do
-
-{- Cost ordered lists of remotes that the location log indicates
- - may have a key.
- -
- - Also returns a list of UUIDs that are trusted to have the key
- - (some may not have configured remotes).
- -}
-keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID])
-keyPossibilitiesTrusted key = keyPossibilities' key =<< trustGet Trusted
-
-keyPossibilities' :: Key -> [UUID] -> Annex ([Remote], [UUID])
-keyPossibilities' key trusted = do
 	u <- getUUID
-
 	-- uuids of all remotes that are recorded to have the key
-	validuuids <- filter (/= u) <$> keyLocations key
+	locations <- filter (/= u) <$> keyLocations key
+	fst <$> remoteLocations locations []
 
-	-- note that validuuids is assumed to not have dups
+{- Given a list of locations of a key, and a list of all
-	let validtrusteduuids = validuuids `intersect` trusted
+ - trusted repositories, generates a cost-ordered list of
+ - remotes that contain the key, and a list of trusted locations of the key.
+ -}
+remoteLocations :: [UUID] -> [UUID] -> Annex ([Remote], [UUID])
+remoteLocations locations trusted = do
+	let validtrustedlocations = nub locations `intersect` trusted
 
 	-- remotes that match uuids that have the key
 	allremotes <- filter (not . remoteAnnexIgnore . gitconfig)
 		<$> remoteList
-	let validremotes = remotesWithUUID allremotes validuuids
+	let validremotes = remotesWithUUID allremotes locations
 
-	return (sortBy (comparing cost) validremotes, validtrusteduuids)
+	return (sortBy (comparing cost) validremotes, validtrustedlocations)
 
 {- Displays known locations of a key. -}
 showLocations :: Bool -> Key -> [UUID] -> String -> Annex ()

Remote/BitTorrent.hs

@@ -58,6 +58,7 @@ gen r _ c gc =
 		, retrieveKeyFile = downloadKey
 		, retrieveKeyFileCheap = downloadKeyCheap
 		, removeKey = dropKey
+		, lockContent = Nothing
 		, checkPresent = checkKey
 		, checkPresentCheap = False
 		, whereisKey = Nothing

Remote/Bup.hs

@@ -58,6 +58,7 @@ gen r u c gc = do
 		, retrieveKeyFile = retreiveKeyFileDummy
 		, retrieveKeyFileCheap = retrieveCheap buprepo
 		, removeKey = removeKeyDummy
+		, lockContent = Nothing
 		, checkPresent = checkPresentDummy
 		, checkPresentCheap = bupLocal buprepo
 		, whereisKey = Nothing

Remote/Ddar.hs

@@ -57,6 +57,7 @@ gen r u c gc = do
 		, retrieveKeyFile = retreiveKeyFileDummy
 		, retrieveKeyFileCheap = retrieveCheap
 		, removeKey = removeKeyDummy
+		, lockContent = Nothing
 		, checkPresent = checkPresentDummy
 		, checkPresentCheap = ddarLocal ddarrepo
 		, whereisKey = Nothing

Remote/Directory.hs

@@ -55,6 +55,7 @@ gen r u c gc = do
 			, retrieveKeyFile = retreiveKeyFileDummy
 			, retrieveKeyFileCheap = retrieveCheap dir chunkconfig
 			, removeKey = removeKeyDummy
+			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = True
 			, whereisKey = Nothing

Remote/External.hs

@@ -81,6 +81,7 @@ gen r u c gc
 			, retrieveKeyFile = retreiveKeyFileDummy
 			, retrieveKeyFileCheap = \_ _ _ -> return False
 			, removeKey = removeKeyDummy
+			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
 			, whereisKey = towhereis

Remote/GCrypt.hs

@@ -111,6 +111,7 @@ gen' r u c gc = do
 		, retrieveKeyFile = retreiveKeyFileDummy
 		, retrieveKeyFileCheap = \_ _ _ -> return False
 		, removeKey = removeKeyDummy
+		, lockContent = Nothing
 		, checkPresent = checkPresentDummy
 		, checkPresentCheap = repoCheap r
 		, whereisKey = Nothing

Remote/Git.hs

@@ -53,9 +53,11 @@ import Annex.Path
 import Creds
 import Annex.CatFile
 import Messages.Progress
+import Types.NumCopies
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
+import Control.Concurrent.Async
 import qualified Data.Map as M
 import Network.URI
 
@@ -142,6 +144,7 @@ gen r u c gc
 			, retrieveKeyFile = copyFromRemote new
 			, retrieveKeyFileCheap = copyFromRemoteCheap new
 			, removeKey = dropKey new
+			, lockContent = Just (lockKey new)
 			, checkPresent = inAnnex new
 			, checkPresentCheap = repoCheap r
 			, whereisKey = Nothing
@@ -350,7 +353,7 @@ dropKey r key
 			commitOnCleanup r $ onLocal r $ do
 				ensureInitialized
 				whenM (Annex.Content.inAnnex key) $ do
-					Annex.Content.lockContent key
+					Annex.Content.lockContentForRemoval key
 						Annex.Content.removeAnnex
 					logStatus key InfoMissing
 					Annex.Content.saveState True
@@ -358,6 +361,64 @@ 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 callback
+	| not $ Git.repoIsUrl (repo r) =
+		guardUsable (repo r) failedlock $ do
+			inorigrepo <- Annex.makeRunner
+			-- Lock content from perspective of remote,
+			-- and then run the callback in the original
+			-- annex monad, not the remote's.
+			onLocal r $ 
+				Annex.Content.lockContentShared key $ \vc ->
+					ifM (Annex.Content.inAnnex key)
+						( liftIO $ inorigrepo $ callback vc
+						, failedlock
+						)
+	| Git.repoIsSsh (repo r) = do
+		showLocking r
+		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"
+			[Param $ key2file key] []
+		(Just hin, Just hout, Nothing, p) <- liftIO $ 
+			withFile devNull WriteMode $ \nullh ->
+				createProcess $
+					 (proc cmd (toCommand params))
+						{ std_in = CreatePipe
+						, std_out = CreatePipe
+						, std_err = UseHandle nullh
+						}
+		-- Wait for either the process to exit, or for it to
+		-- indicate the content is locked.
+		v <- liftIO $ race 
+			(waitForProcess p)
+			(hGetLine hout)
+		let signaldone = void $ tryNonAsync $ liftIO $ do
+			hPutStrLn hout ""
+			hFlush hout
+			hClose hin
+			hClose hout
+			void $ waitForProcess p
+		let checkexited = not . isJust <$> getProcessExitCode p
+		case v of
+			Left _exited -> do
+				showNote "lockcontent failed"
+				liftIO $ do
+					hClose hin
+					hClose hout
+				failedlock
+			Right l 
+				| l == Ssh.contentLockedMarker -> bracket_
+					noop
+					signaldone 
+					(withVerifiedCopy LockedCopy r checkexited callback)
+				| otherwise -> do
+					showNote "lockcontent failed"
+					signaldone
+					failedlock
+	| otherwise = failedlock
+  where
+	failedlock = 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 $

Remote/Glacier.hs

@@ -55,6 +55,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			, retrieveKeyFile = retreiveKeyFileDummy
 			, retrieveKeyFileCheap = retrieveCheap this
 			, removeKey = removeKeyDummy
+			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
 			, whereisKey = Nothing

Remote/Helper/Messages.hs

@@ -13,20 +13,23 @@ import Common.Annex
 import qualified Git
 import qualified Types.Remote as Remote
 
-class Checkable a where
+class Describable a where
-	descCheckable :: a -> String
+	describe :: a -> String
 
-instance Checkable Git.Repo where
+instance Describable Git.Repo where
-	descCheckable = Git.repoDescribe
+	describe = Git.repoDescribe
 
-instance Checkable (Remote.RemoteA a) where
+instance Describable (Remote.RemoteA a) where
-	descCheckable = Remote.name
+	describe = Remote.name
 
-instance Checkable String where
+instance Describable String where
-	descCheckable = id
+	describe = id
 
-showChecking :: Checkable a => a -> Annex ()
+showChecking :: Describable a => a -> Annex ()
-showChecking v = showAction $ "checking " ++ descCheckable v
+showChecking v = showAction $ "checking " ++ describe v
 
-cantCheck :: Checkable a => a -> e
+cantCheck :: Describable a => a -> e
-cantCheck v = error $ "unable to check " ++ descCheckable v
+cantCheck v = error $ "unable to check " ++ describe v
+
+showLocking :: Describable a => a -> Annex ()
+showLocking v = showAction $ "locking " ++ describe v

Remote/Helper/Ssh.hs

@@ -173,3 +173,8 @@ rsyncParams r direction = do
 		| direction == Download = remoteAnnexRsyncDownloadOptions gc
 		| otherwise = remoteAnnexRsyncUploadOptions gc
 	gc = gitconfig r
+
+-- Used by git-annex-shell lockcontent to indicate the content is
+-- successfully locked.
+contentLockedMarker :: String
+contentLockedMarker = "OK"

Remote/Hook.hs

@@ -49,6 +49,7 @@ gen r u c gc = do
 			, retrieveKeyFile = retreiveKeyFileDummy
 			, retrieveKeyFileCheap = retrieveCheap hooktype
 			, removeKey = removeKeyDummy
+			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
 			, whereisKey = Nothing

Remote/Rsync.hs

@@ -70,6 +70,7 @@ gen r u c gc = do
 			, retrieveKeyFile = retreiveKeyFileDummy
 			, retrieveKeyFileCheap = retrieveCheap o
 			, removeKey = removeKeyDummy
+			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
 			, whereisKey = Nothing

Remote/S3.hs

@@ -81,6 +81,7 @@ gen r u c gc = do
 			, retrieveKeyFile = retreiveKeyFileDummy
 			, retrieveKeyFileCheap = retrieveCheap
 			, removeKey = removeKeyDummy
+			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
 			, whereisKey = Just (getWebUrls info)

Remote/Tahoe.hs

@@ -72,6 +72,7 @@ gen r u c gc = do
 		, retrieveKeyFile = retrieve u hdl
 		, retrieveKeyFileCheap = \_ _ _ -> return False
 		, removeKey = remove
+		, lockContent = Nothing
 		, checkPresent = checkKey u hdl
 		, checkPresentCheap = False
 		, whereisKey = Nothing

Remote/Web.hs

@@ -52,6 +52,7 @@ gen r _ c gc =
 		, retrieveKeyFile = downloadKey
 		, retrieveKeyFileCheap = downloadKeyCheap
 		, removeKey = dropKey
+		, lockContent = Nothing
 		, checkPresent = checkKey
 		, checkPresentCheap = False
 		, whereisKey = Nothing

Remote/WebDAV.hs

@@ -60,6 +60,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			, retrieveKeyFile = retreiveKeyFileDummy
 			, retrieveKeyFileCheap = retrieveCheap
 			, removeKey = removeKeyDummy
+			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
 			, whereisKey = Nothing

Types/NumCopies.hs

@@ -1,14 +1,178 @@
-{- git-annex numcopies type
+{- 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.
  -}
 
-module Types.NumCopies where
+module Types.NumCopies (
+	NumCopies(..),
+	fromNumCopies,
+	VerifiedCopy(..),
+	checkVerifiedCopy,
+	invalidateVerifiedCopy,
+	strongestVerifiedCopy,
+	deDupVerifiedCopies,
+	mkVerifiedCopy,
+	invalidatableVerifiedCopy,
+	withVerifiedCopy,
+	isSafeDrop,
+	SafeDropProof,
+	mkSafeDropProof,
+	ContentRemovalLock(..),
+) where
+
+import Types.UUID
+import Types.Key
+import Utility.Exception (bracketIO)
+import Utility.Monad
+
+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)
+	deriving (Ord, Eq, Show)
 
 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
+	 - object exists in a repository with the given UUID. -}
+	= RecentlyVerifiedCopy V
+	{- Use when a repository cannot be accessed, but it's
+	 - a trusted repository, which is on record as containing a key
+	 - and is presumably not going to lose its copy. -}
+	| TrustedCopy V
+ 	{- 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 removed by any git-annex process. -}
+	| LockedCopy V
+	deriving (Show)
+
+data V = V
+	{ _getUUID :: UUID
+	, _checkVerifiedCopy :: IO Bool
+	, _invalidateVerifiedCopy :: IO ()
+	}
+
+instance Show V where
+	show v = show (_getUUID v)
+
+instance ToUUID VerifiedCopy where
+	toUUID = _getUUID . toV
+	
+toV :: VerifiedCopy -> V
+toV (TrustedCopy v) = v
+toV (RecentlyVerifiedCopy v) = v
+toV (LockedCopy v) = v
+
+-- Checks that it's still valid.
+checkVerifiedCopy :: VerifiedCopy -> IO Bool
+checkVerifiedCopy = _checkVerifiedCopy . toV
+
+invalidateVerifiedCopy :: VerifiedCopy -> IO ()
+invalidateVerifiedCopy = _invalidateVerifiedCopy . toV
+
+strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy
+strongestVerifiedCopy a@(LockedCopy _) _ = a
+strongestVerifiedCopy _ b@(LockedCopy _) = b
+strongestVerifiedCopy a@(TrustedCopy _) _ = a
+strongestVerifiedCopy _ b@(TrustedCopy _) = b
+strongestVerifiedCopy a@(RecentlyVerifiedCopy _) _ = a
+
+-- Retains stronger verifications over weaker for the same uuid.
+deDupVerifiedCopies :: [VerifiedCopy] -> [VerifiedCopy]
+deDupVerifiedCopies l = M.elems $
+	M.fromListWith strongestVerifiedCopy (zip (map toUUID l) l)
+
+mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy
+mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ())
+
+invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO Bool -> IO VerifiedCopy
+invalidatableVerifiedCopy mk u check = do
+	v <- newEmptyMVar
+	let invalidate = do
+		_ <- tryPutMVar v ()
+		return ()
+	let check' = isEmptyMVar v <&&> check
+	return $ mk $ V (toUUID u) check' invalidate
+
+-- Constructs a VerifiedCopy, and runs the action, ensuring that the
+-- verified copy is invalidated when the action returns, or on error.
+withVerifiedCopy 
+	:: (Monad m, MonadMask m, MonadIO m, ToUUID u)
+	=> (V -> VerifiedCopy)
+	-> u
+	-> IO Bool
+	-> (VerifiedCopy -> m a)
+	-> m a
+withVerifiedCopy mk u check = bracketIO setup cleanup
+  where
+	setup = invalidatableVerifiedCopy mk u check
+	cleanup = invalidateVerifiedCopy
+
+{- Check whether enough verification has been done of copies to allow
+ - dropping content safely.
+ -
+ - 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 that 
+ - all special remotes support locking.
+ -}
+isSafeDrop (NumCopies n) l Nothing
+	| n == 0 = True
+	| otherwise = and
+		[ length (deDupVerifiedCopies l) >= n
+		, any fullVerification l
+		]
+
+fullVerification :: VerifiedCopy -> Bool
+fullVerification (LockedCopy _) = True
+fullVerification (TrustedCopy _) = True
+fullVerification (RecentlyVerifiedCopy _) = False
+
+-- A proof that it's currently safe to drop an object.
+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] -> Maybe ContentRemovalLock -> IO (Either [VerifiedCopy] SafeDropProof)
+mkSafeDropProof need have removallock = do
+	stillhave <- filterM checkVerifiedCopy have
+	return $ if isSafeDrop need stillhave removallock
+		then Right (SafeDropProof need stillhave removallock)
+		else Left stillhave

Types/Remote.hs

@@ -7,6 +7,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE RankNTypes #-}
+
 module Types.Remote
 	( RemoteConfigKey
 	, RemoteConfig
@@ -28,6 +30,7 @@ import Types.GitConfig
 import Types.Availability
 import Types.Creds
 import Types.UrlContents
+import Types.NumCopies
 import Config.Cost
 import Utility.Metered
 import Git.Types
@@ -72,8 +75,14 @@ data RemoteA a = Remote {
 	-- Retrieves a key's contents to a tmp file, if it can be done cheaply.
 	-- It's ok to create a symlink or hardlink.
 	retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool,
-	-- removes a key's contents (succeeds if the contents are not present)
+	-- 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, 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 -> (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,
@@ -125,6 +134,9 @@ instance Eq (RemoteA a) where
 instance Ord (RemoteA a) where
 	compare = comparing uuid
 
+instance ToUUID (RemoteA a) where
+	toUUID = uuid
+
 -- Use Verified when the content of a key is verified as part of a
 -- transfer, and so a separate verification step is not needed.
 data Verification = UnVerified | Verified

Types/UUID.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
 module Types.UUID where
 
 import qualified Data.Map as M
@@ -19,9 +21,15 @@ fromUUID :: UUID -> String
 fromUUID (UUID u) = u
 fromUUID NoUUID = ""
 
-toUUID :: String -> UUID
+class ToUUID a where
-toUUID [] = NoUUID
+	toUUID :: a -> UUID
-toUUID s = UUID s
+
+instance ToUUID UUID where
+	toUUID = id
+
+instance ToUUID String where
+	toUUID [] = NoUUID
+	toUUID s = UUID s
 
 isUUID :: String -> Bool
 isUUID = isJust . U.fromString

Utility/FileMode.hs

@@ -7,7 +7,32 @@
 
 {-# LANGUAGE CPP #-}
 
-module Utility.FileMode where
+module Utility.FileMode (
+	FileMode,
+	modifyFileMode,
+	addModes,
+	removeModes,
+	writeModes,
+	readModes,
+	executeModes,
+	otherGroupModes,
+	preventWrite,
+	allowWrite,
+	allowRead,
+	groupSharedModes,
+	groupWriteRead,
+	checkMode,
+	isSymLink,
+	isExecutable,
+	noUmask,
+	withUmask,
+	combineModes,
+	isSticky,
+	stickyMode,
+	setSticky,
+	writeFileProtected,
+	writeFileProtected'
+) where
 
 import System.IO
 import Control.Monad

Utility/LockFile/Posix.hs

@@ -9,6 +9,7 @@ module Utility.LockFile.Posix (
 	LockHandle,
 	lockShared,
 	lockExclusive,
+	tryLockShared,
 	tryLockExclusive,
 	checkLocked,
 	getLockStatus,
@@ -36,31 +37,43 @@ lockShared = lock ReadLock
 lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
 lockExclusive = lock WriteLock
 
+-- Tries to take a shared lock, but does not block.
+tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
+tryLockShared = tryLock ReadLock
+
 -- Tries to take an exclusive lock, but does not block.
 tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
-tryLockExclusive mode lockfile = do
+tryLockExclusive = tryLock WriteLock
-	l <- openLockFile mode lockfile
+
-	v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
+-- Setting the FileMode allows creation of a new lock file.
+-- If it's Nothing then this only succeeds when the lock file already exists.
+lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle
+lock lockreq mode lockfile = do
+	l <- openLockFile lockreq mode lockfile
+	waitToSetLock l (lockreq, AbsoluteSeek, 0, 0)
+	return (LockHandle l)
+
+-- Tries to take an lock, but does not block.
+tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
+tryLock lockreq mode lockfile = do
+	l <- openLockFile lockreq mode lockfile
+	v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0)
 	case v of
 		Left _ -> do
 			closeFd l
 			return Nothing
 		Right _ -> return $ Just $ LockHandle l
 
--- Setting the FileMode allows creation of a new lock file.
--- If it's Nothing then this only succeeds when the lock file already exists.
-lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle
-lock lockreq mode lockfile = do
-	l <- openLockFile mode lockfile
-	waitToSetLock l (lockreq, AbsoluteSeek, 0, 0)
-	return (LockHandle l)
-
 -- Close on exec flag is set so child processes do not inherit the lock.
-openLockFile :: Maybe FileMode -> LockFile -> IO Fd
+openLockFile :: LockRequest -> Maybe FileMode -> LockFile -> IO Fd
-openLockFile filemode lockfile = do
+openLockFile lockreq filemode lockfile = do
-	l <- openFd lockfile ReadWrite filemode defaultFileFlags
+	l <- openFd lockfile openfor filemode defaultFileFlags
 	setFdOption l CloseOnExec True
 	return l
+  where
+	openfor = case lockreq of
+		ReadLock -> ReadOnly
+		_ -> ReadWrite
 
 -- Returns Nothing when the file doesn't exist, for cases where
 -- that is different from it not being locked.
@@ -81,7 +94,7 @@ getLockStatus lockfile = do
 getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID))
 getLockStatus' lockfile = go =<< catchMaybeIO open
   where
-	open = openFd lockfile ReadOnly Nothing defaultFileFlags
+	open = openLockFile ReadLock Nothing lockfile
 	go Nothing = return Nothing
 	go (Just h) = do
 		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)

Utility/LockPool/Posix.hs

@@ -6,9 +6,11 @@
  -}
 
 module Utility.LockPool.Posix (
+	P.LockFile,
 	LockHandle,
 	lockShared,
 	lockExclusive,
+	tryLockShared,
 	tryLockExclusive,
 	checkLocked,
 	getLockStatus,
@@ -35,11 +37,19 @@ lockShared mode file = makeLockHandle
 	(P.waitTakeLock P.lockPool file LockShared)
 	(F.lockShared mode file)
 
+-- Takes an exclusive lock, blocking until the lock is available.
 lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
 lockExclusive mode file = makeLockHandle
 	(P.waitTakeLock P.lockPool file LockExclusive)
 	(F.lockExclusive mode file)
 
+-- Tries to take a shared lock, but does not block.
+tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
+tryLockShared mode file = tryMakeLockHandle
+	(P.tryTakeLock P.lockPool file LockShared)
+	(F.tryLockShared mode file)
+
+-- Tries to take an exclusive lock, but does not block.
 tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
 tryLockExclusive mode file = tryMakeLockHandle
 	(P.tryTakeLock P.lockPool file LockExclusive)

Utility/LockPool/Windows.hs

@@ -6,6 +6,7 @@
  -}
 
 module Utility.LockPool.Windows (
+	P.LockFile,
 	LockHandle,
 	lockShared,
 	lockExclusive,

debian/changelog

@@ -1,5 +1,19 @@
 git-annex (5.20150931) UNRELEASED; urgency=medium
 
+  * 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
+    a key's content. This is necessary due to the above bugfix.
+  * In some cases, the above bugfix changes what git-annex allows to be dropped:
+    - When a file is present in several special remotes,
+      but not in any accessible git repositories, dropping it from one of
+      the special remotes will now fail. Instead, the file has to be
+      moved from one of the special remotes to the git repository, and can
+      then safely be dropped from the git repository.
+    - If a git remote has too old a version of git-annex-shell installed,
+      git-annex won't trust it to hold onto a copy of a file when dropping
+      that file from some other remote.
   * Do verification of checksums of annex objects downloaded from remotes.
   * When annex objects are received into git repositories from other git
     repos, their checksums are verified then too.
@@ -20,7 +34,7 @@ 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.
-
+    
  -- Joey Hess <id@joeyh.name>  Thu, 01 Oct 2015 12:42:56 -0400
 
 git-annex (5.20150930) unstable; urgency=medium

doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn

@@ -2,6 +2,8 @@ Concurrent dropping of a file has problems when drop --from is
 used. (Also when the assistant or sync --content decided to drop from a
 remote.)
 
+> Now [[fixed|done]] --[[Joey]]
+
 [[!toc]]
 
 # refresher
@@ -73,6 +75,8 @@ as part of its check of numcopies, and keep it locked
 while it's asking B to drop it. Then when B tells A to drop it,
 it'll be locked and that'll fail (and vice-versa).
 
+> Done, and verified the fix works in this situation.
+
 # the bug part 2
 
 <pre>
@@ -116,6 +120,8 @@ Note that this is analgous to the fix above; in both cases
 the change is from checking if content is in a location, to locking it in
 that location while performing a drop from another location.
 
+> Done, and verified the fix works in this situation.
+
 # the bug part 3 (where it gets really nasty)
 
 <pre>
@@ -198,6 +204,9 @@ never entirely lost.
 Dipping below desired numcopies in an unusual race condition, and then
 doing extra work later to recover may be good enough.
 
+> Implemented, and I've now verified this solves the case above.
+> Indeed, neither drop succeeds, because no copy can be locked.
+
 ### to drop from local repo
 
 When dropping an object from the local repo, lock it for drop,
@@ -339,3 +348,22 @@ A drops                    B keeps                    C keeps
 It can race other ways, but they all work out the same way essentially,
 due to the locking.
 </pre>
+
+# the bug, with moves
+
+`git annex move --from remote` is the same as a copy followed by drop --from,
+so the same bug can occur then.
+
+But, the implementation differs from Command.Drop, so will also
+need some changes.
+
+Command.Move.toPerform already locks local content for removal before
+removing it, of course. So, that will interoperate fine with
+concurrent drops/moves. Seems fine as-is.
+
+Command.Move.fromPerform simply needs to lock the local content
+in place before dropping it from the remote. This satisfies the need
+for 1 locked copy when dropping from a remote, and so is sufficent to
+fix the bug.
+
+> done

doc/git-annex-shell.mdwn

@@ -43,6 +43,17 @@ first "/~/" or "/~user/" is expanded to the specified home directory.
   Exits 100 if it's unable to tell (perhaps the key is in the process of
   being removed from the annex).
 
+* lockcontent directory key
+
+  This locks a key's content in place in the annex, preventing it from
+  being dropped.
+
+  Once the content is successfully locked, outputs "OK". Then the content
+  remains locked until a newline is received from the caller or the
+  connection is broken.
+
+  Exits nonzero if the content is not present, or could not be locked.
+
 * dropkey directory [key ...]
 
   This drops the annexed data for the specified keys.