maintain pools of running transferkeys processes (untested)

1 files changed, 21 insertions, 16 deletions

diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 7c9f74702..81a778a0a 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -11,28 +11,30 @@ import Assistant.Common
 import Utility.ThreadScheduler
 import Assistant.Types.TransferSlots
 import Assistant.DaemonStatus
+import Assistant.TransferrerPool
+import Assistant.Types.TransferrerPool
 import Logs.Transfer
 
 import qualified Control.Exception as E
 import Control.Concurrent
 import qualified Control.Concurrent.MSemN as MSemN
 
-type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Assistant ()))
+type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
 
 {- Waits until a transfer slot becomes available, then runs a
  - TransferGenerator, and then runs the transfer action in its own thread. 
  -}
-inTransferSlot :: TransferGenerator -> Assistant ()
-inTransferSlot gen = do
+inTransferSlot :: FilePath -> TransferGenerator -> Assistant ()
+inTransferSlot program gen = do
 	flip MSemN.wait 1 <<~ transferSlots
-	runTransferThread =<< gen
+	runTransferThread program =<< gen
 
 {- Runs a TransferGenerator, and its transfer action,
  - without waiting for a slot to become available. -}
-inImmediateTransferSlot :: TransferGenerator -> Assistant ()
-inImmediateTransferSlot gen = do
+inImmediateTransferSlot :: FilePath -> TransferGenerator -> Assistant ()
+inImmediateTransferSlot program gen = do
 	flip MSemN.signal (-1) <<~ transferSlots
-	runTransferThread =<< gen
+	runTransferThread program =<< gen
 
 {- Runs a transfer action, in an already allocated transfer slot.
  - Once it finishes, frees the transfer slot.
@@ -44,19 +46,22 @@ inImmediateTransferSlot gen = do
  - then pausing the thread until a ResumeTransfer exception is raised,
  - then rerunning the action.
  -}
-runTransferThread :: Maybe (Transfer, TransferInfo, Assistant ()) -> Assistant ()
-runTransferThread Nothing = flip MSemN.signal 1 <<~ transferSlots
-runTransferThread (Just (t, info, a)) = do
+runTransferThread :: FilePath -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
+runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots
+runTransferThread program (Just (t, info, a)) = do
 	d <- getAssistant id
-	aio <- asIO a
-	tid <- liftIO $ forkIO $ runTransferThread' d aio
+	aio <- asIO1 a
+	tid <- liftIO $ forkIO $ runTransferThread' program d aio
 	updateTransferInfo t $ info { transferTid = Just tid }
 
-runTransferThread' :: AssistantData -> IO () -> IO ()
-runTransferThread' d a = go
+runTransferThread' :: FilePath -> AssistantData -> (Transferrer -> IO ()) -> IO ()
+runTransferThread' program d run = go
   where
-	go = catchPauseResume a
-	pause = catchPauseResume $ runEvery (Seconds 86400) noop
+	go = catchPauseResume $
+		withTransferrer program (transferrerPool d)
+			run
+	pause = catchPauseResume $
+		runEvery (Seconds 86400) noop
 	{- Note: This must use E.try, rather than E.catch.
 	 - When E.catch is used, and has called go in its exception
 	 - handler, Control.Concurrent.throwTo will block sometimes