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 Data.Attoparsec.Parsable
24 import Data.ByteString (ByteString)
25 import qualified Data.Collections.Newtype.TH as C
26 import Data.Convertible.Base
27 import Data.Convertible.Instances.Ascii ()
28 import Data.Convertible.Utils
29 import Data.List (intersperse)
30 import qualified Data.Map as M (Map)
31 import Data.Collections
32 import Data.Collections.BaseInstances ()
34 import Data.Monoid.Unicode
35 import Network.HTTP.Lucu.Parser.Http
36 import Prelude hiding (lookup, null)
37 import Prelude.Unicode
40 = Headers (M.Map CIAscii Ascii)
43 class HasHeaders a where
44 getHeaders ∷ a → Headers
45 setHeaders ∷ a → Headers → a
47 modifyHeaders ∷ (Headers → Headers) → a → a
48 {-# INLINE modifyHeaders #-}
49 modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
51 getHeader ∷ CIAscii → a → Maybe Ascii
52 {-# INLINE getHeader #-}
53 getHeader = (∘ getHeaders) ∘ lookup
55 hasHeader ∷ CIAscii → a → Bool
56 {-# INLINE hasHeader #-}
57 hasHeader = (∘ getHeaders) ∘ member
59 getCIHeader ∷ CIAscii → a → Maybe CIAscii
60 {-# INLINE getCIHeader #-}
61 getCIHeader = ((cs <$>) ∘) ∘ getHeader
63 deleteHeader ∷ CIAscii → a → a
64 {-# INLINE deleteHeader #-}
65 deleteHeader = modifyHeaders ∘ delete
67 setHeader ∷ CIAscii → Ascii → a → a
68 {-# INLINE setHeader #-}
69 setHeader = (modifyHeaders ∘) ∘ insertWith const
71 instance HasHeaders Headers where
75 C.derive [d| instance Foldable Headers (CIAscii, Ascii)
76 instance Collection Headers (CIAscii, Ascii)
77 instance Indexed Headers CIAscii Ascii
78 instance Map Headers CIAscii Ascii
79 instance SortingCollection Headers (CIAscii, Ascii)
82 -- |@'insert' (key, val)@ merges @val@ with an existing one if any.
83 instance Unfoldable Headers (CIAscii, Ascii) where
85 insert (key, val) (Headers m)
86 = Headers $ insertWith merge key val m
89 {-# INLINE singleton #-}
90 singleton = Headers ∘ singleton
92 instance Monoid Headers where
95 {-# INLINE mappend #-}
98 merge ∷ Ascii → Ascii → Ascii
101 | nullA a ∧ nullA b = (∅)
104 | otherwise = a ⊕ ", " ⊕ b
108 nullA = null ∘ A.toByteString
110 instance ConvertSuccess Headers Ascii where
111 {-# INLINE convertSuccess #-}
112 convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
114 instance ConvertSuccess Headers AsciiBuilder where
115 {-# INLINEABLE convertSuccess #-}
116 convertSuccess (Headers m)
117 = mconcat (header <$> fromFoldable m) ⊕ cs ("\x0D\x0A" ∷ Ascii)
119 header ∷ (CIAscii, Ascii) → AsciiBuilder
120 {-# INLINE header #-}
125 cs ("\x0D\x0A" ∷ Ascii)
127 deriveAttempts [ ([t| Headers |], [t| Ascii |])
128 , ([t| Headers |], [t| AsciiBuilder |])
132 message-header = field-name ":" [ field-value ]
134 field-value = *( field-content | LWS )
135 field-content = <field-value を構成し、*TEXT あるいは
136 token, separators, quoted-string を連結
139 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
142 instance Parsable ByteString Headers where
143 {-# INLINEABLE parser #-}
144 parser = do xs ← many header
146 return $ fromFoldable xs
148 header ∷ Parser (CIAscii, Ascii)
149 {-# INLINEABLE header #-}
150 header = do name ← cs <$> token
153 values ← content `sepBy` try lws
156 return (name, joinValues values)
158 content ∷ Parser Ascii
159 {-# INLINEABLE content #-}
160 content = A.unsafeFromByteString
162 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
164 joinValues ∷ [Ascii] → Ascii
165 {-# INLINEABLE joinValues #-}
168 ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)