--
-- HTTP types for use with io-streams and pipes
--
-- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd
--
-- The code in this file, and the program it is a part of, is
-- made available to you by its authors as open source software:
-- you can redistribute it and/or modify it under the terms of
-- the BSD licence.
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide, prune #-}

--

{- | If you're not http-streams or pipes-http and you're importing this,
 you're Doing It Wrong.
-}
module Network.Http.Internal (
    Hostname,
    Port,
    ContentType,
    FieldName,
    Request (..),
    EntityBody (..),
    ExpectMode (..),
    Boundary,
    unBoundary,
    emptyBoundary,
    randomBoundary,
    packBoundary,
    Response (..),
    StatusCode,
    TransferEncoding (..),
    ContentEncoding (..),
    getStatusCode,
    getStatusMessage,
    getHeader,
    Method (..),
    Headers,
    emptyHeaders,
    updateHeader,
    removeHeader,
    buildHeaders,
    lookupHeader,
    retrieveHeaders,
    HttpType (getHeaders),
    HttpParseException (..),
    composeMultipartBytes,
    composeMultipartEnding,
    -- for testing
    composeRequestBytes,
    composeResponseBytes,
) where

import Prelude hiding (lookup)

import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder (
    copyByteString,
    fromByteString,
    toByteString,
 )
import qualified Blaze.ByteString.Builder.Char8 as Builder (
    fromChar,
    fromShow,
    fromString,
 )
import Control.Exception (Exception)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
import Data.CaseInsensitive (CI, mk, original)
import Data.Char (chr)
import Data.HashMap.Strict (
    HashMap,
    delete,
    empty,
    foldrWithKey,
    insert,
    insertWith,
    lookup,
    toList,
 )
import Data.Int (Int64)
import Data.List (foldl')
import Data.Typeable (Typeable)
import Data.Word (Word16)
import System.Random (newStdGen, randomRs)

type Hostname = ByteString

type Port = Word16

type ContentType = ByteString

type FieldName = ByteString

-- | HTTP Methods, as per RFC 2616
data Method
    = GET
    | HEAD
    | POST
    | PUT
    | DELETE
    | TRACE
    | OPTIONS
    | CONNECT
    | PATCH
    | Method ByteString
    deriving (Int -> Method -> ShowS
[Method] -> ShowS
Method -> String
(Int -> Method -> ShowS)
-> (Method -> String) -> ([Method] -> ShowS) -> Show Method
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> String
$cshow :: Method -> String
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show, ReadPrec [Method]
ReadPrec Method
Int -> ReadS Method
ReadS [Method]
(Int -> ReadS Method)
-> ReadS [Method]
-> ReadPrec Method
-> ReadPrec [Method]
-> Read Method
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Method]
$creadListPrec :: ReadPrec [Method]
readPrec :: ReadPrec Method
$creadPrec :: ReadPrec Method
readList :: ReadS [Method]
$creadList :: ReadS [Method]
readsPrec :: Int -> ReadS Method
$creadsPrec :: Int -> ReadS Method
Read, Eq Method
Eq Method
-> (Method -> Method -> Ordering)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Method)
-> (Method -> Method -> Method)
-> Ord Method
Method -> Method -> Bool
Method -> Method -> Ordering
Method -> Method -> Method
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Method -> Method -> Method
$cmin :: Method -> Method -> Method
max :: Method -> Method -> Method
$cmax :: Method -> Method -> Method
>= :: Method -> Method -> Bool
$c>= :: Method -> Method -> Bool
> :: Method -> Method -> Bool
$c> :: Method -> Method -> Bool
<= :: Method -> Method -> Bool
$c<= :: Method -> Method -> Bool
< :: Method -> Method -> Bool
$c< :: Method -> Method -> Bool
compare :: Method -> Method -> Ordering
$ccompare :: Method -> Method -> Ordering
$cp1Ord :: Eq Method
Ord)

instance Eq Method where
    Method
GET == :: Method -> Method -> Bool
== Method
GET = Bool
True
    Method
HEAD == Method
HEAD = Bool
True
    Method
POST == Method
POST = Bool
True
    Method
PUT == Method
PUT = Bool
True
    Method
DELETE == Method
DELETE = Bool
True
    Method
TRACE == Method
TRACE = Bool
True
    Method
OPTIONS == Method
OPTIONS = Bool
True
    Method
CONNECT == Method
CONNECT = Bool
True
    Method
PATCH == Method
PATCH = Bool
True
    Method
GET == Method ByteString
"GET" = Bool
True
    Method
HEAD == Method ByteString
"HEAD" = Bool
True
    Method
POST == Method ByteString
"POST" = Bool
True
    Method
PUT == Method ByteString
"PUT" = Bool
True
    Method
DELETE == Method ByteString
"DELETE" = Bool
True
    Method
TRACE == Method ByteString
"TRACE" = Bool
True
    Method
OPTIONS == Method ByteString
"OPTIONS" = Bool
True
    Method
CONNECT == Method ByteString
"CONNECT" = Bool
True
    Method
PATCH == Method ByteString
"PATCH" = Bool
True
    Method ByteString
a == Method ByteString
b = ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
b
    m :: Method
m@(Method ByteString
_) == Method
other = Method
other Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
m
    Method
_ == Method
_ = Bool
False

--

{- |
A description of the request that will be sent to the server. Note
unlike other HTTP libraries, the request body is /not/ a part of this
object; that will be streamed out by you when actually sending the
request with 'sendRequest'.

'Request' has a useful @Show@ instance that will output the request
line and headers (as it will be sent over the wire but with the @\\r@
characters stripped) which can be handy for debugging.

Note that the actual @Host:@ header is not set until the request is sent,
so you will not see it in the Show instance (unless you call 'setHostname'
 to override the value inherited from the @Connection@).
-}
data Request = Request
    { Request -> Method
qMethod :: !Method
    , Request -> Maybe ByteString
qHost :: !(Maybe ByteString)
    , Request -> ByteString
qPath :: !ByteString
    , Request -> EntityBody
qBody :: !EntityBody
    , Request -> ExpectMode
qExpect :: !ExpectMode
    , Request -> Headers
qHeaders :: !Headers
    , Request -> Boundary
qBoundary :: !Boundary
    }
    deriving (Request -> Request -> Bool
(Request -> Request -> Bool)
-> (Request -> Request -> Bool) -> Eq Request
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c== :: Request -> Request -> Bool
Eq)

instance Show Request where
    show :: Request -> String
show Request
q =
        {-# SCC "Request.show" #-}
        ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ByteString -> Builder
composeRequestBytes Request
q ByteString
"<to be determined>"

data EntityBody = Empty | Chunking | Static Int64 deriving (Int -> EntityBody -> ShowS
[EntityBody] -> ShowS
EntityBody -> String
(Int -> EntityBody -> ShowS)
-> (EntityBody -> String)
-> ([EntityBody] -> ShowS)
-> Show EntityBody
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EntityBody] -> ShowS
$cshowList :: [EntityBody] -> ShowS
show :: EntityBody -> String
$cshow :: EntityBody -> String
showsPrec :: Int -> EntityBody -> ShowS
$cshowsPrec :: Int -> EntityBody -> ShowS
Show, EntityBody -> EntityBody -> Bool
(EntityBody -> EntityBody -> Bool)
-> (EntityBody -> EntityBody -> Bool) -> Eq EntityBody
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EntityBody -> EntityBody -> Bool
$c/= :: EntityBody -> EntityBody -> Bool
== :: EntityBody -> EntityBody -> Bool
$c== :: EntityBody -> EntityBody -> Bool
Eq, Eq EntityBody
Eq EntityBody
-> (EntityBody -> EntityBody -> Ordering)
-> (EntityBody -> EntityBody -> Bool)
-> (EntityBody -> EntityBody -> Bool)
-> (EntityBody -> EntityBody -> Bool)
-> (EntityBody -> EntityBody -> Bool)
-> (EntityBody -> EntityBody -> EntityBody)
-> (EntityBody -> EntityBody -> EntityBody)
-> Ord EntityBody
EntityBody -> EntityBody -> Bool
EntityBody -> EntityBody -> Ordering
EntityBody -> EntityBody -> EntityBody
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EntityBody -> EntityBody -> EntityBody
$cmin :: EntityBody -> EntityBody -> EntityBody
max :: EntityBody -> EntityBody -> EntityBody
$cmax :: EntityBody -> EntityBody -> EntityBody
>= :: EntityBody -> EntityBody -> Bool
$c>= :: EntityBody -> EntityBody -> Bool
> :: EntityBody -> EntityBody -> Bool
$c> :: EntityBody -> EntityBody -> Bool
<= :: EntityBody -> EntityBody -> Bool
$c<= :: EntityBody -> EntityBody -> Bool
< :: EntityBody -> EntityBody -> Bool
$c< :: EntityBody -> EntityBody -> Bool
compare :: EntityBody -> EntityBody -> Ordering
$ccompare :: EntityBody -> EntityBody -> Ordering
$cp1Ord :: Eq EntityBody
Ord)

data ExpectMode = Normal | Continue deriving (Int -> ExpectMode -> ShowS
[ExpectMode] -> ShowS
ExpectMode -> String
(Int -> ExpectMode -> ShowS)
-> (ExpectMode -> String)
-> ([ExpectMode] -> ShowS)
-> Show ExpectMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExpectMode] -> ShowS
$cshowList :: [ExpectMode] -> ShowS
show :: ExpectMode -> String
$cshow :: ExpectMode -> String
showsPrec :: Int -> ExpectMode -> ShowS
$cshowsPrec :: Int -> ExpectMode -> ShowS
Show, ExpectMode -> ExpectMode -> Bool
(ExpectMode -> ExpectMode -> Bool)
-> (ExpectMode -> ExpectMode -> Bool) -> Eq ExpectMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExpectMode -> ExpectMode -> Bool
$c/= :: ExpectMode -> ExpectMode -> Bool
== :: ExpectMode -> ExpectMode -> Bool
$c== :: ExpectMode -> ExpectMode -> Bool
Eq, Eq ExpectMode
Eq ExpectMode
-> (ExpectMode -> ExpectMode -> Ordering)
-> (ExpectMode -> ExpectMode -> Bool)
-> (ExpectMode -> ExpectMode -> Bool)
-> (ExpectMode -> ExpectMode -> Bool)
-> (ExpectMode -> ExpectMode -> Bool)
-> (ExpectMode -> ExpectMode -> ExpectMode)
-> (ExpectMode -> ExpectMode -> ExpectMode)
-> Ord ExpectMode
ExpectMode -> ExpectMode -> Bool
ExpectMode -> ExpectMode -> Ordering
ExpectMode -> ExpectMode -> ExpectMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ExpectMode -> ExpectMode -> ExpectMode
$cmin :: ExpectMode -> ExpectMode -> ExpectMode
max :: ExpectMode -> ExpectMode -> ExpectMode
$cmax :: ExpectMode -> ExpectMode -> ExpectMode
>= :: ExpectMode -> ExpectMode -> Bool
$c>= :: ExpectMode -> ExpectMode -> Bool
> :: ExpectMode -> ExpectMode -> Bool
$c> :: ExpectMode -> ExpectMode -> Bool
<= :: ExpectMode -> ExpectMode -> Bool
$c<= :: ExpectMode -> ExpectMode -> Bool
< :: ExpectMode -> ExpectMode -> Bool
$c< :: ExpectMode -> ExpectMode -> Bool
compare :: ExpectMode -> ExpectMode -> Ordering
$ccompare :: ExpectMode -> ExpectMode -> Ordering
$cp1Ord :: Eq ExpectMode
Ord)

newtype Boundary = Boundary ByteString deriving (Int -> Boundary -> ShowS
[Boundary] -> ShowS
Boundary -> String
(Int -> Boundary -> ShowS)
-> (Boundary -> String) -> ([Boundary] -> ShowS) -> Show Boundary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Boundary] -> ShowS
$cshowList :: [Boundary] -> ShowS
show :: Boundary -> String
$cshow :: Boundary -> String
showsPrec :: Int -> Boundary -> ShowS
$cshowsPrec :: Int -> Boundary -> ShowS
Show, Boundary -> Boundary -> Bool
(Boundary -> Boundary -> Bool)
-> (Boundary -> Boundary -> Bool) -> Eq Boundary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Boundary -> Boundary -> Bool
$c/= :: Boundary -> Boundary -> Bool
== :: Boundary -> Boundary -> Bool
$c== :: Boundary -> Boundary -> Bool
Eq)

unBoundary :: Boundary -> ByteString
unBoundary :: Boundary -> ByteString
unBoundary (Boundary ByteString
b') = ByteString
b'

emptyBoundary :: Boundary
emptyBoundary :: Boundary
emptyBoundary = ByteString -> Boundary
Boundary ByteString
S.empty

represent :: Int -> Char
represent :: Int -> Char
represent Int
x
    | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 = Int -> Char
chr (Int
48 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x)
    | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
36 = Int -> Char
chr (Int
65 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)
    | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
62 = Int -> Char
chr (Int
97 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
36)
    | Bool
otherwise = Char
'@'

{- |
Generate a random string to be used as an inter-part boundary in RFC 7578
multipart form data. You pass this value to
'Network.Http.Client.setContentMultipart' and subsequently to
'Network.Http.Client.multipartFormBody'.
-}
randomBoundary :: IO Boundary
randomBoundary :: IO Boundary
randomBoundary = do
    StdGen
gen <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
    let result :: ByteString
result = String -> ByteString
S.pack (String -> ByteString)
-> (StdGen -> String) -> StdGen -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Char) -> [Int] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
represent ([Int] -> String) -> (StdGen -> [Int]) -> StdGen -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
20 ([Int] -> [Int]) -> (StdGen -> [Int]) -> StdGen -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> StdGen -> [Int]
forall a g. (Random a, RandomGen g) => (a, a) -> g -> [a]
randomRs (Int
0, Int
61) (StdGen -> ByteString) -> StdGen -> ByteString
forall a b. (a -> b) -> a -> b
$ StdGen
gen
    Boundary -> IO Boundary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Boundary
Boundary ByteString
result)

{- |
If you want to fix the multipart boundary to a known value (for testing
purposes) you can use this. The ideal such string, in case you are wondering,
is @\"bEacHV0113YB\@ll\"@.

This isn't safe for use in production; you need to use an unpredictable value
as the boundary separtor so prefer 'randomBoundary'.
-}
packBoundary :: String -> Boundary
packBoundary :: String -> Boundary
packBoundary = ByteString -> Boundary
Boundary (ByteString -> Boundary)
-> (String -> ByteString) -> String -> Boundary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
S.pack

{-
    The bit that builds up the actual string to be transmitted. This
    is on the critical path for every request, so we'll want to revisit
    this to improve performance.

    - Rewrite rule for Method?
    - How can serializing the Headers be made efficient?

    This code includes the RFC compliant CR-LF sequences as line
    terminators, which is why the Show instance above has to bother
    with removing them.
-}

composeRequestBytes :: Request -> ByteString -> Builder
composeRequestBytes :: Request -> ByteString -> Builder
composeRequestBytes Request
q ByteString
h' =
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ Builder
requestline
        , Builder
hostLine
        , Builder
headerFields
        , Builder
crlf
        ]
  where
    requestline :: Builder
requestline =
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Builder
method
            , Builder
sp
            , Builder
uri
            , Builder
sp
            , Builder
version
            , Builder
crlf
            ]

    method :: Builder
method = case Request -> Method
qMethod Request
q of
        Method
GET -> String -> Builder
Builder.fromString String
"GET"
        Method
HEAD -> String -> Builder
Builder.fromString String
"HEAD"
        Method
POST -> String -> Builder
Builder.fromString String
"POST"
        Method
PUT -> String -> Builder
Builder.fromString String
"PUT"
        Method
DELETE -> String -> Builder
Builder.fromString String
"DELETE"
        Method
TRACE -> String -> Builder
Builder.fromString String
"TRACE"
        Method
OPTIONS -> String -> Builder
Builder.fromString String
"OPTIONS"
        Method
CONNECT -> String -> Builder
Builder.fromString String
"CONNECT"
        Method
PATCH -> String -> Builder
Builder.fromString String
"PATCH"
        (Method ByteString
x) -> ByteString -> Builder
Builder.fromByteString ByteString
x

    uri :: Builder
uri = case Request -> ByteString
qPath Request
q of
        ByteString
"" -> Char -> Builder
Builder.fromChar Char
'/'
        ByteString
path -> ByteString -> Builder
Builder.copyByteString ByteString
path

    version :: Builder
version = String -> Builder
Builder.fromString String
"HTTP/1.1"

    hostLine :: Builder
hostLine =
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ String -> Builder
Builder.fromString String
"Host: "
            , Builder
hostname
            , Builder
crlf
            ]

    hostname :: Builder
hostname = case Request -> Maybe ByteString
qHost Request
q of
        Just ByteString
x' -> ByteString -> Builder
Builder.copyByteString ByteString
x'
        Maybe ByteString
Nothing -> ByteString -> Builder
Builder.copyByteString ByteString
h'

    headerFields :: Builder
headerFields = HashMap (CI ByteString) ByteString -> Builder
joinHeaders (HashMap (CI ByteString) ByteString -> Builder)
-> HashMap (CI ByteString) ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Headers -> HashMap (CI ByteString) ByteString
unWrap (Headers -> HashMap (CI ByteString) ByteString)
-> Headers -> HashMap (CI ByteString) ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Headers
qHeaders Request
q

crlf :: Builder
crlf = String -> Builder
Builder.fromString String
"\r\n"

sp :: Builder
sp = Char -> Builder
Builder.fromChar Char
' '

dashdash :: Builder
dashdash = String -> Builder
Builder.fromString String
"--"

composeMultipartBytes :: Boundary -> FieldName -> Maybe FilePath -> Maybe ContentType -> Builder
composeMultipartBytes :: Boundary
-> ByteString -> Maybe String -> Maybe ByteString -> Builder
composeMultipartBytes Boundary
boundary ByteString
name Maybe String
possibleFilename Maybe ByteString
possibleContentType =
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ Builder
boundaryLine
        , Builder
dispositionLine
        , Builder
mimetypeLine
        , Builder
crlf -- second CR LF
        ]
  where
    boundaryLine :: Builder
boundaryLine =
        Builder
crlf
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
dashdash
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.copyByteString (Boundary -> ByteString
unBoundary Boundary
boundary)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
crlf
    dispositionLine :: Builder
dispositionLine =
        Builder
"Content-Disposition: form-data; name=\""
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.copyByteString ByteString
name
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\""
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> case Maybe String
possibleFilename of
                Just String
filename ->
                    Builder
"; filename=\""
                        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
Builder.fromString String
filename
                        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\""
                Maybe String
Nothing -> Builder
forall a. Monoid a => a
mempty
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
crlf
    mimetypeLine :: Builder
mimetypeLine =
        case Maybe ByteString
possibleContentType of
            Just ByteString
mimetype ->
                Builder
"Content-Type: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.copyByteString ByteString
mimetype
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
crlf
            Maybe ByteString
Nothing -> Builder
forall a. Monoid a => a
mempty

composeMultipartEnding :: Boundary -> Builder
composeMultipartEnding :: Boundary -> Builder
composeMultipartEnding Boundary
boundary =
    Builder
crlf
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
dashdash
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.copyByteString (Boundary -> ByteString
unBoundary Boundary
boundary)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
dashdash
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
crlf

type StatusCode = Int

{- |
A description of the response received from the server. Note
unlike other HTTP libraries, the response body is /not/ a part
of this object; that will be streamed in by you when calling
'receiveResponse'.

Like 'Request', 'Response' has a @Show@ instance that will output
the status line and response headers as they were received from the
server.
-}
data Response = Response
    { Response -> Int
pStatusCode :: !StatusCode
    , Response -> ByteString
pStatusMsg :: !ByteString
    , Response -> TransferEncoding
pTransferEncoding :: !TransferEncoding
    , Response -> ContentEncoding
pContentEncoding :: !ContentEncoding
    , Response -> Maybe Int64
pContentLength :: !(Maybe Int64)
    , Response -> Headers
pHeaders :: !Headers
    }

instance Show Response where
    show :: Response -> String
show Response
p =
        {-# SCC "Response.show" #-}
        ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Response -> Builder
composeResponseBytes Response
p

data TransferEncoding = None | Chunked

data ContentEncoding = Identity | Gzip | Deflate
    deriving (Int -> ContentEncoding -> ShowS
[ContentEncoding] -> ShowS
ContentEncoding -> String
(Int -> ContentEncoding -> ShowS)
-> (ContentEncoding -> String)
-> ([ContentEncoding] -> ShowS)
-> Show ContentEncoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentEncoding] -> ShowS
$cshowList :: [ContentEncoding] -> ShowS
show :: ContentEncoding -> String
$cshow :: ContentEncoding -> String
showsPrec :: Int -> ContentEncoding -> ShowS
$cshowsPrec :: Int -> ContentEncoding -> ShowS
Show)

-- | Get the HTTP response status code.
getStatusCode :: Response -> StatusCode
getStatusCode :: Response -> Int
getStatusCode = Response -> Int
pStatusCode
{-# INLINE getStatusCode #-}

{- |
Get the HTTP response status message. Keep in mind that this is
/not/ normative; whereas 'getStatusCode' values are authoritative.
-}
getStatusMessage :: Response -> ByteString
getStatusMessage :: Response -> ByteString
getStatusMessage = Response -> ByteString
pStatusMsg
{-# INLINE getStatusMessage #-}

{- |
Lookup a header in the response. HTTP header field names are
case-insensitive, so you can specify the name to lookup however you
like. If the header is not present @Nothing@ will be returned.

>     let n = case getHeader p "Content-Length" of
>                Just x' -> read x' :: Int
>                Nothing -> 0

which of course is essentially what goes on inside the client library when
it receives a response from the server and has to figure out how many bytes
to read.

There is a fair bit of complexity in some of the other HTTP response
fields, so there are a number of specialized functions for reading
those values where we've found them useful.
-}
getHeader :: Response -> ByteString -> Maybe ByteString
getHeader :: Response -> ByteString -> Maybe ByteString
getHeader Response
p ByteString
k =
    Headers -> ByteString -> Maybe ByteString
lookupHeader Headers
h ByteString
k
  where
    h :: Headers
h = Response -> Headers
pHeaders Response
p

{- |
Accessors common to both the outbound and return sides of an HTTP connection.

Most people do not need this; for most cases you just need to get a header or
two from the response, for which you can use 'getHeader'. On the other hand,
if you do need to poke around in the raw headers,

@
import Network.Http.Types
@

will give you functions like 'lookupHeader' and 'updateHeader' to to work
with.
-}
class HttpType τ where
    -- | Get the Headers from a Request or Response.y
    getHeaders :: τ -> Headers

instance HttpType Request where
    getHeaders :: Request -> Headers
getHeaders Request
q = Request -> Headers
qHeaders Request
q

instance HttpType Response where
    getHeaders :: Response -> Headers
getHeaders Response
p = Response -> Headers
pHeaders Response
p

composeResponseBytes :: Response -> Builder
composeResponseBytes :: Response -> Builder
composeResponseBytes Response
p =
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ Builder
statusline
        , Builder
headerFields
        , Builder
crlf
        ]
  where
    statusline :: Builder
statusline =
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Builder
version
            , Builder
sp
            , Builder
code
            , Builder
sp
            , Builder
message
            , Builder
crlf
            ]

    code :: Builder
code = Int -> Builder
forall a. Show a => a -> Builder
Builder.fromShow (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ Response -> Int
pStatusCode Response
p

    message :: Builder
message = ByteString -> Builder
Builder.copyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Response -> ByteString
pStatusMsg Response
p

    version :: Builder
version = String -> Builder
Builder.fromString String
"HTTP/1.1"

    headerFields :: Builder
headerFields = HashMap (CI ByteString) ByteString -> Builder
joinHeaders (HashMap (CI ByteString) ByteString -> Builder)
-> HashMap (CI ByteString) ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Headers -> HashMap (CI ByteString) ByteString
unWrap (Headers -> HashMap (CI ByteString) ByteString)
-> Headers -> HashMap (CI ByteString) ByteString
forall a b. (a -> b) -> a -> b
$ Response -> Headers
pHeaders Response
p

{- |
The map of headers in a 'Request' or 'Response'. Note that HTTP
header field names are case insensitive, so if you call 'setHeader'
on a field that's already defined but with a different capitalization
you will replace the existing value.
-}

{-
    This is a fair bit of trouble just to avoid using a typedef here.
    Probably worth it, though; every other HTTP client library out there
    exposes the gory details of the underlying map implementation, and
    to use it you need to figure out all kinds of crazy imports. Indeed,
    this code used here in the Show instance for debugging has been
    copied & pasted around various projects of mine since I started
    writing Haskell. It's quite tedious, and very arcane! So, wrap it
    up.
-}
newtype Headers = Wrap
    { Headers -> HashMap (CI ByteString) ByteString
unWrap :: HashMap (CI ByteString) ByteString
    }
    deriving (Headers -> Headers -> Bool
(Headers -> Headers -> Bool)
-> (Headers -> Headers -> Bool) -> Eq Headers
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Headers -> Headers -> Bool
$c/= :: Headers -> Headers -> Bool
== :: Headers -> Headers -> Bool
$c== :: Headers -> Headers -> Bool
Eq)

instance Show Headers where
    show :: Headers -> String
show Headers
x = ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ HashMap (CI ByteString) ByteString -> Builder
joinHeaders (HashMap (CI ByteString) ByteString -> Builder)
-> HashMap (CI ByteString) ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Headers -> HashMap (CI ByteString) ByteString
unWrap Headers
x

joinHeaders :: HashMap (CI ByteString) ByteString -> Builder
joinHeaders :: HashMap (CI ByteString) ByteString -> Builder
joinHeaders HashMap (CI ByteString) ByteString
m = (CI ByteString -> ByteString -> Builder -> Builder)
-> Builder -> HashMap (CI ByteString) ByteString -> Builder
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
foldrWithKey CI ByteString -> ByteString -> Builder -> Builder
combine Builder
forall a. Monoid a => a
mempty HashMap (CI ByteString) ByteString
m

combine :: CI ByteString -> ByteString -> Builder -> Builder
combine :: CI ByteString -> ByteString -> Builder -> Builder
combine CI ByteString
k ByteString
v Builder
acc =
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder
acc, Builder
key, String -> Builder
Builder.fromString String
": ", Builder
value, Builder
crlf]
  where
    key :: Builder
key = ByteString -> Builder
Builder.copyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
k
    value :: Builder
value = ByteString -> Builder
Builder.fromByteString ByteString
v
{-# INLINE combine #-}

emptyHeaders :: Headers
emptyHeaders :: Headers
emptyHeaders =
    HashMap (CI ByteString) ByteString -> Headers
Wrap HashMap (CI ByteString) ByteString
forall k v. HashMap k v
empty

{- |
Set a header field to the specified value. This will overwrite
any existing value for the field. Remember that HTTP fields names
are case insensitive!
-}
updateHeader :: Headers -> ByteString -> ByteString -> Headers
updateHeader :: Headers -> ByteString -> ByteString -> Headers
updateHeader Headers
x ByteString
k ByteString
v =
    HashMap (CI ByteString) ByteString -> Headers
Wrap HashMap (CI ByteString) ByteString
result
  where
    !result :: HashMap (CI ByteString) ByteString
result = CI ByteString
-> ByteString
-> HashMap (CI ByteString) ByteString
-> HashMap (CI ByteString) ByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
k) ByteString
v HashMap (CI ByteString) ByteString
m
    !m :: HashMap (CI ByteString) ByteString
m = Headers -> HashMap (CI ByteString) ByteString
unWrap Headers
x

{- |
Remove a header from the map. If a field with that name is not present,
then this will have no effect.
-}
removeHeader :: Headers -> ByteString -> Headers
removeHeader :: Headers -> ByteString -> Headers
removeHeader Headers
x ByteString
k =
    HashMap (CI ByteString) ByteString -> Headers
Wrap HashMap (CI ByteString) ByteString
result
  where
    !result :: HashMap (CI ByteString) ByteString
result = CI ByteString
-> HashMap (CI ByteString) ByteString
-> HashMap (CI ByteString) ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
delete (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
k) HashMap (CI ByteString) ByteString
m
    !m :: HashMap (CI ByteString) ByteString
m = Headers -> HashMap (CI ByteString) ByteString
unWrap Headers
x

-- | Given a list of field-name,field-value pairs, construct a Headers map.

{-
    This is only going to be used by RequestBuilder and ResponseParser,
    obviously. And yes, as usual, we go to a lot of trouble to splice out the
    function doing the work, in the name of type sanity.
-}
buildHeaders :: [(ByteString, ByteString)] -> Headers
buildHeaders :: [(ByteString, ByteString)] -> Headers
buildHeaders [(ByteString, ByteString)]
hs =
    HashMap (CI ByteString) ByteString -> Headers
Wrap HashMap (CI ByteString) ByteString
result
  where
    result :: HashMap (CI ByteString) ByteString
result = (HashMap (CI ByteString) ByteString
 -> (ByteString, ByteString) -> HashMap (CI ByteString) ByteString)
-> HashMap (CI ByteString) ByteString
-> [(ByteString, ByteString)]
-> HashMap (CI ByteString) ByteString
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HashMap (CI ByteString) ByteString
-> (ByteString, ByteString) -> HashMap (CI ByteString) ByteString
addHeader HashMap (CI ByteString) ByteString
forall k v. HashMap k v
empty [(ByteString, ByteString)]
hs

{-
    insertWith is used here for the case where a header is repeated
    (for example, Set-Cookie) and the values need to be intercalated
    with ',' as per RFC 2616 §4.2.
-}
addHeader ::
    HashMap (CI ByteString) ByteString ->
    (ByteString, ByteString) ->
    HashMap (CI ByteString) ByteString
addHeader :: HashMap (CI ByteString) ByteString
-> (ByteString, ByteString) -> HashMap (CI ByteString) ByteString
addHeader HashMap (CI ByteString) ByteString
m (ByteString
k, ByteString
v) =
    (ByteString -> ByteString -> ByteString)
-> CI ByteString
-> ByteString
-> HashMap (CI ByteString) ByteString
-> HashMap (CI ByteString) ByteString
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
insertWith ByteString -> ByteString -> ByteString
f (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
k) ByteString
v HashMap (CI ByteString) ByteString
m
  where
    f :: ByteString -> ByteString -> ByteString
f ByteString
new ByteString
old = [ByteString] -> ByteString
S.concat [ByteString
old, ByteString
",", ByteString
new]

lookupHeader :: Headers -> ByteString -> Maybe ByteString
lookupHeader :: Headers -> ByteString -> Maybe ByteString
lookupHeader Headers
x ByteString
k =
    CI ByteString
-> HashMap (CI ByteString) ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
k) HashMap (CI ByteString) ByteString
m
  where
    !m :: HashMap (CI ByteString) ByteString
m = Headers -> HashMap (CI ByteString) ByteString
unWrap Headers
x

-- | Get the headers as a field-name,field-value association list.
retrieveHeaders :: Headers -> [(ByteString, ByteString)]
retrieveHeaders :: Headers -> [(ByteString, ByteString)]
retrieveHeaders Headers
x =
    ((CI ByteString, ByteString) -> (ByteString, ByteString))
-> [(CI ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> (ByteString, ByteString)
down ([(CI ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(CI ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ HashMap (CI ByteString) ByteString -> [(CI ByteString, ByteString)]
forall k v. HashMap k v -> [(k, v)]
toList HashMap (CI ByteString) ByteString
m
  where
    !m :: HashMap (CI ByteString) ByteString
m = Headers -> HashMap (CI ByteString) ByteString
unWrap Headers
x

down :: (CI ByteString, ByteString) -> (ByteString, ByteString)
down :: (CI ByteString, ByteString) -> (ByteString, ByteString)
down (CI ByteString
k, ByteString
v) =
    (CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
k, ByteString
v)

data HttpParseException = HttpParseException String
    deriving (Typeable, Int -> HttpParseException -> ShowS
[HttpParseException] -> ShowS
HttpParseException -> String
(Int -> HttpParseException -> ShowS)
-> (HttpParseException -> String)
-> ([HttpParseException] -> ShowS)
-> Show HttpParseException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HttpParseException] -> ShowS
$cshowList :: [HttpParseException] -> ShowS
show :: HttpParseException -> String
$cshow :: HttpParseException -> String
showsPrec :: Int -> HttpParseException -> ShowS
$cshowsPrec :: Int -> HttpParseException -> ShowS
Show)

instance Exception HttpParseException