it builds again

Currently nothing waits on transfer processes.

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

Assistant.hs

@@ -84,6 +84,7 @@ import Assistant.Changes
 import Assistant.Commits
 import Assistant.Pushes
 import Assistant.TransferQueue
+import Assistant.TransferSlots
 import Assistant.Threads.Watcher
 import Assistant.Threads.Committer
 import Assistant.Threads.Pusher
@@ -122,7 +123,7 @@ startDaemon assistant foreground
 				, pushThread st dstatus commitchan pushmap
 				, pushRetryThread st pushmap
 				, mergeThread st
-				, transferWatcherThread st dstatus transferslots
+				, transferWatcherThread st dstatus
 				, transfererThread st dstatus transferqueue transferslots
 				, daemonStatusThread st dstatus
 				, sanityCheckerThread st dstatus transferqueue changechan

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 :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
-transfererThread st dstatus transferqueue = runEvery (Seconds 1) $ do
+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
 

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)