avoid repeatedly searching path to make batch command when running transferkeys

Assistant/Threads/Transferrer.hs

@@ -12,12 +12,14 @@ import Assistant.TransferQueue
 import Assistant.TransferSlots
 import Logs.Transfer
 import Config.Files
+import Utility.Batch
 
 {- Dispatches transfers from the queue. -}
 transfererThread :: NamedThread
 transfererThread = namedThread "Transferrer" $ do
 	program <- liftIO readProgramFile
-	forever $ inTransferSlot program $
+	batchmaker <- liftIO getBatchCommandMaker
+	forever $ inTransferSlot program batchmaker $
 		maybe (return Nothing) (uncurry genTransfer)
 			=<< getNextTransfer notrunning
   where

Assistant/TransferSlots.hs

@@ -29,6 +29,7 @@ import qualified Types.Remote as Remote
 import Annex.Content
 import Annex.Wanted
 import Config.Files
+import Utility.Batch
 
 import qualified Data.Map as M 
 import qualified Control.Exception as E
@@ -44,17 +45,17 @@ type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -
 {- Waits until a transfer slot becomes available, then runs a
  - TransferGenerator, and then runs the transfer action in its own thread. 
  -}
-inTransferSlot :: FilePath -> TransferGenerator -> Assistant ()
-inTransferSlot program gen = do
+inTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()
+inTransferSlot program batchmaker gen = do
 	flip MSemN.wait 1 <<~ transferSlots
-	runTransferThread program =<< gen
+	runTransferThread program batchmaker =<< gen
 
 {- Runs a TransferGenerator, and its transfer action,
  - without waiting for a slot to become available. -}
-inImmediateTransferSlot :: FilePath -> TransferGenerator -> Assistant ()
-inImmediateTransferSlot program gen = do
+inImmediateTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()
+inImmediateTransferSlot program batchmaker gen = do
 	flip MSemN.signal (-1) <<~ transferSlots
-	runTransferThread program =<< gen
+	runTransferThread program batchmaker =<< gen
 
 {- Runs a transfer action, in an already allocated transfer slot.
  - Once it finishes, frees the transfer slot.
@@ -66,19 +67,19 @@ inImmediateTransferSlot program gen = do
  - then pausing the thread until a ResumeTransfer exception is raised,
  - then rerunning the action.
  -}
-runTransferThread :: FilePath -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
-runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots
-runTransferThread program (Just (t, info, a)) = do
+runTransferThread :: FilePath -> BatchCommandMaker -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
+runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots
+runTransferThread program batchmaker (Just (t, info, a)) = do
 	d <- getAssistant id
 	aio <- asIO1 a
-	tid <- liftIO $ forkIO $ runTransferThread' program d aio
+	tid <- liftIO $ forkIO $ runTransferThread' program batchmaker d aio
 	updateTransferInfo t $ info { transferTid = Just tid }
 
-runTransferThread' :: FilePath -> AssistantData -> (Transferrer -> IO ()) -> IO ()
-runTransferThread' program d run = go
+runTransferThread' :: FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO ()
+runTransferThread' program batchmaker d run = go
   where
 	go = catchPauseResume $
-		withTransferrer program (transferrerPool d)
+		withTransferrer program batchmaker (transferrerPool d)
 			run
 	pause = catchPauseResume $
 		runEvery (Seconds 86400) noop
@@ -279,7 +280,8 @@ startTransfer t = do
 		liftIO $ throwTo tid ResumeTransfer
 	start info = do
 		program <- liftIO readProgramFile
-		inImmediateTransferSlot program $
+		batchmaker <- liftIO getBatchCommandMaker
+		inImmediateTransferSlot program batchmaker $
 			genTransfer t info
 
 getCurrentTransfers :: Assistant TransferMap

Assistant/TransferrerPool.hs

@@ -24,9 +24,9 @@ import Control.Exception (throw)
 import Control.Concurrent
 
 {- Runs an action with a Transferrer from the pool. -}
-withTransferrer :: FilePath -> TransferrerPool -> (Transferrer -> IO a) -> IO a
-withTransferrer program pool a = do
-	t <- maybe (mkTransferrer program) (checkTransferrer program)
+withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a
+withTransferrer program batchmaker pool a = do
+	t <- maybe (mkTransferrer program batchmaker) (checkTransferrer program batchmaker)
 		=<< atomically (tryReadTChan pool)
 	v <- tryNonAsync $ a t
 	unlessM (putback t) $
@@ -53,8 +53,8 @@ performTransfer transferrer t f = catchBoolIO $ do
 
 {- Starts a new git-annex transferkeys process, setting up a pipe
  - that will be used to communicate with it. -}
-mkTransferrer :: FilePath -> IO Transferrer
-mkTransferrer program = do
+mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer
+mkTransferrer program batchmaker = do
 #ifndef mingw32_HOST_OS
 	(myread, twrite) <- createPipe
 	(tread, mywrite) <- createPipe
@@ -65,7 +65,7 @@ mkTransferrer program = do
 		, Param "--writefd", Param $ show twrite
 		]
 	{- It runs as a batch job. -}
-	(program', params') <- toBatchCommand (program, params)
+	let (program', params') = batchmaker (program, params)
 	{- It's put into its own group so that the whole group can be
 	 - killed to stop a transfer. -}
 	(_, _, _, pid) <- createProcess (proc program' $ toCommand params')
@@ -86,9 +86,10 @@ mkTransferrer program = do
 #endif
 
 {- Checks if a Transferrer is still running. If not, makes a new one. -}
-checkTransferrer :: FilePath -> Transferrer -> IO Transferrer
-checkTransferrer program t = maybe (return t) (const $ mkTransferrer program)
-	=<< getProcessExitCode (transferrerHandle t)
+checkTransferrer :: FilePath -> BatchCommandMaker -> Transferrer -> IO Transferrer
+checkTransferrer program batchmaker t =
+	maybe (return t) (const $ mkTransferrer program batchmaker)
+		=<< getProcessExitCode (transferrerHandle t)
 
 {- Closing the fds will stop the transferrer. -}
 stopTransferrer :: Transferrer -> IO ()

Utility/Batch.hs

@@ -45,22 +45,28 @@ maxNice = 19
 
 {- Makes a command be run by whichever of nice, ionice, and nocache
  - are available in the path. -}
-toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam])
-toBatchCommand (command, params) = do
+type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam])
+
+getBatchCommandMaker :: IO BatchCommandMaker
+getBatchCommandMaker = do
 #ifndef mingw32_HOST_OS
 	nicers <- filterM (inPath . fst)
 		[ ("nice", [])
 		, ("ionice", ["-c3"])
 		, ("nocache", [])
 		]
-	let (command', params') = case nicers of
-		[] -> (command, params)
-		(first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params)
+	return $ \(command, params) ->
+		case nicers of
+			[] -> (command, params)
+			(first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params)
 #else
-	let command' = command
-	let params' = params
+	return id
 #endif
-	return (command', params')
+
+toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam])
+toBatchCommand v = do
+	batchmaker <- getBatchCommandMaker
+	return $ batchmaker v
 
 {- Runs a command in a way that's suitable for batch jobs that can be
  - interrupted.
@@ -73,7 +79,8 @@ batchCommand command params = batchCommandEnv command params Nothing
 
 batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
 batchCommandEnv command params environ = do
-	(command', params') <- toBatchCommand (command, params)
+	batchmaker <- getBatchCommandMaker
+	let (command', params') = batchmaker (command, params)
 	let p = proc command' $ toCommand params'
 	(_, _, _, pid) <- createProcess $ p { env = environ }
 	r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)