run resumed transfers immediately, do not wait for free transfer slot

The resumed transfer still uses a slot, so will delay other, queued
transfers from starting.

3 files changed, 20 insertions, 10 deletions

diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index c349acf44..8118a3f3c 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -38,7 +38,7 @@ transfererThread st dstatus transferqueue slots = go
 				( do
 					debug thisThread [ "Transferring:" , show t ]
 					notifyTransfer dstatus
-					transferThread dstatus slots t info
+					transferThread dstatus slots t info inTransferSlot
 				, do
 					debug thisThread [ "Skipping unnecessary transfer:" , show t ]
 					-- getNextTransfer added t to the
@@ -78,12 +78,12 @@ shouldTransfer t info
  - the transfer info; the thread will also be killed when a transfer is
  - stopped, to avoid it displaying any alert about the transfer having
  - failed. -}
-transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO ()
-transferThread dstatus slots t info = case (transferRemote info, associatedFile info) of
+transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> TransferSlotRunner -> IO ()
+transferThread dstatus slots t info runner = case (transferRemote info, associatedFile info) of
 	(Nothing, _) -> noop
 	(_, Nothing) -> noop
 	(Just remote, Just file) -> do
-		tid <- inTransferSlot slots $
+		tid <- runner slots $
 			transferprocess remote file
 		updateTransferInfo dstatus t $ info { transferTid = Just tid }
 	where
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 81eb6500f..27b869f1d 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -25,6 +25,8 @@ data TransferException = PauseTransfer | ResumeTransfer
 
 instance E.Exception TransferException
 
+type TransferSlotRunner = TransferSlots -> IO () -> IO ThreadId
+
 {- Number of concurrent transfers allowed to be run from the assistant.
  -
  - Transfers launched by other means, including by remote assistants,
@@ -38,17 +40,24 @@ newTransferSlots = newQSemN numSlots
 
 {- Waits until a transfer slot becomes available, and runs a transfer
  - action in the slot, in its own thread. 
- -
- - Note that the action is subject to being killed when the transfer
+ -}
+inTransferSlot :: TransferSlotRunner
+inTransferSlot = runTransferSlot (\s -> waitQSemN s 1)
+
+{- Runs a transfer action, without waiting for a slot to become available. -}
+inImmediateTransferSlot :: TransferSlotRunner
+inImmediateTransferSlot = runTransferSlot (\s -> signalQSemN s (-1))
+
+{- Note that the action is subject to being killed when the transfer
  - is canceled or paused.
  -
  - A PauseTransfer exception is handled by letting the action be killed,
  - then pausing the thread until a ResumeTransfer exception is raised,
  - then rerunning the action.
  -}
-inTransferSlot :: TransferSlots -> IO () -> IO ThreadId
-inTransferSlot s transfer = do
-	waitQSemN s 1
+runTransferSlot :: (QSemN -> IO ()) -> TransferSlotRunner
+runTransferSlot allocator s transfer = do
+	allocator s
 	forkIO $ E.bracket_ noop (signalQSemN s 1) go
 	where
 		go = catchPauseResume transfer
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 0e871d373..e51eb7777 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -209,7 +209,8 @@ startTransfer t = do
 			 - forget that old pid, and start a new one. -}
 			liftIO $ updateTransferInfo dstatus t $ info
 				{ transferPid = Nothing }
-			liftIO $ Transferrer.transferThread dstatus slots t info
+			liftIO $ Transferrer.transferThread
+				dstatus slots t info inImmediateTransferSlot
 
 getCurrentTransfers :: Handler TransferMap
 getCurrentTransfers = currentTransfers