{-# LANGUAGE DataKinds #-}
module Data.Conduit.Process.Typed
(
createSink
, createSinkClose
, createSource
, withLoggedProcess_
, module System.Process.Typed
) where
import System.Process.Typed
import qualified System.Process.Typed as P
import Data.Conduit (ConduitM, (.|), runConduit)
import qualified Data.Conduit.Binary as CB
import Control.Monad.IO.Unlift
import qualified Data.ByteString as S
import qualified Data.Conduit.List as CL
import qualified Data.ByteString.Lazy as BL
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
import Control.Exception (throwIO, catch)
import Control.Concurrent.Async (concurrently)
import System.IO (hSetBuffering, BufferMode (NoBuffering), hClose)
createSink :: MonadIO m => StreamSpec 'STInput (ConduitM S.ByteString o m ())
createSink :: forall (m :: * -> *) o.
MonadIO m =>
StreamSpec 'STInput (ConduitM ByteString o m ())
createSink =
(\Handle
h -> IO () -> ConduitM ByteString o m ()
forall a. IO a -> ConduitT ByteString o m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering) ConduitM ByteString o m ()
-> ConduitM ByteString o m () -> ConduitM ByteString o m ()
forall a b.
ConduitT ByteString o m a
-> ConduitT ByteString o m b -> ConduitT ByteString o m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> ConduitM ByteString o m ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
CB.sinkHandle Handle
h)
(Handle -> ConduitM ByteString o m ())
-> StreamSpec 'STInput Handle
-> StreamSpec 'STInput (ConduitM ByteString o m ())
forall a b.
(a -> b) -> StreamSpec 'STInput a -> StreamSpec 'STInput b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StreamSpec 'STInput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
createSinkClose :: MonadIO m => StreamSpec 'STInput (ConduitM S.ByteString o m ())
createSinkClose :: forall (m :: * -> *) o.
MonadIO m =>
StreamSpec 'STInput (ConduitM ByteString o m ())
createSinkClose =
(\Handle
h -> IO () -> ConduitM ByteString o m ()
forall a. IO a -> ConduitT ByteString o m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering) ConduitM ByteString o m ()
-> ConduitM ByteString o m () -> ConduitM ByteString o m ()
forall a b.
ConduitT ByteString o m a
-> ConduitT ByteString o m b -> ConduitT ByteString o m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> ConduitM ByteString o m ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
CB.sinkHandle Handle
h ConduitM ByteString o m ()
-> ConduitM ByteString o m () -> ConduitM ByteString o m ()
forall a b.
ConduitT ByteString o m a
-> ConduitT ByteString o m b -> ConduitT ByteString o m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> ConduitM ByteString o m ()
forall a. IO a -> ConduitT ByteString o m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ()
hClose Handle
h))
(Handle -> ConduitM ByteString o m ())
-> StreamSpec 'STInput Handle
-> StreamSpec 'STInput (ConduitM ByteString o m ())
forall a b.
(a -> b) -> StreamSpec 'STInput a -> StreamSpec 'STInput b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StreamSpec 'STInput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
createSource :: MonadIO m => StreamSpec 'STOutput (ConduitM i S.ByteString m ())
createSource :: forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource =
(\Handle
h -> IO () -> ConduitM i ByteString m ()
forall a. IO a -> ConduitT i ByteString m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering) ConduitM i ByteString m ()
-> ConduitM i ByteString m () -> ConduitM i ByteString m ()
forall a b.
ConduitT i ByteString m a
-> ConduitT i ByteString m b -> ConduitT i ByteString m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> ConduitM i ByteString m ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
CB.sourceHandle Handle
h)
(Handle -> ConduitM i ByteString m ())
-> StreamSpec 'STOutput Handle
-> StreamSpec 'STOutput (ConduitM i ByteString m ())
forall a b.
(a -> b) -> StreamSpec 'STOutput a -> StreamSpec 'STOutput b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
createSourceLogged
:: MonadIO m
=> IORef ([S.ByteString] -> [S.ByteString])
-> StreamSpec 'STOutput (ConduitM i S.ByteString m ())
createSourceLogged :: forall (m :: * -> *) i.
MonadIO m =>
IORef ([ByteString] -> [ByteString])
-> StreamSpec 'STOutput (ConduitM i ByteString m ())
createSourceLogged IORef ([ByteString] -> [ByteString])
ref =
(\Handle
h ->
( Handle -> ConduitM i ByteString m ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
CB.sourceHandle Handle
h
ConduitM i ByteString m ()
-> ConduitT ByteString ByteString m ()
-> ConduitM i ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (ByteString -> m ()) -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> ConduitT a a m ()
CL.iterM (\ByteString
bs -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef ([ByteString] -> [ByteString])
-> (([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ([ByteString] -> [ByteString])
ref (([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:))))
)
(Handle -> ConduitM i ByteString m ())
-> StreamSpec 'STOutput Handle
-> StreamSpec 'STOutput (ConduitM i ByteString m ())
forall a b.
(a -> b) -> StreamSpec 'STOutput a -> StreamSpec 'STOutput b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
withLoggedProcess_
:: MonadUnliftIO m
=> ProcessConfig stdin stdoutIgnored stderrIgnored
-> (Process stdin (ConduitM () S.ByteString m ()) (ConduitM () S.ByteString m ()) -> m a)
-> m a
withLoggedProcess_ :: forall (m :: * -> *) stdin stdoutIgnored stderrIgnored a.
MonadUnliftIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> (Process
stdin (ConduitM () ByteString m ()) (ConduitM () ByteString m ())
-> m a)
-> m a
withLoggedProcess_ ProcessConfig stdin stdoutIgnored stderrIgnored
pc Process
stdin (ConduitM () ByteString m ()) (ConduitM () ByteString m ())
-> m a
inner = (UnliftIO m -> IO a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO ((UnliftIO m -> IO a) -> m a) -> (UnliftIO m -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \UnliftIO m
u -> do
stdoutBuffer <- ([ByteString] -> [ByteString])
-> IO (IORef ([ByteString] -> [ByteString]))
forall a. a -> IO (IORef a)
newIORef [ByteString] -> [ByteString]
forall a. a -> a
id
stderrBuffer <- newIORef id
let pc' = StreamSpec 'STOutput (ConduitM i ByteString m ())
-> ProcessConfig stdin stdoutIgnored (ConduitM i ByteString m ())
-> ProcessConfig
stdin (ConduitM i ByteString m ()) (ConduitM i ByteString m ())
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout (IORef ([ByteString] -> [ByteString])
-> StreamSpec 'STOutput (ConduitM i ByteString m ())
forall (m :: * -> *) i.
MonadIO m =>
IORef ([ByteString] -> [ByteString])
-> StreamSpec 'STOutput (ConduitM i ByteString m ())
createSourceLogged IORef ([ByteString] -> [ByteString])
stdoutBuffer)
(ProcessConfig stdin stdoutIgnored (ConduitM i ByteString m ())
-> ProcessConfig
stdin (ConduitM i ByteString m ()) (ConduitM i ByteString m ()))
-> ProcessConfig stdin stdoutIgnored (ConduitM i ByteString m ())
-> ProcessConfig
stdin (ConduitM i ByteString m ()) (ConduitM i ByteString m ())
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput (ConduitM i ByteString m ())
-> ProcessConfig stdin stdoutIgnored stderrIgnored
-> ProcessConfig stdin stdoutIgnored (ConduitM i ByteString m ())
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr (IORef ([ByteString] -> [ByteString])
-> StreamSpec 'STOutput (ConduitM i ByteString m ())
forall (m :: * -> *) i.
MonadIO m =>
IORef ([ByteString] -> [ByteString])
-> StreamSpec 'STOutput (ConduitM i ByteString m ())
createSourceLogged IORef ([ByteString] -> [ByteString])
stderrBuffer) ProcessConfig stdin stdoutIgnored stderrIgnored
pc
P.withProcessWait pc' $ \Process
stdin (ConduitM () ByteString m ()) (ConduitM () ByteString m ())
p -> do
a <- UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ Process
stdin (ConduitM () ByteString m ()) (ConduitM () ByteString m ())
-> m a
inner Process
stdin (ConduitM () ByteString m ()) (ConduitM () ByteString m ())
p
let drain ConduitT () b m ()
src = UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () b m ()
src ConduitT () b m () -> ConduitT b Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT b Void m ()
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull))
((), ()) <- drain (getStdout p) `concurrently`
drain (getStderr p)
checkExitCode p `catch` \ExitCodeException
ece -> do
stdout <- IORef ([ByteString] -> [ByteString])
-> IO ([ByteString] -> [ByteString])
forall a. IORef a -> IO a
readIORef IORef ([ByteString] -> [ByteString])
stdoutBuffer
stderr <- readIORef stderrBuffer
throwIO ece
{ eceStdout = BL.fromChunks $ stdout []
, eceStderr = BL.fromChunks $ stderr []
}
return a