+{-
+ message-header = field-name ":" [ field-value ]
+ field-name = token
+ field-value = *( field-content | LWS )
+ field-content = <field-value を構成し、*TEXT あるいは
+ token, separators, quoted-string を連結
+ したものから成る OCTET>
+
+ field-value の先頭および末尾にある LWS は全て削除され、それ以外の
+ LWS は單一の SP に變換される。
+-}
+headersP :: Parser Headers
+headersP = do xs <- many header
+ crlf
+ return xs
+ where
+ header :: Parser (String, String)
+ header = do name <- token
+ char ':'
+ -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
+ -- の記述はひどく曖昧であり、この動作が本當に間違って
+ -- ゐるのかどうかも良く分からない。例へば
+ -- quoted-string の内部にある空白は纏めていいのか惡い
+ -- のか?直勸的には駄目さうに思へるが、そんな記述は見
+ -- 付からない。
+ contents <- many (lws <|> many1 text)
+ crlf
+ let value = foldr (++) "" contents
+ return (name, normalize value)
+
+ normalize :: String -> String
+ normalize = trimBody . trim isWhiteSpace
+
+ trimBody = nubBy (\ a b -> a == ' ' && b == ' ')
+ . map (\ c -> if isWhiteSpace c
+ then ' '
+ else c)
+
+
+hPutHeaders :: Handle -> Headers -> IO ()
+hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n"
+ where
+ putH (name, value) = do hPutStr h name
+ hPutStr h ": "
+ hPutStr h value
+ hPutStr h "\r\n"