{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide, prune #-}
module Network.Http.Internal (
Hostname,
Port,
Request(..),
EntityBody(..),
ExpectMode(..),
Response(..),
StatusCode,
TransferEncoding(..),
ContentEncoding(..),
getStatusCode,
getStatusMessage,
getHeader,
getHeaderMap,
Method(..),
Headers,
emptyHeaders,
updateHeader,
removeHeader,
buildHeaders,
lookupHeader,
retrieveHeaders,
HttpType (getHeaders),
HttpParseException(..),
hasBrotli,
composeRequestBytes,
composeResponseBytes
) where
import Prelude hiding (lookup)
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder (copyByteString,
copyByteString,
fromByteString,
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 qualified Data.Map.Strict as Map
import Data.Map (Map)
import Data.Int (Int64)
import Data.List (foldl')
import Data.Monoid as Mon (mconcat, mempty)
import Data.Typeable (Typeable)
import Data.Word (Word16)
type Hostname = ByteString
type Port = Word16
{-# INLINE hasBrotli #-}
hasBrotli :: Bool
#if defined(MIN_VERSION_brotli_streams)
hasBrotli :: Bool
hasBrotli = Bool
True
#else
hasBrotli = False
#endif
data Method
= GET
| HEAD
| POST
| PUT
| DELETE
| TRACE
| OPTIONS
| CONNECT
| PATCH
| Method ByteString
deriving (Int -> Method -> ShowS
[Method] -> ShowS
Method -> String
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]
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
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
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 forall a. Eq a => a -> a -> Bool
== ByteString
b
m :: Method
m@(Method ByteString
_) == Method
other = Method
other forall a. Eq a => a -> a -> Bool
== Method
m
Method
_ == Method
_ = Bool
False
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,
:: !Headers
} deriving (Request -> Request -> Bool
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 forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r') forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString forall a b. (a -> b) -> a -> b
$ Request -> ByteString -> Builder
composeRequestBytes Request
q ByteString
"<default>"
data EntityBody = Empty | Chunking | Static Int64 deriving (Int -> EntityBody -> ShowS
[EntityBody] -> ShowS
EntityBody -> String
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
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
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
Ord)
data ExpectMode = Normal | Continue deriving (Int -> ExpectMode -> ShowS
[ExpectMode] -> ShowS
ExpectMode -> String
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
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
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
Ord)
composeRequestBytes :: Request -> ByteString -> Builder
composeRequestBytes :: Request -> ByteString -> Builder
composeRequestBytes Request
q ByteString
h' =
forall a. Monoid a => [a] -> a
mconcat
[Builder
requestline,
Builder
hostLine,
Builder
headerFields,
Builder
crlf]
where
requestline :: Builder
requestline = forall a. Monoid a => [a] -> a
Mon.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 = 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 = Map (CI ByteString) ByteString -> Builder
joinHeaders forall a b. (a -> b) -> a -> b
$ Headers -> Map (CI ByteString) ByteString
unWrap 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
' '
type StatusCode = Int
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),
:: !Headers
}
instance Show Response where
show :: Response -> String
show Response
p = {-# SCC "Response.show" #-}
ByteString -> String
S.unpack forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r') forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString forall a b. (a -> b) -> a -> b
$ Response -> Builder
composeResponseBytes Response
p
data TransferEncoding = None | Chunked
data ContentEncoding = Identity | Gzip | Deflate | Br | UnknownCE !ByteString
deriving (Int -> ContentEncoding -> ShowS
[ContentEncoding] -> ShowS
ContentEncoding -> String
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)
getStatusCode :: Response -> StatusCode
getStatusCode :: Response -> Int
getStatusCode = Response -> Int
pStatusCode
{-# INLINE getStatusCode #-}
getStatusMessage :: Response -> ByteString
getStatusMessage :: Response -> ByteString
getStatusMessage = Response -> ByteString
pStatusMsg
{-# INLINE getStatusMessage #-}
getHeader :: Response -> ByteString -> Maybe ByteString
Response
p ByteString
k =
Headers -> ByteString -> Maybe ByteString
lookupHeader Headers
h ByteString
k
where
h :: Headers
h = Response -> Headers
pHeaders Response
p
getHeaderMap :: Response -> Map (CI ByteString) ByteString
= Headers -> Map (CI ByteString) ByteString
unWrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Headers
pHeaders
class HttpType τ where
:: τ -> 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 =
forall a. Monoid a => [a] -> a
mconcat
[Builder
statusline,
Builder
headerFields,
Builder
crlf]
where
statusline :: Builder
statusline = forall a. Monoid a => [a] -> a
mconcat
[Builder
version,
Builder
sp,
Builder
code,
Builder
sp,
Builder
message,
Builder
crlf]
code :: Builder
code = forall a. Show a => a -> Builder
Builder.fromShow forall a b. (a -> b) -> a -> b
$ Response -> Int
pStatusCode Response
p
message :: Builder
message = ByteString -> Builder
Builder.copyByteString 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 = Map (CI ByteString) ByteString -> Builder
joinHeaders forall a b. (a -> b) -> a -> b
$ Headers -> Map (CI ByteString) ByteString
unWrap forall a b. (a -> b) -> a -> b
$ Response -> Headers
pHeaders Response
p
newtype = Wrap {
Headers -> Map (CI ByteString) ByteString
unWrap :: Map (CI ByteString) ByteString
} deriving (Headers -> Headers -> Bool
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 forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r') forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString forall a b. (a -> b) -> a -> b
$ Map (CI ByteString) ByteString -> Builder
joinHeaders forall a b. (a -> b) -> a -> b
$ Headers -> Map (CI ByteString) ByteString
unWrap Headers
x
joinHeaders :: Map (CI ByteString) ByteString -> Builder
Map (CI ByteString) ByteString
m = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey CI ByteString -> ByteString -> Builder -> Builder
combine forall a. Monoid a => a
Mon.mempty Map (CI ByteString) ByteString
m
combine :: CI ByteString -> ByteString -> Builder -> Builder
combine :: CI ByteString -> ByteString -> Builder -> Builder
combine CI ByteString
k ByteString
v Builder
acc =
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 forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
original CI ByteString
k
value :: Builder
value = ByteString -> Builder
Builder.fromByteString ByteString
v
{-# INLINE combine #-}
emptyHeaders :: Headers
=
Map (CI ByteString) ByteString -> Headers
Wrap forall k a. Map k a
Map.empty
updateHeader :: Headers -> ByteString -> ByteString -> Headers
Headers
x ByteString
k ByteString
v =
Map (CI ByteString) ByteString -> Headers
Wrap Map (CI ByteString) ByteString
result
where
!result :: Map (CI ByteString) ByteString
result = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall s. FoldCase s => s -> CI s
mk ByteString
k) ByteString
v Map (CI ByteString) ByteString
m
!m :: Map (CI ByteString) ByteString
m = Headers -> Map (CI ByteString) ByteString
unWrap Headers
x
removeHeader :: Headers -> ByteString -> Headers
Headers
x ByteString
k =
Map (CI ByteString) ByteString -> Headers
Wrap Map (CI ByteString) ByteString
result
where
!result :: Map (CI ByteString) ByteString
result = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall s. FoldCase s => s -> CI s
mk ByteString
k) Map (CI ByteString) ByteString
m
!m :: Map (CI ByteString) ByteString
m = Headers -> Map (CI ByteString) ByteString
unWrap Headers
x
buildHeaders :: [(ByteString, ByteString)] -> Headers
[(ByteString, ByteString)]
hs =
Map (CI ByteString) ByteString -> Headers
Wrap Map (CI ByteString) ByteString
result
where
result :: Map (CI ByteString) ByteString
result = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map (CI ByteString) ByteString
-> (ByteString, ByteString) -> Map (CI ByteString) ByteString
addHeader forall k a. Map k a
Map.empty [(ByteString, ByteString)]
hs
addHeader
:: Map (CI ByteString) ByteString
-> (ByteString,ByteString)
-> Map (CI ByteString) ByteString
Map (CI ByteString) ByteString
m (ByteString
k,ByteString
v) =
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ByteString -> ByteString -> ByteString
f (forall s. FoldCase s => s -> CI s
mk ByteString
k) ByteString
v Map (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
Headers
x ByteString
k =
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall s. FoldCase s => s -> CI s
mk ByteString
k) Map (CI ByteString) ByteString
m
where
!m :: Map (CI ByteString) ByteString
m = Headers -> Map (CI ByteString) ByteString
unWrap Headers
x
retrieveHeaders :: Headers -> [(ByteString, ByteString)]
Headers
x =
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> (ByteString, ByteString)
down forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map (CI ByteString) ByteString
m
where
!m :: Map (CI ByteString) ByteString
m = Headers -> Map (CI ByteString) ByteString
unWrap Headers
x
down :: (CI ByteString, ByteString) -> (ByteString, ByteString)
down :: (CI ByteString, ByteString) -> (ByteString, ByteString)
down (CI ByteString
k, ByteString
v) =
(forall s. CI s -> s
original CI ByteString
k, ByteString
v)
data HttpParseException = HttpParseException String
deriving (Typeable, Int -> HttpParseException -> ShowS
[HttpParseException] -> ShowS
HttpParseException -> String
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