Header.hs

{-# 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 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
    { reqidxContentLength :: Maybe HeaderValue
    , reqidxTransferEncoding :: Maybe HeaderValue
    , reqidxExpect :: Maybe HeaderValue
    , reqidxConnection :: Maybe HeaderValue
    , reqidxRange :: Maybe HeaderValue
    , reqidxHost :: Maybe HeaderValue
    , reqidxIfModifiedSince :: Maybe HeaderValue
    , reqidxIfUnmodifiedSince :: Maybe HeaderValue
    , reqidxIfRange :: Maybe HeaderValue
    , reqidxReferer :: Maybe HeaderValue
    , reqidxUserAgent :: Maybe HeaderValue
    , reqidxIfMatch :: Maybe HeaderValue
    , reqidxIfNoneMatch :: Maybe HeaderValue
    }

indexRequestHeader :: RequestHeaders -> IndexedRequestHeader
indexRequestHeader = L.foldl' insert defaultIndexRequestHeader
  where
    insert ix (key, val) = case BS.length bs of
        4 | bs == "host" -> ix{reqidxHost = Just val}
        5 | bs == "range" -> ix{reqidxRange = Just val}
        6 | bs == "expect" -> ix{reqidxExpect = Just val}
        7 | bs == "referer" -> ix{reqidxReferer = Just val}
        8
            | bs == "if-range" -> ix{reqidxIfRange = Just val}
            | bs == "if-match" -> ix{reqidxIfMatch = Just val}
        10
            | bs == "user-agent" -> ix{reqidxUserAgent = Just val}
            | bs == "connection" -> ix{reqidxConnection = Just val}
        13 | bs == "if-none-match" -> ix{reqidxIfNoneMatch = Just val}
        14 | bs == "content-length" -> ix{reqidxContentLength = Just val}
        17
            | bs == "transfer-encoding" -> ix{reqidxTransferEncoding = Just val}
            | bs == "if-modified-since" -> ix{reqidxIfModifiedSince = Just val}
        19 | bs == "if-unmodified-since" -> ix{reqidxIfUnmodifiedSince = Just val}
        _ -> ix
      where
        bs = foldedCase key

-- | 'IndexedRequestHeader' with no headers set.
defaultIndexRequestHeader :: IndexedRequestHeader
defaultIndexRequestHeader =
    IndexedRequestHeader
        { reqidxContentLength = Nothing
        , reqidxTransferEncoding = Nothing
        , reqidxExpect = Nothing
        , reqidxConnection = Nothing
        , reqidxRange = Nothing
        , reqidxHost = Nothing
        , reqidxIfModifiedSince = Nothing
        , reqidxIfUnmodifiedSince = Nothing
        , reqidxIfRange = Nothing
        , reqidxReferer = Nothing
        , reqidxUserAgent = Nothing
        , reqidxIfMatch = Nothing
        , reqidxIfNoneMatch = 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
    { hasContentLength :: Bool
    , hasServer :: Bool
    , hasDate :: Bool
    , hasLastModified :: Bool
    , hasTransferEncoding :: Maybe HeaderValue
    , hasConnection :: Maybe HeaderValue
    }

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

emptyResponseHeaderPresence :: ResponseHeaderPresence
emptyResponseHeaderPresence =
    ResponseHeaderPresence
        { hasContentLength = False
        , hasServer = False
        , hasDate = False
        , hasLastModified = False
        , hasTransferEncoding = Nothing
        , hasConnection = Nothing
        }