From fe98c97b1cbc156b1ba7dc43d41a820f55906aab Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Thu, 29 Nov 2018 22:32:21 +0100
Subject: Text.Pandoc.Process: update pipeProcess
The implementation of `pipeProcess` was rewritten to fix sporadic
failures caused by prematurely closed pipes.
---
src/Text/Pandoc/Process.hs | 91 ++++++++++++++++++++++++++++++----------------
1 file changed, 60 insertions(+), 31 deletions(-)
(limited to 'src/Text')
diff --git a/src/Text/Pandoc/Process.hs b/src/Text/Pandoc/Process.hs
index 868977c86..c22e85ec0 100644
--- a/src/Text/Pandoc/Process.hs
+++ b/src/Text/Pandoc/Process.hs
@@ -31,12 +31,17 @@ ByteString variant of 'readProcessWithExitCode'.
module Text.Pandoc.Process (pipeProcess)
where
import Prelude
-import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
-import Control.Exception
+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, hFlush)
+import System.IO (hClose)
import System.Process
{- |
@@ -52,49 +57,73 @@ 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 mbenv cmd args input =
- mask $ \restore -> do
- (Just inh, Just outh, Nothing, pid) <- createProcess (proc cmd args)
- { env = mbenv,
- std_in = CreatePipe,
- std_out = CreatePipe,
- std_err = Inherit }
- flip onException
- (do hClose inh; hClose outh;
- terminateProcess pid; waitForProcess pid) $ restore $ do
- -- fork off a thread to start consuming stdout
+pipeProcess mbenv cmd args input = do
+ let cp_opts = (proc cmd args)
+ { env = mbenv
+ , std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ }
+ withCreateProcess cp_opts $
+ \mbInh mbOuth _ pid -> do
+ let Just inh = mbInh
+ Just outh = mbOuth
+
out <- BL.hGetContents outh
- waitOut <- forkWait $ evaluate $ BL.length out
- -- now write and flush any input
- let writeInput = do
- unless (BL.null input) $ do
- BL.hPutStr inh input
- hFlush inh
- hClose inh
+ -- fork off threads to start consuming stdout & stderr
+ withForkWait (E.evaluate $ rnf out) $ \waitOut -> do
- writeInput
+ -- now write any input
+ unless (BL.null input) $
+ ignoreSigPipe $ BL.hPutStr inh input
+ -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+ ignoreSigPipe $ hClose inh
- -- wait on the output
- waitOut
+ -- wait on the output
+ waitOut
- hClose outh
+ hClose outh
-- wait on the process
ex <- waitForProcess pid
return (ex, out)
-forkWait :: IO a -> IO (IO a)
-forkWait a = do
- res <- newEmptyMVar
- _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res
- return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return)
+-- | 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 async body = do
+ waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
+ E.mask $ \restore -> do
+ tid <- forkIO $ E.try (restore async) >>= putMVar waitVar
+ let wait = takeMVar waitVar >>= either E.throwIO 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 = E.handle $ \e ->
+ case e of
+ IOError { ioe_type = ResourceVanished
+ , ioe_errno = Just ioe }
+ | Errno ioe == ePIPE -> return ()
+ _ -> E.throwIO e
--
cgit v1.2.3