From e5f1d16ff456df869ccf1239bbaf697f3126a21d Mon Sep 17 00:00:00 2001 From: Daniel Wagner 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/Network/Browser.hs +++ b/Network/Browser.hs @@ -977,7 +977,7 @@ updateConnectionPool c = do pool <- getBS bsConnectionPool let len_pool = length pool when (len_pool > maxPoolSize) - (ioAction $ close (last pool)) + (ioAction $ close (last pool) True) let pool' | len_pool > maxPoolSize = init pool | otherwise = pool diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs index 366f457..85b8247 100644 --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -87,7 +87,7 @@ sendHTTP_notify :: HStream ty sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True) catchIO (sendMain conn rq onSendComplete) - (\e -> do { close conn; ioError e }) + (\e -> do { close conn True; ioError e }) where providedClose = findConnClose (rqHeaders rq) @@ -160,7 +160,7 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = return (Right $ Response cd rn hdrs (buf_empty bufferOps)) DieHorribly str -> do - close conn + close conn True return (responseParseError "Invalid response:" str) ExpectEntity -> do r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ @@ -175,7 +175,7 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = tc case r of Left{} -> do - close conn + close conn True return r Right (Response _ _ hs _) -> do when (findConnClose hs) diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs index 5951e88..f95aa23 100644 --- a/Network/HTTP/Stream.hs +++ b/Network/HTTP/Stream.hs @@ -87,7 +87,7 @@ sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Respon sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True) catchIO (sendMain conn rq onSendComplete) - (\e -> do { close conn; ioError e }) + (\e -> do { close conn True; ioError e }) where providedClose = findConnClose (rqHeaders rq) @@ -164,7 +164,7 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = return (Right $ Response cd rn hdrs "") DieHorribly str -> do - close conn + close conn True return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) ExpectEntity -> @@ -182,7 +182,7 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "sendHTTP" ; case rslt of - Left e -> close conn >> return (Left e) + Left e -> close conn True >> return (Left e) Right (ftrs,bdy) -> do when (findConnClose (hdrs++ftrs)) (closeOnEnd conn True) diff --git a/Network/Stream.hs b/Network/Stream.hs index 0083221..4e65791 100644 --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -78,7 +78,8 @@ class Stream x where readLine :: x -> IO (Result String) readBlock :: x -> Int -> IO (Result String) writeBlock :: x -> String -> IO (Result ()) - close :: x -> IO () + close :: x -> Bool -> IO () + -- ^ True => please munch the rest of the stream before closing closeOnEnd :: x -> Bool -> IO () -- ^ True => shutdown the connection when response has been read / end-of-stream -- has been reached. diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs index 645c7ea..d364a37 100644 --- a/Network/StreamDebugger.hs +++ b/Network/StreamDebugger.hs @@ -48,10 +48,10 @@ instance (Stream x) => Stream (StreamDebugger x) where hPutStrLn h ("--writeBlock" ++ show str) hPutStrLn h (show val) return val - close (Dbg h x) = + close (Dbg h x) b = do hPutStrLn h "--closing..." hFlush h - close x + close x b hPutStrLn h "--closed." hClose h closeOnEnd (Dbg h x) f = diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs index d8c1ed9..5d09e6c 100644 --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -55,7 +55,7 @@ instance Stream Socket where readBlock sk n = readBlockSocket sk n readLine sk = readLineSocket sk writeBlock sk str = writeBlockSocket sk str - close sk = do + close sk _ = do -- This slams closed the connection (which is considered rude for TCP\/IP) shutdown sk ShutdownBoth sClose sk diff --git a/Network/TCP.hs b/Network/TCP.hs index 6944ccb..beae599 100644 --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -138,7 +138,8 @@ class BufferType bufType => HStream bufType where readLine :: HandleStream bufType -> IO (Result bufType) readBlock :: HandleStream bufType -> Int -> IO (Result bufType) writeBlock :: HandleStream bufType -> bufType -> IO (Result ()) - close :: HandleStream bufType -> IO () + close :: HandleStream bufType -> Bool -> IO () + -- ^ True => please munch the rest of the stream before closing closeOnEnd :: HandleStream bufType -> Bool -> IO () instance HStream Strict.ByteString where @@ -325,9 +326,9 @@ writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do (connHooks' conn) return x -closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> IO () -closeIt c p = do - closeConnection c (readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True}) +closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO () +closeIt c p b = do + closeConnection c (if b then readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True} else return True) conn <- readMVar (getRef c) maybe (return ()) (hook_close) @@ -348,7 +349,7 @@ bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do (\ e -> if isEOFError e then do - when (connCloseEOF conn) $ catch (close ref) (\ _ -> return ()) + when (connCloseEOF conn) $ catch (close ref False) (\ _ -> return ()) return (return (buf_empty (connBuffer conn))) else return (fail (show e))) @@ -371,7 +372,7 @@ bufferReadLine ref = onNonClosedDo ref $ \ conn -> do (\ e -> if isEOFError e then do - when (connCloseEOF conn) $ catch (close ref) (\ _ -> return ()) + when (connCloseEOF conn) $ catch (close ref False) (\ _ -> return ()) return (return (buf_empty (connBuffer conn))) else return (fail (show e))) where -- 1.7.3.1