-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
-- | Utilities to deal with processes.
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


-- | Similar to 'Process.readProcessWithExitCode' but return ByteStrings
-- instead of String.
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 <- forall a. IO (MVar a)
MVar.newEmptyMVar
    MVar ByteString
errMVar <- forall a. IO (MVar a)
MVar.newEmptyMVar
    IO () -> IO ThreadId
Concurrent.forkIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
MVar.putMVar MVar ByteString
outMVar 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 forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
MVar.putMVar MVar ByteString
errMVar 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 forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
ByteString.hPut Handle
inh ByteString
stdin forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
IO.hClose Handle
inh
    ByteString
out <- forall a. MVar a -> IO a
MVar.takeMVar MVar ByteString
outMVar
    ByteString
err <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, ByteString
out, ByteString
err)

-- | Start a subprocess, wait for it to complete, and kill it if this thread
-- is killed.  This is like 'Async.withAsync', except for a subprocess, and
-- it's hardcoded to wait for the subprocess.
--
-- TODO use Process.withCreateProcess?
-- TODO I think 'multipleOutput' makes this obsolete.
supervised :: Process.CreateProcess -> IO ()
supervised :: CreateProcess -> IO ()
supervised CreateProcess
proc = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    -- Hopefully this mask means that I can't get killed after starting the
    -- process but before installing the exception handler.
    (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, Maybe ProcessHandle
hdl) <- CreateProcess
-> IO
     (Maybe Handle, Maybe Handle, Maybe Handle, Maybe ProcessHandle)
create CreateProcess
proc
    forall a b. IO a -> IO b -> IO a
Exception.onException (forall a. IO a -> IO a
restore (CreateProcess -> Maybe ProcessHandle -> IO ()
waitAndLog CreateProcess
proc Maybe ProcessHandle
hdl)) forall a b. (a -> b) -> a -> b
$ case Maybe ProcessHandle
hdl of
        Maybe ProcessHandle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ProcessHandle
hdl -> do
            Maybe ProcessID
pid <- ProcessHandle -> IO (Maybe ProcessID)
Process.getPid ProcessHandle
hdl
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"received exception, killing " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (CreateProcess -> String
cmdOf CreateProcess
proc)
                forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((forall a. Semigroup a => a -> a -> a
<>Text
")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
" (pid "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt) Maybe ProcessID
pid
            ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
hdl

-- | Wait for the process (if it started) and log if it didn't exit
-- successfully.
waitAndLog :: Process.CreateProcess -> Maybe Process.ProcessHandle -> IO ()
waitAndLog :: CreateProcess -> Maybe ProcessHandle -> IO ()
waitAndLog CreateProcess
proc Maybe ProcessHandle
hdl = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
annotate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe ProcessHandle
maybeHdl of
    -- If the binary doesn't exist, sometimes 'create' notices, and sometimes
    -- waitForProcess notices.  I think it's dependent on GHC version.
    Maybe ProcessHandle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
noBinary
    Just ProcessHandle
hdl -> do
        Maybe ExitCode
result <- forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
hdl)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe ExitCode
result of
            Maybe ExitCode
Nothing -> forall a. Maybe a
Nothing
            Just ExitCode
code -> case ExitCode
code of
                ExitCode
Exit.ExitSuccess -> forall a. Maybe a
Nothing
                Exit.ExitFailure Int
c
                    | Int
c forall a. Eq a => a -> a -> Bool
== Int
127 -> Maybe Text
noBinary
                    | Bool
otherwise -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"process failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
c
    where
    noBinary :: Maybe Text
noBinary = forall a. a -> Maybe a
Just Text
"binary not found"
    annotate :: Text -> Text
annotate Text
msg = Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (CreateProcess -> String
cmdOf CreateProcess
proc)

-- | Like 'Process.callProcess', but log if the binary wasn't found or
-- failed.
call :: FilePath -> [String] -> IO ()
call :: String -> [String] -> IO ()
call String
cmd [String]
args = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle IOError -> IO ()
ioError forall a b. (a -> b) -> a -> b
$
    forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
proc forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
hdl -> CreateProcess -> Maybe ProcessHandle -> IO ()
waitAndLog CreateProcess
proc (forall a. a -> Maybe a
Just ProcessHandle
hdl)
    where
    -- If I don't close the fds, the subprocess can inherit open fds, with
    -- confusing results.
    proc :: CreateProcess
proc = String -> [String] -> CreateProcess
Process.proc String
cmd [String]
args
    -- In modern GHCs, this will happen when the binary doesn't exist.  The
    -- exception will have the binary name in it, so cmdOf not needed.
    ioError :: IO.Error.IOError -> IO ()
    ioError :: IOError -> IO ()
ioError IOError
exc = forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt IOError
exc

-- | Like 'Process.createProcess', but return a Nothing instead of a pid if
-- the binary doesn't exist.
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 = forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
proc) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
    Just (Maybe Handle
inh, Maybe Handle
outh, Maybe Handle
errh, ProcessHandle
hdl) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
inh, Maybe Handle
outh, Maybe Handle
errh, forall a. a -> Maybe a
Just ProcessHandle
hdl)

-- * conversation

data TalkOut = Stdout !Text | Stderr !Text
    -- | This always terminates the conversation, and effectively marks the
    -- channel closed.
    | Exit !Exit
    deriving (TalkOut -> TalkOut -> Bool
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
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
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
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
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
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
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
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

-- | Have a conversation with a subprocess.  This doesn't use ptys, so this
-- will only work if the subprocess explicitly doesn't use block buffering.
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 <- forall a. IO (Chan a)
Chan.newChan
    forall a.
String
-> [String]
-> Maybe [(String, String)]
-> IO TalkIn
-> (TalkOut -> IO ())
-> IO a
-> IO a
conversationWith String
cmd [String]
args Maybe [(String, String)]
env (forall a. Chan a -> IO a
Chan.readChan Chan TalkIn
input) (forall a. Chan a -> a -> IO ()
Chan.writeChan Chan TalkOut
output)
        (Chan TalkOut -> IO a
action Chan TalkOut
output)

-- | Get output from multiple subprocesses.  They'll be killed when the action
-- returns, if they haven't already exited.
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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, [String])]
cmds) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO Text
"no command given"
    Chan ((String, [String]), TalkOut)
output <- forall a. IO (Chan a)
Chan.newChan
    let run :: (String, [String]) -> IO a -> IO a
run (String
cmd, [String]
args) = forall a.
String
-> [String]
-> Maybe [(String, String)]
-> IO TalkIn
-> (TalkOut -> IO ())
-> IO a
-> IO a
conversationWith String
cmd [String]
args forall a. Maybe a
Nothing (forall (m :: * -> *) a. Monad m => a -> m a
return TalkIn
EOF)
            (forall a. Chan a -> a -> IO ()
Chan.writeChan Chan ((String, [String]), TalkOut)
output forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
cmd, [String]
args),))
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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
    -- Apparently binary not found is detected in createProcess.  I think in
    -- previous versions it was detected in waitForProcess.
    Maybe a
ok <- forall a. IO a -> IO (Maybe a)
binaryNotFound forall a b. (a -> b) -> a -> b
$ forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
proc 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 <- forall a. IO a -> IO (Async a)
Async.async forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a
Fix.fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> IO TalkIn
getInput 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
IO.hFlush Handle
stdin forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
                TalkIn
EOF -> Handle -> IO ()
IO.hClose Handle
stdin
            Async ()
outThread <- forall a. IO a -> IO (Async a)
Async.async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEOF forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
                TalkOut -> IO ()
notifyOutput forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TalkOut
Stdout forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO Text
Text.IO.hGetLine Handle
stdout
            Async ()
errThread <- forall a. IO a -> IO (Async a)
Async.async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEOF forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
                TalkOut -> IO ()
notifyOutput forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TalkOut
Stderr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO Text
Text.IO.hGetLine Handle
stderr
            -- Ensure both stdout and stderr are flushed before exit.
            Async ()
complete <- forall a. IO a -> IO (Async a)
Async.async forall a b. (a -> b) -> a -> b
$ do
                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 forall a b. (a -> b) -> a -> b
$ Exit -> TalkOut
Exit forall a b. (a -> b) -> a -> b
$ Int -> Exit
ExitCode 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 forall a b. IO a -> IO b -> IO a
`Exception.onException` do
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Async a -> IO ()
Async.cancel [Async ()
inThread, Async ()
outThread, Async ()
errThread, Async ()
complete]
                -- I could also just return and let withCreateProcess kill it,
                -- but then I wouldn't get the exit code, and more importantly,
                -- confirmation that it actually died.  Of course this means
                -- I'm trusting that the process will actually exit on SIGTERM.
                -- And for some reason trying to get 'complete' to do this
                -- doesn't work.
                ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
pid
                Maybe ExitCode
code <- forall a. Int -> IO a -> IO (Maybe a)
Timeout.timeout Int
killTimeout forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
pid
                TalkOut -> IO ()
notifyOutput forall a b. (a -> b) -> a -> b
$ Exit -> TalkOut
Exit 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
            forall a. Async a -> IO ()
Async.cancel Async ()
complete
            forall (m :: * -> *) a. Monad m => a -> m a
return a
result
    case Maybe a
ok of
        Maybe a
Nothing -> do
            TalkOut -> IO ()
notifyOutput forall a b. (a -> b) -> a -> b
$ Exit -> TalkOut
Exit Exit
BinaryNotFound
            IO a
action
        Just a
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
        }

-- | ghc 9.2 seems to have added a bug on darwin where binary not found
-- is reported as illegal operation from a binary, and errno=0 from ghci.
binaryNotFound :: IO a -> IO (Maybe a)
binaryNotFound :: forall a. IO a -> IO (Maybe a)
binaryNotFound = forall e a. Exception e => (e -> Bool) -> IO a -> IO (Maybe a)
Exceptions.ignoreError 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 = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*NominalDiffTime
1000000)

-- * util

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 forall a b. (a -> b) -> a -> b
$ String
fn 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 -> forall a. (a -> Bool) -> [a] -> [a]
takeWhile (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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not 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
    -- Ignore the exit code, because ps -p returns 1 when the pid doesn't
    -- exist.
    (ExitCode
_, String
output, String
_) <- String -> [String] -> String -> IO (ExitCode, String, String)
Process.readProcessWithExitCode
        String
"ps" [String
"-p", forall a. Show a => a -> String
show ProcessID
pid, String
"-o", String
"comm"] String
""
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case String -> [String]
lines String
output of
        [String
_, String
cmd] -> forall a. a -> Maybe a
Just String
cmd
        [String]
_ -> forall a. Maybe a
Nothing

exit :: Int -> IO a
exit :: forall a. Int -> IO a
exit Int
0 = forall a. IO a
Exit.exitSuccess
exit Int
n = forall a. ExitCode -> IO a
Exit.exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
Exit.ExitFailure Int
n