staticDir

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 28ce4628901a8380a3e48e578657b143cf778a0d..7b1b26a0dd08ea9423f3f895395d0e6a45c2c145 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 ()
@@ -67,9 +72,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)
@@ -414,18 +447,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