Ticket #5766: 0001-Fixed-asynchronous-exception-bugs-in-readProcess.patch

File 0001-Fixed-asynchronous-exception-bugs-in-readProcess.patch, 11.6 KB (added by basvandijk, 4 years ago)
  • System/Process.hs

    From fdcfb242420d4af553de54df9bac85d30c01a757 Mon Sep 17 00:00:00 2001
    From: Bas van Dijk <[email protected]>
    Date: Tue, 7 Feb 2012 20:18:57 +0100
    Subject: [PATCH] Fixed asynchronous exception bugs in readProcess and
     readProcessWithExitCode This patch fixes the following two
     bugs:
    
    1) If an asynchronous exception was thrown to the thread executing
       readProcess somewhere after createProcess was executed, the standard handles
       would not be closed anymore resulting in a "handle leak" so to speak.
    
       This is fixed by catching exceptions in the IO processing code and
       closing the standard handles when an exception occurs.
       Additionally, I also terminate the process and wait for its termination.
    
    2) If an asynchronous exception was thrown to the
       stdout/stderr-read-thread it did not execute the putMVar anymore
       resulting in a dead-lock when takeMVar was executed.
    
       This is fixed by properly catching exception in the read-thread
       and propagating them to the parent thread which will then handle
       them as described above.
    ---
     System/Process.hs |  162 ++++++++++++++++++++++++++++++-----------------------
     process.cabal     |    3 +-
     2 files changed, 94 insertions(+), 71 deletions(-)
    
    diff --git a/System/Process.hs b/System/Process.hs
    index f3a8f9b..1acb308 100644
    a b  
    2222--      * Flag to control whether exiting the parent also kills the child.
    2323
    2424{- NOTES on createPipe:
    25  
     25
    2626   createPipe is no longer exported, because of the following problems:
    2727
    2828        - it wasn't used to implement runInteractiveProcess on Unix, because
    import Prelude hiding (mapM) 
    7070#ifndef __HUGS__
    7171import System.Process.Internals
    7272
    73 import System.IO.Error
     73import Control.Exception (SomeException, mask, try, onException, throwIO)
     74import Control.DeepSeq (rnf)
     75import System.IO.Error (mkIOError, ioeSetErrorString)
    7476#if !defined(mingw32_HOST_OS)
    7577import System.Posix.Types
    7678#if MIN_VERSION_unix(2,5,0)
    runCommand string = do 
    132134     process (otherwise these handles are inherited from the current
    133135     process).
    134136
    135      Any 'Handle's passed to 'runProcess' are placed immediately in the 
     137     Any 'Handle's passed to 'runProcess' are placed immediately in the
    136138     closed state.
    137139
    138140     Note: consider using the more general 'createProcess' instead of
    fill in the fields with default values which can be overriden as 
    212214needed.
    213215
    214216'createProcess' returns @(mb_stdin_hdl, mb_stdout_hdl, mb_stderr_hdl, p)@,
    215 where 
     217where
    216218
    217219 * if @std_in == CreatePipe@, then @mb_stdin_hdl@ will be @Just h@,
    218220   where @h@ is the write end of the pipe connected to the child
    runInteractiveCommand string = 
    275277     with the process via its @stdin@, @stdout@ and @stderr@ respectively.
    276278
    277279    For example, to start a process and feed a string to its stdin:
    278    
     280
    279281>   (inp,out,err,pid) <- runInteractiveProcess "..."
    280282>   forkIO (hPutStr inp str)
    281283
    runInteractiveProcess 
    290292  -> IO (Handle,Handle,Handle,ProcessHandle)
    291293
    292294runInteractiveProcess cmd args mb_cwd mb_env = do
    293   runInteractiveProcess1 "runInteractiveProcess" 
     295  runInteractiveProcess1 "runInteractiveProcess"
    294296        (proc cmd args){ cwd = mb_cwd, env = mb_env }
    295297
    296298runInteractiveProcess1
    runInteractiveProcess1 
    298300  -> CreateProcess
    299301  -> IO (Handle,Handle,Handle,ProcessHandle)
    300302runInteractiveProcess1 fun cmd = do
    301   (mb_in, mb_out, mb_err, p) <- 
     303  (mb_in, mb_out, mb_err, p) <-
    302304      runGenProcess_ fun
    303305           cmd{ std_in  = CreatePipe,
    304306                std_out = CreatePipe,
    305                 std_err = CreatePipe } 
     307                std_err = CreatePipe }
    306308           Nothing Nothing
    307309  return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)
    308310
    runInteractiveProcess1 fun cmd = do 
    310312-- waitForProcess
    311313
    312314{- | Waits for the specified process to terminate, and returns its exit code.
    313    
     315
    314316     GHC Note: in order to call @waitForProcess@ without blocking all the
    315317     other threads in the system, you must compile the program with
    316318     @-threaded@.
    waitForProcess ph = do 
    341343
    342344-- -----------------------------------------------------------------------------
    343345--
    344 -- | readProcess forks an external process, reads its standard output
     346-- | @readProcess@ forks an external process, reads its standard output
    345347-- strictly, blocking until the process terminates, and returns the output
    346348-- string.
    347349--
     350-- If an asynchronous exception is thrown to the thread executing
     351-- @readProcess@. The forked process will be terminated and @readProcess@ will
     352-- wait (block) until the process has been terminated.
     353--
    348354-- Output is returned strictly, so this is not suitable for
    349355-- interactive applications.
    350356--
    waitForProcess ph = do 
    366372--
    367373-- * A string to pass on the standard input to the program.
    368374--
    369 readProcess 
     375readProcess
    370376    :: FilePath                 -- ^ command to run
    371377    -> [String]                 -- ^ any arguments
    372378    -> String                   -- ^ standard input
    373379    -> IO String                -- ^ stdout
    374 readProcess cmd args input = do
    375     (Just inh, Just outh, _, pid) <-
     380readProcess cmd args input =
     381    mask $ \restore -> do
     382      (Just inh, Just outh, _, pid) <-
    376383        createProcess (proc cmd args){ std_in  = CreatePipe,
    377384                                       std_out = CreatePipe,
    378385                                       std_err = Inherit }
    379 
    380     -- fork off a thread to start consuming the output
    381     output  <- hGetContents outh
    382     outMVar <- newEmptyMVar
    383     _ <- forkIO $ C.evaluate (length output) >> putMVar outMVar ()
    384 
    385     -- now write and flush any input
    386     when (not (null input)) $ do hPutStr inh input; hFlush inh
    387     hClose inh -- done with stdin
    388 
    389     -- wait on the output
    390     takeMVar outMVar
    391     hClose outh
    392 
    393     -- wait on the process
    394     ex <- waitForProcess pid
    395 
    396     case ex of
    397      ExitSuccess   -> return output
    398      ExitFailure r ->
    399       ioError (mkIOError OtherError ("readProcess: " ++ cmd ++
    400                                      ' ':unwords (map show args) ++
    401                                      " (exit " ++ show r ++ ")")
    402                                  Nothing Nothing)
     386      flip onException
     387        (do hClose inh; hClose outh;
     388            terminateProcess pid; waitForProcess pid) $ restore $ do
     389        -- fork off a thread to start consuming the output
     390        output  <- hGetContents outh
     391        waitOut <- forkWait $ C.evaluate $ rnf output
     392
     393        -- now write and flush any input
     394        when (not (null input)) $ do hPutStr inh input; hFlush inh
     395        hClose inh -- done with stdin
     396
     397        -- wait on the output
     398        waitOut
     399        hClose outh
     400
     401        -- wait on the process
     402        ex <- waitForProcess pid
     403
     404        case ex of
     405         ExitSuccess   -> return output
     406         ExitFailure r ->
     407          ioError (mkIOError OtherError ("readProcess: " ++ cmd ++
     408                                         ' ':unwords (map show args) ++
     409                                         " (exit " ++ show r ++ ")")
     410                                     Nothing Nothing)
    403411
    404412{- |
    405 readProcessWithExitCode creates an external process, reads its
     413@readProcessWithExitCode@ creates an external process, reads its
    406414standard output and standard error strictly, waits until the process
    407415terminates, and then returns the 'ExitCode' of the process,
    408416the standard output, and the standard error.
    409417
     418If an asynchronous exception is thrown to the thread executing
     419@readProcessWithExitCode@. The forked process will be terminated and
     420@readProcessWithExitCode@ will wait (block) until the process has been
     421terminated.
     422
    410423'readProcess' and 'readProcessWithExitCode' are fairly simple wrappers
    411424around 'createProcess'.  Constructing variants of these functions is
    412425quite easy: follow the link to the source code to see how
    readProcessWithExitCode 
    418431    -> [String]                 -- ^ any arguments
    419432    -> String                   -- ^ standard input
    420433    -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr
    421 readProcessWithExitCode cmd args input = do
    422     (Just inh, Just outh, Just errh, pid) <-
    423         createProcess (proc cmd args){ std_in  = CreatePipe,
    424                                        std_out = CreatePipe,
    425                                        std_err = CreatePipe }
    426 
    427     outMVar <- newEmptyMVar
    428 
    429     -- fork off a thread to start consuming stdout
    430     out  <- hGetContents outh
    431     _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar ()
    432 
    433     -- fork off a thread to start consuming stderr
    434     err  <- hGetContents errh
    435     _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar ()
    436 
    437     -- now write and flush any input
    438     when (not (null input)) $ do hPutStr inh input; hFlush inh
    439     hClose inh -- done with stdin
     434readProcessWithExitCode cmd args input =
     435    mask $ \restore -> do
     436      (Just inh, Just outh, Just errh, pid) <- createProcess (proc cmd args)
     437                                                   { std_in  = CreatePipe,
     438                                                     std_out = CreatePipe,
     439                                                     std_err = CreatePipe }
     440      flip onException
     441        (do hClose inh; hClose outh; hClose errh;
     442            terminateProcess pid; waitForProcess pid) $ restore $ do
     443        -- fork off a thread to start consuming stdout
     444        out <- hGetContents outh
     445        waitOut <- forkWait $ C.evaluate $ rnf out
     446
     447        -- fork off a thread to start consuming stderr
     448        err <- hGetContents errh
     449        waitErr <- forkWait $ C.evaluate $ rnf err
     450
     451        -- now write and flush any input
     452        when (not (null input)) $ do hPutStr inh input; hFlush inh
     453        hClose inh -- done with stdin
     454
     455        -- wait on the output
     456        waitOut
     457        waitErr
     458
     459        hClose outh
     460        hClose errh
     461
     462        -- wait on the process
     463        ex <- waitForProcess pid
     464
     465        return (ex, out, err)
     466
     467forkWait :: IO a -> IO (IO a)
     468forkWait a = do
     469  res <- newEmptyMVar
     470  _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res
     471  return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return)
    440472
    441     -- wait on the output
    442     takeMVar outMVar
    443     takeMVar outMVar
    444     hClose outh
    445     hClose errh
    446 
    447     -- wait on the process
    448     ex <- waitForProcess pid
    449 
    450     return (ex, out, err)
    451473#endif /* !__HUGS__ */
    452474
    453475-- ---------------------------------------------------------------------------
    454476-- system
    455477
    456 {-| 
     478{-|
    457479Computation @system cmd@ returns the exit code produced when the
    458480operating system runs the shell command @cmd@.
    459481
    showCommandForUser cmd args = unwords (map translate (cmd : args)) 
    552574terminateProcess :: ProcessHandle -> IO ()
    553575terminateProcess ph = do
    554576  withProcessHandle_ ph $ \p_ ->
    555     case p_ of 
     577    case p_ of
    556578      ClosedHandle _ -> return p_
    557579      OpenHandle h -> do
    558580        throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h
    interruptProcessGroupOf ph = do 
    600622-- ----------------------------------------------------------------------------
    601623-- getProcessExitCode
    602624
    603 {- | 
     625{- |
    604626This is a non-blocking version of 'waitForProcess'.  If the process is
    605627still running, 'Nothing' is returned.  If the process has exited, then
    606628@'Just' e@ is returned where @e@ is the exit code of the process.
  • process.cabal

    diff --git a/process.cabal b/process.cabal
    index aaf232b..a3c99c8 100644
    a b Library { 
    5858  }
    5959
    6060  build-depends: directory >= 1.0 && < 1.2,
    61                  filepath  >= 1.1 && < 1.3
     61                 filepath  >= 1.1 && < 1.3,
     62                 deepseq   >= 1.1 && < 1.4
    6263
    6364  extensions: CPP
    6465}