diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 8 | ||||
| -rw-r--r-- | Assistant/TransferSlots.hs | 19 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 3 |
3 files changed, 20 insertions, 10 deletions
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index c349acf44..8118a3f3c 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -38,7 +38,7 @@ transfererThread st dstatus transferqueue slots = go ( do debug thisThread [ "Transferring:" , show t ] notifyTransfer dstatus - transferThread dstatus slots t info + transferThread dstatus slots t info inTransferSlot , do debug thisThread [ "Skipping unnecessary transfer:" , show t ] -- 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 - stopped, to avoid it displaying any alert about the transfer having - failed. -} -transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO () -transferThread dstatus slots t info = case (transferRemote info, associatedFile info) of +transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> TransferSlotRunner -> IO () +transferThread dstatus slots t info runner = case (transferRemote info, associatedFile info) of (Nothing, _) -> noop (_, Nothing) -> noop (Just remote, Just file) -> do - tid <- inTransferSlot slots $ + tid <- runner slots $ transferprocess remote file updateTransferInfo dstatus t $ info { transferTid = Just tid } where diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 81eb6500f..27b869f1d 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -25,6 +25,8 @@ data TransferException = PauseTransfer | ResumeTransfer instance E.Exception TransferException +type TransferSlotRunner = TransferSlots -> IO () -> IO ThreadId + {- Number of concurrent transfers allowed to be run from the assistant. - - 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 - 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. - - A PauseTransfer exception is handled by letting the action be killed, - then pausing the thread until a ResumeTransfer exception is raised, - then rerunning the action. -} -inTransferSlot :: TransferSlots -> IO () -> IO ThreadId -inTransferSlot s transfer = do - waitQSemN s 1 +runTransferSlot :: (QSemN -> IO ()) -> TransferSlotRunner +runTransferSlot allocator s transfer = do + allocator s forkIO $ E.bracket_ noop (signalQSemN s 1) go where go = catchPauseResume transfer diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 0e871d373..e51eb7777 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -209,7 +209,8 @@ startTransfer t = do - forget that old pid, and start a new one. -} liftIO $ updateTransferInfo dstatus t $ info { transferPid = Nothing } - liftIO $ Transferrer.transferThread dstatus slots t info + liftIO $ Transferrer.transferThread + dstatus slots t info inImmediateTransferSlot getCurrentTransfers :: Handler TransferMap getCurrentTransfers = currentTransfers |