{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

-- | A wrapping of createProcess to provide a more flexible interface.
module General.Process(
    Buffer, newBuffer, readBuffer,
    process, ProcessOpts(..), Source(..), Destination(..)
    ) where

import Control.Concurrent.Extra
import Control.DeepSeq
import Control.Exception.Extra as C
import Control.Monad.Extra
import Data.List.Extra
import Data.Maybe
import Foreign.C.Error
import System.Exit
import System.IO.Extra
import System.Info.Extra
import System.Process
import System.Time.Extra
import Data.Unique
import Data.IORef.Extra
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import General.Extra
import Development.Shake.Internal.Errors

import GHC.IO.Exception (IOErrorType(..), IOException(..))

---------------------------------------------------------------------
-- BUFFER ABSTRACTION

data Buffer a = Buffer Unique (IORef [a])
instance Eq (Buffer a) where Buffer Unique
x IORef [a]
_ == :: Buffer a -> Buffer a -> Bool
== Buffer Unique
y IORef [a]
_ = Unique
x forall a. Eq a => a -> a -> Bool
== Unique
y
instance Ord (Buffer a) where compare :: Buffer a -> Buffer a -> Ordering
compare (Buffer Unique
x IORef [a]
_) (Buffer Unique
y IORef [a]
_) = forall a. Ord a => a -> a -> Ordering
compare Unique
x Unique
y

newBuffer :: IO (Buffer a)
newBuffer :: forall a. IO (Buffer a)
newBuffer = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Unique -> IORef [a] -> Buffer a
Buffer IO Unique
newUnique (forall a. a -> IO (IORef a)
newIORef [])

addBuffer :: Buffer a -> a -> IO ()
addBuffer :: forall a. Buffer a -> a -> IO ()
addBuffer (Buffer Unique
_ IORef [a]
ref) a
x = forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef [a]
ref (a
xforall a. a -> [a] -> [a]
:)

readBuffer :: Buffer a -> IO [a]
readBuffer :: forall a. Buffer a -> IO [a]
readBuffer (Buffer Unique
_ IORef [a]
ref) = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef [a]
ref


---------------------------------------------------------------------
-- OPTIONS

data Source
    = SrcFile FilePath
    | SrcString String
    | SrcBytes LBS.ByteString
    | SrcInherit

data Destination
    = DestEcho
    | DestFile FilePath
    | DestString (Buffer String)
    | DestBytes (Buffer BS.ByteString)
      deriving (Destination -> Destination -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Destination -> Destination -> Bool
$c/= :: Destination -> Destination -> Bool
== :: Destination -> Destination -> Bool
$c== :: Destination -> Destination -> Bool
Eq,Eq Destination
Destination -> Destination -> Bool
Destination -> Destination -> Ordering
Destination -> Destination -> Destination
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Destination -> Destination -> Destination
$cmin :: Destination -> Destination -> Destination
max :: Destination -> Destination -> Destination
$cmax :: Destination -> Destination -> Destination
>= :: Destination -> Destination -> Bool
$c>= :: Destination -> Destination -> Bool
> :: Destination -> Destination -> Bool
$c> :: Destination -> Destination -> Bool
<= :: Destination -> Destination -> Bool
$c<= :: Destination -> Destination -> Bool
< :: Destination -> Destination -> Bool
$c< :: Destination -> Destination -> Bool
compare :: Destination -> Destination -> Ordering
$ccompare :: Destination -> Destination -> Ordering
Ord)

isDestString :: Destination -> Bool
isDestString DestString{} = Bool
True; isDestString Destination
_ = Bool
False
isDestBytes :: Destination -> Bool
isDestBytes  DestBytes{}  = Bool
True; isDestBytes  Destination
_ = Bool
False

data ProcessOpts = ProcessOpts
    {ProcessOpts -> CmdSpec
poCommand :: CmdSpec
    ,ProcessOpts -> Maybe String
poCwd :: Maybe FilePath
    ,ProcessOpts -> Maybe [(String, String)]
poEnv :: Maybe [(String, String)]
    ,ProcessOpts -> Maybe Double
poTimeout :: Maybe Double
    ,ProcessOpts -> [Source]
poStdin :: [Source]
    ,ProcessOpts -> [Destination]
poStdout :: [Destination]
    ,ProcessOpts -> [Destination]
poStderr :: [Destination]
    ,ProcessOpts -> Bool
poAsync :: Bool
    ,ProcessOpts -> Bool
poCloseFds :: Bool
    ,ProcessOpts -> Bool
poGroup :: Bool
    }


---------------------------------------------------------------------
-- IMPLEMENTATION

-- | If two buffers can be replaced by one and a copy, do that (only if they start empty)
optimiseBuffers :: ProcessOpts -> IO (ProcessOpts, IO ())
optimiseBuffers :: ProcessOpts -> IO (ProcessOpts, IO ())
optimiseBuffers po :: ProcessOpts
po@ProcessOpts{Bool
[Destination]
[Source]
Maybe Double
Maybe String
Maybe [(String, String)]
CmdSpec
poGroup :: Bool
poCloseFds :: Bool
poAsync :: Bool
poStderr :: [Destination]
poStdout :: [Destination]
poStdin :: [Source]
poTimeout :: Maybe Double
poEnv :: Maybe [(String, String)]
poCwd :: Maybe String
poCommand :: CmdSpec
poGroup :: ProcessOpts -> Bool
poCloseFds :: ProcessOpts -> Bool
poAsync :: ProcessOpts -> Bool
poStderr :: ProcessOpts -> [Destination]
poStdout :: ProcessOpts -> [Destination]
poStdin :: ProcessOpts -> [Source]
poTimeout :: ProcessOpts -> Maybe Double
poEnv :: ProcessOpts -> Maybe [(String, String)]
poCwd :: ProcessOpts -> Maybe String
poCommand :: ProcessOpts -> CmdSpec
..} = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcessOpts
po{poStdout :: [Destination]
poStdout = forall a. Ord a => [a] -> [a]
nubOrd [Destination]
poStdout, poStderr :: [Destination]
poStderr = forall a. Ord a => [a] -> [a]
nubOrd [Destination]
poStderr}, forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

stdStream :: (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream :: (String -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream String -> Handle
_ [Destination
DestEcho] [Destination]
_ = StdStream
Inherit
stdStream String -> Handle
file [DestFile String
x] [Destination]
other | [Destination]
other forall a. Eq a => a -> a -> Bool
== [String -> Destination
DestFile String
x] Bool -> Bool -> Bool
|| String -> Destination
DestFile String
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Destination]
other = Handle -> StdStream
UseHandle forall a b. (a -> b) -> a -> b
$ String -> Handle
file String
x
stdStream String -> Handle
_ [Destination]
_ [Destination]
_ = StdStream
CreatePipe


stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn :: (String -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn String -> Handle
_ [Source
SrcInherit] = (StdStream
Inherit, forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
stdIn String -> Handle
file [SrcFile String
x] = (Handle -> StdStream
UseHandle forall a b. (a -> b) -> a -> b
$ String -> Handle
file String
x, forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
stdIn String -> Handle
file [Source]
src = (,) StdStream
CreatePipe forall a b. (a -> b) -> a -> b
$ \Handle
h -> IO () -> IO ()
ignoreSigPipe forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Source]
src forall a b. (a -> b) -> a -> b
$ \case
        SrcString String
x -> Handle -> String -> IO ()
hPutStr Handle
h String
x
        SrcBytes ByteString
x -> Handle -> ByteString -> IO ()
LBS.hPutStr Handle
h ByteString
x
        SrcFile String
x -> Handle -> ByteString -> IO ()
LBS.hPutStr Handle
h forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO ByteString
LBS.hGetContents (String -> Handle
file String
x)
        Source
SrcInherit -> forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Can't both inherit and set it
    Handle -> IO ()
hClose Handle
h


ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = forall a. (IOException -> IO a) -> IO a -> IO a
handleIO forall a b. (a -> b) -> a -> b
$ \IOException
e -> case IOException
e of
    IOError {ioe_type :: IOException -> IOErrorType
ioe_type=IOErrorType
ResourceVanished, ioe_errno :: IOException -> Maybe CInt
ioe_errno=Just CInt
ioe} | CInt -> Errno
Errno CInt
ioe forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    IOException
_ -> forall e a. Exception e => e -> IO a
throwIO IOException
e


withExceptions :: IO () -> IO a -> IO a
withExceptions :: forall a. IO () -> IO a -> IO a
withExceptions IO ()
stop IO a
go = do
    Barrier (Either SomeException a)
bar <- forall a. IO (Barrier a)
newBarrier
    Either SomeException a
v <- forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
        forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (forall a. IO a -> IO a
unmask IO a
go) forall a b. (a -> b) -> a -> b
$ forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier (Either SomeException a)
bar
        forall a. IO a -> IO a
unmask (forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException a)
bar) forall a b. IO a -> IO b -> IO a
`onException` do
            IO () -> IO ThreadId
forkIO IO ()
stop
            forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException a)
bar
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException a
v


withTimeout :: Maybe Double -> IO () -> IO a -> IO a
withTimeout :: forall a. Maybe Double -> IO () -> IO a -> IO a
withTimeout Maybe Double
Nothing IO ()
_ IO a
go = IO a
go
withTimeout (Just Double
s) IO ()
stop IO a
go = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Double -> IO ()
sleep Double
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
stop) ThreadId -> IO ()
killThread forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const IO a
go


cmdSpec :: CmdSpec -> CreateProcess
cmdSpec :: CmdSpec -> CreateProcess
cmdSpec (ShellCommand String
x) = String -> CreateProcess
shell String
x
cmdSpec (RawCommand String
x [String]
xs) = String -> [String] -> CreateProcess
proc String
x [String]
xs



forkWait :: IO a -> IO (IO a)
forkWait :: forall a. IO a -> IO (IO a)
forkWait IO a
a = do
    MVar (Either SomeException a)
res <- forall a. IO (MVar a)
newEmptyMVar
    ThreadId
_ <- forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Either SomeException a)
try_ (forall a. IO a -> IO a
restore IO a
a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException a)
res
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Either SomeException a)
res forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure


abort :: Bool -> ProcessHandle -> IO ()
abort :: Bool -> ProcessHandle -> IO ()
abort Bool
poGroup ProcessHandle
pid = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
poGroup forall a b. (a -> b) -> a -> b
$ do
        ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
pid
        Double -> IO ()
sleep Double
3 -- give the process a few seconds grace period to die nicely
    ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid


withFiles :: IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a
withFiles :: forall a.
IOMode -> [String] -> ((String -> Handle) -> IO a) -> IO a
withFiles IOMode
mode [String]
files (String -> Handle) -> IO a
act = forall a r. [(a -> r) -> r] -> ([a] -> r) -> r
withs (forall a b. (a -> b) -> [a] -> [b]
map (forall r. String -> IOMode -> (Handle -> IO r) -> IO r
`withFile` IOMode
mode) [String]
files) forall a b. (a -> b) -> a -> b
$ \[Handle]
handles ->
    (String -> Handle) -> IO a
act forall a b. (a -> b) -> a -> b
$ \String
x -> forall a. Partial => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x forall a b. (a -> b) -> a -> b
$ forall a b. Partial => [a] -> [b] -> [(a, b)]
zipExact [String]
files [Handle]
handles


-- General approach taken from readProcessWithExitCode
process :: ProcessOpts -> IO (ProcessHandle, ExitCode)
process :: ProcessOpts -> IO (ProcessHandle, ExitCode)
process ProcessOpts
po = do
    (ProcessOpts{Bool
[Destination]
[Source]
Maybe Double
Maybe String
Maybe [(String, String)]
CmdSpec
poGroup :: Bool
poCloseFds :: Bool
poAsync :: Bool
poStderr :: [Destination]
poStdout :: [Destination]
poStdin :: [Source]
poTimeout :: Maybe Double
poEnv :: Maybe [(String, String)]
poCwd :: Maybe String
poCommand :: CmdSpec
poGroup :: ProcessOpts -> Bool
poCloseFds :: ProcessOpts -> Bool
poAsync :: ProcessOpts -> Bool
poStderr :: ProcessOpts -> [Destination]
poStdout :: ProcessOpts -> [Destination]
poStdin :: ProcessOpts -> [Source]
poTimeout :: ProcessOpts -> Maybe Double
poEnv :: ProcessOpts -> Maybe [(String, String)]
poCwd :: ProcessOpts -> Maybe String
poCommand :: ProcessOpts -> CmdSpec
..}, IO ()
flushBuffers) <- ProcessOpts -> IO (ProcessOpts, IO ())
optimiseBuffers ProcessOpts
po
    let outFiles :: [String]
outFiles = forall a. Ord a => [a] -> [a]
nubOrd [String
x | DestFile String
x <- [Destination]
poStdout forall a. [a] -> [a] -> [a]
++ [Destination]
poStderr]
    let inFiles :: [String]
inFiles = forall a. Ord a => [a] -> [a]
nubOrd [String
x | SrcFile String
x <- [Source]
poStdin]
    forall a.
IOMode -> [String] -> ((String -> Handle) -> IO a) -> IO a
withFiles IOMode
WriteMode [String]
outFiles forall a b. (a -> b) -> a -> b
$ \String -> Handle
outHandle -> forall a.
IOMode -> [String] -> ((String -> Handle) -> IO a) -> IO a
withFiles IOMode
ReadMode [String]
inFiles forall a b. (a -> b) -> a -> b
$ \String -> Handle
inHandle -> do
        let cp :: CreateProcess
cp = (CmdSpec -> CreateProcess
cmdSpec CmdSpec
poCommand){cwd :: Maybe String
cwd = Maybe String
poCwd, env :: Maybe [(String, String)]
env = Maybe [(String, String)]
poEnv, create_group :: Bool
create_group = Bool
poGroup, close_fds :: Bool
close_fds = Bool
poCloseFds
                 ,std_in :: StdStream
std_in = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ (String -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn String -> Handle
inHandle [Source]
poStdin
                 ,std_out :: StdStream
std_out = (String -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream String -> Handle
outHandle [Destination]
poStdout [Destination]
poStderr, std_err :: StdStream
std_err = (String -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream String -> Handle
outHandle [Destination]
poStderr [Destination]
poStdout}
        forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcessCompat CreateProcess
cp forall a b. (a -> b) -> a -> b
$ \Maybe Handle
inh Maybe Handle
outh Maybe Handle
errh ProcessHandle
pid ->
            forall a. Maybe Double -> IO () -> IO a -> IO a
withTimeout Maybe Double
poTimeout (Bool -> ProcessHandle -> IO ()
abort Bool
poGroup ProcessHandle
pid) forall a b. (a -> b) -> a -> b
$ forall a. IO () -> IO a -> IO a
withExceptions (Bool -> ProcessHandle -> IO ()
abort Bool
poGroup ProcessHandle
pid) forall a b. (a -> b) -> a -> b
$ do

                let streams :: [(Handle, Handle, [Destination])]
streams = [(Handle
outh, Handle
stdout, [Destination]
poStdout) | Just Handle
outh <- [Maybe Handle
outh], StdStream
CreatePipe <- [CreateProcess -> StdStream
std_out CreateProcess
cp]] forall a. [a] -> [a] -> [a]
++
                              [(Handle
errh, Handle
stderr, [Destination]
poStderr) | Just Handle
errh <- [Maybe Handle
errh], StdStream
CreatePipe <- [CreateProcess -> StdStream
std_err CreateProcess
cp]]
                [IO ()]
wait <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Handle, Handle, [Destination])]
streams forall a b. (a -> b) -> a -> b
$ \(Handle
h, Handle
hh, [Destination]
dest) -> do
                    -- no point tying the streams together if one is being streamed directly
                    let isTied :: Bool
isTied = Bool -> Bool
not ([Destination]
poStdout forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [Destination]
poStderr) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Handle, Handle, [Destination])]
streams forall a. Eq a => a -> a -> Bool
== Int
2
                    let isBinary :: Bool
isBinary = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Destination -> Bool
isDestBytes [Destination]
dest Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Destination -> Bool
isDestString [Destination]
dest)
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTied forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Destination
DestEcho forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Destination]
dest) forall a b. (a -> b) -> a -> b
$ do
                        BufferMode
buf <- Handle -> IO BufferMode
hGetBuffering Handle
hh
                        case BufferMode
buf of
                            BlockBuffering{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                            BufferMode
_ -> Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
buf

                    if Bool
isBinary then do
                        Handle -> Bool -> IO ()
hSetBinaryMode Handle
h Bool
True
                        [ByteString -> IO ()]
dest<- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Destination]
dest forall a b. (a -> b) -> a -> b
$ \case
                            Destination
DestEcho -> Handle -> ByteString -> IO ()
BS.hPut Handle
hh
                            DestFile String
x -> Handle -> ByteString -> IO ()
BS.hPut (String -> Handle
outHandle String
x)
                            DestString Buffer String
x -> forall a. Buffer a -> a -> IO ()
addBuffer Buffer String
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isWindows then forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace String
"\r\n" String
"\n" else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.unpack
                            DestBytes Buffer ByteString
x -> forall a. Buffer a -> a -> IO ()
addBuffer Buffer ByteString
x
                        forall a. IO a -> IO (IO a)
forkWait forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => m Bool -> m ()
whileM forall a b. (a -> b) -> a -> b
$ do
                            ByteString
src <- Handle -> Int -> IO ByteString
BS.hGetSome Handle
h Int
4096
                            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b. (a -> b) -> a -> b
$ ByteString
src) [ByteString -> IO ()]
dest
                            forall (m :: * -> *). Functor m => m Bool -> m Bool
notM forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsEOF Handle
h
                     else if Bool
isTied then do
                        [String -> IO ()]
dest<- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Destination]
dest forall a b. (a -> b) -> a -> b
$ \case
                            Destination
DestEcho -> Handle -> String -> IO ()
hPutStrLn Handle
hh
                            DestFile String
x -> Handle -> String -> IO ()
hPutStrLn (String -> Handle
outHandle String
x)
                            DestString Buffer String
x -> forall a. Buffer a -> a -> IO ()
addBuffer Buffer String
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
"\n")
                            DestBytes{} -> forall a. SomeException -> a
throwImpure forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal String
"Not reachable due to isBinary condition"
                        forall a. IO a -> IO (IO a)
forkWait forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => m Bool -> m ()
whileM forall a b. (a -> b) -> a -> b
$
                            forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Handle -> IO Bool
hIsEOF Handle
h) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) forall a b. (a -> b) -> a -> b
$ do
                                String
src <- Handle -> IO String
hGetLine Handle
h
                                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b. (a -> b) -> a -> b
$ String
src) [String -> IO ()]
dest
                                forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                     else do
                        String
src <- Handle -> IO String
hGetContents Handle
h
                        IO ()
wait1 <- forall a. IO a -> IO (IO a)
forkWait forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
C.evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> ()
rnf String
src
                        [IO ()]
waits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Destination]
dest forall a b. (a -> b) -> a -> b
$ \case
                            Destination
DestEcho -> forall a. IO a -> IO (IO a)
forkWait forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
hh String
src
                            DestFile String
x -> forall a. IO a -> IO (IO a)
forkWait forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr (String -> Handle
outHandle String
x) String
src
                            DestString Buffer String
x -> do forall a. Buffer a -> a -> IO ()
addBuffer Buffer String
x String
src; forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                            DestBytes{} -> forall a. SomeException -> a
throwImpure forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal String
"Not reachable due to isBinary condition"
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ IO ()
wait1 forall a. a -> [a] -> [a]
: [IO ()]
waits

                forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
inh forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ (String -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn String -> Handle
inHandle [Source]
poStdin
                if Bool
poAsync then
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcessHandle
pid, ExitCode
ExitSuccess)
                 else do
                    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
wait
                    IO ()
flushBuffers
                    ExitCode
res <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
                    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
outh Handle -> IO ()
hClose
                    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
errh Handle -> IO ()
hClose
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcessHandle
pid, ExitCode
res)


---------------------------------------------------------------------
-- COMPATIBILITY

-- available in process-1.4.3.0, GHC ??? (Nov 2015)
-- logic copied directly (apart from Ctrl-C handling magic using internal pieces)
withCreateProcessCompat :: CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a
withCreateProcessCompat :: forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcessCompat CreateProcess
cp Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a
act = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp) (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ThreadId
cleanup
    (\(Maybe Handle
m_in, Maybe Handle
m_out, Maybe Handle
m_err, ProcessHandle
ph) -> Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a
act Maybe Handle
m_in Maybe Handle
m_out Maybe Handle
m_err ProcessHandle
ph)
    where
        cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ThreadId
cleanup (Maybe Handle
inh, Maybe Handle
outh, Maybe Handle
errh, ProcessHandle
pid) = do
            ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
inh forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignoreSigPipe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
hClose
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
outh Handle -> IO ()
hClose
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
errh Handle -> IO ()
hClose
            IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid