diff options
| -rw-r--r-- | Assistant/Changes.hs | 2 | ||||
| -rw-r--r-- | Assistant/TransferQueue.hs | 20 | ||||
| -rw-r--r-- | Assistant/Types/TransferQueue.hs | 4 | ||||
| -rw-r--r-- | Utility/TList.hs | 11 |
4 files changed, 21 insertions, 16 deletions
diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs index 9daef511b..2ecd2036c 100644 --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -32,7 +32,7 @@ getChanges = (atomically . getTList) <<~ changePool {- Gets all unhandled changes, without blocking. -} getAnyChanges :: Assistant [Change] -getAnyChanges = (atomically . readTList) <<~ changePool +getAnyChanges = (atomically . takeTList) <<~ changePool {- Puts unhandled changes back into the pool. - Note: Original order is not preserved. -} diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index e0b57a2ac..f94e73c2b 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -39,7 +39,7 @@ type Reason = String {- Reads the queue's content without blocking or changing it. -} getTransferQueue :: Assistant [(Transfer, TransferInfo)] -getTransferQueue = (atomically . readTVar . queuelist) <<~ transferQueue +getTransferQueue = (atomically . readTList . queuelist) <<~ transferQueue stubInfo :: AssociatedFile -> Remote -> TransferInfo stubInfo f r = stubTransferInfo @@ -126,10 +126,9 @@ queueDeferredDownloads reason schedule = do enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant () enqueue reason schedule t info - | schedule == Next = go (new:) - | otherwise = go (\l -> l++[new]) + | schedule == Next = go consTList + | otherwise = go snocTList where - new = (t, info) go modlist = whenM (add modlist) $ do debug [ "queued", describeTransfer t info, ": " ++ reason ] notifyTransfer @@ -139,11 +138,11 @@ enqueue reason schedule t info liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t) ( return False , do - l <- readTVar (queuelist q) + l <- readTList (queuelist q) if (t `notElem` map fst l) then do void $ modifyTVar' (queuesize q) succ - void $ modifyTVar' (queuelist q) modlist + void $ modlist (queuelist q) (t, info) return True else return False ) @@ -184,9 +183,9 @@ getNextTransfer acceptable = do if sz < 1 then retry -- blocks until queuesize changes else do - (r@(t,info):rest) <- readTVar (queuelist q) - writeTVar (queuelist q) rest + (r@(t,info):rest) <- readTList (queuelist q) void $ modifyTVar' (queuesize q) pred + setTList (queuelist q) rest if acceptable info then do adjustTransfersSTM dstatus $ @@ -218,8 +217,7 @@ dequeueTransfers c = do dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)] dequeueTransfersSTM q c = do - (removed, ts) <- partition (c . fst) - <$> readTVar (queuelist q) + (removed, ts) <- partition (c . fst) <$> readTList (queuelist q) void $ writeTVar (queuesize q) (length ts) - void $ writeTVar (queuelist q) ts + setTList (queuelist q) ts return removed diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs index 706c64bbb..e4e305d5a 100644 --- a/Assistant/Types/TransferQueue.hs +++ b/Assistant/Types/TransferQueue.hs @@ -16,7 +16,7 @@ import Utility.TList data TransferQueue = TransferQueue { queuesize :: TVar Int - , queuelist :: TVar [(Transfer, TransferInfo)] + , queuelist :: TList (Transfer, TransferInfo) , deferreddownloads :: TList (Key, AssociatedFile) } @@ -26,5 +26,5 @@ data Schedule = Next | Later newTransferQueue :: IO TransferQueue newTransferQueue = atomically $ TransferQueue <$> newTVar 0 - <*> newTVar [] + <*> newTList <*> newTList diff --git a/Utility/TList.hs b/Utility/TList.hs index 33a50b7dd..716f72017 100644 --- a/Utility/TList.hs +++ b/Utility/TList.hs @@ -25,10 +25,14 @@ newTList = newEmptyTMVar getTList :: TList a -> STM [a] getTList tlist = D.toList <$> takeTMVar tlist -{- Gets anything currently in the TList, without blocking. +{- Takes anything currently in the TList, without blocking. - TList is left empty. -} +takeTList :: TList a -> STM [a] +takeTList tlist = maybe [] D.toList <$> tryTakeTMVar tlist + +{- Reads anything in the list, without modifying it, or blocking. -} readTList :: TList a -> STM [a] -readTList tlist = maybe [] D.toList <$> tryTakeTMVar tlist +readTList tlist = maybe [] D.toList <$> tryReadTMVar tlist {- Mutates a TList. -} modifyTList :: TList a -> (D.DList a -> D.DList a) -> STM () @@ -50,3 +54,6 @@ snocTList tlist v = modifyTList tlist $ \dl -> D.snoc dl v appendTList :: TList a -> [a] -> STM () appendTList tlist l = modifyTList tlist $ \dl -> D.append dl (D.fromList l) + +setTList :: TList a -> [a] -> STM () +setTList tlist l = modifyTList tlist $ const $ D.fromList l |