From: pho <pho@cielonegro.org>
Date: Tue, 2 Oct 2007 14:59:00 +0000 (+0900)
Subject: Added new actions to the Resource.
X-Git-Tag: RELEASE-0_2_1~34
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=636a3b3334f1ede61dc1e6faa2c4a021ea9bbd5c;p=Lucu.git

Added new actions to the Resource.

darcs-hash:20071002145900-62b54-89be9254e0b4e65f57b3248fb40ae6d2ee264908.gz
---

diff --git a/Lucu.cabal b/Lucu.cabal
index 22a64f0..0fb5c07 100644
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -17,7 +17,7 @@ Homepage: http://ccm.sherry.jp/lucu/
 Category: Network
 Tested-With: GHC == 6.6.1
 Build-Depends:
-         base, mtl, network, stm, hxt, haskell-src, unix
+        base, mtl, network, stm, hxt, haskell-src, unix
 Exposed-Modules:
         Network.HTTP.Lucu
         Network.HTTP.Lucu.Abortion
@@ -52,8 +52,12 @@ Extra-Source-Files:
         data/mime.types
         examples/HelloWorld.hs
         examples/Makefile
-ghc-options: -fglasgow-exts -fwarn-missing-signatures -fwarn-unused-imports -funbox-strict-fields -O3
---ghc-options: -fglasgow-exts
+ghc-options:
+        -fglasgow-exts
+        -fwarn-missing-signatures
+        -fwarn-unused-imports
+        -funbox-strict-fields
+        -O3
 
 
 --Executable: HelloWorld
diff --git a/Makefile b/Makefile
index 7c0b30e..6b4ad4d 100644
--- a/Makefile
+++ b/Makefile
@@ -9,6 +9,7 @@ run: build
 	$(MAKE) -C examples run
 
 .setup-config: $(CABAL_FILE) Setup
+#	./Setup configure
 	./Setup configure -p
 
 Setup: Setup.hs
diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index cb21d29..77dbe7f 100644
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -13,13 +13,14 @@ module Network.HTTP.Lucu.Parser.Http
     , text
     , separator
     , quotedStr
+    , qvalue
     )
     where
 
 import           Data.List
 import           Network.HTTP.Lucu.Parser
 
--- |@'isCtl' c@ is True iff @0x20 <= @c@ < 0x7F@.
+-- |@'isCtl' c@ is False iff @0x20 <= @c@ < 0x7F@.
 isCtl :: Char -> Bool
 isCtl c
     | c <  '\x1f' = True
@@ -105,3 +106,19 @@ quotedStr = do char '"'
       quotedPair = do q <- char '\\'
                       c <- satisfy isChar
                       return [c]
+
+-- |'qvalue' accepts a so-called qvalue.
+qvalue :: Parser Double
+qvalue = do x  <- char '0'
+            xs <- option ""
+                  $ do x  <- char '.'
+                       xs <- many digit -- 本當は三文字までに制限
+                       return (x:xs)
+            return $ read (x:xs)
+         <|>
+         do x  <- char '1'
+            xs <- option ""
+                  $ do x  <- char '.'
+                       xs <- many (char '0') -- 本當は三文字までに制限
+                       return (x:xs)
+            return $ read (x:xs)
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index bacb00f..fcf2359 100644
--- 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 時に使用するアクション群 -}
 
diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index d6e46f1..d92516e 100644
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -25,7 +25,7 @@ splitBy isSeparator src
       of (last , []      ) -> last  : []
          (first, sep:rest) -> first : splitBy isSeparator rest
 
--- |> joinWith ':' ["ab", "c", "def"]
+-- |> joinWith ":" ["ab", "c", "def"]
 --  > ==> "ab:c:def"
 joinWith :: [a] -> [[a]] -> [a]
 joinWith separator xs