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
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.Promise
import Control.Exception
import System.Process
import System.IO
import System.IO.Error
import System.Exit
import System.Process.Internals
import System.Posix.Signals
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
silent (hPutStr inh input)
silent (hFlush inh)
silent (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
silent (hClose outh)
silent (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
v <- readTVar result_var
when (v == Unfinished) (writeTVar result_var Cancelled)
writeTVar spawn_ok False
swapTVar pid_var Nothing
case m_pid of
Just pid -> void $ forkIO $ silent $ do
terminateProcess9 pid
ex_code <- waitForProcess pid
ex_code `seq` return ()
Nothing -> return ()
result = readTVar result_var
return Promise {..}
terminateProcess9 :: ProcessHandle -> IO ()
terminateProcess9 ph = do
#if __GLASGOW_HASKELL__ >= 708
let ProcessHandle pmvar _ = ph
#else
let ProcessHandle pmvar = ph
#endif
posixh <- readMVar pmvar
case posixh of
OpenHandle pid -> signalProcess 9 pid
_ -> return ()
processPromise
:: FilePath
-> [String]
-> String
-> IO (Promise ProcessResult)
processPromise = processPromiseCallback (\ _ -> return ())