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.

1 files changed, 18 insertions, 38 deletions

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