diff options
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 4 | ||||
| -rw-r--r-- | Assistant/TransferSlots.hs | 30 | ||||
| -rw-r--r-- | Assistant/TransferrerPool.hs | 19 | ||||
| -rw-r--r-- | Utility/Batch.hs | 25 |
4 files changed, 45 insertions, 33 deletions
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 0bc419e15..53d8a578c 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/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 diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index cb66e845a..4852c36f8 100644 --- a/Assistant/TransferSlots.hs +++ b/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 diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs index 79b609a1d..8ebe81f60 100644 --- a/Assistant/TransferrerPool.hs +++ b/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 () diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 958801e88..61026f19e 100644 --- a/Utility/Batch.hs +++ b/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) |