add additional debug info about reasons for transfers
This commit is contained in:
parent
e2f1f7afc6
commit
46c9cbeb1e
9 changed files with 43 additions and 31 deletions
|
@ -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. -}
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue