Network/HTTP/Base.hs

{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Network.HTTP.Base
-- Copyright : See LICENSE file
-- License : BSD
-- 
-- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>
-- Stability : experimental
-- Portability : non-portable (not tested)
--
-- Definitions of @Request@ and @Response@ types along with functions
-- for normalizing them. It is assumed to be an internal module; user
-- code should, if possible, import @Network.HTTP@ to access the functionality
-- that this module provides.
--
-- Additionally, the module exports internal functions for working with URLs,
-- and for handling the processing of requests and responses coming back.
--
-----------------------------------------------------------------------------
module Network.HTTP.Base
 (
 -- ** Constants
 httpVersion -- :: String

 -- ** HTTP
 , Request(..)
 , Response(..)
 , RequestMethod(..)
 
 , Request_String
 , Response_String
 , HTTPRequest
 , HTTPResponse
 
 -- ** URL Encoding
 , urlEncode
 , urlDecode
 , urlEncodeVars

 -- ** URI authority parsing
 , URIAuthority(..)
 , parseURIAuthority
 
 -- internal
 , uriToAuthorityString -- :: URI -> String
 , uriAuthToString -- :: URIAuth -> String
 , uriAuthPort -- :: Maybe URI -> URIAuth -> Int
 , reqURIAuth -- :: Request ty -> URIAuth

 , parseResponseHead -- :: [String] -> Result ResponseData
 , parseRequestHead -- :: [String] -> Result RequestData

 , ResponseNextStep(..)
 , matchResponse
 , ResponseData
 , ResponseCode
 , RequestData
 
 , NormalizeRequestOptions(..) 
 , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty
 , RequestNormalizer

 , normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty

 , splitRequestURI

 , getAuth
 , normalizeRequestURI
 , normalizeHostHeader
 , findConnClose

 -- internal export (for the use by Network.HTTP.{Stream,ByteStream} )
 , linearTransfer
 , hopefulTransfer
 , chunkedTransfer
 , uglyDeathTransfer
 , readTillEmpty1
 , readTillEmpty2
 
 , defaultGETRequest
 , defaultGETRequest_
 , mkRequest
 , setRequestBody

 , defaultUserAgent
 , httpPackageVersion
 , libUA {- backwards compatibility, will disappear..soon -}
 
 , catchIO
 , catchIO_
 , responseParseError
 
 , getRequestVersion
 , getResponseVersion
 , setRequestVersion
 , setResponseVersion

 , failHTTPS
 
 ) where

import Network.URI
 ( URI(uriAuthority, uriPath, uriScheme)
 , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort)
 , parseURIReference
 )

import Control.Monad ( guard )
import Control.Monad.Error ()
import Data.Bits ( (.&.), (.|.), shiftL, shiftR )
import Data.Word ( Word8 )
import Data.Char ( digitToInt, intToDigit, toLower, isDigit,
 isAscii, isAlphaNum, ord, chr )
import Data.List ( partition, find )
import Data.Maybe ( listToMaybe, fromMaybe )
import Numeric ( readHex )

import Network.Stream
import Network.BufferType ( BufferOp(..), BufferType(..) )
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim, crlf, sp, readsOne )
import qualified Network.HTTP.Base64 as Base64 (encode)

import Text.Read.Lex (readDecP)
import Text.ParserCombinators.ReadP
 ( ReadP, readP_to_S, char, (<++), look, munch )

import Control.Exception as Exception (catch, IOException)

import qualified Paths_HTTP as Self (version)
import Data.Version (showVersion)

-----------------------------------------------------------------
------------------ URI Authority parsing ------------------------
-----------------------------------------------------------------

data URIAuthority = URIAuthority { user :: Maybe String, 
				 password :: Maybe String,
				 host :: String,
				 port :: Maybe Int
				 } deriving (Eq,Show)

-- | Parse the authority part of a URL.
--
-- > RFC 1732, section 3.1:
-- >
-- > //<user>:<password>@<host>:<port>/<url-path>
-- > Some or all of the parts "<user>:<password>@", ":<password>",
-- > ":<port>", and "/<url-path>" may be excluded.
parseURIAuthority :: String -> Maybe URIAuthority
parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))


pURIAuthority :: ReadP URIAuthority
pURIAuthority = do
		(u,pw) <- (pUserInfo `before` char '@') 
			 <++ return (Nothing, Nothing)
		h <- munch (/=':')
		p <- orNothing (char ':' >> readDecP)
		look >>= guard . null 
		return URIAuthority{ user=u, password=pw, host=h, port=p }

pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo = do
	 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

orNothing :: ReadP a -> ReadP (Maybe a)
orNothing p = fmap Just p <++ return Nothing

-- This function duplicates old Network.URI.authority behaviour.
uriToAuthorityString :: URI -> String
uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u)

uriAuthToString :: URIAuth -> String
uriAuthToString ua = 
 concat [ uriUserInfo ua 
 , uriRegName ua
	 , uriPort ua
	 ]

uriAuthPort :: Maybe URI -> URIAuth -> Int
uriAuthPort mbURI u = 
 case uriPort u of
 (':':s) -> readsOne id (default_port mbURI) s
 _ -> default_port mbURI
 where
 default_port Nothing = default_http
 default_port (Just url) = 
 case map toLower $ uriScheme url of
 "http:" -> default_http
 "https:" -> default_https
 -- todo: refine
 _ -> default_http

 default_http = 80
 default_https = 443

failHTTPS :: Monad m => URI -> m ()
failHTTPS uri
 | map toLower (uriScheme uri) == "https:" = fail "https not supported"
 | otherwise = return ()

-- Fish out the authority from a possibly normalized Request, i.e.,
-- the information may either be in the request's URI or inside
-- the Host: header.
reqURIAuth :: Request ty -> URIAuth
reqURIAuth req = 
 case uriAuthority (rqURI req) of
 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
			 }
 where
 -- Note: just in case you're wondering..the convention is to include the ':'
 -- in the port part..
 toHostPort h = break (==':') h

-----------------------------------------------------------------
------------------ HTTP Messages --------------------------------
-----------------------------------------------------------------


-- Protocol version
httpVersion :: String
httpVersion = "HTTP/1.1"


-- | The HTTP request method, to be used in the 'Request' object.
-- We are missing a few of the stranger methods, but these are
-- not really necessary until we add full TLS.
data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String
 deriving(Eq)

instance Show RequestMethod where
 show x = 
 case x of
 HEAD -> "HEAD"
 PUT -> "PUT"
 GET -> "GET"
 POST -> "POST"
 DELETE -> "DELETE"
 OPTIONS -> "OPTIONS"
 TRACE -> "TRACE"
 CONNECT -> "CONNECT"
 Custom c -> c

rqMethodMap :: [(String, RequestMethod)]
rqMethodMap = [("HEAD", HEAD),
	 ("PUT", PUT),
	 ("GET", GET),
	 ("POST", POST),
 ("DELETE", DELETE),
	 ("OPTIONS", OPTIONS),
	 ("TRACE", TRACE),
	 ("CONNECT", CONNECT)]

-- 
-- for backwards-ish compatibility; suggest
-- migrating to new Req/Resp by adding type param.
-- 
type Request_String = Request String
type Response_String = Response String

-- Hmm..I really want to use these for the record
-- type, but it will upset codebases wanting to
-- migrate (and live with using pre-HTTPbis versions.)
type HTTPRequest a = Request a
type HTTPResponse a = Response a

-- | An HTTP Request.
-- The 'Show' instance of this type is used for message serialisation,
-- which means no body data is output.
data Request a =
 Request { rqURI :: URI -- ^ might need changing in future
 -- 1) to support '*' uri in OPTIONS request
 -- 2) transparent support for both relative
 -- & absolute uris, although this should
 -- already work (leave scheme & host parts empty).
 , rqMethod :: RequestMethod
 , rqHeaders :: [Header]
 , rqBody :: a
 }

-- Notice that request body is not included,
-- this show function is used to serialise
-- a request for the transport link, we send
-- the body separately where possible.
instance Show (Request a) where
 show req@(Request u m h _) =
 show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf
 ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf
 where
	 ver = fromMaybe httpVersion (getRequestVersion req)
 alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' 
 then u { uriPath = '/' : uriPath u } 
 else u

instance HasHeaders (Request a) where
 getHeaders = rqHeaders
 setHeaders rq hdrs = rq { rqHeaders=hdrs }

-- | For easy pattern matching, HTTP response codes @xyz@ are
-- represented as @(x,y,z)@.
type ResponseCode = (Int,Int,Int)

-- | @ResponseData@ contains the head of a response payload;
-- HTTP response code, accompanying text description + header
-- fields.
type ResponseData = (ResponseCode,String,[Header])

-- | @RequestData@ contains the head of a HTTP request; method,
-- its URL along with the auxillary/supporting header data.
type RequestData = (RequestMethod,URI,[Header])

-- | An HTTP Response.
-- The 'Show' instance of this type is used for message serialisation,
-- which means no body data is output, additionally the output will
-- show an HTTP version of 1.1 instead of the actual version returned
-- by a server.
data Response a =
 Response { rspCode :: ResponseCode
 , rspReason :: String
 , rspHeaders :: [Header]
 , rspBody :: a
 }
 
-- This is an invalid representation of a received response, 
-- since we have made the assumption that all responses are HTTP/1.1
instance Show (Response a) where
 show rsp@(Response (a,b,c) reason headers _) =
 ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf
 ++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf
 where
 ver = fromMaybe httpVersion (getResponseVersion rsp)

instance HasHeaders (Response a) where
 getHeaders = rspHeaders
 setHeaders rsp hdrs = rsp { rspHeaders=hdrs }


------------------------------------------------------------------
------------------ Request Building ------------------------------
------------------------------------------------------------------

-- | Deprecated. Use 'defaultUserAgent'
libUA :: String
libUA = "hs-HTTP-400009"
{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-}

-- | A default user agent string. The string is @\"haskell-HTTP/$version\"@
-- where @$version@ is the version of this HTTP package.
--
defaultUserAgent :: String
defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion

-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This
-- may be useful to include in a user agent string so that you can determine
-- from server logs what version of this package HTTP clients are using.
-- This can be useful for tracking down HTTP compatibility quirks.
--
httpPackageVersion :: String
httpPackageVersion = showVersion Self.version

defaultGETRequest :: URI -> Request_String
defaultGETRequest uri = defaultGETRequest_ uri

defaultGETRequest_ :: BufferType a => URI -> Request a
defaultGETRequest_ uri = mkRequest GET uri 

-- | 'mkRequest method uri' constructs a well formed
-- request for the given HTTP method and URI. It does not
-- normalize the URI for the request _nor_ add the required 
-- Host: header. That is done either explicitly by the user
-- or when requests are normalized prior to transmission.
mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty
mkRequest meth uri = req
 where
 req = 
 Request { rqURI = uri
 , rqBody = empty
 , rqHeaders = [ Header HdrContentLength "0"
 , Header HdrUserAgent defaultUserAgent
 ]
 , rqMethod = meth
 }

 empty = buf_empty (toBufOps req)

-- set rqBody, Content-Type and Content-Length headers.
setRequestBody :: Request_String -> (String, String) -> Request_String
setRequestBody req (typ, body) = req' { rqBody=body }
 where
 req' = replaceHeader HdrContentType typ .
 replaceHeader HdrContentLength (show $ length body) $
 req

{-
 -- stub out the user info.
 updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri)

 withHost = 
 case uriToAuthorityString uri{uriAuthority=updAuth} of
 "" -> id
 h -> ((Header HdrHost h):)

 uri_req 
 | forProxy = uri
 | otherwise = snd (splitRequestURI uri)
-}


toBufOps :: BufferType a => Request a -> BufferOp a
toBufOps _ = bufferOps

-----------------------------------------------------------------
------------------ Parsing --------------------------------------
-----------------------------------------------------------------

-- Parsing a request
parseRequestHead :: [String] -> Result RequestData
parseRequestHead [] = Left ErrorClosed
parseRequestHead (com:hdrs) = do
 (version,rqm,uri) <- requestCommand com (words com)
 hdrs' <- parseHeaders hdrs
 return (rqm,uri,withVer version hdrs')
 where
 withVer [] hs = hs
 withVer (h:_) hs = withVersion h hs

 requestCommand l _yes@(rqm:uri:version) =
 case (parseURIReference uri, lookup rqm rqMethodMap) of
 (Just u, Just r) -> return (version,r,u)
 (Just u, Nothing) -> return (version,Custom rqm,u)
 _ -> parse_err l
 requestCommand l _
 | null l = failWith ErrorClosed
 | otherwise = parse_err l

 parse_err l = responseParseError "parseRequestHead"
 ("Request command line parse failure: " ++ l)

-- Parsing a response
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead [] = failWith ErrorClosed
parseResponseHead (sts:hdrs) = do
 (version,code,reason) <- responseStatus sts (words sts)
 hdrs' <- parseHeaders hdrs
 return (code,reason, withVersion version hdrs')
 where
 responseStatus _l _yes@(version:code:reason) =
 return (version,match code,concatMap (++" ") reason)
 responseStatus l _no 
 | null l = failWith ErrorClosed -- an assumption
 | otherwise = parse_err l

 parse_err l = 
 responseParseError 
 "parseResponseHead"
 ("Response status line parse failure: " ++ l)

 match [a,b,c] = (digitToInt a,
 digitToInt b,
 digitToInt c)
 match _ = (-1,-1,-1) -- will create appropriate behaviour

-- To avoid changing the @RequestData@ and @ResponseData@ types
-- just for this (and the upstream backwards compat. woes that
-- will result in), encode version info as a custom header.
-- Used by 'parseResponseData' and 'parseRequestData'.
--
-- Note: the Request and Response types do not currently represent
-- the version info explicitly in their record types. You have to use
-- {get,set}{Request,Response}Version for that.
withVersion :: String -> [Header] -> [Header]
withVersion v hs 
 | v == httpVersion = hs -- don't bother adding it if the default.
 | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs

-- | @getRequestVersion req@ returns the HTTP protocol version of
-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed.
getRequestVersion :: Request a -> Maybe String
getRequestVersion r = getHttpVersion r

-- | @setRequestVersion v req@ returns a new request, identical to
-- @req@, but with its HTTP version set to @v@.
setRequestVersion :: String -> Request a -> Request a
setRequestVersion s r = setHttpVersion r s


-- | @getResponseVersion rsp@ returns the HTTP protocol version of
-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be 
-- assumed.
getResponseVersion :: Response a -> Maybe String
getResponseVersion r = getHttpVersion r

-- | @setResponseVersion v rsp@ returns a new response, identical to
-- @rsp@, but with its HTTP version set to @v@.
setResponseVersion :: String -> Response a -> Response a
setResponseVersion s r = setHttpVersion r s

-- internal functions for accessing HTTP-version info in
-- requests and responses. Not exported as it exposes ho
-- version info is represented internally.

getHttpVersion :: HasHeaders a => a -> Maybe String
getHttpVersion r = 
 fmap toVersion $
 find isHttpVersion $
 getHeaders r
 where
 toVersion (Header _ x) = x

setHttpVersion :: HasHeaders a => a -> String -> a
setHttpVersion r v = 
 setHeaders r $
 withVersion v $
 dropHttpVersion $
 getHeaders r

dropHttpVersion :: [Header] -> [Header]
dropHttpVersion hs = filter (not.isHttpVersion) hs

isHttpVersion :: Header -> Bool
isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True
isHttpVersion _ = False 



-----------------------------------------------------------------
------------------ HTTP Send / Recv ----------------------------------
-----------------------------------------------------------------

data ResponseNextStep
 = Continue
 | Retry
 | Done
 | ExpectEntity
 | DieHorribly String

matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse rqst rsp =
 case rsp of
 (1,0,0) -> Continue
 (1,0,1) -> Done -- upgrade to TLS
 (1,_,_) -> Continue -- default
 (2,0,4) -> Done
 (2,0,5) -> Done
 (2,_,_) -> ans
 (3,0,4) -> Done
 (3,0,5) -> Done
 (3,_,_) -> ans
 (4,1,7) -> Retry -- Expectation failed
 (4,_,_) -> ans
 (5,_,_) -> ans
 (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")
 where
 ans | rqst == HEAD = Done
 | otherwise = ExpectEntity
 

 
-----------------------------------------------------------------
------------------ A little friendly funtionality ---------------
-----------------------------------------------------------------


{-
 I had a quick look around but couldn't find any RFC about
 the encoding of data on the query string. I did find an
 IETF memo, however, so this is how I justify the urlEncode
 and urlDecode methods.

 Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org)

 Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.
 Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"
 URI delims: "<" | ">" | "#" | "%" | <">
 Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>
 <US-ASCII coded character 20 hexadecimal>
 Also unallowed: any non-us-ascii character

 Escape method: char -> '%' a b where a, b :: Hex digits
-}

replacement_character :: Char
replacement_character = '\xfffd'

-- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format.
--
-- Shamelessly stolen from utf-8string-0.3.7
encodeChar :: Char -> [Word8]
encodeChar = map fromIntegral . go . ord
 where
 go oc
 | oc <= 0x7f = [oc]

 | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6)
 , 0x80 + oc .&. 0x3f
 ]

 | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12)
 , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
 , 0x80 + oc .&. 0x3f
 ]
 | otherwise = [ 0xf0 + (oc `shiftR` 18)
 , 0x80 + ((oc `shiftR` 12) .&. 0x3f)
 , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
 , 0x80 + oc .&. 0x3f
 ]

-- | Decode a UTF8 string packed into a list of Word8 values, directly to String
--
-- Shamelessly stolen from utf-8string-0.3.7
decode :: [Word8] -> String
decode [ ] = ""
decode (c:cs)
 | c < 0x80 = chr (fromEnum c) : decode cs
 | c < 0xc0 = replacement_character : decode cs
 | c < 0xe0 = multi1
 | c < 0xf0 = multi_byte 2 0xf 0x800
 | c < 0xf8 = multi_byte 3 0x7 0x10000
 | c < 0xfc = multi_byte 4 0x3 0x200000
 | c < 0xfe = multi_byte 5 0x1 0x4000000
 | otherwise = replacement_character : decode cs
 where
 multi1 = case cs of
 c1 : ds | c1 .&. 0xc0 == 0x80 ->
 let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f)
 in if d >= 0x000080 then toEnum d : decode ds
 else replacement_character : decode ds
 _ -> replacement_character : decode cs

 multi_byte :: Int -> Word8 -> Int -> [Char]
 multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))
 where
 aux 0 rs acc
 | overlong <= acc && acc <= 0x10ffff &&
 (acc < 0xd800 || 0xdfff < acc) &&
 (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs
 | otherwise = replacement_character : decode rs

 aux n (r:rs) acc
 | r .&. 0xc0 == 0x80 = aux (n-1) rs
 $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)

 aux _ rs _ = replacement_character : decode rs


-- This function is a bit funny because potentially the input String could contain some actual Unicode
-- characters (though this shouldn't happen for most use cases), so we have to preserve those characters
-- while simultaneously decoding any UTF-8 data
urlDecode :: String -> String
urlDecode = go []
 where
 go bs ('%':a:b:rest) = go (fromIntegral (16 * digitToInt a + digitToInt b) : bs) rest
 go bs (h:t) | fromEnum h < 256 = go (fromIntegral (fromEnum h) : bs) t -- Treat ASCII as just another byte of UTF-8
 go [] [] = []
 go [] (h:t) = h : go [] t -- h >= 256, so can't be part of any UTF-8 byte sequence
 go bs rest = decode (reverse bs) ++ go [] rest


urlEncode :: String -> String
urlEncode [] = []
urlEncode (ch:t) 
 | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t
 | not (isAscii ch) = foldr escape (urlEncode t) (encodeChar ch)
 | otherwise = escape (fromIntegral (fromEnum ch)) (urlEncode t)
 where
 escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs)

 showH :: Word8 -> String -> String
 showH x xs
 | x <= 9 = to (o_0 + x) : xs
 | otherwise = to (o_A + (x-10)) : xs
 where
 to = toEnum . fromIntegral
 fro = fromIntegral . fromEnum

 o_0 = fro '0'
 o_A = fro 'A'

-- Encode form variables, useable in either the
-- query part of a URI, or the body of a POST request.
-- I have no source for this information except experience,
-- this sort of encoding worked fine in CGI programming.
urlEncodeVars :: [(String,String)] -> String
urlEncodeVars ((n,v):t) =
 let (same,diff) = partition ((==n) . fst) t
 in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)
 ++ urlEncodeRest diff
 where urlEncodeRest [] = []
 urlEncodeRest diff = '&' : urlEncodeVars diff
urlEncodeVars [] = []

-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@
-- header.
getAuth :: Monad m => Request ty -> m URIAuthority
getAuth r = 
 -- ToDo: verify that Network.URI functionality doesn't take care of this (now.)
 case parseURIAuthority auth of
 Just x -> return x 
 Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'"
 where 
 auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r)
 uri = rqURI r

{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty
normalizeRequestURI doClose h r = 
 (if doClose then replaceHeader HdrConnection "close" else id) $
 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
data NormalizeRequestOptions ty
 = NormalizeRequestOptions
 { normDoClose :: Bool
 , normForProxy :: Bool
 , normUserAgent :: Maybe String
 , normCustoms :: [RequestNormalizer ty]
 }

-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites
-- a request into some normalized form.
type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty

defaultNormalizeRequestOptions :: NormalizeRequestOptions ty
defaultNormalizeRequestOptions = NormalizeRequestOptions
 { normDoClose = False
 , normForProxy = False
 , normUserAgent = Just defaultUserAgent
 , normCustoms = []
 }

-- | @normalizeRequest opts req@ is the entry point to use to normalize your
-- request prior to transmission (or other use.) Normalization is controlled
-- via the @NormalizeRequestOptions@ record.
normalizeRequest :: NormalizeRequestOptions ty
 -> Request ty
		 -> Request ty
normalizeRequest opts req = foldr (\ f -> f opts) req normalizers
 where
 --normalizers :: [RequestNormalizer ty]
 normalizers = 
 ( normalizeHostURI
 : normalizeBasicAuth
 : normalizeConnectionClose
 : normalizeUserAgent 
 : normCustoms opts
 )

-- | @normalizeUserAgent ua x req@ augments the request @req@ with 
-- a @User-Agent: ua@ header if @req@ doesn't already have a 
-- a @User-Agent:@ set.
normalizeUserAgent :: RequestNormalizer ty
normalizeUserAgent opts req = 
 case normUserAgent opts of
 Nothing -> req
 Just ua -> 
 case findHeader HdrUserAgent req of
 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
-- _replaces_ any an existing @Connection:@ header in @req@.
normalizeConnectionClose :: RequestNormalizer ty
normalizeConnectionClose opts req 
 | normDoClose opts = replaceHeader HdrConnection "close" req
 | otherwise = req

-- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@
-- if the "user:pass@" part is present in the "http://user:pass@host/path"
-- of the URI. If Authorization header was present already it is not replaced.
normalizeBasicAuth :: RequestNormalizer ty
normalizeBasicAuth _ req =
 case getAuth req of
 Just uriauth ->
 case (user uriauth, password uriauth) of
 (Just u, Just p) ->
 insertHeaderIfMissing HdrAuthorization astr req
 where
 astr = "Basic " ++ base64encode (u ++ ":" ++ p)
 base64encode = Base64.encode . stringToOctets :: String -> String
 stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8]
 (_, _) -> req
 Nothing ->req

-- | @normalizeHostURI forProxy req@ rewrites your request to have it
-- follow the expected formats by the receiving party (proxy or server.)
-- 
normalizeHostURI :: RequestNormalizer ty
normalizeHostURI opts req = 
 case splitRequestURI uri of
 ("",_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
				 }}
 where 
	 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,"")
 | otherwise -> 
 case findHeader HdrHost req of
	 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
 where
 uri0 = rqURI req 
 -- stub out the user:pass 
 uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)}

 forProxy = normForProxy opts

{- Comments re: above rewriting:
 RFC 2616, section 5.1.2:
 "The most common form of Request-URI is that used to identify a
 resource on an origin server or gateway. In this case the absolute
 path of the URI MUST be transmitted (see section 3.2.1, abs_path) as
 the Request-URI, and the network location of the URI (authority) MUST
 be transmitted in a Host header field." 
 We assume that this is the case, so we take the host name from
 the Host header if there is one, otherwise from the request-URI.
 Then we make the request-URI an abs_path and make sure that there
 is a Host header.
-}

splitRequestURI :: URI -> ({-authority-}String, URI)
splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing})

-- Adds a Host header if one is NOT ALREADY PRESENT..
{-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeHostHeader :: Request ty -> Request ty
normalizeHostHeader rq = 
 insertHeaderIfMissing HdrHost
 (uriToAuthorityString $ rqURI rq)
			rq
 
-- Looks for a "Connection" header with the value "close".
-- Returns True when this is found.
findConnClose :: [Header] -> Bool
findConnClose hdrs =
 maybe False
 (\ x -> map toLower (trim x) == "close")
	(lookupHeader HdrConnection hdrs)

-- | Used when we know exactly how many bytes to expect.
linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))
linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n)

-- | Used when nothing about data is known,
-- Unfortunately waiting for a socket closure
-- causes bad behaviour. Here we just
-- take data once and give up the rest.
hopefulTransfer :: BufferOp a
 -> IO (Result a)
		-> [a]
		-> IO (Result ([Header],a))
hopefulTransfer bufOps readL strs 
 = readL >>= 
 either (\v -> return $ Left v)
 (\more -> if (buf_isEmpty bufOps more)
 then return (Right ([], buf_concat bufOps $ reverse strs))
 else hopefulTransfer bufOps readL (more:strs))

-- | A necessary feature of HTTP\/1.1
-- Also the only transfer variety likely to
-- return any footers.
chunkedTransfer :: BufferOp a
		-> IO (Result a)
 -> (Int -> IO (Result a))
 -> IO (Result ([Header], a))
chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0

chunkedTransferC :: BufferOp a
 -> IO (Result a)
 -> (Int -> IO (Result a))
		 -> [a]
		 -> Int
		 -> IO (Result ([Header], a))
chunkedTransferC bufOps readL readBlk acc n = do
 v <- readL
 case v of
 Left e -> return (Left e)
 Right line 
 | 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
 return (ftrs',buf_concat bufOps (reverse acc)))

	 (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)
 where
 size 
 | buf_isEmpty bufOps line = 0
 | otherwise = 
	 case readHex (buf_toStr bufOps line) of
 (hx,_):_ -> hx
 _ -> 0

-- | Maybe in the future we will have a sensible thing
-- to do here, at that time we might want to change
-- the name.
uglyDeathTransfer :: String -> IO (Result ([Header],a))
uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding")

-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)
readTillEmpty1 :: BufferOp a
	 -> IO (Result a)
 -> IO (Result [a])
readTillEmpty1 bufOps readL =
 readL >>=
 either (return . Left)
 (\ s -> 
	 if buf_isLineTerm bufOps s
 then readTillEmpty1 bufOps readL
 else readTillEmpty2 bufOps readL [s])

-- | Read lines until an empty line (CRLF),
-- also accepts a connection close as end of
-- input, which is not an HTTP\/1.1 compliant
-- thing to do - so probably indicates an
-- error condition.
readTillEmpty2 :: BufferOp 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
 then return (Right $ reverse (s:list))
 else readTillEmpty2 bufOps readL (s:list))

--
-- Misc
--

-- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific
-- tweaks better go here.
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO a h = Exception.catch a h

catchIO_ :: IO a -> IO a -> IO a
catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)

responseParseError :: String -> String -> Result a
responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v))