3 , GeneralizedNewtypeDeriving
4 , MultiParamTypeClasses
10 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
11 -- |An internal module for HTTP headers.
12 module Network.HTTP.Lucu.Headers
20 import Control.Applicative hiding (empty)
21 import Control.Applicative.Unicode hiding ((∅))
23 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
24 import qualified Data.Ascii as A
25 import Data.Attoparsec.Char8 as P
26 import qualified Data.Collections.Newtype.TH as C
27 import Data.List (intersperse)
28 import qualified Data.Map as M (Map)
29 import Data.Collections
30 import Data.Collections.BaseInstances ()
32 import Data.Monoid.Unicode
33 import Network.HTTP.Lucu.Parser.Http
34 import Prelude hiding (lookup, null)
35 import Prelude.Unicode
38 = Headers (M.Map CIAscii Ascii)
41 class HasHeaders a where
42 getHeaders ∷ a → Headers
43 setHeaders ∷ a → Headers → a
45 modifyHeaders ∷ (Headers → Headers) → a → a
46 {-# INLINE modifyHeaders #-}
47 modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
49 getHeader ∷ CIAscii → a → Maybe Ascii
50 {-# INLINE getHeader #-}
51 getHeader = (∘ getHeaders) ∘ lookup
53 hasHeader ∷ CIAscii → a → Bool
54 {-# INLINE hasHeader #-}
55 hasHeader = (∘ getHeaders) ∘ member
57 getCIHeader ∷ CIAscii → a → Maybe CIAscii
58 {-# INLINE getCIHeader #-}
59 getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
61 deleteHeader ∷ CIAscii → a → a
62 {-# INLINE deleteHeader #-}
63 deleteHeader = modifyHeaders ∘ delete
65 setHeader ∷ CIAscii → Ascii → a → a
66 {-# INLINE setHeader #-}
67 setHeader = (modifyHeaders ∘) ∘ insertWith const
69 instance HasHeaders Headers where
73 C.derive [d| instance Foldable Headers (CIAscii, Ascii)
74 instance Collection Headers (CIAscii, Ascii)
75 instance Indexed Headers CIAscii Ascii
76 instance Map Headers CIAscii Ascii
77 instance SortingCollection Headers (CIAscii, Ascii)
80 -- |@'insert' (key, val)@ merges @val@ with an existing one if any.
81 instance Unfoldable Headers (CIAscii, Ascii) where
83 insert (key, val) (Headers m)
84 = Headers $ insertWith merge key val m
87 {-# INLINE singleton #-}
88 singleton = Headers ∘ singleton
90 instance Monoid Headers where
93 {-# INLINE mappend #-}
96 merge ∷ Ascii → Ascii → Ascii
99 | nullA a ∧ nullA b = (∅)
102 | otherwise = a ⊕ ", " ⊕ b
106 nullA = null ∘ A.toByteString
109 message-header = field-name ":" [ field-value ]
111 field-value = *( field-content | LWS )
112 field-content = <field-value を構成し、*TEXT あるいは
113 token, separators, quoted-string を連結
116 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
119 headers ∷ Parser Headers
120 {-# INLINEABLE headers #-}
121 headers = do xs ← P.many header
123 return $ fromFoldable xs
125 header ∷ Parser (CIAscii, Ascii)
126 header = do name ← A.toCIAscii <$> token
129 values ← content `sepBy` try lws
132 return (name, joinValues values)
134 content ∷ Parser Ascii
135 {-# INLINE content #-}
136 content = A.unsafeFromByteString
138 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
140 joinValues ∷ [Ascii] → Ascii
141 {-# INLINE joinValues #-}
142 joinValues = A.fromAsciiBuilder
144 ∘ intersperse (A.toAsciiBuilder "\x20")
145 ∘ (A.toAsciiBuilder <$>)
147 printHeaders ∷ Headers → AsciiBuilder
148 printHeaders (Headers m)
149 = mconcat (printHeader <$> fromFoldable m) ⊕
150 A.toAsciiBuilder "\x0D\x0A"
152 printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
153 printHeader (name, value)
154 = A.toAsciiBuilder (A.fromCIAscii name) ⊕
155 A.toAsciiBuilder ": " ⊕
156 A.toAsciiBuilder value ⊕
157 A.toAsciiBuilder "\x0D\x0A"