{-# 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
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 = forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null 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 = forall {t :: * -> *} {b}. Foldable t => t (ByteString, b) -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(ByteString, ByteString)]
unH
  where
    k :: ByteString
k   = forall s. CI s -> s
CI.foldedCase CI ByteString
k0
    f :: t (ByteString, b) -> Bool
f t (ByteString, b)
m = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.any ((ByteString
k forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup (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 = forall a. a -> Maybe a -> a
fromMaybe ByteString
d 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 forall a b. (a -> b) -> a -> b
$! forall {c}.
([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go forall a. a -> a
id [(ByteString, ByteString)]
m
  where
    k :: ByteString
k = 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 forall a. Eq a => a -> a -> Bool
== ByteString
x    = [(ByteString, ByteString)] -> c
dl ((ByteString
k, ByteString -> ByteString -> ByteString
concatHeaderValues ByteString
v ByteString
y)forall a. a -> [a] -> [a]
:[(ByteString, ByteString)]
xs)
                       | Bool
otherwise = ([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go ([(ByteString, ByteString)] -> c
dl forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString)
zforall 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)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 forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> [(ByteString, ByteString)]
go [(ByteString, ByteString)]
m
  where
    k :: ByteString
k = 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 forall a. Eq a => a -> a -> Bool
== ByteString
k'   = (ByteString
k,ByteString
v) forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
List.filter ((ByteString
k forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
xs
                     | Bool
otherwise = (ByteString, ByteString)
x 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 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
List.filter ((ByteString
k' forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
m
  where
    k' :: ByteString
k' = 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' :: forall a.
(a -> CI ByteString -> ByteString -> a) -> a -> Headers -> a
foldl' a -> CI ByteString -> ByteString -> a
f a
a (H [(ByteString, ByteString)]
m) = 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 (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' :: forall a. (a -> ByteString -> ByteString -> a) -> a -> Headers -> a
foldedFoldl' a -> ByteString -> ByteString -> a
f a
a (H [(ByteString, ByteString)]
m) = 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 :: forall a.
(CI ByteString -> ByteString -> a -> a) -> a -> Headers -> a
foldr CI ByteString -> ByteString -> a -> a
f a
a (H [(ByteString, ByteString)]
m) = 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 (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 :: forall a. (ByteString -> ByteString -> a -> a) -> a -> Headers -> a
foldedFoldr ByteString -> ByteString -> a -> a
f a
a (H [(ByteString, ByteString)]
m) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr (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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall s. FoldCase s => s -> CI s
CI.unsafeMk) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first 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