{-# LANGUAGE DisambiguateRecordFields #-}
{-# 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.Char (ord)
import           Data.Maybe (mapMaybe)
import           Data.Monoid
import           Network.HTTP.Client.Connection
import           Network.HTTP.Client.Types
import           System.Timeout                 (timeout)
import           Network.HTTP.Types
import Data.Word (Word8)

charSpace, charColon, charPeriod :: Word8
charSpace :: Word8
charSpace = Word8
32
charColon :: Word8
charColon = Word8
58
charPeriod :: Word8
charPeriod = Word8
46


parseStatusHeaders :: Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders
parseStatusHeaders :: Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders
parseStatusHeaders Connection
conn Maybe Int
timeout' 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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return StatusHeaders
s
            Maybe StatusHeaders
Nothing -> IO a
sendBody IO a -> IO StatusHeaders -> IO StatusHeaders
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO StatusHeaders
getStatus

    nextStatusHeaders :: IO (Maybe StatusHeaders)
nextStatusHeaders = do
        (Status
s, HttpVersion
v) <- IO (Status, HttpVersion)
nextStatusLine
        if Status -> Int
statusCode Status
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
100
            then Connection -> IO ()
connectionDropTillBlankLine Connection
conn IO () -> IO (Maybe StatusHeaders) -> IO (Maybe StatusHeaders)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe StatusHeaders -> IO (Maybe StatusHeaders)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StatusHeaders
forall a. Maybe a
Nothing
            else StatusHeaders -> Maybe StatusHeaders
forall a. a -> Maybe a
Just (StatusHeaders -> Maybe StatusHeaders)
-> (RequestHeaders -> StatusHeaders)
-> RequestHeaders
-> Maybe StatusHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> HttpVersion -> RequestHeaders -> StatusHeaders
StatusHeaders Status
s HttpVersion
v (RequestHeaders -> Maybe StatusHeaders)
-> IO RequestHeaders -> IO (Maybe StatusHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
forall t c. (Eq t, Num t) => t -> (RequestHeaders -> c) -> IO c
parseHeaders (Int
0 :: Int) RequestHeaders -> RequestHeaders
forall a. a -> a
id

    nextStatusLine :: IO (Status, HttpVersion)
    nextStatusLine :: IO (Status, HttpVersion)
nextStatusLine = do
        -- Ensure that there is some data coming in. If not, we want to signal
        -- this as a connection problem and not a protocol problem.
        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
        Connection -> ByteString -> IO ByteString
connectionReadLineWith Connection
conn ByteString
bs IO ByteString
-> (ByteString -> IO (Status, HttpVersion))
-> IO (Status, HttpVersion)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ByteString -> IO (Status, HttpVersion)
parseStatus Int
3

    parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion)
    parseStatus :: Int -> ByteString -> IO (Status, HttpVersion)
parseStatus 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 = Connection -> IO ByteString
connectionReadLine Connection
conn IO ByteString
-> (ByteString -> IO (Status, HttpVersion))
-> IO (Status, HttpVersion)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ByteString -> IO (Status, HttpVersion)
parseStatus (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    parseStatus 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 (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 (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 (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 :: t -> (RequestHeaders -> c) -> IO c
parseHeaders t
100 RequestHeaders -> c
_ = HttpExceptionContent -> IO c
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
OverlongHeaders
    parseHeaders t
count RequestHeaders -> c
front = do
        ByteString
line <- Connection -> IO ByteString
connectionReadLine Connection
conn
        if ByteString -> Bool
S.null ByteString
line
            then c -> IO c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> IO c) -> c -> IO c
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> c
front []
            else do
                Maybe Header
mheader <- ByteString -> IO (Maybe Header)
parseHeader ByteString
line
                case Maybe Header
mheader of
                    Just Header
header ->
                        t -> (RequestHeaders -> c) -> IO c
parseHeaders (t
count t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) ((RequestHeaders -> c) -> IO c) -> (RequestHeaders -> c) -> IO c
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> c
front (RequestHeaders -> c)
-> (RequestHeaders -> RequestHeaders) -> RequestHeaders -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header
headerHeader -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:)
                    Maybe Header
Nothing ->
                        -- Unparseable header line; rather than throwing
                        -- an exception, ignore it for robustness.
                        t -> (RequestHeaders -> c) -> IO c
parseHeaders t
count RequestHeaders -> c
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Header
forall a. Maybe a
Nothing
            else Maybe Header -> IO (Maybe Header)
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 HeadersValidationResult
    = GoodHeaders
    | BadHeaders S.ByteString -- contains a message with the reason

validateHeaders :: RequestHeaders -> HeadersValidationResult
validateHeaders :: RequestHeaders -> HeadersValidationResult
validateHeaders 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