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:
parent
b6b8f6da9c
commit
a73e271d60
3 changed files with 20 additions and 10 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue