The parser now returns unboxed tuple.

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index fcf23593e9ee89ca83d8c3e768242740c79ed717..8942c762da36fa8104efe762288d1de33f0a6721 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
@@ -280,12 +280,13 @@ getAccept = do acceptM <- getHeader "Accept"
                      -> return []
                  Just accept
                      -> case parseStr mimeTypeListP accept of
-                          (Success xs, _) -> return xs
-                          _               -> abort BadRequest []
-                                             (Just $ "Unparsable Accept: " ++ accept)
+                          (# Success xs, _ #) -> return xs
+                          (# _         , _ #) -> abort BadRequest []
+                                                 (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
-                    _              -> 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
+               -> case parseStr acceptEncodingListP accEnc of
+                    (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
+                    (# _        , _ #) -> abort BadRequest []
+                                          (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
+
+-- |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'.
@@ -336,9 +327,9 @@ getContentType
                -> return Nothing
            Just cType
                -> case parseStr mimeTypeP cType of
-                    (Success t, _) -> return $ Just t
-                    _              -> abort BadRequest []
-                                      (Just $ "Unparsable Content-Type: " ++ cType)
+                    (# Success t, _ #) -> return $ Just t
+                    (# _        , _ #) -> abort BadRequest []
+                                          (Just $ "Unparsable Content-Type: " ++ cType)
 
 
 {- ExaminingRequest 時に使用するアクション群 -}
@@ -397,13 +388,14 @@ foundETag tag
            Nothing   -> return ()
            Just "*"  -> return ()
            Just list -> case parseStr eTagListP list of
-                          (Success tags, _)
+                          (# Success tags, _ #)
                               -- tags の中に一致するものが無ければ
                               -- PreconditionFailed で終了。
                               -> when (not $ any (== tag) tags)
                                  $ abort PreconditionFailed []
                                        $! Just ("The entity tag doesn't match: " ++ list)
-                          _   -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
+                          (# _, _ #)
+                              -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
 
          let statusForNoneMatch = if method == GET || method == HEAD then
                                       NotModified
@@ -416,10 +408,11 @@ foundETag tag
            Nothing   -> return ()
            Just "*"  -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
            Just list -> case parseStr eTagListP list of
-                          (Success tags, _)
+                          (# Success tags, _ #)
                               -> when (any (== tag) tags)
                                  $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
-                          _   -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
+                          (# _, _ #)
+                              -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
 
          driftTo GettingBody
 
@@ -764,7 +757,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 時に使用するアクション群 -}