fix transfer slots blocking and refilling when transfers are stopped
There's a bug, if a transfer process notices it needs to do nothing, it never starts the transfer, so the slot is never freed.
This commit is contained in:
parent
d954a0ce59
commit
cc6f660752
3 changed files with 27 additions and 14 deletions
|
@ -24,7 +24,17 @@ newTransferSlots :: IO TransferSlots
|
|||
newTransferSlots = newQSemN numSlots
|
||||
|
||||
{- Waits until a transfer slot becomes available, and runs a transfer
|
||||
- action in the slot.
|
||||
- action in the slot. If the action throws an exception, its slot is
|
||||
- freed here, otherwise it should be freed by the TransferWatcher when
|
||||
- the transfer is complete.
|
||||
-}
|
||||
inTransferSlot :: TransferSlots -> IO a -> IO a
|
||||
inTransferSlot s = bracket_ (waitQSemN s 1) (signalQSemN s 1)
|
||||
inTransferSlot s a = bracketOnError start abort run
|
||||
where
|
||||
start = waitQSemN s 1
|
||||
abort = const $ transferComplete s
|
||||
run = const a
|
||||
|
||||
{- Call when a transfer is complete. -}
|
||||
transferComplete :: TransferSlots -> IO ()
|
||||
transferComplete s = signalQSemN s 1
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue