{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}

module Network.Wai.Handler.Warp.Header where

import Data.Array
import Data.Array.ST
import qualified Data.ByteString as BS
import Data.CaseInsensitive (foldedCase)
import Network.HTTP.Types

import Network.Wai.Handler.Warp.Types

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

-- | Array for a set of HTTP headers.
type IndexedHeader = Array Int (Maybe HeaderValue)

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

indexRequestHeader :: RequestHeaders -> IndexedHeader
indexRequestHeader :: RequestHeaders -> IndexedHeader
indexRequestHeader hdr :: RequestHeaders
hdr = RequestHeaders -> Int -> (HeaderName -> Int) -> IndexedHeader
traverseHeader RequestHeaders
hdr Int
requestMaxIndex HeaderName -> Int
requestKeyIndex

data RequestHeaderIndex = ReqContentLength
                        | ReqTransferEncoding
                        | ReqExpect
                        | ReqConnection
                        | ReqRange
                        | ReqHost
                        | ReqIfModifiedSince
                        | ReqIfUnmodifiedSince
                        | ReqIfRange
                        | ReqReferer
                        | ReqUserAgent
                        deriving (Int -> RequestHeaderIndex
RequestHeaderIndex -> Int
RequestHeaderIndex -> [RequestHeaderIndex]
RequestHeaderIndex -> RequestHeaderIndex
RequestHeaderIndex -> RequestHeaderIndex -> [RequestHeaderIndex]
RequestHeaderIndex
-> RequestHeaderIndex -> RequestHeaderIndex -> [RequestHeaderIndex]
(RequestHeaderIndex -> RequestHeaderIndex)
-> (RequestHeaderIndex -> RequestHeaderIndex)
-> (Int -> RequestHeaderIndex)
-> (RequestHeaderIndex -> Int)
-> (RequestHeaderIndex -> [RequestHeaderIndex])
-> (RequestHeaderIndex
    -> RequestHeaderIndex -> [RequestHeaderIndex])
-> (RequestHeaderIndex
    -> RequestHeaderIndex -> [RequestHeaderIndex])
-> (RequestHeaderIndex
    -> RequestHeaderIndex
    -> RequestHeaderIndex
    -> [RequestHeaderIndex])
-> Enum RequestHeaderIndex
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: RequestHeaderIndex
-> RequestHeaderIndex -> RequestHeaderIndex -> [RequestHeaderIndex]
$cenumFromThenTo :: RequestHeaderIndex
-> RequestHeaderIndex -> RequestHeaderIndex -> [RequestHeaderIndex]
enumFromTo :: RequestHeaderIndex -> RequestHeaderIndex -> [RequestHeaderIndex]
$cenumFromTo :: RequestHeaderIndex -> RequestHeaderIndex -> [RequestHeaderIndex]
enumFromThen :: RequestHeaderIndex -> RequestHeaderIndex -> [RequestHeaderIndex]
$cenumFromThen :: RequestHeaderIndex -> RequestHeaderIndex -> [RequestHeaderIndex]
enumFrom :: RequestHeaderIndex -> [RequestHeaderIndex]
$cenumFrom :: RequestHeaderIndex -> [RequestHeaderIndex]
fromEnum :: RequestHeaderIndex -> Int
$cfromEnum :: RequestHeaderIndex -> Int
toEnum :: Int -> RequestHeaderIndex
$ctoEnum :: Int -> RequestHeaderIndex
pred :: RequestHeaderIndex -> RequestHeaderIndex
$cpred :: RequestHeaderIndex -> RequestHeaderIndex
succ :: RequestHeaderIndex -> RequestHeaderIndex
$csucc :: RequestHeaderIndex -> RequestHeaderIndex
Enum,RequestHeaderIndex
RequestHeaderIndex
-> RequestHeaderIndex -> Bounded RequestHeaderIndex
forall a. a -> a -> Bounded a
maxBound :: RequestHeaderIndex
$cmaxBound :: RequestHeaderIndex
minBound :: RequestHeaderIndex
$cminBound :: RequestHeaderIndex
Bounded)

-- | The size for 'IndexedHeader' for HTTP Request.
--   From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",
--   \"Expect\", \"Connection\", \"Range\", \"Host\",
--   \"If-Modified-Since\", \"If-Unmodified-Since\" and \"If-Range\".
requestMaxIndex :: Int
requestMaxIndex :: Int
requestMaxIndex = RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum (RequestHeaderIndex
forall a. Bounded a => a
maxBound :: RequestHeaderIndex)

requestKeyIndex :: HeaderName -> Int
requestKeyIndex :: HeaderName -> Int
requestKeyIndex hn :: HeaderName
hn = case ByteString -> Int
BS.length ByteString
bs of
   4  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "host" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqHost else -1
   5  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "range" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqRange else -1
   6  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "expect" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqExpect else -1
   7  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "referer" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqReferer else -1
   8  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "if-range" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfRange else -1
   10 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "user-agent" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqUserAgent else
         if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "connection" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqConnection else -1
   14 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "content-length" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqContentLength else -1
   17 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "transfer-encoding" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqTransferEncoding else
         if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "if-modified-since" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfModifiedSince
         else -1
   19 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "if-unmodified-since" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfUnmodifiedSince else -1
   _  -> -1
  where
    bs :: ByteString
bs = HeaderName -> ByteString
forall s. CI s -> s
foldedCase HeaderName
hn

defaultIndexRequestHeader :: IndexedHeader
defaultIndexRequestHeader :: IndexedHeader
defaultIndexRequestHeader = (Int, Int) -> [(Int, Maybe ByteString)] -> IndexedHeader
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (0,Int
requestMaxIndex) [(Int
i,Maybe ByteString
forall a. Maybe a
Nothing)|Int
i<-[0..Int
requestMaxIndex]]

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

indexResponseHeader :: ResponseHeaders -> IndexedHeader
indexResponseHeader :: RequestHeaders -> IndexedHeader
indexResponseHeader hdr :: RequestHeaders
hdr = RequestHeaders -> Int -> (HeaderName -> Int) -> IndexedHeader
traverseHeader RequestHeaders
hdr Int
responseMaxIndex HeaderName -> Int
responseKeyIndex

data ResponseHeaderIndex = ResContentLength
                         | ResServer
                         | ResDate
                         | ResLastModified
                         deriving (Int -> ResponseHeaderIndex
ResponseHeaderIndex -> Int
ResponseHeaderIndex -> [ResponseHeaderIndex]
ResponseHeaderIndex -> ResponseHeaderIndex
ResponseHeaderIndex -> ResponseHeaderIndex -> [ResponseHeaderIndex]
ResponseHeaderIndex
-> ResponseHeaderIndex
-> ResponseHeaderIndex
-> [ResponseHeaderIndex]
(ResponseHeaderIndex -> ResponseHeaderIndex)
-> (ResponseHeaderIndex -> ResponseHeaderIndex)
-> (Int -> ResponseHeaderIndex)
-> (ResponseHeaderIndex -> Int)
-> (ResponseHeaderIndex -> [ResponseHeaderIndex])
-> (ResponseHeaderIndex
    -> ResponseHeaderIndex -> [ResponseHeaderIndex])
-> (ResponseHeaderIndex
    -> ResponseHeaderIndex -> [ResponseHeaderIndex])
-> (ResponseHeaderIndex
    -> ResponseHeaderIndex
    -> ResponseHeaderIndex
    -> [ResponseHeaderIndex])
-> Enum ResponseHeaderIndex
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ResponseHeaderIndex
-> ResponseHeaderIndex
-> ResponseHeaderIndex
-> [ResponseHeaderIndex]
$cenumFromThenTo :: ResponseHeaderIndex
-> ResponseHeaderIndex
-> ResponseHeaderIndex
-> [ResponseHeaderIndex]
enumFromTo :: ResponseHeaderIndex -> ResponseHeaderIndex -> [ResponseHeaderIndex]
$cenumFromTo :: ResponseHeaderIndex -> ResponseHeaderIndex -> [ResponseHeaderIndex]
enumFromThen :: ResponseHeaderIndex -> ResponseHeaderIndex -> [ResponseHeaderIndex]
$cenumFromThen :: ResponseHeaderIndex -> ResponseHeaderIndex -> [ResponseHeaderIndex]
enumFrom :: ResponseHeaderIndex -> [ResponseHeaderIndex]
$cenumFrom :: ResponseHeaderIndex -> [ResponseHeaderIndex]
fromEnum :: ResponseHeaderIndex -> Int
$cfromEnum :: ResponseHeaderIndex -> Int
toEnum :: Int -> ResponseHeaderIndex
$ctoEnum :: Int -> ResponseHeaderIndex
pred :: ResponseHeaderIndex -> ResponseHeaderIndex
$cpred :: ResponseHeaderIndex -> ResponseHeaderIndex
succ :: ResponseHeaderIndex -> ResponseHeaderIndex
$csucc :: ResponseHeaderIndex -> ResponseHeaderIndex
Enum,ResponseHeaderIndex
ResponseHeaderIndex
-> ResponseHeaderIndex -> Bounded ResponseHeaderIndex
forall a. a -> a -> Bounded a
maxBound :: ResponseHeaderIndex
$cmaxBound :: ResponseHeaderIndex
minBound :: ResponseHeaderIndex
$cminBound :: ResponseHeaderIndex
Bounded)

-- | The size for 'IndexedHeader' for HTTP Response.
responseMaxIndex :: Int
responseMaxIndex :: Int
responseMaxIndex = ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum (ResponseHeaderIndex
forall a. Bounded a => a
maxBound :: ResponseHeaderIndex)

responseKeyIndex :: HeaderName -> Int
responseKeyIndex :: HeaderName -> Int
responseKeyIndex hn :: HeaderName
hn = case ByteString -> Int
BS.length ByteString
bs of
    4  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "date" then ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResDate else -1
    6  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "server" then ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResServer else -1
    13 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "last-modified" then ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResLastModified else -1
    14 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "content-length" then ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResContentLength else -1
    _  -> -1
  where
    bs :: ByteString
bs = HeaderName -> ByteString
forall s. CI s -> s
foldedCase HeaderName
hn

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

traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader
traverseHeader :: RequestHeaders -> Int -> (HeaderName -> Int) -> IndexedHeader
traverseHeader hdr :: RequestHeaders
hdr maxidx :: Int
maxidx getIndex :: HeaderName -> Int
getIndex = (forall s. ST s (STArray s Int (Maybe ByteString)))
-> IndexedHeader
forall i e. (forall s. ST s (STArray s i e)) -> Array i e
runSTArray ((forall s. ST s (STArray s Int (Maybe ByteString)))
 -> IndexedHeader)
-> (forall s. ST s (STArray s Int (Maybe ByteString)))
-> IndexedHeader
forall a b. (a -> b) -> a -> b
$ do
    STArray s Int (Maybe ByteString)
arr <- (Int, Int)
-> Maybe ByteString -> ST s (STArray s Int (Maybe ByteString))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (0,Int
maxidx) Maybe ByteString
forall a. Maybe a
Nothing
    ((HeaderName, ByteString) -> ST s ()) -> RequestHeaders -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STArray s Int (Maybe ByteString)
-> (HeaderName, ByteString) -> ST s ()
forall (m :: * -> *) (a :: * -> * -> *) a.
MArray a (Maybe a) m =>
a Int (Maybe a) -> (HeaderName, a) -> m ()
insert STArray s Int (Maybe ByteString)
arr) RequestHeaders
hdr
    STArray s Int (Maybe ByteString)
-> ST s (STArray s Int (Maybe ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return STArray s Int (Maybe ByteString)
arr
  where
    insert :: a Int (Maybe a) -> (HeaderName, a) -> m ()
insert arr :: a Int (Maybe a)
arr (key :: HeaderName
key,val :: a
val)
      | Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -1 = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = a Int (Maybe a) -> Int -> Maybe a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a Int (Maybe a)
arr Int
idx (a -> Maybe a
forall a. a -> Maybe a
Just a
val)
      where
        idx :: Int
idx = HeaderName -> Int
getIndex HeaderName
key