{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
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(..))
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
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
}
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 ()
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
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
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
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)
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