fix bug in transfer initiation checking

Putting the transfer on the currentTransfers atomically introduced a bug:
It checks to see if the transfer is in progress, and cancels it.

Fixed by moving that check inside the STM transaction.

Assistant/Threads/Transferrer.hs

@@ -33,9 +33,10 @@ maxTransfers = 1
 transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
 transfererThread st dstatus transferqueue slots = go
 	where
-		go = do
+		go = getNextTransfer transferqueue dstatus notrunning >>= handle
-			(t, info) <- getNextTransfer transferqueue dstatus
+		handle Nothing = go
-			ifM (runThreadState st $ shouldTransfer dstatus t info)
+		handle (Just (t, info)) = do
+			ifM (runThreadState st $ shouldTransfer t info)
 				( do
 					debug thisThread [ "Transferring:" , show t ]
 					notifyTransfer dstatus
@@ -47,16 +48,13 @@ transfererThread st dstatus transferqueue slots = go
 					void $ removeTransfer dstatus t
 				)
 			go
+		{- Skip transfers that are already running. -}
+		notrunning i = startedTime i == Nothing
 
-{- Checks if the requested transfer is already running, or
+{- Checks if the file to download is already present, or the remote
- - the file to download is already present, or the remote
  - being uploaded to isn't known to have the file. -}
-shouldTransfer :: DaemonStatusHandle -> Transfer -> TransferInfo -> Annex Bool
+shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
-shouldTransfer dstatus t info =
+shouldTransfer t info
-	go =<< currentTransfers <$> liftIO (getDaemonStatus dstatus)
-	where
-		go m
-			| M.member t m = return False
 	| transferDirection t == Download =
 		not <$> inAnnex key
 	| transferDirection t == Upload =
@@ -69,6 +67,7 @@ shouldTransfer dstatus t info =
 				notElem (Remote.uuid remote)
 					<$> loggedLocations key
 	| otherwise = return False
+	where
 		key = transferKey t
 
 {- A transfer is run in a separate thread, with a *copy* of the Annex

Assistant/TransferQueue.hs

@@ -113,16 +113,22 @@ queueTransferAt wantsz schedule q dstatus f t remote = do
 			else retry -- blocks until queuesize changes
 	enqueue schedule q dstatus t (stubInfo f remote)
 
-{- Blocks until a pending transfer is available from the queue.
+{- Blocks until a pending transfer is available from the queue,
- - The transfer is removed from the transfer queue, and added to
+ - and removes it.
- - the daemon status currentTransfers map. This is done in a single STM
+ -
- - transaction, so there is no window where an observer sees an
+ - Checks that it's acceptable, before adding it to the
- - inconsistent status. -}
+ - the currentTransfers map. If it's not acceptable, it's discarded.
-getNextTransfer :: TransferQueue -> DaemonStatusHandle -> IO (Transfer, TransferInfo)
+ -
-getNextTransfer q dstatus = atomically $ do
+ - This is done in a single STM transaction, so there is no window
+ - where an observer sees an inconsistent status. -}
+getNextTransfer :: TransferQueue -> DaemonStatusHandle -> (TransferInfo -> Bool) -> IO (Maybe (Transfer, TransferInfo))
+getNextTransfer q dstatus acceptable = atomically $ do
 	void $ modifyTVar' (queuesize q) pred
 	void $ modifyTVar' (queuelist q) (drop 1)
 	r@(t, info) <- readTChan (queue q)
+	if acceptable info
+		then do
 			adjustTransfersSTM dstatus $
 				M.insertWith' const t info
-	return r
+			return $ Just r
+		else return Nothing