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, 3 years ago)

patch 1/2 addressing this ticket

  • Network/Browser.hs

    From e5f1d16ff456df869ccf1239bbaf697f3126a21d Mon Sep 17 00:00:00 2001
    From: Daniel Wagner <daniel@wagner-home.com>
    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