{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Handler.Warp.Header (
    IndexedRequestHeader (..),
    ResponseHeaderPresence (..),
    indexRequestHeader,
    defaultIndexRequestHeader,
    indexResponseHeader,
) where

import qualified Data.ByteString as BS
import Data.CaseInsensitive (foldedCase)
import Data.List as L (foldl')
import Data.Maybe (isJust)
import Network.HTTP.Types

import Network.Wai.Handler.Warp.Types

----------------------------------------------------------------

-- | Strict record of the request headers that Warp inspects,
--   one field per header.
data IndexedRequestHeader = IndexedRequestHeader
    { IndexedRequestHeader -> Maybe HeaderValue
reqidxContentLength :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxTransferEncoding :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxExpect :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxConnection :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxRange :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxHost :: Maybe HeaderValue
    , IndexedRequestHeader -> Bool
reqidxHostRepeated :: Bool
    -- ^ Whether more than one @Host@ field line was sent.
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxIfModifiedSince :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxIfUnmodifiedSince :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxIfRange :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxReferer :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxUserAgent :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxIfMatch :: Maybe HeaderValue
    , IndexedRequestHeader -> Maybe HeaderValue
reqidxIfNoneMatch :: Maybe HeaderValue
    }

indexRequestHeader :: RequestHeaders -> IndexedRequestHeader
indexRequestHeader :: RequestHeaders -> IndexedRequestHeader
indexRequestHeader = (IndexedRequestHeader -> Header -> IndexedRequestHeader)
-> IndexedRequestHeader -> RequestHeaders -> IndexedRequestHeader
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' IndexedRequestHeader -> Header -> IndexedRequestHeader
insert IndexedRequestHeader
defaultIndexRequestHeader
  where
    insert :: IndexedRequestHeader -> Header -> IndexedRequestHeader
insert IndexedRequestHeader
ix (CI HeaderValue
key, HeaderValue
val) = case HeaderValue -> Int
BS.length HeaderValue
bs of
        Int
4
            | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"host" ->
                IndexedRequestHeader
ix
                    { reqidxHost = Just val
                    , reqidxHostRepeated = isJust (reqidxHost ix)
                    }
        Int
5 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"range" -> IndexedRequestHeader
ix{reqidxRange = Just val}
        Int
6 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"expect" -> IndexedRequestHeader
ix{reqidxExpect = Just val}
        Int
7 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"referer" -> IndexedRequestHeader
ix{reqidxReferer = Just val}
        Int
8
            | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"if-range" -> IndexedRequestHeader
ix{reqidxIfRange = Just val}
            | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"if-match" -> IndexedRequestHeader
ix{reqidxIfMatch = Just val}
        Int
10
            | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"user-agent" -> IndexedRequestHeader
ix{reqidxUserAgent = Just val}
            | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"connection" -> IndexedRequestHeader
ix{reqidxConnection = Just val}
        Int
13 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"if-none-match" -> IndexedRequestHeader
ix{reqidxIfNoneMatch = Just val}
        Int
14
            | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"content-length" ->
                IndexedRequestHeader
ix{reqidxContentLength = appendField (reqidxContentLength ix) val}
        Int
17
            | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"transfer-encoding" ->
                IndexedRequestHeader
ix{reqidxTransferEncoding = appendField (reqidxTransferEncoding ix) val}
            | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"if-modified-since" -> IndexedRequestHeader
ix{reqidxIfModifiedSince = Just val}
        Int
19 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"if-unmodified-since" -> IndexedRequestHeader
ix{reqidxIfUnmodifiedSince = Just val}
        Int
_ -> IndexedRequestHeader
ix
      where
        bs :: HeaderValue
bs = CI HeaderValue -> HeaderValue
forall s. CI s -> s
foldedCase CI HeaderValue
key
        -- RFC 9112: repeated field lines are one comma separated list, so
        -- keep them all. Taking the last line alone would let a second
        -- Content-Length hide the length of the first, or a second
        -- Transfer-Encoding its chunked coding.
        appendField :: Maybe a -> a -> Maybe a
appendField Maybe a
Nothing a
val' = a -> Maybe a
forall a. a -> Maybe a
Just a
val'
        appendField (Just a
prev) a
val' = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a
prev a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"," a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
val'

-- | 'IndexedRequestHeader' with no headers set.
defaultIndexRequestHeader :: IndexedRequestHeader
defaultIndexRequestHeader :: IndexedRequestHeader
defaultIndexRequestHeader =
    IndexedRequestHeader
        { reqidxContentLength :: Maybe HeaderValue
reqidxContentLength = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxTransferEncoding :: Maybe HeaderValue
reqidxTransferEncoding = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxExpect :: Maybe HeaderValue
reqidxExpect = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxConnection :: Maybe HeaderValue
reqidxConnection = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxRange :: Maybe HeaderValue
reqidxRange = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxHost :: Maybe HeaderValue
reqidxHost = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxHostRepeated :: Bool
reqidxHostRepeated = Bool
False
        , reqidxIfModifiedSince :: Maybe HeaderValue
reqidxIfModifiedSince = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxIfUnmodifiedSince :: Maybe HeaderValue
reqidxIfUnmodifiedSince = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxIfRange :: Maybe HeaderValue
reqidxIfRange = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxReferer :: Maybe HeaderValue
reqidxReferer = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxUserAgent :: Maybe HeaderValue
reqidxUserAgent = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxIfMatch :: Maybe HeaderValue
reqidxIfMatch = Maybe HeaderValue
forall a. Maybe a
Nothing
        , reqidxIfNoneMatch :: Maybe HeaderValue
reqidxIfNoneMatch = Maybe HeaderValue
forall a. Maybe a
Nothing
        }

----------------------------------------------------------------

-- | Presence of the response headers Warp itself consults.
--   Only these four headers are ever looked up on the response side, and
--   only their presence, never their value, so a flat record of strict
--   'Bool's built in a single traversal beats a boxed array.
data ResponseHeaderPresence = ResponseHeaderPresence
    { ResponseHeaderPresence -> Bool
hasContentLength :: Bool
    , ResponseHeaderPresence -> Bool
hasServer :: Bool
    , ResponseHeaderPresence -> Bool
hasDate :: Bool
    , ResponseHeaderPresence -> Bool
hasLastModified :: Bool
    , ResponseHeaderPresence -> Maybe HeaderValue
hasTransferEncoding :: Maybe HeaderValue
    , ResponseHeaderPresence -> Maybe HeaderValue
hasConnection :: Maybe HeaderValue
    }

indexResponseHeader :: ResponseHeaders -> ResponseHeaderPresence
indexResponseHeader :: RequestHeaders -> ResponseHeaderPresence
indexResponseHeader = ResponseHeaderPresence -> RequestHeaders -> ResponseHeaderPresence
go ResponseHeaderPresence
emptyResponseHeaderPresence
  where
    go :: ResponseHeaderPresence -> RequestHeaders -> ResponseHeaderPresence
go ResponseHeaderPresence
ix [] = ResponseHeaderPresence
ix
    go ResponseHeaderPresence
ix (Header
tup : RequestHeaders
rest) = ResponseHeaderPresence -> RequestHeaders -> ResponseHeaderPresence
go (ResponseHeaderPresence -> Header -> ResponseHeaderPresence
insert ResponseHeaderPresence
ix Header
tup) RequestHeaders
rest
    insert :: ResponseHeaderPresence -> Header -> ResponseHeaderPresence
insert ResponseHeaderPresence
ix (CI HeaderValue
key, HeaderValue
val) = case HeaderValue -> Int
BS.length HeaderValue
bs of
        Int
4 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"date" -> ResponseHeaderPresence
ix{hasDate = True}
        Int
6 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"server" -> ResponseHeaderPresence
ix{hasServer = True}
        Int
10 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"connection" -> ResponseHeaderPresence
ix{hasConnection = Just val}
        Int
13 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"last-modified" -> ResponseHeaderPresence
ix{hasLastModified = True}
        Int
14 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"content-length" -> ResponseHeaderPresence
ix{hasContentLength = True}
        Int
17 | HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"transfer-encoding" -> ResponseHeaderPresence
ix{hasTransferEncoding = Just val}
        Int
_ -> ResponseHeaderPresence
ix
      where
        bs :: HeaderValue
bs = CI HeaderValue -> HeaderValue
forall s. CI s -> s
foldedCase CI HeaderValue
key

emptyResponseHeaderPresence :: ResponseHeaderPresence
emptyResponseHeaderPresence :: ResponseHeaderPresence
emptyResponseHeaderPresence =
    ResponseHeaderPresence
        { hasContentLength :: Bool
hasContentLength = Bool
False
        , hasServer :: Bool
hasServer = Bool
False
        , hasDate :: Bool
hasDate = Bool
False
        , hasLastModified :: Bool
hasLastModified = Bool
False
        , hasTransferEncoding :: Maybe HeaderValue
hasTransferEncoding = Maybe HeaderValue
forall a. Maybe a
Nothing
        , hasConnection :: Maybe HeaderValue
hasConnection = Maybe HeaderValue
forall a. Maybe a
Nothing
        }