Ticket #4251: 0001-prevent-infinite-loop-when-reading-EOF.patch

File 0001-prevent-infinite-loop-when-reading-EOF.patch, 7.3 KB (added by dmwit, 5 years ago)

patch 1/2 addressing this ticket

  • Network/Browser.hs

    From e5f1d16ff456df869ccf1239bbaf697f3126a21d Mon Sep 17 00:00:00 2001
    From: Daniel Wagner <[email protected]>
    Date: Thu, 21 Oct 2010 22:11:56 -0400
    Subject: [PATCH 1/2] prevent infinite loop when reading EOF
    
    See also: http://hackage.haskell.org/trac/ghc/ticket/4251
    ---
     Network/Browser.hs           |    2 +-
     Network/HTTP/HandleStream.hs |    6 +++---
     Network/HTTP/Stream.hs       |    6 +++---
     Network/Stream.hs            |    3 ++-
     Network/StreamDebugger.hs    |    4 ++--
     Network/StreamSocket.hs      |    2 +-
     Network/TCP.hs               |   13 +++++++------
     7 files changed, 19 insertions(+), 17 deletions(-)
    
    diff --git a/Network/Browser.hs b/Network/Browser.hs
    index 8756c98..e2534cb 100644
    a b updateConnectionPool c = do 
    977977   pool <- getBS bsConnectionPool
    978978   let len_pool = length pool
    979979   when (len_pool > maxPoolSize)
    980         (ioAction $ close (last pool))
     980        (ioAction $ close (last pool) True)
    981981   let pool'
    982982        | len_pool > maxPoolSize = init pool
    983983        | otherwise              = pool
  • Network/HTTP/HandleStream.hs

    diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs
    index 366f457..85b8247 100644
    a b sendHTTP_notify :: HStream ty 
    8787sendHTTP_notify conn rq onSendComplete = do
    8888  when providedClose $ (closeOnEnd conn True)
    8989  catchIO (sendMain conn rq onSendComplete)
    90           (\e -> do { close conn; ioError e })
     90          (\e -> do { close conn True; ioError e })
    9191 where
    9292  providedClose = findConnClose (rqHeaders rq)
    9393
    switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = 
    160160       return (Right $ Response cd rn hdrs (buf_empty bufferOps))
    161161
    162162     DieHorribly str -> do
    163        close conn
     163       close conn True
    164164       return (responseParseError "Invalid response:" str)
    165165     ExpectEntity -> do
    166166       r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $
    switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = 
    175175                   tc
    176176       case r of
    177177         Left{} -> do
    178            close conn
     178           close conn True
    179179           return r
    180180         Right (Response _ _ hs _) -> do
    181181           when (findConnClose hs)
  • Network/HTTP/Stream.hs

    diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs
    index 5951e88..f95aa23 100644
    a b sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Respon 
    8787sendHTTP_notify conn rq onSendComplete = do
    8888   when providedClose $ (closeOnEnd conn True)
    8989   catchIO (sendMain conn rq onSendComplete)
    90            (\e -> do { close conn; ioError e })
     90           (\e -> do { close conn True; ioError e })
    9191 where
    9292  providedClose = findConnClose (rqHeaders rq)
    9393
    switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = 
    164164                    return (Right $ Response cd rn hdrs "")
    165165
    166166                DieHorribly str -> do
    167                     close conn
     167                    close conn True
    168168                    return $ responseParseError "sendHTTP" ("Invalid response: " ++ str)
    169169
    170170                ExpectEntity ->
    switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = 
    182182                                                               (readLine conn) (readBlock conn)
    183183                                  _         -> uglyDeathTransfer "sendHTTP"
    184184                       ; case rslt of
    185                            Left e -> close conn >> return (Left e)
     185                           Left e -> close conn True >> return (Left e)
    186186                           Right (ftrs,bdy) -> do
    187187                            when (findConnClose (hdrs++ftrs))
    188188                                 (closeOnEnd conn True)
  • Network/Stream.hs

    diff --git a/Network/Stream.hs b/Network/Stream.hs
    index 0083221..4e65791 100644
    a b class Stream x where 
    7878    readLine   :: x -> IO (Result String)
    7979    readBlock  :: x -> Int -> IO (Result String)
    8080    writeBlock :: x -> String -> IO (Result ())
    81     close      :: x -> IO ()
     81    close      :: x -> Bool -> IO ()
     82      -- ^ True => please munch the rest of the stream before closing
    8283    closeOnEnd :: x -> Bool -> IO ()
    8384      -- ^ True => shutdown the connection when response has been read / end-of-stream
    8485      --           has been reached.
  • Network/StreamDebugger.hs

    diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs
    index 645c7ea..d364a37 100644
    a b instance (Stream x) => Stream (StreamDebugger x) where 
    4848           hPutStrLn h ("--writeBlock" ++ show str)
    4949           hPutStrLn h (show val)
    5050           return val
    51     close (Dbg h x) =
     51    close (Dbg h x) b =
    5252        do hPutStrLn h "--closing..."
    5353           hFlush h
    54            close x
     54           close x b
    5555           hPutStrLn h "--closed."
    5656           hClose h
    5757    closeOnEnd (Dbg h x) f =
  • Network/StreamSocket.hs

    diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs
    index d8c1ed9..5d09e6c 100644
    a b instance Stream Socket where 
    5555    readBlock sk n    = readBlockSocket sk n
    5656    readLine sk       = readLineSocket sk
    5757    writeBlock sk str = writeBlockSocket sk str
    58     close sk          = do
     58    close sk _        = do
    5959        -- This slams closed the connection (which is considered rude for TCP\/IP)
    6060         shutdown sk ShutdownBoth
    6161         sClose sk
  • Network/TCP.hs

    diff --git a/Network/TCP.hs b/Network/TCP.hs
    index 6944ccb..beae599 100644
    a b class BufferType bufType => HStream bufType where 
    138138  readLine         :: HandleStream bufType -> IO (Result bufType)
    139139  readBlock        :: HandleStream bufType -> Int -> IO (Result bufType)
    140140  writeBlock       :: HandleStream bufType -> bufType -> IO (Result ())
    141   close            :: HandleStream bufType -> IO ()
     141  close            :: HandleStream bufType -> Bool -> IO ()
     142    -- ^ True => please munch the rest of the stream before closing
    142143  closeOnEnd       :: HandleStream bufType -> Bool -> IO ()
    143144 
    144145instance HStream Strict.ByteString where
    writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do 
    325326        (connHooks' conn)
    326327  return x
    327328
    328 closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> IO ()
    329 closeIt c p = do
    330    closeConnection c (readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True})
     329closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
     330closeIt c p b = do
     331   closeConnection c (if b then readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True} else return True)
    331332   conn <- readMVar (getRef c)
    332333   maybe (return ())
    333334         (hook_close)
    bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do 
    348349                    (\ e ->
    349350                       if isEOFError e
    350351                        then do
    351                           when (connCloseEOF conn) $ catch (close ref) (\ _ -> return ())
     352                          when (connCloseEOF conn) $ catch (close ref False) (\ _ -> return ())
    352353                          return (return (buf_empty (connBuffer conn)))
    353354                        else return (fail (show e)))
    354355
    bufferReadLine ref = onNonClosedDo ref $ \ conn -> do 
    371372              (\ e ->
    372373                 if isEOFError e
    373374                  then do
    374                     when (connCloseEOF conn) $ catch (close ref) (\ _ -> return ())
     375                    when (connCloseEOF conn) $ catch (close ref False) (\ _ -> return ())
    375376                    return (return   (buf_empty (connBuffer conn)))
    376377                  else return (fail (show e)))
    377378 where