diff options
author | Joey Hess <joeyh@debian.org> | 2013-12-03 15:02:21 -0400 |
---|---|---|
committer | Joey Hess <joeyh@debian.org> | 2013-12-03 15:02:21 -0400 |
commit | a4f3e112954e1b785c84c339bcbd83597a89335e (patch) | |
tree | eb2a975663782f83e6b20d6d239447d7222de81b /Utility/Batch.hs | |
download | git-repair-a4f3e112954e1b785c84c339bcbd83597a89335e.tar.gz |
git-repair (1.20131203) unstable; urgency=low
* Fix build deps. Closes: #731179
# imported from the archive
Diffstat (limited to 'Utility/Batch.hs')
-rw-r--r-- | Utility/Batch.hs | 93 |
1 files changed, 93 insertions, 0 deletions
diff --git a/Utility/Batch.hs b/Utility/Batch.hs new file mode 100644 index 0000000..61026f1 --- /dev/null +++ b/Utility/Batch.hs @@ -0,0 +1,93 @@ +{- Running a long or expensive batch operation niced. + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.Batch where + +import Common + +#if defined(linux_HOST_OS) || defined(__ANDROID__) +import Control.Concurrent.Async +import System.Posix.Process +#endif +import qualified Control.Exception as E +import System.Process (env) + +{- Runs an operation, at batch priority. + - + - This is done by running it in a bound thread, which on Linux can be set + - to have a different nice level than the rest of the program. Note that + - due to running in a bound thread, some operations may be more expensive + - to perform. Also note that if the action calls forkIO or forkOS itself, + - that will make a new thread that does not have the batch priority. + - + - POSIX threads do not support separate nice levels, so on other operating + - systems, the action is simply ran. + -} +batch :: IO a -> IO a +#if defined(linux_HOST_OS) || defined(__ANDROID__) +batch a = wait =<< batchthread + where + batchthread = asyncBound $ do + setProcessPriority 0 maxNice + a +#else +batch a = a +#endif + +maxNice :: Int +maxNice = 19 + +{- Makes a command be run by whichever of nice, ionice, and nocache + - are available in the path. -} +type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam]) + +getBatchCommandMaker :: IO BatchCommandMaker +getBatchCommandMaker = do +#ifndef mingw32_HOST_OS + nicers <- filterM (inPath . fst) + [ ("nice", []) + , ("ionice", ["-c3"]) + , ("nocache", []) + ] + 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 + return id +#endif + +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. + - + - If the calling thread receives an async exception, it sends the + - command a SIGTERM, and after the command finishes shuttting down, + - it re-raises the async exception. -} +batchCommand :: String -> [CommandParam] -> IO Bool +batchCommand command params = batchCommandEnv command params Nothing + +batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +batchCommandEnv command params environ = do + 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) + case r of + Right ExitSuccess -> return True + Right _ -> return False + Left asyncexception -> do + terminateProcess pid + void $ waitForProcess pid + E.throwIO asyncexception |