-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 = foldr (++) []
- . map (\ s -> if head s == ' ' then
- " "
- else
- s)
- . group
- . 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"
+instance Parsable ByteString Headers where
+ {-# INLINEABLE parser #-}
+ parser = do xs ← many header
+ crlf
+ return $ fromFoldable xs
+ where
+ header ∷ Parser (CIAscii, Ascii)
+ {-# INLINEABLE header #-}
+ header = do name ← cs <$> token
+ void $ char ':'
+ skipMany lws
+ values ← content `sepBy` try lws
+ skipMany (try lws)
+ crlf
+ return (name, joinValues values)
+
+ content ∷ Parser Ascii
+ {-# INLINEABLE content #-}
+ content = A.unsafeFromByteString
+ <$>
+ takeWhile1 (\c → isText c ∧ c ≢ '\x20')
+
+ joinValues ∷ [Ascii] → Ascii
+ {-# INLINEABLE joinValues #-}
+ joinValues = cs
+ ∘ mconcat
+ ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)
+ ∘ (cs <$>)