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/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

