{-# 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 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. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef [a]
ref (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
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
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
(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
,ProcessOpts -> Bool
poCloseFds :: Bool
,ProcessOpts -> Bool
poGroup :: Bool
}
optimiseBuffers :: ProcessOpts -> IO (ProcessOpts, IO ())
optimiseBuffers :: ProcessOpts -> IO (ProcessOpts, IO ())
optimiseBuffers po :: ProcessOpts
po@ProcessOpts{..} = (ProcessOpts, IO ()) -> IO (ProcessOpts, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure ())
stdStream :: (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream :: (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream _ [DestEcho] _ = 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 _ _ _ = StdStream
CreatePipe
stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn _ [SrcInherit] = (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 (f :: * -> *) a. Applicative f => a -> f a
pure ())
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 (f :: * -> *) a. Applicative f => a -> f a
pure ())
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
$ \case
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)
SrcInherit -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
_ -> IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
withExceptions :: IO () -> IO a -> IO a
withExceptions :: IO () -> IO a -> IO a
withExceptions stop :: IO ()
stop go :: IO a
go = do
Barrier (Either SomeException a)
bar <- IO (Barrier (Either SomeException a))
forall a. IO (Barrier a)
newBarrier
Either SomeException a
v <- ((forall a. IO a -> IO a) -> IO (Either SomeException a))
-> IO (Either SomeException a)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (Either SomeException a))
-> IO (Either SomeException a))
-> ((forall a. IO a -> IO a) -> IO (Either SomeException a))
-> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ \unmask :: forall a. IO a -> IO a
unmask -> do
IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (IO a -> IO a
forall a. IO a -> IO a
unmask IO a
go) ((Either SomeException a -> IO ()) -> IO ThreadId)
-> (Either SomeException a -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Barrier (Either SomeException a) -> Either SomeException a -> IO ()
forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier (Either SomeException a)
bar
IO (Either SomeException a) -> IO (Either SomeException a)
forall a. IO a -> IO a
unmask (Barrier (Either SomeException a) -> IO (Either SomeException a)
forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException a)
bar) IO (Either SomeException a)
-> IO (Either SomeException a) -> IO (Either SomeException a)
forall a b. IO a -> IO b -> IO a
`onException` do
IO () -> IO ThreadId
forkIO IO ()
stop
Barrier (Either SomeException a) -> IO (Either SomeException a)
forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException a)
bar
(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 (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException a
v
withTimeout :: Maybe Double -> IO () -> IO a -> IO a
withTimeout :: Maybe Double -> IO () -> IO a -> IO a
withTimeout Nothing _ 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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure
abort :: Bool -> ProcessHandle -> IO ()
abort :: Bool -> ProcessHandle -> IO ()
abort poGroup :: Bool
poGroup pid :: ProcessHandle
pid = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
poGroup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
pid
Double -> IO ()
sleep 3
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. Partial => 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. Partial => [a] -> [b] -> [(a, b)]
zipExact [FilePath]
files [Handle]
handles
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 = Bool
poGroup, close_fds :: Bool
close_fds = Bool
poCloseFds
,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 (Bool -> ProcessHandle -> IO ()
abort Bool
poGroup ProcessHandle
pid) (IO (ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode)
forall a b. (a -> b) -> a -> b
$ IO ()
-> IO (ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode)
forall a. IO () -> IO a -> IO a
withExceptions (Bool -> ProcessHandle -> IO ()
abort Bool
poGroup 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
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 = (Destination -> Bool) -> [Destination] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Destination -> Bool
isDestBytes [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
isDestString [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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
_ -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString -> IO ()] -> IO [ByteString -> IO ()])
-> [ByteString -> IO ()] -> IO [ByteString -> IO ()]
forall a b. (a -> b) -> a -> b
$ ((Destination -> ByteString -> IO ())
-> [Destination] -> [ByteString -> IO ()])
-> [Destination]
-> (Destination -> ByteString -> IO ())
-> [ByteString -> IO ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Destination -> ByteString -> IO ())
-> [Destination] -> [ByteString -> IO ()]
forall a b. (a -> b) -> [a] -> [b]
map [Destination]
dest ((Destination -> ByteString -> IO ()) -> [ByteString -> IO ()])
-> (Destination -> ByteString -> IO ()) -> [ByteString -> IO ()]
forall a b. (a -> b) -> a -> b
$ \case
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. (Partial, 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
BS.hGetSome 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 (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath -> IO ()] -> IO [FilePath -> IO ()])
-> [FilePath -> IO ()] -> IO [FilePath -> IO ()]
forall a b. (a -> b) -> a -> b
$ ((Destination -> FilePath -> IO ())
-> [Destination] -> [FilePath -> IO ()])
-> [Destination]
-> (Destination -> FilePath -> IO ())
-> [FilePath -> IO ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Destination -> FilePath -> IO ())
-> [Destination] -> [FilePath -> IO ()]
forall a b. (a -> b) -> [a] -> [b]
map [Destination]
dest ((Destination -> FilePath -> IO ()) -> [FilePath -> IO ()])
-> (Destination -> FilePath -> IO ()) -> [FilePath -> IO ()]
forall a b. (a -> b) -> a -> b
$ \case
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")
DestBytes{} -> SomeException -> FilePath -> IO ()
forall a. SomeException -> a
throwImpure (SomeException -> FilePath -> IO ())
-> SomeException -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Partial => FilePath -> SomeException
FilePath -> SomeException
errorInternal "Not reachable due to isBinary condition"
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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
$ \case
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 (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
DestBytes{} -> SomeException -> IO (IO ())
forall a. SomeException -> a
throwImpure (SomeException -> IO (IO ())) -> SomeException -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Partial => FilePath -> SomeException
FilePath -> SomeException
errorInternal "Not reachable due to isBinary condition"
IO () -> IO (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 (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 :: 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