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 toHeaders ∷ [(CIAscii, Ascii)] → Headers
61 {-# INLINE toHeaders #-}
62 toHeaders = flip mkHeaders (∅)
64 mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers
65 mkHeaders [] (Headers m) = Headers m
66 mkHeaders ((key, val):xs) (Headers m)
67 = mkHeaders xs $ Headers $
68 case M.lookup key m of
69 Nothing → M.insert key val m
70 Just old → M.insert key (merge old val) m
72 merge ∷ Ascii → Ascii → Ascii
75 | nullA a ∧ nullA b = (∅)
78 | otherwise = a ⊕ ", " ⊕ b
82 nullA = BS.null ∘ A.toByteString
84 fromHeaders ∷ Headers → [(CIAscii, Ascii)]
85 fromHeaders (Headers m) = M.toList m
88 message-header = field-name ":" [ field-value ]
90 field-value = *( field-content | LWS )
91 field-content = <field-value を構成し、*TEXT あるいは
92 token, separators, quoted-string を連結
95 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
98 headersP ∷ Parser Headers
99 {-# INLINEABLE headersP #-}
100 headersP = do xs ← P.many header
102 return $ toHeaders xs
104 header ∷ Parser (CIAscii, Ascii)
106 do name ← A.toCIAscii <$> token
109 values ← sepBy content lws
112 return (name, joinValues values)
114 content ∷ Parser Ascii
115 {-# INLINE content #-}
116 content = A.unsafeFromByteString
118 takeWhile1 (\c → ((¬) (isSPHT c)) ∧ isText c)
120 joinValues ∷ [Ascii] → Ascii
121 {-# INLINE joinValues #-}
122 joinValues = A.fromAsciiBuilder ∘ joinWith "\x20"
124 hPutHeaders ∷ HandleLike h => h → Headers → IO ()
125 hPutHeaders !h !(Headers m)
126 = mapM_ putH (M.toList m) >> hPutBS h "\r\n"
128 putH ∷ (CIAscii, Ascii) → IO ()
130 = do hPutBS h (A.ciToByteString name)
132 hPutBS h (A.toByteString value)