3 , GeneralizedNewtypeDeriving
4 , MultiParamTypeClasses
10 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
11 -- |An internal module for HTTP headers.
12 module Network.HTTP.Lucu.Headers
17 import Control.Applicative hiding (empty)
18 import Control.Applicative.Unicode hiding ((∅))
20 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
21 import qualified Data.Ascii as A
22 import Data.Attoparsec.Char8
23 import qualified Data.Collections.Newtype.TH as C
24 import Data.Convertible.Base
25 import Data.Convertible.Instances.Ascii ()
26 import Data.Convertible.Utils
28 import Data.List (intersperse)
29 import qualified Data.Map as M (Map)
30 import Data.Collections
31 import Data.Collections.BaseInstances ()
33 import Data.Monoid.Unicode
34 import Network.HTTP.Lucu.Parser.Http
35 import Prelude hiding (lookup, null)
36 import Prelude.Unicode
39 = Headers (M.Map CIAscii Ascii)
42 class HasHeaders a where
43 getHeaders ∷ a → Headers
44 setHeaders ∷ a → Headers → a
46 modifyHeaders ∷ (Headers → Headers) → a → a
47 {-# INLINE modifyHeaders #-}
48 modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
50 getHeader ∷ CIAscii → a → Maybe Ascii
51 {-# INLINE getHeader #-}
52 getHeader = (∘ getHeaders) ∘ lookup
54 hasHeader ∷ CIAscii → a → Bool
55 {-# INLINE hasHeader #-}
56 hasHeader = (∘ getHeaders) ∘ member
58 getCIHeader ∷ CIAscii → a → Maybe CIAscii
59 {-# INLINE getCIHeader #-}
60 getCIHeader = ((cs <$>) ∘) ∘ getHeader
62 deleteHeader ∷ CIAscii → a → a
63 {-# INLINE deleteHeader #-}
64 deleteHeader = modifyHeaders ∘ delete
66 setHeader ∷ CIAscii → Ascii → a → a
67 {-# INLINE setHeader #-}
68 setHeader = (modifyHeaders ∘) ∘ insertWith const
70 instance HasHeaders Headers where
74 C.derive [d| instance Foldable Headers (CIAscii, Ascii)
75 instance Collection Headers (CIAscii, Ascii)
76 instance Indexed Headers CIAscii Ascii
77 instance Map Headers CIAscii Ascii
78 instance SortingCollection Headers (CIAscii, Ascii)
81 -- |@'insert' (key, val)@ merges @val@ with an existing one if any.
82 instance Unfoldable Headers (CIAscii, Ascii) where
84 insert (key, val) (Headers m)
85 = Headers $ insertWith merge key val m
88 {-# INLINE singleton #-}
89 singleton = Headers ∘ singleton
91 instance Monoid Headers where
94 {-# INLINE mappend #-}
97 merge ∷ Ascii → Ascii → Ascii
100 | nullA a ∧ nullA b = (∅)
103 | otherwise = a ⊕ ", " ⊕ b
107 nullA = null ∘ A.toByteString
109 instance ConvertSuccess Headers Ascii where
110 {-# INLINE convertSuccess #-}
111 convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
113 instance ConvertSuccess Headers AsciiBuilder where
114 {-# INLINEABLE convertSuccess #-}
115 convertSuccess (Headers m)
116 = mconcat (header <$> fromFoldable m) ⊕ cs ("\x0D\x0A" ∷ Ascii)
118 header ∷ (CIAscii, Ascii) → AsciiBuilder
119 {-# INLINE header #-}
124 cs ("\x0D\x0A" ∷ Ascii)
126 deriveAttempts [ ([t| Headers |], [t| Ascii |])
127 , ([t| Headers |], [t| AsciiBuilder |])
131 message-header = field-name ":" [ field-value ]
133 field-value = *( field-content | LWS )
134 field-content = <field-value を構成し、*TEXT あるいは
135 token, separators, quoted-string を連結
138 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
141 instance Default (Parser Headers) where
142 {-# INLINEABLE def #-}
143 def = do xs ← many header
145 return $ fromFoldable xs
147 header ∷ Parser (CIAscii, Ascii)
148 {-# INLINEABLE header #-}
149 header = do name ← cs <$> token
152 values ← content `sepBy` try lws
155 return (name, joinValues values)
157 content ∷ Parser Ascii
158 {-# INLINEABLE content #-}
159 content = A.unsafeFromByteString
161 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
163 joinValues ∷ [Ascii] → Ascii
164 {-# INLINEABLE joinValues #-}
167 ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)