-- 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 <- 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)

-- | 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 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
    -- 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
    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

-- | 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 = 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
    -- If the binary doesn't exist, sometimes 'create' notices, and sometimes
    -- waitForProcess notices.  I think it's dependent on GHC version.
    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)

-- | 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 = (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
    -- 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 = 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

-- | 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 = 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)

-- * conversation

data TalkOut = Stdout !Text | Stderr !Text
    -- | This always terminates the conversation, and effectively marks the
    -- channel closed.
    | 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

-- | 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 <- 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)

-- | 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
    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
    -- Apparently binary not found is detected in createProcess.  I think in
    -- previous versions it was detected in waitForProcess.
    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
            -- Ensure both stdout and stderr are flushed before exit.
            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]
                -- 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 <- 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
        }

-- | 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 = (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)

-- * 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 ([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
    -- 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", 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