1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
{-# LANGUAGE DataKinds #-}
-- | The "System.Process.Typed" module from @typed-process@, but with
-- added conduit helpers.
module Data.Conduit.Process.Typed
( -- * Conduit specific stuff
createSink
, createSinkClose
, createSource
-- * Running a process with logging
, withLoggedProcess_
-- * Reexports
, 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)
-- | Provide input to a process by writing to a conduit. The sink provided here
-- will leave the pipe to the child open after the stream ends. This allows the
-- sink to be used multiple times, but may result in surprising behavior. You
-- may prefer 'createSinkClose', see
-- <https://github.com/snoyberg/conduit/issues/434>.
--
-- @since 1.2.1
createSink :: MonadIO m => StreamSpec 'STInput (ConduitM S.ByteString o m ())
createSink =
(\h -> liftIO (hSetBuffering h NoBuffering) >> CB.sinkHandle h)
`fmap` createPipe
-- | Like 'createSink', but closes the pipe to the child process as soon as it
-- runs out of data.
--
-- @since 1.3.5
createSinkClose :: MonadIO m => StreamSpec 'STInput (ConduitM S.ByteString o m ())
createSinkClose =
(\h -> liftIO (hSetBuffering h NoBuffering) >> CB.sinkHandle h >> liftIO (hClose h))
`fmap` createPipe
-- | Read output from a process by read from a conduit.
--
-- @since 1.2.1
createSource :: MonadIO m => StreamSpec 'STOutput (ConduitM i S.ByteString m ())
createSource =
(\h -> liftIO (hSetBuffering h NoBuffering) >> CB.sourceHandle h)
`fmap` createPipe
-- | Internal function: like 'createSource', but stick all chunks into
-- the 'IORef'.
createSourceLogged
:: MonadIO m
=> IORef ([S.ByteString] -> [S.ByteString])
-> StreamSpec 'STOutput (ConduitM i S.ByteString m ())
createSourceLogged ref =
-- We do not add a cleanup action to close the handle, since in
-- withLoggedProcess_ we attempt to read from the handle twice
(\h ->
( CB.sourceHandle h
.| CL.iterM (\bs -> liftIO $ modifyIORef ref (. (bs:))))
)
`fmap` createPipe
-- | Run a process, throwing an exception on a failure exit code. This
-- will store all output from stdout and stderr in memory for better
-- error messages. Note that this will require unbounded memory usage,
-- so caveat emptor.
--
-- This will ignore any previous settings for the stdout and stderr
-- streams, and instead force them to use 'createSource'.
--
-- @since 1.2.3
withLoggedProcess_
:: MonadUnliftIO m
=> ProcessConfig stdin stdoutIgnored stderrIgnored
-> (Process stdin (ConduitM () S.ByteString m ()) (ConduitM () S.ByteString m ()) -> m a)
-> m a
withLoggedProcess_ pc inner = withUnliftIO $ \u -> do
stdoutBuffer <- newIORef id
stderrBuffer <- newIORef id
let pc' = setStdout (createSourceLogged stdoutBuffer)
$ setStderr (createSourceLogged stderrBuffer) pc
-- withProcessWait vs Term doesn't actually matter here, since we
-- call checkExitCode inside regardless. But still, Wait is the
-- safer function to use in general.
P.withProcessWait pc' $ \p -> do
a <- unliftIO u $ inner p
let drain src = unliftIO u (runConduit (src .| CL.sinkNull))
((), ()) <- drain (getStdout p) `concurrently`
drain (getStderr p)
checkExitCode p `catch` \ece -> do
stdout <- readIORef stdoutBuffer
stderr <- readIORef stderrBuffer
throwIO ece
{ eceStdout = BL.fromChunks $ stdout []
, eceStderr = BL.fromChunks $ stderr []
}
return a
|
