我在函数内部调用外部程序。现在我想让这个函数超时,而不仅仅是外部程序。但是在函数超时后,外部程序仍然在我的计算机上运行(我使用的是debian),直到它完成它的计算,之后它的线程仍然作为我的主程序的子线程保留在进程表中,直到主程序终止。
这里有两个最小的例子来说明我想要做什么。第一个使用unsafePerformIO,第二个完全在IO monad中。我并不真的依赖于unsafePerformIO,但如果可能的话,我想保留它。无论有没有它,都会出现所描述的问题。
使用unsafePerformIO
module Main where
import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process
main = do
x <- time $ timeoutP (1 * 1000000) $ mytest 2
y <- getLine
putStrLn $ show x ++ y
timeoutP :: Int -> a -> IO (Maybe a)
timeoutP t fun = timeout t $ return $! fun
mytest :: Int -> String
mytest n =
let
x = runOnExternalProgram $ n * 1000
in
x ++ ". Indeed."
runOnExternalProgram :: Int -> String
runOnExternalProgram n = unsafePerformIO $ do
-- convert the input to a parameter of the external program
let x = show $ n + 12
-- run the external program
-- (here i use "sleep" to indicate a slow computation)
answer <- readProcess "sleep" [x] ""
-- convert the output as needed
let verboseAnswer = "External program answered: " ++ answer
return verboseAnswer
不使用unsafePerformIO
module Main where
import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process
main = do
x <- time $ timeout (1 * 1000000) $ mytest 2
y <- getLine
putStrLn $ show x ++ y
mytest :: Int -> IO String
mytest n = do
x <- runOnExternalProgram $ n * 1000
return $ x ++ ". Indeed."
runOnExternalProgram :: Int -> IO String
runOnExternalProgram n = do
-- convert the input to a parameter for the external program:
let x = show $ n + 12
-- run the external program
-- (here i use "sleep" to indicate a slow computation):
answer <- readProcess "sleep" [x] ""
-- convert the output as needed:
let verboseAnswer = "External program answered: " ++ answer
return verboseAnswer
也许支架在这里能帮上忙,但我真的不知道该怎么做。
编辑:我采纳了John L的答案。现在,我使用了以下内容:
import Control.Concurrent
import Control.Exception
import System.Exit
import System.IO
import System.IO.Error
import System.Posix.Signals
import System.Process
import System.Process.Internals
safeCreateProcess :: String -> [String] -> StdStream -> StdStream -> StdStream
-> ( ( Maybe Handle
, Maybe Handle
, Maybe Handle
, ProcessHandle
) -> IO a )
-> IO a
safeCreateProcess prog args streamIn streamOut streamErr fun = bracket
( do
h <- createProcess (proc prog args)
{ std_in = streamIn
, std_out = streamOut
, std_err = streamErr
, create_group = True }
return h
)
-- "interruptProcessGroupOf" is in the new System.Process. Since some
-- programs return funny exit codes i implemented a "terminateProcessGroupOf".
-- (\(_, _, _, ph) -> interruptProcessGroupOf ph >> waitForProcess ph)
(\(_, _, _, ph) -> terminateProcessGroup ph >> waitForProcess ph)
fun
{-# NOINLINE safeCreateProcess #-}
safeReadProcess :: String -> [String] -> String -> IO String
safeReadProcess prog args str =
safeCreateProcess prog args CreatePipe CreatePipe Inherit
(\(Just inh, Just outh, _, ph) -> do
hPutStr inh str
hClose inh
-- fork a thread to consume output
output <- hGetContents outh
outMVar <- newEmptyMVar
forkIO $ evaluate (length output) >> putMVar outMVar ()
-- wait on output
takeMVar outMVar
hClose outh
return output
-- The following would be great, if some programs did not return funny
-- exit codes!
-- ex <- waitForProcess ph
-- case ex of
-- ExitSuccess -> return output
-- ExitFailure r ->
-- fail ("spawned process " ++ prog ++ " exit: " ++ show r)
)
terminateProcessGroup :: ProcessHandle -> IO ()
terminateProcessGroup ph = do
let (ProcessHandle pmvar) = ph
ph_ <- readMVar pmvar
case ph_ of
OpenHandle pid -> do -- pid is a POSIX pid
signalProcessGroup 15 pid
otherwise -> return ()
这解决了我的问题。它会在适当的时候杀死所产生的进程的所有子进程。
致以亲切的问候。
发布于 2012-01-11 23:48:30
编辑:可以获得衍生进程的pid。您可以使用如下代码来完成此操作:
-- highly non-portable, and liable to change between versions
import System.Process.Internals
-- from the finalizer of the bracketed function
-- `ph` is a ProcessHandle as returned by createProcess
(\(_,_,_,ph) -> do
let (ProcessHandle pmvar) = ph
ph_ <- takeMVar pmvar
case ph_ of
OpenHandle pid -> do -- pid is a POSIX pid
... -- do stuff
putMVar pmvar ph_
如果您终止了进程,而不是将打开的ph_
放入mvar中,则应该创建一个适当的ClosedHandle
并将其放回原处。很重要的一点是,这段代码是屏蔽执行的(括号会帮你做到这一点)。
现在您有了一个POSIX id,您可以根据需要使用系统调用或shell来杀死它。只需注意,如果您使用该路径,您的Haskell可执行文件不在同一进程组中。
/end编辑
这种行为似乎是合理的。timeout
的文档声称它根本不适用于非Haskell代码,事实上,我看不到它可以通用的任何方法。发生的情况是,readProcess
会产生一个新进程,但随后在等待该进程的输出时超时。当异常中止时,readProcess
似乎不会终止衍生的进程。这可能是readProcess
中的一个错误,也可能是设计出来的。
作为一种变通方法,我认为您需要自己实现其中的一部分。timeout
通过在派生的线程中引发异步异常来工作。如果您将runOnExternalProgram
包装在异常处理程序中,您将获得您想要的行为。
这里的关键函数是新的runOnExternalProgram
,它是原始函数和readProcess
的组合。更好的做法是(更模块化、更可重用、更可维护)创建一个新的readProcess
,在引发异常时终止衍生的进程,但我将其作为练习。
module Main where
import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process
import Control.Exception
import System.IO
import System.IO.Error
import GHC.IO.Exception
import System.Exit
import Control.Concurrent.MVar
import Control.Concurrent
main = do
x <- time $ timeoutP (1 * 1000000) $ mytest 2
y <- getLine
putStrLn $ show x ++ y
timeoutP :: Int -> IO a -> IO (Maybe a)
timeoutP t fun = timeout t $ fun
mytest :: Int -> IO String
mytest n = do
x <- runOnExternalProgram $ n * 1000
return $ x ++ ". Indeed."
runOnExternalProgram :: Int -> IO String
runOnExternalProgram n =
-- convert the input to a parameter of the external program
let x = show $ n + 12
in bracketOnError
(createProcess (proc "sleep" [x]){std_in = CreatePipe
,std_out = CreatePipe
,std_err = Inherit})
(\(Just inh, Just outh, _, pid) -> terminateProcess pid >> waitForProcess pid)
(\(Just inh, Just outh, _, pid) -> do
-- fork a thread to consume output
output <- hGetContents outh
outMVar <- newEmptyMVar
forkIO $ evaluate (length output) >> putMVar outMVar ()
-- no input in this case
hClose inh
-- wait on output
takeMVar outMVar
hClose outh
-- wait for process
ex <- waitForProcess pid
case ex of
ExitSuccess -> do
-- convert the output as needed
let verboseAnswer = "External program answered: " ++ output
return verboseAnswer
ExitFailure r ->
ioError (mkIOError OtherError ("spawned process exit: " ++ show r) Nothing Nothing) )
https://stackoverflow.com/questions/8820903
复制相似问题