3 , GeneralizedNewtypeDeriving
4 , MultiParamTypeClasses
9 -- |An internal module for HTTP headers.
10 module Network.HTTP.Lucu.Headers
18 import Control.Applicative hiding (empty)
19 import Control.Applicative.Unicode hiding ((∅))
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 ()
30 import Data.Monoid.Unicode
31 import Network.HTTP.Lucu.Parser.Http
32 import Prelude hiding (filter, foldr, lookup, null)
33 import Prelude.Unicode
36 = Headers (M.Map CIAscii Ascii)
39 class HasHeaders a where
40 getHeaders ∷ a → Headers
41 setHeaders ∷ a → Headers → a
43 modifyHeaders ∷ (Headers → Headers) → a → a
44 {-# INLINE modifyHeaders #-}
45 modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
47 getHeader ∷ CIAscii → a → Maybe Ascii
48 {-# INLINE getHeader #-}
49 getHeader = (∘ getHeaders) ∘ lookup
51 hasHeader ∷ CIAscii → a → Bool
52 {-# INLINE hasHeader #-}
53 hasHeader = (∘ getHeaders) ∘ member
55 getCIHeader ∷ CIAscii → a → Maybe CIAscii
56 {-# INLINE getCIHeader #-}
57 getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
59 deleteHeader ∷ CIAscii → a → a
60 {-# INLINE deleteHeader #-}
61 deleteHeader = modifyHeaders ∘ delete
63 setHeader ∷ CIAscii → Ascii → a → a
64 {-# INLINE setHeader #-}
65 setHeader = (modifyHeaders ∘) ∘ insertWith const
67 instance HasHeaders Headers where
71 -- |@'insert' (key, val)@ merges @val@ with an existing one if any.
72 instance Unfoldable Headers (CIAscii, Ascii) where
74 insert (key, val) (Headers m)
75 = Headers $ insertWith merge key val m
79 {-# INLINE singleton #-}
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
89 instance Foldable Headers (CIAscii, Ascii) where
91 null (Headers m) = null m
93 size (Headers m) = size m
95 foldr f b (Headers m) = foldr f b m
97 instance Collection Headers (CIAscii, Ascii) where
99 filter f (Headers m) = Headers $ filter f m
101 instance Indexed Headers CIAscii Ascii where
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
109 instance Monoid Headers where
110 {-# INLINE mempty #-}
112 {-# INLINE mappend #-}
113 mappend (Headers α) (Headers β)
114 = Headers $ insertManySorted β α
116 -- FIXME: override every methods
117 instance Map Headers CIAscii Ascii where
118 {-# INLINE lookup #-}
119 lookup k (Headers m) = lookup k m
120 {-# INLINE insertWith #-}
121 insertWith f k v (Headers m)
122 = Headers $ insertWith f k v m
123 {-# INLINE mapWithKey #-}
124 mapWithKey f (Headers m)
125 = Headers $ mapWithKey f m
126 {-# INLINE unionWith #-}
127 unionWith f (Headers α) (Headers β)
128 = Headers $ unionWith f α β
129 {-# INLINE intersectionWith #-}
130 intersectionWith f (Headers α) (Headers β)
131 = Headers $ intersectionWith f α β
132 {-# INLINE differenceWith #-}
133 differenceWith f (Headers α) (Headers β)
134 = Headers $ differenceWith f α β
135 {-# INLINE isSubmapBy #-}
136 isSubmapBy f (Headers α) (Headers β)
138 {-# INLINE isProperSubmapBy #-}
139 isProperSubmapBy f (Headers α) (Headers β)
140 = isProperSubmapBy f α β
142 instance SortingCollection Headers (CIAscii, Ascii) where
143 {-# INLINE minView #-}
144 minView (Headers m) = second Headers <$> minView m
146 merge ∷ Ascii → Ascii → Ascii
149 | nullA a ∧ nullA b = (∅)
152 | otherwise = a ⊕ ", " ⊕ b
156 nullA = null ∘ A.toByteString
159 message-header = field-name ":" [ field-value ]
161 field-value = *( field-content | LWS )
162 field-content = <field-value を構成し、*TEXT あるいは
163 token, separators, quoted-string を連結
166 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
169 headers ∷ Parser Headers
170 {-# INLINEABLE headers #-}
171 headers = do xs ← P.many header
173 return $ fromFoldable xs
175 header ∷ Parser (CIAscii, Ascii)
176 header = do name ← A.toCIAscii <$> token
179 values ← content `sepBy` try lws
182 return (name, joinValues values)
184 content ∷ Parser Ascii
185 {-# INLINE content #-}
186 content = A.unsafeFromByteString
188 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
190 joinValues ∷ [Ascii] → Ascii
191 {-# INLINE joinValues #-}
192 joinValues = A.fromAsciiBuilder
194 ∘ intersperse (A.toAsciiBuilder "\x20")
195 ∘ map A.toAsciiBuilder
197 printHeaders ∷ Headers → AsciiBuilder
198 printHeaders (Headers m)
199 = mconcat (map printHeader (fromFoldable m)) ⊕
200 A.toAsciiBuilder "\x0D\x0A"
202 printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
203 printHeader (name, value)
204 = A.toAsciiBuilder (A.fromCIAscii name) ⊕
205 A.toAsciiBuilder ": " ⊕
206 A.toAsciiBuilder value ⊕
207 A.toAsciiBuilder "\x0D\x0A"