    {- |
       Module      : Text.Pandoc.Process
       Copyright   : Copyright (C) 2013-2024 John MacFarlane
       License     : GNU GPL, version 2 or above

       Maintainer  : John MacFarlane <jgm@berkeley.edu>
       Stability   : alpha
       Portability : portable

    ByteString variant of 'readProcessWithExitCode'.
    -}
    module Text.Pandoc.Process (pipeProcess)
    where
    import Control.Concurrent (MVar, forkIO, killThread, newEmptyMVar, putMVar,
                               takeMVar)
    import Control.Exception (SomeException (..))
    import qualified Control.Exception as E
    import Control.Monad (unless)
    import Control.DeepSeq (rnf)
    import qualified Data.ByteString.Lazy as BL
    import Foreign.C (Errno (Errno), ePIPE)
    import GHC.IO.Exception (IOErrorType(..), IOException(..))
    import System.Exit (ExitCode (..))
    import System.IO (hClose)
    import System.Process

    {- |
    Version of 'System.Process.readProcessWithExitCode' that uses lazy bytestrings
    instead of strings and allows setting environment variables.

    @readProcessWithExitCode@ creates an external process, reads its
    standard output strictly, waits until the process
    terminates, and then returns the 'ExitCode' of the process
    and the standard output.  stderr is inherited from the parent.

    If an asynchronous exception is thrown to the thread executing
    @readProcessWithExitCode@, the forked process will be terminated and
    @readProcessWithExitCode@ will wait (block) until the process has been
    terminated.

    This function was adapted from @readProcessWithExitCode@ of module
    System.Process, package process-1.6.3.0. The original code is BSD
    licensed and © University of Glasgow 2004-2008.
    -}
    pipeProcess
        :: Maybe [(String, String)] -- ^ environment variables
        -> FilePath                 -- ^ Filename of the executable (see 'proc' for details)
        -> [String]                 -- ^ any arguments
        -> BL.ByteString            -- ^ standard input
        -> IO (ExitCode,BL.ByteString) -- ^ exitcode, stdout
    pipeProcess :: Maybe [(String, String)]
    -> String -> [String] -> ByteString -> IO (ExitCode, ByteString)
    pipeProcess Maybe [(String, String)]
    mbenv String
    cmd [String]
    args ByteString
    input = do
        let cp_opts :: CreateProcess
    cp_opts = (String -> [String] -> CreateProcess
    proc String
    cmd [String]
    args)
                      { env     = mbenv
                      , std_in  = CreatePipe
                      , std_out = CreatePipe
                      , std_err = Inherit
                      }
        CreateProcess
    -> (Maybe Handle
        -> Maybe Handle
        -> Maybe Handle
        -> ProcessHandle
        -> IO (ExitCode, ByteString))
    -> IO (ExitCode, ByteString)
    forall a.
    CreateProcess
    -> (Maybe Handle
        -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
    -> IO a
    withCreateProcess CreateProcess
    cp_opts ((Maybe Handle
      -> Maybe Handle
      -> Maybe Handle
      -> ProcessHandle
      -> IO (ExitCode, ByteString))
     -> IO (ExitCode, ByteString))
    -> (Maybe Handle
        -> Maybe Handle
        -> Maybe Handle
        -> ProcessHandle
        -> IO (ExitCode, ByteString))
    -> IO (ExitCode, ByteString)
    forall a b. (a -> b) -> a -> b
    $
          \Maybe Handle
    mbInh Maybe Handle
    mbOuth Maybe Handle
    _ ProcessHandle
    pid -> do
            let (Handle
    inh, Handle
    outh) =
                 case (Maybe Handle
    mbInh, Maybe Handle
    mbOuth) of
                      (Just Handle
    i, Just Handle
    o) -> (Handle
    i, Handle
    o)
                      (Maybe Handle
    Nothing, Maybe Handle
    _)     -> String -> (Handle, Handle)
    forall a. HasCallStack => String -> a
    error String
    "withCreateProcess no inh"
                      (Maybe Handle
    _, Maybe Handle
    Nothing)     -> String -> (Handle, Handle)
    forall a. HasCallStack => String -> a
    error String
    "withCreateProcess no outh"

            out <- Handle -> IO ByteString
    BL.hGetContents Handle
    outh

            -- fork off threads to start consuming stdout & stderr
            withForkWait (E.evaluate $ rnf out) $ \IO ()
    waitOut -> do

              -- now write any input
              Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (ByteString -> Bool
    BL.null ByteString
    input) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                IO () -> IO ()
    ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> ByteString -> IO ()
    BL.hPutStr Handle
    inh ByteString
    input
              -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
              IO () -> IO ()
    ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> IO ()
    hClose Handle
    inh

              -- wait on the output
              IO ()
    waitOut

              Handle -> IO ()
    hClose Handle
    outh

            -- wait on the process
            ex <- waitForProcess pid

            return (ex, out)

    -- | Fork a thread while doing something else, but kill it if there's an
    -- exception.
    --
    -- This is important in the cases above because we want to kill the thread
    -- that is holding the Handle lock, because when we clean up the process we
    -- try to close that handle, which could otherwise deadlock.
    --
    -- This function was copied verbatim from module System.Process of package
    -- process-1.6.3.0.
    withForkWait :: IO () -> (IO () ->  IO a) -> IO a
    withForkWait :: forall a. IO () -> (IO () -> IO a) -> IO a
    withForkWait IO ()
    async IO () -> IO a
    body = do
      waitVar <- IO (MVar (Either SomeException ()))
    forall a. IO (MVar a)
    newEmptyMVar :: IO (MVar (Either SomeException ()))
      E.mask $ \forall a. IO a -> IO a
    restore -> do
        tid <- IO () -> IO ThreadId
    forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
    forall a b. (a -> b) -> a -> b
    $ IO () -> IO (Either SomeException ())
    forall e a. Exception e => IO a -> IO (Either e a)
    E.try (IO () -> IO ()
    forall a. IO a -> IO a
    restore IO ()
    async) IO (Either SomeException ())
    -> (Either SomeException () -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MVar (Either SomeException ()) -> Either SomeException () -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Either SomeException ())
    waitVar
        let wait = MVar (Either SomeException ()) -> IO (Either SomeException ())
    forall a. MVar a -> IO a
    takeMVar MVar (Either SomeException ())
    waitVar IO (Either SomeException ())
    -> (Either SomeException () -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (SomeException -> IO ())
    -> (() -> IO ()) -> Either SomeException () -> IO ()
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either SomeException -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    E.throwIO () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
        restore (body wait) `E.onException` killThread tid

    -- This function was copied verbatim from module System.Process of package
    -- process-1.6.3.0.
    ignoreSigPipe :: IO () -> IO ()
    ignoreSigPipe :: IO () -> IO ()
    ignoreSigPipe = (IOException -> IO ()) -> IO () -> IO ()
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
    E.handle ((IOException -> IO ()) -> IO () -> IO ())
    -> (IOException -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \IOException
    e ->
      case IOException
    e of
        IOError { ioe_type :: IOException -> IOErrorType
    ioe_type  = IOErrorType
    ResourceVanished
                , ioe_errno :: IOException -> Maybe CInt
    ioe_errno = Just CInt
    ioe }
          | CInt -> Errno
    Errno CInt
    ioe Errno -> Errno -> Bool
    forall a. Eq a => a -> a -> Bool
    == Errno
    ePIPE -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        IOException
    _ -> IOException -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    E.throwIO IOException
    e