diff options
author | Joey Hess <joey@kitenet.net> | 2012-08-29 15:56:47 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-08-29 15:56:47 -0400 |
commit | c21a9fe04a8848641a8d838a24d77cafe9af68e8 (patch) | |
tree | bfa975b3a42189c4601a4e03ec11f89f6ecc648e /Assistant | |
parent | 0842e99637977237849e67f749b23d5528fb6284 (diff) |
more generic
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/TransferQueue.hs | 20 | ||||
-rw-r--r-- | Assistant/WebApp/DashBoard.hs | 3 |
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 |