Network/HTTP/Lucu/Headers.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , GeneralizedNewtypeDeriving
   4   , MultiParamTypeClasses
   5   , TypeSynonymInstances
   6   , OverloadedStrings
   7   , UnicodeSyntax
   8   #-}
   9 -- |An internal module for HTTP headers.
  10 module Network.HTTP.Lucu.Headers
  11     ( Headers
  12     , HasHeaders(..)
  13
  14     , headers
  15     , printHeaders
  16     )
  17     where
  18 import Control.Applicative hiding (empty)
  19 import Control.Applicative.Unicode hiding ((∅))
  20 import Control.Arrow
  21 import Control.Monad
  22 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  23 import qualified Data.Ascii as A
  24 import Data.Attoparsec.Char8 as P
  25 import Data.List (intersperse)
  26 import qualified Data.Map as M (Map)
  27 import Data.Collections
  28 import Data.Collections.BaseInstances ()
  29 import Data.Monoid
  30 import Data.Monoid.Unicode
  31 import Network.HTTP.Lucu.Parser.Http
  32 import Prelude hiding (filter, foldl, foldl1, foldr, foldr1, lookup, null)
  33 import Prelude.Unicode
  34
  35 newtype Headers
  36     = Headers (M.Map CIAscii Ascii)
  37       deriving (Eq, Show)
  38
  39 class HasHeaders a where
  40     getHeaders ∷ a → Headers
  41     setHeaders ∷ a → Headers → a
  42
  43     modifyHeaders ∷ (Headers → Headers) → a → a
  44     {-# INLINE modifyHeaders #-}
  45     modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
  46
  47     getHeader ∷ CIAscii → a → Maybe Ascii
  48     {-# INLINE getHeader #-}
  49     getHeader = (∘ getHeaders) ∘ lookup
  50
  51     hasHeader ∷ CIAscii → a → Bool
  52     {-# INLINE hasHeader #-}
  53     hasHeader = (∘ getHeaders) ∘ member
  54
  55     getCIHeader ∷ CIAscii → a → Maybe CIAscii
  56     {-# INLINE getCIHeader #-}
  57     getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
  58
  59     deleteHeader ∷ CIAscii → a → a
  60     {-# INLINE deleteHeader #-}
  61     deleteHeader = modifyHeaders ∘ delete
  62
  63     setHeader ∷ CIAscii → Ascii → a → a
  64     {-# INLINE setHeader #-}
  65     setHeader = (modifyHeaders ∘) ∘ insertWith const
  66
  67 instance HasHeaders Headers where
  68     getHeaders   = id
  69     setHeaders _ = id
  70
  71 -- |@'insert' (key, val)@ merges @val@ with an existing one if any.
  72 instance Unfoldable Headers (CIAscii, Ascii) where
  73     {-# INLINE insert #-}
  74     insert (key, val) (Headers m)
  75         = Headers $ insertWith merge key val m
  76     {-# INLINE empty #-}
  77     empty     = Headers empty
  78     {-# INLINE singleton #-}
  79     singleton = Headers ∘ singleton
  80
  81 -- FIXME: auto-derive
  82 instance Foldable Headers (CIAscii, Ascii) where
  83     {-# INLINE fold #-}
  84     fold (Headers m) = fold m
  85     {-# INLINE foldMap #-}
  86     foldMap f (Headers m) = foldMap f m
  87     {-# INLINE foldr #-}
  88     foldr f b (Headers m) = foldr f b m
  89     {-# INLINE foldl #-}
  90     foldl f b (Headers m) = foldl f b m
  91     {-# INLINE foldr1 #-}
  92     foldr1 f (Headers m) = foldr1 f m
  93     {-# INLINE foldl1 #-}
  94     foldl1 f (Headers m) = foldl1 f m
  95     {-# INLINE null #-}
  96     null (Headers m) = null m
  97     {-# INLINE size #-}
  98     size (Headers m) = size m
  99     {-# INLINE isSingleton #-}
 100     isSingleton (Headers m) = isSingleton m
 101
 102 -- FIXME: auto-derive
 103 instance Collection Headers (CIAscii, Ascii) where
 104     {-# INLINE filter #-}
 105     filter f (Headers m) = Headers $ filter f m
 106
 107 -- FIXME: auto-derive
 108 instance Indexed Headers CIAscii Ascii where
 109     {-# INLINE index #-}
 110     index k (Headers m) = index k m
 111     {-# INLINE adjust #-}
 112     adjust f k (Headers m) = Headers $ adjust f k m
 113     {-# INLINE inDomain #-}
 114     inDomain k (Headers m) = inDomain k m
 115     {-# INLINE (//) #-}
 116     Headers m // l = Headers $ m // l
 117     {-# INLINE accum #-}
 118     accum f (Headers m) l = Headers $ accum f m l
 119
 120 instance Monoid Headers where
 121     {-# INLINE mempty #-}
 122     mempty  = empty
 123     {-# INLINE mappend #-}
 124     mappend = insertMany
 125
 126 -- FIXME: auto-derive
 127 instance Map Headers CIAscii Ascii where
 128     {-# INLINE delete #-}
 129     delete k (Headers m) = Headers $ delete k m
 130     {-# INLINE member #-}
 131     member k (Headers m) = member k m
 132     {-# INLINE union #-}
 133     union (Headers α) (Headers β)
 134         = Headers $ union α β
 135     {-# INLINE intersection #-}
 136     intersection (Headers α) (Headers β)
 137         = Headers $ intersection α β
 138     {-# INLINE difference #-}
 139     difference (Headers α) (Headers β)
 140         = Headers $ difference α β
 141     {-# INLINE isSubset #-}
 142     isSubset (Headers α) (Headers β)
 143         = isSubset α β
 144     {-# INLINE isProperSubset #-}
 145     isProperSubset (Headers α) (Headers β)
 146         = isProperSubset α β
 147     {-# INLINE lookup #-}
 148     lookup k (Headers m) = lookup k m
 149     {-# INLINE alter #-}
 150     alter f k (Headers m)
 151         = Headers $ alter f k m
 152     {-# INLINE insertWith #-}
 153     insertWith f k v (Headers m)
 154         = Headers $ insertWith f k v m
 155     {-# INLINE fromFoldableWith #-}
 156     fromFoldableWith = (Headers ∘) ∘ fromFoldableWith
 157     {-# INLINE foldGroups #-}
 158     foldGroups = ((Headers ∘) ∘) ∘ foldGroups
 159     {-# INLINE mapWithKey #-}
 160     mapWithKey f (Headers m)
 161         = Headers $ mapWithKey f m
 162     {-# INLINE unionWith #-}
 163     unionWith f (Headers α) (Headers β)
 164         = Headers $ unionWith f α β
 165     {-# INLINE intersectionWith #-}
 166     intersectionWith f (Headers α) (Headers β)
 167         = Headers $ intersectionWith f α β
 168     {-# INLINE differenceWith #-}
 169     differenceWith f (Headers α) (Headers β)
 170         = Headers $ differenceWith f α β
 171     {-# INLINE isSubmapBy #-}
 172     isSubmapBy f (Headers α) (Headers β)
 173         = isSubmapBy f α β
 174     {-# INLINE isProperSubmapBy #-}
 175     isProperSubmapBy f (Headers α) (Headers β)
 176         = isProperSubmapBy f α β
 177
 178 -- FIXME: auto-derive
 179 instance SortingCollection Headers (CIAscii, Ascii) where
 180     {-# INLINE minView #-}
 181     minView (Headers m) = second Headers <$> minView m
 182
 183 merge ∷ Ascii → Ascii → Ascii
 184 {-# INLINE merge #-}
 185 merge a b
 186     | nullA a ∧ nullA b = (∅)
 187     | nullA a           = b
 188     |           nullA b = a
 189     | otherwise         = a ⊕ ", " ⊕ b
 190     where
 191       nullA ∷ Ascii → Bool
 192       {-# INLINE nullA #-}
 193       nullA = null ∘ A.toByteString
 194
 195 {-
 196   message-header = field-name ":" [ field-value ]
 197   field-name     = token
 198   field-value    = *( field-content | LWS )
 199   field-content  = <field-value を構成し、*TEXT あるいは
 200                     token, separators, quoted-string を連結
 201                     したものから成る OCTET>
 202
 203   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 204   LWS は單一の SP に變換される。
 205 -}
 206 headers ∷ Parser Headers
 207 {-# INLINEABLE headers #-}
 208 headers = do xs ← P.many header
 209              crlf
 210              return $ fromFoldable xs
 211     where
 212       header ∷ Parser (CIAscii, Ascii)
 213       header = do name ← A.toCIAscii <$> token
 214                   void $ char ':'
 215                   skipMany lws
 216                   values ← content `sepBy` try lws
 217                   skipMany (try lws)
 218                   crlf
 219                   return (name, joinValues values)
 220
 221       content ∷ Parser Ascii
 222       {-# INLINE content #-}
 223       content = A.unsafeFromByteString
 224                 <$>
 225                 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
 226
 227       joinValues ∷ [Ascii] → Ascii
 228       {-# INLINE joinValues #-}
 229       joinValues = A.fromAsciiBuilder
 230                    ∘ mconcat
 231                    ∘ intersperse (A.toAsciiBuilder "\x20")
 232                    ∘ (A.toAsciiBuilder <$>)
 233
 234 printHeaders ∷ Headers → AsciiBuilder
 235 printHeaders (Headers m)
 236     = mconcat (printHeader <$> fromFoldable m) ⊕
 237       A.toAsciiBuilder "\x0D\x0A"
 238     where
 239       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
 240       printHeader (name, value)
 241           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
 242             A.toAsciiBuilder ": "                 ⊕
 243             A.toAsciiBuilder value                ⊕
 244             A.toAsciiBuilder "\x0D\x0A"