{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------

-- |

-- Module      :  Network.HTTP.Base

-- Copyright   :  See LICENSE file

-- License     :  BSD

-- 

-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>

-- 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:

-- >

-- >       //<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 <- 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: <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)