Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
968 lines (822 sloc) 33.1 KB
{-# 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 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-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: <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
: 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
-- | @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 ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) 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))
Something went wrong with that request. Please try again.