{-# 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 { unH :: [(ByteString, ByteString)] }
  deriving (Show)


------------------------------------------------------------------------------
-- | An empty collection of HTTP header fields.
--
-- Example:
--
-- @
-- ghci> H.'empty'
-- H {unH = []}
-- @
empty :: Headers
empty = 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 = List.null . 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 k0 = f . unH
  where
    k   = CI.foldedCase k0
    f m = List.any ((k ==) . fst) 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 k (H m) = List.lookup (CI.foldedCase k) 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 d k m = fromMaybe d $ lookup k 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 k0 v (H m) = H $! go id m
  where
    k = CI.foldedCase k0

    go dl []                       = dl [(k, v)]
    go dl (z@(x,y):xs) | k == x    = dl ((k, concatHeaderValues v y):xs)
                       | otherwise = go (dl . (z:)) xs

    concatHeaderValues :: ByteString -> ByteString -> ByteString
    concatHeaderValues new old = S.concat [old, ",", 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 k v (H hdrs) = H ((k,v):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 k0 v (H m) = H $ go m
  where
    k = CI.foldedCase k0

    go []                        = [(k,v)]
    go (x@(k',_):xs) | k == k'   = (k,v) : List.filter ((k /=) . fst) xs
                     | otherwise = x : go 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 k (H m) = H $ List.filter ((k' /=) . fst) m
  where
    k' = CI.foldedCase 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' f a (H m) = List.foldl' f' a m
  where
    f' v (x,y) = f v (CI.unsafeMk x) 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' f a (H m) = List.foldl' f' a m
  where
    f' v (x,y) = f v x 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 f a (H m) = List.foldr f' a m
  where
    f' (x, y) v = f (CI.unsafeMk x) y 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 f a (H m) = List.foldr (uncurry f) a 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 = map (first CI.unsafeMk) . 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 = H . map (first CI.foldedCase)


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


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