{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Util.Processes where
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.Chan as Chan
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Exception as Exception
import qualified Control.Monad.Fix as Fix
import qualified Data.ByteString as ByteString
import qualified Data.String as String
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Time as Time
import qualified System.Exit as Exit
import qualified System.IO as IO
import qualified System.IO.Error as IO.Error
import qualified System.Posix as Posix
import qualified System.Process as Process
import qualified System.Timeout as Timeout
import qualified Util.Exceptions as Exceptions
import qualified Util.Log as Log
import Global
readProcessWithExitCode :: Maybe [(String, String)] -> FilePath -> [String]
-> ByteString.ByteString
-> IO (Exit.ExitCode, ByteString.ByteString, ByteString.ByteString)
readProcessWithExitCode :: Maybe [(String, String)]
-> String
-> [String]
-> ByteString
-> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode Maybe [(String, String)]
env String
cmd [String]
args ByteString
stdin = do
(Just Handle
inh, Just Handle
outh, Just Handle
errh, ProcessHandle
hdl) <-
CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess (String -> [String] -> CreateProcess
Process.proc String
cmd [String]
args)
{ env :: Maybe [(String, String)]
Process.env = Maybe [(String, String)]
env
, std_in :: StdStream
Process.std_in = StdStream
Process.CreatePipe
, std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe
, std_err :: StdStream
Process.std_err = StdStream
Process.CreatePipe
}
MVar ByteString
outMVar <- IO (MVar ByteString)
forall a. IO (MVar a)
MVar.newEmptyMVar
MVar ByteString
errMVar <- IO (MVar ByteString)
forall a. IO (MVar a)
MVar.newEmptyMVar
IO () -> IO ThreadId
Concurrent.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar ByteString
outMVar (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO ByteString
ByteString.hGetContents Handle
outh
IO () -> IO ThreadId
Concurrent.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar ByteString
errMVar (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO ByteString
ByteString.hGetContents Handle
errh
IO () -> IO ThreadId
Concurrent.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
ByteString.hPut Handle
inh ByteString
stdin IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
IO.hClose Handle
inh
ByteString
out <- MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
MVar.takeMVar MVar ByteString
outMVar
ByteString
err <- MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
MVar.takeMVar MVar ByteString
errMVar
Handle -> IO ()
IO.hClose Handle
outh
Handle -> IO ()
IO.hClose Handle
errh
ExitCode
ex <- ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
hdl
(ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, ByteString
out, ByteString
err)
supervised :: Process.CreateProcess -> IO ()
supervised :: CreateProcess -> IO ()
supervised CreateProcess
proc = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, Maybe ProcessHandle
hdl) <- CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle)
create CreateProcess
proc
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
Exception.onException (IO () -> IO ()
forall a. IO a -> IO a
restore (CreateProcess -> Maybe ProcessHandle -> IO ()
waitAndLog CreateProcess
proc Maybe ProcessHandle
hdl)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe ProcessHandle
hdl of
Maybe ProcessHandle
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ProcessHandle
hdl -> do
Maybe ProcessID
pid <- ProcessHandle -> IO (Maybe ProcessID)
Process.getPid ProcessHandle
hdl
Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"received exception, killing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
showt (CreateProcess -> String
cmdOf CreateProcess
proc)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (ProcessID -> Text) -> Maybe ProcessID -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
")") (Text -> Text) -> (ProcessID -> Text) -> ProcessID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
" (pid "<>) (Text -> Text) -> (ProcessID -> Text) -> ProcessID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> Text
forall a. Show a => a -> Text
showt) Maybe ProcessID
pid
ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
hdl
waitAndLog :: Process.CreateProcess -> Maybe Process.ProcessHandle -> IO ()
waitAndLog :: CreateProcess -> Maybe ProcessHandle -> IO ()
waitAndLog CreateProcess
proc Maybe ProcessHandle
hdl = IO () -> (Text -> IO ()) -> Maybe Text -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Maybe Text -> IO ()) -> IO (Maybe Text) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CreateProcess -> Maybe ProcessHandle -> IO (Maybe Text)
waitError CreateProcess
proc Maybe ProcessHandle
hdl
waitError :: Process.CreateProcess -> Maybe Process.ProcessHandle
-> IO (Maybe Text)
waitError :: CreateProcess -> Maybe ProcessHandle -> IO (Maybe Text)
waitError CreateProcess
proc Maybe ProcessHandle
maybeHdl = (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
annotate (Maybe Text -> Maybe Text) -> IO (Maybe Text) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe ProcessHandle
maybeHdl of
Maybe ProcessHandle
Nothing -> Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
noBinary
Just ProcessHandle
hdl -> do
Maybe ExitCode
result <- IO ExitCode -> IO (Maybe ExitCode)
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
hdl)
Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ case Maybe ExitCode
result of
Maybe ExitCode
Nothing -> Maybe Text
forall a. Maybe a
Nothing
Just ExitCode
code -> case ExitCode
code of
ExitCode
Exit.ExitSuccess -> Maybe Text
forall a. Maybe a
Nothing
Exit.ExitFailure Int
c
| Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
127 -> Maybe Text
noBinary
| Bool
otherwise -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"process failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
c
where
noBinary :: Maybe Text
noBinary = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"binary not found"
annotate :: Text -> Text
annotate Text
msg = Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (CreateProcess -> String
cmdOf CreateProcess
proc)
call :: FilePath -> [String] -> IO ()
call :: String -> [String] -> IO ()
call String
cmd [String]
args = (IOError -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle IOError -> IO ()
ioError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
proc ((Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ())
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
hdl -> CreateProcess -> Maybe ProcessHandle -> IO ()
waitAndLog CreateProcess
proc (ProcessHandle -> Maybe ProcessHandle
forall a. a -> Maybe a
Just ProcessHandle
hdl)
where
proc :: CreateProcess
proc = String -> [String] -> CreateProcess
Process.proc String
cmd [String]
args
ioError :: IO.Error.IOError -> IO ()
ioError :: IOError -> IO ()
ioError IOError
exc = Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> Text
forall a. Show a => a -> Text
showt IOError
exc
create :: Process.CreateProcess
-> IO (Maybe IO.Handle, Maybe IO.Handle, Maybe IO.Handle,
Maybe Process.ProcessHandle)
create :: CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle)
create CreateProcess
proc = IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO
(Maybe (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
proc) IO
(Maybe (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> (Maybe (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle))
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Nothing -> (Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle)
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
forall a. Maybe a
Nothing, Maybe Handle
forall a. Maybe a
Nothing, Maybe Handle
forall a. Maybe a
Nothing, Maybe ProcessHandle
forall a. Maybe a
Nothing)
Just (Maybe Handle
inh, Maybe Handle
outh, Maybe Handle
errh, ProcessHandle
hdl) -> (Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle)
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
inh, Maybe Handle
outh, Maybe Handle
errh, ProcessHandle -> Maybe ProcessHandle
forall a. a -> Maybe a
Just ProcessHandle
hdl)
data TalkOut = Stdout !Text | Stderr !Text
| Exit !Exit
deriving (TalkOut -> TalkOut -> Bool
(TalkOut -> TalkOut -> Bool)
-> (TalkOut -> TalkOut -> Bool) -> Eq TalkOut
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TalkOut -> TalkOut -> Bool
$c/= :: TalkOut -> TalkOut -> Bool
== :: TalkOut -> TalkOut -> Bool
$c== :: TalkOut -> TalkOut -> Bool
Eq, Eq TalkOut
Eq TalkOut
-> (TalkOut -> TalkOut -> Ordering)
-> (TalkOut -> TalkOut -> Bool)
-> (TalkOut -> TalkOut -> Bool)
-> (TalkOut -> TalkOut -> Bool)
-> (TalkOut -> TalkOut -> Bool)
-> (TalkOut -> TalkOut -> TalkOut)
-> (TalkOut -> TalkOut -> TalkOut)
-> Ord TalkOut
TalkOut -> TalkOut -> Bool
TalkOut -> TalkOut -> Ordering
TalkOut -> TalkOut -> TalkOut
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 :: TalkOut -> TalkOut -> TalkOut
$cmin :: TalkOut -> TalkOut -> TalkOut
max :: TalkOut -> TalkOut -> TalkOut
$cmax :: TalkOut -> TalkOut -> TalkOut
>= :: TalkOut -> TalkOut -> Bool
$c>= :: TalkOut -> TalkOut -> Bool
> :: TalkOut -> TalkOut -> Bool
$c> :: TalkOut -> TalkOut -> Bool
<= :: TalkOut -> TalkOut -> Bool
$c<= :: TalkOut -> TalkOut -> Bool
< :: TalkOut -> TalkOut -> Bool
$c< :: TalkOut -> TalkOut -> Bool
compare :: TalkOut -> TalkOut -> Ordering
$ccompare :: TalkOut -> TalkOut -> Ordering
Ord, Int -> TalkOut -> ShowS
[TalkOut] -> ShowS
TalkOut -> String
(Int -> TalkOut -> ShowS)
-> (TalkOut -> String) -> ([TalkOut] -> ShowS) -> Show TalkOut
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TalkOut] -> ShowS
$cshowList :: [TalkOut] -> ShowS
show :: TalkOut -> String
$cshow :: TalkOut -> String
showsPrec :: Int -> TalkOut -> ShowS
$cshowsPrec :: Int -> TalkOut -> ShowS
Show)
data TalkIn = Text !Text | EOF
deriving (TalkIn -> TalkIn -> Bool
(TalkIn -> TalkIn -> Bool)
-> (TalkIn -> TalkIn -> Bool) -> Eq TalkIn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TalkIn -> TalkIn -> Bool
$c/= :: TalkIn -> TalkIn -> Bool
== :: TalkIn -> TalkIn -> Bool
$c== :: TalkIn -> TalkIn -> Bool
Eq, Int -> TalkIn -> ShowS
[TalkIn] -> ShowS
TalkIn -> String
(Int -> TalkIn -> ShowS)
-> (TalkIn -> String) -> ([TalkIn] -> ShowS) -> Show TalkIn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TalkIn] -> ShowS
$cshowList :: [TalkIn] -> ShowS
show :: TalkIn -> String
$cshow :: TalkIn -> String
showsPrec :: Int -> TalkIn -> ShowS
$cshowsPrec :: Int -> TalkIn -> ShowS
Show)
data Exit = ExitCode !Int | BinaryNotFound | KillTimeout
deriving (Exit -> Exit -> Bool
(Exit -> Exit -> Bool) -> (Exit -> Exit -> Bool) -> Eq Exit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exit -> Exit -> Bool
$c/= :: Exit -> Exit -> Bool
== :: Exit -> Exit -> Bool
$c== :: Exit -> Exit -> Bool
Eq, Eq Exit
Eq Exit
-> (Exit -> Exit -> Ordering)
-> (Exit -> Exit -> Bool)
-> (Exit -> Exit -> Bool)
-> (Exit -> Exit -> Bool)
-> (Exit -> Exit -> Bool)
-> (Exit -> Exit -> Exit)
-> (Exit -> Exit -> Exit)
-> Ord Exit
Exit -> Exit -> Bool
Exit -> Exit -> Ordering
Exit -> Exit -> Exit
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 :: Exit -> Exit -> Exit
$cmin :: Exit -> Exit -> Exit
max :: Exit -> Exit -> Exit
$cmax :: Exit -> Exit -> Exit
>= :: Exit -> Exit -> Bool
$c>= :: Exit -> Exit -> Bool
> :: Exit -> Exit -> Bool
$c> :: Exit -> Exit -> Bool
<= :: Exit -> Exit -> Bool
$c<= :: Exit -> Exit -> Bool
< :: Exit -> Exit -> Bool
$c< :: Exit -> Exit -> Bool
compare :: Exit -> Exit -> Ordering
$ccompare :: Exit -> Exit -> Ordering
Ord, Int -> Exit -> ShowS
[Exit] -> ShowS
Exit -> String
(Int -> Exit -> ShowS)
-> (Exit -> String) -> ([Exit] -> ShowS) -> Show Exit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exit] -> ShowS
$cshowList :: [Exit] -> ShowS
show :: Exit -> String
$cshow :: Exit -> String
showsPrec :: Int -> Exit -> ShowS
$cshowsPrec :: Int -> Exit -> ShowS
Show)
instance String.IsString TalkIn where
fromString :: String -> TalkIn
fromString = Text -> TalkIn
Text (Text -> TalkIn) -> (String -> Text) -> String -> TalkIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
conversation :: FilePath -> [String] -> Maybe [(String, String)]
-> Chan.Chan TalkIn -> (Chan.Chan TalkOut -> IO a) -> IO a
conversation :: forall a.
String
-> [String]
-> Maybe [(String, String)]
-> Chan TalkIn
-> (Chan TalkOut -> IO a)
-> IO a
conversation String
cmd [String]
args Maybe [(String, String)]
env Chan TalkIn
input Chan TalkOut -> IO a
action = do
Chan TalkOut
output <- IO (Chan TalkOut)
forall a. IO (Chan a)
Chan.newChan
String
-> [String]
-> Maybe [(String, String)]
-> IO TalkIn
-> (TalkOut -> IO ())
-> IO a
-> IO a
forall a.
String
-> [String]
-> Maybe [(String, String)]
-> IO TalkIn
-> (TalkOut -> IO ())
-> IO a
-> IO a
conversationWith String
cmd [String]
args Maybe [(String, String)]
env (Chan TalkIn -> IO TalkIn
forall a. Chan a -> IO a
Chan.readChan Chan TalkIn
input) (Chan TalkOut -> TalkOut -> IO ()
forall a. Chan a -> a -> IO ()
Chan.writeChan Chan TalkOut
output)
(Chan TalkOut -> IO a
action Chan TalkOut
output)
multipleOutput :: [(FilePath, [String])]
-> (Chan.Chan ((FilePath, [String]), TalkOut) -> IO a)
-> IO a
multipleOutput :: forall a.
[(String, [String])]
-> (Chan ((String, [String]), TalkOut) -> IO a) -> IO a
multipleOutput [(String, [String])]
cmds Chan ((String, [String]), TalkOut) -> IO a
action = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(String, [String])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, [String])]
cmds) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Text -> IO ()
forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO Text
"no command given"
Chan ((String, [String]), TalkOut)
output <- IO (Chan ((String, [String]), TalkOut))
forall a. IO (Chan a)
Chan.newChan
let run :: (String, [String]) -> IO a -> IO a
run (String
cmd, [String]
args) = String
-> [String]
-> Maybe [(String, String)]
-> IO TalkIn
-> (TalkOut -> IO ())
-> IO a
-> IO a
forall a.
String
-> [String]
-> Maybe [(String, String)]
-> IO TalkIn
-> (TalkOut -> IO ())
-> IO a
-> IO a
conversationWith String
cmd [String]
args Maybe [(String, String)]
forall a. Maybe a
Nothing (TalkIn -> IO TalkIn
forall (m :: * -> *) a. Monad m => a -> m a
return TalkIn
EOF)
(Chan ((String, [String]), TalkOut)
-> ((String, [String]), TalkOut) -> IO ()
forall a. Chan a -> a -> IO ()
Chan.writeChan Chan ((String, [String]), TalkOut)
output (((String, [String]), TalkOut) -> IO ())
-> (TalkOut -> ((String, [String]), TalkOut)) -> TalkOut -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
cmd, [String]
args),))
((String, [String]) -> IO a -> IO a)
-> IO a -> [(String, [String])] -> IO a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, [String]) -> IO a -> IO a
forall {a}. (String, [String]) -> IO a -> IO a
run (Chan ((String, [String]), TalkOut) -> IO a
action Chan ((String, [String]), TalkOut)
output) [(String, [String])]
cmds
conversationWith :: FilePath -> [String] -> Maybe [(String, String)]
-> IO TalkIn -> (TalkOut -> IO ()) -> IO a -> IO a
conversationWith :: forall a.
String
-> [String]
-> Maybe [(String, String)]
-> IO TalkIn
-> (TalkOut -> IO ())
-> IO a
-> IO a
conversationWith String
cmd [String]
args Maybe [(String, String)]
env IO TalkIn
getInput TalkOut -> IO ()
notifyOutput IO a
action = do
Maybe a
ok <- IO a -> IO (Maybe a)
forall a. IO a -> IO (Maybe a)
binaryNotFound (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
proc ((Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a)
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$
\(Just Handle
stdin) (Just Handle
stdout) (Just Handle
stderr) ProcessHandle
pid -> do
Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
stdout BufferMode
IO.LineBuffering
Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
stderr BufferMode
IO.LineBuffering
Async ()
inThread <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
Fix.fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> IO TalkIn
getInput IO TalkIn -> (TalkIn -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Text Text
t -> Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
stdin Text
t IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
IO.hFlush Handle
stdin IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
TalkIn
EOF -> Handle -> IO ()
IO.hClose Handle
stdin
Async ()
outThread <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO (Maybe Any) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Any) -> IO ()) -> IO (Maybe Any) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Any -> IO (Maybe Any)
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEOF (IO Any -> IO (Maybe Any)) -> IO Any -> IO (Maybe Any)
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$
TalkOut -> IO ()
notifyOutput (TalkOut -> IO ()) -> (Text -> TalkOut) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TalkOut
Stdout (Text -> IO ()) -> IO Text -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO Text
Text.IO.hGetLine Handle
stdout
Async ()
errThread <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO (Maybe Any) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Any) -> IO ()) -> IO (Maybe Any) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Any -> IO (Maybe Any)
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEOF (IO Any -> IO (Maybe Any)) -> IO Any -> IO (Maybe Any)
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$
TalkOut -> IO ()
notifyOutput (TalkOut -> IO ()) -> (Text -> TalkOut) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TalkOut
Stderr (Text -> IO ()) -> IO Text -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO Text
Text.IO.hGetLine Handle
stderr
Async ()
complete <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
Async () -> Async () -> IO ((), ())
forall a b. Async a -> Async b -> IO (a, b)
Async.waitBoth Async ()
outThread Async ()
errThread
ExitCode
code <- ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
pid
TalkOut -> IO ()
notifyOutput (TalkOut -> IO ()) -> TalkOut -> IO ()
forall a b. (a -> b) -> a -> b
$ Exit -> TalkOut
Exit (Exit -> TalkOut) -> Exit -> TalkOut
forall a b. (a -> b) -> a -> b
$ Int -> Exit
ExitCode (Int -> Exit) -> Int -> Exit
forall a b. (a -> b) -> a -> b
$ case ExitCode
code of
Exit.ExitFailure Int
code -> Int
code
ExitCode
Exit.ExitSuccess -> Int
0
a
result <- IO a
action IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`Exception.onException` do
(Async () -> IO ()) -> [Async ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel [Async ()
inThread, Async ()
outThread, Async ()
errThread, Async ()
complete]
ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
pid
Maybe ExitCode
code <- Int -> IO ExitCode -> IO (Maybe ExitCode)
forall a. Int -> IO a -> IO (Maybe a)
Timeout.timeout Int
killTimeout (IO ExitCode -> IO (Maybe ExitCode))
-> IO ExitCode -> IO (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
pid
TalkOut -> IO ()
notifyOutput (TalkOut -> IO ()) -> TalkOut -> IO ()
forall a b. (a -> b) -> a -> b
$ Exit -> TalkOut
Exit (Exit -> TalkOut) -> Exit -> TalkOut
forall a b. (a -> b) -> a -> b
$ case Maybe ExitCode
code of
Just (Exit.ExitFailure Int
code) -> Int -> Exit
ExitCode Int
code
Just ExitCode
Exit.ExitSuccess -> Int -> Exit
ExitCode Int
0
Maybe ExitCode
Nothing -> Exit
KillTimeout
Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
complete
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
case Maybe a
ok of
Maybe a
Nothing -> do
TalkOut -> IO ()
notifyOutput (TalkOut -> IO ()) -> TalkOut -> IO ()
forall a b. (a -> b) -> a -> b
$ Exit -> TalkOut
Exit Exit
BinaryNotFound
IO a
action
Just a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
where
killTimeout :: Int
killTimeout = NominalDiffTime -> Int
toUsec NominalDiffTime
4
proc :: CreateProcess
proc = (String -> [String] -> CreateProcess
Process.proc String
cmd [String]
args)
{ std_in :: StdStream
Process.std_in = StdStream
Process.CreatePipe
, std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe
, std_err :: StdStream
Process.std_err = StdStream
Process.CreatePipe
, env :: Maybe [(String, String)]
Process.env = Maybe [(String, String)]
env
}
binaryNotFound :: IO a -> IO (Maybe a)
binaryNotFound :: forall a. IO a -> IO (Maybe a)
binaryNotFound = (IOError -> Bool) -> IO a -> IO (Maybe a)
forall e a. Exception e => (e -> Bool) -> IO a -> IO (Maybe a)
Exceptions.ignoreError ((IOError -> Bool) -> IO a -> IO (Maybe a))
-> (IOError -> Bool) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \IOError
exc ->
IOError -> Bool
IO.Error.isDoesNotExistError IOError
exc Bool -> Bool -> Bool
|| IOError -> Bool
IO.Error.isIllegalOperation IOError
exc
toUsec :: Time.NominalDiffTime -> Int
toUsec :: NominalDiffTime -> Int
toUsec = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Int)
-> (NominalDiffTime -> NominalDiffTime) -> NominalDiffTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
1000000)
cmdOf :: Process.CreateProcess -> String
cmdOf :: CreateProcess -> String
cmdOf CreateProcess
proc = case CreateProcess -> CmdSpec
Process.cmdspec CreateProcess
proc of
Process.RawCommand String
fn [String]
args -> [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
fn String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
Process.ShellCommand String
cmd -> String
cmd
binaryOf :: Process.CreateProcess -> FilePath
binaryOf :: CreateProcess -> String
binaryOf CreateProcess
proc = case CreateProcess -> CmdSpec
Process.cmdspec CreateProcess
proc of
Process.RawCommand String
fn [String]
_ -> String
fn
Process.ShellCommand String
cmd -> (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
' ') String
cmd
isAlive :: Posix.ProcessID -> IO Bool
isAlive :: ProcessID -> IO Bool
isAlive ProcessID
pid = (Signal -> ProcessID -> IO ()
Posix.signalProcess Signal
Posix.nullSignal ProcessID
pid IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (IOError -> Bool) -> IOError -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (IOError -> Bool) -> IOError -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
IO.Error.isDoesNotExistError)
commandName :: Posix.ProcessID -> IO (Maybe String)
commandName :: ProcessID -> IO (Maybe String)
commandName ProcessID
pid = do
(ExitCode
_, String
output, String
_) <- String -> [String] -> String -> IO (ExitCode, String, String)
Process.readProcessWithExitCode
String
"ps" [String
"-p", ProcessID -> String
forall a. Show a => a -> String
show ProcessID
pid, String
"-o", String
"comm"] String
""
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ case String -> [String]
lines String
output of
[String
_, String
cmd] -> String -> Maybe String
forall a. a -> Maybe a
Just String
cmd
[String]
_ -> Maybe String
forall a. Maybe a
Nothing
exit :: Int -> IO a
exit :: forall a. Int -> IO a
exit Int
0 = IO a
forall a. IO a
Exit.exitSuccess
exit Int
n = ExitCode -> IO a
forall a. ExitCode -> IO a
Exit.exitWith (ExitCode -> IO a) -> ExitCode -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
Exit.ExitFailure Int
n