如何在不阻止Haskell中的线程的情况下从进程检索输出

Question

在不阻塞的情况下写入标准输入和从子进程的标准输出读取的最佳方法是什么？

通过创建子流程，通过该子流程System.IO.createProcess返回用于写入和读取子流程的句柄。书写和阅读以文本格式完成。

例如，我做非阻塞读取的最佳尝试是timeout 1 $ hGetLine out返回a Just "some line"或Nothing如果不存在要读取的行。但是，对我来说这似乎是一个hack，因此我正在寻找一种更“标准”的方式。

谢谢

Answer 1

以下是一些如何以@jberryman提到的方式与生成的流程进行交互的示例。

该程序与一个脚本交互，该脚本./compute仅从stdin读取格式的行，<x> <y>并在y秒的延迟后返回x + 1。更多细节请点击这里。

与生成的流程进行交互时，有许多警告。为了避免“遭受缓冲的折磨”，您需要在每次发送输入时都刷新输出管道，并且在生成的进程每次发送响应时都需要刷新stdout。如果发现stdout没有足够及时地刷新，则可以通过伪tty与该进程进行交互。

此外，这些示例还假设关闭输入管道将导致生成过程终止。如果不是这种情况，则必须向其发送信号以确保终止。

这是示例代码- main有关示例调用，请参见最后的例程。

import System.Environment
import System.Timeout (timeout)
import Control.Concurrent
import Control.Concurrent (forkIO, threadDelay, killThread)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)

import System.Process
import System.IO

-- blocking IO
main1 cmd tmicros = do
  r <- createProcess (proc "./compute" []) { std_out = CreatePipe, std_in = CreatePipe }
  let (Just inp, Just outp, _, phandle) = r

  hSetBuffering inp NoBuffering
  hPutStrLn inp cmd     -- send a command

  -- block until the response is received
  contents <- hGetLine outp
  putStrLn $ "got: " ++ contents

  hClose inp            -- and close the pipe
  putStrLn "waiting for process to terminate"
  waitForProcess phandle

-- non-blocking IO, send one line, wait the timeout period for a response
main2 cmd tmicros = do
  r <- createProcess (proc "./compute" []) { std_out = CreatePipe, std_in = CreatePipe }
  let (Just inp, Just outp, _, phandle) = r

  hSetBuffering inp NoBuffering
  hPutStrLn inp cmd   -- send a command, will respond after 4 seconds

  mvar <- newEmptyMVar
  tid  <- forkIO $ hGetLine outp >>= putMVar mvar

  -- wait the timeout period for the response
  result <- timeout tmicros (takeMVar mvar)
  killThread tid

  case result of
    Nothing -> putStrLn "timed out"
    Just x  -> putStrLn $ "got: " ++ x

  hClose inp            -- and close the pipe
  putStrLn "waiting for process to terminate"
  waitForProcess phandle

-- non-block IO, send one line, report progress every timeout period
main3 cmd tmicros = do
  r <- createProcess (proc "./compute" []) { std_out = CreatePipe, std_in = CreatePipe }
  let (Just inp, Just outp, _, phandle) = r

  hSetBuffering inp NoBuffering
  hPutStrLn inp cmd   -- send command

  mvar <- newEmptyMVar
  tid  <- forkIO $ hGetLine outp >>= putMVar mvar

  -- loop until response received; report progress every timeout period
  let loop = do result <- timeout tmicros (takeMVar mvar)
                case result of
                  Nothing -> putStrLn  "still waiting..." >> loop
                  Just x  -> return x
  x <- loop
  killThread tid

  putStrLn $ "got: " ++ x

  hClose inp            -- and close the pipe
  putStrLn "waiting for process to terminate"
  waitForProcess phandle

{-

Usage: ./prog which delay timeout

  where
    which   = main routine to run: 1, 2 or 3
    delay   = delay in seconds to send to compute script
    timeout = timeout in seconds to wait for response

E.g.:

  ./prog 1 4 3   -- note: timeout is ignored for main1
  ./prog 2 2 3   -- should timeout
  ./prog 2 4 3   -- should get response
  ./prog 3 4 1   -- should see "still waiting..." a couple of times

-}

main = do
  (which : vtime : tout : _) <- fmap (map read) getArgs
  let cmd = "10 " ++ show vtime
      tmicros = 1000000*tout :: Int
  case which of
    1 -> main1 cmd tmicros
    2 -> main2 cmd tmicros
    3 -> main3 cmd tmicros
    _   -> error "huh?"