Run.hs

-- This module is heavily inspired/copied by/from Don Stewats System.Process.Run
-- module. See http://www.haskell.org/pipermail/libraries/2006-December/006632.html
-- and http://www.cse.unsw.edu.au/~dons/code/newpopen/
--
-- Stewats module has a BSD-style license.

module Run (readCommand, ExitCode(ExitSuccess, ExitFailure)) where

import System.Process
import System.Exit
import System.IO

import Control.Monad
import Control.Concurrent
import qualified Control.Exception as C

data Output = Standard { contents :: String }
            | Error    { contents :: String }   deriving Show

--
-- |readCommand forks an external thread, reads its standard output
-- and standard error, waits for the process to terminate, and
-- returns the output (both standard output and standard error) and
-- an exitcode.
--
readCommand :: String                       -- ^ command to run
            -> String                       -- ^ standard input
            -> IO (ExitCode, String)        -- ^ exitcode and output
readCommand cmd input = C.handle (return . handler) $ do

    (inh,outh,errh,pid) <- runInteractiveCommand cmd

    -- fork off a thread to start consuming the output
    commonOutputMVar <- newMVar []
    stdOutIsFinished <- newEmptyMVar
    stdErrIsFinished <- newEmptyMVar
    
    let consume handle isFinished outputMVar =
            do outIsEOF <- hIsEOF handle
               if outIsEOF
                  then putMVar isFinished ()
                  else do x <- hGetLine handle
                          modifyMVar_ outputMVar (\y -> return $ y ++ [Standard x])
                          consume handle isFinished outputMVar
    forkIO $ consume outh stdOutIsFinished commonOutputMVar
    forkIO $ consume errh stdErrIsFinished commonOutputMVar

    -- now write and flush any input
    when (not (null input)) $ hPutStr inh input
    hClose inh          -- done with stdin
    
    -- wait on the output
    takeMVar stdOutIsFinished
    takeMVar stdErrIsFinished
    hClose outh
    hClose errh
    output <- takeMVar commonOutputMVar
    -- We could drop the *IsFinished MVars and just use waitForProcess. However, according to
    -- http://haskell.org/ghc/docs/latest/html/libraries/base/System-Process.html#v%3AwaitForProcess
    -- this would require the program to be compiled with -threaded.
    ex <- C.catch (waitForProcess pid) (\_ -> return ExitSuccess)
    
    return (ex, unlines $ map contents output)

  where
    handler (C.ExitException e) = (e, [])
    handler e                   = (ExitFailure 1, [])