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:
Joey Hess 2012-07-06 21:45:08 -06:00
parent d954a0ce59
commit cc6f660752
3 changed files with 27 additions and 14 deletions

View file

@ -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