it builds again

Currently nothing waits on transfer processes.

(Second drive of the day fried. Not concentrating very well.)

2 files changed, 37 insertions, 4 deletions

diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index 0d0bc6f6d..3e417e7ff 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -11,6 +11,7 @@ import Common.Annex
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.TransferQueue
+import Assistant.TransferSlots
 import Logs.Transfer
 import Annex.Content
 import Utility.ThreadScheduler
@@ -25,14 +26,16 @@ maxTransfers :: Int
 maxTransfers = 1
 
 {- Dispatches transfers from the queue. -}
-transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> IO ()
-transfererThread st dstatus transferqueue = runEvery (Seconds 1) $ do
+transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
+transfererThread st dstatus transferqueue slots = runEvery (Seconds 1) $ do
 	(t, info) <- getNextTransfer transferqueue
 	c <- runThreadState st $ shouldTransfer dstatus t
+	let run = void $ inTransferSlot slots $
+		runTransfer st dstatus t info
 	case c of
-		Yes -> void $ runTransfer st dstatus t info
+		Yes -> run
 		Skip -> noop
-		TooMany -> void $ waitTransfer >> runTransfer st dstatus t info
+		TooMany -> waitTransfer >> run
 
 data ShouldTransfer = Yes | Skip | TooMany
 
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
new file mode 100644
index 000000000..0e2bb98b0
--- /dev/null
+++ b/Assistant/TransferSlots.hs
@@ -0,0 +1,30 @@
+{- 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
+
+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.
+ -}
+inTransferSlot :: TransferSlots -> IO a -> IO a
+inTransferSlot s = bracket_ (waitQSemN s 1) (signalQSemN s 1)