{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Data.Conduit.Shell.Process
(
run
,text
,bytes
,conduit
,conduitEither
,Data.Conduit.Shell.Process.shell
,Data.Conduit.Shell.Process.proc
,($|)
,Segment
,ProcessException(..)
,ToChunk(..)
,tryS
)
where
import Control.Applicative
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.Conduit
import Data.Conduit.Binary
import qualified Data.Conduit.List as CL
import Conduit (MonadThrow)
import Data.Conduit.Text (encodeUtf8, decodeUtf8)
import Data.Text (Text)
import Data.Typeable
import System.Exit
import System.IO
import System.Posix.IO (createPipe, fdToHandle)
import System.Process hiding (createPipe)
import UnliftIO (MonadUnliftIO, unliftIO, askUnliftIO)
data Segment m r
= SegmentConduit (ConduitM ByteString (Either ByteString ByteString) m r)
| SegmentProcess (Handles -> m r)
instance MonadIO m => Monad (Segment m) where
return :: forall a. a -> Segment m a
return = ConduitM ByteString (Either ByteString ByteString) m a
-> Segment m a
forall (m :: * -> *) r.
ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
SegmentConduit (ConduitM ByteString (Either ByteString ByteString) m a
-> Segment m a)
-> (a -> ConduitM ByteString (Either ByteString ByteString) m a)
-> a
-> Segment m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ConduitM ByteString (Either ByteString ByteString) m a
forall (m :: * -> *) a. Monad m => a -> m a
return
SegmentConduit ConduitM ByteString (Either ByteString ByteString) m a
c >>= :: forall a b. Segment m a -> (a -> Segment m b) -> Segment m b
>>= a -> Segment m b
f =
(Handles -> m a) -> Segment m a
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess (ConduitM ByteString (Either ByteString ByteString) m a
-> Handles -> m a
forall (m :: * -> *) r.
MonadIO m =>
ConduitT ByteString (Either ByteString ByteString) m r
-> Handles -> m r
conduitToProcess ConduitM ByteString (Either ByteString ByteString) m a
c) Segment m a -> (a -> Segment m b) -> Segment m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
a -> Segment m b
f
SegmentProcess Handles -> m a
f >>= a -> Segment m b
g =
(Handles -> m b) -> Segment m b
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess
(\Handles
handles ->
do a
x <- Handles -> m a
f Handles
handles
case a -> Segment m b
g a
x of
SegmentConduit ConduitM ByteString (Either ByteString ByteString) m b
c ->
ConduitM ByteString (Either ByteString ByteString) m b
-> Handles -> m b
forall (m :: * -> *) r.
MonadIO m =>
ConduitT ByteString (Either ByteString ByteString) m r
-> Handles -> m r
conduitToProcess ConduitM ByteString (Either ByteString ByteString) m b
c Handles
handles
SegmentProcess Handles -> m b
p -> Handles -> m b
p Handles
handles)
instance MonadIO m => Functor (Segment m) where
fmap :: forall a b. (a -> b) -> Segment m a -> Segment m b
fmap = (a -> b) -> Segment m a -> Segment m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance MonadIO m => Applicative (Segment m) where
<*> :: forall a b. Segment m (a -> b) -> Segment m a -> Segment m b
(<*>) = Segment m (a -> b) -> Segment m a -> Segment m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap; pure :: forall a. a -> Segment m a
pure = a -> Segment m a
forall (m :: * -> *) a. Monad m => a -> m a
return
instance MonadUnliftIO m => Alternative (Segment m) where
Segment m a
this <|> :: forall a. Segment m a -> Segment m a -> Segment m a
<|> Segment m a
that =
do Either ProcessException a
ex <- Segment m a -> Segment m (Either ProcessException a)
forall e (m :: * -> *) r.
(Exception e, MonadUnliftIO m) =>
Segment m r -> Segment m (Either e r)
tryS Segment m a
this
case Either ProcessException a
ex of
Right a
x -> a -> Segment m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Left (ProcessException
_ :: ProcessException) -> Segment m a
that
empty :: forall a. Segment m a
empty = ProcessException -> Segment m a
forall a e. Exception e => e -> a
throw ProcessException
ProcessEmpty
tryS :: (Exception e, MonadUnliftIO m) => Segment m r -> Segment m (Either e r)
tryS :: forall e (m :: * -> *) r.
(Exception e, MonadUnliftIO m) =>
Segment m r -> Segment m (Either e r)
tryS Segment m r
s =
case Segment m r
s of
SegmentConduit ConduitM ByteString (Either ByteString ByteString) m r
c -> ConduitM ByteString (Either ByteString ByteString) m (Either e r)
-> Segment m (Either e r)
forall (m :: * -> *) r.
ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
SegmentConduit (ConduitM ByteString (Either ByteString ByteString) m r
-> ConduitM
ByteString (Either ByteString ByteString) m (Either e r)
forall (m :: * -> *) e i o r.
(MonadUnliftIO m, Exception e) =>
ConduitT i o m r -> ConduitT i o m (Either e r)
tryC ConduitM ByteString (Either ByteString ByteString) m r
c)
SegmentProcess Handles -> m r
f -> (Handles -> m (Either e r)) -> Segment m (Either e r)
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess ((Handles -> m (Either e r)) -> Segment m (Either e r))
-> (Handles -> m (Either e r)) -> Segment m (Either e r)
forall a b. (a -> b) -> a -> b
$ (\Handles
h -> do
UnliftIO m
u <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
IO (Either e r) -> m (Either e r)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either e r) -> m (Either e r))
-> IO (Either e r) -> m (Either e r)
forall a b. (a -> b) -> a -> b
$ IO r -> IO (Either e r)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO r -> IO (Either e r)) -> IO r -> IO (Either e r)
forall a b. (a -> b) -> a -> b
$ UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (Handles -> m r
f Handles
h))
instance MonadIO m => MonadIO (Segment m) where
liftIO :: forall a. IO a -> Segment m a
liftIO IO a
x = (Handles -> m a) -> Segment m a
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess (m a -> Handles -> m a
forall a b. a -> b -> a
const (m a -> Handles -> m a) -> m a -> Handles -> m a
forall a b. (a -> b) -> a -> b
$ IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
x)
data Handles =
Handles Handle
Handle
Handle
data ProcessException
= ProcessException CreateProcess
ExitCode
| ProcessEmpty
deriving (Typeable)
instance Exception ProcessException
instance Show ProcessException where
show :: ProcessException -> String
show ProcessException
ProcessEmpty = String
"empty process"
show (ProcessException CreateProcess
cp ExitCode
ec) =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"The "
, case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
ShellCommand String
s -> String
"shell command " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
RawCommand String
f [String]
args -> String
"raw command: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (String
f String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
forall a. Show a => a -> String
show [String]
args)
, String
" returned a failure exit code: "
, case ExitCode
ec of
ExitFailure Int
i -> Int -> String
forall a. Show a => a -> String
show Int
i
ExitCode
_ -> ExitCode -> String
forall a. Show a => a -> String
show ExitCode
ec
]
class ToSegment m a where
type SegmentResult m a
toSegment :: a -> Segment m (SegmentResult m a)
instance ToSegment m (Segment m r) where
type SegmentResult m (Segment m r) = r
toSegment :: Segment m r -> Segment m (SegmentResult m (Segment m r))
toSegment = Segment m r -> Segment m (SegmentResult m (Segment m r))
forall a. a -> a
id
instance (a ~ ByteString, ToChunk b, Monad m) =>
ToSegment m (ConduitT a b m r) where
type SegmentResult m (ConduitT a b m r) = r
toSegment :: ConduitT a b m r -> Segment m (SegmentResult m (ConduitT a b m r))
toSegment ConduitT a b m r
f = ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
forall (m :: * -> *) r.
ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
SegmentConduit (ConduitT a b m r
f ConduitT a b m r
-> ConduitT b (Either ByteString ByteString) m ()
-> ConduitT a (Either ByteString ByteString) m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r
`fuseUpstream` (b -> Either ByteString ByteString)
-> ConduitT b (Either ByteString ByteString) m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map b -> Either ByteString ByteString
forall a. ToChunk a => a -> Either ByteString ByteString
toChunk)
instance MonadIO m => ToSegment m CreateProcess where
type SegmentResult m CreateProcess = ()
toSegment :: CreateProcess -> Segment m (SegmentResult m CreateProcess)
toSegment = CreateProcess -> Segment m (SegmentResult m CreateProcess)
forall (m :: * -> *). MonadIO m => CreateProcess -> Segment m ()
liftProcess
class ToChunk a where
toChunk :: a -> Either ByteString ByteString
instance ToChunk ByteString where
toChunk :: ByteString -> Either ByteString ByteString
toChunk = ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left
instance ToChunk (Either ByteString ByteString) where
toChunk :: Either ByteString ByteString -> Either ByteString ByteString
toChunk = Either ByteString ByteString -> Either ByteString ByteString
forall a. a -> a
id
shell :: MonadIO m => String -> Segment m ()
shell :: forall (m :: * -> *). MonadIO m => String -> Segment m ()
shell = CreateProcess -> Segment m ()
forall (m :: * -> *). MonadIO m => CreateProcess -> Segment m ()
liftProcess (CreateProcess -> Segment m ())
-> (String -> CreateProcess) -> String -> Segment m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CreateProcess
System.Process.shell
proc :: MonadIO m => String -> [String] -> Segment m ()
proc :: forall (m :: * -> *).
MonadIO m =>
String -> [String] -> Segment m ()
proc String
name [String]
args = CreateProcess -> Segment m ()
forall (m :: * -> *). MonadIO m => CreateProcess -> Segment m ()
liftProcess (String -> [String] -> CreateProcess
System.Process.proc String
name [String]
args)
run :: MonadIO m => Segment m r -> m r
run :: forall (m :: * -> *) r. MonadIO m => Segment m r -> m r
run (SegmentConduit ConduitM ByteString (Either ByteString ByteString) m r
c) = Segment m r -> m r
forall (m :: * -> *) r. MonadIO m => Segment m r -> m r
run ((Handles -> m r) -> Segment m r
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess (ConduitM ByteString (Either ByteString ByteString) m r
-> Handles -> m r
forall (m :: * -> *) r.
MonadIO m =>
ConduitT ByteString (Either ByteString ByteString) m r
-> Handles -> m r
conduitToProcess ConduitM ByteString (Either ByteString ByteString) m r
c))
run (SegmentProcess Handles -> m r
p) = Handles -> m r
p (Handle -> Handle -> Handle -> Handles
Handles Handle
stdin Handle
stdout Handle
stderr)
($|) :: MonadUnliftIO m => Segment m () -> Segment m b -> Segment m b
Segment m ()
x $| :: forall (m :: * -> *) b.
MonadUnliftIO m =>
Segment m () -> Segment m b -> Segment m b
$| Segment m b
y = Segment m ()
x Segment m () -> Segment m b -> Segment m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
Segment m () -> Segment m b -> Segment m b
`fuseSegment` Segment m b
y
infixl 0 $|
text
:: (r ~ (), MonadThrow m)
=> ConduitT Text Text m r -> Segment m r
text :: forall r (m :: * -> *).
(r ~ (), MonadThrow m) =>
ConduitT Text Text m r -> Segment m r
text ConduitT Text Text m r
conduit' = ConduitT ByteString ByteString m () -> Segment m ()
forall a (m :: * -> *) r.
(a ~ ByteString, Monad m) =>
ConduitT a ByteString m r -> Segment m r
bytes (ConduitT ByteString Text m ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8 ConduitT ByteString Text m ()
-> ConduitT Text ByteString m ()
-> ConduitT ByteString ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Text m r
ConduitT Text Text m ()
conduit' ConduitT Text Text m ()
-> ConduitT Text ByteString m () -> ConduitT Text ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text ByteString m ()
forall (m :: * -> *) text binary.
(Monad m, Utf8 text binary) =>
ConduitT text binary m ()
encodeUtf8)
bytes
:: (a ~ ByteString, Monad m)
=> ConduitT a ByteString m r -> Segment m r
bytes :: forall a (m :: * -> *) r.
(a ~ ByteString, Monad m) =>
ConduitT a ByteString m r -> Segment m r
bytes ConduitT a ByteString m r
f = ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
forall (m :: * -> *) r.
ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
SegmentConduit (ConduitT a ByteString m r
f ConduitT a ByteString m r
-> ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitT a (Either ByteString ByteString) m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r
`fuseUpstream` (ByteString -> Either ByteString ByteString)
-> ConduitT ByteString (Either ByteString ByteString) m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map ByteString -> Either ByteString ByteString
forall a. ToChunk a => a -> Either ByteString ByteString
toChunk)
conduit
:: (a ~ ByteString, Monad m)
=> ConduitT a ByteString m r -> Segment m r
conduit :: forall a (m :: * -> *) r.
(a ~ ByteString, Monad m) =>
ConduitT a ByteString m r -> Segment m r
conduit ConduitT a ByteString m r
f = ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
forall (m :: * -> *) r.
ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
SegmentConduit (ConduitT a ByteString m r
f ConduitT a ByteString m r
-> ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitT a (Either ByteString ByteString) m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r
`fuseUpstream` (ByteString -> Either ByteString ByteString)
-> ConduitT ByteString (Either ByteString ByteString) m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map ByteString -> Either ByteString ByteString
forall a. ToChunk a => a -> Either ByteString ByteString
toChunk)
conduitEither
:: (a ~ ByteString, Monad m)
=> ConduitT a (Either ByteString ByteString) m r -> Segment m r
conduitEither :: forall a (m :: * -> *) r.
(a ~ ByteString, Monad m) =>
ConduitT a (Either ByteString ByteString) m r -> Segment m r
conduitEither ConduitT a (Either ByteString ByteString) m r
f = ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
forall (m :: * -> *) r.
ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
SegmentConduit (ConduitT a (Either ByteString ByteString) m r
f ConduitT a (Either ByteString ByteString) m r
-> ConduitT
(Either ByteString ByteString) (Either ByteString ByteString) m ()
-> ConduitT a (Either ByteString ByteString) m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r
`fuseUpstream` (Either ByteString ByteString -> Either ByteString ByteString)
-> ConduitT
(Either ByteString ByteString) (Either ByteString ByteString) m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Either ByteString ByteString -> Either ByteString ByteString
forall a. ToChunk a => a -> Either ByteString ByteString
toChunk)
liftProcess :: MonadIO m => CreateProcess -> Segment m ()
liftProcess :: forall (m :: * -> *). MonadIO m => CreateProcess -> Segment m ()
liftProcess CreateProcess
cp =
(Handles -> m ()) -> Segment m ()
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess
(\(Handles Handle
inh Handle
outh Handle
errh) ->
let config :: CreateProcess
config =
CreateProcess
cp
{ std_in :: StdStream
std_in = Handle -> StdStream
UseHandle Handle
inh
, std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
outh
, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
errh
, close_fds :: Bool
close_fds = Bool
True
}
in
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
(Maybe Handle
Nothing, Maybe Handle
Nothing, Maybe Handle
Nothing, ProcessHandle
ph) <- String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ String
"liftProcess" CreateProcess
config
ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
case ExitCode
ec of
ExitCode
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitCode
_ -> ProcessException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (CreateProcess -> ExitCode -> ProcessException
ProcessException CreateProcess
cp ExitCode
ec))
conduitToProcess :: MonadIO m => ConduitT ByteString (Either ByteString ByteString) m r
-> (Handles -> m r)
conduitToProcess :: forall (m :: * -> *) r.
MonadIO m =>
ConduitT ByteString (Either ByteString ByteString) m r
-> Handles -> m r
conduitToProcess ConduitT ByteString (Either ByteString ByteString) m r
c (Handles Handle
inh Handle
outh Handle
errh) =
ConduitT () Void m r -> m r
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m r -> m r) -> ConduitT () Void m r -> m r
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString m ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
inh ConduitT () ByteString m ()
-> ConduitT ByteString Void m r -> ConduitT () Void m r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString (Either ByteString ByteString) m r
c ConduitT ByteString (Either ByteString ByteString) m r
-> ConduitT (Either ByteString ByteString) Void m ()
-> ConduitT ByteString Void m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r
`fuseUpstream` Handle
-> Handle -> ConduitT (Either ByteString ByteString) Void m ()
forall (m :: * -> *).
MonadIO m =>
Handle
-> Handle -> ConduitT (Either ByteString ByteString) Void m ()
sinkHandles Handle
outh Handle
errh
sinkHandles ::
MonadIO m
=> Handle
-> Handle
-> ConduitT (Either ByteString ByteString) Void m ()
sinkHandles :: forall (m :: * -> *).
MonadIO m =>
Handle
-> Handle -> ConduitT (Either ByteString ByteString) Void m ()
sinkHandles Handle
out Handle
err =
(Either ByteString ByteString -> m ())
-> ConduitT (Either ByteString ByteString) Void m ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_
(\Either ByteString ByteString
ebs ->
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ case Either ByteString ByteString
ebs of
Left ByteString
bs -> Handle -> ByteString -> IO ()
S.hPut Handle
out ByteString
bs
Right ByteString
bs -> Handle -> ByteString -> IO ()
S.hPut Handle
err ByteString
bs)
createHandles :: IO (Handle, Handle)
createHandles :: IO (Handle, Handle)
createHandles =
IO (Handle, Handle) -> IO (Handle, Handle)
forall a. IO a -> IO a
mask_
(do (Fd
inFD, Fd
outFD) <- IO (Fd, Fd)
createPipe
Handle
x <- Fd -> IO Handle
fdToHandle Fd
inFD
Handle
y <- Fd -> IO Handle
fdToHandle Fd
outFD
Handle -> BufferMode -> IO ()
hSetBuffering Handle
x BufferMode
NoBuffering
Handle -> BufferMode -> IO ()
hSetBuffering Handle
y BufferMode
NoBuffering
(Handle, Handle) -> IO (Handle, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
x, Handle
y))
fuseProcess :: MonadUnliftIO m => (Handles -> m ()) -> (Handles -> m r) -> (Handles -> m r)
fuseProcess :: forall (m :: * -> *) r.
MonadUnliftIO m =>
(Handles -> m ()) -> (Handles -> m r) -> Handles -> m r
fuseProcess Handles -> m ()
left Handles -> m r
right (Handles Handle
in1 Handle
out2 Handle
err) = do
UnliftIO m
u <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
(Handle
in2, Handle
out1) <- IO (Handle, Handle) -> m (Handle, Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createHandles
IO r -> m r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ Concurrently r -> IO r
forall a. Concurrently a -> IO a
runConcurrently
(IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently ((UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handles -> m ()
left (Handle -> Handle -> Handle -> Handles
Handles Handle
in1 Handle
out1 Handle
err)) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
out1) Concurrently () -> Concurrently r -> Concurrently r
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
IO r -> Concurrently r
forall a. IO a -> Concurrently a
Concurrently ((UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m r -> IO r) -> m r -> IO r
forall a b. (a -> b) -> a -> b
$ Handles -> m r
right (Handle -> Handle -> Handle -> Handles
Handles Handle
in2 Handle
out2 Handle
err)) IO r -> IO () -> IO r
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
in2))
fuseConduit
:: Monad m
=> ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitT ByteString (Either ByteString ByteString) m r
-> ConduitT ByteString (Either ByteString ByteString) m r
fuseConduit :: forall (m :: * -> *) r.
Monad m =>
ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitT ByteString (Either ByteString ByteString) m r
-> ConduitT ByteString (Either ByteString ByteString) m r
fuseConduit ConduitT ByteString (Either ByteString ByteString) m ()
left ConduitT ByteString (Either ByteString ByteString) m r
right = ConduitT ByteString (Either ByteString ByteString) m ()
left ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitT
(Either ByteString ByteString) (Either ByteString ByteString) m r
-> ConduitT ByteString (Either ByteString ByteString) m r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ZipConduit
(Either ByteString ByteString) (Either ByteString ByteString) m r
-> ConduitT
(Either ByteString ByteString) (Either ByteString ByteString) m r
forall i o (m :: * -> *) r. ZipConduit i o m r -> ConduitT i o m r
getZipConduit ZipConduit
(Either ByteString ByteString) (Either ByteString ByteString) m r
right'
where
right' :: ZipConduit
(Either ByteString ByteString) (Either ByteString ByteString) m r
right' =
ConduitT
(Either ByteString ByteString) (Either ByteString ByteString) m ()
-> ZipConduit
(Either ByteString ByteString) (Either ByteString ByteString) m ()
forall i o (m :: * -> *) r. ConduitT i o m r -> ZipConduit i o m r
ZipConduit ((Either ByteString ByteString -> Bool)
-> ConduitT
(Either ByteString ByteString) (Either ByteString ByteString) m ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter Either ByteString ByteString -> Bool
forall {a} {b}. Either a b -> Bool
isRight) ZipConduit
(Either ByteString ByteString) (Either ByteString ByteString) m ()
-> ZipConduit
(Either ByteString ByteString) (Either ByteString ByteString) m r
-> ZipConduit
(Either ByteString ByteString) (Either ByteString ByteString) m r
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
ConduitT
(Either ByteString ByteString) (Either ByteString ByteString) m r
-> ZipConduit
(Either ByteString ByteString) (Either ByteString ByteString) m r
forall i o (m :: * -> *) r. ConduitT i o m r -> ZipConduit i o m r
ZipConduit ((Either ByteString ByteString -> Maybe ByteString)
-> ConduitT (Either ByteString ByteString) ByteString m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> Maybe b) -> ConduitT a b m ()
CL.mapMaybe ((ByteString -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either ByteString ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> ByteString -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) ConduitT (Either ByteString ByteString) ByteString m ()
-> ConduitT ByteString (Either ByteString ByteString) m r
-> ConduitT
(Either ByteString ByteString) (Either ByteString ByteString) m r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString (Either ByteString ByteString) m r
right)
isRight :: Either a b -> Bool
isRight Right {} = Bool
True
isRight Left {} = Bool
False
fuseConduitProcess
:: MonadUnliftIO m
=> ConduitT ByteString (Either ByteString ByteString) m ()
-> (Handles -> m r)
-> (Handles -> m r)
fuseConduitProcess :: forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT ByteString (Either ByteString ByteString) m ()
-> (Handles -> m r) -> Handles -> m r
fuseConduitProcess ConduitT ByteString (Either ByteString ByteString) m ()
left Handles -> m r
right (Handles Handle
in1 Handle
out2 Handle
err) = do
UnliftIO m
u <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
(Handle
in2, Handle
out1) <- IO (Handle, Handle) -> m (Handle, Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createHandles
IO r -> m r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ Concurrently r -> IO r
forall a. Concurrently a -> IO a
runConcurrently
(IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently
((UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString m ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
in1 ConduitT () ByteString m ()
-> ConduitT ByteString 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 ByteString (Either ByteString ByteString) m ()
left ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitT (Either ByteString ByteString) Void m ()
-> ConduitT ByteString Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Handle
-> Handle -> ConduitT (Either ByteString ByteString) Void m ()
forall (m :: * -> *).
MonadIO m =>
Handle
-> Handle -> ConduitT (Either ByteString ByteString) Void m ()
sinkHandles Handle
out1 Handle
err) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally`
Handle -> IO ()
hClose Handle
out1) Concurrently () -> Concurrently r -> Concurrently r
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
IO r -> Concurrently r
forall a. IO a -> Concurrently a
Concurrently ((UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m r -> IO r) -> m r -> IO r
forall a b. (a -> b) -> a -> b
$ Handles -> m r
right (Handle -> Handle -> Handle -> Handles
Handles Handle
in2 Handle
out2 Handle
err)) IO r -> IO () -> IO r
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
in2))
fuseProcessConduit
:: MonadUnliftIO m
=> (Handles -> m ())
-> ConduitT ByteString (Either ByteString ByteString) m r
-> (Handles -> m r)
fuseProcessConduit :: forall (m :: * -> *) r.
MonadUnliftIO m =>
(Handles -> m ())
-> ConduitT ByteString (Either ByteString ByteString) m r
-> Handles
-> m r
fuseProcessConduit Handles -> m ()
left ConduitT ByteString (Either ByteString ByteString) m r
right (Handles Handle
in1 Handle
out2 Handle
err) = do
UnliftIO m
u <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
(Handle
in2, Handle
out1) <- IO (Handle, Handle) -> m (Handle, Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createHandles
IO r -> m r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ Concurrently r -> IO r
forall a. Concurrently a -> IO a
runConcurrently
(IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently ((UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handles -> m ()
left (Handle -> Handle -> Handle -> Handles
Handles Handle
in1 Handle
out1 Handle
err)) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
out1) Concurrently () -> Concurrently r -> Concurrently r
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
IO r -> Concurrently r
forall a. IO a -> Concurrently a
Concurrently
((UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m r -> IO r) -> m r -> IO r
forall a b. (a -> b) -> a -> b
$ ConduitT () Void m r -> m r
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m r -> m r) -> ConduitT () Void m r -> m r
forall a b. (a -> b) -> a -> b
$
Handle -> ConduitT () ByteString m ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
in2 ConduitT () ByteString m ()
-> ConduitT ByteString Void m r -> ConduitT () Void m r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString (Either ByteString ByteString) m r
right ConduitT ByteString (Either ByteString ByteString) m r
-> ConduitT (Either ByteString ByteString) Void m ()
-> ConduitT ByteString Void m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r
`fuseUpstream` Handle
-> Handle -> ConduitT (Either ByteString ByteString) Void m ()
forall (m :: * -> *).
MonadIO m =>
Handle
-> Handle -> ConduitT (Either ByteString ByteString) Void m ()
sinkHandles Handle
out2 Handle
err) IO r -> IO () -> IO r
forall a b. IO a -> IO b -> IO a
`finally`
Handle -> IO ()
hClose Handle
in2))
fuseSegment :: MonadUnliftIO m => Segment m () -> Segment m r -> Segment m r
SegmentConduit ConduitM ByteString (Either ByteString ByteString) m ()
x fuseSegment :: forall (m :: * -> *) b.
MonadUnliftIO m =>
Segment m () -> Segment m b -> Segment m b
`fuseSegment` SegmentConduit ConduitM ByteString (Either ByteString ByteString) m r
y =
ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
forall (m :: * -> *) r.
ConduitM ByteString (Either ByteString ByteString) m r
-> Segment m r
SegmentConduit (ConduitM ByteString (Either ByteString ByteString) m ()
-> ConduitM ByteString (Either ByteString ByteString) m r
-> ConduitM ByteString (Either ByteString ByteString) m r
forall (m :: * -> *) r.
Monad m =>
ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitT ByteString (Either ByteString ByteString) m r
-> ConduitT ByteString (Either ByteString ByteString) m r
fuseConduit ConduitM ByteString (Either ByteString ByteString) m ()
x ConduitM ByteString (Either ByteString ByteString) m r
y)
SegmentConduit ConduitM ByteString (Either ByteString ByteString) m ()
x `fuseSegment` SegmentProcess Handles -> m r
y =
(Handles -> m r) -> Segment m r
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess (ConduitM ByteString (Either ByteString ByteString) m ()
-> (Handles -> m r) -> Handles -> m r
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT ByteString (Either ByteString ByteString) m ()
-> (Handles -> m r) -> Handles -> m r
fuseConduitProcess ConduitM ByteString (Either ByteString ByteString) m ()
x Handles -> m r
y)
SegmentProcess Handles -> m ()
x `fuseSegment` SegmentConduit ConduitM ByteString (Either ByteString ByteString) m r
y =
(Handles -> m r) -> Segment m r
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess ((Handles -> m ())
-> ConduitM ByteString (Either ByteString ByteString) m r
-> Handles
-> m r
forall (m :: * -> *) r.
MonadUnliftIO m =>
(Handles -> m ())
-> ConduitT ByteString (Either ByteString ByteString) m r
-> Handles
-> m r
fuseProcessConduit Handles -> m ()
x ConduitM ByteString (Either ByteString ByteString) m r
y)
SegmentProcess Handles -> m ()
x `fuseSegment` SegmentProcess Handles -> m r
y =
(Handles -> m r) -> Segment m r
forall (m :: * -> *) r. (Handles -> m r) -> Segment m r
SegmentProcess ((Handles -> m ()) -> (Handles -> m r) -> Handles -> m r
forall (m :: * -> *) r.
MonadUnliftIO m =>
(Handles -> m ()) -> (Handles -> m r) -> Handles -> m r
fuseProcess Handles -> m ()
x Handles -> m r
y)