-- | This module wraps over the API in @Procex.Core@ in a user-friendly way.
module Procex.Process (makeCmd, CmdException (..), run, pipeArgIn, pipeArgOut, pipeHIn, pipeHOut, pipeIn, pipeOut, pipeArgHIn, pipeArgHOut, captureFdsAsHandles, waitCmd) where

import Control.Concurrent.Async
import Control.Exception.Base
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import Data.Char (ord)
import Data.Function
import Data.Tuple
import Procex.Core
import System.Exit (ExitCode (..))
import System.IO (Handle)
import System.Posix.ByteString

findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM :: (a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
f (a
x : [a]
xs) =
  a -> m Bool
f a
x m Bool -> (Bool -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> case Bool
b of
    Bool
True -> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
    Bool
False -> (a -> m Bool) -> [a] -> m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
f [a]
xs
findM a -> m Bool
_ [] = Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

-- | A version of 'Procex.Core.makeCmd'' that resolves the path
-- according to PATH and passes through stdin, stdout and stderr (unless overrided).
makeCmd :: ByteString -> Cmd
makeCmd :: ByteString -> Cmd
makeCmd ByteString
path = IO Cmd -> Cmd
unIOCmd (IO Cmd -> Cmd) -> IO Cmd -> Cmd
forall a b. (a -> b) -> a -> b
$ do
  ByteString
fullpath :: ByteString <-
    if (Word8 -> Bool) -> ByteString -> Bool
B.any ((Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Word8) -> Char -> Word8
forall a b. (a -> b) -> a -> b
$ Char
'/') Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==) ByteString
path
      then ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
path
      else do
        ByteString
pathvar <- ByteString -> ByteString
B.fromStrict (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ByteString -> IO ByteString
getEnvDefault ByteString
"PATH" ByteString
""
        Maybe ByteString
fullpath <- (ByteString -> IO Bool) -> [ByteString] -> IO (Maybe ByteString)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM ByteString -> IO Bool
fileExist ([ByteString] -> IO (Maybe ByteString))
-> (ByteString -> [ByteString])
-> ByteString
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ByteString
x -> ByteString -> ByteString
B.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
path) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [Item [ByteString]
"/", Item [ByteString]
"."]) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
B.split (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
':') (ByteString -> IO (Maybe ByteString))
-> ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
pathvar
        case Maybe ByteString
fullpath of
          Just ByteString
p -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.fromStrict (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
p
          Maybe ByteString
Nothing -> IOError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO ByteString) -> IOError -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (ByteString -> String
forall a. Show a => a -> String
show ByteString
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not exist")
  Cmd -> IO Cmd
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cmd -> IO Cmd) -> Cmd -> IO Cmd
forall a b. (a -> b) -> a -> b
$ ByteString -> Cmd
makeCmd' ByteString
fullpath Cmd -> (Cmd -> Cmd) -> Cmd
forall a b. a -> (a -> b) -> b
& ByteString -> Cmd -> Cmd
passArg ByteString
path Cmd -> (Cmd -> Cmd) -> Cmd
forall a b. a -> (a -> b) -> b
& (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
0, Fd
0) Cmd -> (Cmd -> Cmd) -> Cmd
forall a b. a -> (a -> b) -> b
& (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
1, Fd
1) Cmd -> (Cmd -> Cmd) -> Cmd
forall a b. a -> (a -> b) -> b
& (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
2, Fd
2)

-- | Thrown when the return code of a command isn't 0.
newtype CmdException = CmdException ProcessStatus deriving (Int -> CmdException -> String -> String
[CmdException] -> String -> String
CmdException -> String
(Int -> CmdException -> String -> String)
-> (CmdException -> String)
-> ([CmdException] -> String -> String)
-> Show CmdException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CmdException] -> String -> String
$cshowList :: [CmdException] -> String -> String
show :: CmdException -> String
$cshow :: CmdException -> String
showsPrec :: Int -> CmdException -> String -> String
$cshowsPrec :: Int -> CmdException -> String -> String
Show)

instance Exception CmdException where
  displayException :: CmdException -> String
displayException (CmdException ProcessStatus
status) = String
"Command failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ProcessStatus -> String
forall a. Show a => a -> String
show ProcessStatus
status

-- | Wait on a process status and raise 'CmdException' if it is a non-zero exit code.
waitCmd :: Async ProcessStatus -> IO ()
waitCmd :: Async ProcessStatus -> IO ()
waitCmd Async ProcessStatus
status =
  Async ProcessStatus -> IO ProcessStatus
forall a. Async a -> IO a
wait Async ProcessStatus
status IO ProcessStatus -> (ProcessStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Exited ExitCode
ExitSuccess -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ProcessStatus
e -> CmdException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ProcessStatus -> CmdException
CmdException ProcessStatus
e)

-- | Runs a command synchronously. See also 'Procex.Core.run''.
-- 'CmdException' will be thrown if the command fails.
run :: Cmd -> IO ()
run :: Cmd -> IO ()
run Cmd
cmd =
  Cmd -> IO (Async ProcessStatus)
run' Cmd
cmd IO (Async ProcessStatus) -> (Async ProcessStatus -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Async ProcessStatus -> IO ()
waitCmd

pipeFd' :: Bool -> Fd -> Cmd -> (Fd -> Cmd) -> Cmd
pipeFd' :: Bool -> Fd -> Cmd -> (Fd -> Cmd) -> Cmd
pipeFd' Bool
dir Fd
fd1 Cmd
cmd1 Fd -> Cmd
cmd2 = IO Cmd -> Cmd
unIOCmd (IO Cmd -> Cmd) -> IO Cmd -> Cmd
forall a b. (a -> b) -> a -> b
$ do
  IO (Fd, Fd)
-> ((Fd, Fd) -> IO ()) -> ((Fd, Fd) -> IO Cmd) -> IO Cmd
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError ((if Bool
dir then (Fd, Fd) -> (Fd, Fd)
forall a b. (a, b) -> (b, a)
swap else (Fd, Fd) -> (Fd, Fd)
forall a. a -> a
id) ((Fd, Fd) -> (Fd, Fd)) -> IO (Fd, Fd) -> IO (Fd, Fd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Fd, Fd)
createPipe) (\(Fd
x, Fd
y) -> Fd -> IO ()
closeFd Fd
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
y) (((Fd, Fd) -> IO Cmd) -> IO Cmd) -> ((Fd, Fd) -> IO Cmd) -> IO Cmd
forall a b. (a -> b) -> a -> b
$ \(Fd
x, Fd
y) -> do
    IO (Async ProcessStatus)
-> (Async ProcessStatus -> IO (Async ()))
-> (Async ProcessStatus -> IO Cmd)
-> IO Cmd
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (Cmd -> IO (Async ProcessStatus)
run' (Cmd -> IO (Async ProcessStatus))
-> Cmd -> IO (Async ProcessStatus)
forall a b. (a -> b) -> a -> b
$ Cmd
cmd1 Cmd -> (Cmd -> Cmd) -> Cmd
forall a b. a -> (a -> b) -> b
& (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
fd1, Fd
x)) (IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ()))
-> (Async ProcessStatus -> IO ())
-> Async ProcessStatus
-> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async ProcessStatus -> IO ()
forall a. Async a -> IO ()
cancel) ((Async ProcessStatus -> IO Cmd) -> IO Cmd)
-> (Async ProcessStatus -> IO Cmd) -> IO Cmd
forall a b. (a -> b) -> a -> b
$ \Async ProcessStatus
status1 -> do
      Cmd -> IO Cmd
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cmd -> IO Cmd) -> Cmd -> IO Cmd
forall a b. (a -> b) -> a -> b
$
        ((Either SomeException (Async ProcessStatus) -> IO ())
 -> Cmd -> Cmd)
-> Cmd
-> (Either SomeException (Async ProcessStatus) -> IO ())
-> Cmd
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd -> Cmd
postCmd (Fd -> Cmd
cmd2 Fd
y) ((Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd)
-> (Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd
forall a b. (a -> b) -> a -> b
$ \Either SomeException (Async ProcessStatus)
status2 -> do
          Fd -> IO ()
closeFd Fd
x
          Fd -> IO ()
closeFd Fd
y
          Async ProcessStatus
_ <- IO ProcessStatus -> IO (Async ProcessStatus)
forall a. IO a -> IO (Async a)
async (IO ProcessStatus -> IO (Async ProcessStatus))
-> IO ProcessStatus -> IO (Async ProcessStatus)
forall a b. (a -> b) -> a -> b
$ ((SomeException -> IO (Async ProcessStatus))
-> (Async ProcessStatus -> IO (Async ProcessStatus))
-> Either SomeException (Async ProcessStatus)
-> IO (Async ProcessStatus)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO (Async ProcessStatus)
forall e a. Exception e => e -> IO a
throwIO Async ProcessStatus -> IO (Async ProcessStatus)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException (Async ProcessStatus)
status2 IO (Async ProcessStatus)
-> (Async ProcessStatus -> IO ProcessStatus) -> IO ProcessStatus
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Async ProcessStatus -> IO ProcessStatus
forall a. Async a -> IO a
wait) IO ProcessStatus -> IO () -> IO ProcessStatus
forall a b. IO a -> IO b -> IO a
`finally` Async ProcessStatus -> IO ()
forall a. Async a -> IO ()
cancel Async ProcessStatus
status1
          () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

pipeArgFd :: Bool -> Fd -> Cmd -> Cmd -> Cmd
pipeArgFd :: Bool -> Fd -> Cmd -> Cmd -> Cmd
pipeArgFd Bool
dir Fd
fd Cmd
cmd1 Cmd
cmd2 = Bool -> Fd -> Cmd -> (Fd -> Cmd) -> Cmd
pipeFd' Bool
dir Fd
fd Cmd
cmd1 (\Fd
y -> Fd -> Cmd -> Cmd
passArgFd Fd
y Cmd
cmd2)

pipeFd :: Bool -> Fd -> Fd -> Cmd -> Cmd -> Cmd
pipeFd :: Bool -> Fd -> Fd -> Cmd -> Cmd -> Cmd
pipeFd Bool
dir Fd
fd1 Fd
fd2 Cmd
cmd1 Cmd
cmd2 = Bool -> Fd -> Cmd -> (Fd -> Cmd) -> Cmd
pipeFd' Bool
dir Fd
fd1 Cmd
cmd1 (\Fd
y -> (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
fd2, Fd
y) Cmd
cmd2)

-- | Pass an argument of the form @\/proc\/self\/fd\/\<n\>@ to the process,
-- where `n` is the reader end of a pipe which the command
-- writes to through the specified fd.
pipeArgIn ::
  -- | The fd the command will write to
  Fd ->
  -- | The command that will write to the fd
  Cmd ->
  -- | The command you're modifying
  Cmd ->
  Cmd
pipeArgIn :: Fd -> Cmd -> Cmd -> Cmd
pipeArgIn = Bool -> Fd -> Cmd -> Cmd -> Cmd
pipeArgFd Bool
True

-- | Pass an argument of the form @\/proc\/self\/fd\/\<n\>@ to the process,
-- where `n` is the writer end of a pipe which the command
-- reads from through the specified fd.
pipeArgOut ::
  -- | The fd the command will read from
  Fd ->
  -- | The command that will read from the fd
  Cmd ->
  -- | The command you're modifying
  Cmd ->
  Cmd
pipeArgOut :: Fd -> Cmd -> Cmd -> Cmd
pipeArgOut = Bool -> Fd -> Cmd -> Cmd -> Cmd
pipeArgFd Bool
False

-- | Pipes from the first command to the second command
pipeIn ::
  -- | The writing end
  Fd ->
  -- | The reading end
  Fd ->
  -- | The writer command
  Cmd ->
  -- | The reader command
  Cmd ->
  Cmd
pipeIn :: Fd -> Fd -> Cmd -> Cmd -> Cmd
pipeIn = Bool -> Fd -> Fd -> Cmd -> Cmd -> Cmd
pipeFd Bool
True

-- | Pipes from the second command to the first command
pipeOut ::
  -- | The reading end
  Fd ->
  -- | The writing end
  Fd ->
  -- | The reader command
  Cmd ->
  -- | The writer command
  Cmd ->
  Cmd
pipeOut :: Fd -> Fd -> Cmd -> Cmd -> Cmd
pipeOut = Bool -> Fd -> Fd -> Cmd -> Cmd -> Cmd
pipeFd Bool
False

pipeH' :: Bool -> (Async ProcessStatus -> Handle -> IO ()) -> (Fd -> Cmd) -> Cmd
pipeH' :: Bool
-> (Async ProcessStatus -> Handle -> IO ()) -> (Fd -> Cmd) -> Cmd
pipeH' Bool
dir Async ProcessStatus -> Handle -> IO ()
handler Fd -> Cmd
cmd = IO Cmd -> Cmd
unIOCmd (IO Cmd -> Cmd) -> IO Cmd -> Cmd
forall a b. (a -> b) -> a -> b
$
  IO (Fd, Fd)
-> ((Fd, Fd) -> IO ()) -> ((Fd, Fd) -> IO Cmd) -> IO Cmd
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError ((if Bool
dir then (Fd, Fd) -> (Fd, Fd)
forall a b. (a, b) -> (b, a)
swap else (Fd, Fd) -> (Fd, Fd)
forall a. a -> a
id) ((Fd, Fd) -> (Fd, Fd)) -> IO (Fd, Fd) -> IO (Fd, Fd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Fd, Fd)
createPipe) (\(Fd
x, Fd
y) -> Fd -> IO ()
closeFd Fd
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
y) (((Fd, Fd) -> IO Cmd) -> IO Cmd) -> ((Fd, Fd) -> IO Cmd) -> IO Cmd
forall a b. (a -> b) -> a -> b
$ \(Fd
x, Fd
y) -> do
    Cmd -> IO Cmd
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cmd -> IO Cmd) -> Cmd -> IO Cmd
forall a b. (a -> b) -> a -> b
$
      ((Either SomeException (Async ProcessStatus) -> IO ())
 -> Cmd -> Cmd)
-> Cmd
-> (Either SomeException (Async ProcessStatus) -> IO ())
-> Cmd
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd -> Cmd
postCmd (Fd -> Cmd
cmd Fd
y) ((Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd)
-> (Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd
forall a b. (a -> b) -> a -> b
$ \Either SomeException (Async ProcessStatus)
status -> do
        Fd -> IO ()
closeFd Fd
y
        case Either SomeException (Async ProcessStatus)
status of
          Right Async ProcessStatus
status -> do
            Handle
x <- Fd -> IO Handle
fdToHandle Fd
x
            Async ()
a <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Async ProcessStatus -> Handle -> IO ()
handler Async ProcessStatus
status Handle
x
            Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
a
            () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Left SomeException
e -> do
            Fd -> IO ()
closeFd Fd
x
            SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
e

pipeH :: Bool -> Fd -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeH :: Bool
-> Fd -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeH Bool
dir Fd
fdNew Async ProcessStatus -> Handle -> IO ()
handler Cmd
cmd = Bool
-> (Async ProcessStatus -> Handle -> IO ()) -> (Fd -> Cmd) -> Cmd
pipeH' Bool
dir Async ProcessStatus -> Handle -> IO ()
handler (\Fd
fdOld -> (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
fdNew, Fd
fdOld) Cmd
cmd)

-- | Pipes from the handle to the fd.
pipeHIn :: Fd -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeHIn :: Fd -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeHIn = Bool
-> Fd -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeH Bool
True

-- | Pipes from the fd to the handle.
pipeHOut :: Fd -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeHOut :: Fd -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeHOut = Bool
-> Fd -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeH Bool
False

pipeArgH :: Bool -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeArgH :: Bool -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeArgH Bool
dir Async ProcessStatus -> Handle -> IO ()
handler Cmd
cmd = Bool
-> (Async ProcessStatus -> Handle -> IO ()) -> (Fd -> Cmd) -> Cmd
pipeH' Bool
dir Async ProcessStatus -> Handle -> IO ()
handler (\Fd
fd -> Fd -> Cmd -> Cmd
passArgFd Fd
fd Cmd
cmd)

-- | Pass an argument of the form @\/proc\/self\/fd\/\<n\>@ to the process,
-- where `n` is the reader end of a pipe where the writer end is passed
-- to a Haskell function.
pipeArgHIn :: (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeArgHIn :: (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeArgHIn = Bool -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeArgH Bool
True

-- | Pass an argument of the form @\/proc\/self\/fd\/\<n\>@ to the process,
-- where `n` is the writer end of a pipe where the reader end is passed
-- to a Haskell function.
pipeArgHOut :: (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeArgHOut :: (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeArgHOut = Bool -> (Async ProcessStatus -> Handle -> IO ()) -> Cmd -> Cmd
pipeArgH Bool
False

-- | Captures the outputs to the specified fds.
captureFdsAsHandles :: [Fd] -> Cmd -> IO (Async ProcessStatus, [Handle])
captureFdsAsHandles :: [Fd] -> Cmd -> IO (Async ProcessStatus, [Handle])
captureFdsAsHandles [Fd]
fds Cmd
cmd = do
  [(Fd, Fd, Fd)]
fds <- (Fd -> IO (Fd, Fd, Fd)) -> [Fd] -> IO [(Fd, Fd, Fd)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Fd
wnew -> IO (Fd, Fd)
createPipe IO (Fd, Fd) -> ((Fd, Fd) -> IO (Fd, Fd, Fd)) -> IO (Fd, Fd, Fd)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Fd
r, Fd
wold) -> (Fd, Fd, Fd) -> IO (Fd, Fd, Fd)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fd
wnew, Fd
r, Fd
wold)) [Fd]
fds
  (IO (Async ProcessStatus, [Handle])
 -> IO [()] -> IO (Async ProcessStatus, [Handle]))
-> IO [()]
-> IO (Async ProcessStatus, [Handle])
-> IO (Async ProcessStatus, [Handle])
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Async ProcessStatus, [Handle])
-> IO [()] -> IO (Async ProcessStatus, [Handle])
forall a b. IO a -> IO b -> IO a
onException (((Fd, Fd, Fd) -> IO ()) -> [(Fd, Fd, Fd)] -> IO [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Fd
_wnew, Fd
r, Fd
wold) -> Fd -> IO ()
closeFd Fd
r IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
wold) [(Fd, Fd, Fd)]
fds) (IO (Async ProcessStatus, [Handle])
 -> IO (Async ProcessStatus, [Handle]))
-> IO (Async ProcessStatus, [Handle])
-> IO (Async ProcessStatus, [Handle])
forall a b. (a -> b) -> a -> b
$ do
    Async ProcessStatus
status <- Cmd -> IO (Async ProcessStatus)
run' (Cmd -> IO (Async ProcessStatus))
-> Cmd -> IO (Async ProcessStatus)
forall a b. (a -> b) -> a -> b
$ ((Fd, Fd, Fd) -> Cmd -> Cmd) -> Cmd -> [(Fd, Fd, Fd)] -> Cmd
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Fd
wnew, Fd
_r, Fd
wold) -> (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
wnew, Fd
wold)) Cmd
cmd [(Fd, Fd, Fd)]
fds -- TODO terminate eventually?
    ((Fd, Fd, Fd) -> IO ()) -> [(Fd, Fd, Fd)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Fd
_wnew, Fd
_r, Fd
wold) -> Fd -> IO ()
closeFd Fd
wold) [(Fd, Fd, Fd)]
fds
    [Handle]
handles <- ((Fd, Fd, Fd) -> IO Handle) -> [(Fd, Fd, Fd)] -> IO [Handle]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Fd
_wnew, Fd
r, Fd
_wold) -> Fd -> IO Handle
fdToHandle Fd
r) [(Fd, Fd, Fd)]
fds
    (Async ProcessStatus, [Handle])
-> IO (Async ProcessStatus, [Handle])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Async ProcessStatus, [Handle])
 -> IO (Async ProcessStatus, [Handle]))
-> (Async ProcessStatus, [Handle])
-> IO (Async ProcessStatus, [Handle])
forall a b. (a -> b) -> a -> b
$ (Async ProcessStatus
status, [Handle]
handles)