Say good bye to the ugliness of "text" </> "plain".

[Lucu.git] / Network / HTTP / Lucu / Resource.hs

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index fcf23593e9ee89ca83d8c3e768242740c79ed717..7b64629bf832245669effa0acd8d55c5cc045a9c 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -81,6 +81,7 @@ module Network.HTTP.Lucu.Resource
     , getHeader
     , getAccept
     , getAcceptEncoding
+    , isEncodingAcceptable
     , getContentType
 
     -- ** Finding an entity
@@ -133,18 +134,17 @@ import           Control.Monad.Reader
 import           Data.Bits
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
-import           Data.Char
 import           Data.List
 import           Data.Maybe
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.ContentCoding
 import           Network.HTTP.Lucu.DefaultPage
 import           Network.HTTP.Lucu.ETag
 import qualified Network.HTTP.Lucu.Headers as H
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
 import           Network.HTTP.Lucu.Postprocess
 import           Network.HTTP.Lucu.RFC1123DateTime
 import           Network.HTTP.Lucu.Request
@@ -285,7 +285,8 @@ getAccept = do acceptM <- getHeader "Accept"
                                              (Just $ "Unparsable Accept: " ++ accept)
 
 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
--- \"Accept-Encoding\".
+-- \"Accept-Encoding\". The list is sorted in descending order by
+-- qvalue.
 getAcceptEncoding :: Resource [(String, Maybe Double)]
 getAcceptEncoding
     = do accEncM <- getHeader "Accept-Encoding"
@@ -303,28 +304,18 @@ getAcceptEncoding
                -- identity のみが許される。
                -> return [("identity", Nothing)]
            Just accEnc
-               -> case parseStr accEncListP accEnc of
-                    (Success x, _) -> return x
+               -> case parseStr acceptEncodingListP accEnc of
+                    (Success x, _) -> return $ reverse $ sortBy orderAcceptEncodings 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
+
+-- |Check whether a given content-coding is acceptable.
+isEncodingAcceptable :: String -> Resource Bool
+isEncodingAcceptable coding
+    = do accList <- getAcceptEncoding
+         return (flip any accList $ \ (c, q) ->
+                     (c == "*" || c `noCaseEq` coding) && q /= Just 0)
+
 
 -- |Get the header \"Content-Type\" as
 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
@@ -764,7 +755,11 @@ setLocation uri
 -- header \"Content-Encoding\" to @codings@.
 setContentEncoding :: [String] -> Resource ()
 setContentEncoding codings
-    = setHeader "Content-Encoding" $ joinWith ", " codings
+    = do ver <- getRequestVersion
+         let tr = case ver of
+                    HttpVersion 1 0 -> unnormalizeCoding
+                    HttpVersion 1 1 -> id
+         setHeader "Content-Encoding" $ joinWith ", " $ map tr codings
 
 
 {- DecidingBody 時に使用するアクション群 -}