{-# language DuplicateRecordFields #-}
{-# language DerivingStrategies #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language OverloadedStrings #-}

-- TODO: Right now, this uses a crummy implementation. Instead, we
-- should hash all the keys and search the hashes first to speed
-- things up.
module Http.Headers
  ( -- * Types
    Headers
  , LookupException(..)
    -- * Construct
  , fromArray
  , fromList
    -- * Expose
  , toArray
    -- * Lookup
  , lookup
  , lookupFirst
  , lookupAll
    -- * Specialized Lookup
  , lookupContentType
  , lookupContentLength
  , lookupTransferEncoding
  ) where

import Prelude hiding (lookup)

import Data.Text (Text)
import Data.Primitive (SmallArray)
import Http.Header (Header(Header))
import Data.Foldable (foldl')

import qualified Data.List as List
import qualified Data.Primitive.Contiguous as C
import qualified Data.Text as T
import qualified Http.Header
import qualified GHC.Exts as Exts

-- | Collection of HTTP headers. Supports case-insensitive lookup.
-- This is intended to be used for small collections of headers.
-- Expect degraded performance if this is used for collections of
-- more than 128 headers.
--
-- This preserves the original order of the headers and the original
-- case of the header names.
newtype Headers = Headers (SmallArray Header)
  deriving newtype (Int -> Headers -> ShowS
[Headers] -> ShowS
Headers -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Headers] -> ShowS
$cshowList :: [Headers] -> ShowS
show :: Headers -> String
$cshow :: Headers -> String
showsPrec :: Int -> Headers -> ShowS
$cshowsPrec :: Int -> Headers -> ShowS
Show)

-- | Many headers cannot appear more than once. This is part of
-- the return type for 'lookup', and it helps us track whether the
-- lookup failure was the result of something that might be expected
-- (the header was @Missing@) or something that is definitely a mistake
-- (the header was duplicated).
data LookupException
  = Duplicate
  | Missing

-- | Convert array of headers to a 'Headers' collection that supports
-- efficient lookup.
fromArray :: SmallArray Header -> Headers
fromArray :: SmallArray Header -> Headers
fromArray = SmallArray Header -> Headers
Headers

-- | Convert list of headers to a 'Headers' collection that supports
-- efficient lookup.
fromList :: [Header] -> Headers
fromList :: [Header] -> Headers
fromList = SmallArray Header -> Headers
Headers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
Exts.fromList

-- | Recover the original headers from from the 'Headers' collection.
-- This is @O(1)@ and is most commonly used to fold over the headers.
toArray :: Headers -> SmallArray Header
toArray :: Headers -> SmallArray Header
toArray (Headers SmallArray Header
xs) = SmallArray Header
xs

-- | Case insensitive lookup of an HTTP header. If the header is present,
-- returns both the original header name (may differs in case from the
-- header name searched for) and the header value. Only returns the first
-- occurrence of the header.
lookupFirst ::
     Text -- header name
  -> Headers
  -> Maybe Header
lookupFirst :: Text -> Headers -> Maybe Header
lookupFirst Text
needle (Headers SmallArray Header
hdrs) =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\Header{Text
name :: Header -> Text
name :: Text
name} -> Text -> Text -> Bool
caseInsensitiveEq Text
needle Text
name) SmallArray Header
hdrs

-- | Lookup a header that should not appear more than one time and verify
-- that it did not occur more than once. If it appears more than once
-- (or less than once), returns a 'LookupException'.
lookup ::
     Text -- header name
  -> Headers
  -> Either LookupException Header
lookup :: Text -> Headers -> Either LookupException Header
lookup Text
needle hdrs :: Headers
hdrs@(Headers SmallArray Header
xs) = case Text -> Headers -> Maybe Header
lookupFirst Text
needle Headers
hdrs of
  Maybe Header
Nothing -> forall a b. a -> Either a b
Left LookupException
Missing
  Just Header
hdr ->
    let count :: Int
count = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
          (\Int
acc Header{Text
name :: Text
name :: Header -> Text
name} -> if Text -> Text -> Bool
caseInsensitiveEq Text
needle Text
name
            then Int
acc forall a. Num a => a -> a -> a
+ Int
1
            else Int
acc
          ) (Int
0 :: Int) SmallArray Header
xs
     in if Int
count forall a. Ord a => a -> a -> Bool
> Int
1 then forall a b. a -> Either a b
Left LookupException
Duplicate else forall a b. b -> Either a b
Right Header
hdr

-- | Lookup a header that may appear more than once. Some headers
-- (e.g. @Set-Cookie@, @X-Forwarded-For@) are allowed to appear multiple
-- times. This returns all the headers that matched along with their
-- original names.
lookupAll ::
     Text -- header name
  -> Headers
  -> SmallArray Header
lookupAll :: Text -> Headers -> SmallArray Header
lookupAll Text
needle (Headers SmallArray Header
hdrs) =
  forall (arr :: * -> *) a.
(Contiguous arr, Element arr a) =>
(a -> Bool) -> arr a -> arr a
C.filter (\Header{Text
name :: Text
name :: Header -> Text
name} -> Text -> Text -> Bool
caseInsensitiveEq Text
needle Text
name) SmallArray Header
hdrs
  
-- TODO: Make this not allocate
caseInsensitiveEq :: Text -> Text -> Bool
caseInsensitiveEq :: Text -> Text -> Bool
caseInsensitiveEq Text
a Text
b = Text -> Text
T.toLower Text
a forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toLower Text
b

lookupTransferEncoding :: Headers -> Either LookupException Header
lookupTransferEncoding :: Headers -> Either LookupException Header
lookupTransferEncoding = Text -> Headers -> Either LookupException Header
lookup Text
"transfer-encoding"

lookupContentType :: Headers -> Either LookupException Header
lookupContentType :: Headers -> Either LookupException Header
lookupContentType = Text -> Headers -> Either LookupException Header
lookup Text
"content-type"

lookupContentLength :: Headers -> Either LookupException Header
lookupContentLength :: Headers -> Either LookupException Header
lookupContentLength = Text -> Headers -> Either LookupException Header
lookup Text
"content-length"