1 {-# LANGUAGE OverloadedStrings #-}
    2 
    3 -- | An opaque data type for HTTP headers. Intended to be imported qualified,
    4 -- i.e:
    5 --
    6 -- > import           Snap.Types.Headers (Headers)
    7 -- > import qualified Snap.Types.Headers as H
    8 -- >
    9 -- > foo :: Headers
   10 -- > foo = H.empty
   11 
   12 module Snap.Types.Headers
   13   ( -- * Headers type
   14     Headers
   15 
   16     -- * Headers creation
   17   , empty
   18 
   19     -- * Predicates
   20   , null
   21   , member
   22 
   23     -- * Lookup
   24   , lookup
   25   , lookupWithDefault
   26 
   27     -- * Adding/setting headers
   28   , insert
   29   , unsafeInsert
   30   , set
   31 
   32     -- * Deleting
   33   , delete
   34 
   35     -- * Traversal
   36   , foldl'
   37   , foldr
   38   , foldedFoldl'
   39   , foldedFoldr
   40 
   41     -- * Lists
   42   , toList
   43   , fromList
   44 
   45   , unsafeFromCaseFoldedList
   46   , unsafeToCaseFoldedList
   47 
   48   ) where
   49 
   50 ------------------------------------------------------------------------------
   51 import           Control.Arrow               (first)
   52 import           Data.ByteString.Char8       (ByteString)
   53 import qualified Data.ByteString.Char8       as S
   54 import           Data.CaseInsensitive        (CI)
   55 import qualified Data.CaseInsensitive        as CI
   56 import qualified Data.CaseInsensitive.Unsafe as CI
   57 import qualified Data.List                   as List
   58 import           Data.Maybe                  (fromMaybe)
   59 import           Prelude                     (Bool (..), Eq (..), Maybe (..), Show (..), fst, id, map, otherwise, uncurry, ($), ($!), (.))
   60 ------------------------------------------------------------------------------
   61 
   62 ------------------------------------------------------------------------------
   63 -- | A key-value map that represents a collection of HTTP header fields. Keys
   64 -- are case-insensitive.
   65 newtype Headers = H { unH :: [(ByteString, ByteString)] }
   66   deriving (Show)
   67 
   68 
   69 ------------------------------------------------------------------------------
   70 -- | An empty collection of HTTP header fields.
   71 --
   72 -- Example:
   73 --
   74 -- @
   75 -- ghci> H.'empty'
   76 -- H {unH = []}
   77 -- @
   78 empty :: Headers
   79 empty = H []
   80 
   81 
   82 ------------------------------------------------------------------------------
   83 -- | Is a given collection of HTTP header fields empty?
   84 --
   85 -- Example:
   86 --
   87 -- @
   88 -- ghci> :set -XOverloadedStrings
   89 -- ghci> H.'null' H.'empty'
   90 -- True
   91 -- ghci> H.'null' $ H.'fromList' [(\"Host\", \"localhost\")]
   92 -- False
   93 -- @
   94 null :: Headers -> Bool
   95 null = List.null . unH
   96 {-# INLINE null #-}
   97 
   98 
   99 ------------------------------------------------------------------------------
  100 -- | Does this collection of HTTP header fields contain a given field?
  101 --
  102 -- Example:
  103 --
  104 -- @
  105 -- ghci> :set -XOverloadedStrings
  106 -- ghci> H.'member' \"host\" $ H.'fromList' [(\"Host\", \"localhost\")]
  107 -- True
  108 -- ghci> H.'member' \"Accept\" $ H.'fromList' [(\"Host\", \"localhost\")]
  109 -- False
  110 -- @
  111 member :: CI ByteString -> Headers -> Bool
  112 member k0 = f . unH
  113   where
  114     k   = CI.foldedCase k0
  115     f m = List.any ((k ==) . fst) m
  116 {-# INLINE member #-}
  117 
  118 
  119 ------------------------------------------------------------------------------
  120 -- | Look up the value of a given HTTP header field.
  121 --
  122 -- Example:
  123 --
  124 -- @
  125 -- ghci> :set -XOverloadedStrings
  126 -- ghci> H.'lookup' \"host\" $ H.'fromList' [(\"Host\", \"localhost\")]
  127 -- Just \"localhost\"
  128 -- ghci> H.'lookup' \"Accept\" $ H.'fromList' [(\"Host\", \"localhost\")]
  129 -- Nothing
  130 -- @
  131 lookup :: CI ByteString -> Headers -> Maybe ByteString
  132 lookup k (H m) = List.lookup (CI.foldedCase k) m
  133 {-# INLINE lookup #-}
  134 
  135 
  136 ------------------------------------------------------------------------------
  137 -- | Look up the value of a given HTTP header field or return the provided
  138 -- default value when that header field is not present.
  139 --
  140 -- Example:
  141 --
  142 -- @
  143 -- ghci> :set -XOverloadedStrings
  144 -- ghci> let hdrs = H.'fromList' [(\"Host\", \"localhost\")]
  145 -- ghci> H.'lookupWithDefault' \"host\" \"127.0.0.1\" $ hdrs
  146 -- \"localhost\"
  147 -- ghci> H.'lookupWithDefault' \"Accept\" \"text\/plain\" $ hdrs
  148 -- \"text\/plain\"
  149 -- @
  150 lookupWithDefault :: ByteString -> CI ByteString -> Headers -> ByteString
  151 lookupWithDefault d k m = fromMaybe d $ lookup k m
  152 
  153 
  154 ------------------------------------------------------------------------------
  155 -- | Insert a key-value pair into the headers map. If the key already exists in
  156 -- the map, the values are catenated with ", ".
  157 --
  158 -- Example:
  159 --
  160 -- @
  161 -- ghci> :set -XOverloadedStrings
  162 -- ghci> let hdrs = H.'insert' \"Accept\" \"text\/plain\" $ H.'empty'
  163 -- ghci> hdrs
  164 -- H {unH = [(\"accept\",\"text\/plain\")]}
  165 -- ghci> H.'insert' \"Accept\" \"text\/html\" $ hdrs
  166 -- H {unH = [(\"accept\",\"text\/plain,text\/html\")]}
  167 -- @
  168 insert :: CI ByteString -> ByteString -> Headers -> Headers
  169 insert k0 v (H m) = H $! go id m
  170   where
  171     k = CI.foldedCase k0
  172 
  173     go dl []                       = dl [(k, v)]
  174     go dl (z@(x,y):xs) | k == x    = dl ((k, concatHeaderValues v y):xs)
  175                        | otherwise = go (dl . (z:)) xs
  176 
  177     concatHeaderValues :: ByteString -> ByteString -> ByteString
  178     concatHeaderValues new old = S.concat [old, ",", new]
  179 
  180 
  181 ------------------------------------------------------------------------------
  182 -- | Insert a key-value pair into the headers map, without checking whether the
  183 -- header already exists. The key /must/ be already case-folded, or none of the
  184 -- lookups will work!
  185 --
  186 -- Example:
  187 --
  188 -- @
  189 -- ghci> :set -XOverloadedStrings
  190 -- ghci> let hdrs = H.'unsafeInsert' \"accept\" \"text\/plain\" $ H.'empty'
  191 -- ghci> hdrs
  192 -- H {unH = [(\"accept\",\"text\/plain\")]}
  193 -- ghci> let hdrs' = H.'unsafeInsert' \"accept\" \"text\/html\" $ hdrs
  194 -- ghci> hdrs'
  195 -- H {unH = [(\"accept\",\"text\/html\"), (\"accept\",\"text\/plain\")]}
  196 -- ghci> H.'lookup' \"accept\" hdrs'
  197 -- Just \"text\/html\"
  198 -- @
  199 unsafeInsert :: ByteString -> ByteString -> Headers -> Headers
  200 unsafeInsert k v (H hdrs) = H ((k,v):hdrs)
  201 
  202 
  203 ------------------------------------------------------------------------------
  204 -- | Set the value of a HTTP header field to a given value, replacing the old
  205 -- value.
  206 --
  207 -- Example:
  208 --
  209 -- @
  210 -- ghci> :set -XOverloadedStrings
  211 -- ghci> H.'set' \"accept\" \"text\/plain\" $ H.'empty'
  212 -- H {unH = [(\"accept\",\"text\/plain\")]}
  213 -- ghci> H.'set' \"accept\" \"text\/html\" $ H.'fromList' [(\"Accept\", \"text\/plain\")]
  214 -- H {unH = [(\"accept\",\"text\/html\")]}
  215 -- @
  216 set :: CI ByteString -> ByteString -> Headers -> Headers
  217 set k0 v (H m) = H $ go m
  218   where
  219     k = CI.foldedCase k0
  220 
  221     go []                        = [(k,v)]
  222     go (x@(k',_):xs) | k == k'   = (k,v) : List.filter ((k /=) . fst) xs
  223                      | otherwise = x : go xs
  224 
  225 
  226 ------------------------------------------------------------------------------
  227 -- | Delete all key-value pairs associated with the given key from the headers
  228 -- map.
  229 --
  230 -- Example:
  231 --
  232 -- @
  233 -- ghci> :set -XOverloadedStrings
  234 -- ghci> H.'delete' \"accept\" $ H.'fromList' [(\"Accept\", \"text\/plain\")]
  235 -- H {unH = []}
  236 -- @
  237 delete :: CI ByteString -> Headers -> Headers
  238 delete k (H m) = H $ List.filter ((k' /=) . fst) m
  239   where
  240     k' = CI.foldedCase k
  241 
  242 
  243 ------------------------------------------------------------------------------
  244 -- | Strict left fold over all key-value pairs in the headers map.
  245 --
  246 -- Example:
  247 --
  248 -- @
  249 -- ghci> :set -XOverloadedStrings
  250 -- ghci> import "Data.Monoid"
  251 -- ghci> let hdrs = H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]
  252 -- ghci> let f (cntr, acc) _ val = (cntr+1, val <> \";\" <> acc)
  253 -- ghci> H.'foldl'' f (0, \"\") hdrs
  254 -- (2,\"text\/html;text\/plain;\")
  255 -- @
  256 foldl' :: (a -> CI ByteString -> ByteString -> a)
  257        -> a
  258        -> Headers
  259        -> a
  260 foldl' f a (H m) = List.foldl' f' a m
  261   where
  262     f' v (x,y) = f v (CI.unsafeMk x) y
  263 
  264 
  265 ------------------------------------------------------------------------------
  266 -- | Same as 'foldl'', but the key parameter is of type 'ByteString' instead of
  267 -- 'CI' 'ByteString'. The key is case-folded (lowercase).
  268 foldedFoldl' :: (a -> ByteString -> ByteString -> a)
  269              -> a
  270              -> Headers
  271              -> a
  272 foldedFoldl' f a (H m) = List.foldl' f' a m
  273   where
  274     f' v (x,y) = f v x y
  275 
  276 
  277 ------------------------------------------------------------------------------
  278 -- | Right fold over all key-value pairs in the headers map.
  279 --
  280 -- Example:
  281 --
  282 -- @
  283 -- ghci> :set -XOverloadedStrings
  284 -- ghci> import "Data.Monoid"
  285 -- ghci> let hdrs = H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]
  286 -- ghci> let f _ val (cntr, acc) = (cntr+1, val <> \";\" <> acc)
  287 -- ghci> H.'foldr' f (0, \"\") hdrs
  288 -- (2,\"text\/plain;text\/html;\")
  289 -- @
  290 foldr :: (CI ByteString -> ByteString -> a -> a)
  291       -> a
  292       -> Headers
  293       -> a
  294 foldr f a (H m) = List.foldr f' a m
  295   where
  296     f' (x, y) v = f (CI.unsafeMk x) y v
  297 
  298 
  299 ------------------------------------------------------------------------------
  300 -- | Same as 'foldr', but the key parameter is of type 'ByteString' instead of
  301 -- 'CI' 'ByteString'. The key is case-folded (lowercase).
  302 foldedFoldr :: (ByteString -> ByteString -> a -> a)
  303             -> a
  304             -> Headers
  305             -> a
  306 foldedFoldr f a (H m) = List.foldr (uncurry f) a m
  307 
  308 
  309 ------------------------------------------------------------------------------
  310 -- | Convert a 'Headers' value to a list of key-value pairs.
  311 --
  312 -- Example:
  313 --
  314 -- @
  315 -- ghci> :set -XOverloadedStrings
  316 -- ghci> let l = [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]
  317 -- ghci> H.'toList' . H.'fromList' $ l
  318 -- [(\"accept\",\"text\/plain\"),(\"accept\",\"text\/html\")]
  319 -- @
  320 toList :: Headers -> [(CI ByteString, ByteString)]
  321 toList = map (first CI.unsafeMk) . unH
  322 
  323 
  324 ------------------------------------------------------------------------------
  325 -- | Build a 'Headers' value from a list of key-value pairs.
  326 --
  327 -- Example:
  328 --
  329 -- @
  330 -- ghci> :set -XOverloadedStrings
  331 -- ghci> H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]
  332 -- H {unH = [(\"accept\",\"text\/plain\"),(\"accept\",\"text\/html\")]}
  333 -- @
  334 fromList :: [(CI ByteString, ByteString)] -> Headers
  335 fromList = H . map (first CI.foldedCase)
  336 
  337 
  338 ------------------------------------------------------------------------------
  339 -- | Like 'fromList', but the keys are assumed to be already case-folded (in
  340 -- lowercase).
  341 unsafeFromCaseFoldedList :: [(ByteString, ByteString)] -> Headers
  342 unsafeFromCaseFoldedList = H
  343 
  344 
  345 ------------------------------------------------------------------------------
  346 -- | Like 'toList', but does not convert the keys to 'CI' 'ByteString', so key
  347 -- comparisons will be case-sensitive.
  348 unsafeToCaseFoldedList :: Headers -> [(ByteString, ByteString)]
  349 unsafeToCaseFoldedList = unH