{-# 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 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 Unique
x IORef [a]
_) (Buffer Unique
y IORef [a]
_) = 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 Unique
_ IORef [a]
ref) 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 Unique
_ 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
    | 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 Destination
_ = Bool
False
isDestBytes :: Destination -> Bool
isDestBytes  DestBytes{}  = Bool
True; isDestBytes  Destination
_ = 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
    }


---------------------------------------------------------------------
-- 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 FilePath
Maybe [(FilePath, FilePath)]
CmdSpec
poGroup :: Bool
poCloseFds :: Bool
poAsync :: Bool
poStderr :: [Destination]
poStdout :: [Destination]
poStdin :: [Source]
poTimeout :: Maybe Double
poEnv :: Maybe [(FilePath, FilePath)]
poCwd :: Maybe FilePath
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 [(FilePath, FilePath)]
poCwd :: ProcessOpts -> Maybe FilePath
poCommand :: ProcessOpts -> CmdSpec
..} = (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 FilePath -> Handle
_ [Destination
DestEcho] [Destination]
_ = StdStream
Inherit
stdStream FilePath -> Handle
file [DestFile FilePath
x] [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 FilePath -> Handle
_ [Destination]
_ [Destination]
_ = StdStream
CreatePipe


stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn FilePath -> Handle
_ [Source
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 FilePath -> Handle
file [SrcFile 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 FilePath -> Handle
file [Source]
src = (,) StdStream
CreatePipe ((Handle -> IO ()) -> (StdStream, Handle -> IO ()))
-> (Handle -> IO ()) -> (StdStream, Handle -> IO ())
forall a b. (a -> b) -> a -> b
$ \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 FilePath
x -> Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
x
        SrcBytes ByteString
x -> Handle -> ByteString -> IO ()
LBS.hPutStr Handle
h ByteString
x
        SrcFile 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)
        Source
SrcInherit -> () -> IO ()
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 = (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
$ \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 Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    IOException
_ -> 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 IO ()
stop 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
$ \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 Maybe Double
Nothing IO ()
_ IO a
go = IO a
go
withTimeout (Just Double
s) IO ()
stop 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 FilePath
x) = FilePath -> CreateProcess
shell FilePath
x
cmdSpec (RawCommand FilePath
x [FilePath]
xs) = FilePath -> [FilePath] -> CreateProcess
proc FilePath
x [FilePath]
xs



forkWait :: IO a -> IO (IO a)
forkWait :: IO a -> IO (IO a)
forkWait 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
$ \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 Bool
poGroup 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 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 :: IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a
withFiles IOMode
mode [FilePath]
files (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
$ \[Handle]
handles ->
    (FilePath -> Handle) -> IO a
act ((FilePath -> Handle) -> IO a) -> (FilePath -> Handle) -> IO a
forall a b. (a -> b) -> a -> b
$ \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


-- 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 FilePath
Maybe [(FilePath, FilePath)]
CmdSpec
poGroup :: Bool
poCloseFds :: Bool
poAsync :: Bool
poStderr :: [Destination]
poStdout :: [Destination]
poStdin :: [Source]
poTimeout :: Maybe Double
poEnv :: Maybe [(FilePath, FilePath)]
poCwd :: Maybe FilePath
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 [(FilePath, FilePath)]
poCwd :: ProcessOpts -> Maybe FilePath
poCommand :: ProcessOpts -> CmdSpec
..}, 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 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 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
$ \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
$ \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
$ \Maybe Handle
inh Maybe Handle
outh Maybe Handle
errh 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 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 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
$ \(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 [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
== Int
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 ()
                            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<- [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
                            Destination
DestEcho -> Handle -> ByteString -> IO ()
BS.hPut Handle
hh
                            DestFile FilePath
x -> Handle -> ByteString -> IO ()
BS.hPut (FilePath -> Handle
outHandle FilePath
x)
                            DestString 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 FilePath
"\r\n" FilePath
"\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 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 Int
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
                            Destination
DestEcho -> Handle -> FilePath -> IO ()
hPutStrLn Handle
hh
                            DestFile FilePath
x -> Handle -> FilePath -> IO ()
hPutStrLn (FilePath -> Handle
outHandle FilePath
x)
                            DestString 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]
++ FilePath
"\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 FilePath
"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
                            Destination
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 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 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 FilePath
"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)


---------------------------------------------------------------------
-- 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 :: 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 = 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
    (\(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
            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