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
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)
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
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)
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)
pipeArgIn ::
Fd ->
Cmd ->
Cmd ->
Cmd
pipeArgIn :: Fd -> Cmd -> Cmd -> Cmd
pipeArgIn = Bool -> Fd -> Cmd -> Cmd -> Cmd
pipeArgFd Bool
True
pipeArgOut ::
Fd ->
Cmd ->
Cmd ->
Cmd
pipeArgOut :: Fd -> Cmd -> Cmd -> Cmd
pipeArgOut = Bool -> Fd -> Cmd -> Cmd -> Cmd
pipeArgFd Bool
False
pipeIn ::
Fd ->
Fd ->
Cmd ->
Cmd ->
Cmd
pipeIn :: Fd -> Fd -> Cmd -> Cmd -> Cmd
pipeIn = Bool -> Fd -> Fd -> Cmd -> Cmd -> Cmd
pipeFd Bool
True
pipeOut ::
Fd ->
Fd ->
Cmd ->
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)
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
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)
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
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
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
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)