1 module Network.HTTP.Lucu.Headers
4 , emptyHeaders -- Headers
5 , headersP -- Parser Headers
6 , hPutHeaders -- Handle -> Headers -> IO ()
12 import Network.HTTP.Lucu.Parser
13 import Network.HTTP.Lucu.Parser.Http
14 import Network.HTTP.Lucu.Utils
17 type Headers = [ (String, String) ]
19 class HasHeaders a where
20 getHeaders :: a -> Headers
21 setHeaders :: a -> Headers -> a
23 getHeader :: String -> a -> Maybe String
25 = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
27 deleteHeader :: String -> a -> a
29 = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
31 addHeader :: String -> String -> a -> a
33 = setHeaders a $ (getHeaders a) ++ [(key, val)]
35 setHeader :: String -> String -> a -> a
37 = let list = getHeaders a
38 deleted = filter (not . noCaseEq key . fst) list
39 added = deleted ++ [(key, val)]
43 emptyHeaders :: Headers
48 message-header = field-name ":" [ field-value ]
50 field-value = *( field-content | LWS )
51 field-content = <field-value を構成し、*TEXT あるいは
52 token, separators, quoted-string を連結
55 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
58 headersP :: Parser Headers
59 headersP = do xs <- many header
63 header :: Parser (String, String)
64 header = do name <- token
66 -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
67 -- の記述はひどく曖昧であり、この動作が本當に間違って
68 -- ゐるのかどうかも良く分からない。例へば
69 -- quoted-string の内部にある空白は纏めていいのか惡い
70 -- のか?直勸的には駄目さうに思へるが、そんな記述は見
72 contents <- many (lws <|> many1 text)
74 let value = foldr (++) "" contents
75 return (name, normalize value)
77 normalize :: String -> String
78 normalize = trimBody . trim isWhiteSpace
80 trimBody = foldr (++) []
81 . map (\ s -> if head s == ' ' then
86 . map (\ c -> if isWhiteSpace c
91 hPutHeaders :: Handle -> Headers -> IO ()
92 hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n"
94 putH (name, value) = do hPutStr h name