summaryrefslogtreecommitdiff
path: root/Utility/Batch.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Utility/Batch.hs')
-rw-r--r--Utility/Batch.hs50
1 files changed, 26 insertions, 24 deletions
diff --git a/Utility/Batch.hs b/Utility/Batch.hs
index 035a2eb..61026f1 100644
--- a/Utility/Batch.hs
+++ b/Utility/Batch.hs
@@ -10,9 +10,6 @@
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
@@ -46,36 +43,45 @@ batch a = a
maxNice :: Int
maxNice = 19
-{- Converts a command to run niced. -}
-toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam])
-toBatchCommand (command, params) = (command', params')
- where
+{- 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
- commandline = unwords $ map shellEscape $ command : toCommand params
- nicedcommand
- | Build.SysConfig.nice = "nice " ++ commandline
- | otherwise = commandline
- command' = "sh"
- params' =
- [ Param "-c"
- , Param $ "exec " ++ nicedcommand
+ 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
- command' = command
- params' = params
+ 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.
-
- - 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. -}
+ - 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
@@ -85,7 +91,3 @@ batchCommandEnv command params environ = do
terminateProcess pid
void $ waitForProcess pid
E.throwIO asyncexception
- where
- (command', params') = toBatchCommand (command, params)
- p = proc command' $ toCommand params'
-