1 module Network.HTTP.Lucu.Headers
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
26 fmap snd $ find (noCaseEq' key . fst) (getHeaders a)
28 deleteHeader :: String -> a -> a
31 setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a)
33 addHeader :: String -> String -> a -> a
35 = key `seq` val `seq` a `seq`
36 setHeaders a $ (getHeaders a) ++ [(key, val)]
38 setHeader :: String -> String -> a -> a
40 = key `seq` val `seq` a `seq`
41 let list = getHeaders a
42 deleted = filter (not . noCaseEq' key . fst) list
43 added = deleted ++ [(key, val)]
47 emptyHeaders :: Headers
52 message-header = field-name ":" [ field-value ]
54 field-value = *( field-content | LWS )
55 field-content = <field-value を構成し、*TEXT あるいは
56 token, separators, quoted-string を連結
59 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
62 headersP :: Parser Headers
63 headersP = do xs <- many header
67 header :: Parser (String, String)
68 header = do name <- token
70 -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
71 -- の記述はひどく曖昧であり、この動作が本當に間違って
72 -- ゐるのかどうかも良く分からない。例へば
73 -- quoted-string の内部にある空白は纏めていいのか惡い
74 -- のか?直勸的には駄目さうに思へるが、そんな記述は見
76 contents <- many (lws <|> many1 text)
78 let value = foldr (++) "" contents
79 return (name, normalize value)
81 normalize :: String -> String
82 normalize = trimBody . trim isWhiteSpace
84 trimBody = foldr (++) []
85 . map (\ s -> if head s == ' ' then
90 . map (\ c -> if isWhiteSpace c
95 hPutHeaders :: Handle -> Headers -> IO ()
98 mapM_ putH hds >> hPutStr h "\r\n"
100 putH :: (String, String) -> IO ()
102 = name `seq` value `seq`