{-# 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
    -- * Modify
  , cons
  , snoc
    -- * Expose
  , toArray
    -- * Lookup
  , lookup
  , lookupFirst
  , lookupAll
    -- * Specialized Lookup
  , lookupContentType
  , lookupContentLength
  , lookupTransferEncoding
  , lookupHost
  , lookupAccept
  , lookupDate
    -- * Specialized Snoc
  , snocContentLength
    -- * Specialized Absence
  , lacksContentLengthAndTransferEncoding
  ) where

import Prelude hiding (lookup)

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

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

-- | 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,NonEmpty Headers -> Headers
Headers -> Headers -> Headers
forall b. Integral b => b -> Headers -> Headers
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Headers -> Headers
$cstimes :: forall b. Integral b => b -> Headers -> Headers
sconcat :: NonEmpty Headers -> Headers
$csconcat :: NonEmpty Headers -> Headers
<> :: Headers -> Headers -> Headers
$c<> :: Headers -> Headers -> Headers
Semigroup,Semigroup Headers
Headers
[Headers] -> Headers
Headers -> Headers -> Headers
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Headers] -> Headers
$cmconcat :: [Headers] -> Headers
mappend :: Headers -> Headers -> Headers
$cmappend :: Headers -> Headers -> Headers
mempty :: Headers
$cmempty :: Headers
Monoid)

-- | 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

-- | Add a header to the beginning of the headers.
cons :: Header -> Headers -> Headers
cons :: Header -> Headers -> Headers
cons Header
hdr (Headers SmallArray Header
hdrs) = SmallArray Header -> Headers
Headers (forall (arr :: * -> *) b.
(Contiguous arr, Element arr b) =>
arr b -> Int -> b -> arr b
C.insertAt SmallArray Header
hdrs Int
0 Header
hdr)

-- | Add a header to the beginning of the headers.
snoc :: Headers -> Header -> Headers
snoc :: Headers -> Header -> Headers
snoc (Headers SmallArray Header
hdrs) Header
hdr = SmallArray Header -> Headers
Headers (forall (arr :: * -> *) b.
(Contiguous arr, Element arr b) =>
arr b -> Int -> b -> arr b
C.insertAt SmallArray Header
hdrs (forall a. SmallArray a -> Int
PM.sizeofSmallArray SmallArray Header
hdrs) Header
hdr)

-- | 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"

lookupHost :: Headers -> Either LookupException Header
lookupHost :: Headers -> Either LookupException Header
lookupHost = Text -> Headers -> Either LookupException Header
lookup Text
"host"

lookupAccept :: Headers -> Either LookupException Header
lookupAccept :: Headers -> Either LookupException Header
lookupAccept = Text -> Headers -> Either LookupException Header
lookup Text
"accept"

lookupDate :: Headers -> Either LookupException Header
lookupDate :: Headers -> Either LookupException Header
lookupDate = Text -> Headers -> Either LookupException Header
lookup Text
"date"

snocContentLength :: Headers -> Text -> Headers
snocContentLength :: Headers -> Text -> Headers
snocContentLength Headers
hdrs Text
val = Headers -> Header -> Headers
snoc Headers
hdrs (Text -> Text -> Header
Header Text
"Content-Length" Text
val)

-- | Returns @True@ if both the @Content-Length@ and @Transfer-Encoding@
-- headers are missing.
lacksContentLengthAndTransferEncoding :: Headers -> Bool
lacksContentLengthAndTransferEncoding :: Headers -> Bool
lacksContentLengthAndTransferEncoding Headers
hdrs =
  forall a. Maybe a -> Bool
isNothing (Text -> Headers -> Maybe Header
lookupFirst Text
"content-length" Headers
hdrs)
  Bool -> Bool -> Bool
&&
  forall a. Maybe a -> Bool
isNothing (Text -> Headers -> Maybe Header
lookupFirst Text
"transfer-encoding" Headers
hdrs)