summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-08-29 15:56:47 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-08-29 15:56:47 -0400
commitc21a9fe04a8848641a8d838a24d77cafe9af68e8 (patch)
treebfa975b3a42189c4601a4e03ec11f89f6ecc648e /Assistant
parent0842e99637977237849e67f749b23d5528fb6284 (diff)
more generic
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/TransferQueue.hs20
-rw-r--r--Assistant/WebApp/DashBoard.hs3
2 files changed, 12 insertions, 11 deletions
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 3ecad600d..ff202d11a 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 7a01401c6..10a6deb5f 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