better dup key with -J fix

This avoids all the complication about redundant work discussed in
the previous try at fixing this. At the expense of needing each command
that could have the problem to be patched to simply wrap the action in
onlyActionOn once the key is known. But there do not seem to be many
such commands.

onlyActionOn' should not be used with a CommandStart (or CommandPerform),
although the types do allow it. onlyActionOn handles running the whole
CommandStart chain. I couldn't immediately see a way to avoid mistken
use of onlyActionOn'.

This commit was supported by the NSF-funded DataLad project.

15 files changed, 81 insertions, 77 deletions

diff --git a/Annex.hs b/Annex.hs
index 8e79e63c1..32a303239 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -61,7 +61,6 @@ import Types.UUID
 import Types.FileMatcher
 import Types.NumCopies
 import Types.LockCache
-import Types.Transfer
 import Types.DesktopNotify
 import Types.CleanupActions
 import qualified Database.Keys.Handle as Keys
@@ -126,7 +125,6 @@ data AnnexState = AnnexState
 	, groupmap :: Maybe GroupMap
 	, ciphers :: M.Map StorableCipher Cipher
 	, lockcache :: LockCache
-	, currentprocesstransfers :: TVar (S.Set Transfer)
 	, sshstalecleaned :: TMVar Bool
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
@@ -140,6 +138,7 @@ data AnnexState = AnnexState
 	, existinghooks :: M.Map Git.Hook.Hook Bool
 	, desktopnotify :: DesktopNotify
 	, workers :: [Either AnnexState (Async AnnexState)]
+	, activekeys :: TVar (M.Map Key ThreadId)
 	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)
 	, keysdbhandle :: Maybe Keys.DbHandle
 	, cachedcurrentbranch :: Maybe Git.Branch
@@ -149,9 +148,9 @@ data AnnexState = AnnexState
 newState :: GitConfig -> Git.Repo -> IO AnnexState
 newState c r = do
 	emptyactiveremotes <- newMVar M.empty
+	emptyactivekeys <- newTVarIO M.empty
 	o <- newMessageState
 	sc <- newTMVarIO False
-	cpt <- newTVarIO S.empty
 	return $ AnnexState
 		{ repo = r
 		, repoadjustment = return
@@ -182,7 +181,6 @@ newState c r = do
 		, groupmap = Nothing
 		, ciphers = M.empty
 		, lockcache = M.empty
-		, currentprocesstransfers = cpt
 		, sshstalecleaned = sc
 		, flags = M.empty
 		, fields = M.empty
@@ -196,6 +194,7 @@ newState c r = do
 		, existinghooks = M.empty
 		, desktopnotify = mempty
 		, workers = []
+		, activekeys = emptyactivekeys
 		, activeremotes = emptyactiveremotes
 		, keysdbhandle = Nothing
 		, cachedcurrentbranch = Nothing
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index 35294ba2b..3fcf1a1b9 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -32,9 +32,7 @@ import qualified Types.Remote as Remote
 import Types.Concurrency
 
 import Control.Concurrent
-import Control.Concurrent.STM
 import qualified Data.Map.Strict as M
-import qualified Data.Set as S
 import Data.Ord
 
 class Observable a where
@@ -91,23 +89,22 @@ alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider
 alwaysRunTransfer = runTransfer' True
 
 runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
-runTransfer' ignorelock t afile shouldretry transferaction = 
-	checkSecureHashes t $ currentProcessTransfer t $ do
-		info <- liftIO $ startTransferInfo afile
-		(meter, tfile, metervar) <- mkProgressUpdater t info
-		mode <- annexFileMode
-		(lck, inprogress) <- prep tfile mode info
-		if inprogress && not ignorelock
-			then do
-				showNote "transfer already in progress, or unable to take transfer lock"
-				return observeFailure
-			else do
-				v <- handleretry info metervar $ transferaction meter
-				liftIO $ cleanup tfile lck
-				if observeBool v
-					then removeFailedTransfer t
-					else recordFailedTransfer t info
-				return v
+runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t $ do
+	info <- liftIO $ startTransferInfo afile
+	(meter, tfile, metervar) <- mkProgressUpdater t info
+	mode <- annexFileMode
+	(lck, inprogress) <- prep tfile mode info
+	if inprogress && not ignorelock
+		then do
+			showNote "transfer already in progress, or unable to take transfer lock"
+			return observeFailure
+		else do
+			v <- retry info metervar $ transferaction meter
+			liftIO $ cleanup tfile lck
+			if observeBool v
+				then removeFailedTransfer t
+				else recordFailedTransfer t info
+			return v
   where
 #ifndef mingw32_HOST_OS
 	prep tfile mode info = catchPermissionDenied (const prepfailed) $ do
@@ -156,7 +153,7 @@ runTransfer' ignorelock t afile shouldretry transferaction =
 		dropLock lockhandle
 		void $ tryIO $ removeFile lck
 #endif
-	handleretry oldinfo metervar run = do
+	retry oldinfo metervar run = do
 		v <- tryNonAsync run
 		case v of
 			Right b -> return b
@@ -165,7 +162,7 @@ runTransfer' ignorelock t afile shouldretry transferaction =
 				b <- getbytescomplete metervar
 				let newinfo = oldinfo { bytesComplete = Just b }
 				if shouldretry oldinfo newinfo
-					then handleretry newinfo metervar run
+					then retry newinfo metervar run
 					else return observeFailure
 	getbytescomplete metervar
 		| transferDirection t == Upload =
@@ -259,20 +256,3 @@ lessActiveFirst :: M.Map Remote Integer -> Remote -> Remote -> Ordering
 lessActiveFirst active a b
 	| Remote.cost a == Remote.cost b = comparing (`M.lookup` active) a b
 	| otherwise = compare a b
-
-{- Runs a transfer action. Only one thread can run for a given Transfer
- - at a time; other threads will block. -}
-currentProcessTransfer :: Transfer -> Annex a -> Annex a
-currentProcessTransfer t a = go =<< Annex.getState Annex.concurrency
-  where
-	go NonConcurrent = a
-	go (Concurrent _) = do
-		tv <- Annex.getState Annex.currentprocesstransfers
-		bracket_ (setup tv) (cleanup tv) a
-	setup tv = liftIO $ atomically $ do
-		s <- readTVar tv
-		if S.member t s
-			then retry
-			else writeTVar tv $! S.insert t s
-	cleanup tv = liftIO $ atomically $
-		modifyTVar' tv $ S.delete t
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index f775e3064..1166cd18a 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/Assistant/Types/DaemonStatus.hs
@@ -38,8 +38,7 @@ data DaemonStatus = DaemonStatus
 	, lastSanityCheck :: Maybe POSIXTime
 	-- True when a scan for file transfers is running
 	, transferScanRunning :: Bool
-	-- Currently running file content transfers, for both this process
-	-- and other processes.
+	-- Currently running file content transfers
 	, currentTransfers :: TransferMap
 	-- Messages to display to the user.
 	, alertMap :: AlertMap
diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs
index f7ce33bda..7e2b4ce3b 100644
--- a/Assistant/Types/TransferQueue.hs
+++ b/Assistant/Types/TransferQueue.hs
@@ -8,6 +8,7 @@
 module Assistant.Types.TransferQueue where
 
 import Annex.Common
+import Types.Transfer
 
 import Control.Concurrent.STM
 import Utility.TList
diff --git a/CHANGELOG b/CHANGELOG
index 1c9d6132a..1d9a71188 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -11,8 +11,8 @@ git-annex (6.20171004) UNRELEASED; urgency=medium
     where interrupting an add could result in the file being
     moved into the annex, with no symlink yet created.
   * Avoid repeated checking that files passed on the command line exist.
-  * Improve behavior when -J transfers multiple files that point to the
-    same key.
+  * get -J/move -J/copy -J/mirror -J/sync -J: Avoid "transfer already in
+    progress" errors when two files use the same key.
   * stack.yaml: Update to lts-9.9.
 
  -- Joey Hess <id@joeyh.name>  Sat, 07 Oct 2017 14:11:00 -0400
diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs
index 75c9e9471..b8d0e3a40 100644
--- a/CmdLine/Action.hs
+++ b/CmdLine/Action.hs
@@ -1,6 +1,6 @@
 {- git-annex command-line actions
  -
- - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -18,9 +18,12 @@ import Messages.Concurrent
 import Types.Messages
 import Remote.List
 
+import Control.Concurrent
 import Control.Concurrent.Async
+import Control.Concurrent.STM
 import Control.Exception (throwIO)
 import Data.Either
+import qualified Data.Map.Strict as M
 
 #ifdef WITH_CONCURRENTOUTPUT
 import qualified System.Console.Regions as Regions
@@ -177,3 +180,36 @@ allowConcurrentOutput a = go =<< Annex.getState Annex.concurrency
 #else
 allowConcurrentOutput = id
 #endif
+
+{- Ensures that only one thread processes a key at a time.
+ - Other threads will block until it's done. -}
+onlyActionOn :: Key -> CommandStart -> CommandStart
+onlyActionOn k a = onlyActionOn' k run
+  where
+	run = do
+		-- Run whole action, not just start stage, so other threads
+		-- block until it's done.
+		r <- callCommandAction' a
+		case r of
+			Nothing -> return Nothing
+			Just r' -> return $ Just $ return $ Just $ return r'
+
+onlyActionOn' :: Key -> Annex a -> Annex a
+onlyActionOn' k a = go =<< Annex.getState Annex.concurrency
+  where
+	go NonConcurrent = a
+	go (Concurrent _) = do
+		tv <- Annex.getState Annex.activekeys
+		bracket (setup tv) id (const a)
+	setup tv = liftIO $ do
+		mytid <- myThreadId
+		atomically $ do
+			m <- readTVar tv
+			case M.lookup k m of
+				Just tid
+					| tid /= mytid -> retry
+					| otherwise -> return (return ())
+				Nothing -> do
+					writeTVar tv $! M.insert k mytid m
+					return $ liftIO $ atomically $
+						modifyTVar tv $ M.delete k
diff --git a/Command/Get.hs b/Command/Get.hs
index e91798eba..a412b2cb3 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -62,8 +62,8 @@ startKeys from key ai = checkFailedTransferDirection ai Download $
 	start' (return True) from key (AssociatedFile Nothing) ai
 
 start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart
-start' expensivecheck from key afile ai = stopUnless (not <$> inAnnex key) $
-	stopUnless expensivecheck $
+start' expensivecheck from key afile ai = onlyActionOn key $
+	stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $
 		case from of
 			Nothing -> go $ perform key afile
 			Just src ->
@@ -109,10 +109,9 @@ getKey' key afile = dispatch
 		| Remote.hasKeyCheap r =
 			either (const False) id <$> Remote.hasKey r key
 		| otherwise = return True
-	docopy r = download (Remote.uuid r) key afile forwardRetry $ \p ->
-		ifM (inAnnex key)
-			( return True
-			, getViaTmp (RemoteVerify r) key $ \dest -> do
+	docopy r witness = getViaTmp (RemoteVerify r) key $ \dest ->
+		download (Remote.uuid r) key afile forwardRetry
+			(\p -> do
 				showAction $ "from " ++ Remote.name r
 				Remote.retrieveKeyFile r key afile dest p
-			)
+			) witness
diff --git a/Command/Mirror.hs b/Command/Mirror.hs
index a8f4307a2..941e397a4 100644
--- a/Command/Mirror.hs
+++ b/Command/Mirror.hs
@@ -53,7 +53,7 @@ start o file k = startKey o afile k (mkActionItem afile)
 	afile = AssociatedFile (Just file)
 
 startKey :: MirrorOptions -> AssociatedFile -> Key -> ActionItem -> CommandStart
-startKey o afile key ai = case fromToOptions o of
+startKey o afile key ai = onlyActionOn key $ case fromToOptions o of
 	ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)
 		( Command.Move.toStart False afile key ai =<< getParsed r
 		, do
diff --git a/Command/Move.hs b/Command/Move.hs
index 9e6c03e3b..04e6aa384 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -74,7 +74,7 @@ startKey :: MoveOptions -> Bool -> Key -> ActionItem -> CommandStart
 startKey o move = start' o move (AssociatedFile Nothing)
 
 start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart
-start' o move afile key ai = 
+start' o move afile key ai = onlyActionOn key $
 	case fromToOptions o of
 		Right (FromRemote src) ->
 			checkFailedTransferDirection ai Download $
@@ -200,11 +200,8 @@ fromPerform src move key afile = do
   where
 	go = notifyTransfer Download afile $ 
 		download (Remote.uuid src) key afile forwardRetry $ \p ->
-			ifM (inAnnex key)
-				( return True
-				, getViaTmp (RemoteVerify src) key $ \t ->
-					Remote.retrieveKeyFile src key afile t p
-				)
+			getViaTmp (RemoteVerify src) key $ \t ->
+				Remote.retrieveKeyFile src key afile t p
 	dispatch _ False = stop -- failed
 	dispatch False True = next $ return True -- copy complete
 	-- Finish by dropping from remote, taking care to verify that
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 1bd8e623c..b2d0bd275 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -609,7 +609,7 @@ seekSyncContent o rs = do
  - Returns True if any file transfers were made.
  -}
 syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool
-syncFile ebloom rs af k = do
+syncFile ebloom rs af k = onlyActionOn' k $ do
 	locs <- Remote.keyLocations k
 	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
 
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 91683b1d0..3e90ae1ee 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -9,7 +9,6 @@
 
 module Logs.Transfer where
 
-import Types
 import Types.Transfer
 import Types.ActionItem
 import Annex.Common
diff --git a/Types.hs b/Types.hs
index ec7709a0e..884c91a6b 100644
--- a/Types.hs
+++ b/Types.hs
@@ -15,8 +15,6 @@ module Types (
 	RemoteGitConfig(..),
 	Remote,
 	RemoteType,
-	Transfer,
-	TransferInfo,
 ) where
 
 import Annex
@@ -25,9 +23,7 @@ import Types.GitConfig
 import Types.Key
 import Types.UUID
 import Types.Remote
-import Types.Transfer
 
 type Backend = BackendA Annex
 type Remote = RemoteA Annex
 type RemoteType = RemoteTypeA Annex
-type TransferInfo = TransferInfoA Annex
diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs
index 0b53bec01..73d845101 100644
--- a/Types/ActionItem.hs
+++ b/Types/ActionItem.hs
@@ -10,7 +10,6 @@
 module Types.ActionItem where
 
 import Key
-import Types
 import Types.Transfer
 import Git.FilePath
 
diff --git a/Types/Transfer.hs b/Types/Transfer.hs
index 093307ea9..ade8fc763 100644
--- a/Types/Transfer.hs
+++ b/Types/Transfer.hs
@@ -7,13 +7,10 @@
 
 module Types.Transfer where
 
-import Types.Remote
-import Types.Key
-import Types.UUID
+import Types
 import Utility.PID
 import Utility.QuickCheck
 
-import Control.Concurrent.STM
 import Data.Time.Clock.POSIX
 import Control.Concurrent
 import Control.Applicative
@@ -33,18 +30,18 @@ data Transfer = Transfer
  - git repository. It's some file, possibly relative to some directory,
  - of some repository, that was acted on to initiate the transfer.
  -}
-data TransferInfoA a = TransferInfo
+data TransferInfo = TransferInfo
 	{ startedTime :: Maybe POSIXTime
 	, transferPid :: Maybe PID
 	, transferTid :: Maybe ThreadId
-	, transferRemote :: Maybe (RemoteA a)
+	, transferRemote :: Maybe Remote
 	, bytesComplete :: Maybe Integer
 	, associatedFile :: AssociatedFile
 	, transferPaused :: Bool
 	}
 	deriving (Show, Eq, Ord)
 
-stubTransferInfo :: TransferInfoA a
+stubTransferInfo :: TransferInfo
 stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing (AssociatedFile Nothing) False
 
 data Direction = Upload | Download
@@ -59,7 +56,7 @@ parseDirection "upload" = Just Upload
 parseDirection "download" = Just Download
 parseDirection _ = Nothing
 
-instance Arbitrary (TransferInfoA a) where
+instance Arbitrary TransferInfo where
 	arbitrary = TransferInfo
 		<$> arbitrary
 		<*> arbitrary
diff --git a/doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn b/doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn
index 80c16d6e1..7008eb62d 100644
--- a/doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn
+++ b/doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn
@@ -47,4 +47,6 @@ I wondered if annex should first analyze passed paths to get actual keys to be f
 
 [[!meta author=yoh]]
 
-> [[fixed|done]] --[[Joey]]
+> [[fixed|done]]; also fixed for several other commands, but the final 
+> fix needed each command that could have the problem to be modified, so 
+> there could possibly be some I missed.. --[[Joey]]