{-# 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.Applicative
import Control.Concurrent
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
import qualified Data.ByteString.Internal as BS(createAndTrim)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import General.Extra
import Prelude

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

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

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

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

addBuffer :: Buffer a -> a -> IO ()
addBuffer :: Buffer a -> a -> IO ()
addBuffer (Buffer _ ref :: IORef [a]
ref) x :: a
x = IORef [a] -> ([a] -> ([a], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [a]
ref (([a] -> ([a], ())) -> IO ()) -> ([a] -> ([a], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \xs :: [a]
xs -> (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs, ())

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


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

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

data Destination
    = DestEcho
    | DestFile FilePath
    | DestString (Buffer String)
    | DestBytes (Buffer BS.ByteString)
      deriving (Destination -> Destination -> Bool
(Destination -> Destination -> Bool)
-> (Destination -> Destination -> Bool) -> Eq Destination
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
Eq Destination =>
(Destination -> Destination -> Ordering)
-> (Destination -> Destination -> Bool)
-> (Destination -> Destination -> Bool)
-> (Destination -> Destination -> Bool)
-> (Destination -> Destination -> Bool)
-> (Destination -> Destination -> Destination)
-> (Destination -> Destination -> Destination)
-> Ord 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
$cp1Ord :: Eq Destination
Ord)

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

data ProcessOpts = ProcessOpts
    {ProcessOpts -> CmdSpec
poCommand :: CmdSpec
    ,ProcessOpts -> Maybe FilePath
poCwd :: Maybe FilePath
    ,ProcessOpts -> Maybe [(FilePath, FilePath)]
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
    }


---------------------------------------------------------------------
-- 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{..} = (ProcessOpts, IO ()) -> IO (ProcessOpts, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessOpts
po{poStdout :: [Destination]
poStdout = [Destination] -> [Destination]
forall a. Ord a => [a] -> [a]
nubOrd [Destination]
poStdout, poStderr :: [Destination]
poStderr = [Destination] -> [Destination]
forall a. Ord a => [a] -> [a]
nubOrd [Destination]
poStderr}, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

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


stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn file :: FilePath -> Handle
file [] = (StdStream
Inherit, IO () -> Handle -> IO ()
forall a b. a -> b -> a
const (IO () -> Handle -> IO ()) -> IO () -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
stdIn file :: FilePath -> Handle
file [SrcFile x :: FilePath
x] = (Handle -> StdStream
UseHandle (Handle -> StdStream) -> Handle -> StdStream
forall a b. (a -> b) -> a -> b
$ FilePath -> Handle
file FilePath
x, IO () -> Handle -> IO ()
forall a b. a -> b -> a
const (IO () -> Handle -> IO ()) -> IO () -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
stdIn file :: FilePath -> Handle
file src :: [Source]
src = (,) StdStream
CreatePipe ((Handle -> IO ()) -> (StdStream, Handle -> IO ()))
-> (Handle -> IO ()) -> (StdStream, Handle -> IO ())
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Source] -> (Source -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Source]
src ((Source -> IO ()) -> IO ()) -> (Source -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \x :: Source
x -> case Source
x of
        SrcString x :: FilePath
x -> Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
x
        SrcBytes x :: ByteString
x -> Handle -> ByteString -> IO ()
LBS.hPutStr Handle
h ByteString
x
        SrcFile x :: FilePath
x -> Handle -> ByteString -> IO ()
LBS.hPutStr Handle
h (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO ByteString
LBS.hGetContents (FilePath -> Handle
file FilePath
x)
    Handle -> IO ()
hClose Handle
h


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


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


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



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


abort :: ProcessHandle -> IO ()
abort :: ProcessHandle -> IO ()
abort pid :: ProcessHandle
pid = do
    ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
pid
    Double -> IO ()
sleep 5 -- give the process a few seconds grace period to die nicely
    -- seems to happen with some GHC 7.2 compiled binaries with FFI etc
    ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid

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


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

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

                    if Bool
isBinary then do
                        Handle -> Bool -> IO ()
hSetBinaryMode Handle
h Bool
True
                        [ByteString -> IO ()]
dest <- [ByteString -> IO ()] -> IO [ByteString -> IO ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString -> IO ()] -> IO [ByteString -> IO ()])
-> [ByteString -> IO ()] -> IO [ByteString -> IO ()]
forall a b. (a -> b) -> a -> b
$ [Destination]
-> (Destination -> ByteString -> IO ()) -> [ByteString -> IO ()]
forall a b. [a] -> (a -> b) -> [b]
for [Destination]
dest ((Destination -> ByteString -> IO ()) -> [ByteString -> IO ()])
-> (Destination -> ByteString -> IO ()) -> [ByteString -> IO ()]
forall a b. (a -> b) -> a -> b
$ \d :: Destination
d -> case Destination
d of
                            DestEcho -> Handle -> ByteString -> IO ()
BS.hPut Handle
hh
                            DestFile x :: FilePath
x -> Handle -> ByteString -> IO ()
BS.hPut (FilePath -> Handle
outHandle FilePath
x)
                            DestString x :: Buffer FilePath
x -> Buffer FilePath -> FilePath -> IO ()
forall a. Buffer a -> a -> IO ()
addBuffer Buffer FilePath
x (FilePath -> IO ())
-> (ByteString -> FilePath) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isWindows then FilePath -> FilePath -> FilePath -> FilePath
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [a] -> [a]
replace "\r\n" "\n" else FilePath -> FilePath
forall a. a -> a
id) (FilePath -> FilePath)
-> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BS.unpack
                            DestBytes x :: Buffer ByteString
x -> Buffer ByteString -> ByteString -> IO ()
forall a. Buffer a -> a -> IO ()
addBuffer Buffer ByteString
x
                        IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            ByteString
src <- Handle -> Int -> IO ByteString
bsHGetSome Handle
h 4096
                            ((ByteString -> IO ()) -> IO ()) -> [ByteString -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
src) [ByteString -> IO ()]
dest
                            IO Bool -> IO Bool
forall (m :: * -> *). Functor m => m Bool -> m Bool
notM (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsEOF Handle
h
                     else if Bool
isTied then do
                        [FilePath -> IO ()]
dest <- [FilePath -> IO ()] -> IO [FilePath -> IO ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath -> IO ()] -> IO [FilePath -> IO ()])
-> [FilePath -> IO ()] -> IO [FilePath -> IO ()]
forall a b. (a -> b) -> a -> b
$ [Destination]
-> (Destination -> FilePath -> IO ()) -> [FilePath -> IO ()]
forall a b. [a] -> (a -> b) -> [b]
for [Destination]
dest ((Destination -> FilePath -> IO ()) -> [FilePath -> IO ()])
-> (Destination -> FilePath -> IO ()) -> [FilePath -> IO ()]
forall a b. (a -> b) -> a -> b
$ \d :: Destination
d -> case Destination
d of
                            DestEcho -> Handle -> FilePath -> IO ()
hPutStrLn Handle
hh
                            DestFile x :: FilePath
x -> Handle -> FilePath -> IO ()
hPutStrLn (FilePath -> Handle
outHandle FilePath
x)
                            DestString x :: Buffer FilePath
x -> Buffer FilePath -> FilePath -> IO ()
forall a. Buffer a -> a -> IO ()
addBuffer Buffer FilePath
x (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n")
                        IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
                            IO Bool -> IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Handle -> IO Bool
hIsEOF Handle
h) (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
                                FilePath
src <- Handle -> IO FilePath
hGetLine Handle
h
                                ((FilePath -> IO ()) -> IO ()) -> [FilePath -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
src) [FilePath -> IO ()]
dest
                                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                     else do
                        FilePath
src <- Handle -> IO FilePath
hGetContents Handle
h
                        IO ()
wait1 <- IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
C.evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ()
forall a. NFData a => a -> ()
rnf FilePath
src
                        [IO ()]
waits <- [Destination] -> (Destination -> IO (IO ())) -> IO [IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Destination]
dest ((Destination -> IO (IO ())) -> IO [IO ()])
-> (Destination -> IO (IO ())) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \d :: Destination
d -> case Destination
d of
                            DestEcho -> IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr Handle
hh FilePath
src
                            DestFile x :: FilePath
x -> IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr (FilePath -> Handle
outHandle FilePath
x) FilePath
src
                            DestString x :: Buffer FilePath
x -> do Buffer FilePath -> FilePath -> IO ()
forall a. Buffer a -> a -> IO ()
addBuffer Buffer FilePath
x FilePath
src; IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
wait1 IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
waits

                Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
inh ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (StdStream, Handle -> IO ()) -> Handle -> IO ()
forall a b. (a, b) -> b
snd ((StdStream, Handle -> IO ()) -> Handle -> IO ())
-> (StdStream, Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn FilePath -> Handle
inHandle [Source]
poStdin
                if Bool
poAsync then
                    (ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle
pid, ExitCode
ExitSuccess)
                 else do
                    [IO ()] -> IO ()
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
                    Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
outh Handle -> IO ()
hClose
                    Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
errh Handle -> IO ()
hClose
                    (ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle
pid, ExitCode
res)


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

-- available in bytestring-0.9.1.10, GHC 7.8 and above
-- implementation copied below
bsHGetSome :: Handle -> Int -> IO BS.ByteString
bsHGetSome :: Handle -> Int -> IO ByteString
bsHGetSome h :: Handle
h i :: Int
i = Int -> (Ptr Word8 -> IO Int) -> IO ByteString
BS.createAndTrim Int
i ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p -> Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufSome Handle
h Ptr Word8
p Int
i

-- 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 :: CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcessCompat cp :: CreateProcess
cp act :: Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a
act = IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ThreadId)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
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
    (\(m_in :: Maybe Handle
m_in, m_out :: Maybe Handle
m_out, m_err :: Maybe Handle
m_err, ph :: 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 (inh :: Maybe Handle
inh, outh :: Maybe Handle
outh, errh :: Maybe Handle
errh, pid :: ProcessHandle
pid) = do
            ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid
            Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
inh ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> (Handle -> IO ()) -> Handle -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
hClose
            Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
outh Handle -> IO ()
hClose
            Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
errh Handle -> IO ()
hClose
            IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid