getRequestURI should always return an absolute URI

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

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 4ed161fafc39c41ed0ed324100042430b674f8a2..d468d2b482baaa09da6af0289ba31e4067d1929a 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -168,7 +168,8 @@ findResource (ResNode rootDefM subtree) uri
 runResource :: ResourceDef -> Interaction -> IO ThreadId
 runResource def itr
     = fork
-      $ catch ( runReaderT ( do fromMaybe notAllowed rsrc 
+      $ catch ( runReaderT ( do req <- getRequest
+                                fromMaybe notAllowed $ rsrc req
                                 driftTo Done
                            ) itr
               )
@@ -179,15 +180,16 @@ runResource def itr
              then forkOS
              else forkIO
       
-      rsrc :: Maybe (Resource ())
-      rsrc = case reqMethod $ fromJust $ itrRequest itr of
-               GET    -> resGet def
-               HEAD   -> case resHead def of
-                           Just r  -> Just r
-                           Nothing -> resGet def
-               POST   -> resPost def
-               PUT    -> resPut def
-               DELETE -> resDelete def
+      rsrc :: Request -> Maybe (Resource ())
+      rsrc req
+          = case reqMethod req of
+              GET    -> resGet def
+              HEAD   -> case resHead def of
+                          Just r  -> Just r
+                          Nothing -> resGet def
+              POST   -> resPost def
+              PUT    -> resPut def
+              DELETE -> resDelete def
 
       notAllowed :: Resource ()
       notAllowed = do setStatus MethodNotAllowed
@@ -218,11 +220,11 @@ runResource def itr
                                                          $ Just $ show exc
                            _                 -> Abortion InternalServerError [] $ Just $ show exc
                    conf = itrConfig itr
-                   reqM = itrRequest itr
                -- まだ DecidingHeader 以前の状態だったら、この途中終了
                -- を應答に反映させる餘地がある。さうでなければ stderr
                -- にでも吐くしか無い。
                state <- atomically $ readItr itr itrState id
+               reqM  <- atomically $ readItr itr itrRequest id
                res   <- atomically $ readItr itr itrResponse id
                if state <= DecidingHeader then
                    flip runReaderT itr