module Control.Concurrent.STM.Promise.Process
( processPromise, processPromiseCallback
, ProcessResult(..), ExitCode(..)) where
import Control.Monad
import Control.Monad.Error
import Control.Monad.STM
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.Promise
import Control.Exception
import System.Process
import System.IO
import System.Exit
data ProcessResult = ProcessResult
{ stderr :: String
, stdout :: String
, excode :: ExitCode
}
deriving (Eq, Ord, Show)
processPromiseCallback
:: (ProcessResult -> IO ())
-> FilePath
-> [String]
-> String
-> IO (Promise ProcessResult)
processPromiseCallback callback cmd args input = do
pid_var <- newTVarIO Nothing
result_var <- newTVarIO Unfinished
spawn_ok <- newTVarIO True
let silent io = io `catchError` const (return ())
spawn = do
spawn_now <- atomically $ swapTVar spawn_ok False
when spawn_now $ do
(Just inh, Just outh, Just errh, pid) <- createProcess $
(proc cmd args)
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
atomically $ writeTVar pid_var (Just pid)
unless (null input) $ do
hPutStr inh input
hFlush inh
hClose inh
let go = do
ex_code <- waitForProcess pid
out <- hGetContents outh
err <- hGetContents errh
a <- evaluate (length out)
b <- evaluate (length err)
a `seq` b `seq` do
hClose outh
hClose errh
let res = ProcessResult
{ stderr = err
, stdout = out
, excode = ex_code
}
atomically $ writeTVar result_var (An res)
callback res
go `catchError` \ _ -> atomically (writeTVar result_var Cancelled)
cancel = do
m_pid <- atomically $ do
writeTVar result_var Cancelled
writeTVar spawn_ok False
swapTVar pid_var Nothing
case m_pid of
Just pid -> silent $ do
terminateProcess pid
ex_code <- waitForProcess pid
ex_code `seq` return ()
Nothing -> return ()
result = readTVar result_var
return Promise {..}
processPromise
:: FilePath
-> [String]
-> String
-> IO (Promise ProcessResult)
processPromise = processPromiseCallback (\ _ -> return ())