mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

fix including of remote in TransferInfo when queueing new transfers

Browse source
This commit is contained in:
Joey Hess 2012-07-25 14:02:50 -04:00
parent a9dbfdf28d
commit 2b7f9c8442
1 changed files with 12 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

24
Assistant/TransferQueue.hs
View file

@ -28,17 +28,17 @@ data Schedule = Next | Later
newTransferQueue :: IO TransferQueue newTransferQueue :: IO TransferQueue
newTransferQueue = atomically $ TransferQueue <$> newTChan <*> newTVar 0 newTransferQueue = atomically $ TransferQueue <$> newTChan <*> newTVar 0
stubInfo :: AssociatedFile -> TransferInfo stubInfo :: AssociatedFile -> Remote -> TransferInfo
stubInfo f = TransferInfo stubInfo f r = TransferInfo
{ startedTime = Nothing { startedTime = Nothing
, transferPid = Nothing , transferPid = Nothing
, transferTid = Nothing , transferTid = Nothing
, transferRemote = Nothing , transferRemote = Just r
, bytesComplete = Nothing , bytesComplete = Nothing
, associatedFile = f , associatedFile = f
} }
{- Adds pending transfers to queue for some of the known remotes. -} {- Adds transfers to queue for some of the known remotes. -}
queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex () queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex ()
queueTransfers schedule q daemonstatus k f direction = do queueTransfers schedule q daemonstatus k f direction = do
rs <- knownRemotes <$> getDaemonStatus daemonstatus rs <- knownRemotes <$> getDaemonStatus daemonstatus
@ -62,9 +62,8 @@ queueTransfers schedule q daemonstatus k f direction = do
, transferKey = k , transferKey = k
, transferUUID = Remote.uuid r , transferUUID = Remote.uuid r
} }
go r = liftIO $ atomically $ do go r = liftIO $ atomically $
let info = (stubInfo f) { transferRemote = Just r } enqueue schedule q (gentransfer r) (stubInfo f r)
enqueue schedule q (gentransfer r) info
enqueue :: Schedule -> TransferQueue -> Transfer -> TransferInfo -> STM () enqueue :: Schedule -> TransferQueue -> Transfer -> TransferInfo -> STM ()
enqueue schedule q t info enqueue schedule q t info
@ -76,16 +75,17 @@ enqueue schedule q t info
void $ modifyTVar' (queuesize q) succ void $ modifyTVar' (queuesize q) succ
{- Adds a transfer to the queue. -} {- Adds a transfer to the queue. -}
queueTransfer :: Schedule -> TransferQueue -> AssociatedFile -> Transfer -> IO () queueTransfer :: Schedule -> TransferQueue -> AssociatedFile -> Transfer -> Remote -> IO ()
queueTransfer schedule q f t = atomically $ enqueue schedule q t (stubInfo f) queueTransfer schedule q f t remote = atomically $
enqueue schedule q t (stubInfo f remote)
{- Blocks until the queue is no larger than a given size, and then adds a {- Blocks until the queue is no larger than a given size, and then adds a
- transfer to the queue. -} - transfer to the queue. -}
queueTransferAt :: Integer -> Schedule -> TransferQueue -> AssociatedFile -> Transfer -> IO () queueTransferAt :: Integer -> Schedule -> TransferQueue -> AssociatedFile -> Transfer -> Remote -> IO ()
queueTransferAt wantsz schedule q f t = atomically $ do queueTransferAt wantsz schedule q f t remote = atomically $ do
sz <- readTVar (queuesize q) sz <- readTVar (queuesize q)
if sz <= wantsz if sz <= wantsz
then enqueue schedule q t (stubInfo f) then enqueue schedule q t (stubInfo f remote)
else retry -- blocks until queuesize changes else retry -- blocks until queuesize changes
{- Blocks until a pending transfer is available from the queue. -} {- Blocks until a pending transfer is available from the queue. -}