+getAccept = do acceptM <- getHeader (C8.pack "Accept")
+ case acceptM of
+ Nothing
+ -> return []
+ Just accept
+ -> case parse mimeTypeListP (L8.fromChunks [accept]) of
+ (# Success xs, _ #) -> return xs
+ (# _ , _ #) -> abort BadRequest []
+ (Just $ "Unparsable Accept: " ++ C8.unpack accept)
+
+-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
+-- \"Accept-Encoding\". The list is sorted in descending order by
+-- qvalue.
+getAcceptEncoding :: Resource [(String, Maybe Double)]
+getAcceptEncoding
+ = do accEncM <- getHeader (C8.pack "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)]
+ _ -> undefined
+ Just value
+ -> if C8.null value then
+ -- identity のみが許される。
+ return [("identity", Nothing)]
+ else
+ case parse acceptEncodingListP (L8.fromChunks [value]) of
+ (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
+ (# _ , _ #) -> abort BadRequest []
+ (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
+
+-- |Check whether a given content-coding is acceptable.
+isEncodingAcceptable :: String -> Resource Bool
+isEncodingAcceptable coding
+ = do accList <- getAcceptEncoding
+ return (flip any accList $ \ (c, q) ->
+ (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
+
+
+-- |Get the header \"Content-Type\" as
+-- 'Network.HTTP.Lucu.MIMEType.MIMEType'.