{-# LANGUAGE CPP, 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 { URIAuthority -> Maybe String
user :: Maybe String,
                                   URIAuthority -> Maybe String
password :: Maybe String,
                                   URIAuthority -> String
host :: String,
                                   URIAuthority -> Maybe Int
port :: Maybe Int
                                 } deriving (URIAuthority -> URIAuthority -> Bool
(URIAuthority -> URIAuthority -> Bool)
-> (URIAuthority -> URIAuthority -> Bool) -> Eq URIAuthority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URIAuthority -> URIAuthority -> Bool
$c/= :: URIAuthority -> URIAuthority -> Bool
== :: URIAuthority -> URIAuthority -> Bool
$c== :: URIAuthority -> URIAuthority -> Bool
Eq,Int -> URIAuthority -> ShowS
[URIAuthority] -> ShowS
URIAuthority -> String
(Int -> URIAuthority -> ShowS)
-> (URIAuthority -> String)
-> ([URIAuthority] -> ShowS)
-> Show URIAuthority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URIAuthority] -> ShowS
$cshowList :: [URIAuthority] -> ShowS
show :: URIAuthority -> String
$cshow :: URIAuthority -> String
showsPrec :: Int -> URIAuthority -> ShowS
$cshowsPrec :: Int -> URIAuthority -> ShowS
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 :: String -> Maybe URIAuthority
parseURIAuthority String
s = [URIAuthority] -> Maybe URIAuthority
forall a. [a] -> Maybe a
listToMaybe (((URIAuthority, String) -> URIAuthority)
-> [(URIAuthority, String)] -> [URIAuthority]
forall a b. (a -> b) -> [a] -> [b]
map (URIAuthority, String) -> URIAuthority
forall a b. (a, b) -> a
fst (ReadP URIAuthority -> ReadS URIAuthority
forall a. ReadP a -> ReadS a
readP_to_S ReadP URIAuthority
pURIAuthority String
s))


pURIAuthority :: ReadP URIAuthority
pURIAuthority :: ReadP URIAuthority
pURIAuthority = do
                (Maybe String
u,Maybe String
pw) <- (ReadP (Maybe String, Maybe String)
pUserInfo ReadP (Maybe String, Maybe String)
-> ReadP Char -> ReadP (Maybe String, Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
`before` Char -> ReadP Char
char Char
'@')
                          ReadP (Maybe String, Maybe String)
-> ReadP (Maybe String, Maybe String)
-> ReadP (Maybe String, Maybe String)
forall a. ReadP a -> ReadP a -> ReadP a
<++ (Maybe String, Maybe String) -> ReadP (Maybe String, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)
                String
h <- ReadP String
rfc2732host ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ (Char -> Bool) -> ReadP String
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':')
                Maybe Int
p <- ReadP Int -> ReadP (Maybe Int)
forall a. ReadP a -> ReadP (Maybe a)
orNothing (Char -> ReadP Char
char Char
':' ReadP Char -> ReadP Int -> ReadP Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Int
forall a. (Eq a, Num a) => ReadP a
readDecP)
                ReadP String
look ReadP String -> (String -> ReadP ()) -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> ReadP ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReadP ()) -> (String -> Bool) -> String -> ReadP ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
                URIAuthority -> ReadP URIAuthority
forall (m :: * -> *) a. Monad m => a -> m a
return URIAuthority :: Maybe String -> Maybe String -> String -> Maybe Int -> URIAuthority
URIAuthority{ user :: Maybe String
user=Maybe String
u, password :: Maybe String
password=Maybe String
pw, host :: String
host=String
h, port :: Maybe Int
port=Maybe Int
p }

-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL
rfc2732host :: ReadP String
rfc2732host :: ReadP String
rfc2732host = do
    Char
_ <- Char -> ReadP Char
char Char
'['
    String
res <- (Char -> Bool) -> ReadP String
munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
']')
    Char
_ <- Char -> ReadP Char
char Char
']'
    String -> ReadP String
forall (m :: * -> *) a. Monad m => a -> m a
return String
res

pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo = do
            Maybe String
u <- ReadP String -> ReadP (Maybe String)
forall a. ReadP a -> ReadP (Maybe a)
orNothing ((Char -> Bool) -> ReadP String
munch (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
":@"))
            Maybe String
p <- ReadP String -> ReadP (Maybe String)
forall a. ReadP a -> ReadP (Maybe a)
orNothing (Char -> ReadP Char
char Char
':' ReadP Char -> ReadP String -> ReadP String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> ReadP String
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'@'))
            (Maybe String, Maybe String) -> ReadP (Maybe String, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
u,Maybe String
p)

before :: Monad m => m a -> m b -> m a
before :: m a -> m b -> m a
before m a
a m b
b = m a
a m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> m b
b m b -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

orNothing :: ReadP a -> ReadP (Maybe a)
orNothing :: ReadP a -> ReadP (Maybe a)
orNothing ReadP a
p = (a -> Maybe a) -> ReadP a -> ReadP (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just ReadP a
p ReadP (Maybe a) -> ReadP (Maybe a) -> ReadP (Maybe a)
forall a. ReadP a -> ReadP a -> ReadP a
<++ Maybe a -> ReadP (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

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

uriAuthToString :: URIAuth -> String
uriAuthToString :: URIAuth -> String
uriAuthToString URIAuth
ua = 
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ URIAuth -> String
uriUserInfo URIAuth
ua 
         , URIAuth -> String
uriRegName URIAuth
ua
         , URIAuth -> String
uriPort URIAuth
ua
         ]

uriAuthPort :: Maybe URI -> URIAuth -> Int
uriAuthPort :: Maybe URI -> URIAuth -> Int
uriAuthPort Maybe URI
mbURI URIAuth
u = 
  case URIAuth -> String
uriPort URIAuth
u of
    (Char
':':String
s) -> (Int -> Int) -> Int -> String -> Int
forall a b. Read a => (a -> b) -> b -> String -> b
readsOne Int -> Int
forall a. a -> a
id (Maybe URI -> Int
default_port Maybe URI
mbURI) String
s
    String
_       -> Maybe URI -> Int
default_port Maybe URI
mbURI
 where
  default_port :: Maybe URI -> Int
default_port Maybe URI
Nothing = Int
default_http
  default_port (Just URI
url) = 
    case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ URI -> String
uriScheme URI
url of
      String
"http:" -> Int
default_http
      String
"https:" -> Int
default_https
        -- todo: refine
      String
_ -> Int
default_http

  default_http :: Int
default_http  = Int
80
  default_https :: Int
default_https = Int
443

#if MIN_VERSION_base(4,13,0)
failHTTPS :: MonadFail m => URI -> m ()
#else
failHTTPS :: Monad m => URI -> m ()
#endif
failHTTPS :: URI -> m ()
failHTTPS URI
uri
  | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (URI -> String
uriScheme URI
uri) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"https:" = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"https not supported"
  | Bool
otherwise = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: Request ty -> URIAuth
reqURIAuth Request ty
req = 
  case URI -> Maybe URIAuth
uriAuthority (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
req) of
    Just URIAuth
ua -> URIAuth
ua
    Maybe URIAuth
_ -> case HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrHost (Request ty -> [Header]
forall a. Request a -> [Header]
rqHeaders Request ty
req) of
           Maybe String
Nothing -> String -> URIAuth
forall a. HasCallStack => String -> a
error (String
"reqURIAuth: no URI authority for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Request ty -> String
forall a. Show a => a -> String
show Request ty
req)
           Just String
h  ->
              case String -> (String, String)
toHostPort String
h of
                (String
ht,String
p) -> URIAuth :: String -> String -> String -> URIAuth
URIAuth { uriUserInfo :: String
uriUserInfo = String
""
                                  , uriRegName :: String
uriRegName  = String
ht
                                  , uriPort :: String
uriPort     = String
p
                                  }
  where
    -- Note: just in case you're wondering..the convention is to include the ':'
    -- in the port part..
   toHostPort :: String -> (String, String)
toHostPort String
h = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') String
h

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


-- Protocol version
httpVersion :: String
httpVersion :: String
httpVersion = String
"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(RequestMethod -> RequestMethod -> Bool
(RequestMethod -> RequestMethod -> Bool)
-> (RequestMethod -> RequestMethod -> Bool) -> Eq RequestMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestMethod -> RequestMethod -> Bool
$c/= :: RequestMethod -> RequestMethod -> Bool
== :: RequestMethod -> RequestMethod -> Bool
$c== :: RequestMethod -> RequestMethod -> Bool
Eq)

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

rqMethodMap :: [(String, RequestMethod)]
rqMethodMap :: [(String, RequestMethod)]
rqMethodMap = [(String
"HEAD",    RequestMethod
HEAD),
               (String
"PUT",     RequestMethod
PUT),
               (String
"GET",     RequestMethod
GET),
               (String
"POST",    RequestMethod
POST),
               (String
"DELETE",  RequestMethod
DELETE),
               (String
"OPTIONS", RequestMethod
OPTIONS),
               (String
"TRACE",   RequestMethod
TRACE),
               (String
"CONNECT", RequestMethod
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 { Request a -> URI
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).
             , Request a -> RequestMethod
rqMethod    :: RequestMethod
             , Request a -> [Header]
rqHeaders   :: [Header]
             , Request a -> a
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 :: Request a -> String
show req :: Request a
req@(Request URI
u RequestMethod
m [Header]
h a
_) =
        RequestMethod -> String
forall a. Show a => a -> String
show RequestMethod
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
alt_uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> ShowS) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ShowS
forall a. [a] -> [a] -> [a]
(++) [] ((Header -> String) -> [Header] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Header -> String
forall a. Show a => a -> String
show ([Header] -> [Header]
dropHttpVersion [Header]
h)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf
        where
            ver :: String
ver = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
httpVersion (Request a -> Maybe String
forall a. Request a -> Maybe String
getRequestVersion Request a
req)
            alt_uri :: String
alt_uri = URI -> String
forall a. Show a => a -> String
show (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriPath URI
u) Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
head (URI -> String
uriPath URI
u) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' 
                        then URI
u { uriPath :: String
uriPath = Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: URI -> String
uriPath URI
u } 
                        else URI
u

instance HasHeaders (Request a) where
    getHeaders :: Request a -> [Header]
getHeaders = Request a -> [Header]
forall a. Request a -> [Header]
rqHeaders
    setHeaders :: Request a -> [Header] -> Request a
setHeaders Request a
rq [Header]
hdrs = Request a
rq { rqHeaders :: [Header]
rqHeaders=[Header]
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 { Response a -> ResponseCode
rspCode     :: ResponseCode
             , Response a -> String
rspReason   :: String
             , Response a -> [Header]
rspHeaders  :: [Header]
             , Response a -> a
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 :: Response a -> String
show rsp :: Response a
rsp@(Response (Int
a,Int
b,Int
c) String
reason [Header]
headers a
_) =
        String
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
a,Int
b,Int
c] String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
reason String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> ShowS) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ShowS
forall a. [a] -> [a] -> [a]
(++) [] ((Header -> String) -> [Header] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Header -> String
forall a. Show a => a -> String
show ([Header] -> [Header]
dropHttpVersion [Header]
headers)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf
     where
      ver :: String
ver = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
httpVersion (Response a -> Maybe String
forall a. Response a -> Maybe String
getResponseVersion Response a
rsp)

instance HasHeaders (Response a) where
    getHeaders :: Response a -> [Header]
getHeaders = Response a -> [Header]
forall a. Response a -> [Header]
rspHeaders
    setHeaders :: Response a -> [Header] -> Response a
setHeaders Response a
rsp [Header]
hdrs = Response a
rsp { rspHeaders :: [Header]
rspHeaders=[Header]
hdrs }


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

-- | Deprecated. Use 'defaultUserAgent'
libUA :: String
libUA :: String
libUA = String
"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 :: String
defaultUserAgent = String
"haskell-HTTP/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 :: String
httpPackageVersion = Version -> String
showVersion Version
Self.version

defaultGETRequest :: URI -> Request_String
defaultGETRequest :: URI -> Request_String
defaultGETRequest URI
uri = URI -> Request_String
forall a. BufferType a => URI -> Request a
defaultGETRequest_ URI
uri

defaultGETRequest_ :: BufferType a => URI -> Request a
defaultGETRequest_ :: URI -> Request a
defaultGETRequest_ URI
uri = RequestMethod -> URI -> Request a
forall ty. BufferType ty => RequestMethod -> URI -> Request ty
mkRequest RequestMethod
GET URI
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 :: RequestMethod -> URI -> Request ty
mkRequest RequestMethod
meth URI
uri = Request ty
req
 where
  req :: Request ty
req = 
    Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request { rqURI :: URI
rqURI      = URI
uri
            , rqBody :: ty
rqBody     = ty
empty
            , rqHeaders :: [Header]
rqHeaders  = [ HeaderName -> String -> Header
Header HeaderName
HdrContentLength String
"0"
                           , HeaderName -> String -> Header
Header HeaderName
HdrUserAgent     String
defaultUserAgent
                           ]
            , rqMethod :: RequestMethod
rqMethod   = RequestMethod
meth
            }

  empty :: ty
empty = BufferOp ty -> ty
forall a. BufferOp a -> a
buf_empty (Request ty -> BufferOp ty
forall a. BufferType a => Request a -> BufferOp a
toBufOps Request ty
req)

-- set rqBody, Content-Type and Content-Length headers.
setRequestBody :: Request_String -> (String, String) -> Request_String
setRequestBody :: Request_String -> (String, String) -> Request_String
setRequestBody Request_String
req (String
typ, String
body) = Request_String
req' { rqBody :: String
rqBody=String
body }
  where
    req' :: Request_String
req' = HeaderSetter Request_String
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrContentType String
typ (Request_String -> Request_String)
-> (Request_String -> Request_String)
-> Request_String
-> Request_String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           HeaderSetter Request_String
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrContentLength (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
body) (Request_String -> Request_String)
-> Request_String -> Request_String
forall a b. (a -> b) -> a -> b
$
           Request_String
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 :: Request a -> BufferOp a
toBufOps Request a
_ = BufferOp a
forall bufType. BufferType bufType => BufferOp bufType
bufferOps

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

-- Parsing a request
parseRequestHead :: [String] -> Result RequestData
parseRequestHead :: [String] -> Result RequestData
parseRequestHead         [] = ConnError -> Result RequestData
forall a b. a -> Either a b
Left ConnError
ErrorClosed
parseRequestHead (String
com:[String]
hdrs) = do
  ([String]
version,RequestMethod
rqm,URI
uri) <- String
-> [String] -> Either ConnError ([String], RequestMethod, URI)
requestCommand String
com (String -> [String]
words String
com)
  [Header]
hdrs'              <- [String] -> Result [Header]
parseHeaders [String]
hdrs
  RequestData -> Result RequestData
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestMethod
rqm,URI
uri,[String] -> [Header] -> [Header]
withVer [String]
version [Header]
hdrs')
 where
  withVer :: [String] -> [Header] -> [Header]
withVer [] [Header]
hs = [Header]
hs
  withVer (String
h:[String]
_) [Header]
hs = String -> [Header] -> [Header]
withVersion String
h [Header]
hs

  requestCommand :: String
-> [String] -> Either ConnError ([String], RequestMethod, URI)
requestCommand String
l _yes :: [String]
_yes@(String
rqm:String
uri:[String]
version) =
    case (String -> Maybe URI
parseURIReference String
uri, String -> [(String, RequestMethod)] -> Maybe RequestMethod
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
rqm [(String, RequestMethod)]
rqMethodMap) of
     (Just URI
u, Just RequestMethod
r) -> ([String], RequestMethod, URI)
-> Either ConnError ([String], RequestMethod, URI)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
version,RequestMethod
r,URI
u)
     (Just URI
u, Maybe RequestMethod
Nothing) -> ([String], RequestMethod, URI)
-> Either ConnError ([String], RequestMethod, URI)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
version,String -> RequestMethod
Custom String
rqm,URI
u)
     (Maybe URI, Maybe RequestMethod)
_                -> String -> Either ConnError ([String], RequestMethod, URI)
forall a. String -> Result a
parse_err String
l
  requestCommand String
l [String]
_
   | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l    = ConnError -> Either ConnError ([String], RequestMethod, URI)
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed
   | Bool
otherwise = String -> Either ConnError ([String], RequestMethod, URI)
forall a. String -> Result a
parse_err String
l

  parse_err :: String -> Result a
parse_err String
l = String -> String -> Result a
forall a. String -> String -> Result a
responseParseError String
"parseRequestHead"
                   (String
"Request command line parse failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l)

-- Parsing a response
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead []         = ConnError -> Result ResponseData
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed
parseResponseHead (String
sts:[String]
hdrs) = do
  (String
version,ResponseCode
code,String
reason)  <- String
-> [String] -> Either ConnError (String, ResponseCode, String)
responseStatus String
sts (String -> [String]
words String
sts)
  [Header]
hdrs'                  <- [String] -> Result [Header]
parseHeaders [String]
hdrs
  ResponseData -> Result ResponseData
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseCode
code,String
reason, String -> [Header] -> [Header]
withVersion String
version [Header]
hdrs')
 where
  responseStatus :: String
-> [String] -> Either ConnError (String, ResponseCode, String)
responseStatus String
_l _yes :: [String]
_yes@(String
version:String
code:[String]
reason) =
    (String, ResponseCode, String)
-> Either ConnError (String, ResponseCode, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
version,String -> ResponseCode
match String
code,ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" ") [String]
reason)
  responseStatus String
l [String]
_no 
    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l    = ConnError -> Either ConnError (String, ResponseCode, String)
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed  -- an assumption
    | Bool
otherwise = String -> Either ConnError (String, ResponseCode, String)
forall a. String -> Result a
parse_err String
l

  parse_err :: String -> Result a
parse_err String
l = 
    String -> String -> Result a
forall a. String -> String -> Result a
responseParseError 
        String
"parseResponseHead"
        (String
"Response status line parse failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l)

  match :: String -> ResponseCode
match [Char
a,Char
b,Char
c] = (Char -> Int
digitToInt Char
a,
                   Char -> Int
digitToInt Char
b,
                   Char -> Int
digitToInt Char
c)
  match String
_ = (-Int
1,-Int
1,-Int
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 :: String -> [Header] -> [Header]
withVersion String
v [Header]
hs 
 | String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
httpVersion = [Header]
hs  -- don't bother adding it if the default.
 | Bool
otherwise        = (HeaderName -> String -> Header
Header (String -> HeaderName
HdrCustom String
"X-HTTP-Version") String
v) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
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 :: Request a -> Maybe String
getRequestVersion Request a
r = Request a -> Maybe String
forall a. HasHeaders a => a -> Maybe String
getHttpVersion Request a
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 :: String -> Request a -> Request a
setRequestVersion String
s Request a
r = Request a -> String -> Request a
forall a. HasHeaders a => a -> String -> a
setHttpVersion Request a
r String
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 :: Response a -> Maybe String
getResponseVersion Response a
r = Response a -> Maybe String
forall a. HasHeaders a => a -> Maybe String
getHttpVersion Response a
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 :: String -> Response a -> Response a
setResponseVersion String
s Response a
r = Response a -> String -> Response a
forall a. HasHeaders a => a -> String -> a
setHttpVersion Response a
r String
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 :: a -> Maybe String
getHttpVersion a
r = 
  (Header -> String) -> Maybe Header -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Header -> String
toVersion      (Maybe Header -> Maybe String) -> Maybe Header -> Maybe String
forall a b. (a -> b) -> a -> b
$
   (Header -> Bool) -> [Header] -> Maybe Header
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Header -> Bool
isHttpVersion ([Header] -> Maybe Header) -> [Header] -> Maybe Header
forall a b. (a -> b) -> a -> b
$
    a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
r
 where
  toVersion :: Header -> String
toVersion (Header HeaderName
_ String
x) = String
x

setHttpVersion :: HasHeaders a => a -> String -> a
setHttpVersion :: a -> String -> a
setHttpVersion a
r String
v = 
  a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
r ([Header] -> a) -> [Header] -> a
forall a b. (a -> b) -> a -> b
$
   String -> [Header] -> [Header]
withVersion String
v  ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
    [Header] -> [Header]
dropHttpVersion ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
     a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
r

dropHttpVersion :: [Header] -> [Header]
dropHttpVersion :: [Header] -> [Header]
dropHttpVersion [Header]
hs = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (Header -> Bool) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Header -> Bool
isHttpVersion) [Header]
hs

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



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

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

matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse RequestMethod
rqst ResponseCode
rsp =
    case ResponseCode
rsp of
        (Int
1,Int
0,Int
0) -> ResponseNextStep
Continue
        (Int
1,Int
0,Int
1) -> ResponseNextStep
Done        -- upgrade to TLS
        (Int
1,Int
_,Int
_) -> ResponseNextStep
Continue    -- default
        (Int
2,Int
0,Int
4) -> ResponseNextStep
Done
        (Int
2,Int
0,Int
5) -> ResponseNextStep
Done
        (Int
2,Int
_,Int
_) -> ResponseNextStep
ans
        (Int
3,Int
0,Int
4) -> ResponseNextStep
Done
        (Int
3,Int
0,Int
5) -> ResponseNextStep
Done
        (Int
3,Int
_,Int
_) -> ResponseNextStep
ans
        (Int
4,Int
1,Int
7) -> ResponseNextStep
Retry       -- Expectation failed
        (Int
4,Int
_,Int
_) -> ResponseNextStep
ans
        (Int
5,Int
_,Int
_) -> ResponseNextStep
ans
        (Int
a,Int
b,Int
c) -> String -> ResponseNextStep
DieHorribly (String
"Response code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
a,Int
b,Int
c] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not recognised")
    where
        ans :: ResponseNextStep
ans | RequestMethod
rqst RequestMethod -> RequestMethod -> Bool
forall a. Eq a => a -> a -> Bool
== RequestMethod
HEAD = ResponseNextStep
Done
            | Bool
otherwise    = ResponseNextStep
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 :: Char
replacement_character = Char
'\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 :: Char -> [Word8]
encodeChar = (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [Word8]) -> (Char -> [Int]) -> Char -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall a. (Ord a, Num a, Bits a) => a -> [a]
go (Int -> [Int]) -> (Char -> Int) -> Char -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
 where
  go :: a -> [a]
go a
oc
   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x7f       = [a
oc]

   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x7ff      = [ a
0xc0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
                        ]

   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0xffff     = [ a
0xe0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
12)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
                        ]
   | Bool
otherwise        = [ a
0xf0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
18)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
12) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
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 :: [Word8] -> String
decode [    ] = String
""
decode (Word8
c:[Word8]
cs)
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80  = Int -> Char
chr (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
c) Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
cs
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xc0  = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
cs
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xe0  = String
multi1
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xf0  = Int -> Word8 -> Int -> String
multi_byte Int
2 Word8
0xf  Int
0x800
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xf8  = Int -> Word8 -> Int -> String
multi_byte Int
3 Word8
0x7  Int
0x10000
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xfc  = Int -> Word8 -> Int -> String
multi_byte Int
4 Word8
0x3  Int
0x200000
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xfe  = Int -> Word8 -> Int -> String
multi_byte Int
5 Word8
0x1  Int
0x4000000
  | Bool
otherwise = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
cs
  where
    multi1 :: String
multi1 = case [Word8]
cs of
      Word8
c1 : [Word8]
ds | Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xc0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 ->
        let d :: Int
d = ((Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x1f) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.  Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f)
        in if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0x000080 then Int -> Char
forall a. Enum a => Int -> a
toEnum Int
d Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
ds
                            else Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
ds
      [Word8]
_ -> Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
cs

    multi_byte :: Int -> Word8 -> Int -> [Char]
    multi_byte :: Int -> Word8 -> Int -> String
multi_byte Int
i Word8
mask Int
overlong = Int -> [Word8] -> Int -> String
forall t. (Eq t, Num t) => t -> [Word8] -> Int -> String
aux Int
i [Word8]
cs (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask))
      where
        aux :: t -> [Word8] -> Int -> String
aux t
0 [Word8]
rs Int
acc
          | Int
overlong Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
acc Bool -> Bool -> Bool
&& Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10ffff Bool -> Bool -> Bool
&&
            (Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xd800 Bool -> Bool -> Bool
|| Int
0xdfff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc)     Bool -> Bool -> Bool
&&
            (Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xfffe Bool -> Bool -> Bool
|| Int
0xffff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc)      = Int -> Char
chr Int
acc Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
rs
          | Bool
otherwise = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
rs

        aux t
n (Word8
r:[Word8]
rs) Int
acc
          | Word8
r Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xc0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 = t -> [Word8] -> Int -> String
aux (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [Word8]
rs
                               (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
acc Int
6 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
r Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f)

        aux t
_ [Word8]
rs     Int
_ = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
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 :: ShowS
urlDecode = [Word8] -> ShowS
go []
  where
    go :: [Word8] -> ShowS
go [Word8]
bs (Char
'%':Char
a:Char
b:String
rest)           = [Word8] -> ShowS
go (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Char -> Int
digitToInt Char
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
b) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
bs) String
rest
    go [Word8]
bs (Char
h:String
t) | Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 = [Word8] -> ShowS
go (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
h) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
bs) String
t -- Treat ASCII as just another byte of UTF-8
    go [] []                       = []
    go [] (Char
h:String
t)                    = Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> ShowS
go [] String
t -- h >= 256, so can't be part of any UTF-8 byte sequence
    go [Word8]
bs String
rest                     = [Word8] -> String
decode ([Word8] -> [Word8]
forall a. [a] -> [a]
reverse [Word8]
bs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Word8] -> ShowS
go [] String
rest


urlEncode :: String -> String
urlEncode :: ShowS
urlEncode     [] = []
urlEncode (Char
ch:String
t) 
  | (Char -> Bool
isAscii Char
ch Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
ch) Bool -> Bool -> Bool
|| Char
ch Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"-_.~" = Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
urlEncode String
t
  | Bool -> Bool
not (Char -> Bool
isAscii Char
ch) = (Word8 -> ShowS) -> String -> [Word8] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> ShowS
escape (ShowS
urlEncode String
t) (Char -> [Word8]
encodeChar Char
ch)
  | Bool
otherwise = Word8 -> ShowS
escape (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
ch)) (ShowS
urlEncode String
t)
    where
     escape :: Word8 -> ShowS
escape Word8
b String
rs = Char
'%'Char -> ShowS
forall a. a -> [a] -> [a]
:Word8 -> ShowS
showH (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
16) (Word8 -> ShowS
showH (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`mod` Word8
16) String
rs)

     showH :: Word8 -> String -> String
     showH :: Word8 -> ShowS
showH Word8
x String
xs
       | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
9    = Word8 -> Char
to (Word8
o_0 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
x) Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
       | Bool
otherwise = Word8 -> Char
to (Word8
o_A Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ (Word8
xWord8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
-Word8
10)) Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
      where
       to :: Word8 -> Char
to  = Int -> Char
forall a. Enum a => Int -> a
toEnum  (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
       fro :: Char -> Word8
fro = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum

       o_0 :: Word8
o_0 = Char -> Word8
fro Char
'0'
       o_A :: Word8
o_A = Char -> Word8
fro Char
'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 :: [(String, String)] -> String
urlEncodeVars ((String
n,String
v):[(String, String)]
t) =
    let ([(String, String)]
same,[(String, String)]
diff) = ((String, String) -> Bool)
-> [(String, String)] -> ([(String, String)], [(String, String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
n) (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
t
    in ShowS
urlEncode String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'=' Char -> ShowS
forall a. a -> [a] -> [a]
: (String -> ShowS) -> String -> [String] -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String
x String
y -> String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
',' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
urlEncode String
y) (ShowS
urlEncode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
v) (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> b
snd [(String, String)]
same)
       String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
urlEncodeRest [(String, String)]
diff
       where urlEncodeRest :: [(String, String)] -> String
urlEncodeRest [] = []
             urlEncodeRest [(String, String)]
diff = Char
'&' Char -> ShowS
forall a. a -> [a] -> [a]
: [(String, String)] -> String
urlEncodeVars [(String, String)]
diff
urlEncodeVars [] = []

-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@
-- header.
#if MIN_VERSION_base(4,13,0)
getAuth :: MonadFail m => Request ty -> m URIAuthority
#else
getAuth :: Monad m => Request ty -> m URIAuthority
#endif
getAuth :: Request ty -> m URIAuthority
getAuth Request ty
r = 
   -- ToDo: verify that Network.URI functionality doesn't take care of this (now.)
  case String -> Maybe URIAuthority
parseURIAuthority String
auth of
    Just URIAuthority
x -> URIAuthority -> m URIAuthority
forall (m :: * -> *) a. Monad m => a -> m a
return URIAuthority
x 
    Maybe URIAuthority
Nothing -> String -> m URIAuthority
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m URIAuthority) -> String -> m URIAuthority
forall a b. (a -> b) -> a -> b
$ String
"Network.HTTP.Base.getAuth: Error parsing URI authority '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
auth String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
 where 
  auth :: String
auth = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (URI -> String
uriToAuthorityString URI
uri) ShowS
forall a. a -> a
id (HeaderName -> Request ty -> Maybe String
forall a. HasHeaders a => HeaderName -> a -> Maybe String
findHeader HeaderName
HdrHost Request ty
r)
  uri :: URI
uri  = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r

{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty
normalizeRequestURI :: Bool -> String -> Request ty -> Request ty
normalizeRequestURI Bool
doClose String
h Request ty
r = 
  (if Bool
doClose then HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrConnection String
"close" else Request ty -> Request ty
forall a. a -> a
id) (Request ty -> Request ty) -> Request ty -> Request ty
forall a b. (a -> b) -> a -> b
$
  HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost String
h (Request ty -> Request ty) -> Request ty -> Request ty
forall a b. (a -> b) -> a -> b
$
    Request ty
r { rqURI :: URI
rqURI = (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r){ uriScheme :: String
uriScheme = String
""
                         , uriAuthority :: Maybe URIAuth
uriAuthority = Maybe URIAuth
forall a. Maybe a
Nothing
                         }}

-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options
-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option
data NormalizeRequestOptions ty
 = NormalizeRequestOptions
     { NormalizeRequestOptions ty -> Bool
normDoClose   :: Bool
     , NormalizeRequestOptions ty -> Bool
normForProxy  :: Bool
     , NormalizeRequestOptions ty -> Maybe String
normUserAgent :: Maybe String
     , NormalizeRequestOptions ty -> [RequestNormalizer ty]
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 ty
defaultNormalizeRequestOptions = NormalizeRequestOptions :: forall ty.
Bool
-> Bool
-> Maybe String
-> [RequestNormalizer ty]
-> NormalizeRequestOptions ty
NormalizeRequestOptions
     { normDoClose :: Bool
normDoClose   = Bool
False
     , normForProxy :: Bool
normForProxy  = Bool
False
     , normUserAgent :: Maybe String
normUserAgent = String -> Maybe String
forall a. a -> Maybe a
Just String
defaultUserAgent
     , normCustoms :: [RequestNormalizer ty]
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 :: NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeRequest NormalizeRequestOptions ty
opts Request ty
req = ((NormalizeRequestOptions ty -> Request ty -> Request ty)
 -> Request ty -> Request ty)
-> Request ty
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> Request ty
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ NormalizeRequestOptions ty -> Request ty -> Request ty
f -> NormalizeRequestOptions ty -> Request ty -> Request ty
f NormalizeRequestOptions ty
opts) Request ty
req [NormalizeRequestOptions ty -> Request ty -> Request ty]
normalizers
 where
  --normalizers :: [RequestNormalizer ty]
  normalizers :: [NormalizeRequestOptions ty -> Request ty -> Request ty]
normalizers = 
     ( NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. RequestNormalizer ty
normalizeHostURI
     (NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. RequestNormalizer ty
normalizeBasicAuth
     (NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. RequestNormalizer ty
normalizeConnectionClose
     (NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. RequestNormalizer ty
normalizeUserAgent 
     (NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall ty. NormalizeRequestOptions ty -> [RequestNormalizer ty]
normCustoms NormalizeRequestOptions ty
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 :: RequestNormalizer ty
normalizeUserAgent NormalizeRequestOptions ty
opts Request ty
req = 
  case NormalizeRequestOptions ty -> Maybe String
forall ty. NormalizeRequestOptions ty -> Maybe String
normUserAgent NormalizeRequestOptions ty
opts of
    Maybe String
Nothing -> Request ty
req
    Just String
ua -> 
     case HeaderName -> Request ty -> Maybe String
forall a. HasHeaders a => HeaderName -> a -> Maybe String
findHeader HeaderName
HdrUserAgent Request ty
req of
       Just String
u  | String
u String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
defaultUserAgent -> Request ty
req
       Maybe String
_ -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrUserAgent String
ua Request ty
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 :: RequestNormalizer ty
normalizeConnectionClose NormalizeRequestOptions ty
opts Request ty
req 
 | NormalizeRequestOptions ty -> Bool
forall ty. NormalizeRequestOptions ty -> Bool
normDoClose NormalizeRequestOptions ty
opts = HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrConnection String
"close" Request ty
req
 | Bool
otherwise        = Request ty
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 :: RequestNormalizer ty
normalizeBasicAuth NormalizeRequestOptions ty
_ Request ty
req =
  case Request ty -> Maybe URIAuthority
forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request ty
req of
    Just URIAuthority
uriauth ->
      case (URIAuthority -> Maybe String
user URIAuthority
uriauth, URIAuthority -> Maybe String
password URIAuthority
uriauth) of
        (Just String
u, Just String
p) ->
          HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrAuthorization String
astr Request ty
req
            where
              astr :: String
astr = String
"Basic " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
base64encode (String
u String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p)
              base64encode :: ShowS
base64encode = [Word8] -> String
Base64.encode ([Word8] -> String) -> (String -> [Word8]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
stringToOctets :: String -> String
              stringToOctets :: String -> [Word8]
stringToOctets = (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) :: String -> [Word8]
        (Maybe String
_, Maybe String
_) -> Request ty
req
    Maybe URIAuthority
Nothing ->Request ty
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 :: RequestNormalizer ty
normalizeHostURI NormalizeRequestOptions ty
opts Request ty
req = 
  case URI -> (String, URI)
splitRequestURI URI
uri of
    (String
"",URI
_uri_abs)
      | Bool
forProxy -> 
         case HeaderName -> Request ty -> Maybe String
forall a. HasHeaders a => HeaderName -> a -> Maybe String
findHeader HeaderName
HdrHost Request ty
req of
           Maybe String
Nothing -> Request ty
req -- no host/authority in sight..not much we can do.
           Just String
h  -> Request ty
req{rqURI :: URI
rqURI=URI
uri{ uriAuthority :: Maybe URIAuth
uriAuthority=URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just URIAuth :: String -> String -> String -> URIAuth
URIAuth{uriUserInfo :: String
uriUserInfo=String
"", uriRegName :: String
uriRegName=String
hst, uriPort :: String
uriPort=String
pNum}
                                   , uriScheme :: String
uriScheme=if (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriScheme URI
uri)) then String
"http" else URI -> String
uriScheme URI
uri
                                   }}
            where 
              hst :: String
hst = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'@') String
user_hst of
                       (String
as,Char
'@':String
bs) ->
                          case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') String
as of
                            (String
_,Char
_:String
_) -> String
bs
                            (String, String)
_ -> String
user_hst
                       (String, String)
_ -> String
user_hst

              (String
user_hst, String
pNum) =
                 case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit (ShowS
forall a. [a] -> [a]
reverse String
h) of
                   (String
ds,Char
':':String
bs) -> (ShowS
forall a. [a] -> [a]
reverse String
bs, Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
forall a. [a] -> [a]
reverse String
ds)
                   (String, String)
_ -> (String
h,String
"")
      | Bool
otherwise -> 
         case HeaderName -> Request ty -> Maybe String
forall a. HasHeaders a => HeaderName -> a -> Maybe String
findHeader HeaderName
HdrHost Request ty
req of
           Maybe String
Nothing -> Request ty
req -- no host/authority in sight..not much we can do...complain?
           Just{}  -> Request ty
req
    (String
h,URI
uri_abs) 
      | Bool
forProxy  -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost String
h Request ty
req 
      | Bool
otherwise -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrHost String
h Request ty
req{rqURI :: URI
rqURI=URI
uri_abs} -- Note: _not_ stubbing out user:pass
 where
   uri0 :: URI
uri0     = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
req 
     -- stub out the user:pass 
   uri :: URI
uri      = URI
uri0{uriAuthority :: Maybe URIAuth
uriAuthority=(URIAuth -> URIAuth) -> Maybe URIAuth -> Maybe URIAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ URIAuth
x -> URIAuth
x{uriUserInfo :: String
uriUserInfo=String
""}) (URI -> Maybe URIAuth
uriAuthority URI
uri0)}

   forProxy :: Bool
forProxy = NormalizeRequestOptions ty -> Bool
forall ty. NormalizeRequestOptions ty -> Bool
normForProxy NormalizeRequestOptions ty
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 -> (String, URI)
splitRequestURI URI
uri = (URI -> String
uriToAuthorityString URI
uri, URI
uri{uriScheme :: String
uriScheme=String
"", uriAuthority :: Maybe URIAuth
uriAuthority=Maybe URIAuth
forall a. Maybe a
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 :: Request ty -> Request ty
normalizeHostHeader Request ty
rq = 
  HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost
                        (URI -> String
uriToAuthorityString (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rq)
                        Request ty
rq
                                     
-- Looks for a "Connection" header with the value "close".
-- Returns True when this is found.
findConnClose :: [Header] -> Bool
findConnClose :: [Header] -> Bool
findConnClose [Header]
hdrs =
  Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
        (\ String
x -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim String
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"close")
        (HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrConnection [Header]
hdrs)

-- | Used when we know exactly how many bytes to expect.
linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))
linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer Int -> IO (Result a)
readBlk Int
n = (a -> Result ([Header], a))
-> IO (Result a) -> IO (Result ([Header], a))
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\a
str -> ([Header], a) -> Result ([Header], a)
forall a b. b -> Either a b
Right ([],a
str)) (Int -> IO (Result a)
readBlk Int
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 :: BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp a
bufOps IO (Result a)
readL [a]
strs 
    = IO (Result a)
readL IO (Result a)
-> (Result a -> IO (Result ([Header], a)))
-> IO (Result ([Header], a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 
      (ConnError -> IO (Result ([Header], a)))
-> (a -> IO (Result ([Header], a)))
-> Result a
-> IO (Result ([Header], a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ConnError
v -> Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result ([Header], a) -> IO (Result ([Header], a)))
-> Result ([Header], a) -> IO (Result ([Header], a))
forall a b. (a -> b) -> a -> b
$ ConnError -> Result ([Header], a)
forall a b. a -> Either a b
Left ConnError
v)
             (\a
more -> if (BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
more)
                         then Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (([Header], a) -> Result ([Header], a)
forall a b. b -> Either a b
Right ([], BufferOp a -> [a] -> a
forall a. BufferOp a -> [a] -> a
buf_concat BufferOp a
bufOps ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
strs))
                         else BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
forall a.
BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp a
bufOps IO (Result a)
readL (a
morea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
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 :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk = BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk [] Int
0

chunkedTransferC :: BufferOp a
                 -> IO (Result a)
                 -> (Int -> IO (Result a))
                 -> [a]
                 -> Int
                 -> IO (Result ([Header], a))
chunkedTransferC :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk [a]
acc Int
n = do
  Result a
v <- IO (Result a)
readL
  case Result a
v of
    Left ConnError
e -> Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result ([Header], a)
forall a b. a -> Either a b
Left ConnError
e)
    Right a
line 
     | Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> 
         -- last chunk read; look for trailing headers..
        ([a] -> Result ([Header], a))
-> IO (Result [a]) -> IO (Result ([Header], a))
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\ [a]
strs -> do
                 [Header]
ftrs <- [String] -> Result [Header]
parseHeaders ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (BufferOp a -> a -> String
forall a. BufferOp a -> a -> String
buf_toStr BufferOp a
bufOps) [a]
strs)
                  -- insert (computed) Content-Length header.
                 let ftrs' :: [Header]
ftrs' = HeaderName -> String -> Header
Header HeaderName
HdrContentLength (Int -> String
forall a. Show a => a -> String
show Int
n) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
ftrs
                 ([Header], a) -> Result ([Header], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Header]
ftrs',BufferOp a -> [a] -> a
forall a. BufferOp a -> [a] -> a
buf_concat BufferOp a
bufOps ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc)))

              (BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL [])

     | Bool
otherwise -> do
         Result a
some <- Int -> IO (Result a)
readBlk Int
size
         case Result a
some of
           Left ConnError
e -> Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result ([Header], a)
forall a b. a -> Either a b
Left ConnError
e)
           Right a
cdata -> do
               Result a
_ <- IO (Result a)
readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?
               BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk (a
cdataa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
size)
     where
      size :: Int
size 
       | BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
line = Int
0
       | Bool
otherwise = 
         case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex (BufferOp a -> a -> String
forall a. BufferOp a -> a -> String
buf_toStr BufferOp a
bufOps a
line) of
          (Int
hx,String
_):[(Int, String)]
_ -> Int
hx
          [(Int, String)]
_        -> Int
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 :: String -> IO (Result ([Header], a))
uglyDeathTransfer String
loc = Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Result ([Header], a)
forall a. String -> String -> Result a
responseParseError String
loc String
"Unknown Transfer-Encoding")

-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)
readTillEmpty1 :: BufferOp a
               -> IO (Result a)
               -> IO (Result [a])
readTillEmpty1 :: BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp a
bufOps IO (Result a)
readL =
  IO (Result a)
readL IO (Result a) -> (Result a -> IO (Result [a])) -> IO (Result [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (ConnError -> IO (Result [a]))
-> (a -> IO (Result [a])) -> Result a -> IO (Result [a])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result [a] -> IO (Result [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [a] -> IO (Result [a]))
-> (ConnError -> Result [a]) -> ConnError -> IO (Result [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnError -> Result [a]
forall a b. a -> Either a b
Left)
           (\ a
s -> 
               if BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isLineTerm BufferOp a
bufOps a
s
                then BufferOp a -> IO (Result a) -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp a
bufOps IO (Result a)
readL
                else BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL [a
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 :: BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL [a]
list =
    IO (Result a)
readL IO (Result a) -> (Result a -> IO (Result [a])) -> IO (Result [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      (ConnError -> IO (Result [a]))
-> (a -> IO (Result [a])) -> Result a -> IO (Result [a])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result [a] -> IO (Result [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [a] -> IO (Result [a]))
-> (ConnError -> Result [a]) -> ConnError -> IO (Result [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnError -> Result [a]
forall a b. a -> Either a b
Left)
             (\ a
s ->
                if BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isLineTerm BufferOp a
bufOps a
s Bool -> Bool -> Bool
|| BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
s
                 then Result [a] -> IO (Result [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Result [a]
forall a b. b -> Either a b
Right ([a] -> Result [a]) -> [a] -> Result [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse (a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
list))
                 else BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL (a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
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 :: IO a -> (IOException -> IO a) -> IO a
catchIO IO a
a IOException -> IO a
h = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch IO a
a IOException -> IO a
h

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

responseParseError :: String -> String -> Result a
responseParseError :: String -> String -> Result a
responseParseError String
loc String
v = ConnError -> Result a
forall a. ConnError -> Result a
failWith (String -> ConnError
ErrorParse (String
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:String
v))