HTTP 4000.2.20 → 4000.2.21

raw patch · 14 files changed

+264/−263 lines, 14 filesdep ~HUnitdep ~networkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: HUnit, network

API changes (from Hackage documentation)

Files

• HTTP.cabal +7/−7
• Network/Browser.hs +79/−79
• Network/BufferType.hs +1/−1
• Network/HTTP.hs +3/−3
• Network/HTTP/Auth.hs +9/−9
• Network/HTTP/Base.hs +71/−71
• Network/HTTP/Cookie.hs +1/−1
• Network/HTTP/HandleStream.hs +32/−32
• Network/HTTP/Headers.hs +5/−5
• Network/HTTP/MD5Aux.hs +1/−0
• Network/HTTP/Proxy.hs +2/−2
• Network/HTTP/Stream.hs +18/−18
• Network/StreamDebugger.hs +7/−7
• Network/TCP.hs +28/−28

@@ -1,5 +1,5 @@ Name: HTTP-Version: 4000.2.20+Version: 4000.2.21 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3@@ -9,9 +9,9 @@ Homepage: https://github.com/haskell/HTTP Category: Network Synopsis: A library for client-side HTTP-Description: +Description: - The HTTP package supports client-side web programming in Haskell. It lets you set up + 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.@@ -74,12 +74,12 @@   default: True  Library-  Exposed-modules: +  Exposed-modules:                  Network.BufferType,                  Network.Stream,                  Network.StreamDebugger,                  Network.StreamSocket,-                 Network.TCP,                +                 Network.TCP,                  Network.HTTP,                  Network.HTTP.Headers,                  Network.HTTP.Base,@@ -112,7 +112,7 @@   if flag(network-uri)     Build-depends: network-uri == 2.6.*, network == 2.6.*   else-    Build-depends: network >= 2.2.1.5 && < 2.6+    Build-depends: network >= 2.2.1.8 && < 2.6    build-tools: ghc >= 7.0 && < 7.12 @@ -137,7 +137,7 @@   -- note: version constraints for dependencies shared with the library   -- should be the same   build-depends:     HTTP,-                     HUnit >= 1.2.0.1 && < 1.3,+                     HUnit >= 1.2.0.1 && < 1.4,                      httpd-shed >= 0.4 && < 0.5,                      mtl >= 1.1.1.0 && < 2.3,                      bytestring >= 0.9.1.5 && < 0.11,

@@ -711,7 +711,7 @@ -- is returned along with the 'Response' itself. request :: HStream ty         => Request ty-	-> BrowserAction (HandleStream ty) (URI,Response ty)+        -> BrowserAction (HandleStream ty) (URI,Response ty) request req = nextRequest $ do   res <- request' nullVal initialState req   reportEvent ResponseFinish (show (rqURI req))@@ -729,9 +729,9 @@ -- counts. request' :: HStream ty          => ty-	 -> RequestState-	 -> Request ty-	 -> BrowserAction (HandleStream ty) (Result (URI,Response ty))+         -> RequestState+         -> Request ty+         -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) request' nullVal rqState rq = do    let uri = rqURI rq    failHTTPS uri@@ -765,18 +765,18 @@    let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq'    p <- getProxy    def_ua <- gets bsUserAgent-   let defaultOpts = +   let defaultOpts =          case p of -	   NoProxy     -> defaultNormalizeRequestOptions{normUserAgent=def_ua}-	   Proxy _ ath ->-	      defaultNormalizeRequestOptions-	        { normForProxy  = True-		, normUserAgent = def_ua-		, normCustoms   = -		    maybe []-		          (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])-			  ath-		}+           NoProxy     -> defaultNormalizeRequestOptions{normUserAgent=def_ua}+           Proxy _ ath ->+              defaultNormalizeRequestOptions+                { normForProxy  = True+                , normUserAgent = def_ua+                , normCustoms   =+                    maybe []+                          (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])+                          ath+                }    let final_req = normalizeRequest defaultOpts rq''    out ("Sending:\n" ++ show final_req)    e_rsp <- @@ -784,16 +784,16 @@        NoProxy        -> dorequest (reqURIAuth rq'') final_req        Proxy str _ath -> do           let notURI -	       | null pt || null hst = -	         URIAuth{ uriUserInfo = ""-	                , uriRegName  = str-			, uriPort     = ""-			}-	       | otherwise = -	         URIAuth{ uriUserInfo = ""-	                , uriRegName  = hst-			, uriPort     = pt-			}+               | null pt || null hst =+                 URIAuth{ uriUserInfo = ""+                        , uriRegName  = str+                        , uriPort     = ""+                        }+               | otherwise =+                 URIAuth{ uriUserInfo = ""+                        , uriRegName  = hst+                        , uriPort     = pt+                        }                   -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it!                  where (hst, pt) = span (':'/=) str            -- Proxy can take multiple forms - look for http://host:port first,@@ -804,7 +804,7 @@                       (parseURI str)            out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth-	  dorequest proxyURIAuth final_req+          dorequest proxyURIAuth final_req    mbMx <- getMaxErrorRetries    case e_rsp of     Left v @@ -827,27 +827,27 @@       (4,0,1) -- Credentials not sent or refused.         | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do           out "401 - credentials again refused; exceeded retry count (2)"-	  return (Right (uri,rsp))-	| otherwise -> do+          return (Right (uri,rsp))+        | otherwise -> do           out "401 - credentials not supplied or refused; retrying.."           let hdrs = retrieveHeaders HdrWWWAuthenticate rsp-	  flg <- getAllowBasicAuth+          flg <- getAllowBasicAuth           case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of             Nothing -> do-	      out "no challenge"-	      return (Right (uri,rsp))   {- do nothing -}+              out "no challenge"+              return (Right (uri,rsp))   {- do nothing -}             Just x  -> do               au <- challengeToAuthority uri x               case au of                 Nothing  -> do-		  out "no auth"-		  return (Right (uri,rsp)) {- do nothing -}+                  out "no auth"+                  return (Right (uri,rsp)) {- do nothing -}                 Just au' -> do                   out "Retrying request with new credentials"-		  request' nullVal-			   rqState{ reqDenies     = succ(reqDenies rqState)-			          , reqStopOnDeny = False-				  }+                  request' nullVal+                           rqState{ reqDenies     = succ(reqDenies rqState)+                                  , reqStopOnDeny = False+                                  }                            (insertHeader HdrAuthorization (withAuthority au' rq) rq)        (4,0,7)  -- Proxy Authentication required@@ -857,7 +857,7 @@         | otherwise -> do           out "407 - proxy authentication required"           let hdrs = retrieveHeaders HdrProxyAuthenticate rsp-	  flg <- getAllowBasicAuth+          flg <- getAllowBasicAuth           case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of             Nothing -> return (Right (uri,rsp))   {- do nothing -}             Just x  -> do@@ -874,32 +874,32 @@                      out "Retrying with proxy authentication"                      setProxy (Proxy px (Just au'))                      request' nullVal-			      rqState{ reqDenies     = succ(reqDenies rqState)-			             , reqStopOnDeny = False-				     }-			      rq+                              rqState{ reqDenies     = succ(reqDenies rqState)+                                     , reqStopOnDeny = False+                                     }+                              rq        (3,0,x) | x `elem` [2,3,1,7]  ->  do         out ("30" ++ show x ++  " - redirect")-	allow_redirs <- allowRedirect rqState-	case allow_redirs of-	  False -> return (Right (uri,rsp))-	  _ -> do+        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"+              err "No Location: header in redirect response"               return (Right (uri,rsp))             (Header _ u:_) -> -	      case parseURIReference u of+              case parseURIReference u of                 Nothing -> do                   err ("Parse of Location: header in a redirect response failed: " ++ u)                   return (Right (uri,rsp))                 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 ++ " ...") +                 | {-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 ++ " ...")                                          -- Redirect using GET request method, depending on                     -- response code.@@ -909,10 +909,10 @@                         rq2 = if toGet then (replaceHeader HdrContentLength "0") (rq1 {rqBody = nullVal}) else rq1                                          request' nullVal-	         	    rqState{ reqDenies     = 0-	         	           , reqRedirects  = succ(reqRedirects rqState)-	         		   , reqStopOnDeny = True-	         		   }+                            rqState{ reqDenies     = 0+                                   , reqRedirects  = succ(reqRedirects rqState)+                                   , reqStopOnDeny = True+                                   }                              rq2                  where                    newURI_abs = uriDefaultTo newURI uri@@ -920,10 +920,10 @@       (3,0,5) ->         case retrieveHeaders HdrLocation rsp of          [] -> do -	   err "No Location header in proxy redirect response."+           err "No Location header in proxy redirect response."            return (Right (uri,rsp))          (Header _ u:_) -> -	   case parseURIReference u of+           case parseURIReference u of             Nothing -> do              err ("Parse of Location header in a proxy redirect response failed: " ++ u)              return (Right (uri,rsp))@@ -931,19 +931,19 @@              out ("Retrying with proxy " ++ show newuri ++ "...")              setProxy (Proxy (uriToAuthorityString newuri) Nothing)              request' nullVal rqState{ reqDenies     = 0-	                             , reqRedirects  = 0-				     , reqRetries    = succ (reqRetries rqState)-				     , reqStopOnDeny = True-				     }-				     rq+                                     , reqRedirects  = 0+                                     , reqRetries    = succ (reqRetries rqState)+                                     , reqStopOnDeny = True+                                     }+                                     rq       _       -> return (Right (uri,rsp))  -- | The internal request handling state machine. dorequest :: (HStream ty)           => URIAuth-	  -> Request ty-	  -> BrowserAction (HandleStream ty)-	                   (Result (Response ty))+          -> Request ty+          -> BrowserAction (HandleStream ty)+                           (Result (Response ty)) dorequest hst rqst = do   pool <- gets bsConnectionPool   let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst@@ -952,13 +952,13 @@     case conn of       [] -> do          out ("Creating new connection to " ++ uriAuthToString hst)-	reportEvent OpenConnection (show (rqURI rqst))+        reportEvent OpenConnection (show (rqURI rqst))         c <- liftIO $ openStream (uriRegName hst) uPort-	updateConnectionPool c-	dorequest2 c rqst+        updateConnectionPool c+        dorequest2 c rqst       (c:_) -> do         out ("Recovering connection to " ++ uriAuthToString hst)-	reportEvent ReuseConnection (show (rqURI rqst))+        reportEvent ReuseConnection (show (rqURI rqst))         dorequest2 c rqst   case rsp of       Right (Response a b c _) -> @@ -972,20 +972,20 @@      onSendComplete =        maybe (return ())              (\evh -> do-	        x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)-		runBA st (evh x)-		return ())+                x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)+                runBA st (evh x)+                return ())              (bsEvent st)     liftIO $        maybe (sendHTTP_notify c r onSendComplete)             (\ f -> do                c' <- debugByteStream (f++'-': uriAuthToString hst) c-	       sendHTTP_notify c' r onSendComplete)-	    dbg+               sendHTTP_notify c' r onSendComplete)+            dbg  updateConnectionPool :: HStream hTy                      => HandleStream hTy-		     -> BrowserAction (HandleStream hTy) ()+                     -> BrowserAction (HandleStream hTy) () updateConnectionPool c = do    pool <- gets bsConnectionPool    let len_pool = length pool@@ -993,8 +993,8 @@    when (len_pool > maxPoolSize)         (liftIO $ close (last pool))    let pool' -	| len_pool > maxPoolSize = init pool-	| otherwise              = pool+        | len_pool > maxPoolSize = init pool+        | otherwise              = pool    when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' })    return ()                              

@@ -156,7 +156,7 @@       , buf_splitAt      = splitAt       , buf_span         = \ p a ->                               case Strict.span p (Strict.pack a) of-			       (x,y) -> (Strict.unpack x, Strict.unpack y)+                               (x,y) -> (Strict.unpack x, Strict.unpack y)       , buf_empty        = []       , buf_isLineTerm   = \ b -> b == crlf || b == lf       , buf_isEmpty      = null 

@@ -130,9 +130,9 @@ -- request transmission and its performance. sendHTTP_notify :: HStream ty                 => HandleStream ty-		-> Request ty-		-> IO ()-		-> IO (Result (Response ty))+                -> Request ty+                -> IO ()+                -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do   let norm_r = normalizeRequest defaultNormalizeRequestOptions rq    S.sendHTTP_notify conn norm_r onSendComplete

@@ -87,16 +87,16 @@         AuthBasic{}  -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a)         AuthDigest{} ->             "Digest " ++-	     concat [ "username="  ++ quo (auUsername a)-	            , ",realm="    ++ quo (auRealm a)-		    , ",nonce="    ++ quo (auNonce a)-		    , ",uri="      ++ quo digesturi-		    , ",response=" ++ quo rspdigest+             concat [ "username="  ++ quo (auUsername a)+                    , ",realm="    ++ quo (auRealm a)+                    , ",nonce="    ++ quo (auNonce a)+                    , ",uri="      ++ quo digesturi+                    , ",response=" ++ quo rspdigest                        -- plus optional stuff:-		    , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))-		    , fromMaybe "" (fmap (\ o   -> ",opaque=" ++ quo o) (auOpaque a))-		    , if null (auQop a) then "" else ",qop=auth"-		    ]+                    , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))+                    , fromMaybe "" (fmap (\ o   -> ",opaque=" ++ quo o) (auOpaque a))+                    , if null (auQop a) then "" else ",qop=auth"+                    ]     where         quo s = '"':s ++ "\"" 

@@ -135,11 +135,11 @@ ------------------ URI Authority parsing ------------------------ ----------------------------------------------------------------- -data URIAuthority = URIAuthority { user :: Maybe String, -				   password :: Maybe String,-				   host :: String,-				   port :: Maybe Int-				 } deriving (Eq,Show)+data URIAuthority = URIAuthority { user :: Maybe String,+                                   password :: Maybe String,+                                   host :: String,+                                   port :: Maybe Int+                                 } deriving (Eq,Show)  -- | Parse the authority part of a URL. --@@ -154,12 +154,12 @@  pURIAuthority :: ReadP URIAuthority pURIAuthority = do-		(u,pw) <- (pUserInfo `before` char '@') -			  <++ return (Nothing, Nothing)-		h <- rfc2732host <++ munch (/=':')-		p <- orNothing (char ':' >> readDecP)-		look >>= guard . null -		return URIAuthority{ user=u, password=pw, host=h, port=p }+                (u,pw) <- (pUserInfo `before` char '@')+                          <++ return (Nothing, Nothing)+                h <- rfc2732host <++ munch (/=':')+                p <- orNothing (char ':' >> readDecP)+                look >>= guard . null+                return URIAuthority{ user=u, password=pw, host=h, port=p }  -- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL rfc2732host :: ReadP String@@ -171,9 +171,9 @@  pUserInfo :: ReadP (Maybe String, Maybe String) pUserInfo = do-	    u <- orNothing (munch (`notElem` ":@"))-	    p <- orNothing (char ':' >> munch (/='@'))-	    return (u,p)+            u <- orNothing (munch (`notElem` ":@"))+            p <- orNothing (char ':' >> munch (/='@'))+            return (u,p)  before :: Monad m => m a -> m b -> m a before a b = a >>= \x -> b >> return x@@ -189,8 +189,8 @@ uriAuthToString ua =    concat [ uriUserInfo ua           , uriRegName ua-	 , uriPort ua-	 ]+         , uriPort ua+         ]  uriAuthPort :: Maybe URI -> URIAuth -> Int uriAuthPort mbURI u = @@ -223,12 +223,12 @@     Just ua -> ua     _ -> case lookupHeader HdrHost (rqHeaders req) of            Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req)-	   Just h  -> -	      case toHostPort h of-	        (ht,p) -> URIAuth { uriUserInfo = ""-	                          , uriRegName  = ht-			          , uriPort     = p-			          }+           Just h  ->+              case toHostPort h of+                (ht,p) -> URIAuth { uriUserInfo = ""+                                  , uriRegName  = ht+                                  , uriPort     = p+                                  }   where     -- Note: just in case you're wondering..the convention is to include the ':'     -- in the port part..@@ -265,13 +265,13 @@  rqMethodMap :: [(String, RequestMethod)] rqMethodMap = [("HEAD",    HEAD),-	       ("PUT",     PUT),-	       ("GET",     GET),-	       ("POST",    POST),+               ("PUT",     PUT),+               ("GET",     GET),+               ("POST",    POST),                ("DELETE",  DELETE),-	       ("OPTIONS", OPTIONS),-	       ("TRACE",   TRACE),-	       ("CONNECT", CONNECT)]+               ("OPTIONS", OPTIONS),+               ("TRACE",   TRACE),+               ("CONNECT", CONNECT)]  --  -- for backwards-ish compatibility; suggest@@ -309,7 +309,7 @@         show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf         ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf         where-	    ver = fromMaybe httpVersion (getRequestVersion req)+            ver = fromMaybe httpVersion (getRequestVersion req)             alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/'                          then u { uriPath = '/' : uriPath u }                          else u@@ -730,7 +730,7 @@   insertHeaderIfMissing HdrHost h $     r { rqURI = (rqURI r){ uriScheme = ""                          , uriAuthority = Nothing-			 }}+                         }}  -- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options -- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option@@ -759,7 +759,7 @@ -- via the @NormalizeRequestOptions@ record. normalizeRequest :: NormalizeRequestOptions ty                  -> Request ty-		 -> Request ty+                 -> Request ty normalizeRequest opts req = foldr (\ f -> f opts) req normalizers  where   --normalizers :: [RequestNormalizer ty]@@ -817,26 +817,26 @@     ("",_uri_abs)       | forProxy ->           case findHeader HdrHost req of-	   Nothing -> req -- no host/authority in sight..not much we can do.-	   Just h  -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}-	                           , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri-				   }}+           Nothing -> req -- no host/authority in sight..not much we can do.+           Just h  -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}+                                   , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri+                                   }}             where -	      hst = case span (/='@') user_hst of-	               (as,'@':bs) -> -		          case span (/=':') as of-			    (_,_:_) -> bs-			    _ -> user_hst-		       _ -> user_hst+              hst = case span (/='@') user_hst of+                       (as,'@':bs) ->+                          case span (/=':') as of+                            (_,_:_) -> bs+                            _ -> user_hst+                       _ -> user_hst -	      (user_hst, pNum) = -	         case span isDigit (reverse h) of-		   (ds,':':bs) -> (reverse bs, ':':reverse ds)-		   _ -> (h,"")+              (user_hst, pNum) =+                 case span isDigit (reverse h) of+                   (ds,':':bs) -> (reverse bs, ':':reverse ds)+                   _ -> (h,"")       | otherwise ->           case findHeader HdrHost req of-	   Nothing -> req -- no host/authority in sight..not much we can do...complain?-	   Just{}  -> req+           Nothing -> req -- no host/authority in sight..not much we can do...complain?+           Just{}  -> req     (h,uri_abs)        | forProxy  -> insertHeaderIfMissing HdrHost h req        | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass@@ -869,7 +869,7 @@ normalizeHostHeader rq =    insertHeaderIfMissing HdrHost                         (uriToAuthorityString $ rqURI rq)-			rq+                        rq                                       -- Looks for a "Connection" header with the value "close". -- Returns True when this is found.@@ -877,7 +877,7 @@ findConnClose hdrs =   maybe False         (\ x -> map toLower (trim x) == "close")-	(lookupHeader HdrConnection hdrs)+        (lookupHeader HdrConnection hdrs)  -- | Used when we know exactly how many bytes to expect. linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))@@ -889,8 +889,8 @@ --   take data once and give up the rest. hopefulTransfer :: BufferOp a                 -> IO (Result a)-		-> [a]-		-> IO (Result ([Header],a))+                -> [a]+                -> IO (Result ([Header],a)) hopefulTransfer bufOps readL strs      = readL >>=        either (\v -> return $ Left v)@@ -902,7 +902,7 @@ --   Also the only transfer variety likely to --   return any footers. chunkedTransfer :: BufferOp a-		-> IO (Result a)+                -> IO (Result a)                 -> (Int -> IO (Result a))                 -> IO (Result ([Header], a)) chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0@@ -910,9 +910,9 @@ chunkedTransferC :: BufferOp a                  -> IO (Result a)                  -> (Int -> IO (Result a))-		 -> [a]-		 -> Int-		 -> IO (Result ([Header], a))+                 -> [a]+                 -> Int+                 -> IO (Result ([Header], a)) chunkedTransferC bufOps readL readBlk acc n = do   v <- readL   case v of@@ -921,25 +921,25 @@      | size == 0 ->           -- last chunk read; look for trailing headers..         fmapE (\ strs -> do-	         ftrs <- parseHeaders (map (buf_toStr bufOps) strs)-		   -- insert (computed) Content-Length header.-		 let ftrs' = Header HdrContentLength (show n) : ftrs+                 ftrs <- parseHeaders (map (buf_toStr bufOps) strs)+                  -- insert (computed) Content-Length header.+                 let ftrs' = Header HdrContentLength (show n) : ftrs                  return (ftrs',buf_concat bufOps (reverse acc))) -	      (readTillEmpty2 bufOps readL [])+              (readTillEmpty2 bufOps readL [])       | otherwise -> do          some <- readBlk size-	 case some of-	   Left e -> return (Left e)-	   Right cdata -> do-	       _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?-	       chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size)+         case some of+           Left e -> return (Left e)+           Right cdata -> do+               _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?+               chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size)      where       size         | buf_isEmpty bufOps line = 0        | otherwise = -	 case readHex (buf_toStr bufOps line) of+         case readHex (buf_toStr bufOps line) of           (hx,_):_ -> hx           _        -> 0 @@ -951,13 +951,13 @@  -- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) readTillEmpty1 :: BufferOp a-	       -> IO (Result a)+               -> IO (Result a)                -> IO (Result [a]) readTillEmpty1 bufOps readL =   readL >>=     either (return . Left)            (\ s -> -	       if buf_isLineTerm bufOps s+               if buf_isLineTerm bufOps s                 then readTillEmpty1 bufOps readL                 else readTillEmpty2 bufOps readL [s]) @@ -967,14 +967,14 @@ --   thing to do - so probably indicates an --   error condition. readTillEmpty2 :: BufferOp a-	       -> IO (Result a)-	       -> [a]-	       -> IO (Result [a])+               -> IO (Result a)+               -> [a]+               -> IO (Result [a]) readTillEmpty2 bufOps readL list =     readL >>=       either (return . Left)              (\ s ->-	        if buf_isLineTerm bufOps s || buf_isEmpty bufOps s+                if buf_isLineTerm bufOps s || buf_isEmpty bufOps s                  then return (Right $ reverse (s:list))                  else readTillEmpty2 bufOps readL (s:list)) 

@@ -119,7 +119,7 @@     mkCookie :: String -> String -> [(String,String)] -> Cookie    mkCookie nm cval more = -	  MkCookie { ckName    = nm+          MkCookie { ckName    = nm                    , ckValue   = cval                    , ckDomain  = map toLower (fromMaybe dom (lookup "domain" more))                    , ckPath    = lookup "path" more

@@ -84,9 +84,9 @@ -- request transmission and its performance. sendHTTP_notify :: HStream ty                 => HandleStream ty-		-> Request ty-		-> IO ()-		-> IO (Result (Response ty))+                -> Request ty+                -> IO ()+                -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do   when providedClose $ (closeOnEnd conn True)   onException (sendMain conn rq onSendComplete)@@ -106,9 +106,9 @@ -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: HStream ty          => HandleStream ty-	 -> Request ty-	 -> (IO ())-	 -> IO (Result (Response ty))+         -> Request ty+         -> (IO ())+         -> IO (Result (Response ty)) sendMain conn rqst onSendComplete = do       --let str = if null (rqBody rqst)       --              then show rqst@@ -128,7 +128,7 @@  switchResponse :: HStream ty                => HandleStream ty-	       -> Bool {- allow retry? -}+               -> Bool {- allow retry? -}                -> Bool {- is body sent? -}                -> Result ResponseData                -> Request ty@@ -143,7 +143,7 @@      Continue       | not bdy_sent -> do {- Time to send the body -}         writeBlock conn (rqBody rqst) >>= either (return . Left)-	   (\ _ -> do+           (\ _ -> do               rsp <- getResponseHead conn               switchResponse conn allow_retry True rsp rqst)       | otherwise    -> do {- keep waiting -}@@ -155,8 +155,8 @@                     other than "100-Continue" -}         -- TODO review throwing away of result         _ <- writeBlock conn ((buf_append bufferOps)-		                     (buf_fromStr bufferOps (show rqst))-			             (rqBody rqst))+                                     (buf_fromStr bufferOps (show rqst))+                                     (rqBody rqst))         rsp <- getResponseHead conn         switchResponse conn False bdy_sent rsp rqst                      @@ -171,22 +171,22 @@      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"))+                       (\ 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)+           close conn+           return r+         Right (Response _ _ hs _) -> do+           when (findConnClose hs)                 (closeOnEnd conn True)-	   return r+           return r        where        tc = lookupHeader HdrTransferEncoding hdrs@@ -208,18 +208,18 @@    getRequestHead = do       fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es))             (readTillEmpty1 bufferOps (readLine conn))-	+    processRequest (rm,uri,hdrs) =       fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $-	     maybe -	      (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""-	             (\ x -> readsOne (linearTransfer (readBlock conn))-			              (return$responseParseError "unrecognized Content-Length value" x)-				      x)-				      -		     cl)-  	      (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))-	                 (uglyDeathTransfer "receiveHTTP"))+             maybe+              (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""+                     (\ x -> readsOne (linearTransfer (readBlock conn))+                                      (return$responseParseError "unrecognized Content-Length value" x)+                                      x)++                     cl)+              (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+                         (uglyDeathTransfer "receiveHTTP"))               tc     where      -- FIXME : Also handle 100-continue.

@@ -279,17 +279,17 @@ parseHeaders :: [String] -> Result [Header] parseHeaders = catRslts [] .                   map (parseHeader . clean) . -		     joinExtended ""+                     joinExtended ""    where         -- Joins consecutive lines where the second line         -- begins with ' ' or '\t'.         joinExtended old      [] = [old]         joinExtended old (h : t)-	  | isLineExtension h    = joinExtended (old ++ ' ' : tail h) t+          | isLineExtension h    = joinExtended (old ++ ' ' : tail h) t           | otherwise            = old : joinExtended h t-	-	isLineExtension (x:_) = x == ' ' || x == '\t'-	isLineExtension _ = False++        isLineExtension (x:_) = x == ' ' || x == '\t'+        isLineExtension _ = False          clean [] = []         clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t

@@ -91,6 +91,7 @@ instance Num ABCD where  ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + (-)         = error "(-){ABCD}: no instance method defined"  (*)         = error "(*){ABCD}: no instance method defined"  signum      = error "signum{ABCD}: no instance method defined"  fromInteger = error "fromInteger{ABCD}: no instance method defined"

@@ -25,7 +25,7 @@ #endif -} -import Control.Monad ( when, mplus, join, liftM, liftM2)+import Control.Monad ( when, mplus, join, liftM2)  #if defined(WIN32) import Network.HTTP.Base ( catchIO )@@ -196,7 +196,7 @@        [] -> Nothing        as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri)         where-	 (usr,pwd) = chopAtDelim ':' as+         (usr,pwd) = chopAtDelim ':' as  uri2proxy _ = Nothing 

@@ -127,7 +127,7 @@ -- to the RFC. switchResponse :: Stream s                => s-	       -> Bool {- allow retry? -}+               -> Bool {- allow retry? -}                -> Bool {- is body sent? -}                -> Result ResponseData                -> Request_String@@ -163,12 +163,12 @@                        }                                          Done -> do-		    when (findConnClose hdrs)-            	    	 (closeOnEnd conn True)+                    when (findConnClose hdrs)+                         (closeOnEnd conn True)                     return (Right $ Response cd rn hdrs "")                  DieHorribly str -> do-		    close conn+                    close conn                     return $ responseParseError "sendHTTP" ("Invalid response: " ++ str)                  ExpectEntity ->@@ -183,14 +183,14 @@                           Just x  ->                                case map toLower (trim x) of                                   "chunked" -> chunkedTransfer stringBufferOp-				                               (readLine conn) (readBlock conn)+                                                               (readLine conn) (readBlock conn)                                   _         -> uglyDeathTransfer "sendHTTP"                        ; 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))+                           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 @@ -204,13 +204,13 @@             do { lor <- readTillEmpty1 stringBufferOp (readLine conn)                ; return $ lor >>= parseRequestHead                }-	+         processRequest (Left e) = return $ Left e-	processRequest (Right (rm,uri,hdrs)) = -	    do -- FIXME : Also handle 100-continue.+        processRequest (Right (rm,uri,hdrs)) =+            do -- FIXME : Also handle 100-continue.                let tc = lookupHeader HdrTransferEncoding hdrs                    cl = lookupHeader HdrContentLength hdrs-	       rslt <- case tc of+               rslt <- case tc of                           Nothing ->                               case cl of                                   Just x  -> linearTransfer (readBlock conn) (read x :: Int)@@ -218,12 +218,12 @@                           Just x  ->                               case map toLower (trim x) of                                   "chunked" -> chunkedTransfer stringBufferOp-				                               (readLine conn) (readBlock conn)+                                                               (readLine conn) (readBlock conn)                                   _         -> uglyDeathTransfer "receiveHTTP"                                return $ do-	          (ftrs,bdy) <- rslt-		  return (Request uri rm (hdrs++ftrs) bdy)+                  (ftrs,bdy) <- rslt+                  return (Request uri rm (hdrs++ftrs) bdy)  -- | Very simple function, send a HTTP response over the given stream. This  --   could be improved on to use different transfer types.@@ -233,4 +233,4 @@                           -- write body immediately, don't wait for 100 CONTINUE                           -- TODO review throwing away of result                           _ <- writeBlock conn (rspBody rsp)-			  return ()+                          return ()

@@ -27,7 +27,7 @@      hSetBuffering, BufferMode(NoBuffering)    ) import Network.TCP ( HandleStream, HStream, -       		     StreamHooks(..), setStreamHooks, getStreamHooks )+                     StreamHooks(..), setStreamHooks, getStreamHooks )  -- | Allows stream logging.  Refer to 'debugStream' below. data StreamDebugger x@@ -37,17 +37,17 @@     readBlock (Dbg h x) n =         do val <- readBlock x n            hPutStrLn h ("--readBlock " ++ show n)-	   hPutStrLn h (show val)+           hPutStrLn h (show val)            return val     readLine (Dbg h x) =         do val <- readLine x            hPutStrLn h ("--readLine")-	   hPutStrLn h (show val)+           hPutStrLn h (show val)            return val     writeBlock (Dbg h x) str =         do val <- writeBlock x str            hPutStrLn h ("--writeBlock" ++ show str)-	   hPutStrLn h (show val)+           hPutStrLn h (show val)            return val     close (Dbg h x) =         do hPutStrLn h "--closing..."@@ -89,12 +89,12 @@        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}+           let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}            hPutStrLn h ("--readLine")-	   hPutStrLn h (either show show eval)+           hPutStrLn h (either show show eval)     , hook_writeBlock = \ toStr str val -> do            hPutStrLn h ("--writeBlock " ++ show val)-	   hPutStrLn h (toStr str)+           hPutStrLn h (toStr str)     , hook_close = do            hPutStrLn h "--closing..."            hFlush h

@@ -88,12 +88,12 @@  data Conn a   = MkConn { connSock      :: ! Socket-	  , connHandle    :: Handle+          , connHandle    :: Handle           , connBuffer    :: BufferOp a-	  , connInput     :: Maybe a+          , connInput     :: Maybe a           , connEndPoint  :: EndPoint-	  , connHooks     :: Maybe (StreamHooks a)-	  , connCloseEOF  :: Bool -- True => close socket upon reaching end-of-stream.+          , connHooks     :: Maybe (StreamHooks a)+          , connCloseEOF  :: Bool -- True => close socket upon reaching end-of-stream.           }  | ConnClosed    deriving(Eq)@@ -248,8 +248,8 @@ socketConnection :: BufferType ty                  => String                  -> Int-		 -> Socket-		 -> IO (HandleStream ty)+                 -> Socket+                 -> IO (HandleStream ty) socketConnection hst port sock = socketConnection_ hst port sock False  -- Internal function used to control the on-demand streaming of input@@ -257,21 +257,21 @@ socketConnection_ :: BufferType ty                   => String                   -> Int-		  -> Socket-		  -> Bool-		  -> IO (HandleStream ty)+                  -> Socket+                  -> Bool+                  -> IO (HandleStream ty) socketConnection_ hst port sock stashInput = do     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-	 , connEndPoint = EndPoint hst port-	 , connHooks    = Nothing-	 , connCloseEOF = False-	 }+         , connHandle   = h+         , connBuffer   = bufferOps+         , connInput    = mb+         , connEndPoint = EndPoint hst port+         , connHooks    = Nothing+         , connCloseEOF = False+         }     v <- newMVar conn     return (HandleStream v) @@ -330,7 +330,7 @@    x <- bufferGetBlock ref n    maybe (return ())          (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x)-	 (connHooks' conn)+         (connHooks' conn)    return x  -- This function uses a buffer, at this time the buffer is just 1000 characters.@@ -340,7 +340,7 @@    x <- bufferReadLine ref    maybe (return ())          (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x)-	 (connHooks' conn)+         (connHooks' conn)    return x  -- The 'Connection' object allows no outward buffering, @@ -350,7 +350,7 @@   x    <- bufferPutBlock (connBuffer conn) (connHandle conn) b   maybe (return ())         (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x)-	(connHooks' conn)+        (connHooks' conn)   return x  closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO ()@@ -361,7 +361,7 @@    conn <- readMVar (getRef c)    maybe (return ())          (hook_close)-	 (connHooks' conn)+         (connHooks' conn)  closeEOF :: HandleStream ty -> Bool -> IO () closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg})@@ -376,11 +376,11 @@     _ -> do       catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)               (\ e ->-		       if isEOFError e -			then do-			  when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())-			  return (return (buf_empty (connBuffer conn)))-			else return (failMisc (show e)))+                       if isEOFError e+                        then do+                          when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())+                          return (return (buf_empty (connBuffer conn)))+                        else return (failMisc (show e)))  bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) bufferPutBlock ops h b = @@ -397,12 +397,12 @@     return (return (buf_append (connBuffer conn) a newl))    _ -> catchIO               (buf_hGetLine (connBuffer conn) (connHandle conn) >>= -	            return . return . appendNL (connBuffer conn))+                    return . return . appendNL (connBuffer conn))               (\ e ->                  if isEOFError e                   then do-	  	    when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())-		    return (return   (buf_empty (connBuffer conn)))+                    when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())+                    return (return   (buf_empty (connBuffer conn)))                   else return (failMisc (show e)))  where    -- yes, this s**ks.. _may_ have to be addressed if perf