avoid queuing transfers that are currently running

2 files changed, 17 insertions, 8 deletions

diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index e5c25f4cd..b6c9d0a67 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -151,6 +151,11 @@ adjustTransfersSTM dstatus a = do
 	s <- takeTMVar dstatus
 	putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }
 
+{- Checks if a transfer is currently running. -}
+checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
+checkRunningTransferSTM dstatus t = M.member t . currentTransfers
+	<$> readTMVar dstatus
+
 {- Alters a transfer's info, if the transfer is in the map. -}
 alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
 alterTransferInfo t a = updateTransferInfo' $ M.adjust a t
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 0afe3cb19..ac9ed3216 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -136,14 +136,18 @@ enqueue reason schedule t info
 		notifyTransfer
 	add modlist = do
 		q <- getAssistant transferQueue
-		liftIO $ atomically $ do
-			l <- readTVar (queuelist q)
-			if (t `notElem` map fst l)
-				then do	
-					void $ modifyTVar' (queuesize q) succ
-					void $ modifyTVar' (queuelist q) modlist
-					return True
-				else return False
+		dstatus <- getAssistant daemonStatusHandle
+		liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t)
+			( return False
+			, do
+				l <- readTVar (queuelist q)
+				if (t `notElem` map fst l)
+					then do	
+						void $ modifyTVar' (queuesize q) succ
+						void $ modifyTVar' (queuelist q) modlist
+						return True
+					else return False
+			)
 
 {- Adds a transfer to the queue. -}
 queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()