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
pipeProcess
:: Maybe [(String, String)]
-> FilePath
-> [String]
-> BL.ByteString
-> IO (ExitCode,BL.ByteString)
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 :: Maybe [(String, String)]
env = Maybe [(String, String)]
mbenv
, std_in :: StdStream
std_in = StdStream
CreatePipe
, std_out :: StdStream
std_out = StdStream
CreatePipe
, std_err :: StdStream
std_err = StdStream
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"
ByteString
out <- Handle -> IO ByteString
BL.hGetContents Handle
outh
IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
E.evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
out) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
waitOut -> do
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
IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
inh
IO ()
waitOut
Handle -> IO ()
hClose Handle
outh
ExitCode
ex <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
(ExitCode, ByteString) -> IO (ExitCode, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, ByteString
out)
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait :: forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait IO ()
async IO () -> IO a
body = do
MVar (Either SomeException ())
waitVar <- IO (MVar (Either SomeException ()))
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar (Either SomeException ()))
((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
ThreadId
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 :: IO ()
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. Exception e => e -> IO a
E.throwIO () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
IO a -> IO a
forall a. IO a -> IO a
restore (IO () -> IO a
body IO ()
wait) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`E.onException` ThreadId -> IO ()
killThread ThreadId
tid
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. Exception e => e -> IO a
E.throwIO IOException
e