non-blocking I/O examples in Haskell

compute

#!/usr/bin/env perl
#
# A program to interact with via stdin / stdout.
#
# Receives "x y" on stdin; emits x+1 after a delay of y seconds.

$| = 1;

while (<STDIN>) {
  my ($a, $t) = split(' ', $_);
  sleep $t;
  print $a+1, "\n";
}

Timed.hs

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