{-# LANGUAGE OverloadedStrings #-}

-- | An opaque data type for HTTP headers. Intended to be imported qualified,
-- i.e:
--
-- > import           Snap.Types.Headers (Headers)
-- > import qualified Snap.Types.Headers as H
-- >
-- > foo :: Headers
-- > foo = H.empty

module Snap.Types.Headers
  ( -- * Headers type
    Headers

    -- * Headers creation
  , empty

    -- * Predicates
  , null
  , member

    -- * Lookup
  , lookup
  , lookupWithDefault

    -- * Adding/setting headers
  , insert
  , unsafeInsert
  , set

    -- * Deleting
  , delete

    -- * Traversal
  , foldl'
  , foldr
  , foldedFoldl'
  , foldedFoldr

    -- * Lists
  , toList
  , fromList

  , unsafeFromCaseFoldedList
  , unsafeToCaseFoldedList

  ) where

------------------------------------------------------------------------------
import           Control.Arrow               (first)
import           Data.ByteString.Char8       (ByteString)
import qualified Data.ByteString.Char8       as S
import           Data.CaseInsensitive        (CI)
import qualified Data.CaseInsensitive        as CI
import qualified Data.CaseInsensitive.Unsafe as CI
import qualified Data.List                   as List
import           Data.Maybe                  (fromMaybe)
import           Prelude                     (Bool (..), Eq (..), Maybe (..), Show (..), fst, id, map, otherwise, uncurry, ($), ($!), (.))
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- | A key-value map that represents a collection of HTTP header fields. Keys
-- are case-insensitive.
newtype Headers = H { Headers -> [(ByteString, ByteString)]
unH :: [(ByteString, ByteString)] }
  deriving (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
showList :: [Headers] -> ShowS
$cshowList :: [Headers] -> ShowS
show :: Headers -> String
$cshow :: Headers -> String
showsPrec :: Int -> Headers -> ShowS
$cshowsPrec :: Int -> Headers -> ShowS
Show)


------------------------------------------------------------------------------
-- | An empty collection of HTTP header fields.
--
-- Example:
--
-- @
-- ghci> H.'empty'
-- H {unH = []}
-- @
empty :: Headers
empty :: Headers
empty = [(ByteString, ByteString)] -> Headers
H []


------------------------------------------------------------------------------
-- | Is a given collection of HTTP header fields empty?
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> H.'null' H.'empty'
-- True
-- ghci> H.'null' $ H.'fromList' [(\"Host\", \"localhost\")]
-- False
-- @
null :: Headers -> Bool
null :: Headers -> Bool
null = [(ByteString, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null ([(ByteString, ByteString)] -> Bool)
-> (Headers -> [(ByteString, ByteString)]) -> Headers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(ByteString, ByteString)]
unH
{-# INLINE null #-}


------------------------------------------------------------------------------
-- | Does this collection of HTTP header fields contain a given field?
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> H.'member' \"host\" $ H.'fromList' [(\"Host\", \"localhost\")]
-- True
-- ghci> H.'member' \"Accept\" $ H.'fromList' [(\"Host\", \"localhost\")]
-- False
-- @
member :: CI ByteString -> Headers -> Bool
member :: CI ByteString -> Headers -> Bool
member CI ByteString
k0 = [(ByteString, ByteString)] -> Bool
forall (t :: * -> *) b. Foldable t => t (ByteString, b) -> Bool
f ([(ByteString, ByteString)] -> Bool)
-> (Headers -> [(ByteString, ByteString)]) -> Headers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(ByteString, ByteString)]
unH
  where
    k :: ByteString
k   = CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase CI ByteString
k0
    f :: t (ByteString, b) -> Bool
f t (ByteString, b)
m = ((ByteString, b) -> Bool) -> t (ByteString, b) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.any ((ByteString
k ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> Bool)
-> ((ByteString, b) -> ByteString) -> (ByteString, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, b) -> ByteString
forall a b. (a, b) -> a
fst) t (ByteString, b)
m
{-# INLINE member #-}


------------------------------------------------------------------------------
-- | Look up the value of a given HTTP header field.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> H.'lookup' \"host\" $ H.'fromList' [(\"Host\", \"localhost\")]
-- Just \"localhost\"
-- ghci> H.'lookup' \"Accept\" $ H.'fromList' [(\"Host\", \"localhost\")]
-- Nothing
-- @
lookup :: CI ByteString -> Headers -> Maybe ByteString
lookup :: CI ByteString -> Headers -> Maybe ByteString
lookup CI ByteString
k (H [(ByteString, ByteString)]
m) = ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup (CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase CI ByteString
k) [(ByteString, ByteString)]
m
{-# INLINE lookup #-}


------------------------------------------------------------------------------
-- | Look up the value of a given HTTP header field or return the provided
-- default value when that header field is not present.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> let hdrs = H.'fromList' [(\"Host\", \"localhost\")]
-- ghci> H.'lookupWithDefault' \"host\" \"127.0.0.1\" $ hdrs
-- \"localhost\"
-- ghci> H.'lookupWithDefault' \"Accept\" \"text\/plain\" $ hdrs
-- \"text\/plain\"
-- @
lookupWithDefault :: ByteString -> CI ByteString -> Headers -> ByteString
lookupWithDefault :: ByteString -> CI ByteString -> Headers -> ByteString
lookupWithDefault ByteString
d CI ByteString
k Headers
m = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
d (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Headers -> Maybe ByteString
lookup CI ByteString
k Headers
m


------------------------------------------------------------------------------
-- | Insert a key-value pair into the headers map. If the key already exists in
-- the map, the values are catenated with ", ".
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> let hdrs = H.'insert' \"Accept\" \"text\/plain\" $ H.'empty'
-- ghci> hdrs
-- H {unH = [(\"accept\",\"text\/plain\")]}
-- ghci> H.'insert' \"Accept\" \"text\/html\" $ hdrs
-- H {unH = [(\"accept\",\"text\/plain,text\/html\")]}
-- @
insert :: CI ByteString -> ByteString -> Headers -> Headers
insert :: CI ByteString -> ByteString -> Headers -> Headers
insert CI ByteString
k0 ByteString
v (H [(ByteString, ByteString)]
m) = [(ByteString, ByteString)] -> Headers
H ([(ByteString, ByteString)] -> Headers)
-> [(ByteString, ByteString)] -> Headers
forall a b. (a -> b) -> a -> b
$! ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall c.
([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> a
id [(ByteString, ByteString)]
m
  where
    k :: ByteString
k = CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase CI ByteString
k0

    go :: ([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go [(ByteString, ByteString)] -> c
dl []                       = [(ByteString, ByteString)] -> c
dl [(ByteString
k, ByteString
v)]
    go [(ByteString, ByteString)] -> c
dl (z :: (ByteString, ByteString)
z@(ByteString
x,ByteString
y):[(ByteString, ByteString)]
xs) | ByteString
k ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
x    = [(ByteString, ByteString)] -> c
dl ((ByteString
k, ByteString -> ByteString -> ByteString
concatHeaderValues ByteString
v ByteString
y)(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:[(ByteString, ByteString)]
xs)
                       | Bool
otherwise = ([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go ([(ByteString, ByteString)] -> c
dl ([(ByteString, ByteString)] -> c)
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString)
z(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:)) [(ByteString, ByteString)]
xs

    concatHeaderValues :: ByteString -> ByteString -> ByteString
    concatHeaderValues :: ByteString -> ByteString -> ByteString
concatHeaderValues ByteString
new ByteString
old = [ByteString] -> ByteString
S.concat [ByteString
old, ByteString
",", ByteString
new]


------------------------------------------------------------------------------
-- | Insert a key-value pair into the headers map, without checking whether the
-- header already exists. The key /must/ be already case-folded, or none of the
-- lookups will work!
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> let hdrs = H.'unsafeInsert' \"accept\" \"text\/plain\" $ H.'empty'
-- ghci> hdrs
-- H {unH = [(\"accept\",\"text\/plain\")]}
-- ghci> let hdrs' = H.'unsafeInsert' \"accept\" \"text\/html\" $ hdrs
-- ghci> hdrs'
-- H {unH = [(\"accept\",\"text\/html\"), (\"accept\",\"text\/plain\")]}
-- ghci> H.'lookup' \"accept\" hdrs'
-- Just \"text\/html\"
-- @
unsafeInsert :: ByteString -> ByteString -> Headers -> Headers
unsafeInsert :: ByteString -> ByteString -> Headers -> Headers
unsafeInsert ByteString
k ByteString
v (H [(ByteString, ByteString)]
hdrs) = [(ByteString, ByteString)] -> Headers
H ((ByteString
k,ByteString
v)(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:[(ByteString, ByteString)]
hdrs)


------------------------------------------------------------------------------
-- | Set the value of a HTTP header field to a given value, replacing the old
-- value.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> H.'set' \"accept\" \"text\/plain\" $ H.'empty'
-- H {unH = [(\"accept\",\"text\/plain\")]}
-- ghci> H.'set' \"accept\" \"text\/html\" $ H.'fromList' [(\"Accept\", \"text\/plain\")]
-- H {unH = [(\"accept\",\"text\/html\")]}
-- @
set :: CI ByteString -> ByteString -> Headers -> Headers
set :: CI ByteString -> ByteString -> Headers -> Headers
set CI ByteString
k0 ByteString
v (H [(ByteString, ByteString)]
m) = [(ByteString, ByteString)] -> Headers
H ([(ByteString, ByteString)] -> Headers)
-> [(ByteString, ByteString)] -> Headers
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> [(ByteString, ByteString)]
go [(ByteString, ByteString)]
m
  where
    k :: ByteString
k = CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase CI ByteString
k0

    go :: [(ByteString, ByteString)] -> [(ByteString, ByteString)]
go []                        = [(ByteString
k,ByteString
v)]
    go (x :: (ByteString, ByteString)
x@(ByteString
k',ByteString
_):[(ByteString, ByteString)]
xs) | ByteString
k ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
k'   = (ByteString
k,ByteString
v) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
List.filter ((ByteString
k ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/=) (ByteString -> Bool)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
xs
                     | Bool
otherwise = (ByteString, ByteString)
x (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString, ByteString)] -> [(ByteString, ByteString)]
go [(ByteString, ByteString)]
xs


------------------------------------------------------------------------------
-- | Delete all key-value pairs associated with the given key from the headers
-- map.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> H.'delete' \"accept\" $ H.'fromList' [(\"Accept\", \"text\/plain\")]
-- H {unH = []}
-- @
delete :: CI ByteString -> Headers -> Headers
delete :: CI ByteString -> Headers -> Headers
delete CI ByteString
k (H [(ByteString, ByteString)]
m) = [(ByteString, ByteString)] -> Headers
H ([(ByteString, ByteString)] -> Headers)
-> [(ByteString, ByteString)] -> Headers
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
List.filter ((ByteString
k' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/=) (ByteString -> Bool)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
m
  where
    k' :: ByteString
k' = CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase CI ByteString
k


------------------------------------------------------------------------------
-- | Strict left fold over all key-value pairs in the headers map.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import "Data.Monoid"
-- ghci> let hdrs = H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]
-- ghci> let f (cntr, acc) _ val = (cntr+1, val <> \";\" <> acc)
-- ghci> H.'foldl'' f (0, \"\") hdrs
-- (2,\"text\/html;text\/plain;\")
-- @
foldl' :: (a -> CI ByteString -> ByteString -> a)
       -> a
       -> Headers
       -> a
foldl' :: (a -> CI ByteString -> ByteString -> a) -> a -> Headers -> a
foldl' a -> CI ByteString -> ByteString -> a
f a
a (H [(ByteString, ByteString)]
m) = (a -> (ByteString, ByteString) -> a)
-> a -> [(ByteString, ByteString)] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' a -> (ByteString, ByteString) -> a
f' a
a [(ByteString, ByteString)]
m
  where
    f' :: a -> (ByteString, ByteString) -> a
f' a
v (ByteString
x,ByteString
y) = a -> CI ByteString -> ByteString -> a
f a
v (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.unsafeMk ByteString
x) ByteString
y


------------------------------------------------------------------------------
-- | Same as 'foldl'', but the key parameter is of type 'ByteString' instead of
-- 'CI' 'ByteString'. The key is case-folded (lowercase).
foldedFoldl' :: (a -> ByteString -> ByteString -> a)
             -> a
             -> Headers
             -> a
foldedFoldl' :: (a -> ByteString -> ByteString -> a) -> a -> Headers -> a
foldedFoldl' a -> ByteString -> ByteString -> a
f a
a (H [(ByteString, ByteString)]
m) = (a -> (ByteString, ByteString) -> a)
-> a -> [(ByteString, ByteString)] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' a -> (ByteString, ByteString) -> a
f' a
a [(ByteString, ByteString)]
m
  where
    f' :: a -> (ByteString, ByteString) -> a
f' a
v (ByteString
x,ByteString
y) = a -> ByteString -> ByteString -> a
f a
v ByteString
x ByteString
y


------------------------------------------------------------------------------
-- | Right fold over all key-value pairs in the headers map.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import "Data.Monoid"
-- ghci> let hdrs = H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]
-- ghci> let f _ val (cntr, acc) = (cntr+1, val <> \";\" <> acc)
-- ghci> H.'foldr' f (0, \"\") hdrs
-- (2,\"text\/plain;text\/html;\")
-- @
foldr :: (CI ByteString -> ByteString -> a -> a)
      -> a
      -> Headers
      -> a
foldr :: (CI ByteString -> ByteString -> a -> a) -> a -> Headers -> a
foldr CI ByteString -> ByteString -> a -> a
f a
a (H [(ByteString, ByteString)]
m) = ((ByteString, ByteString) -> a -> a)
-> a -> [(ByteString, ByteString)] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr (ByteString, ByteString) -> a -> a
f' a
a [(ByteString, ByteString)]
m
  where
    f' :: (ByteString, ByteString) -> a -> a
f' (ByteString
x, ByteString
y) a
v = CI ByteString -> ByteString -> a -> a
f (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.unsafeMk ByteString
x) ByteString
y a
v


------------------------------------------------------------------------------
-- | Same as 'foldr', but the key parameter is of type 'ByteString' instead of
-- 'CI' 'ByteString'. The key is case-folded (lowercase).
foldedFoldr :: (ByteString -> ByteString -> a -> a)
            -> a
            -> Headers
            -> a
foldedFoldr :: (ByteString -> ByteString -> a -> a) -> a -> Headers -> a
foldedFoldr ByteString -> ByteString -> a -> a
f a
a (H [(ByteString, ByteString)]
m) = ((ByteString, ByteString) -> a -> a)
-> a -> [(ByteString, ByteString)] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr ((ByteString -> ByteString -> a -> a)
-> (ByteString, ByteString) -> a -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> a -> a
f) a
a [(ByteString, ByteString)]
m


------------------------------------------------------------------------------
-- | Convert a 'Headers' value to a list of key-value pairs.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> let l = [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]
-- ghci> H.'toList' . H.'fromList' $ l
-- [(\"accept\",\"text\/plain\"),(\"accept\",\"text\/html\")]
-- @
toList :: Headers -> [(CI ByteString, ByteString)]
toList :: Headers -> [(CI ByteString, ByteString)]
toList = ((ByteString, ByteString) -> (CI ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> CI ByteString)
-> (ByteString, ByteString) -> (CI ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.unsafeMk) ([(ByteString, ByteString)] -> [(CI ByteString, ByteString)])
-> (Headers -> [(ByteString, ByteString)])
-> Headers
-> [(CI ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(ByteString, ByteString)]
unH


------------------------------------------------------------------------------
-- | Build a 'Headers' value from a list of key-value pairs.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]
-- H {unH = [(\"accept\",\"text\/plain\"),(\"accept\",\"text\/html\")]}
-- @
fromList :: [(CI ByteString, ByteString)] -> Headers
fromList :: [(CI ByteString, ByteString)] -> Headers
fromList = [(ByteString, ByteString)] -> Headers
H ([(ByteString, ByteString)] -> Headers)
-> ([(CI ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(CI ByteString, ByteString)]
-> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI ByteString, ByteString) -> (ByteString, ByteString))
-> [(CI ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((CI ByteString -> ByteString)
-> (CI ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase)


------------------------------------------------------------------------------
-- | Like 'fromList', but the keys are assumed to be already case-folded (in
-- lowercase).
unsafeFromCaseFoldedList :: [(ByteString, ByteString)] -> Headers
unsafeFromCaseFoldedList :: [(ByteString, ByteString)] -> Headers
unsafeFromCaseFoldedList = [(ByteString, ByteString)] -> Headers
H


------------------------------------------------------------------------------
-- | Like 'toList', but does not convert the keys to 'CI' 'ByteString', so key
-- comparisons will be case-sensitive.
unsafeToCaseFoldedList :: Headers -> [(ByteString, ByteString)]
unsafeToCaseFoldedList :: Headers -> [(ByteString, ByteString)]
unsafeToCaseFoldedList = Headers -> [(ByteString, ByteString)]
unH