{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Base -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- 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, munch1 ) 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: -- > -- > //:@:/ -- > Some or all of the parts ":@", ":", -- > ":", and "/" 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 <- 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 rfc2732host = do _ <- char '[' res <- munch1 (/=']') _ <- char ']' return res 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-4000.0.9" {-# 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: 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))