module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) , emptyHeaders -- Headers , headersP -- Parser Headers , hPutHeaders -- Handle -> Headers -> IO () ) where import Data.Char import Data.List import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import System.IO type Headers = [ (String, String) ] class HasHeaders a where getHeaders :: a -> Headers setHeaders :: a -> Headers -> a getHeader :: a -> String -> Maybe String getHeader a key = fmap snd $ find (noCaseEq key . fst) (getHeaders a) deleteHeader :: a -> String -> a deleteHeader a key = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a) addHeader :: a -> String -> String -> a addHeader a key val = setHeaders a $ (getHeaders a) ++ [(key, val)] setHeader :: a -> String -> String -> a setHeader a key val = let list = getHeaders a deleted = filter (not . noCaseEq key . fst) list added = deleted ++ [(key, val)] in setHeaders a added emptyHeaders :: Headers emptyHeaders = [] {- message-header = field-name ":" [ field-value ] field-name = token field-value = *( field-content | LWS ) field-content = 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"