    {-# 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 -> Maybe MaxNumberHeaders -> Connection -> Maybe Int -> ([Header] -> IO ()) -> Maybe (IO ()) -> IO StatusHeaders
    parseStatusHeaders :: Maybe MaxHeaderLength
    -> Maybe MaxNumberHeaders
    -> Connection
    -> Maybe Int
    -> (RequestHeaders -> IO ())
    -> Maybe (IO ())
    -> IO StatusHeaders
    parseStatusHeaders Maybe MaxHeaderLength
    mhl Maybe MaxNumberHeaders
    mnh 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
            status <- IO (Maybe StatusHeaders) -> IO (Maybe StatusHeaders)
    forall {c}. IO c -> IO c
    withTimeout IO (Maybe StatusHeaders)
    nextStatusHeaders
            case 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
            (s, v) <- Maybe MaxHeaderLength -> IO (Status, HttpVersion)
    nextStatusLine Maybe MaxHeaderLength
    mhl
            if | statusCode s == 100 -> connectionDropTillBlankLine mhl conn >> return Nothing
               | statusCode s == 103 -> do
                     earlyHeaders <- parseEarlyHintHeadersUntilFailure 0 id
                     onEarlyHintHeaders earlyHeaders
                     nextStatusHeaders >>= \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
               | otherwise -> (Just <$>) $ StatusHeaders s v mempty A.<$> parseHeaders 0 id

        nextStatusLine :: Maybe MaxHeaderLength -> IO (Status, HttpVersion)
        nextStatusLine :: Maybe MaxHeaderLength -> IO (Status, HttpVersion)
    nextStatusLine Maybe MaxHeaderLength
    mhl = 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.
            bs <- Connection -> IO ByteString
    connectionRead Connection
    conn
            when (S.null bs) $ throwHttp NoResponseDataReceived
            connectionReadLineWith mhl conn bs >>= parseStatus mhl 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
            bs1 <- ByteString -> ByteString -> Maybe ByteString
    stripPrefixBS ByteString
    "HTTP/" ByteString
    bs0
            let (num1, S.drop 1 -> num2) = S.break (== charPeriod) bs1
            HttpVersion <$> readInt num1 <*> readInt 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

        guardMaxNumberHeaders :: Int -> IO ()
        guardMaxNumberHeaders :: Int -> IO ()
    guardMaxNumberHeaders Int
    count = case (MaxNumberHeaders -> Int) -> Maybe MaxNumberHeaders -> Maybe Int
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap MaxNumberHeaders -> Int
    unMaxNumberHeaders Maybe MaxNumberHeaders
    mnh of
            Maybe Int
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
            Just Int
    n -> Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    count Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    n) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ HttpExceptionContent -> IO ()
    forall a. HttpExceptionContent -> IO a
    throwHttp HttpExceptionContent
    TooManyHeaderFields

        parseHeaders :: Int -> ([Header] -> [Header]) -> IO [Header]
        parseHeaders :: Int -> (RequestHeaders -> RequestHeaders) -> IO RequestHeaders
    parseHeaders Int
    count RequestHeaders -> RequestHeaders
    front = do
            Int -> IO ()
    guardMaxNumberHeaders Int
    count
            line <- Maybe MaxHeaderLength -> Connection -> IO ByteString
    connectionReadLine Maybe MaxHeaderLength
    mhl Connection
    conn
            if S.null line
                then return $ front []
                else
                    parseHeader line >>= \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 ->
                            -- Unparseable header line; rather than throwing
                            -- an exception, ignore it for robustness.
                            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
    count RequestHeaders -> RequestHeaders
    front = do
            Int -> IO ()
    guardMaxNumberHeaders Int
    count
            line <- Maybe MaxHeaderLength -> Connection -> IO ByteString
    connectionReadLine Maybe MaxHeaderLength
    mhl Connection
    conn
            if S.null line
                then return $ front []
                else
                    parseHeader line >>= \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 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