{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Network.HTTP.Client.Headers
( parseStatusHeaders
, validateHeaders
, HeadersValidationResult (..)
) where
import Control.Applicative as A ((<$>), (<*>))
import Control.Monad
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.CaseInsensitive as CI
import Data.Maybe (mapMaybe)
import Data.Monoid
import Data.Word (Word8)
import Network.HTTP.Client.Connection
import Network.HTTP.Client.Types
import Network.HTTP.Types
import System.Timeout (timeout)
charSpace, charColon, charPeriod :: Word8
charSpace :: Word8
charSpace = Word8
32
charColon :: Word8
charColon = Word8
58
charPeriod :: Word8
charPeriod = Word8
46
parseStatusHeaders :: Maybe MaxHeaderLength -> Connection -> Maybe Int -> ([Header] -> IO ()) -> Maybe (IO ()) -> IO StatusHeaders
Maybe MaxHeaderLength
mhl Connection
conn Maybe Int
timeout' RequestHeaders -> IO ()
onEarlyHintHeaders Maybe (IO ())
cont
| Just IO ()
k <- Maybe (IO ())
cont = IO () -> IO StatusHeaders
forall {a}. IO a -> IO StatusHeaders
getStatusExpectContinue IO ()
k
| Bool
otherwise = IO StatusHeaders
getStatus
where
withTimeout :: IO c -> IO c
withTimeout = case Maybe Int
timeout' of
Maybe Int
Nothing -> IO c -> IO c
forall a. a -> a
id
Just Int
t -> Int -> IO c -> IO (Maybe c)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
t (IO c -> IO (Maybe c)) -> (Maybe c -> IO c) -> IO c -> IO c
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO c -> (c -> IO c) -> Maybe c -> IO c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HttpExceptionContent -> IO c
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
ResponseTimeout) c -> IO c
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
getStatus :: IO StatusHeaders
getStatus = IO StatusHeaders -> IO StatusHeaders
forall {c}. IO c -> IO c
withTimeout IO StatusHeaders
next
where
next :: IO StatusHeaders
next = IO (Maybe StatusHeaders)
nextStatusHeaders IO (Maybe StatusHeaders)
-> (Maybe StatusHeaders -> IO StatusHeaders) -> IO StatusHeaders
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO StatusHeaders
-> (StatusHeaders -> IO StatusHeaders)
-> Maybe StatusHeaders
-> IO StatusHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO StatusHeaders
next StatusHeaders -> IO StatusHeaders
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
getStatusExpectContinue :: IO a -> IO StatusHeaders
getStatusExpectContinue IO a
sendBody = do
Maybe StatusHeaders
status <- IO (Maybe StatusHeaders) -> IO (Maybe StatusHeaders)
forall {c}. IO c -> IO c
withTimeout IO (Maybe StatusHeaders)
nextStatusHeaders
case Maybe StatusHeaders
status of
Just StatusHeaders
s -> StatusHeaders -> IO StatusHeaders
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StatusHeaders
s
Maybe StatusHeaders
Nothing -> IO a
sendBody IO a -> IO StatusHeaders -> IO StatusHeaders
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO StatusHeaders
getStatus
nextStatusHeaders :: IO (Maybe StatusHeaders)
nextStatusHeaders :: IO (Maybe StatusHeaders)
nextStatusHeaders = do
(Status
s, HttpVersion
v) <- Maybe MaxHeaderLength -> IO (Status, HttpVersion)
nextStatusLine Maybe MaxHeaderLength
mhl
if | Status -> Int
statusCode Status
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
100 -> Maybe MaxHeaderLength -> Connection -> IO ()
connectionDropTillBlankLine Maybe MaxHeaderLength
mhl Connection
conn IO () -> IO (Maybe StatusHeaders) -> IO (Maybe StatusHeaders)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe StatusHeaders -> IO (Maybe StatusHeaders)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StatusHeaders
forall a. Maybe a
Nothing
| Status -> Int
statusCode Status
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
103 -> do
RequestHeaders
earlyHeaders <- Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
parseEarlyHintHeadersUntilFailure Int
0 RequestHeaders -> RequestHeaders
forall a. a -> a
id
RequestHeaders -> IO ()
onEarlyHintHeaders RequestHeaders
earlyHeaders
IO (Maybe StatusHeaders)
nextStatusHeaders IO (Maybe StatusHeaders)
-> (Maybe StatusHeaders -> IO (Maybe StatusHeaders))
-> IO (Maybe StatusHeaders)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe StatusHeaders
Nothing -> Maybe StatusHeaders -> IO (Maybe StatusHeaders)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StatusHeaders
forall a. Maybe a
Nothing
Just (StatusHeaders Status
s' HttpVersion
v' RequestHeaders
earlyHeaders' RequestHeaders
reqHeaders) ->
Maybe StatusHeaders -> IO (Maybe StatusHeaders)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StatusHeaders -> IO (Maybe StatusHeaders))
-> Maybe StatusHeaders -> IO (Maybe StatusHeaders)
forall a b. (a -> b) -> a -> b
$ StatusHeaders -> Maybe StatusHeaders
forall a. a -> Maybe a
Just (StatusHeaders -> Maybe StatusHeaders)
-> StatusHeaders -> Maybe StatusHeaders
forall a b. (a -> b) -> a -> b
$ Status
-> HttpVersion -> RequestHeaders -> RequestHeaders -> StatusHeaders
StatusHeaders Status
s' HttpVersion
v' (RequestHeaders
earlyHeaders RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. Semigroup a => a -> a -> a
<> RequestHeaders
earlyHeaders') RequestHeaders
reqHeaders
| Bool
otherwise -> (StatusHeaders -> Maybe StatusHeaders
forall a. a -> Maybe a
Just (StatusHeaders -> Maybe StatusHeaders)
-> IO StatusHeaders -> IO (Maybe StatusHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO StatusHeaders -> IO (Maybe StatusHeaders))
-> IO StatusHeaders -> IO (Maybe StatusHeaders)
forall a b. (a -> b) -> a -> b
$ Status
-> HttpVersion -> RequestHeaders -> RequestHeaders -> StatusHeaders
StatusHeaders Status
s HttpVersion
v RequestHeaders
forall a. Monoid a => a
mempty (RequestHeaders -> StatusHeaders)
-> IO RequestHeaders -> IO StatusHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
parseHeaders Int
0 RequestHeaders -> RequestHeaders
forall a. a -> a
id
nextStatusLine :: Maybe MaxHeaderLength -> IO (Status, HttpVersion)
nextStatusLine :: Maybe MaxHeaderLength -> IO (Status, HttpVersion)
nextStatusLine Maybe MaxHeaderLength
mhl = do
ByteString
bs <- Connection -> IO ByteString
connectionRead Connection
conn
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
NoResponseDataReceived
Maybe MaxHeaderLength -> Connection -> ByteString -> IO ByteString
connectionReadLineWith Maybe MaxHeaderLength
mhl Connection
conn ByteString
bs IO ByteString
-> (ByteString -> IO (Status, HttpVersion))
-> IO (Status, HttpVersion)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe MaxHeaderLength
-> Int -> ByteString -> IO (Status, HttpVersion)
parseStatus Maybe MaxHeaderLength
mhl Int
3
parseStatus :: Maybe MaxHeaderLength -> Int -> S.ByteString -> IO (Status, HttpVersion)
parseStatus :: Maybe MaxHeaderLength
-> Int -> ByteString -> IO (Status, HttpVersion)
parseStatus Maybe MaxHeaderLength
mhl Int
i ByteString
bs | ByteString -> Bool
S.null ByteString
bs Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Maybe MaxHeaderLength -> Connection -> IO ByteString
connectionReadLine Maybe MaxHeaderLength
mhl Connection
conn IO ByteString
-> (ByteString -> IO (Status, HttpVersion))
-> IO (Status, HttpVersion)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe MaxHeaderLength
-> Int -> ByteString -> IO (Status, HttpVersion)
parseStatus Maybe MaxHeaderLength
mhl (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
parseStatus Maybe MaxHeaderLength
_ Int
_ ByteString
bs = do
let (ByteString
ver, ByteString
bs2) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charSpace) ByteString
bs
(ByteString
code, ByteString
bs3) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charSpace) (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charSpace) ByteString
bs2
msg :: ByteString
msg = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charSpace) ByteString
bs3
case (,) (HttpVersion -> Int -> (HttpVersion, Int))
-> Maybe HttpVersion -> Maybe (Int -> (HttpVersion, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe HttpVersion
parseVersion ByteString
ver Maybe (Int -> (HttpVersion, Int))
-> Maybe Int -> Maybe (HttpVersion, Int)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
A.<*> ByteString -> Maybe Int
readInt ByteString
code of
Just (HttpVersion
ver', Int
code') -> (Status, HttpVersion) -> IO (Status, HttpVersion)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ByteString -> Status
Status Int
code' ByteString
msg, HttpVersion
ver')
Maybe (HttpVersion, Int)
Nothing -> HttpExceptionContent -> IO (Status, HttpVersion)
forall a. HttpExceptionContent -> IO a
throwHttp (HttpExceptionContent -> IO (Status, HttpVersion))
-> HttpExceptionContent -> IO (Status, HttpVersion)
forall a b. (a -> b) -> a -> b
$ ByteString -> HttpExceptionContent
InvalidStatusLine ByteString
bs
stripPrefixBS :: ByteString -> ByteString -> Maybe ByteString
stripPrefixBS ByteString
x ByteString
y
| ByteString
x ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
y = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
x) ByteString
y
| Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing
parseVersion :: ByteString -> Maybe HttpVersion
parseVersion ByteString
bs0 = do
ByteString
bs1 <- ByteString -> ByteString -> Maybe ByteString
stripPrefixBS ByteString
"HTTP/" ByteString
bs0
let (ByteString
num1, Int -> ByteString -> ByteString
S.drop Int
1 -> ByteString
num2) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charPeriod) ByteString
bs1
Int -> Int -> HttpVersion
HttpVersion (Int -> Int -> HttpVersion)
-> Maybe Int -> Maybe (Int -> HttpVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe Int
readInt ByteString
num1 Maybe (Int -> HttpVersion) -> Maybe Int -> Maybe HttpVersion
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Maybe Int
readInt ByteString
num2
readInt :: ByteString -> Maybe Int
readInt ByteString
bs =
case ByteString -> Maybe (Int, ByteString)
S8.readInt ByteString
bs of
Just (Int
i, ByteString
"") -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
Maybe (Int, ByteString)
_ -> Maybe Int
forall a. Maybe a
Nothing
parseHeaders :: Int -> ([Header] -> [Header]) -> IO [Header]
parseHeaders :: Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
parseHeaders Int
100 RequestHeaders -> RequestHeaders
_ = HttpExceptionContent -> IO RequestHeaders
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
OverlongHeaders
parseHeaders Int
count RequestHeaders -> RequestHeaders
front = do
ByteString
line <- Maybe MaxHeaderLength -> Connection -> IO ByteString
connectionReadLine Maybe MaxHeaderLength
mhl Connection
conn
if ByteString -> Bool
S.null ByteString
line
then RequestHeaders -> IO RequestHeaders
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestHeaders -> IO RequestHeaders)
-> RequestHeaders -> IO RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> RequestHeaders
front []
else
ByteString -> IO (Maybe Header)
parseHeader ByteString
line IO (Maybe Header)
-> (Maybe Header -> IO RequestHeaders) -> IO RequestHeaders
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Header
header ->
Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
parseHeaders (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ((RequestHeaders -> RequestHeaders) -> IO RequestHeaders)
-> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> RequestHeaders
front (RequestHeaders -> RequestHeaders)
-> (RequestHeaders -> RequestHeaders)
-> RequestHeaders
-> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header
headerHeader -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:)
Maybe Header
Nothing ->
Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
parseHeaders Int
count RequestHeaders -> RequestHeaders
front
parseEarlyHintHeadersUntilFailure :: Int -> ([Header] -> [Header]) -> IO [Header]
parseEarlyHintHeadersUntilFailure :: Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
parseEarlyHintHeadersUntilFailure Int
100 RequestHeaders -> RequestHeaders
_ = HttpExceptionContent -> IO RequestHeaders
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
OverlongHeaders
parseEarlyHintHeadersUntilFailure Int
count RequestHeaders -> RequestHeaders
front = do
ByteString
line <- Maybe MaxHeaderLength -> Connection -> IO ByteString
connectionReadLine Maybe MaxHeaderLength
mhl Connection
conn
if ByteString -> Bool
S.null ByteString
line
then RequestHeaders -> IO RequestHeaders
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestHeaders -> IO RequestHeaders)
-> RequestHeaders -> IO RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> RequestHeaders
front []
else
ByteString -> IO (Maybe Header)
parseHeader ByteString
line IO (Maybe Header)
-> (Maybe Header -> IO RequestHeaders) -> IO RequestHeaders
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Header
header ->
Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
parseEarlyHintHeadersUntilFailure (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ((RequestHeaders -> RequestHeaders) -> IO RequestHeaders)
-> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> RequestHeaders
front (RequestHeaders -> RequestHeaders)
-> (RequestHeaders -> RequestHeaders)
-> RequestHeaders
-> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header
headerHeader -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:)
Maybe Header
Nothing -> do
Connection -> ByteString -> IO ()
connectionUnreadLine Connection
conn ByteString
line
RequestHeaders -> IO RequestHeaders
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestHeaders -> IO RequestHeaders)
-> RequestHeaders -> IO RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> RequestHeaders
front []
parseHeader :: S.ByteString -> IO (Maybe Header)
parseHeader :: ByteString -> IO (Maybe Header)
parseHeader ByteString
bs = do
let (ByteString
key, ByteString
bs2) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charColon) ByteString
bs
if ByteString -> Bool
S.null ByteString
bs2
then Maybe Header -> IO (Maybe Header)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Header
forall a. Maybe a
Nothing
else Maybe Header -> IO (Maybe Header)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Header -> Maybe Header
forall a. a -> Maybe a
Just (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString
strip ByteString
key, ByteString -> ByteString
strip (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$! Int -> ByteString -> ByteString
S.drop Int
1 ByteString
bs2))
strip :: ByteString -> ByteString
strip = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charSpace) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charSpace)
data
=
| S.ByteString
validateHeaders :: RequestHeaders -> HeadersValidationResult
RequestHeaders
headers =
case (Header -> Maybe ByteString) -> RequestHeaders -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Header -> Maybe ByteString
forall {a}.
(Semigroup a, IsString a) =>
(CI a, ByteString) -> Maybe a
validateHeader RequestHeaders
headers of
[] -> HeadersValidationResult
GoodHeaders
[ByteString]
reasons -> ByteString -> HeadersValidationResult
BadHeaders ([ByteString] -> ByteString
S8.unlines [ByteString]
reasons)
where
validateHeader :: (CI a, ByteString) -> Maybe a
validateHeader (CI a
k, ByteString
v)
| Char -> ByteString -> Bool
S8.elem Char
'\n' ByteString
v = a -> Maybe a
forall a. a -> Maybe a
Just (a
"Header " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> CI a -> a
forall s. CI s -> s
CI.original CI a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" has newlines")
| Bool
True = Maybe a
forall a. Maybe a
Nothing