-- | 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 :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
f (a
x : [a]
xs) =
  a -> m Bool
f a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> case Bool
b of
    Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
    Bool
False -> forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
f [a]
xs
findM a -> m Bool
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a b. (a -> b) -> a -> b
$ do
  ByteString
fullpath :: ByteString <-
    if (Word8 -> Bool) -> ByteString -> Bool
B.any ((forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord forall a b. (a -> b) -> a -> b
$ Char
'/') forall a. Eq a => a -> a -> Bool
==) ByteString
path
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
path
      else do
        ByteString
pathvar <- ByteString -> ByteString
B.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ByteString -> IO ByteString
getEnvDefault ByteString
"PATH" ByteString
""
        Maybe ByteString
fullpath <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM ByteString -> IO Bool
fileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ByteString
x -> ByteString -> ByteString
B.toStrict forall a b. (a -> b) -> a -> b
$ ByteString
x forall a. Semigroup a => a -> a -> a
<> ByteString
"/" forall a. Semigroup a => a -> a -> a
<> ByteString
path) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> [ByteString
"/", ByteString
"."]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
B.split (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
':') forall a b. (a -> b) -> a -> b
$ ByteString
pathvar
        case Maybe ByteString
fullpath of
          Just ByteString
p -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.fromStrict forall a b. (a -> b) -> a -> b
$ ByteString
p
          Maybe ByteString
Nothing -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (forall a. Show a => a -> String
show ByteString
path forall a. Semigroup a => a -> a -> a
<> String
" does not exist")
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> Cmd
makeCmd' ByteString
fullpath forall a b. a -> (a -> b) -> b
& ByteString -> Cmd -> Cmd
passArg ByteString
path forall a b. a -> (a -> b) -> b
& (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
0, Fd
0) forall a b. a -> (a -> b) -> b
& (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
1, Fd
1) 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 stock (Int -> CmdException -> ShowS
[CmdException] -> ShowS
CmdException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CmdException] -> ShowS
$cshowList :: [CmdException] -> ShowS
show :: CmdException -> String
$cshow :: CmdException -> String
showsPrec :: Int -> CmdException -> ShowS
$cshowsPrec :: Int -> CmdException -> ShowS
Show)

instance Exception CmdException where
  displayException :: CmdException -> String
displayException (CmdException ProcessStatus
status) = String
"Command failed: " forall a. Semigroup a => a -> a -> a
<> 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 =
  forall a. Async a -> IO a
wait Async ProcessStatus
status forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Exited ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ProcessStatus
e -> 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 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 forall a b. (a -> b) -> a -> b
$ do
  forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError ((if Bool
dir then forall a b. (a, b) -> (b, a)
swap else forall a. a -> a
id) 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
y) forall a b. (a -> b) -> a -> b
$ \(Fd
x, Fd
y) -> do
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (Cmd -> IO (Async ProcessStatus)
run' forall a b. (a -> b) -> a -> b
$ Cmd
cmd1 forall a b. a -> (a -> b) -> b
& (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
fd1, Fd
x)) (forall a. IO a -> IO (Async a)
async forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Async a -> IO ()
cancel) forall a b. (a -> b) -> a -> b
$ \Async ProcessStatus
status1 -> do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd -> Cmd
postCmd (Fd -> Cmd
cmd2 Fd
y) 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
_ <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException (Async ProcessStatus)
status2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Async a -> IO a
wait) forall a b. IO a -> IO b -> IO a
`finally` forall a. Async a -> IO ()
cancel Async ProcessStatus
status1
          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 forall a b. (a -> b) -> a -> b
$
  forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError ((if Bool
dir then forall a b. (a, b) -> (b, a)
swap else forall a. a -> a
id) 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
y) forall a b. (a -> b) -> a -> b
$ \(Fd
x, Fd
y) -> do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd -> Cmd
postCmd (Fd -> Cmd
cmd Fd
y) 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 <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ Async ProcessStatus -> Handle -> IO ()
handler Async ProcessStatus
status Handle
x
            forall a. Async a -> IO ()
link Async ()
a
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Left SomeException
e -> do
            Fd -> IO ()
closeFd Fd
x
            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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Fd
wnew -> IO (Fd, Fd)
createPipe forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Fd
r, Fd
wold) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fd
wnew, Fd
r, Fd
wold)) [Fd]
fds
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
onException (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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
wold) [(Fd, Fd, Fd)]
fds) forall a b. (a -> b) -> a -> b
$ do
    Async ProcessStatus
status <- Cmd -> IO (Async ProcessStatus)
run' forall a b. (a -> b) -> a -> b
$ 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?
    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 <- 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Async ProcessStatus
status, [Handle]
handles)