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, foldl, foldl1, foldr, foldr1, 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
78 {-# INLINE singleton #-}
79 singleton = Headers ∘ singleton
82 instance Foldable Headers (CIAscii, Ascii) where
84 fold (Headers m) = fold m
85 {-# INLINE foldMap #-}
86 foldMap f (Headers m) = foldMap f m
88 foldr f b (Headers m) = foldr f b m
90 foldl f b (Headers m) = foldl f b m
92 foldr1 f (Headers m) = foldr1 f m
94 foldl1 f (Headers m) = foldl1 f m
96 null (Headers m) = null m
98 size (Headers m) = size m
99 {-# INLINE isSingleton #-}
100 isSingleton (Headers m) = isSingleton m
102 -- FIXME: auto-derive
103 instance Collection Headers (CIAscii, Ascii) where
104 {-# INLINE filter #-}
105 filter f (Headers m) = Headers $ filter f m
107 -- FIXME: auto-derive
108 instance Indexed Headers CIAscii Ascii where
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
116 Headers m // l = Headers $ m // l
118 accum f (Headers m) l = Headers $ accum f m l
120 instance Monoid Headers where
121 {-# INLINE mempty #-}
123 {-# INLINE mappend #-}
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
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 β)
144 {-# INLINE isProperSubset #-}
145 isProperSubset (Headers α) (Headers β)
147 {-# INLINE lookup #-}
148 lookup k (Headers m) = lookup k m
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 β)
174 {-# INLINE isProperSubmapBy #-}
175 isProperSubmapBy f (Headers α) (Headers β)
176 = isProperSubmapBy f α β
178 -- FIXME: auto-derive
179 instance SortingCollection Headers (CIAscii, Ascii) where
180 {-# INLINE minView #-}
181 minView (Headers m) = second Headers <$> minView m
183 merge ∷ Ascii → Ascii → Ascii
186 | nullA a ∧ nullA b = (∅)
189 | otherwise = a ⊕ ", " ⊕ b
193 nullA = null ∘ A.toByteString
196 message-header = field-name ":" [ field-value ]
198 field-value = *( field-content | LWS )
199 field-content = <field-value を構成し、*TEXT あるいは
200 token, separators, quoted-string を連結
203 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
206 headers ∷ Parser Headers
207 {-# INLINEABLE headers #-}
208 headers = do xs ← P.many header
210 return $ fromFoldable xs
212 header ∷ Parser (CIAscii, Ascii)
213 header = do name ← A.toCIAscii <$> token
216 values ← content `sepBy` try lws
219 return (name, joinValues values)
221 content ∷ Parser Ascii
222 {-# INLINE content #-}
223 content = A.unsafeFromByteString
225 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
227 joinValues ∷ [Ascii] → Ascii
228 {-# INLINE joinValues #-}
229 joinValues = A.fromAsciiBuilder
231 ∘ intersperse (A.toAsciiBuilder "\x20")
232 ∘ (A.toAsciiBuilder <$>)
234 printHeaders ∷ Headers → AsciiBuilder
235 printHeaders (Headers m)
236 = mconcat (printHeader <$> fromFoldable m) ⊕
237 A.toAsciiBuilder "\x0D\x0A"
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"