{-# 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 :: (Maybe Handle -> IO ClosedStream, Maybe StdStream)
isStdStream = (\(Just Handle
h) -> Handle -> IO ()
hClose Handle
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ClosedStream
ClosedStream, forall a. a -> Maybe a
Just StdStream
CreatePipe)
instance InputSource Inherited where
isStdStream :: (Maybe Handle -> IO Inherited, Maybe StdStream)
isStdStream = (\Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Inherited
Inherited, forall a. a -> Maybe a
Just StdStream
Inherit)
instance InputSource UseProvidedHandle where
isStdStream :: (Maybe Handle -> IO UseProvidedHandle, Maybe StdStream)
isStdStream = (\Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return UseProvidedHandle
UseProvidedHandle, forall a. Maybe a
Nothing)
instance OutputSink ClosedStream where
osStdStream :: (Maybe Handle -> IO ClosedStream, Maybe StdStream)
osStdStream = (\(Just Handle
h) -> Handle -> IO ()
hClose Handle
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ClosedStream
ClosedStream, forall a. a -> Maybe a
Just StdStream
CreatePipe)
instance OutputSink Inherited where
osStdStream :: (Maybe Handle -> IO Inherited, Maybe StdStream)
osStdStream = (\Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Inherited
Inherited, forall a. a -> Maybe a
Just StdStream
Inherit)
instance OutputSink UseProvidedHandle where
osStdStream :: (Maybe Handle -> IO UseProvidedHandle, Maybe StdStream)
osStdStream = (\Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return UseProvidedHandle
UseProvidedHandle, forall a. Maybe a
Nothing)
waitForStreamingProcess :: MonadIO m => StreamingProcessHandle -> m ExitCode
waitForStreamingProcess :: forall (m :: * -> *).
MonadIO m =>
StreamingProcessHandle -> m ExitCode
waitForStreamingProcess = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamingProcessHandle -> STM ExitCode
waitForStreamingProcessSTM
waitForStreamingProcessSTM :: StreamingProcessHandle -> STM ExitCode
waitForStreamingProcessSTM :: StreamingProcessHandle -> STM ExitCode
waitForStreamingProcessSTM = forall a. TMVar a -> STM a
readTMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamingProcessHandle -> TMVar ExitCode
streamingProcessHandleTMVar
getStreamingProcessExitCode :: MonadIO m => StreamingProcessHandle -> m (Maybe ExitCode)
getStreamingProcessExitCode :: forall (m :: * -> *).
MonadIO m =>
StreamingProcessHandle -> m (Maybe ExitCode)
getStreamingProcessExitCode = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamingProcessHandle -> STM (Maybe ExitCode)
getStreamingProcessExitCodeSTM
getStreamingProcessExitCodeSTM :: StreamingProcessHandle -> STM (Maybe ExitCode)
getStreamingProcessExitCodeSTM :: StreamingProcessHandle -> STM (Maybe ExitCode)
getStreamingProcessExitCodeSTM = forall a. TMVar a -> STM (Maybe a)
tryReadTMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamingProcessHandle -> TMVar ExitCode
streamingProcessHandleTMVar
streamingProcessHandleRaw :: StreamingProcessHandle -> ProcessHandle
streamingProcessHandleRaw :: StreamingProcessHandle -> ProcessHandle
streamingProcessHandleRaw (StreamingProcessHandle ProcessHandle
ph TMVar ExitCode
_ IO ()
_) = ProcessHandle
ph
streamingProcessHandleTMVar :: StreamingProcessHandle -> TMVar ExitCode
streamingProcessHandleTMVar :: StreamingProcessHandle -> TMVar ExitCode
streamingProcessHandleTMVar (StreamingProcessHandle ProcessHandle
_ TMVar ExitCode
var IO ()
_) = TMVar ExitCode
var
streamingProcess :: (MonadIO m, InputSource stdin, OutputSink stdout, OutputSink stderr)
=> CreateProcess
-> m (stdin, stdout, stderr, StreamingProcessHandle)
streamingProcess :: forall (m :: * -> *) stdin stdout stderr.
(MonadIO m, InputSource stdin, OutputSink stdout,
OutputSink stderr) =>
CreateProcess -> m (stdin, stdout, stderr, StreamingProcessHandle)
streamingProcess CreateProcess
cp = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let (Maybe Handle -> IO stdin
getStdin, Maybe StdStream
stdinStream) = forall a. InputSource a => (Maybe Handle -> IO a, Maybe StdStream)
isStdStream
(Maybe Handle -> IO stdout
getStdout, Maybe StdStream
stdoutStream) = forall a. OutputSink a => (Maybe Handle -> IO a, Maybe StdStream)
osStdStream
(Maybe Handle -> IO stderr
getStderr, Maybe StdStream
stderrStream) = forall a. OutputSink a => (Maybe Handle -> IO a, Maybe StdStream)
osStdStream
#if MIN_VERSION_process(1,2,0)
(Maybe Handle
stdinH, Maybe Handle
stdoutH, Maybe Handle
stderrH, ProcessHandle
ph) <- String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
PI.createProcess_ String
"streamingProcess" CreateProcess
cp
#else
(stdinH, stdoutH, stderrH, ph) <- createProcess cp
#endif
{ std_in :: StdStream
std_in = forall a. a -> Maybe a -> a
fromMaybe (CreateProcess -> StdStream
std_in CreateProcess
cp) Maybe StdStream
stdinStream
, std_out :: StdStream
std_out = forall a. a -> Maybe a -> a
fromMaybe (CreateProcess -> StdStream
std_out CreateProcess
cp) Maybe StdStream
stdoutStream
, std_err :: StdStream
std_err = forall a. a -> Maybe a -> a
fromMaybe (CreateProcess -> StdStream
std_err CreateProcess
cp) Maybe StdStream
stderrStream
}
TMVar ExitCode
ec <- forall a. STM a -> IO a
atomically forall a. STM (TMVar a)
newEmptyTMVar
ThreadId
_ <- ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_unmask -> forall e a. Exception e => IO a -> IO (Either e a)
try (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. STM a -> IO a
atomically
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> a -> STM ()
putTMVar TMVar ExitCode
ec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(forall a e. Exception e => e -> a
throw :: SomeException -> a)
forall a. a -> a
id
let close :: IO ()
close =
Maybe Handle -> IO ()
mclose Maybe Handle
stdinH forall a b. IO a -> IO b -> IO a
`finally` Maybe Handle -> IO ()
mclose Maybe Handle
stdoutH forall a b. IO a -> IO b -> IO a
`finally` Maybe Handle -> IO ()
mclose Maybe Handle
stderrH
where
mclose :: Maybe Handle -> IO ()
mclose = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Handle -> IO ()
hClose
(,,,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Maybe Handle -> IO stdin
getStdin Maybe Handle
stdinH
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
A.<*> Maybe Handle -> IO stdout
getStdout Maybe Handle
stdoutH
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Handle -> IO stderr
getStderr Maybe Handle
stderrH
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle -> TMVar ExitCode -> IO () -> StreamingProcessHandle
StreamingProcessHandle ProcessHandle
ph TMVar ExitCode
ec IO ()
close)
closeStreamingProcessHandle :: MonadIO m => StreamingProcessHandle -> m ()
closeStreamingProcessHandle :: forall (m :: * -> *). MonadIO m => StreamingProcessHandle -> m ()
closeStreamingProcessHandle (StreamingProcessHandle ProcessHandle
_ TMVar ExitCode
_ IO ()
f) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
f
data ProcessExitedUnsuccessfully = ProcessExitedUnsuccessfully CreateProcess ExitCode
deriving Typeable
instance Show ProcessExitedUnsuccessfully where
show :: ProcessExitedUnsuccessfully -> String
show (ProcessExitedUnsuccessfully CreateProcess
cp ExitCode
ec) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Process exited with "
, forall a. Show a => a -> String
show ExitCode
ec
, String
": "
, CmdSpec -> String
showCmdSpec (CreateProcess -> CmdSpec
cmdspec CreateProcess
cp)
]
where
showCmdSpec :: CmdSpec -> String
showCmdSpec (ShellCommand String
str) = String
str
showCmdSpec (RawCommand String
x [String]
xs) = [String] -> String
unwords (String
xforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map ShowS
showArg [String]
xs)
showArg :: ShowS
showArg String
x
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
' ') String
x = forall a. Show a => a -> String
show String
x
| Bool
otherwise = String
x
instance Exception ProcessExitedUnsuccessfully
withCheckedProcess :: ( InputSource stdin
, OutputSink stderr
, OutputSink stdout
, MonadIO m
)
=> CreateProcess
-> (stdin -> stdout -> stderr -> m b)
-> m b
withCheckedProcess :: forall stdin stderr stdout (m :: * -> *) b.
(InputSource stdin, OutputSink stderr, OutputSink stdout,
MonadIO m) =>
CreateProcess -> (stdin -> stdout -> stderr -> m b) -> m b
withCheckedProcess CreateProcess
cp stdin -> stdout -> stderr -> m b
f = do
(stdin
x, stdout
y, stderr
z, StreamingProcessHandle
sph) <- forall (m :: * -> *) stdin stdout stderr.
(MonadIO m, InputSource stdin, OutputSink stdout,
OutputSink stderr) =>
CreateProcess -> m (stdin, stdout, stderr, StreamingProcessHandle)
streamingProcess CreateProcess
cp
b
res <- stdin -> stdout -> stderr -> m b
f stdin
x stdout
y stderr
z
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
ExitCode
ec <- forall (m :: * -> *).
MonadIO m =>
StreamingProcessHandle -> m ExitCode
waitForStreamingProcess StreamingProcessHandle
sph forall a b. IO a -> IO b -> IO a
`finally` forall (m :: * -> *). MonadIO m => StreamingProcessHandle -> m ()
closeStreamingProcessHandle StreamingProcessHandle
sph
if ExitCode
ec forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then forall (m :: * -> *) a. Monad m => a -> m a
return b
res
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ CreateProcess -> ExitCode -> ProcessExitedUnsuccessfully
ProcessExitedUnsuccessfully CreateProcess
cp ExitCode
ec