CODEWITHSUNDEEP
haskell
mljrg
mljrg

Reputation: 4620

How to retrieve output from a process without blocking the thread in Haskell

What is the best way to write to the stdin and read from the stdout of a subprocess without blocking?

The subprocess was created via System.IO.createProcess which returns handles for writing to and reading from the subprocess. The writing and reading is done in text format.

For example, my best attempt at doing non-blocking read is timeout 1 $ hGetLine out which returns a Just "some line" or Nothing if no line exists to be read. However, this seems an hack to me, so I am looking for a more "standard" way.

Thanks

Upvotes: 3

Views: 1046

Answers (1)

ErikR
ErikR

Reputation: 52039

Here are some examples of how to interact with a spawned process in a fashion mentioned by @jberryman.

The program interacts with a script ./compute which simply reads lines from stdin in the form <x> <y> and returns x+1 after a delay of y seconds. More details at this gist.

There are many caveats when interacting with spawned processes. In order to avoid "suffering from buffering" you need to flush the outgoing pipe whenever you send input and the spawned process needs to flush stdout every time it sends a response. Interacting with the process via a pseudo-tty is an alternative if you find that stdout is not flushed promptly enough.

Also, the examples assume that closing the input pipe will lead to termination of the spawn process. If this is not the case you will have to send it a signal to ensure termination.

Here is the example code - see the main routine at the end for sample invocations.

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?"

Upvotes: 7

Related Questions