From bab88f3596c570346a3d069af9e3c8ed92e473c9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 8 Oct 2015 14:27:37 -0400
Subject: add lockContentShared

Also, rename lockContent to lockContentExclusive

inAnnexSafe should perhaps be eliminated, and instead use
`lockContentShared inAnnex`. However, I'm waiting on that, as there are
only 2 call sites for inAnnexSafe and it's fiddly.
---
 Remote/Git.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'Remote/Git.hs')

diff --git a/Remote/Git.hs b/Remote/Git.hs
index f7a0b4a39..8f7e69cbd 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -350,7 +350,7 @@ dropKey r key
 			commitOnCleanup r $ onLocal r $ do
 				ensureInitialized
 				whenM (Annex.Content.inAnnex key) $ do
-					Annex.Content.lockContent key
+					Annex.Content.lockContentExclusive key
 						Annex.Content.removeAnnex
 					logStatus key InfoMissing
 					Annex.Content.saveState True
-- 
cgit v1.2.3


From 55fb90edfc8732b08bea9239a6f4a471ac7867c3 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 8 Oct 2015 15:01:38 -0400
Subject: add removeKey action to Remote

Not implemented for any remotes yet; probably the git remote is the only
one that will ever implement it.
---
 Command/Drop.hs      | 2 +-
 Remote/BitTorrent.hs | 1 +
 Remote/Bup.hs        | 1 +
 Remote/Ddar.hs       | 1 +
 Remote/Directory.hs  | 1 +
 Remote/External.hs   | 1 +
 Remote/GCrypt.hs     | 1 +
 Remote/Git.hs        | 1 +
 Remote/Glacier.hs    | 1 +
 Remote/Hook.hs       | 1 +
 Remote/Rsync.hs      | 1 +
 Remote/S3.hs         | 1 +
 Remote/Tahoe.hs      | 1 +
 Remote/Web.hs        | 1 +
 Remote/WebDAV.hs     | 1 +
 Types/Remote.hs      | 8 +++++++-
 16 files changed, 22 insertions(+), 2 deletions(-)

(limited to 'Remote/Git.hs')

diff --git a/Command/Drop.hs b/Command/Drop.hs
index 6bbdb58fd..8b361ed56 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -91,7 +91,7 @@ startRemote afile numcopies key remote = do
 -- 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
--- see the key is present on the other.
+-- sees the key is present on the other.
 performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform
 performLocal key afile numcopies knownpresentremote = lockContentExclusive key $ \contentlock -> do
 	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index f9027ba61..8349631de 100644
--- a/Remote/BitTorrent.hs
+++ b/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
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index a253b0889..d9d561b0d 100644
--- a/Remote/Bup.hs
+++ b/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
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index b616093a3..d485d3793 100644
--- a/Remote/Ddar.hs
+++ b/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
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index ab4137d75..987c3079f 100644
--- a/Remote/Directory.hs
+++ b/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
diff --git a/Remote/External.hs b/Remote/External.hs
index 9f8bd4ccf..68237b939 100644
--- a/Remote/External.hs
+++ b/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
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 3a63642c8..c720e55b2 100644
--- a/Remote/GCrypt.hs
+++ b/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
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 8f7e69cbd..725b302b8 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -142,6 +142,7 @@ gen r u c gc
 			, retrieveKeyFile = copyFromRemote new
 			, retrieveKeyFileCheap = copyFromRemoteCheap new
 			, removeKey = dropKey new
+			, lockContent = Nothing
 			, checkPresent = inAnnex new
 			, checkPresentCheap = repoCheap r
 			, whereisKey = Nothing
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index e69903634..8529b6341 100644
--- a/Remote/Glacier.hs
+++ b/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
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 98eeeb031..5d3c0af5c 100644
--- a/Remote/Hook.hs
+++ b/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
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 829a2661a..fd6c25c15 100644
--- a/Remote/Rsync.hs
+++ b/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
diff --git a/Remote/S3.hs b/Remote/S3.hs
index c8a34f2e7..d381e0b72 100644
--- a/Remote/S3.hs
+++ b/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)
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index c04cdae58..2ced67e30 100644
--- a/Remote/Tahoe.hs
+++ b/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
diff --git a/Remote/Web.hs b/Remote/Web.hs
index ae0281064..257eba2e1 100644
--- a/Remote/Web.hs
+++ b/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
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 730093a3b..7f4173d03 100644
--- a/Remote/WebDAV.hs
+++ b/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
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 24851e17c..1bf79a81e 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -7,6 +7,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE RankNTypes #-}
+
 module Types.Remote
 	( RemoteConfigKey
 	, RemoteConfig
@@ -72,8 +74,12 @@ 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,
+	-- and runs the passed action while it's locked.
+	-- This is optional; remotes do not have to support locking.
+	lockContent :: forall r. Maybe (Key -> 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,
-- 
cgit v1.2.3


From 8817fe6331ffc3d99bbf44af559f773af1a2ddd2 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 9 Oct 2015 13:07:03 -0400
Subject: content locking during drop working for local git remotes

Only ssh remotes lack locking now
---
 Annex/NumCopies.hs | 38 +++++++++++++++++++++++++++++++++++---
 Remote/Git.hs      | 13 ++++++++++++-
 Types/NumCopies.hs |  2 +-
 Types/Remote.hs    |  7 ++++---
 4 files changed, 52 insertions(+), 8 deletions(-)

(limited to 'Remote/Git.hs')

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,
-- 
cgit v1.2.3


From cdc18dea255090d0eb9c1dcd9ffa433665736b18 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 9 Oct 2015 13:35:28 -0400
Subject: fix lockKey to run callback in original Annex monad, not local
 remote's

---
 Annex.hs      |  8 ++++++++
 Remote/Git.hs | 11 ++++++++---
 2 files changed, 16 insertions(+), 3 deletions(-)

(limited to 'Remote/Git.hs')

diff --git a/Annex.hs b/Annex.hs
index 78a6bf369..d6834e24a 100644
--- a/Annex.hs
+++ b/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
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 9fa7158e5..5c429c93c 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -361,10 +361,15 @@ dropKey r key
 	| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
 
 lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
-lockKey r key a
+lockKey r key callback
 	| not $ Git.repoIsUrl (repo r) =
-		guardUsable (repo r) cantlock $
-			onLocal r $ Annex.Content.lockContentShared key a
+		guardUsable (repo r) cantlock $ 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 $ 
+				liftIO . inorigrepo . callback
 	| Git.repoIsHttp (repo r) = cantlock
 	| otherwise = error "TODO"
   where
-- 
cgit v1.2.3


From 3c43af79d56a25bfff3eae1c1342c9a308223347 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 9 Oct 2015 15:48:02 -0400
Subject: fix local dropping to not require extra locking of copies, but only
 that the local copy be locked for removal

---
 Annex/Content.hs      | 15 +++++++-------
 Annex/NumCopies.hs    | 13 +++++++------
 Assistant/Unused.hs   |  2 +-
 Command/Drop.hs       | 16 +++++++--------
 Command/DropKey.hs    |  2 +-
 Command/Import.hs     |  2 +-
 Command/Move.hs       |  2 +-
 Command/TestRemote.hs | 10 +++++-----
 Command/Uninit.hs     |  2 +-
 Remote/Git.hs         |  2 +-
 Types/NumCopies.hs    | 54 ++++++++++++++++++++++++++++++++++++++-------------
 11 files changed, 72 insertions(+), 48 deletions(-)

(limited to 'Remote/Git.hs')

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
-- 
cgit v1.2.3


From 43efb9173bbf23d35106d980fc36c07c6c29a4e6 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 9 Oct 2015 16:55:41 -0400
Subject: implement lockContent for ssh remotes

---
 Annex/Content.hs       |  2 +-
 Command/LockContent.hs |  3 ++-
 Remote/Git.hs          | 38 ++++++++++++++++++++++++++++++++++++--
 Remote/Helper/Ssh.hs   |  5 +++++
 Types/NumCopies.hs     | 14 ++++++++------
 5 files changed, 52 insertions(+), 10 deletions(-)

(limited to 'Remote/Git.hs')

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 0dc47d9e2..0b15ce53b 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -184,7 +184,7 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key)
 lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a
 lockContentShared key a = lockContentUsing lock key $ do
 	u <- getUUID
-	withVerifiedCopy LockedCopy u a
+	withVerifiedCopy LockedCopy u (return True) a
   where
 #ifndef mingw32_HOST_OS
 	lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile
diff --git a/Command/LockContent.hs b/Command/LockContent.hs
index e37d4cca5..72b2bb096 100644
--- a/Command/LockContent.hs
+++ b/Command/LockContent.hs
@@ -11,6 +11,7 @@ import Common.Annex
 import Command
 import Annex.Content
 import Types.Key
+import Remote.Helper.Ssh (contentLockedMarker)
 
 cmd :: Command
 cmd = noCommit $ 
@@ -36,7 +37,7 @@ start [ks] = do
 	k = fromMaybe (error "bad key") (file2key ks)
 	locksuccess = ifM (inAnnex k)
 		( liftIO $ do
-			putStrLn "OK"
+			putStrLn contentLockedMarker
 			hFlush stdout
 			_ <- getLine
 			return True
diff --git a/Remote/Git.hs b/Remote/Git.hs
index a6c4315ab..c2bd307ad 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -57,6 +57,7 @@ import Types.NumCopies
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
+import Control.Concurrent.Async
 import qualified Data.Map as M
 import Network.URI
 
@@ -370,8 +371,41 @@ lockKey r key callback
 			-- annex monad, not the remote's.
 			onLocal r $ Annex.Content.lockContentShared key $ 
 				liftIO . inorigrepo . callback
-	| Git.repoIsHttp (repo r) = cantlock
-	| otherwise = error "TODO"
+	| Git.repoIsSsh (repo r) = do
+		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"
+			[Param $ key2file key] []
+		(Just hin, Just hout, Nothing, p) <- liftIO $ createProcess $
+			 (proc cmd (toCommand params))
+				{ std_in = CreatePipe
+				, std_out = CreatePipe
+				}
+		-- 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
+				liftIO $ do
+					hClose hin
+					hClose hout
+				cantlock
+			Right l 
+				| l == Ssh.contentLockedMarker -> bracket_
+					noop
+					signaldone 
+					(withVerifiedCopy LockedCopy r checkexited callback)
+				| otherwise -> do
+					signaldone
+					cantlock
+	| otherwise = cantlock
   where
 	cantlock = error "can't lock content"
 
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 162c34f4e..0442ce839 100644
--- a/Remote/Helper/Ssh.hs
+++ b/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"
diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs
index 60e0db580..8677e22b3 100644
--- a/Types/NumCopies.hs
+++ b/Types/NumCopies.hs
@@ -25,6 +25,7 @@ module Types.NumCopies (
 import Types.UUID
 import Types.Key
 import Utility.Exception (bracketIO)
+import Utility.Monad
 
 import qualified Data.Map as M
 import Control.Concurrent.MVar
@@ -98,14 +99,14 @@ deDupVerifiedCopies l = M.elems $
 mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy
 mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ())
 
-invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO VerifiedCopy
-invalidatableVerifiedCopy mk u = do
+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
-	return $ mk $ V (toUUID u) check invalidate
+	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.
@@ -113,11 +114,12 @@ withVerifiedCopy
 	:: (Monad m, MonadMask m, MonadIO m, ToUUID u)
 	=> (V -> VerifiedCopy)
 	-> u
+	-> IO Bool
 	-> (VerifiedCopy -> m a)
 	-> m a
-withVerifiedCopy mk u = bracketIO setup cleanup
+withVerifiedCopy mk u check = bracketIO setup cleanup
   where
-	setup = invalidatableVerifiedCopy mk u
+	setup = invalidatableVerifiedCopy mk u check
 	cleanup = invalidateVerifiedCopy
 
 {- Check whether enough verification has been done of copies to allow
-- 
cgit v1.2.3


From 841e9fc078f114a7d1942d433a7f50af8f8552d4 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 9 Oct 2015 17:21:02 -0400
Subject: improve display when lockcontent fails

/dev/null stderr; ssh is still able to display a password prompt
despite this

Show some messages so the user knows it's locking a remote, and
knows if that locking failed.
---
 Remote/Git.hs             | 26 ++++++++++++++++----------
 Remote/Helper/Messages.hs | 27 +++++++++++++++------------
 debian/changelog          |  9 +++++++++
 3 files changed, 40 insertions(+), 22 deletions(-)

(limited to 'Remote/Git.hs')

diff --git a/Remote/Git.hs b/Remote/Git.hs
index c2bd307ad..80c0579cc 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -364,7 +364,7 @@ dropKey r key
 lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
 lockKey r key callback
 	| not $ Git.repoIsUrl (repo r) =
-		guardUsable (repo r) cantlock $ do
+		guardUsable (repo r) failedlock $ do
 			inorigrepo <- Annex.makeRunner
 			-- Lock content from perspective of remote,
 			-- and then run the callback in the original
@@ -372,13 +372,17 @@ lockKey r key callback
 			onLocal r $ Annex.Content.lockContentShared key $ 
 				liftIO . inorigrepo . callback
 	| 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 $ createProcess $
-			 (proc cmd (toCommand params))
-				{ std_in = CreatePipe
-				, std_out = CreatePipe
-				}
+		(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 
@@ -393,21 +397,23 @@ lockKey r key callback
 		let checkexited = not . isJust <$> getProcessExitCode p
 		case v of
 			Left _exited -> do
+				showNote "lockcontent failed"
 				liftIO $ do
 					hClose hin
 					hClose hout
-				cantlock
+				failedlock
 			Right l 
 				| l == Ssh.contentLockedMarker -> bracket_
 					noop
 					signaldone 
 					(withVerifiedCopy LockedCopy r checkexited callback)
 				| otherwise -> do
+					showNote "lockcontent failed"
 					signaldone
-					cantlock
-	| otherwise = cantlock
+					failedlock
+	| otherwise = failedlock
   where
-	cantlock = error "can't lock content"
+	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)
diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs
index 377f2d231..6e72758fb 100644
--- a/Remote/Helper/Messages.hs
+++ b/Remote/Helper/Messages.hs
@@ -13,20 +13,23 @@ import Common.Annex
 import qualified Git
 import qualified Types.Remote as Remote
 
-class Checkable a where
-	descCheckable :: a -> String
+class Describable a where
+	describe :: a -> String
 
-instance Checkable Git.Repo where
-	descCheckable = Git.repoDescribe
+instance Describable Git.Repo where
+	describe = Git.repoDescribe
 
-instance Checkable (Remote.RemoteA a) where
-	descCheckable = Remote.name
+instance Describable (Remote.RemoteA a) where
+	describe = Remote.name
 
-instance Checkable String where
-	descCheckable = id
+instance Describable String where
+	describe = id
 
-showChecking :: Checkable a => a -> Annex ()
-showChecking v = showAction $ "checking " ++ descCheckable v
+showChecking :: Describable a => a -> Annex ()
+showChecking v = showAction $ "checking " ++ describe v
 
-cantCheck :: Checkable a => a -> e
-cantCheck v = error $ "unable to check " ++ descCheckable v
+cantCheck :: Describable a => a -> e
+cantCheck v = error $ "unable to check " ++ describe v
+
+showLocking :: Describable a => a -> Annex ()
+showLocking v = showAction $ "locking " ++ describe v
diff --git a/debian/changelog b/debian/changelog
index 81797bc4f..250e183a6 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -5,6 +5,15 @@ git-annex (5.20150931) UNRELEASED; urgency=medium
     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.
-- 
cgit v1.2.3


From bef58852d9b6150b0e2a47c412bd12dcc34a7794 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 9 Oct 2015 18:00:37 -0400
Subject: add inAnnex check to local lockKey

---
 Remote/Git.hs | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

(limited to 'Remote/Git.hs')

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 80c0579cc..c80a0d1c6 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -369,8 +369,12 @@ lockKey r key callback
 			-- 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 $ 
-				liftIO . inorigrepo . callback
+			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"
-- 
cgit v1.2.3