{-# 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 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 HeaderName
hn = case ByteString -> Int
BS.length ByteString
bs of
   Int
4  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"host" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqHost else -Int
1
   Int
5  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"range" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqRange else -Int
1
   Int
6  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"expect" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqExpect else -Int
1
   Int
7  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"referer" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqReferer else -Int
1
   Int
8  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"if-range" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfRange else -Int
1
   Int
10 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"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
== ByteString
"connection" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqConnection else -Int
1
   Int
14 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"content-length" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqContentLength else -Int
1
   Int
17 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"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
== ByteString
"if-modified-since" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfModifiedSince
         else -Int
1
   Int
19 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"if-unmodified-since" then RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfUnmodifiedSince else -Int
1
   Int
_  -> -Int
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 (Int
0,Int
requestMaxIndex) [(Int
i,Maybe ByteString
forall a. Maybe a
Nothing)|Int
i<-[Int
0..Int
requestMaxIndex]]

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

indexResponseHeader :: ResponseHeaders -> IndexedHeader
indexResponseHeader :: RequestHeaders -> IndexedHeader
indexResponseHeader 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 HeaderName
hn = case ByteString -> Int
BS.length ByteString
bs of
    Int
4  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"date" then ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResDate else -Int
1
    Int
6  -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"server" then ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResServer else -Int
1
    Int
13 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"last-modified" then ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResLastModified else -Int
1
    Int
14 -> if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"content-length" then ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResContentLength else -Int
1
    Int
_  -> -Int
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 RequestHeaders
hdr Int
maxidx 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 (Int
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 a Int (Maybe a)
arr (HeaderName
key,a
val)
      | Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
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