3 , GeneralizedNewtypeDeriving
7 module Network.HTTP.Lucu.Headers
18 import Control.Applicative
19 import Data.Ascii (Ascii, CIAscii)
20 import qualified Data.Ascii as A
21 import Data.Attoparsec.Char8 as P
22 import qualified Data.ByteString as BS
24 import qualified Data.Map as M
26 import Data.Monoid.Unicode
27 import Network.HTTP.Lucu.HandleLike
28 import Network.HTTP.Lucu.Parser.Http
29 import Network.HTTP.Lucu.Utils
30 import Prelude.Unicode
33 = Headers (Map CIAscii Ascii)
34 deriving (Eq, Show, Monoid)
36 class HasHeaders a where
37 getHeaders ∷ a → Headers
38 setHeaders ∷ a → Headers → a
40 getHeader ∷ CIAscii → a → Maybe Ascii
41 {-# INLINE getHeader #-}
43 = case getHeaders a of
44 Headers m → M.lookup key m
46 deleteHeader ∷ CIAscii → a → a
47 {-# INLINE deleteHeader #-}
49 = case getHeaders a of
51 → setHeaders a $ Headers $ M.delete key m
53 setHeader ∷ CIAscii → Ascii → a → a
54 {-# INLINE setHeader #-}
55 setHeader !key !val !a
56 = case getHeaders a of
58 → setHeaders a $ Headers $ M.insert key val m
60 instance HasHeaders Headers where
64 toHeaders ∷ [(CIAscii, Ascii)] → Headers
65 {-# INLINE toHeaders #-}
66 toHeaders = flip mkHeaders (∅)
68 mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers
69 mkHeaders [] (Headers m) = Headers m
70 mkHeaders ((key, val):xs) (Headers m)
71 = mkHeaders xs $ Headers $
72 case M.lookup key m of
73 Nothing → M.insert key val m
74 Just old → M.insert key (merge old val) m
76 merge ∷ Ascii → Ascii → Ascii
79 | nullA a ∧ nullA b = (∅)
82 | otherwise = a ⊕ ", " ⊕ b
86 nullA = BS.null ∘ A.toByteString
88 fromHeaders ∷ Headers → [(CIAscii, Ascii)]
89 fromHeaders (Headers m) = M.toList m
92 message-header = field-name ":" [ field-value ]
94 field-value = *( field-content | LWS )
95 field-content = <field-value を構成し、*TEXT あるいは
96 token, separators, quoted-string を連結
99 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
102 headersP ∷ Parser Headers
103 {-# INLINEABLE headersP #-}
104 headersP = do xs ← P.many header
106 return $ toHeaders xs
108 header ∷ Parser (CIAscii, Ascii)
109 header = do name ← A.toCIAscii <$> token
112 values ← sepBy content (try lws)
115 return (name, joinValues values)
117 content ∷ Parser Ascii
118 {-# INLINE content #-}
119 content = A.unsafeFromByteString
121 takeWhile1 (\c → ((¬) (isSPHT c)) ∧ isText c)
123 joinValues ∷ [Ascii] → Ascii
124 {-# INLINE joinValues #-}
125 joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder
127 hPutHeaders ∷ HandleLike h => h → Headers → IO ()
128 hPutHeaders !h !(Headers m)
129 = mapM_ putH (M.toList m) >> hPutBS h "\r\n"
131 putH ∷ (CIAscii, Ascii) → IO ()
133 = do hPutBS h (A.ciToByteString name)
135 hPutBS h (A.toByteString value)