run resumed transfers immediately, do not wait for free transfer slot

The resumed transfer still uses a slot, so will delay other, queued
transfers from starting.
This commit is contained in:
Joey Hess 2012-08-12 12:36:08 -04:00
parent b6b8f6da9c
commit a73e271d60
3 changed files with 20 additions and 10 deletions

View file

@ -38,7 +38,7 @@ transfererThread st dstatus transferqueue slots = go
( do ( do
debug thisThread [ "Transferring:" , show t ] debug thisThread [ "Transferring:" , show t ]
notifyTransfer dstatus notifyTransfer dstatus
transferThread dstatus slots t info transferThread dstatus slots t info inTransferSlot
, do , do
debug thisThread [ "Skipping unnecessary transfer:" , show t ] debug thisThread [ "Skipping unnecessary transfer:" , show t ]
-- getNextTransfer added t to the -- getNextTransfer added t to the
@ -78,12 +78,12 @@ shouldTransfer t info
- the transfer info; the thread will also be killed when a transfer is - the transfer info; the thread will also be killed when a transfer is
- stopped, to avoid it displaying any alert about the transfer having - stopped, to avoid it displaying any alert about the transfer having
- failed. -} - failed. -}
transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO () transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> TransferSlotRunner -> IO ()
transferThread dstatus slots t info = case (transferRemote info, associatedFile info) of transferThread dstatus slots t info runner = case (transferRemote info, associatedFile info) of
(Nothing, _) -> noop (Nothing, _) -> noop
(_, Nothing) -> noop (_, Nothing) -> noop
(Just remote, Just file) -> do (Just remote, Just file) -> do
tid <- inTransferSlot slots $ tid <- runner slots $
transferprocess remote file transferprocess remote file
updateTransferInfo dstatus t $ info { transferTid = Just tid } updateTransferInfo dstatus t $ info { transferTid = Just tid }
where where

View file

@ -25,6 +25,8 @@ data TransferException = PauseTransfer | ResumeTransfer
instance E.Exception TransferException instance E.Exception TransferException
type TransferSlotRunner = TransferSlots -> IO () -> IO ThreadId
{- Number of concurrent transfers allowed to be run from the assistant. {- Number of concurrent transfers allowed to be run from the assistant.
- -
- Transfers launched by other means, including by remote assistants, - Transfers launched by other means, including by remote assistants,
@ -38,17 +40,24 @@ newTransferSlots = newQSemN numSlots
{- Waits until a transfer slot becomes available, and runs a transfer {- Waits until a transfer slot becomes available, and runs a transfer
- action in the slot, in its own thread. - action in the slot, in its own thread.
- -}
- Note that the action is subject to being killed when the transfer inTransferSlot :: TransferSlotRunner
inTransferSlot = runTransferSlot (\s -> waitQSemN s 1)
{- Runs a transfer action, without waiting for a slot to become available. -}
inImmediateTransferSlot :: TransferSlotRunner
inImmediateTransferSlot = runTransferSlot (\s -> signalQSemN s (-1))
{- Note that the action is subject to being killed when the transfer
- is canceled or paused. - is canceled or paused.
- -
- A PauseTransfer exception is handled by letting the action be killed, - A PauseTransfer exception is handled by letting the action be killed,
- then pausing the thread until a ResumeTransfer exception is raised, - then pausing the thread until a ResumeTransfer exception is raised,
- then rerunning the action. - then rerunning the action.
-} -}
inTransferSlot :: TransferSlots -> IO () -> IO ThreadId runTransferSlot :: (QSemN -> IO ()) -> TransferSlotRunner
inTransferSlot s transfer = do runTransferSlot allocator s transfer = do
waitQSemN s 1 allocator s
forkIO $ E.bracket_ noop (signalQSemN s 1) go forkIO $ E.bracket_ noop (signalQSemN s 1) go
where where
go = catchPauseResume transfer go = catchPauseResume transfer

View file

@ -209,7 +209,8 @@ startTransfer t = do
- forget that old pid, and start a new one. -} - forget that old pid, and start a new one. -}
liftIO $ updateTransferInfo dstatus t $ info liftIO $ updateTransferInfo dstatus t $ info
{ transferPid = Nothing } { transferPid = Nothing }
liftIO $ Transferrer.transferThread dstatus slots t info liftIO $ Transferrer.transferThread
dstatus slots t info inImmediateTransferSlot
getCurrentTransfers :: Handler TransferMap getCurrentTransfers :: Handler TransferMap
getCurrentTransfers = currentTransfers getCurrentTransfers = currentTransfers