X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=fa08fa5c3450c28b2131c7aa3320da814afa4e21;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=e456fd278d93c976834a2ad993d3c1545413ddc6;hpb=b0efa668bb881d1c9db4b852b1b9063a2db12b3d;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index e456fd2..fa08fa5 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE
+    UnboxedTuples
+  , UnicodeSyntax
+  #-}
 {-# OPTIONS_HADDOCK prune #-}
 
 -- |This is the Resource Monad; monadic actions to define the behavior
@@ -60,7 +64,7 @@
 
 module Network.HTTP.Lucu.Resource
     (
-    -- * Monad
+    -- * Types
       Resource
     , FormData(..)
     , runRes -- private
@@ -146,6 +150,7 @@ import           Data.Char
 import           Data.List
 import           Data.Maybe
 import           Data.Time
+import qualified Data.Time.HTTP as HTTP
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Authorization
 import           Network.HTTP.Lucu.Config
@@ -158,7 +163,6 @@ import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.MultipartForm
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
-import           Network.HTTP.Lucu.RFC1123DateTime
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.MIMEType
@@ -285,14 +289,15 @@ getResourcePath = do itr <- getInteraction
                      return $! fromJust $! itrResourcePath itr
 
 
--- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
--- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
--- greedy. See 'getResourcePath'.
+-- |This is an analogy of CGI PATH_INFO. The result is
+-- URI-unescaped. It is always @[]@ if the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
+-- 'getResourcePath'.
 getPathInfo :: Resource [String]
 getPathInfo = do rsrcPath <- getResourcePath
                  uri      <- getRequestURI
                  let reqPathStr = uriPath uri
-                     reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
+                     reqPath    = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""]
                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
@@ -300,20 +305,26 @@ getPathInfo = do rsrcPath <- getResourcePath
                  -- rsrcPath の長さの分だけ削除すれば良い。
                  return $! drop (length rsrcPath) reqPath
 
--- | Assume the query part of request URI as
--- application\/x-www-form-urlencoded, and parse it. This action
--- doesn't parse the request body. See 'inputForm'.
-getQueryForm :: Resource [FormData]
-getQueryForm = do uri <- getRequestURI
-                  return $! map pairToFormData $ parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
-
-pairToFormData :: (String, String) -> FormData
-pairToFormData (name, value)
-    = FormData {
-        fdName     = name
-      , fdFileName = Nothing
-      , fdContent  = L8.pack value
-      }
+-- |Assume the query part of request URI as
+-- application\/x-www-form-urlencoded, and parse it to pairs of
+-- @(name, formData)@. This action doesn't parse the request body. See
+-- 'inputForm'.
+getQueryForm :: Resource [(String, FormData)]
+getQueryForm = liftM parse' getRequestURI
+    where
+      parse' = map toPairWithFormData .
+               parseWWWFormURLEncoded .
+               snd .
+               splitAt 1 .
+               uriQuery
+
+toPairWithFormData :: (String, String) -> (String, FormData)
+toPairWithFormData (name, value)
+    = let fd = FormData {
+                 fdFileName = Nothing
+               , fdContent  = L8.pack value
+               }
+      in (name, fd)
 
 -- |Get a value of given request header. Comparison of header name is
 -- case-insensitive. Note that this action is not intended to be used
@@ -406,7 +417,7 @@ getAuthorization
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. If this is a GET or HEAD request, a found entity means
 -- a datum to be replied. If this is a PUT or DELETE request, it means
--- a datum which was stored for the URI up to now. It is an error to
+-- a datum which was stored for the URI until now. It is an error to
 -- compute 'foundEntity' if this is a POST request.
 --
 -- Computation of 'foundEntity' performs \"If-Match\" test or
@@ -424,10 +435,10 @@ foundEntity tag timeStamp
 
          method <- getMethod
          when (method == GET || method == HEAD)
-                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
+                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
          when (method == POST)
                   $ abort InternalServerError []
-                        (Just "Illegal computation of foundEntity for POST request.")
+                        (Just "Illegal computation of foundEntity for a POST request.")
          foundETag tag
 
          driftTo GettingBody
@@ -506,7 +517,7 @@ foundTimeStamp timeStamp
 
          method <- getMethod
          when (method == GET || method == HEAD)
-                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
+                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
          when (method == POST)
                   $ abort InternalServerError []
                         (Just "Illegal computation of foundTimeStamp for POST request.")
@@ -519,7 +530,7 @@ foundTimeStamp timeStamp
          -- If-Modified-Since があればそれを見る。
          ifModSince <- getHeader (C8.pack "If-Modified-Since")
          case ifModSince of
-           Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
+           Just str -> case HTTP.parse (C8.unpack str) of
                          Just lastTime
                              -> when (timeStamp <= lastTime)
                                 $ abort statusForIfModSince []
@@ -531,7 +542,7 @@ foundTimeStamp timeStamp
          -- If-Unmodified-Since があればそれを見る。
          ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
          case ifUnmodSince of
-           Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
+           Just str -> case HTTP.parse (C8.unpack str) of
                          Just lastTime
                              -> when (timeStamp > lastTime)
                                 $ abort PreconditionFailed []
@@ -725,7 +736,7 @@ inputChunkLBS limit
 -- makes 'Resource' abort with status \"415 Unsupported Media
 -- Type\". If the request has no \"Content-Type\", it aborts with
 -- \"400 Bad Request\".
-inputForm :: Int -> Resource [FormData]
+inputForm :: Int -> Resource [(String, FormData)]
 inputForm limit
     = limit `seq` 
       do cTypeM <- getContentType
@@ -741,8 +752,7 @@ inputForm limit
                                                           ++ show cType)
     where
       readWWWFormURLEncoded
-          = do src <- input limit
-               return $ map pairToFormData $ parseWWWFormURLEncoded src
+          = liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit)
 
       readMultipartFormData params
           = do case find ((== "boundary") . map toLower . fst) params of
@@ -751,7 +761,8 @@ inputForm limit
                  Just (_, boundary)
                      -> do src <- inputLBS limit
                            case parse (multipartFormP boundary) src of
-                             (# Success fdList, _ #) -> return fdList
+                             (# Success formList, _ #)
+                                 -> return formList
                              (# _, _ #)
                                  -> abort BadRequest [] (Just "Unparsable multipart/form-data")