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