Haskell:如何使运行外部命令的函数超时

Question

我在函数内部调用一个外部程序。现在我想暂停这个函数，而不仅仅是外部程序。但在函数超时后，外部程序仍在我的计算机上运行（我使用的是debian），直到它完成计算，之后它的线程仍作为主程序的子线程留在进程表中，直到主程序终止。

这里有两个最简单的例子来说明我想做什么。第一个使用unsafePerformIO，第二个完全在IO monad中。我并不真的依赖不安全的PerformIO，但如果可能的话，我想保留它。所描述的问题在有和没有它的情况下都会发生。

带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

无不安全PerformIO

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

也许括号可以帮上忙，但我真的不知道怎么做。

编辑：我采纳了约翰·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 ()

这解决了我的问题。它会在正确的时间杀死派生进程的所有子进程。

致以亲切的问候。

Answer 1

编辑：可以获取派生进程的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可执行文件不在同一个进程组中，如果你走那条路的话。

/结束编辑

这种行为似乎有点明智。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) )