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, foldr, 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
  78         = Headers empty
  79     {-# INLINE singleton #-}
  80     singleton p
  81         = Headers $ singleton p
  82     {-# INLINE insertMany #-}
  83     insertMany f (Headers m)
  84         = Headers $ insertMany f m
  85     {-# INLINE insertManySorted #-}
  86     insertManySorted f (Headers m)
  87         = Headers $ insertManySorted f m
  88
  89 instance Foldable Headers (CIAscii, Ascii) where
  90     {-# INLINE null #-}
  91     null (Headers m) = null m
  92     {-# INLINE size #-}
  93     size (Headers m) = size m
  94     {-# INLINE foldr #-}
  95     foldr f b (Headers m) = foldr f b m
  96
  97 instance Collection Headers (CIAscii, Ascii) where
  98     {-# INLINE filter #-}
  99     filter f (Headers m) = Headers $ filter f m
 100
 101 instance Indexed Headers CIAscii Ascii where
 102     {-# INLINE index #-}
 103     index k (Headers m) = index k m
 104     {-# INLINE adjust #-}
 105     adjust f k (Headers m) = Headers $ adjust f k m
 106     {-# INLINE inDomain #-}
 107     inDomain k (Headers m) = inDomain k m
 108
 109 instance Monoid Headers where
 110     {-# INLINE mempty #-}
 111     mempty = empty
 112     {-# INLINE mappend #-}
 113     mappend (Headers α) (Headers β)
 114         = Headers $ insertManySorted β α
 115
 116 instance Map Headers CIAscii Ascii where
 117     {-# INLINE lookup #-}
 118     lookup k (Headers m) = lookup k m
 119     {-# INLINE insertWith #-}
 120     insertWith f k v (Headers m)
 121         = Headers $ insertWith f k v m
 122     {-# INLINE mapWithKey #-}
 123     mapWithKey f (Headers m)
 124         = Headers $ mapWithKey f m
 125     {-# INLINE unionWith #-}
 126     unionWith f (Headers α) (Headers β)
 127         = Headers $ unionWith f α β
 128     {-# INLINE intersectionWith #-}
 129     intersectionWith f (Headers α) (Headers β)
 130         = Headers $ intersectionWith f α β
 131     {-# INLINE differenceWith #-}
 132     differenceWith f (Headers α) (Headers β)
 133         = Headers $ differenceWith f α β
 134     {-# INLINE isSubmapBy #-}
 135     isSubmapBy f (Headers α) (Headers β)
 136         = isSubmapBy f α β
 137     {-# INLINE isProperSubmapBy #-}
 138     isProperSubmapBy f (Headers α) (Headers β)
 139         = isProperSubmapBy f α β
 140
 141 instance SortingCollection Headers (CIAscii, Ascii) where
 142     {-# INLINE minView #-}
 143     minView (Headers m) = second Headers <$> minView m
 144
 145 merge ∷ Ascii → Ascii → Ascii
 146 {-# INLINE merge #-}
 147 merge a b
 148     | nullA a ∧ nullA b = (∅)
 149     | nullA a           = b
 150     |           nullA b = a
 151     | otherwise         = a ⊕ ", " ⊕ b
 152     where
 153       nullA ∷ Ascii → Bool
 154       {-# INLINE nullA #-}
 155       nullA = null ∘ A.toByteString
 156
 157 {-
 158   message-header = field-name ":" [ field-value ]
 159   field-name     = token
 160   field-value    = *( field-content | LWS )
 161   field-content  = <field-value を構成し、*TEXT あるいは
 162                     token, separators, quoted-string を連結
 163                     したものから成る OCTET>
 164
 165   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 166   LWS は單一の SP に變換される。
 167 -}
 168 headers ∷ Parser Headers
 169 {-# INLINEABLE headers #-}
 170 headers = do xs ← P.many header
 171              crlf
 172              return $ fromFoldable xs
 173     where
 174       header ∷ Parser (CIAscii, Ascii)
 175       header = do name ← A.toCIAscii <$> token
 176                   void $ char ':'
 177                   skipMany lws
 178                   values ← content `sepBy` try lws
 179                   skipMany (try lws)
 180                   crlf
 181                   return (name, joinValues values)
 182
 183       content ∷ Parser Ascii
 184       {-# INLINE content #-}
 185       content = A.unsafeFromByteString
 186                 <$>
 187                 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
 188
 189       joinValues ∷ [Ascii] → Ascii
 190       {-# INLINE joinValues #-}
 191       joinValues = A.fromAsciiBuilder
 192                    ∘ mconcat
 193                    ∘ intersperse (A.toAsciiBuilder "\x20")
 194                    ∘ map A.toAsciiBuilder
 195
 196 printHeaders ∷ Headers → AsciiBuilder
 197 printHeaders (Headers m)
 198     = mconcat (map printHeader (fromFoldable m)) ⊕
 199       A.toAsciiBuilder "\x0D\x0A"
 200     where
 201       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
 202       printHeader (name, value)
 203           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
 204             A.toAsciiBuilder ": "                 ⊕
 205             A.toAsciiBuilder value                ⊕
 206             A.toAsciiBuilder "\x0D\x0A"