Question

我必须编写一个命令行工具，将一些组件粘合在一起进行实验，并需要帮助来完成符合我要求的代码设计。

在顶层，我必须处理每个由运行时和内存消耗生成的样本 - 使用函数＆＃34; System.Process.readProcessWithExitCode＆＃34;对另一个程序进行昂贵的调用。因此，你可以想象有一个（昂贵的）功能＆＃34; genSample :: IO a＆＃34;你需要n返回该函数的值。

我的要求是： 1.令p为处理器的数量，然后最多p个样本（即对genSample的调用）应该并行计算。 2.应该可以设置超时，中止样本的生成。 3.如果所有样本的计算超时，则应停止genSample-call中的已启动进程

我当前的解决方案符合要求1和2.对于第三个，我目前通过执行killall命令来帮助自己。这对我来说似乎是一个肮脏的黑客。也许有人有更好的主意？

这是我当前解决方案的核心部分：

import qualified Control.Monad.Par.Class as ParIO
import qualified Control.Monad.Par.IO as ParIO
…
-- | @parRepeatM i n a@ performs action @a@ @n@ times in parallel with timeout @t@
parRepeatM :: ParIO.NFData a =>
              Integer -- ^ timeout in seconds
           -> Integer -- ^ number of duplicates (here: number of req. samples)
           -> IO a    -- ^ action to perform (here: genSample)
           -> IO (Maybe [a])
parRepeatM t n a = timeout t $ ParIO.runParIO $ do
  let tasks = genericReplicate n $ liftIO a -- :: [ParIO a]
  ivars <- mapM ParIO.spawn tasks
  mapM ParIO.get ivars

目前的一个核心问题是，在因超时而导致堕胎后，genSample中调用的命令会继续执行 - 在最坏的情况下，直到整个haskell-gluing-program结束。

Answer 1

在Haskell中，取消通常通过异步异常来处理。这是timeout似乎使用的内容。

因此，我们可以尝试在执行外部进程的代码中安装异常处理程序。只要异常（异步或非异常）出现，处理程序就会调用terminateProcess。因为terminateProcess需要引用处理句柄，我们必须使用createProcess而不是更高级readProcessWithExitCode。

首先，一些导入和辅助功能（我使用async包）：

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Applicative
import Control.Exception 
import Control.Concurrent (threadDelay, MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.Async (race_, Concurrently(..), waitEither, withAsync)
import System.Process
import System.Exit
import System.IO
import qualified Data.ByteString as B

-- Executes two actions concurrently and returns the one that finishes first.
-- If an asynchronous exception is thrown, the second action is terminated
-- first.
race' :: IO a -> IO a -> IO a
race' left right =
    withAsync left $ \a ->
    withAsync right $ \b ->
    fmap (either id id) (waitEither a b)

-- terminate external process on exception, ignore if already dead.
terminateCarefully :: ProcessHandle -> IO ()
terminateCarefully pHandle = 
    catch (terminateProcess pHandle) (\(e::IOException) -> return ())

此函数启动外部进程并返回其stdout和退出代码，如果线程被取消则终止进程：

safeExec :: CreateProcess -> IO (B.ByteString, ExitCode)
safeExec cp = 
    bracketOnError 
        (createProcess cp {std_out = CreatePipe})
        (\(_,_        ,_,pHandle) -> terminateCarefully pHandle)  
        (\(_,Just hOut,_,pHandle) -> do
            -- Workaround for a Windows issue.
            latch <- newEmptyMVar
            race' 
               (do -- IO actions are uninterruptible on Windows :(
                  takeMVar latch 
                  contents <- B.hGetContents hOut 
                  ec <- waitForProcess pHandle
                  pure (contents,ec))
               -- Dummy interruptible action that   
               -- receives asynchronous exceptions first
               -- and helps to end the other action.
               (onException 
                   (do 
                      putMVar latch () 
                      -- runs forever unless interrupted
                      runConcurrently empty)
                   (terminateCarefully pHandle)))

关于实施：

bracketOnError用于确保在发生异常时终止外部进程。
在Windows中，从Handle读取等I / O操作是不可中断的（请参阅https://ghc.haskell.org/trac/ghc/ticket/7353）。这意味着它们不受异步异常的影响。作为解决方法，我创建了一个＆＃34;虚拟＆＃34;永远等待的线程（runConcurrently empty）并且可以被异常中断。当它被中断时，它会终止外部进程，导致伴随线程中的读取完成，使得伴随线程再次容易受到异步异常的攻击。</ p>
＆＃34; latch＆＃34;用于防止在安装内部异常处理程序之前对句柄执行任何不间断操作。

它有点复杂，但似乎有效，至少测试过：

main :: IO ()
main = do
    race_ (safeExec $ proc "calc" []) 
          (threadDelay (3*10^6))

三分钟后，calc app被杀死。这是整个gist。

还要记住：

在Windows上，如果进程是由createProcess用shell创建的shell命令，或者是由runCommand或runInteractiveCommand创建的，那么terminateProcess将只终止shell，而不是命令本身。

在Haskell中使用工作池并行运行命令调用的超时

1 个答案: