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 96863f044dad4c803bdd42360e27d67cac5b8105..8942c762da36fa8104efe762288d1de33f0a6721 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -74,11 +74,14 @@ module Network.HTTP.Lucu.Resource
     , getRequest
     , getMethod
     , getRequestURI
+    , getRequestVersion
     , getResourcePath
     , getPathInfo
     , getQueryForm
     , getHeader
     , getAccept
+    , getAcceptEncoding
+    , isEncodingAcceptable
     , getContentType
 
     -- ** Finding an entity
@@ -111,6 +114,7 @@ module Network.HTTP.Lucu.Resource
     , redirect
     , setContentType
     , setLocation
+    , setContentEncoding
 
     -- ** Writing a response body
 
@@ -132,9 +136,9 @@ import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Data.List
 import           Data.Maybe
-import           GHC.Conc (unsafeIOToSTM)
 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
@@ -204,6 +208,11 @@ getRequestURI :: Resource URI
 getRequestURI = do req <- getRequest
                    return $! reqURI req
 
+-- |Get the HTTP version of the request.
+getRequestVersion :: Resource HttpVersion
+getRequestVersion = do req <- getRequest
+                       return $! reqVersion req
+
 -- |Get the path of this 'Resource' (to be exact,
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
@@ -265,25 +274,62 @@ getHeader name = name `seq`
 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
 -- header \"Accept\".
 getAccept :: Resource [MIMEType]
-getAccept = do accept <- getHeader "Accept"
-               if accept == Nothing then
-                   return []
-                 else
-                   case parseStr mimeTypeListP $ fromJust accept of
-                     (Success xs, _) -> return xs
-                     _               -> return []
+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\". The list is sorted in descending order by
+-- qvalue.
+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 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'.
 getContentType :: Resource (Maybe MIMEType)
-getContentType = do cType <- getHeader "Content-Type"
-                    if cType == Nothing then
-                        return Nothing
-                      else
-                        case parseStr mimeTypeP $ fromJust cType of
-                          (Success t, _) -> return $ Just t
-                          _              -> return Nothing
-
+getContentType
+    = do cTypeM <- getHeader "Content-Type"
+         case cTypeM of
+           Nothing
+               -> return Nothing
+           Just cType
+               -> case parseStr mimeTypeP cType of
+                    (# Success t, _ #) -> return $ Just t
+                    (# _        , _ #) -> abort BadRequest []
+                                          (Just $ "Unparsable Content-Type: " ++ cType)
 
 
 {- ExaminingRequest 時に使用するアクション群 -}
@@ -342,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
@@ -361,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
 
@@ -705,6 +753,16 @@ setLocation :: URI -> Resource ()
 setLocation uri
     = setHeader "Location" $ uriToString id uri $ ""
 
+-- |Computation of @'setContentEncoding' codings@ sets the response
+-- header \"Content-Encoding\" to @codings@.
+setContentEncoding :: [String] -> Resource ()
+setContentEncoding 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 時に使用するアクション群 -}