X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=7b64629bf832245669effa0acd8d55c5cc045a9c;hb=11c3854540c46bfcd9e88c2164ed554f3b6550a5;hp=96863f044dad4c803bdd42360e27d67cac5b8105;hpb=858129cb755aa09da2b7bd758efb8519f2c89103;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 96863f0..7b64629 100644
--- 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 時に使用するアクション群 -}
@@ -705,6 +751,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 時に使用するアクション群 -}