HTTP 4000.0.8 → 4000.0.9

raw patch · 11 files changed

+270/−152 lines, 11 filesdep ~mtldep ~networkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: mtl, network

API changes (from Hackage documentation)

Files

• CHANGES +14/−0
• HTTP.cabal +18/−7
• Network/Browser.hs +72/−40
• Network/HTTP/Base.hs +3/−3
• Network/HTTP/HandleStream.hs +32/−21
• Network/HTTP/Headers.hs +2/−0
• Network/HTTP/Stream.hs +17/−16
• Network/Stream.hs +3/−0
• Network/StreamDebugger.hs +32/−15
• Network/StreamSocket.hs +5/−2
• Network/TCP.hs +72/−48

@@ -1,3 +1,17 @@+Version 4004.0.9: release 2009-12-20++ * Export headerMap from Network.HTTP.Headers+   (suggested by David Leuschner.)+ * Fix Network.TCP.{isTCPConnectedTo,isConnectedTo} to be useful.+ * Always delay closing non-persistent connections until we reach EOF.+   Delaying it until then is vital when reading the response out as a +   lazy ByteString; all of the I/O may not have happened by the time we+   were returning the HTTP response. Bug manifested itself occasionally+   with larger responses. Courtesy of Valery Vorotyntsev; both untiring bug+   hunt and fix.+ * drop unused type argument from Network.Browser.BrowserEvent; needlessly general.+   (patch provided by Daniel Wagner.)+ Version 4004.0.8: release 2009-08-05   * Incorporated proxy setting lookup and parsing contribution

@@ -1,5 +1,5 @@ Name: HTTP-Version: 4000.0.8+Version: 4000.0.9 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3@@ -20,12 +20,23 @@ Synopsis: A library for client-side HTTP Description:  - A package for sending and receiving HTTP requests and responses, all implemented- in Haskell (assuming you've already got a network stack to spare, via the 'network'- package!) The representation of content of in requests and responses is user-controllable,- letting you pick a representation that fits your code better (e.g., use @ByteString@s rather- than the default Haskell @String@s.) Example uses:+ The HTTP package supports client-side web programming in Haskell. It lets you set up + HTTP connections, transmitting requests and processing the responses coming back, all+ from within the comforts of Haskell. It's dependent on the network package to operate,+ but other than that, the implementation is all written in Haskell.  .+ A basic API for issuing single HTTP requests + receiving responses is provided. On top+ of that, a session-level abstraction is also on offer  (the @BrowserAction@ monad);+ it taking care of handling the management of persistent connections, proxies,+ state (cookies) and authentication credentials required to handle multi-step+ interactions with a web server.+ .+ The representation of the bytes flowing across is extensible via the use of a type class,+ letting you pick the representation of requests and responses that best fits your use.+ Some pre-packaged, common instances are provided for you (@ByteString@, @String@.)+ .+ Here's an example use:+ .  >  >    do  >      rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/")@@ -69,7 +80,7 @@                  Network.HTTP.MD5Aux,                  Network.HTTP.Utils   GHC-options: -fwarn-missing-signatures -Wall-  Build-depends: base >= 2 && < 4 , network, parsec, mtl+  Build-depends: base >= 2 && < 4, network, parsec, mtl   if flag(old-base)     Build-depends: base < 3   else

@@ -82,7 +82,7 @@        , setErrHandler     -- :: (String -> IO ()) -> BrowserAction t ()        , setOutHandler     -- :: (String -> IO ()) -> BrowserAction t ()     -       , setEventHandler   -- :: (BrowserEvent t -> BrowserAction t ()) -> BrowserAction t ()+       , setEventHandler   -- :: (BrowserEvent -> BrowserAction t ()) -> BrowserAction t ()                , BrowserEvent(..)        , BrowserEventType(..)@@ -96,6 +96,9 @@         , setDebugLog      -- :: Maybe String -> BrowserAction t ()        +       , getUserAgent     -- :: BrowserAction t String+       , setUserAgent     -- :: String -> BrowserAction t ()+               , out              -- :: String -> BrowserAction t ()        , err              -- :: String -> BrowserAction t ()        , ioAction         -- :: IO a -> BrowserAction a@@ -112,7 +115,7 @@        ) where  import Network.URI-   ( URI(uriAuthority, uriPath, uriQuery)+   ( URI(..)    , URIAuth(..)    , parseURI, parseURIReference, relativeTo    )@@ -386,8 +389,9 @@       , bsCheckProxy      :: Bool       , bsProxy           :: Proxy       , bsDebug           :: Maybe String-      , bsEvent           :: Maybe (BrowserEvent connection -> BrowserAction connection ())+      , bsEvent           :: Maybe (BrowserEvent -> BrowserAction connection ())       , bsRequestID       :: RequestID+      , bsUserAgent       :: Maybe String       }  instance Show (BrowserState t) where@@ -414,7 +418,7 @@ browse act = do x <- lift act defaultBrowserState                 return (snd x) --- | Default browser state..+-- | The default browser state has the settings  defaultBrowserState :: BrowserState t defaultBrowserState = res  where@@ -439,6 +443,7 @@      , bsDebug            = Nothing       , bsEvent            = Nothing      , bsRequestID        = 0+     , bsUserAgent        = Nothing      }  -- | Alter browser state@@ -567,6 +572,17 @@ setDebugLog :: Maybe String -> BrowserAction t () setDebugLog v = alterBS (\b -> b {bsDebug=v}) +-- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It+-- will be used if no explicit user agent header is found in subsequent requests.+setUserAgent :: String -> BrowserAction t ()+setUserAgent ua = alterBS (\b -> b{bsUserAgent=Just ua})++-- | @getUserAgent@ returns the current @User-Agent:@ default string.+getUserAgent :: BrowserAction t String+getUserAgent  = do+  n <- getBS bsUserAgent+  return (maybe defaultUserAgent id n)+ -- | @RequestState@ is an internal tallying type keeping track of various  -- per-connection counters, like the number of authorization attempts and  -- forwards we've gone through.@@ -592,47 +608,47 @@ -- via 'setEventHandler', will be passed. It indicates various state changes -- encountered in the processing of a given 'RequestID', along with timestamps -- at which they occurred.-data BrowserEvent ty+data BrowserEvent  = BrowserEvent       { browserTimestamp  :: ClockTime       , browserRequestID  :: RequestID       , browserRequestURI :: {-URI-}String-      , browserEventType  :: BrowserEventType ty+      , browserEventType  :: BrowserEventType       }  -- | 'BrowserEventType' is the enumerated list of events that the browser -- internals will report to a user-defined event handler.-data BrowserEventType ty+data BrowserEventType  = OpenConnection  | ReuseConnection  | RequestSent+ | ResponseEnd ResponseData+ | ResponseFinish {- not yet, you will have to determine these via the ResponseEnd event.  | Redirect  | AuthChallenge  | AuthResponse -}- | ResponseEnd ResponseData- | ResponseFinish   -- | @setEventHandler onBrowserEvent@ configures event handling. -- If @onBrowserEvent@ is @Nothing@, event handling is turned off; -- setting it to @Just onEv@ causes the @onEv@ IO action to be -- notified of browser events during the processing of a request -- by the Browser pipeline.-setEventHandler :: Maybe (BrowserEvent ty -> BrowserAction ty ()) -> BrowserAction ty ()+setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty () setEventHandler mbH = alterBS (\b -> b { bsEvent=mbH}) -buildBrowserEvent :: BrowserEventType t -> {-URI-}String -> RequestID -> IO (BrowserEvent t)+buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent buildBrowserEvent bt uri reqID = do   ct <- getClockTime   return BrowserEvent -      { browserTimestamp  = ct-      , browserRequestID  = reqID-      , browserRequestURI = uri-      , browserEventType  = bt-      }+         { browserTimestamp  = ct+         , browserRequestID  = reqID+         , browserRequestURI = uri+         , browserEventType  = bt+         } -reportEvent :: BrowserEventType t -> {-URI-}String -> BrowserAction t ()+reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () reportEvent bt uri = do   st <- getBrowserState   case bsEvent st of@@ -719,13 +735,15 @@          Just x  -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)    let rq'' = insertHeaders (map cookieToHeader cookies) rq'    p <- getProxy+   def_ua <- getBS bsUserAgent    let defaultOpts =           case p of -	   NoProxy     -> defaultNormalizeRequestOptions+	   NoProxy     -> defaultNormalizeRequestOptions{normUserAgent=def_ua} 	   Proxy _ ath -> 	      defaultNormalizeRequestOptions-	        { normForProxy=True-		, normCustoms = +	        { normForProxy  = True+		, normUserAgent = def_ua+		, normCustoms   =  		    maybe [] 		          (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) 			  ath@@ -828,13 +846,12 @@ 				     } 			      rq -      (3,0,x) | x == 3 || x == 2 ->  do -- Redirect using GET request method.+      (3,0,x) | x `elem` [2,3,1,7] ->  do -- Redirect using GET request method.         out ("30" ++ show x ++  " - redirect using GET")-        rd <- getAllowRedirects-	mbMxRetries <- getMaxRedirects-        if not rd || reqRedirects rqState > fromMaybe defaultMaxRetries mbMxRetries-	 then return (Right (uri,rsp))-	 else +	allow_redirs <- allowRedirect rqState+	case allow_redirs of+	  False -> return (Right (uri,rsp))+	  _ -> do           case retrieveHeaders HdrLocation rsp of            [] -> do  	     err "No Location: header in redirect response"@@ -844,17 +861,21 @@                Nothing -> do                  err ("Parse of Location: header in a redirect response failed: " ++ u)                  return (Right (uri,rsp))-               Just newuri -> do-	         out ("Redirecting to " ++ show newuri' ++ " ...") -		 let rq1 = rq { rqMethod=GET, rqURI=newuri', rqBody=nullVal }-                 request' nullVal-			  rqState{ reqDenies     = 0-			         , reqRedirects  = succ(reqRedirects rqState)-				 , reqStopOnDeny = True-				 }-                          (replaceHeader HdrContentLength "0" rq1)+               Just newURI+		| {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do+		   err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs)+		   return (Right (uri, rsp))+                | otherwise -> do		     +  	           out ("Redirecting to " ++ show newURI_abs ++ " ...") +		   let rq1 = rq { rqMethod=GET, rqURI=newURI_abs, rqBody=nullVal }+                   request' nullVal+			    rqState{ reqDenies     = 0+			           , reqRedirects  = succ(reqRedirects rqState)+				   , reqStopOnDeny = True+				   }+                                   (replaceHeader HdrContentLength "0" rq1)                 where-                  newuri' = maybe newuri id (newuri `relativeTo` uri)+                  newURI_abs = maybe newURI id (newURI `relativeTo` uri)        (3,0,5) ->         case retrieveHeaders HdrLocation rsp of@@ -891,15 +912,15 @@             return (Right (uri,rsp))           (Header _ u:_) ->  	    case parseURIReference u of-              Just newuri -> do-                let newuri' = maybe newuri id (newuri `relativeTo` uri)-                out ("Redirecting to " ++ show newuri' ++ " ...") +              Just newURI -> do+                let newURI_abs = maybe newURI id (newURI `relativeTo` uri)+                out ("Redirecting to " ++ show newURI_abs ++ " ...")                  request' nullVal 		         rqState{ reqDenies     = 0 			        , reqRedirects  = succ (reqRedirects rqState) 			        , reqStopOnDeny = True 				}-		         rq{rqURI=newuri'}+		         rq{rqURI=newURI_abs}               Nothing -> do                 err ("Parse of Location header in a redirect response failed: " ++ u)                 return (Right (uri,rsp))@@ -985,6 +1006,17 @@ ------------------------------------------------------------------ ----------------------- Miscellaneous ---------------------------- ------------------------------------------------------------------++allowRedirect :: RequestState -> BrowserAction t Bool+allowRedirect rqState = do+  rd <- getAllowRedirects+  mbMxRetries <- getMaxRedirects+  return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries))++-- | Return @True@ iff the package is able to handle requests and responses+-- over it.+supportedScheme :: URI -> Bool+supportedScheme u = uriScheme u == "http:"  -- | @uriDefaultTo a b@ returns a URI that is consistent with the first -- argument URI @a@ when read in the context of the second URI @b@.

@@ -337,7 +337,7 @@ ------------------ Request Building ------------------------------ ------------------------------------------------------------------ libUA :: String-libUA = "hs-HTTP-4000.0.5"+libUA = "hs-HTTP-4000.0.9"  defaultUserAgent :: String defaultUserAgent = libUA@@ -664,8 +664,8 @@     Nothing -> req     Just ua ->       case findHeader HdrUserAgent req of-       Nothing -> setHeaders req (mkHeader HdrUserAgent ua : getHeaders req)-       Just{}  -> req+       Just u  | u /= defaultUserAgent -> req+       _ -> replaceHeader HdrUserAgent ua req  -- | @normalizeConnectionClose opts req@ sets the header @Connection: close@  -- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then

@@ -85,14 +85,11 @@ 		-> IO () 		-> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do-  rsp <- catchIO (sendMain conn rq onSendComplete)-                 (\e -> do { close conn; ioError e })-  let fn list = when (or $ map findConnClose list)-                     (close conn)-  either (\_ -> fn [rqHeaders rq])-         (\r -> fn [rqHeaders rq,rspHeaders r])-         rsp-  return rsp+  when providedClose $ (closeOnEnd conn True)+  catchIO (sendMain conn rq onSendComplete)+          (\e -> do { close conn; ioError e })+ where+  providedClose = findConnClose (rqHeaders rq)  -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows@@ -157,20 +154,34 @@         rsp <- getResponseHead conn         switchResponse conn False bdy_sent rsp rqst                      -     Done -> return (Right $ Response cd rn hdrs (buf_empty bufferOps))+     Done -> do+       when (findConnClose hdrs)+            (closeOnEnd conn True)+       return (Right $ Response cd rn hdrs (buf_empty bufferOps)) -     DieHorribly str -> return (responseParseError "Invalid response:" str)-     ExpectEntity -> -       fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $-        maybe (maybe (hopefulTransfer bo (readLine conn) [])-	             (\ x -> -		        readsOne (linearTransfer (readBlock conn))-		                 (return$responseParseError "unrecognized content-length value" x)-				 x)-		     cl)-	      (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))-	                 (uglyDeathTransfer "sendHTTP"))-              tc+     DieHorribly str -> do+       close conn+       return (responseParseError "Invalid response:" str)+     ExpectEntity -> do+       r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $+             maybe (maybe (hopefulTransfer bo (readLine conn) [])+	               (\ x -> +		          readsOne (linearTransfer (readBlock conn))+		                   (return$responseParseError "unrecognized content-length value" x)+			  	   x)+		        cl)+	           (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+	                      (uglyDeathTransfer "sendHTTP"))+                   tc+       case r of+         Left{} -> do+	   close conn+	   return r+	 Right (Response _ _ hs _) -> do+	   when (findConnClose hs)+                (closeOnEnd conn True)+	   return r+       where        tc = lookupHeader HdrTransferEncoding hdrs        cl = lookupHeader HdrContentLength hdrs

@@ -36,6 +36,8 @@    , parseHeader           -- :: parseHeader :: String -> Result Header    , parseHeaders          -- :: [String] -> Result [Header]    +   , headerMap             -- :: [(String, HeaderName)]+       , HeaderSetter    ) where 

@@ -79,22 +79,17 @@  | otherwise    = do       s' <- debugStream httpLogFile s       sendHTTP s' r-    -- already done by sendHTTP because of "Connection: close" header-    --; close s   sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) sendHTTP conn rq = sendHTTP_notify conn rq (return ())  sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)-sendHTTP_notify conn rq onSendComplete = do -   rsp <- catchIO (sendMain conn rq onSendComplete)-                  (\e -> do { close conn; ioError e })-   let fn list = when (or $ map findConnClose list)-                      (close conn)-   either (\_ -> fn [rqHeaders rq])-          (\r -> fn [rqHeaders rq,rspHeaders r])-          rsp-   return rsp+sendHTTP_notify conn rq onSendComplete = do+   when providedClose $ (closeOnEnd conn True)+   catchIO (sendMain conn rq onSendComplete)+           (\e -> do { close conn; ioError e })+ where+  providedClose = findConnClose (rqHeaders rq)  -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows@@ -163,10 +158,13 @@                        ; switchResponse conn False bdy_sent rsp rqst                        }                         -                Done ->+                Done -> do+		    when (findConnClose hdrs)+            	    	 (closeOnEnd conn True)                     return (Right $ Response cd rn hdrs "") -                DieHorribly str ->+                DieHorribly str -> do+		    close conn                     return $ responseParseError "sendHTTP" ("Invalid response: " ++ str)                  ExpectEntity ->@@ -183,9 +181,12 @@                                   "chunked" -> chunkedTransfer stringBufferOp 				                               (readLine conn) (readBlock conn)                                   _         -> uglyDeathTransfer "sendHTTP"-                       ; return $ do-		            (ftrs,bdy) <- rslt-			    return (Response cd rn (hdrs++ftrs) bdy)+                       ; case rslt of+		           Left e -> close conn >> return (Left e)+			   Right (ftrs,bdy) -> do+			    when (findConnClose (hdrs++ftrs))+			    	 (closeOnEnd conn True)+			    return (Right (Response cd rn (hdrs++ftrs) bdy))                        }  -- | Receive and parse a HTTP request from the given Stream. Should be used 

@@ -79,3 +79,6 @@     readBlock  :: x -> Int -> IO (Result String)     writeBlock :: x -> String -> IO (Result ())     close      :: x -> IO ()+    closeOnEnd :: x -> Bool -> IO ()+      -- ^ True => shutdown the connection when response has been read / end-of-stream+      --           has been reached.

@@ -25,7 +25,8 @@ import System.IO    ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile    )-import Network.TCP ( HandleStream, StreamHooks(..), HStream, setStreamHooks )+import Network.TCP ( HandleStream, HStream, +       		     StreamHooks(..), setStreamHooks, getStreamHooks )  -- | Allows stream logging.  Refer to 'debugStream' below. data StreamDebugger x@@ -34,22 +35,29 @@ instance (Stream x) => Stream (StreamDebugger x) where     readBlock (Dbg h x) n =         do val <- readBlock x n-           hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)+           hPutStrLn h ("--readBlock " ++ show n)+	   hPutStrLn h (show val)            return val     readLine (Dbg h x) =         do val <- readLine x-           hPutStrLn h ("readLine " ++ show val)+           hPutStrLn h ("--readLine")+	   hPutStrLn h (show val)            return val     writeBlock (Dbg h x) str =         do val <- writeBlock x str-           hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)+           hPutStrLn h ("--writeBlock" ++ show str)+	   hPutStrLn h (show val)            return val     close (Dbg h x) =-        do hPutStrLn h "closing..."+        do hPutStrLn h "--closing..."            hFlush h            close x-           hPutStrLn h "...closed"+           hPutStrLn h "--closed."            hClose h+    closeOnEnd (Dbg h x) f =+        do hPutStrLn h ("--close-on-end.." ++ show f)+           hFlush h +           closeOnEnd x f  -- | Wraps a stream with logging I\/O. --   The first argument is a filename which is opened in @AppendMode@.@@ -60,25 +68,34 @@        return (Dbg h stream)  debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty)-debugByteStream file stream = -    do h <- openFile file AppendMode+debugByteStream file stream = do+   sh <- getStreamHooks stream +   case sh of+     Just h +      | hook_name h == file -> return stream -- reuse the stream hooks.+     _ -> do+       h <- openFile file AppendMode        hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")-       setStreamHooks stream (debugStreamHooks h)+       setStreamHooks stream (debugStreamHooks h file)        return stream -debugStreamHooks :: HStream ty => Handle -> StreamHooks ty-debugStreamHooks h = +debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty+debugStreamHooks h nm =    StreamHooks     { hook_readBlock = \ toStr n val -> do        let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}-       hPutStrLn h ("readBlock " ++ show n ++ ' ' : show eval)+       hPutStrLn h ("--readBlock " ++ show n)+       hPutStrLn h (either show show eval)     , hook_readLine = \ toStr val -> do 	   let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}-           hPutStrLn h ("readLine " ++ show eval)+           hPutStrLn h ("--readLine")+	   hPutStrLn h (either show show eval)     , hook_writeBlock = \ toStr str val -> do-           hPutStrLn h ("writeBlock " ++ show val ++ ' ' : toStr str)+           hPutStrLn h ("--writeBlock " ++ show val)+	   hPutStrLn h (toStr str)     , hook_close = do-           hPutStrLn h "closing..."+           hPutStrLn h "--closing..."            hFlush h            hClose h+    , hook_name = nm     }

@@ -55,8 +55,11 @@     readBlock sk n    = readBlockSocket sk n     readLine sk       = readLineSocket sk     writeBlock sk str = writeBlockSocket sk str-    close sk          = shutdown sk ShutdownBoth >> sClose sk-      -- This slams closed the connection (which is considered rude for TCP\/IP)+    close sk          = do+        -- This slams closed the connection (which is considered rude for TCP\/IP)+         shutdown sk ShutdownBoth+         sClose sk+    closeOnEnd _sk _  = return () -- can't really deal with this, so do run the risk of leaking sockets here.  readBlockSocket :: Socket -> Int -> IO (Result String) readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk)

@@ -28,6 +28,7 @@    , StreamHooks(..)    , nullHooks    , setStreamHooks+   , getStreamHooks    , hstreamToConnection     ) where@@ -36,12 +37,12 @@ import Network.Socket    ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive)    , SocketType(Stream), inet_addr, connect-   , shutdown, ShutdownCmd(ShutdownSend, ShutdownReceive)-   , sClose, sIsConnected, setSocketOption+   , shutdown, ShutdownCmd(..)+   , sClose, setSocketOption, getPeerName    , socket, Family(AF_INET)    ) import qualified Network.Stream as Stream-   ( Stream(readBlock, readLine, writeBlock, close) )+   ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) import Network.Stream    ( ConnError(..)    , Result@@ -55,7 +56,7 @@ import Data.Char  ( toLower ) import Data.Word  ( Word8 ) import Control.Concurrent-import Control.Monad ( liftM )+import Control.Monad ( liftM, when ) import System.IO ( Handle, hFlush, IOMode(..), hClose ) import System.IO.Error ( isEOFError ) @@ -76,12 +77,13 @@ newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)}  data Conn a - = MkConn { connSock     :: ! Socket-	  , connHandle   :: Handle-          , connBuffer   :: BufferOp a-	  , connInput    :: Maybe a-          , connHost     :: String-	  , connHooks    :: Maybe (StreamHooks a)+ = MkConn { connSock      :: ! Socket+	  , connHandle    :: Handle+          , connBuffer    :: BufferOp a+	  , connInput     :: Maybe a+          , connHost      :: String+	  , connHooks     :: Maybe (StreamHooks a)+	  , connCloseEOF  :: Bool -- True => close socket upon reaching end-of-stream.           }  | ConnClosed    deriving(Eq)@@ -100,6 +102,7 @@      , hook_readBlock  :: (ty -> String) -> Int -> Result ty -> IO ()      , hook_writeBlock :: (ty -> String) -> ty  -> Result () -> IO ()      , hook_close      :: IO ()+     , hook_name       :: String -- hack alert: name of the hook itself.      }  instance Eq ty => Eq (StreamHooks ty) where@@ -111,28 +114,32 @@      , hook_readBlock  = \ _ _ _ -> return ()      , hook_writeBlock = \ _ _ _ -> return ()      , hook_close      = return ()+     , hook_name       = ""      }  setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) +getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty))+getStreamHooks h = readMVar (getRef h) >>= return.connHooks+ -- | @HStream@ overloads the use of 'HandleStream's, letting you -- overload the handle operations over the type that is communicated--- across the handle. It is used in the context of @Network.HTTP@ to--- buy us freedom in how HTTP 'Request' and 'Response' payloads are--- represented. +-- across the handle. It comes in handy for @Network.HTTP@ 'Request'+-- and 'Response's as the payload representation isn't fixed, but overloaded. ----- The package provides instances for @ByteString@s and @String@, but+-- The library comes with instances for @ByteString@s and @String@, but -- should you want to plug in your own payload representation, defining--- your own @HStream@ instance is all it takes.+-- your own @HStream@ instance _should_ be all that it takes. --  class BufferType bufType => HStream bufType where   openStream       :: String -> Int -> IO (HandleStream bufType)   openSocketStream :: String -> Socket -> IO (HandleStream bufType)-  readLine   :: HandleStream bufType -> IO (Result bufType)-  readBlock  :: HandleStream bufType -> Int -> IO (Result bufType)-  writeBlock :: HandleStream bufType -> bufType -> IO (Result ())-  close      :: HandleStream bufType -> IO ()+  readLine         :: HandleStream bufType -> IO (Result bufType)+  readBlock        :: HandleStream bufType -> Int -> IO (Result bufType)+  writeBlock       :: HandleStream bufType -> bufType -> IO (Result ())+  close            :: HandleStream bufType -> IO ()+  closeOnEnd       :: HandleStream bufType -> Bool -> IO ()    instance HStream Strict.ByteString where   openStream       = openTCPConnection@@ -141,6 +148,7 @@   readLine c       = readLineBS c   writeBlock c str = writeBlockBS c str   close c          = closeIt c Strict.null+  closeOnEnd c f   = closeEOF c f  instance HStream Lazy.ByteString where     openStream       = \ a b -> openTCPConnection_ a b True@@ -149,12 +157,14 @@     readLine c       = readLineBS c     writeBlock c str = writeBlockBS c str     close c          = closeIt c Lazy.null+    closeOnEnd c f   = closeEOF c f  instance Stream.Stream Connection where-  readBlock (Connection c)  = Network.TCP.readBlock c-  readLine (Connection c)   = Network.TCP.readLine c-  writeBlock (Connection c) = Network.TCP.writeBlock c -  close (Connection c)      = Network.TCP.close c+  readBlock (Connection c)     = Network.TCP.readBlock c+  readLine (Connection c)      = Network.TCP.readLine c+  writeBlock (Connection c)    = Network.TCP.writeBlock c +  close (Connection c)         = Network.TCP.close c+  closeOnEnd (Connection c) f  = Network.TCP.closeEOF c f    instance HStream String where     openStream      = openTCPConnection@@ -174,6 +184,8 @@     -- (I think the behaviour here is TCP specific)     close c = closeIt c null     +    closeOnEnd c f = closeEOF c f+     -- | @openTCPPort uri port@  establishes a connection to a remote -- host, using 'getHostByName' which possibly queries the DNS system, hence  -- may trigger a network connection.@@ -224,17 +236,18 @@     h <- socketToHandle sock ReadWriteMode     mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing }     let conn = MkConn -         { connSock   = sock-	 , connHandle = h-	 , connBuffer = bufferOps-	 , connInput  = mb-	 , connHost   = hst-	 , connHooks  = Nothing+         { connSock     = sock+	 , connHandle   = h+	 , connBuffer   = bufferOps+	 , connInput    = mb+	 , connHost     = hst+	 , connHooks    = Nothing+	 , connCloseEOF = False 	 }     v <- newMVar conn     return (HandleStream v) -closeConnection :: HandleStream a -> IO Bool -> IO ()+closeConnection :: HStream a => HandleStream a -> IO Bool -> IO () closeConnection ref readL = do     -- won't hold onto the lock for the duration     -- we are draining it...ToDo: have Connection@@ -249,6 +262,7 @@   closeConn ConnClosed = return ()   closeConn conn = do     let sk = connSock conn+    hFlush (connHandle conn)     shutdown sk ShutdownSend     suck readL     hClose (connHandle conn)@@ -267,9 +281,10 @@ isConnectedTo (Connection conn) name = do    v <- readMVar (getRef conn)    case v of-     ConnClosed -> return False+     ConnClosed -> print "aa" >> return False      _ -      | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v)+      | map toLower (connHost v) == map toLower name ->+          catch (getPeerName (connSock v) >> return True) (const $ return False)       | otherwise -> return False  isTCPConnectedTo :: HandleStream ty -> String -> IO Bool@@ -278,10 +293,11 @@    case v of      ConnClosed -> return False      _ -      | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v)+      | map toLower (connHost v) == map toLower name -> +          catch (getPeerName (connSock v) >> return True) (const $ return False)       | otherwise -> return False -readBlockBS :: HandleStream a -> Int -> IO (Result a)+readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a) readBlockBS ref n = onNonClosedDo ref $ \ conn -> do    x <- bufferGetBlock ref n    maybe (return ())@@ -291,7 +307,7 @@  -- This function uses a buffer, at this time the buffer is just 1000 characters. -- (however many bytes this is is left for the user to decipher)-readLineBS :: HandleStream a -> IO (Result a)+readLineBS :: HStream a => HandleStream a -> IO (Result a) readLineBS ref = onNonClosedDo ref $ \ conn -> do    x <- bufferReadLine ref    maybe (return ())@@ -309,15 +325,18 @@ 	(connHooks' conn)   return x -closeIt :: HandleStream ty -> (ty -> Bool) -> IO ()+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})-  conn <- readMVar (getRef c)-  maybe (return ())-        (hook_close)-	(connHooks' conn)+   closeConnection c (readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True})+   conn <- readMVar (getRef c)+   maybe (return ())+         (hook_close)+	 (connHooks' conn) -bufferGetBlock :: HandleStream a -> Int -> IO (Result a)+closeEOF :: HandleStream ty -> Bool -> IO ()+closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg})++bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a) bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do    case connInput conn of     Just c -> do@@ -326,16 +345,19 @@       return (return a)     _ -> do       Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)-                    (\ e -> if isEOFError e -			     then return (return (buf_empty (connBuffer conn)))-			     else return (fail (show e)))+                    (\ e -> +		       if isEOFError e +			then do+			  when (connCloseEOF conn) $ catch (close ref) (\ _ -> return ())+			  return (return (buf_empty (connBuffer conn)))+			else return (fail (show e)))  bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) bufferPutBlock ops h b =    Prelude.catch (buf_hPut ops h b >> hFlush h >> return (return ()))                 (\ e -> return (fail (show e))) -bufferReadLine :: HandleStream a -> IO (Result a) -- BufferOp a -> Handle -> IO (Result a)+bufferReadLine :: HStream a => HandleStream a -> IO (Result a) bufferReadLine ref = onNonClosedDo ref $ \ conn -> do   case connInput conn of    Just c -> do@@ -346,9 +368,11 @@    _ -> Prelude.catch                (buf_hGetLine (connBuffer conn) (connHandle conn) >>=  	            return . return . appendNL (connBuffer conn))-              (\ e -> +              (\ e ->                  if isEOFError e-                  then return (return   (buf_empty (connBuffer conn)))+                  then do+	  	    when (connCloseEOF conn) $ catch (close ref) (\ _ -> return ())+		    return (return   (buf_empty (connBuffer conn)))                   else return (fail (show e)))  where    -- yes, this s**ks.. _may_ have to be addressed if perf