{-# 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.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