diff options
| -rw-r--r-- | Assistant/TransferQueue.hs | 7 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 7 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 7 |
3 files changed, 14 insertions, 7 deletions
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index fe2c667f9..2b6f1d20e 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -140,12 +140,13 @@ getNextTransfer q dstatus acceptable = atomically $ do return $ Just r else return Nothing -{- Removes a transfer from the queue, if present, and returns True if it - - was present. -} +{- 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 - (l, removed) <- partition (\i -> fst i /= t) <$> readTVar (queuelist q) + (removed, l) <- partition (equivilantTransfer t . fst) + <$> readTVar (queuelist q) void $ writeTVar (queuesize q) (length l) void $ writeTVar (queuelist q) l return $ not $ null removed diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 8b430d4d0..f21295bf6 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -57,14 +57,13 @@ transfersDisplay warnNoScript = do isrunning info = not $ transferPaused info || isNothing (startedTime info) -{- Simplifies a list of transfers, avoiding display of redundant downloads, - - that appear immediately after a download of the same key. -} +{- Simplifies a list of transfers, avoiding display of redundant + - equivilant transfers. -} simplifyTransfers :: [(Transfer, TransferInfo)] -> [(Transfer, TransferInfo)] simplifyTransfers [] = [] simplifyTransfers (x:[]) = [x] simplifyTransfers (v@(t1, _):r@((t2, _):l)) - | transferDirection t1 == Download && transferDirection t2 == Download && - transferKey t1 == transferKey t2 = simplifyTransfers (v:l) + | equivilantTransfer t1 t2 = simplifyTransfers (v:l) | otherwise = v : (simplifyTransfers r) {- Called by client to get a display of currently in process transfers. diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 642ee7ea1..ea56035d1 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -60,6 +60,13 @@ readLcDirection "upload" = Just Upload readLcDirection "download" = Just Download readLcDirection _ = Nothing +{- Transfers that will accomplish the same task. -} +equivilantTransfer :: Transfer -> Transfer -> Bool +equivilantTransfer t1 t2 + | transferDirection t1 == Download && transferDirection t2 == Download && + transferUUID t1 == transferUUID t2 = True + | otherwise = t1 == t2 + percentComplete :: Transfer -> TransferInfo -> Maybe Percentage percentComplete (Transfer { transferKey = key }) info = percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info) |