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

-- | 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           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)

-- | A pipeable segment. Either a conduit or a process.
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

-- | Try something in a segment.
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)

-- | 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 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
      ]

-- | Convert a process or a conduit to a segment.
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
-> 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 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

-- | 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 :: 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

-- | Run a process command.
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 a segment.
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)

-- | Fuse two segments (either processes or conduits).
($|) :: 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 $|

-- | Work on the stream as 'Text' values from UTF-8.
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 ()
-> 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, 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
-> 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, 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
-> 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, 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
-> 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 :: 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))

-- | Convert a conduit to a process.
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 ()
-> ConduitM ByteString Void m r -> ConduitT () Void 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
c ConduitT ByteString (Either ByteString ByteString) m r
-> Conduit (Either ByteString ByteString) m Void
-> ConduitM ByteString Void 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` Handle -> Handle -> Conduit (Either ByteString ByteString) m Void
forall (m :: * -> *).
MonadIO m =>
Handle
-> Handle -> ConduitT (Either ByteString ByteString) Void m ()
sinkHandles Handle
outh Handle
errh

-- | Sink everything into the two handles.
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)

-- | 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 (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))

-- | Fuse two processes.
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))

-- | 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 :: 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 ()
-> 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
  :: 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 ()
-> ConduitM ByteString Void m () -> ConduitT () Void m ()
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 ()
left ConduitT ByteString (Either ByteString ByteString) m ()
-> ConduitM (Either ByteString ByteString) Void m ()
-> ConduitM ByteString Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Handle
-> Handle -> ConduitM (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))

-- | Fuse a process with a conduit.
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 ()
-> ConduitM ByteString Void m r -> ConduitT () Void 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 ConduitT ByteString (Either ByteString ByteString) m r
-> Conduit (Either ByteString ByteString) m Void
-> ConduitM ByteString Void 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` Handle -> Handle -> Conduit (Either ByteString ByteString) m Void
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))

-- | Fuse one segment with another.
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)