+getAccept = do acceptM <- getHeader "Accept"
+ case acceptM of
+ Nothing
+ -> return []
+ Just accept
+ -> case parseStr mimeTypeListP accept of
+ (Success xs, _) -> return xs
+ _ -> abort BadRequest []
+ (Just $ "Unparsable Accept: " ++ accept)
+
+-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
+-- \"Accept-Encoding\".
+getAcceptEncoding :: Resource [(String, Maybe Double)]
+getAcceptEncoding
+ = do accEncM <- getHeader "Accept-Encoding"
+ case accEncM of
+ Nothing
+ -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
+ -- ので安全の爲 identity が指定された事にする。HTTP/1.1
+ -- の場合は何でも受け入れて良い事になってゐるので "*" が
+ -- 指定された事にする。
+ -> do ver <- getRequestVersion
+ case ver of
+ HttpVersion 1 0 -> return [("identity", Nothing)]
+ HttpVersion 1 1 -> return [("*" , Nothing)]
+ Just ""
+ -- identity のみが許される。
+ -> return [("identity", Nothing)]
+ Just accEnc
+ -> case parseStr accEncListP accEnc of
+ (Success x, _) -> return x
+ _ -> abort BadRequest []
+ (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
+ where
+ accEncListP :: Parser [(String, Maybe Double)]
+ accEncListP = allowEOF $! listOf accEncP
+
+ accEncP :: Parser (String, Maybe Double)
+ accEncP = do coding <- token
+ qVal <- option Nothing
+ $ do string ";q="
+ q <- qvalue
+ return $ Just q
+ return (normalizeCoding coding, qVal)
+
+ normalizeCoding :: String -> String
+ normalizeCoding coding
+ = case map toLower coding of
+ "x-gzip" -> "gzip"
+ "x-compress" -> "compress"
+ other -> other
+
+-- |Get the header \"Content-Type\" as
+-- 'Network.HTTP.Lucu.MIMEType.MIMEType'.