send update notificaton when removing a queued transfer

2 files changed, 20 insertions, 14 deletions

diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 865a82915..24987bfa6 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -136,9 +136,13 @@ getNextTransfer q dstatus acceptable = atomically $ do
 
 {- Removes a transfer from the queue, if present, and returns True if it
  - was present. -}
-dequeueTransfer :: TransferQueue -> Transfer -> IO Bool
-dequeueTransfer q t = atomically $ do
-	(l, removed) <- partition (\i -> fst i /= t) <$> readTVar (queuelist q)
-	void $ writeTVar (queuesize q) (length l)
-	void $ writeTVar (queuelist q) l
-	return $ not $ null removed
+dequeueTransfer :: TransferQueue -> DaemonStatusHandle -> Transfer -> IO Bool
+dequeueTransfer q dstatus t = do
+	ok <- atomically $ do
+		(l, removed) <- partition (\i -> fst i /= t) <$> readTVar (queuelist q)
+		void $ writeTVar (queuesize q) (length l)
+		void $ writeTVar (queuelist q) l
+		return $ not $ null removed
+	when ok $
+		notifyTransfer dstatus
+	return ok
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 94451640e..6268449ed 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -160,14 +160,16 @@ startTransfer t = liftIO $ putStrLn "start"
 cancelTransfer :: Transfer -> Handler ()
 cancelTransfer t = do
 	webapp <- getYesod
-	{- remove queued transfer -}
-	void $ liftIO $ dequeueTransfer (transferQueue webapp) t
-	{- stop running transfer -}
-	maybe noop (void . liftIO . stop webapp) =<< running webapp
+	let dstatus = daemonStatus webapp
+	liftIO $ do
+		{- remove queued transfer -}
+		void $ dequeueTransfer (transferQueue webapp) dstatus t
+		{- stop running transfer -}
+		maybe noop (stop dstatus) =<< running dstatus
 	where
-		running webapp = liftIO $ M.lookup t . currentTransfers
-			<$> getDaemonStatus (daemonStatus webapp)
-		stop webapp info = do
+		running dstatus = M.lookup t . currentTransfers
+			<$> getDaemonStatus dstatus
+		stop dstatus info = void $ do
 			putStrLn $ "stopping transfer " ++ show info
 			{- When there's a thread associated with the
 			 - transfer, it's killed first, to avoid it
@@ -175,7 +177,7 @@ cancelTransfer t = do
 			 - failed when the transfer process is killed. -}
 			maybe noop killThread $ transferTid info
 			maybe noop killproc $ transferPid info
-			removeTransfer (daemonStatus webapp) t
+			removeTransfer dstatus t
 		{- In order to stop helper processes like rsync,
 		 - kill the whole process group of the process running the 
 		 - transfer. -}