module Procex.Core (Cmd, makeCmd', passArg, unIOCmd, postCmd, run', runReplace, passFd, passArgFd, passNoFd) where
import Control.Concurrent.Async
import Control.Exception.Base
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.UTF8 as B
import Data.Foldable (toList)
import qualified Data.Sequence as S
import Foreign.C.Error (throwErrno)
import Procex.Execve
import System.Posix.ByteString
data Arg = ArgStr ByteString | ArgFd Fd deriving stock (Int -> Arg -> ShowS
[Arg] -> ShowS
Arg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arg] -> ShowS
$cshowList :: [Arg] -> ShowS
show :: Arg -> String
$cshow :: Arg -> String
showsPrec :: Int -> Arg -> ShowS
$cshowsPrec :: Int -> Arg -> ShowS
Show)
data Args = Args
{ Args -> [Arg]
args :: [Arg]
, Args -> [(Fd, Maybe Fd)]
fds :: [(Fd, Maybe Fd)]
, Args -> Execve
executor :: Execve
}
emptyArgs :: Args
emptyArgs :: Args
emptyArgs = Args {args :: [Arg]
args = [], fds :: [(Fd, Maybe Fd)]
fds = [], executor :: Execve
executor = Execve
forkexecve}
fdPrepend :: (Fd, Maybe Fd) -> Args -> Args
fdPrepend :: (Fd, Maybe Fd) -> Args -> Args
fdPrepend (Fd
x, Maybe Fd
y) Args
args = Args
args {fds :: [(Fd, Maybe Fd)]
fds = (Fd
x, Maybe Fd
y) forall a. a -> [a] -> [a]
: Args -> [(Fd, Maybe Fd)]
fds Args
args}
argPrepend :: ByteString -> Args -> Args
argPrepend :: ByteString -> Args -> Args
argPrepend ByteString
arg Args {[(Fd, Maybe Fd)]
[Arg]
Execve
executor :: Execve
fds :: [(Fd, Maybe Fd)]
args :: [Arg]
executor :: Args -> Execve
fds :: Args -> [(Fd, Maybe Fd)]
args :: Args -> [Arg]
..} = Args {args :: [Arg]
args = ByteString -> Arg
ArgStr ByteString
arg forall a. a -> [a] -> [a]
: [Arg]
args, [(Fd, Maybe Fd)]
Execve
executor :: Execve
fds :: [(Fd, Maybe Fd)]
executor :: Execve
fds :: [(Fd, Maybe Fd)]
..}
argFdPrepend :: Fd -> Args -> Args
argFdPrepend :: Fd -> Args -> Args
argFdPrepend Fd
arg Args {[(Fd, Maybe Fd)]
[Arg]
Execve
executor :: Execve
fds :: [(Fd, Maybe Fd)]
args :: [Arg]
executor :: Args -> Execve
fds :: Args -> [(Fd, Maybe Fd)]
args :: Args -> [Arg]
..} = Args {args :: [Arg]
args = Fd -> Arg
ArgFd Fd
arg forall a. a -> [a] -> [a]
: [Arg]
args, [(Fd, Maybe Fd)]
Execve
executor :: Execve
fds :: [(Fd, Maybe Fd)]
executor :: Execve
fds :: [(Fd, Maybe Fd)]
..}
newtype Cmd = Cmd {Cmd -> Args -> IO (Async ProcessStatus)
unCmd :: Args -> IO (Async ProcessStatus)}
makeCmd' :: ByteString -> Cmd
makeCmd' :: ByteString -> Cmd
makeCmd' ByteString
path = (Args -> IO (Async ProcessStatus)) -> Cmd
Cmd forall a b. (a -> b) -> a -> b
$ \Args {[Arg]
args :: [Arg]
args :: Args -> [Arg]
args, [(Fd, Maybe Fd)]
fds :: [(Fd, Maybe Fd)]
fds :: Args -> [(Fd, Maybe Fd)]
fds, Execve
executor :: Execve
executor :: Args -> Execve
executor} -> do
let sequentialize_fds :: [(Fd, Maybe Fd)] -> S.Seq Fd -> S.Seq Fd
sequentialize_fds :: [(Fd, Maybe Fd)] -> Seq Fd -> Seq Fd
sequentialize_fds [] Seq Fd
out = Seq Fd
out
sequentialize_fds ((Fd
new, Just Fd
old) : [(Fd, Maybe Fd)]
fds) Seq Fd
out =
[(Fd, Maybe Fd)] -> Seq Fd -> Seq Fd
sequentialize_fds [(Fd, Maybe Fd)]
fds forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> Seq a -> Seq a
S.update (forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
new) Fd
old forall a b. (a -> b) -> a -> b
$ Seq Fd
out forall a. Semigroup a => a -> a -> a
<> forall a. Int -> a -> Seq a
S.replicate (forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
new forall a. Num a => a -> a -> a
- forall a. Seq a -> Int
S.length Seq Fd
out forall a. Num a => a -> a -> a
+ Int
1) (-Fd
1)
sequentialize_fds ((Fd
new, Maybe Fd
Nothing) : [(Fd, Maybe Fd)]
fds) Seq Fd
out =
[(Fd, Maybe Fd)] -> Seq Fd -> Seq Fd
sequentialize_fds [(Fd, Maybe Fd)]
fds forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> Seq a -> Seq a
S.update (forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
new) (-Fd
1) forall a b. (a -> b) -> a -> b
$ Seq Fd
out forall a. Semigroup a => a -> a -> a
<> forall a. Int -> a -> Seq a
S.replicate (forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
new forall a. Num a => a -> a -> a
- forall a. Seq a -> Int
S.length Seq Fd
out forall a. Num a => a -> a -> a
+ Int
1) (-Fd
1)
let fds_seq :: Seq Fd
fds_seq = [(Fd, Maybe Fd)] -> Seq Fd -> Seq Fd
sequentialize_fds [(Fd, Maybe Fd)]
fds []
let (Seq Fd
all_fds, [ByteString]
args') =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
( forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ \(Seq Fd
all_fds, [ByteString]
args') -> \case
ArgStr ByteString
str -> (Seq Fd
all_fds, ByteString
str forall a. a -> [a] -> [a]
: [ByteString]
args')
ArgFd Fd
old_fd -> let new_fd :: Int
new_fd = forall a. Seq a -> Int
S.length Seq Fd
all_fds in (Seq Fd
all_fds forall a. Seq a -> a -> Seq a
S.|> Fd
old_fd, (ByteString
"/proc/self/fd/" forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.fromString (forall a. Show a => a -> String
show Int
new_fd)) forall a. a -> [a] -> [a]
: [ByteString]
args')
)
(Seq Fd
fds_seq, [] :: [ByteString])
[Arg]
args
Maybe CPid
pid <- Execve
executor ByteString
path [ByteString]
args' forall a. Maybe a
Nothing (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Fd
all_fds)
CPid
pid <- case Maybe CPid
pid of
Just CPid
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CPid
x
Maybe CPid
Nothing -> forall a. String -> IO a
throwErrno forall a b. (a -> b) -> a -> b
$ String
"Couldn't execute " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
path forall a. Semigroup a => a -> a -> a
<> String
" with args " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [ByteString]
args' forall a. Semigroup a => a -> a -> a
<> String
" with the following fds: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Seq Fd
all_fds
forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ do
Maybe ProcessStatus
status <- Bool -> Bool -> CPid -> IO (Maybe ProcessStatus)
getProcessStatus Bool
True Bool
True CPid
pid forall a b. IO a -> IO b -> IO a
`onException` Signal -> CPid -> IO ()
signalProcess Signal
sigTERM CPid
pid
case Maybe ProcessStatus
status of
Just ProcessStatus
status -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessStatus
status
Maybe ProcessStatus
Nothing -> forall a. String -> IO a
throwErrno String
"getProcessStatus returned Nothing"
unIOCmd :: IO Cmd -> Cmd
unIOCmd :: IO Cmd -> Cmd
unIOCmd IO Cmd
cmd = (Args -> IO (Async ProcessStatus)) -> Cmd
Cmd forall a b. (a -> b) -> a -> b
$ \Args
args -> do
Cmd
cmd <- IO Cmd
cmd
Cmd -> Args -> IO (Async ProcessStatus)
unCmd Cmd
cmd Args
args
postCmd :: (Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd -> Cmd
postCmd :: (Either SomeException (Async ProcessStatus) -> IO ()) -> Cmd -> Cmd
postCmd Either SomeException (Async ProcessStatus) -> IO ()
f Cmd
cmd = (Args -> IO (Async ProcessStatus)) -> Cmd
Cmd forall a b. (a -> b) -> a -> b
$ \Args
args -> do
Either SomeException (Async ProcessStatus)
r <- forall e a. Exception e => IO a -> IO (Either e a)
try (Cmd -> Args -> IO (Async ProcessStatus)
unCmd Cmd
cmd Args
args)
Either SomeException (Async ProcessStatus) -> IO ()
f Either SomeException (Async ProcessStatus)
r
case Either SomeException (Async ProcessStatus)
r of
Left SomeException
e -> forall e a. Exception e => e -> IO a
throwIO SomeException
e
Right Async ProcessStatus
p -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Async ProcessStatus
p
run' :: Cmd -> IO (Async ProcessStatus)
run' :: Cmd -> IO (Async ProcessStatus)
run' Cmd
cmd = Cmd -> Args -> IO (Async ProcessStatus)
unCmd Cmd
cmd Args
emptyArgs
runReplace :: Cmd -> IO ()
runReplace :: Cmd -> IO ()
runReplace Cmd
cmd = forall a b. a -> b -> a
const () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cmd -> Args -> IO (Async ProcessStatus)
unCmd Cmd
cmd Args
emptyArgs {executor :: Execve
executor = Execve
execve}
passArg :: ByteString -> Cmd -> Cmd
passArg :: ByteString -> Cmd -> Cmd
passArg ByteString
str Cmd
cmd = (Args -> IO (Async ProcessStatus)) -> Cmd
Cmd forall a b. (a -> b) -> a -> b
$ \Args
args -> Cmd -> Args -> IO (Async ProcessStatus)
unCmd Cmd
cmd forall a b. (a -> b) -> a -> b
$ ByteString -> Args -> Args
argPrepend ByteString
str Args
args
passFd ::
(Fd, Fd) ->
Cmd ->
Cmd
passFd :: (Fd, Fd) -> Cmd -> Cmd
passFd (Fd
new, Fd
old) Cmd
cmd = (Args -> IO (Async ProcessStatus)) -> Cmd
Cmd forall a b. (a -> b) -> a -> b
$ \Args
args -> Cmd -> Args -> IO (Async ProcessStatus)
unCmd Cmd
cmd forall a b. (a -> b) -> a -> b
$ (Fd, Maybe Fd) -> Args -> Args
fdPrepend (Fd
new, forall a. a -> Maybe a
Just Fd
old) Args
args
passNoFd ::
Fd ->
Cmd ->
Cmd
passNoFd :: Fd -> Cmd -> Cmd
passNoFd Fd
new Cmd
cmd = (Args -> IO (Async ProcessStatus)) -> Cmd
Cmd forall a b. (a -> b) -> a -> b
$ \Args
args -> Cmd -> Args -> IO (Async ProcessStatus)
unCmd Cmd
cmd forall a b. (a -> b) -> a -> b
$ (Fd, Maybe Fd) -> Args -> Args
fdPrepend (Fd
new, forall a. Maybe a
Nothing) Args
args
passArgFd :: Fd -> Cmd -> Cmd
passArgFd :: Fd -> Cmd -> Cmd
passArgFd Fd
fd Cmd
cmd = (Args -> IO (Async ProcessStatus)) -> Cmd
Cmd forall a b. (a -> b) -> a -> b
$ \Args
args -> Cmd -> Args -> IO (Async ProcessStatus)
unCmd Cmd
cmd forall a b. (a -> b) -> a -> b
$ Fd -> Args -> Args
argFdPrepend Fd
fd Args
args