fix a transfers display glitch
Run code that pops off the next queued transfer and adds it to the active transfer map within an allocated transfer slot, rather than before allocating a slot. Fixes the transfers display, which had been displaying the next transfer as a running transfer, while the previous transfer was still running.
This commit is contained in:
parent
19e8f1ca0e
commit
0dd7860393
3 changed files with 52 additions and 50 deletions
|
@ -9,13 +9,15 @@
|
|||
|
||||
module Assistant.TransferSlots where
|
||||
|
||||
import Common.Annex
|
||||
import Utility.ThreadScheduler
|
||||
import Assistant.DaemonStatus
|
||||
import Logs.Transfer
|
||||
|
||||
import qualified Control.Exception as E
|
||||
import Control.Concurrent
|
||||
import Data.Typeable
|
||||
|
||||
import Common.Annex
|
||||
import Utility.ThreadScheduler
|
||||
|
||||
type TransferSlots = QSemN
|
||||
|
||||
{- A special exception that can be thrown to pause or resume a transfer, while
|
||||
|
@ -25,7 +27,8 @@ data TransferException = PauseTransfer | ResumeTransfer
|
|||
|
||||
instance E.Exception TransferException
|
||||
|
||||
type TransferSlotRunner = TransferSlots -> IO () -> IO ThreadId
|
||||
type TransferSlotRunner = DaemonStatusHandle -> TransferSlots -> TransferGenerator -> IO ()
|
||||
type TransferGenerator = IO (Maybe (Transfer, TransferInfo, IO ()))
|
||||
|
||||
{- Number of concurrent transfers allowed to be run from the assistant.
|
||||
-
|
||||
|
@ -38,31 +41,40 @@ numSlots = 1
|
|||
newTransferSlots :: IO TransferSlots
|
||||
newTransferSlots = newQSemN numSlots
|
||||
|
||||
{- Waits until a transfer slot becomes available, and runs a transfer
|
||||
- action in the slot, in its own thread.
|
||||
{- Waits until a transfer slot becomes available, then runs a
|
||||
- TransferGenerator, and then runs the transfer action in its own thread.
|
||||
-}
|
||||
inTransferSlot :: TransferSlotRunner
|
||||
inTransferSlot = runTransferSlot (\s -> waitQSemN s 1)
|
||||
inTransferSlot dstatus s gen = do
|
||||
waitQSemN s 1
|
||||
runTransferThread dstatus s =<< gen
|
||||
|
||||
{- Runs a transfer action, without waiting for a slot to become available. -}
|
||||
{- Runs a TransferGenerator, and its transfer action,
|
||||
- without waiting for a slot to become available. -}
|
||||
inImmediateTransferSlot :: TransferSlotRunner
|
||||
inImmediateTransferSlot = runTransferSlot (\s -> signalQSemN s (-1))
|
||||
inImmediateTransferSlot dstatus s gen = do
|
||||
signalQSemN s (-1)
|
||||
runTransferThread dstatus s =<< gen
|
||||
|
||||
{- Note that the action is subject to being killed when the transfer
|
||||
{- Runs a transfer action, in an already allocated transfer slot.
|
||||
- Once it finishes, frees the transfer slot.
|
||||
-
|
||||
- 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.
|
||||
-}
|
||||
runTransferSlot :: (QSemN -> IO ()) -> TransferSlotRunner
|
||||
runTransferSlot allocator s transfer = do
|
||||
allocator s
|
||||
forkIO $ E.bracket_ noop (signalQSemN s 1) go
|
||||
runTransferThread :: DaemonStatusHandle -> TransferSlots -> Maybe (Transfer, TransferInfo, IO ()) -> IO ()
|
||||
runTransferThread _ s Nothing = signalQSemN s 1
|
||||
runTransferThread dstatus s (Just (t, info, a)) = do
|
||||
tid <- forkIO $ E.bracket_ noop (signalQSemN s 1) go
|
||||
updateTransferInfo dstatus t $ info { transferTid = Just tid }
|
||||
where
|
||||
go = catchPauseResume transfer
|
||||
go = catchPauseResume a
|
||||
pause = catchPauseResume $ runEvery (Seconds 86400) noop
|
||||
catchPauseResume a = E.catch a handlePauseResume
|
||||
catchPauseResume a' = E.catch a' handlePauseResume
|
||||
handlePauseResume PauseTransfer = do
|
||||
putStrLn "pause"
|
||||
pause
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue