Added inputForm

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 28ce4628901a8380a3e48e578657b143cf778a0d..d01fd1c8d3ee27d7f7591b89ceaad28c0cb6430f 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,10 +1,15 @@
 module Network.HTTP.Lucu.Resource
     ( Resource
 
-    , getConfig -- Resource Config
-    , getMethod -- Resource Method
-    , getHeader -- String -> Resource (Maybe String)
-    , getAccept -- Resource [MIMEType]
+    , getConfig       -- Resource Config
+    , getRequest      -- Resource Request
+    , getMethod       -- Resource Method
+    , getRequestURI   -- Resource URI
+    , getResourcePath -- Resource [String]
+    , getPathInfo     -- Resource [String]
+
+    , getHeader   -- String -> Resource (Maybe String)
+    , getAccept   -- Resource [MIMEType]
     , getContentType -- Resource (Maybe MIMEType)
 
     , foundEntity    -- ETag -> ClockTime -> Resource ()
@@ -16,6 +21,7 @@ module Network.HTTP.Lucu.Resource
     , inputChunk   -- Int -> Resource String
     , inputBS      -- Int -> Resource ByteString
     , inputChunkBS -- Int -> Resource ByteString
+    , inputForm    -- Int -> Resource [(String, String)]
     , defaultLimit -- Int
 
     , setStatus -- StatusCode -> Resource ()
@@ -67,9 +73,37 @@ getConfig = do itr <- ask
                return $ itrConfig itr
 
 
+getRequest :: Resource Request
+getRequest = do itr <- ask
+                return $ fromJust $ itrRequest itr
+
+
 getMethod :: Resource Method
-getMethod = do itr <- ask
-               return $ reqMethod $ fromJust $ itrRequest itr
+getMethod = do req <- getRequest
+               return $ reqMethod req
+
+
+getRequestURI :: Resource URI
+getRequestURI = do req <- getRequest
+                   return $ reqURI req
+
+
+getResourcePath :: Resource [String]
+getResourcePath = do itr <- ask
+                     return $ fromJust $ itrResourcePath itr
+
+
+getPathInfo :: Resource [String]
+getPathInfo = do rsrcPath <- getResourcePath
+                 reqURI   <- getRequestURI
+                 let reqPathStr = uriPath reqURI
+                     reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
+                 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
+                 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
+                 -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
+                 -- ければこの Resource が撰ばれた筈が無い）ので、
+                 -- rsrcPath の長さの分だけ削除すれば良い。
+                 return $ drop (length rsrcPath) reqPath
 
 
 getHeader :: String -> Resource (Maybe String)
@@ -325,6 +359,35 @@ inputChunkBS limit
                return chunk
 
 
+-- application/x-www-form-urlencoded または multipart/form-data をパー
+-- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の
+-- タイプであったら UnsupportedMediaType で終了する。
+inputForm :: Int -> Resource [(String, String)]
+inputForm limit
+    = do cTypeM <- getContentType
+         case cTypeM of
+           Nothing
+               -> abort BadRequest [] (Just "Missing Content-Type")
+           Just (MIMEType "application" "x-www-form-urlencoded" _)
+               -> readWWWFormURLEncoded
+           Just (MIMEType "multipart" "form-data" _)
+               -> readMultipartFormData
+           Just cType
+               -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
+                                                          ++ show cType)
+    where
+      readWWWFormURLEncoded
+          = do src <- input limit
+               return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
+                           let pair = break (== '=') pairStr
+                           return ( unEscapeString $ fst pair
+                                  , unEscapeString $ snd pair
+                                  )
+      readMultipartFormData -- FIXME: 未對應
+          = abort UnsupportedMediaType []
+            (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
+
+
 defaultLimit :: Int
 defaultLimit = (-1)
 
@@ -414,18 +477,22 @@ outputChunk = outputChunkBS . B.pack
 outputChunkBS :: ByteString -> Resource ()
 outputChunkBS str
     = do driftTo DecidingBody
-         unless (B.null str)
-                    $ do itr <- ask
+         itr <- ask
+         
+         let limit = cnfMaxOutputChunkLength $ itrConfig itr
+         when (limit <= 0)
+                  $ fail ("cnfMaxOutputChunkLength must be positive: "
+                          ++ show limit)
 
-                         let limit = cnfMaxOutputChunkLength $ itrConfig itr
-                         when (limit <= 0)
-                                  $ fail ("cnfMaxOutputChunkLength must be positive: "
-                                          ++ show limit)
+         discardBody <- liftIO $ atomically $
+                        readItr itr itrWillDiscardBody id
 
-                         sendChunks str limit
+         unless (discardBody)
+                    $ sendChunks str limit
 
-                         liftIO $ atomically $
-                                writeItr itr itrBodyIsNull False
+         unless (B.null str)
+                    $ liftIO $ atomically $
+                      writeItr itr itrBodyIsNull False
     where
       sendChunks :: ByteString -> Int -> Resource ()
       sendChunks str limit