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
27 fmap snd $ find (noCaseEq' key . fst) (getHeaders a)
29 deleteHeader :: String -> a -> a
32 setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a)
34 addHeader :: String -> String -> a -> a
36 = key `seq` val `seq` a `seq`
37 setHeaders a $ (getHeaders a) ++ [(key, val)]
39 setHeader :: String -> String -> a -> a
41 = key `seq` val `seq` a `seq`
42 let list = getHeaders a
43 deleted = filter (not . noCaseEq' key . fst) list
44 added = deleted ++ [(key, val)]
48 emptyHeaders :: Headers
53 message-header = field-name ":" [ field-value ]
55 field-value = *( field-content | LWS )
56 field-content = <field-value を構成し、*TEXT あるいは
57 token, separators, quoted-string を連結
60 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
63 headersP :: Parser Headers
64 headersP = do xs <- many header
68 header :: Parser (String, String)
69 header = do name <- token
71 -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
72 -- の記述はひどく曖昧であり、この動作が本當に間違って
73 -- ゐるのかどうかも良く分からない。例へば
74 -- quoted-string の内部にある空白は纏めていいのか惡い
75 -- のか?直勸的には駄目さうに思へるが、そんな記述は見
77 contents <- many (lws <|> many1 text)
79 let value = foldr (++) "" contents
80 return (name, normalize value)
82 normalize :: String -> String
83 normalize = trimBody . trim isWhiteSpace
85 trimBody = foldr (++) []
86 . map (\ s -> if head s == ' ' then
91 . map (\ c -> if isWhiteSpace c
96 hPutHeaders :: Handle -> Headers -> IO ()
99 mapM_ putH hds >> hPutStr h "\r\n"
101 putH :: (String, String) -> IO ()
103 = name `seq` value `seq`