{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# 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
  , lookupLocation
  , 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 Data.List qualified as List
import Data.Primitive qualified as PM
import Data.Primitive.Contiguous qualified as C
import Data.Text qualified as T
import GHC.Exts qualified as Exts
import Http.Header qualified

{- | 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 (Headers -> Headers -> Bool
(Headers -> Headers -> Bool)
-> (Headers -> Headers -> Bool) -> Eq Headers
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Headers -> Headers -> Bool
== :: Headers -> Headers -> Bool
$c/= :: Headers -> Headers -> Bool
/= :: Headers -> Headers -> Bool
Eq, Int -> Headers -> ShowS
[Headers] -> ShowS
Headers -> String
(Int -> Headers -> ShowS)
-> (Headers -> String) -> ([Headers] -> ShowS) -> Show Headers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Headers -> ShowS
showsPrec :: Int -> Headers -> ShowS
$cshow :: Headers -> String
show :: Headers -> String
$cshowList :: [Headers] -> ShowS
showList :: [Headers] -> ShowS
Show, NonEmpty Headers -> Headers
Headers -> Headers -> Headers
(Headers -> Headers -> Headers)
-> (NonEmpty Headers -> Headers)
-> (forall b. Integral b => b -> Headers -> Headers)
-> Semigroup 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
$c<> :: Headers -> Headers -> Headers
<> :: Headers -> Headers -> Headers
$csconcat :: NonEmpty Headers -> Headers
sconcat :: NonEmpty Headers -> Headers
$cstimes :: forall b. Integral b => b -> Headers -> Headers
stimes :: forall b. Integral b => b -> Headers -> Headers
Semigroup, Semigroup Headers
Headers
Semigroup Headers =>
Headers
-> (Headers -> Headers -> Headers)
-> ([Headers] -> Headers)
-> Monoid Headers
[Headers] -> Headers
Headers -> Headers -> Headers
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Headers
mempty :: Headers
$cmappend :: Headers -> Headers -> Headers
mappend :: Headers -> Headers -> Headers
$cmconcat :: [Headers] -> Headers
mconcat :: [Headers] -> 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
  deriving (LookupException -> LookupException -> Bool
(LookupException -> LookupException -> Bool)
-> (LookupException -> LookupException -> Bool)
-> Eq LookupException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LookupException -> LookupException -> Bool
== :: LookupException -> LookupException -> Bool
$c/= :: LookupException -> LookupException -> Bool
/= :: LookupException -> LookupException -> Bool
Eq, Int -> LookupException -> ShowS
[LookupException] -> ShowS
LookupException -> String
(Int -> LookupException -> ShowS)
-> (LookupException -> String)
-> ([LookupException] -> ShowS)
-> Show LookupException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LookupException -> ShowS
showsPrec :: Int -> LookupException -> ShowS
$cshow :: LookupException -> String
show :: LookupException -> String
$cshowList :: [LookupException] -> ShowS
showList :: [LookupException] -> ShowS
Show)

{- | 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 (SmallArray Header -> Int -> Header -> SmallArray Header
forall b.
Element SmallArray b =>
SmallArray b -> Int -> b -> SmallArray b
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 (SmallArray Header -> Int -> Header -> SmallArray Header
forall b.
Element SmallArray b =>
SmallArray b -> Int -> b -> SmallArray b
forall (arr :: * -> *) b.
(Contiguous arr, Element arr b) =>
arr b -> Int -> b -> arr b
C.insertAt SmallArray Header
hdrs (SmallArray Header -> Int
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 (SmallArray Header -> Headers)
-> ([Header] -> SmallArray Header) -> [Header] -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item (SmallArray Header)] -> SmallArray Header
[Header] -> SmallArray Header
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) =
  (Header -> Bool) -> SmallArray Header -> Maybe Header
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\Header {Text
name :: Text
name :: Header -> 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 -> LookupException -> Either LookupException Header
forall a b. a -> Either a b
Left LookupException
Missing
  Just Header
hdr ->
    let count :: Int
count =
          (Int -> Header -> Int) -> Int -> SmallArray Header -> Int
forall b a. (b -> a -> b) -> b -> SmallArray a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            ( \Int
acc Header {Text
name :: Header -> Text
name :: Text
name} ->
                if Text -> Text -> Bool
caseInsensitiveEq Text
needle Text
name
                  then Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                  else Int
acc
            )
            (Int
0 :: Int)
            SmallArray Header
xs
     in if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then LookupException -> Either LookupException Header
forall a b. a -> Either a b
Left LookupException
Duplicate else Header -> Either LookupException Header
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) =
  (Header -> Bool) -> SmallArray Header -> SmallArray Header
forall (arr :: * -> *) a.
(Contiguous arr, Element arr a) =>
(a -> Bool) -> arr a -> arr a
C.filter (\Header {Text
name :: Header -> Text
name :: 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 Text -> Text -> Bool
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"

lookupLocation :: Headers -> Either LookupException Header
lookupLocation :: Headers -> Either LookupException Header
lookupLocation = Text -> Headers -> Either LookupException Header
lookup Text
"location"

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 =
  Maybe Header -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Headers -> Maybe Header
lookupFirst Text
"content-length" Headers
hdrs)
    Bool -> Bool -> Bool
&& Maybe Header -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Headers -> Maybe Header
lookupFirst Text
"transfer-encoding" Headers
hdrs)