summaryrefslogtreecommitdiff
path: root/Assistant/TransferQueue.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-03-01 15:23:59 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-03-01 15:23:59 -0400
commit0fa9ecb7ba54aa719dec810033b5f54ca197bf4e (patch)
treeb1179d1852450e1c7d54a99c03de2c0f9fb629a2 /Assistant/TransferQueue.hs
parentee19c8c802bec35fe0d3b92b7f065eed819ec38f (diff)
add additional debug info about reasons for transfers
Diffstat (limited to 'Assistant/TransferQueue.hs')
-rw-r--r--Assistant/TransferQueue.hs38
1 files changed, 21 insertions, 17 deletions
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 66d761f6e..7c41f0399 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -33,6 +33,8 @@ import Annex.Wanted
import Control.Concurrent.STM
import qualified Data.Map as M
+type Reason = String
+
{- Reads the queue's content without blocking or changing it. -}
getTransferQueue :: Assistant [(Transfer, TransferInfo)]
getTransferQueue = (atomically . readTVar . queuelist) <<~ transferQueue
@@ -45,13 +47,13 @@ stubInfo f r = stubTransferInfo
{- Adds transfers to queue for some of the known remotes.
- Honors preferred content settings, only transferring wanted files. -}
-queueTransfers :: Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
+queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
queueTransfers = queueTransfersMatching (const True)
{- Adds transfers to queue for some of the known remotes, that match a
- condition. Honors preferred content settings. -}
-queueTransfersMatching :: (UUID -> Bool) -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
-queueTransfersMatching matching schedule k f direction
+queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
+queueTransfersMatching matching reason schedule k f direction
| direction == Download = whenM (liftAnnex $ wantGet True f) go
| otherwise = go
where
@@ -62,7 +64,7 @@ queueTransfersMatching matching schedule k f direction
if null matchingrs
then defer
else forM_ matchingrs $ \r ->
- enqueue schedule (gentransfer r) (stubInfo f r)
+ enqueue reason schedule (gentransfer r) (stubInfo f r)
sufficientremotes rs
{- Queue downloads from all remotes that
- have the key, with the cheapest ones first.
@@ -90,8 +92,8 @@ queueTransfersMatching matching schedule k f direction
{- Queues any deferred downloads that can now be accomplished, leaving
- any others in the list to try again later. -}
-queueDeferredDownloads :: Schedule -> Assistant ()
-queueDeferredDownloads schedule = do
+queueDeferredDownloads :: Reason -> Schedule -> Assistant ()
+queueDeferredDownloads reason schedule = do
q <- getAssistant transferQueue
l <- liftIO $ atomically $ swapTVar (deferreddownloads q) []
rs <- syncDataRemotes <$> getDaemonStatus
@@ -105,7 +107,7 @@ queueDeferredDownloads schedule = do
let sources = filter (\r -> uuid r `elem` uuids) rs
unless (null sources) $
forM_ sources $ \r ->
- enqueue schedule (gentransfer r) (stubInfo f r)
+ enqueue reason schedule (gentransfer r) (stubInfo f r)
return $ null sources
where
gentransfer r = Transfer
@@ -114,8 +116,8 @@ queueDeferredDownloads schedule = do
, transferUUID = Remote.uuid r
}
-enqueue :: Schedule -> Transfer -> TransferInfo -> Assistant ()
-enqueue schedule t info
+enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant ()
+enqueue reason schedule t info
| schedule == Next = go (new:)
| otherwise = go (\l -> l++[new])
where
@@ -125,31 +127,33 @@ enqueue schedule t info
liftIO $ atomically $ do
void $ modifyTVar' (queuesize q) succ
void $ modifyTVar' (queuelist q) modlist
+ debug [ "queued", describeTransfer t info, ": " ++ reason ]
notifyTransfer
{- Adds a transfer to the queue. -}
-queueTransfer :: Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
-queueTransfer schedule f t remote = enqueue schedule t (stubInfo f remote)
+queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransfer reason schedule f t remote =
+ enqueue reason schedule t (stubInfo f remote)
{- Blocks until the queue is no larger than a given size, and then adds a
- transfer to the queue. -}
-queueTransferAt :: Int -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
-queueTransferAt wantsz schedule f t remote = do
+queueTransferAt :: Int -> Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransferAt wantsz reason schedule f t remote = do
q <- getAssistant transferQueue
liftIO $ atomically $ do
sz <- readTVar (queuesize q)
unless (sz <= wantsz) $
retry -- blocks until queuesize changes
- enqueue schedule t (stubInfo f remote)
+ enqueue reason schedule t (stubInfo f remote)
-queueTransferWhenSmall :: AssociatedFile -> Transfer -> Remote -> Assistant ()
-queueTransferWhenSmall = queueTransferAt 10 Later
+queueTransferWhenSmall :: Reason -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransferWhenSmall reason = queueTransferAt 10 reason Later
{- Blocks until a pending transfer is available in the queue,
- and removes it.
-
- Checks that it's acceptable, before adding it to the
- - the currentTransfers map. If it's not acceptable, it's discarded.
+ - currentTransfers map. If it's not acceptable, it's discarded.
-
- This is done in a single STM transaction, so there is no window
- where an observer sees an inconsistent status. -}