{-# LANGUAGE RecordWildCards #-}
module General.Process(
Buffer, newBuffer, readBuffer,
process, ProcessOpts(..), Source(..), Destination(..)
) where
import Control.Applicative
import Control.Concurrent
import Control.DeepSeq
import Control.Exception.Extra as C
import Control.Monad.Extra
import Data.List.Extra
import Data.Maybe
import Foreign.C.Error
import System.Exit
import System.IO.Extra
import System.Info.Extra
import System.Process
import System.Time.Extra
import Data.Unique
import Data.IORef
import qualified Data.ByteString.Internal as BS(createAndTrim)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import General.Extra
import Prelude
import GHC.IO.Exception (IOErrorType(..), IOException(..))
data Buffer a = Buffer Unique (IORef [a])
instance Eq (Buffer a) where Buffer x :: Unique
x _ == :: Buffer a -> Buffer a -> Bool
== Buffer y :: Unique
y _ = Unique
x Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
y
instance Ord (Buffer a) where compare :: Buffer a -> Buffer a -> Ordering
compare (Buffer x :: Unique
x _) (Buffer y :: Unique
y _) = Unique -> Unique -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Unique
x Unique
y
newBuffer :: IO (Buffer a)
newBuffer :: IO (Buffer a)
newBuffer = (Unique -> IORef [a] -> Buffer a)
-> IO Unique -> IO (IORef [a]) -> IO (Buffer a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Unique -> IORef [a] -> Buffer a
forall a. Unique -> IORef [a] -> Buffer a
Buffer IO Unique
newUnique ([a] -> IO (IORef [a])
forall a. a -> IO (IORef a)
newIORef [])
addBuffer :: Buffer a -> a -> IO ()
addBuffer :: Buffer a -> a -> IO ()
addBuffer (Buffer _ ref :: IORef [a]
ref) x :: a
x = IORef [a] -> ([a] -> ([a], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [a]
ref (([a] -> ([a], ())) -> IO ()) -> ([a] -> ([a], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \xs :: [a]
xs -> (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs, ())
readBuffer :: Buffer a -> IO [a]
readBuffer :: Buffer a -> IO [a]
readBuffer (Buffer _ ref :: IORef [a]
ref) = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> IO [a] -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [a] -> IO [a]
forall a. IORef a -> IO a
readIORef IORef [a]
ref
data Source
= SrcFile FilePath
| SrcString String
| SrcBytes LBS.ByteString
data Destination
= DestEcho
| DestFile FilePath
| DestString (Buffer String)
| DestBytes (Buffer BS.ByteString)
deriving (Destination -> Destination -> Bool
(Destination -> Destination -> Bool)
-> (Destination -> Destination -> Bool) -> Eq Destination
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Destination -> Destination -> Bool
$c/= :: Destination -> Destination -> Bool
== :: Destination -> Destination -> Bool
$c== :: Destination -> Destination -> Bool
Eq,Eq Destination
Eq Destination =>
(Destination -> Destination -> Ordering)
-> (Destination -> Destination -> Bool)
-> (Destination -> Destination -> Bool)
-> (Destination -> Destination -> Bool)
-> (Destination -> Destination -> Bool)
-> (Destination -> Destination -> Destination)
-> (Destination -> Destination -> Destination)
-> Ord Destination
Destination -> Destination -> Bool
Destination -> Destination -> Ordering
Destination -> Destination -> Destination
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Destination -> Destination -> Destination
$cmin :: Destination -> Destination -> Destination
max :: Destination -> Destination -> Destination
$cmax :: Destination -> Destination -> Destination
>= :: Destination -> Destination -> Bool
$c>= :: Destination -> Destination -> Bool
> :: Destination -> Destination -> Bool
$c> :: Destination -> Destination -> Bool
<= :: Destination -> Destination -> Bool
$c<= :: Destination -> Destination -> Bool
< :: Destination -> Destination -> Bool
$c< :: Destination -> Destination -> Bool
compare :: Destination -> Destination -> Ordering
$ccompare :: Destination -> Destination -> Ordering
$cp1Ord :: Eq Destination
Ord)
isDestString :: Destination -> Bool
isDestString DestString{} = Bool
True; isDestString _ = Bool
False
isDestBytes :: Destination -> Bool
isDestBytes DestBytes{} = Bool
True; isDestBytes _ = Bool
False
data ProcessOpts = ProcessOpts
{ProcessOpts -> CmdSpec
poCommand :: CmdSpec
,ProcessOpts -> Maybe FilePath
poCwd :: Maybe FilePath
,ProcessOpts -> Maybe [(FilePath, FilePath)]
poEnv :: Maybe [(String, String)]
,ProcessOpts -> Maybe Double
poTimeout :: Maybe Double
,ProcessOpts -> [Source]
poStdin :: [Source]
,ProcessOpts -> [Destination]
poStdout :: [Destination]
,ProcessOpts -> [Destination]
poStderr :: [Destination]
,ProcessOpts -> Bool
poAsync :: Bool
}
optimiseBuffers :: ProcessOpts -> IO (ProcessOpts, IO ())
optimiseBuffers :: ProcessOpts -> IO (ProcessOpts, IO ())
optimiseBuffers po :: ProcessOpts
po@ProcessOpts{..} = (ProcessOpts, IO ()) -> IO (ProcessOpts, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessOpts
po{poStdout :: [Destination]
poStdout = [Destination] -> [Destination]
forall a. Ord a => [a] -> [a]
nubOrd [Destination]
poStdout, poStderr :: [Destination]
poStderr = [Destination] -> [Destination]
forall a. Ord a => [a] -> [a]
nubOrd [Destination]
poStderr}, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
stdStream :: (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream :: (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream file :: FilePath -> Handle
file [DestEcho] other :: [Destination]
other = StdStream
Inherit
stdStream file :: FilePath -> Handle
file [DestFile x :: FilePath
x] other :: [Destination]
other | [Destination]
other [Destination] -> [Destination] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath -> Destination
DestFile FilePath
x] Bool -> Bool -> Bool
|| FilePath -> Destination
DestFile FilePath
x Destination -> [Destination] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Destination]
other = Handle -> StdStream
UseHandle (Handle -> StdStream) -> Handle -> StdStream
forall a b. (a -> b) -> a -> b
$ FilePath -> Handle
file FilePath
x
stdStream file :: FilePath -> Handle
file _ _ = StdStream
CreatePipe
stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn file :: FilePath -> Handle
file [] = (StdStream
Inherit, IO () -> Handle -> IO ()
forall a b. a -> b -> a
const (IO () -> Handle -> IO ()) -> IO () -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
stdIn file :: FilePath -> Handle
file [SrcFile x :: FilePath
x] = (Handle -> StdStream
UseHandle (Handle -> StdStream) -> Handle -> StdStream
forall a b. (a -> b) -> a -> b
$ FilePath -> Handle
file FilePath
x, IO () -> Handle -> IO ()
forall a b. a -> b -> a
const (IO () -> Handle -> IO ()) -> IO () -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
stdIn file :: FilePath -> Handle
file src :: [Source]
src = (,) StdStream
CreatePipe ((Handle -> IO ()) -> (StdStream, Handle -> IO ()))
-> (Handle -> IO ()) -> (StdStream, Handle -> IO ())
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Source] -> (Source -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Source]
src ((Source -> IO ()) -> IO ()) -> (Source -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \x :: Source
x -> case Source
x of
SrcString x :: FilePath
x -> Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
x
SrcBytes x :: ByteString
x -> Handle -> ByteString -> IO ()
LBS.hPutStr Handle
h ByteString
x
SrcFile x :: FilePath
x -> Handle -> ByteString -> IO ()
LBS.hPutStr Handle
h (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO ByteString
LBS.hGetContents (FilePath -> Handle
file FilePath
x)
Handle -> IO ()
hClose Handle
h
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = (IOException -> IO ()) -> IO () -> IO ()
forall a. (IOException -> IO a) -> IO a -> IO a
handleIO ((IOException -> IO ()) -> IO () -> IO ())
-> (IOException -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \e :: IOException
e -> case IOException
e of
IOError {ioe_type :: IOException -> IOErrorType
ioe_type=IOErrorType
ResourceVanished, ioe_errno :: IOException -> Maybe CInt
ioe_errno=Just ioe :: CInt
ioe} | CInt -> Errno
Errno CInt
ioe Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
withTimeout :: Maybe Double -> IO () -> IO a -> IO a
withTimeout :: Maybe Double -> IO () -> IO a -> IO a
withTimeout Nothing stop :: IO ()
stop go :: IO a
go = IO a
go
withTimeout (Just s :: Double
s) stop :: IO ()
stop go :: IO a
go = IO ThreadId -> (ThreadId -> IO ()) -> (ThreadId -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Double -> IO ()
sleep Double
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
stop) ThreadId -> IO ()
killThread ((ThreadId -> IO a) -> IO a) -> (ThreadId -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> ThreadId -> IO a
forall a b. a -> b -> a
const IO a
go
cmdSpec :: CmdSpec -> CreateProcess
cmdSpec :: CmdSpec -> CreateProcess
cmdSpec (ShellCommand x :: FilePath
x) = FilePath -> CreateProcess
shell FilePath
x
cmdSpec (RawCommand x :: FilePath
x xs :: [FilePath]
xs) = FilePath -> [FilePath] -> CreateProcess
proc FilePath
x [FilePath]
xs
forkWait :: IO a -> IO (IO a)
forkWait :: IO a -> IO (IO a)
forkWait a :: IO a
a = do
MVar (Either SomeException a)
res <- IO (MVar (Either SomeException a))
forall a. IO (MVar a)
newEmptyMVar
ThreadId
_ <- ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \restore :: forall a. IO a -> IO a
restore -> IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall a. IO a -> IO (Either SomeException a)
try_ (IO a -> IO a
forall a. IO a -> IO a
restore IO a
a) IO (Either SomeException a)
-> (Either SomeException a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException a) -> Either SomeException a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException a)
res
IO a -> IO (IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a -> IO (IO a)) -> IO a -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ MVar (Either SomeException a) -> IO (Either SomeException a)
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException a)
res IO (Either SomeException a)
-> (Either SomeException a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO a)
-> (a -> IO a) -> Either SomeException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
abort :: ProcessHandle -> IO ()
abort :: ProcessHandle -> IO ()
abort pid :: ProcessHandle
pid = do
ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
pid
Double -> IO ()
sleep 5
ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid
withFiles :: IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a
withFiles :: IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a
withFiles mode :: IOMode
mode files :: [FilePath]
files act :: (FilePath -> Handle) -> IO a
act = [(Handle -> IO a) -> IO a] -> ([Handle] -> IO a) -> IO a
forall a r. [(a -> r) -> r] -> ([a] -> r) -> r
withs ((FilePath -> (Handle -> IO a) -> IO a)
-> [FilePath] -> [(Handle -> IO a) -> IO a]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> IOMode -> (Handle -> IO a) -> IO a
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
`withFile` IOMode
mode) [FilePath]
files) (([Handle] -> IO a) -> IO a) -> ([Handle] -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \handles :: [Handle]
handles ->
(FilePath -> Handle) -> IO a
act ((FilePath -> Handle) -> IO a) -> (FilePath -> Handle) -> IO a
forall a b. (a -> b) -> a -> b
$ \x :: FilePath
x -> Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Handle -> Handle) -> Maybe Handle -> Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> [(FilePath, Handle)] -> Maybe Handle
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
x ([(FilePath, Handle)] -> Maybe Handle)
-> [(FilePath, Handle)] -> Maybe Handle
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [Handle] -> [(FilePath, Handle)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
files [Handle]
handles
process :: ProcessOpts -> IO (ProcessHandle, ExitCode)
process :: ProcessOpts -> IO (ProcessHandle, ExitCode)
process po :: ProcessOpts
po = do
(ProcessOpts{..}, flushBuffers :: IO ()
flushBuffers) <- ProcessOpts -> IO (ProcessOpts, IO ())
optimiseBuffers ProcessOpts
po
let outFiles :: [FilePath]
outFiles = [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
nubOrd [FilePath
x | DestFile x :: FilePath
x <- [Destination]
poStdout [Destination] -> [Destination] -> [Destination]
forall a. [a] -> [a] -> [a]
++ [Destination]
poStderr]
let inFiles :: [FilePath]
inFiles = [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
nubOrd [FilePath
x | SrcFile x :: FilePath
x <- [Source]
poStdin]
IOMode
-> [FilePath]
-> ((FilePath -> Handle) -> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode)
forall a.
IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a
withFiles IOMode
WriteMode [FilePath]
outFiles (((FilePath -> Handle) -> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode))
-> ((FilePath -> Handle) -> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode)
forall a b. (a -> b) -> a -> b
$ \outHandle :: FilePath -> Handle
outHandle -> IOMode
-> [FilePath]
-> ((FilePath -> Handle) -> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode)
forall a.
IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a
withFiles IOMode
ReadMode [FilePath]
inFiles (((FilePath -> Handle) -> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode))
-> ((FilePath -> Handle) -> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode)
forall a b. (a -> b) -> a -> b
$ \inHandle :: FilePath -> Handle
inHandle -> do
let cp :: CreateProcess
cp = (CmdSpec -> CreateProcess
cmdSpec CmdSpec
poCommand){cwd :: Maybe FilePath
cwd = Maybe FilePath
poCwd, env :: Maybe [(FilePath, FilePath)]
env = Maybe [(FilePath, FilePath)]
poEnv, create_group :: Bool
create_group = Maybe Double -> Bool
forall a. Maybe a -> Bool
isJust Maybe Double
poTimeout, close_fds :: Bool
close_fds = Bool
True
,std_in :: StdStream
std_in = (StdStream, Handle -> IO ()) -> StdStream
forall a b. (a, b) -> a
fst ((StdStream, Handle -> IO ()) -> StdStream)
-> (StdStream, Handle -> IO ()) -> StdStream
forall a b. (a -> b) -> a -> b
$ (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn FilePath -> Handle
inHandle [Source]
poStdin
,std_out :: StdStream
std_out = (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream FilePath -> Handle
outHandle [Destination]
poStdout [Destination]
poStderr, std_err :: StdStream
std_err = (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream
stdStream FilePath -> Handle
outHandle [Destination]
poStderr [Destination]
poStdout}
CreateProcess
-> (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode)
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcessCompat CreateProcess
cp ((Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode))
-> (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode)
forall a b. (a -> b) -> a -> b
$ \inh :: Maybe Handle
inh outh :: Maybe Handle
outh errh :: Maybe Handle
errh pid :: ProcessHandle
pid ->
Maybe Double
-> IO ()
-> IO (ProcessHandle, ExitCode)
-> IO (ProcessHandle, ExitCode)
forall a. Maybe Double -> IO () -> IO a -> IO a
withTimeout Maybe Double
poTimeout (ProcessHandle -> IO ()
abort ProcessHandle
pid) (IO (ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode))
-> IO (ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode)
forall a b. (a -> b) -> a -> b
$ do
let streams :: [(Handle, Handle, [Destination])]
streams = [(Handle
outh, Handle
stdout, [Destination]
poStdout) | Just outh :: Handle
outh <- [Maybe Handle
outh], StdStream
CreatePipe <- [CreateProcess -> StdStream
std_out CreateProcess
cp]] [(Handle, Handle, [Destination])]
-> [(Handle, Handle, [Destination])]
-> [(Handle, Handle, [Destination])]
forall a. [a] -> [a] -> [a]
++
[(Handle
errh, Handle
stderr, [Destination]
poStderr) | Just errh :: Handle
errh <- [Maybe Handle
errh], StdStream
CreatePipe <- [CreateProcess -> StdStream
std_err CreateProcess
cp]]
[IO ()]
wait <- [(Handle, Handle, [Destination])]
-> ((Handle, Handle, [Destination]) -> IO (IO ())) -> IO [IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Handle, Handle, [Destination])]
streams (((Handle, Handle, [Destination]) -> IO (IO ())) -> IO [IO ()])
-> ((Handle, Handle, [Destination]) -> IO (IO ())) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \(h :: Handle
h, hh :: Handle
hh, dest :: [Destination]
dest) -> do
let isTied :: Bool
isTied = Bool -> Bool
not ([Destination]
poStdout [Destination] -> [Destination] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [Destination]
poStderr) Bool -> Bool -> Bool
&& [(Handle, Handle, [Destination])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Handle, Handle, [Destination])]
streams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2
let isBinary :: Bool
isBinary = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Destination -> Bool) -> [Destination] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Destination -> Bool
isDestString [Destination]
dest Bool -> Bool -> Bool
&& Bool -> Bool
not ((Destination -> Bool) -> [Destination] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Destination -> Bool
isDestBytes [Destination]
dest)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTied (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Destination
DestEcho Destination -> [Destination] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Destination]
dest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
BufferMode
buf <- Handle -> IO BufferMode
hGetBuffering Handle
hh
case BufferMode
buf of
BlockBuffering{} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
buf
if Bool
isBinary then do
Handle -> Bool -> IO ()
hSetBinaryMode Handle
h Bool
True
[ByteString -> IO ()]
dest <- [ByteString -> IO ()] -> IO [ByteString -> IO ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString -> IO ()] -> IO [ByteString -> IO ()])
-> [ByteString -> IO ()] -> IO [ByteString -> IO ()]
forall a b. (a -> b) -> a -> b
$ [Destination]
-> (Destination -> ByteString -> IO ()) -> [ByteString -> IO ()]
forall a b. [a] -> (a -> b) -> [b]
for [Destination]
dest ((Destination -> ByteString -> IO ()) -> [ByteString -> IO ()])
-> (Destination -> ByteString -> IO ()) -> [ByteString -> IO ()]
forall a b. (a -> b) -> a -> b
$ \d :: Destination
d -> case Destination
d of
DestEcho -> Handle -> ByteString -> IO ()
BS.hPut Handle
hh
DestFile x :: FilePath
x -> Handle -> ByteString -> IO ()
BS.hPut (FilePath -> Handle
outHandle FilePath
x)
DestString x :: Buffer FilePath
x -> Buffer FilePath -> FilePath -> IO ()
forall a. Buffer a -> a -> IO ()
addBuffer Buffer FilePath
x (FilePath -> IO ())
-> (ByteString -> FilePath) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isWindows then FilePath -> FilePath -> FilePath -> FilePath
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [a] -> [a]
replace "\r\n" "\n" else FilePath -> FilePath
forall a. a -> a
id) (FilePath -> FilePath)
-> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BS.unpack
DestBytes x :: Buffer ByteString
x -> Buffer ByteString -> ByteString -> IO ()
forall a. Buffer a -> a -> IO ()
addBuffer Buffer ByteString
x
IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
src <- Handle -> Int -> IO ByteString
bsHGetSome Handle
h 4096
((ByteString -> IO ()) -> IO ()) -> [ByteString -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
src) [ByteString -> IO ()]
dest
IO Bool -> IO Bool
forall (m :: * -> *). Functor m => m Bool -> m Bool
notM (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsEOF Handle
h
else if Bool
isTied then do
[FilePath -> IO ()]
dest <- [FilePath -> IO ()] -> IO [FilePath -> IO ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath -> IO ()] -> IO [FilePath -> IO ()])
-> [FilePath -> IO ()] -> IO [FilePath -> IO ()]
forall a b. (a -> b) -> a -> b
$ [Destination]
-> (Destination -> FilePath -> IO ()) -> [FilePath -> IO ()]
forall a b. [a] -> (a -> b) -> [b]
for [Destination]
dest ((Destination -> FilePath -> IO ()) -> [FilePath -> IO ()])
-> (Destination -> FilePath -> IO ()) -> [FilePath -> IO ()]
forall a b. (a -> b) -> a -> b
$ \d :: Destination
d -> case Destination
d of
DestEcho -> Handle -> FilePath -> IO ()
hPutStrLn Handle
hh
DestFile x :: FilePath
x -> Handle -> FilePath -> IO ()
hPutStrLn (FilePath -> Handle
outHandle FilePath
x)
DestString x :: Buffer FilePath
x -> Buffer FilePath -> FilePath -> IO ()
forall a. Buffer a -> a -> IO ()
addBuffer Buffer FilePath
x (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n")
IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
IO Bool -> IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Handle -> IO Bool
hIsEOF Handle
h) (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
FilePath
src <- Handle -> IO FilePath
hGetLine Handle
h
((FilePath -> IO ()) -> IO ()) -> [FilePath -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
src) [FilePath -> IO ()]
dest
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
FilePath
src <- Handle -> IO FilePath
hGetContents Handle
h
IO ()
wait1 <- IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
C.evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ()
forall a. NFData a => a -> ()
rnf FilePath
src
[IO ()]
waits <- [Destination] -> (Destination -> IO (IO ())) -> IO [IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Destination]
dest ((Destination -> IO (IO ())) -> IO [IO ()])
-> (Destination -> IO (IO ())) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \d :: Destination
d -> case Destination
d of
DestEcho -> IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr Handle
hh FilePath
src
DestFile x :: FilePath
x -> IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
forkWait (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr (FilePath -> Handle
outHandle FilePath
x) FilePath
src
DestString x :: Buffer FilePath
x -> do Buffer FilePath -> FilePath -> IO ()
forall a. Buffer a -> a -> IO ()
addBuffer Buffer FilePath
x FilePath
src; IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
wait1 IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
waits
Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
inh ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (StdStream, Handle -> IO ()) -> Handle -> IO ()
forall a b. (a, b) -> b
snd ((StdStream, Handle -> IO ()) -> Handle -> IO ())
-> (StdStream, Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())
stdIn FilePath -> Handle
inHandle [Source]
poStdin
if Bool
poAsync then
(ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle
pid, ExitCode
ExitSuccess)
else do
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
wait
IO ()
flushBuffers
ExitCode
res <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
outh Handle -> IO ()
hClose
Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
errh Handle -> IO ()
hClose
(ProcessHandle, ExitCode) -> IO (ProcessHandle, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle
pid, ExitCode
res)
bsHGetSome :: Handle -> Int -> IO BS.ByteString
bsHGetSome :: Handle -> Int -> IO ByteString
bsHGetSome h :: Handle
h i :: Int
i = Int -> (Ptr Word8 -> IO Int) -> IO ByteString
BS.createAndTrim Int
i ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p -> Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufSome Handle
h Ptr Word8
p Int
i
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