{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- | Reading from the process.

module Data.Conduit.Shell.Process
  (-- * Running scripts
   run
   -- * Conduit types
  ,text
  ,bytes
  -- * General conduits
  ,conduit
  ,conduitEither
  -- * Running processes
  ,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           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)

-- | A pipeable segment. Either a conduit or a process.
data Segment r
  = SegmentConduit (ConduitM ByteString (Either ByteString ByteString) IO r)
  | SegmentProcess (Handles -> IO r)

instance Monad Segment where
  return :: a -> Segment a
return = ConduitM ByteString (Either ByteString ByteString) IO a
-> Segment a
forall r.
ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
SegmentConduit (ConduitM ByteString (Either ByteString ByteString) IO a
 -> Segment a)
-> (a -> ConduitM ByteString (Either ByteString ByteString) IO a)
-> a
-> Segment a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ConduitM ByteString (Either ByteString ByteString) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  SegmentConduit c :: ConduitM ByteString (Either ByteString ByteString) IO a
c >>= :: Segment a -> (a -> Segment b) -> Segment b
>>= f :: a -> Segment b
f =
    (Handles -> IO a) -> Segment a
forall r. (Handles -> IO r) -> Segment r
SegmentProcess (ConduitM ByteString (Either ByteString ByteString) IO a
-> Handles -> IO a
forall r.
ConduitT ByteString (Either ByteString ByteString) IO r
-> Handles -> IO r
conduitToProcess ConduitM ByteString (Either ByteString ByteString) IO a
c) Segment a -> (a -> Segment b) -> Segment b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    a -> Segment b
f
  SegmentProcess f :: Handles -> IO a
f >>= g :: a -> Segment b
g =
    (Handles -> IO b) -> Segment b
forall r. (Handles -> IO r) -> Segment r
SegmentProcess
      (\handles :: Handles
handles ->
         do a
x <- Handles -> IO a
f Handles
handles
            case a -> Segment b
g a
x of
              SegmentConduit c :: ConduitM ByteString (Either ByteString ByteString) IO b
c ->
                ConduitM ByteString (Either ByteString ByteString) IO b
-> Handles -> IO b
forall r.
ConduitT ByteString (Either ByteString ByteString) IO r
-> Handles -> IO r
conduitToProcess ConduitM ByteString (Either ByteString ByteString) IO b
c Handles
handles
              SegmentProcess p :: Handles -> IO b
p -> Handles -> IO b
p Handles
handles)

instance Functor Segment where
  fmap :: (a -> b) -> Segment a -> Segment b
fmap = (a -> b) -> Segment a -> Segment b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative Segment where
  <*> :: Segment (a -> b) -> Segment a -> Segment b
(<*>) = Segment (a -> b) -> Segment a -> Segment b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap; pure :: a -> Segment a
pure = a -> Segment a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Alternative Segment where
  this :: Segment a
this <|> :: Segment a -> Segment a -> Segment a
<|> that :: Segment a
that =
    do Either ProcessException a
ex <- Segment a -> Segment (Either ProcessException a)
forall e r. Exception e => Segment r -> Segment (Either e r)
tryS Segment a
this
       case Either ProcessException a
ex of
         Right x :: a
x -> a -> Segment a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
         Left (ProcessException
_ :: ProcessException) -> Segment a
that
  empty :: Segment a
empty = ProcessException -> Segment a
forall a e. Exception e => e -> a
throw ProcessException
ProcessEmpty

-- | Try something in a segment.
tryS :: Exception e => Segment r -> Segment (Either e r)
tryS :: Segment r -> Segment (Either e r)
tryS s :: Segment r
s =
  case Segment r
s of
    SegmentConduit c :: ConduitM ByteString (Either ByteString ByteString) IO r
c -> ConduitM ByteString (Either ByteString ByteString) IO (Either e r)
-> Segment (Either e r)
forall r.
ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
SegmentConduit (ConduitM ByteString (Either ByteString ByteString) IO r
-> ConduitM
     ByteString (Either ByteString ByteString) IO (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) IO r
c)
    SegmentProcess f :: Handles -> IO r
f -> (Handles -> IO (Either e r)) -> Segment (Either e r)
forall r. (Handles -> IO r) -> Segment r
SegmentProcess (\h :: Handles
h -> IO r -> IO (Either e r)
forall e a. Exception e => IO a -> IO (Either e a)
try (Handles -> IO r
f Handles
h))

instance MonadIO Segment where
  liftIO :: IO a -> Segment a
liftIO x :: IO a
x = (Handles -> IO a) -> Segment a
forall r. (Handles -> IO r) -> Segment r
SegmentProcess (IO a -> Handles -> IO a
forall a b. a -> b -> a
const IO a
x)

-- | Process handles: @stdin@, @stdout@, @stderr@
data Handles =
  Handles Handle
          Handle
          Handle

-- | Process running exception.
data ProcessException
  = ProcessException CreateProcess
                     ExitCode
  | ProcessEmpty
  deriving (Typeable)

instance Exception ProcessException

instance Show ProcessException where
  show :: ProcessException -> String
show ProcessEmpty = "empty process"
  show (ProcessException cp :: CreateProcess
cp ec :: ExitCode
ec) =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ "The "
      , case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
          ShellCommand s :: String
s -> "shell command " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
          RawCommand f :: String
f args :: [String]
args -> "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)
      , " returned a failure exit code: "
      , case ExitCode
ec of
          ExitFailure i :: Int
i -> Int -> String
forall a. Show a => a -> String
show Int
i
          _ -> ExitCode -> String
forall a. Show a => a -> String
show ExitCode
ec
      ]

-- | Convert a process or a conduit to a segment.
class ToSegment a  where
  type SegmentResult a
  toSegment :: a -> Segment (SegmentResult a)

instance ToSegment (Segment r) where
  type SegmentResult (Segment r) = r
  toSegment :: Segment r -> Segment (SegmentResult (Segment r))
toSegment = Segment r -> Segment (SegmentResult (Segment r))
forall a. a -> a
id

instance (a ~ ByteString, ToChunk b, m ~ IO) =>
         ToSegment (ConduitT a b m r) where
  type SegmentResult (ConduitT a b m r) = r
  toSegment :: ConduitT a b m r -> Segment (SegmentResult (ConduitT a b m r))
toSegment f :: ConduitT a b m r
f = ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
forall r.
ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
SegmentConduit (ConduitT a b m r
f ConduitT a b m r
-> Conduit b m (Either ByteString ByteString)
-> ConduitT a (Either ByteString ByteString) m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> Conduit b m c -> ConduitT a c m r
`fuseUpstream` (b -> Either ByteString ByteString)
-> Conduit b m (Either ByteString ByteString)
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 ToSegment CreateProcess where
  type SegmentResult CreateProcess = ()
  toSegment :: CreateProcess -> Segment (SegmentResult CreateProcess)
toSegment = CreateProcess -> Segment ()
CreateProcess -> Segment (SegmentResult CreateProcess)
liftProcess

-- | Used to allow outputting stdout or stderr.
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

-- | Run a shell command.
shell :: String -> Segment ()
shell :: String -> Segment ()
shell = CreateProcess -> Segment ()
liftProcess (CreateProcess -> Segment ())
-> (String -> CreateProcess) -> String -> Segment ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CreateProcess
System.Process.shell

-- | Run a process command.
proc :: String -> [String] -> Segment ()
proc :: String -> [String] -> Segment ()
proc name :: String
name args :: [String]
args = CreateProcess -> Segment ()
liftProcess (String -> [String] -> CreateProcess
System.Process.proc String
name [String]
args)

-- | Run a segment.
run :: Segment r -> IO r
run :: Segment r -> IO r
run (SegmentConduit c :: ConduitM ByteString (Either ByteString ByteString) IO r
c) = Segment r -> IO r
forall r. Segment r -> IO r
run ((Handles -> IO r) -> Segment r
forall r. (Handles -> IO r) -> Segment r
SegmentProcess (ConduitM ByteString (Either ByteString ByteString) IO r
-> Handles -> IO r
forall r.
ConduitT ByteString (Either ByteString ByteString) IO r
-> Handles -> IO r
conduitToProcess ConduitM ByteString (Either ByteString ByteString) IO r
c))
run (SegmentProcess p :: Handles -> IO r
p) = Handles -> IO r
p (Handle -> Handle -> Handle -> Handles
Handles Handle
stdin Handle
stdout Handle
stderr)

-- | Fuse two segments (either processes or conduits).
($|) :: Segment () -> Segment b -> Segment b
x :: Segment ()
x $| :: Segment () -> Segment b -> Segment b
$| y :: Segment b
y = Segment ()
x Segment () -> Segment b -> Segment b
forall r. Segment () -> Segment r -> Segment r
`fuseSegment` Segment b
y

infixl 0 $|

-- | Work on the stream as 'Text' values from UTF-8.
text
  :: (r ~ (), m ~ IO)
  => ConduitT Text Text m r -> Segment r
text :: ConduitT Text Text m r -> Segment r
text conduit' :: ConduitT Text Text m r
conduit' = ConduitT ByteString ByteString m () -> Segment ()
forall a (m :: * -> *) r.
(a ~ ByteString, m ~ IO) =>
ConduitT a ByteString m r -> Segment r
bytes (ConduitT ByteString Text m ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8 ConduitT ByteString Text m ()
-> ConduitM Text ByteString m ()
-> ConduitT ByteString ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT Text Text m r
ConduitT Text Text m ()
conduit' ConduitT Text Text m ()
-> ConduitM Text ByteString m () -> ConduitM Text ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Text ByteString m ()
forall (m :: * -> *) text binary.
(Monad m, Utf8 text binary) =>
ConduitT text binary m ()
encodeUtf8)

-- | Lift a conduit into a segment.
bytes
  :: (a ~ ByteString, m ~ IO)
  => ConduitT a ByteString m r -> Segment r
bytes :: ConduitT a ByteString m r -> Segment r
bytes f :: ConduitT a ByteString m r
f = ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
forall r.
ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
SegmentConduit (ConduitT a ByteString m r
f ConduitT a ByteString m r
-> Conduit ByteString m (Either ByteString ByteString)
-> ConduitT a (Either ByteString ByteString) m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> Conduit b m c -> ConduitT a c m r
`fuseUpstream` (ByteString -> Either ByteString ByteString)
-> Conduit ByteString m (Either ByteString ByteString)
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)

-- | Lift a conduit into a segment.
conduit
  :: (a ~ ByteString, m ~ IO)
  => ConduitT a ByteString m r -> Segment r
conduit :: ConduitT a ByteString m r -> Segment r
conduit f :: ConduitT a ByteString m r
f = ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
forall r.
ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
SegmentConduit (ConduitT a ByteString m r
f ConduitT a ByteString m r
-> Conduit ByteString m (Either ByteString ByteString)
-> ConduitT a (Either ByteString ByteString) m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> Conduit b m c -> ConduitT a c m r
`fuseUpstream` (ByteString -> Either ByteString ByteString)
-> Conduit ByteString m (Either ByteString ByteString)
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)

-- | Lift a conduit into a segment, which can yield stderr.
conduitEither
  :: (a ~ ByteString, m ~ IO)
  => ConduitT a (Either ByteString ByteString) m r -> Segment r
conduitEither :: ConduitT a (Either ByteString ByteString) m r -> Segment r
conduitEither f :: ConduitT a (Either ByteString ByteString) m r
f = ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
forall r.
ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
SegmentConduit (ConduitT a (Either ByteString ByteString) m r
f ConduitT a (Either ByteString ByteString) m r
-> Conduit
     (Either ByteString ByteString) m (Either ByteString ByteString)
-> ConduitT a (Either ByteString ByteString) m r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> Conduit b m c -> ConduitT a c m r
`fuseUpstream` (Either ByteString ByteString -> Either ByteString ByteString)
-> Conduit
     (Either ByteString ByteString) m (Either ByteString ByteString)
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)

-- | Lift a process into a segment.
liftProcess :: CreateProcess -> Segment ()
liftProcess :: CreateProcess -> Segment ()
liftProcess cp :: CreateProcess
cp =
  (Handles -> IO ()) -> Segment ()
forall r. (Handles -> IO r) -> Segment r
SegmentProcess
    (\(Handles inh :: Handle
inh outh :: Handle
outh errh :: 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 do (Nothing, Nothing, Nothing, ph :: ProcessHandle
ph) <- String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ "liftProcess" CreateProcess
config
              ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
              case ExitCode
ec of
                ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                _ -> ProcessException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (CreateProcess -> ExitCode -> ProcessException
ProcessException CreateProcess
cp ExitCode
ec))

-- | Convert a conduit to a process.
conduitToProcess :: ConduitT ByteString (Either ByteString ByteString) IO r
                 -> (Handles -> IO r)
conduitToProcess :: ConduitT ByteString (Either ByteString ByteString) IO r
-> Handles -> IO r
conduitToProcess c :: ConduitT ByteString (Either ByteString ByteString) IO r
c (Handles inh :: Handle
inh outh :: Handle
outh errh :: Handle
errh) =
  ConduitT () Void IO r -> IO r
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO r -> IO r) -> ConduitT () Void IO r -> IO r
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
inh ConduitT () ByteString IO ()
-> ConduitM ByteString Void IO r -> ConduitT () Void IO r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString (Either ByteString ByteString) IO r
c ConduitT ByteString (Either ByteString ByteString) IO r
-> Conduit (Either ByteString ByteString) IO Void
-> ConduitM ByteString Void IO r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> Conduit b m c -> ConduitT a c m r
`fuseUpstream` Handle -> Handle -> Conduit (Either ByteString ByteString) IO Void
sinkHandles Handle
outh Handle
errh

-- | Sink everything into the two handles.
sinkHandles :: Handle
            -> Handle
            -> ConduitT (Either ByteString ByteString) Void IO ()
sinkHandles :: Handle -> Handle -> Conduit (Either ByteString ByteString) IO Void
sinkHandles out :: Handle
out err :: Handle
err =
  (Either ByteString ByteString -> IO ())
-> Conduit (Either ByteString ByteString) IO Void
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_
    (\ebs :: Either ByteString ByteString
ebs ->
        case Either ByteString ByteString
ebs of
          Left bs :: ByteString
bs -> Handle -> ByteString -> IO ()
S.hPut Handle
out ByteString
bs
          Right bs :: ByteString
bs -> Handle -> ByteString -> IO ()
S.hPut Handle
err ByteString
bs)

-- | Create a pipe.
createHandles :: IO (Handle, Handle)
createHandles :: IO (Handle, Handle)
createHandles =
  IO (Handle, Handle) -> IO (Handle, Handle)
forall a. IO a -> IO a
mask_
    (do (inFD :: Fd
inFD, outFD :: 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))

-- | Fuse two processes.
fuseProcess :: (Handles -> IO ()) -> (Handles -> IO r) -> (Handles -> IO r)
fuseProcess :: (Handles -> IO ()) -> (Handles -> IO r) -> Handles -> IO r
fuseProcess left :: Handles -> IO ()
left right :: Handles -> IO r
right (Handles in1 :: Handle
in1 out2 :: Handle
out2 err :: Handle
err) = do
  (in2 :: Handle
in2, out1 :: Handle
out1) <- IO (Handle, Handle)
createHandles
  Concurrently r -> IO r
forall a. Concurrently a -> IO a
runConcurrently
    (IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (Handles -> IO ()
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 (Handles -> IO 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))

-- | Fuse two conduits.
fuseConduit
  :: 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 ()
-> ConduitT ByteString (Either ByteString ByteString) m r
-> ConduitT ByteString (Either ByteString ByteString) m r
fuseConduit left :: ConduitT ByteString (Either ByteString ByteString) m ()
left right :: ConduitT ByteString (Either ByteString ByteString) m r
right = ConduitT ByteString (Either ByteString ByteString) m ()
left ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitM
     (Either ByteString ByteString) (Either ByteString ByteString) m r
-> ConduitT ByteString (Either ByteString ByteString) m r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ZipConduit
  (Either ByteString ByteString) (Either ByteString ByteString) m r
-> ConduitM
     (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
*>
      ConduitM
  (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
-> ConduitM
     (Either ByteString ByteString) (Either ByteString ByteString) m r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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

-- | Fuse a conduit with a process.
fuseConduitProcess
  :: ConduitT ByteString (Either ByteString ByteString) IO ()
  -> (Handles -> IO r)
  -> (Handles -> IO r)
fuseConduitProcess :: ConduitT ByteString (Either ByteString ByteString) IO ()
-> (Handles -> IO r) -> Handles -> IO r
fuseConduitProcess left :: ConduitT ByteString (Either ByteString ByteString) IO ()
left right :: Handles -> IO r
right (Handles in1 :: Handle
in1 out2 :: Handle
out2 err :: Handle
err) = do
  (in2 :: Handle
in2, out1 :: Handle
out1) <- IO (Handle, Handle)
createHandles
  Concurrently r -> IO r
forall a. Concurrently a -> IO a
runConcurrently
    (IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently
       ((ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
in1 ConduitT () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString (Either ByteString ByteString) IO ()
left ConduitT ByteString (Either ByteString ByteString) IO ()
-> Conduit (Either ByteString ByteString) IO Void
-> ConduitM ByteString Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Handle -> Handle -> Conduit (Either ByteString ByteString) IO Void
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 (Handles -> IO 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))

-- | Fuse a process with a conduit.
fuseProcessConduit
  :: (Handles -> IO ())
  -> ConduitT ByteString (Either ByteString ByteString) IO r
  -> (Handles -> IO r)
fuseProcessConduit :: (Handles -> IO ())
-> ConduitT ByteString (Either ByteString ByteString) IO r
-> Handles
-> IO r
fuseProcessConduit left :: Handles -> IO ()
left right :: ConduitT ByteString (Either ByteString ByteString) IO r
right (Handles in1 :: Handle
in1 out2 :: Handle
out2 err :: Handle
err) = do
  (in2 :: Handle
in2, out1 :: Handle
out1) <- IO (Handle, Handle)
createHandles
  Concurrently r -> IO r
forall a. Concurrently a -> IO a
runConcurrently
    (IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (Handles -> IO ()
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
       ((ConduitT () Void IO r -> IO r
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO r -> IO r) -> ConduitT () Void IO r -> IO r
forall a b. (a -> b) -> a -> b
$
         Handle -> ConduitT () ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
in2 ConduitT () ByteString IO ()
-> ConduitM ByteString Void IO r -> ConduitT () Void IO r
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString (Either ByteString ByteString) IO r
right ConduitT ByteString (Either ByteString ByteString) IO r
-> Conduit (Either ByteString ByteString) IO Void
-> ConduitM ByteString Void IO r
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> Conduit b m c -> ConduitT a c m r
`fuseUpstream` Handle -> Handle -> Conduit (Either ByteString ByteString) IO Void
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))

-- | Fuse one segment with another.
fuseSegment :: Segment () -> Segment r -> Segment r
SegmentConduit x :: ConduitT ByteString (Either ByteString ByteString) IO ()
x fuseSegment :: Segment () -> Segment r -> Segment r
`fuseSegment` SegmentConduit y :: ConduitM ByteString (Either ByteString ByteString) IO r
y =
  ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
forall r.
ConduitM ByteString (Either ByteString ByteString) IO r
-> Segment r
SegmentConduit (ConduitT ByteString (Either ByteString ByteString) IO ()
-> ConduitM ByteString (Either ByteString ByteString) IO r
-> ConduitM ByteString (Either ByteString ByteString) IO 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 ConduitT ByteString (Either ByteString ByteString) IO ()
x ConduitM ByteString (Either ByteString ByteString) IO r
y)
SegmentConduit x :: ConduitT ByteString (Either ByteString ByteString) IO ()
x `fuseSegment` SegmentProcess y :: Handles -> IO r
y =
  (Handles -> IO r) -> Segment r
forall r. (Handles -> IO r) -> Segment r
SegmentProcess (ConduitT ByteString (Either ByteString ByteString) IO ()
-> (Handles -> IO r) -> Handles -> IO r
forall r.
ConduitT ByteString (Either ByteString ByteString) IO ()
-> (Handles -> IO r) -> Handles -> IO r
fuseConduitProcess ConduitT ByteString (Either ByteString ByteString) IO ()
x Handles -> IO r
y)
SegmentProcess x :: Handles -> IO ()
x `fuseSegment` SegmentConduit y :: ConduitM ByteString (Either ByteString ByteString) IO r
y =
  (Handles -> IO r) -> Segment r
forall r. (Handles -> IO r) -> Segment r
SegmentProcess ((Handles -> IO ())
-> ConduitM ByteString (Either ByteString ByteString) IO r
-> Handles
-> IO r
forall r.
(Handles -> IO ())
-> ConduitT ByteString (Either ByteString ByteString) IO r
-> Handles
-> IO r
fuseProcessConduit Handles -> IO ()
x ConduitM ByteString (Either ByteString ByteString) IO r
y)
SegmentProcess x :: Handles -> IO ()
x `fuseSegment` SegmentProcess y :: Handles -> IO r
y =
  (Handles -> IO r) -> Segment r
forall r. (Handles -> IO r) -> Segment r
SegmentProcess ((Handles -> IO ()) -> (Handles -> IO r) -> Handles -> IO r
forall r.
(Handles -> IO ()) -> (Handles -> IO r) -> Handles -> IO r
fuseProcess Handles -> IO ()
x Handles -> IO r
y)