diff options
| author |  Joey Hess <joey@kitenet.net> | 2012-07-06 21:45:08 -0600 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2012-07-06 21:59:45 -0600 |
| commit | cc6f660752d4eef1e667f1ac859c6140f4da87ca (patch) | |
| tree | 8605cbd31e97154794cd9998faee58cea6ff83e7 /Assistant/TransferSlots.hs | |
| parent | d954a0ce5934a877f8df0c683eaccaf8c2b1938e (diff) | |
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.
Diffstat (limited to 'Assistant/TransferSlots.hs')
| -rw-r--r-- | Assistant/TransferSlots.hs | 14 |
1 files changed, 12 insertions, 2 deletions
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 0e2bb98b0..1859b281b 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -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 |