{-# 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.Class ()
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)

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