diff options
Diffstat (limited to 'Utility/Batch.hs')
| -rw-r--r-- | Utility/Batch.hs | 51 |
1 files changed, 51 insertions, 0 deletions
diff --git a/Utility/Batch.hs b/Utility/Batch.hs index c3c34bf27..035a2eb04 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -9,10 +9,17 @@ module Utility.Batch where +import Common +#ifndef mingw32_HOST_OS +import qualified Build.SysConfig +#endif + #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. - @@ -38,3 +45,47 @@ batch a = a maxNice :: Int maxNice = 19 + +{- Converts a command to run niced. -} +toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam]) +toBatchCommand (command, params) = (command', params') + where +#ifndef mingw32_HOST_OS + commandline = unwords $ map shellEscape $ command : toCommand params + nicedcommand + | Build.SysConfig.nice = "nice " ++ commandline + | otherwise = commandline + command' = "sh" + params' = + [ Param "-c" + , Param $ "exec " ++ nicedcommand + ] +#else + command' = command + params' = params +#endif + +{- Runs a command in a way that's suitable for batch jobs that can be + - interrupted. + - + - The command is run niced. 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 + (_, _, _, 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 + where + (command', params') = toBatchCommand (command, params) + p = proc command' $ toCommand params' + |