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, 3 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}