@@ -31,12 +31,17 @@ ByteString variant of 'readProcessWithExitCode'.
3131module Text.Pandoc.Process (pipeProcess)
3232where
3333import Prelude
34−import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
35−import Control.Exception
34+import Control.Concurrent (MVar, forkIO, killThread, newEmptyMVar, putMVar,
35+ takeMVar)
36+import Control.Exception (SomeException (..))
37+import qualified Control.Exception as E
3638import Control.Monad (unless)
39+import Control.DeepSeq (rnf)
3740import qualified Data.ByteString.Lazy as BL
41+import Foreign.C (Errno (Errno), ePIPE)
42+import GHC.IO.Exception (IOErrorType(..), IOException(..))
3843import System.Exit (ExitCode (..))
39−import System.IO (hClose, hFlush)
44+import System.IO (hClose)
4045import System.Process
4146
4247{- |
@@ -52,49 +57,73 @@ If an asynchronous exception is thrown to the thread executing
5257@readProcessWithExitCode@, the forked process will be terminated and
5358@readProcessWithExitCode@ will wait (block) until the process has been
5459terminated.
55−-}
5660
61+This function was adapted from @readProcessWithExitCode@ of module
62+System.Process, package process-1.6.3.0. The original code is BSD
63+licensed and © University of Glasgow 2004-2008.
64+-}
5765pipeProcess
5866 :: Maybe [(String, String)] -- ^ environment variables
5967 -> FilePath -- ^ Filename of the executable (see 'proc' for details)
6068 -> [String] -- ^ any arguments
6169 -> BL.ByteString -- ^ standard input
6270 -> IO (ExitCode,BL.ByteString) -- ^ exitcode, stdout
63−pipeProcess mbenv cmd args input =
64− mask $ \restore -> do
65− (Just inh, Just outh, Nothing, pid) <- createProcess (proc cmd args)
66− { env = mbenv,
67− std_in = CreatePipe,
68− std_out = CreatePipe,
69− std_err = Inherit }
70− flip onException
71− (do hClose inh; hClose outh;
72− terminateProcess pid; waitForProcess pid) $ restore $ do
73− -- fork off a thread to start consuming stdout
71+pipeProcess mbenv cmd args input = do
72+ let cp_opts = (proc cmd args)
73+ { env = mbenv
74+ , std_in = CreatePipe
75+ , std_out = CreatePipe
76+ , std_err = Inherit
77+ }
78+ withCreateProcess cp_opts $
79+ \mbInh mbOuth _ pid -> do
80+ let Just inh = mbInh
81+ Just outh = mbOuth
82+
7483 out <- BL.hGetContents outh
75− waitOut <- forkWait $ evaluate $ BL.length out
7684
77− -- now write and flush any input
78− let writeInput = do
79− unless (BL.null input) $ do
80− BL.hPutStr inh input
81− hFlush inh
82− hClose inh
85+ -- fork off threads to start consuming stdout & stderr
86+ withForkWait (E.evaluate $ rnf out) $ \waitOut -> do
8387
84− writeInput
88+ -- now write any input
89+ unless (BL.null input) $
90+ ignoreSigPipe $ BL.hPutStr inh input
91+ -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
92+ ignoreSigPipe $ hClose inh
8593
86− -- wait on the output
87− waitOut
94+ -- wait on the output
95+ waitOut
8896
89− hClose outh
97+ hClose outh
9098
9199 -- wait on the process
92100 ex <- waitForProcess pid
93101
94102 return (ex, out)
95103
96−forkWait :: IO a -> IO (IO a)
97−forkWait a = do
98− res <- newEmptyMVar
99− _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res
100− return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return)
104+-- | Fork a thread while doing something else, but kill it if there's an
105+-- exception.
106+--
107+-- This is important in the cases above because we want to kill the thread
108+-- that is holding the Handle lock, because when we clean up the process we
109+-- try to close that handle, which could otherwise deadlock.
110+--
111+-- This function was copied verbatim from module System.Process of package
112+-- process-1.6.3.0.
113+withForkWait :: IO () -> (IO () -> IO a) -> IO a
114+withForkWait async body = do
115+ waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
116+ E.mask $ \restore -> do
117+ tid <- forkIO $ E.try (restore async) >>= putMVar waitVar
118+ let wait = takeMVar waitVar >>= either E.throwIO return
119+ restore (body wait) `E.onException` killThread tid
120+
121+-- This function was copied verbatim from module System.Process of package
122+-- process-1.6.3.0.
123+ignoreSigPipe :: IO () -> IO ()
124+ignoreSigPipe = E.handle $ \e ->
125+ case e of
126+ IOError { ioe_type = ResourceVanished
127+ , ioe_errno = Just ioe }
128+ | Errno ioe == ePIPE -> return ()
129+ _ -> E.throwIO e