d5e06e7b89
This doesn't quite work, because canceling a transfer sends a signal to git-annex, but not to rsync (etc). Looked at making git-annex run in its own process group, which could then be killed, and would kill child processes. But, rsync checks if it's process group is the foreground process group and doesn't show progress if not, and when git has run git-annex, if git-annex makes a new process group, that is not the case. Also, if git has run git-annex, ctrl-c wouldn't be propigated to it if it made a new process group. So this seems like a blind alley, but recording it here just in case.
40 lines
1 KiB
Haskell
40 lines
1 KiB
Haskell
{- git-annex assistant transfer slots
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.TransferSlots where
|
|
|
|
import Control.Exception
|
|
import Control.Concurrent
|
|
|
|
import Common.Annex
|
|
|
|
type TransferSlots = QSemN
|
|
|
|
{- Number of concurrent transfers allowed to be run from the assistant.
|
|
-
|
|
- Transfers launched by other means, including by remote assistants,
|
|
- do not currently take up slots.
|
|
-}
|
|
numSlots :: Int
|
|
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. Note that this thread is
|
|
- subject to being killed when the transfer is canceled. -}
|
|
inTransferSlot :: TransferSlots -> IO () -> IO ThreadId
|
|
inTransferSlot s a = do
|
|
waitQSemN s 1
|
|
forkIO $ bracket_ noop done a
|
|
where
|
|
done = transferComplete s
|
|
|
|
{- Call when a transfer is complete. -}
|
|
transferComplete :: TransferSlots -> IO ()
|
|
transferComplete s = signalQSemN s 1
|