From c21a9fe04a8848641a8d838a24d77cafe9af68e8 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 29 Aug 2012 15:56:47 -0400
Subject: [PATCH] more generic
---
Assistant/TransferQueue.hs | 20 ++++++++++----------
Assistant/WebApp/DashBoard.hs | 3 ++-
2 files changed, 12 insertions(+), 11 deletions(-)
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 3ecad600da..ff202d11ad 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -15,7 +15,7 @@ module Assistant.TransferQueue (
queueTransferAt,
queueTransferWhenSmall,
getNextTransfer,
- dequeueTransfer,
+ dequeueTransfers,
) where
import Common.Annex
@@ -140,20 +140,20 @@ getNextTransfer q dstatus acceptable = atomically $ do
return $ Just r
else return Nothing
-{- Removes a transfer (as well as any equivilant transfers) from the queue,
- - and returns True if anything was removed. -}
-dequeueTransfer :: TransferQueue -> DaemonStatusHandle -> Transfer -> IO Bool
-dequeueTransfer q dstatus t = do
- ok <- atomically $ do
- (removed, ls) <- partition (equivilantTransfer t . fst)
+{- Removes transfers matching a condition from the queue, and returns the
+ - removed transfers. -}
+dequeueTransfers :: TransferQueue -> DaemonStatusHandle -> (Transfer -> Bool) -> IO [(Transfer, TransferInfo)]
+dequeueTransfers q dstatus c = do
+ removed <- atomically $ do
+ (removed, ls) <- partition (c . fst)
<$> readTVar (queuelist q)
void $ writeTVar (queuesize q) (length ls)
void $ writeTVar (queuelist q) ls
drain
forM_ ls $ unGetTChan (queue q)
- return $ not $ null removed
- when ok $
+ return removed
+ unless (null removed) $
notifyTransfer dstatus
- return ok
+ return removed
where
drain = maybe noop (const drain) =<< tryReadTChan (queue q)
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 7a01401c6f..10a6deb5f8 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -175,7 +175,8 @@ cancelTransfer pause t = do
liftIO $ do
unless pause $
{- remove queued transfer -}
- void $ dequeueTransfer (transferQueue webapp) dstatus t
+ void $ dequeueTransfers (transferQueue webapp) dstatus $
+ equivilantTransfer t
{- stop running transfer -}
maybe noop (stop dstatus) (M.lookup t m)
where