Added new actions to the Resource.

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index bacb00f2c6f7c1a1101c4069b5d860899791ddd4..fcf23593e9ee89ca83d8c3e768242740c79ed717 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -74,11 +74,13 @@ module Network.HTTP.Lucu.Resource
     , getRequest
     , getMethod
     , getRequestURI
+    , getRequestVersion
     , getResourcePath
     , getPathInfo
     , getQueryForm
     , getHeader
     , getAccept
+    , getAcceptEncoding
     , getContentType
 
     -- ** Finding an entity
@@ -111,6 +113,7 @@ module Network.HTTP.Lucu.Resource
     , redirect
     , setContentType
     , setLocation
+    , setContentEncoding
 
     -- ** Writing a response body
 
@@ -130,6 +133,7 @@ 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
@@ -137,8 +141,10 @@ import           Network.HTTP.Lucu.Config
 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
@@ -202,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
@@ -263,25 +274,71 @@ 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\".
+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 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
 
 -- |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 時に使用するアクション群 -}
@@ -703,6 +760,12 @@ 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
+    = setHeader "Content-Encoding" $ joinWith ", " codings
+
 
 {- DecidingBody 時に使用するアクション群 -}