2 module Network.HTTP.Lucu.Headers
13 import Network.HTTP.Lucu.Parser
14 import Network.HTTP.Lucu.Parser.Http
15 import Network.HTTP.Lucu.Utils
18 type Headers = [ (String, String) ]
20 class HasHeaders a where
21 getHeaders :: a -> Headers
22 setHeaders :: a -> Headers -> a
24 getHeader :: String -> a -> Maybe String
26 = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
28 deleteHeader :: String -> a -> a
30 = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
32 addHeader :: String -> String -> a -> a
34 = setHeaders a $ (getHeaders a) ++ [(key, val)]
36 setHeader :: String -> String -> a -> a
38 = let list = getHeaders a
39 deleted = filter (not . noCaseEq key . fst) list
40 added = deleted ++ [(key, val)]
44 emptyHeaders :: Headers
49 message-header = field-name ":" [ field-value ]
51 field-value = *( field-content | LWS )
52 field-content = <field-value を構成し、*TEXT あるいは
53 token, separators, quoted-string を連結
56 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
59 headersP :: Parser Headers
60 headersP = do xs <- many header
64 header :: Parser (String, String)
65 header = do name <- token
67 -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
68 -- の記述はひどく曖昧であり、この動作が本當に間違って
69 -- ゐるのかどうかも良く分からない。例へば
70 -- quoted-string の内部にある空白は纏めていいのか惡い
71 -- のか?直勸的には駄目さうに思へるが、そんな記述は見
73 contents <- many (lws <|> many1 text)
75 let value = foldr (++) "" contents
76 return (name, normalize value)
78 normalize :: String -> String
79 normalize = trimBody . trim isWhiteSpace
81 trimBody = foldr (++) []
82 . map (\ s -> if head s == ' ' then
87 . map (\ c -> if isWhiteSpace c
92 hPutHeaders :: Handle -> Headers -> IO ()
93 hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n"
95 putH (name, value) = do hPutStr h name