{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Data.Streaming.Process
(
streamingProcess
, closeStreamingProcessHandle
, Inherited (..)
, ClosedStream (..)
, UseProvidedHandle (..)
, StreamingProcessHandle
, waitForStreamingProcess
, waitForStreamingProcessSTM
, getStreamingProcessExitCode
, getStreamingProcessExitCodeSTM
, streamingProcessHandleRaw
, streamingProcessHandleTMVar
, InputSource
, OutputSink
, withCheckedProcess
, ProcessExitedUnsuccessfully (..)
, module System.Process
) where
import Control.Applicative as A ((<$>), (<*>))
import Control.Concurrent (forkIOWithUnmask)
import Control.Concurrent.STM (STM, TMVar, atomically,
newEmptyTMVar, putTMVar,
readTMVar)
import Control.Exception (Exception, throwIO, try, throw,
SomeException, finally)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Maybe (fromMaybe)
import Data.Streaming.Process.Internal
import Data.Typeable (Typeable)
import System.Exit (ExitCode (ExitSuccess))
import System.IO (hClose)
import System.Process
#if MIN_VERSION_process(1,2,0)
import qualified System.Process.Internals as PI
#endif
#if MIN_VERSION_stm(2,3,0)
import Control.Concurrent.STM (tryReadTMVar)
#else
import Control.Concurrent.STM (tryTakeTMVar, putTMVar)
tryReadTMVar :: TMVar a -> STM (Maybe a)
tryReadTMVar var = do
mx <- tryTakeTMVar var
case mx of
Nothing -> return ()
Just x -> putTMVar var x
return mx
#endif
data UseProvidedHandle = UseProvidedHandle
data Inherited = Inherited
data ClosedStream = ClosedStream
instance InputSource ClosedStream where
isStdStream = (\(Just h) -> hClose h >> return ClosedStream, Just CreatePipe)
instance InputSource Inherited where
isStdStream = (\Nothing -> return Inherited, Just Inherit)
instance InputSource UseProvidedHandle where
isStdStream = (\Nothing -> return UseProvidedHandle, Nothing)
instance OutputSink ClosedStream where
osStdStream = (\(Just h) -> hClose h >> return ClosedStream, Just CreatePipe)
instance OutputSink Inherited where
osStdStream = (\Nothing -> return Inherited, Just Inherit)
instance OutputSink UseProvidedHandle where
osStdStream = (\Nothing -> return UseProvidedHandle, Nothing)
waitForStreamingProcess :: MonadIO m => StreamingProcessHandle -> m ExitCode
waitForStreamingProcess = liftIO . atomically . waitForStreamingProcessSTM
waitForStreamingProcessSTM :: StreamingProcessHandle -> STM ExitCode
waitForStreamingProcessSTM = readTMVar . streamingProcessHandleTMVar
getStreamingProcessExitCode :: MonadIO m => StreamingProcessHandle -> m (Maybe ExitCode)
getStreamingProcessExitCode = liftIO . atomically . getStreamingProcessExitCodeSTM
getStreamingProcessExitCodeSTM :: StreamingProcessHandle -> STM (Maybe ExitCode)
getStreamingProcessExitCodeSTM = tryReadTMVar . streamingProcessHandleTMVar
streamingProcessHandleRaw :: StreamingProcessHandle -> ProcessHandle
streamingProcessHandleRaw (StreamingProcessHandle ph _ _) = ph
streamingProcessHandleTMVar :: StreamingProcessHandle -> TMVar ExitCode
streamingProcessHandleTMVar (StreamingProcessHandle _ var _) = var
streamingProcess :: (MonadIO m, InputSource stdin, OutputSink stdout, OutputSink stderr)
=> CreateProcess
-> m (stdin, stdout, stderr, StreamingProcessHandle)
streamingProcess cp = liftIO $ do
let (getStdin, stdinStream) = isStdStream
(getStdout, stdoutStream) = osStdStream
(getStderr, stderrStream) = osStdStream
#if MIN_VERSION_process(1,2,0)
(stdinH, stdoutH, stderrH, ph) <- PI.createProcess_ "streamingProcess" cp
#else
(stdinH, stdoutH, stderrH, ph) <- createProcess cp
#endif
{ std_in = fromMaybe (std_in cp) stdinStream
, std_out = fromMaybe (std_out cp) stdoutStream
, std_err = fromMaybe (std_err cp) stderrStream
}
ec <- atomically newEmptyTMVar
_ <- forkIOWithUnmask $ \_unmask -> try (waitForProcess ph)
>>= atomically
. putTMVar ec
. either
(throw :: SomeException -> a)
id
let close =
mclose stdinH `finally` mclose stdoutH `finally` mclose stderrH
where
mclose = maybe (return ()) hClose
(,,,)
A.<$> getStdin stdinH
A.<*> getStdout stdoutH
<*> getStderr stderrH
<*> return (StreamingProcessHandle ph ec close)
closeStreamingProcessHandle :: MonadIO m => StreamingProcessHandle -> m ()
closeStreamingProcessHandle (StreamingProcessHandle _ _ f) = liftIO f
data ProcessExitedUnsuccessfully = ProcessExitedUnsuccessfully CreateProcess ExitCode
deriving Typeable
instance Show ProcessExitedUnsuccessfully where
show (ProcessExitedUnsuccessfully cp ec) = concat
[ "Process exited with "
, show ec
, ": "
, showCmdSpec (cmdspec cp)
]
where
showCmdSpec (ShellCommand str) = str
showCmdSpec (RawCommand x xs) = unwords (x:map showArg xs)
showArg x
| any (\c -> c == '"' || c == ' ') x = show x
| otherwise = x
instance Exception ProcessExitedUnsuccessfully
withCheckedProcess :: ( InputSource stdin
, OutputSink stderr
, OutputSink stdout
, MonadIO m
)
=> CreateProcess
-> (stdin -> stdout -> stderr -> m b)
-> m b
withCheckedProcess cp f = do
(x, y, z, sph) <- streamingProcess cp
res <- f x y z
liftIO $ do
ec <- waitForStreamingProcess sph `finally` closeStreamingProcessHandle sph
if ec == ExitSuccess
then return res
else throwIO $ ProcessExitedUnsuccessfully cp ec