getRequestURI should always return an absolute URI

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 6f76e88811734508c1da16337712f7b7760577f3..071ab56b1ea3f7e5f8770e803268f166c24c2c4d 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -56,7 +56,8 @@ import           System.Time
 
 postprocess :: Interaction -> STM ()
 postprocess itr
-    = do res <- readItr itr itrResponse id
+    = do reqM <- readItr itr itrRequest id
+         res  <- readItr itr itrResponse id
          let sc = resStatus res
 
          when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
@@ -72,7 +73,7 @@ postprocess itr
                   $ abortSTM InternalServerError []
                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
 
-         when (itrRequest itr /= Nothing)
+         when (reqM /= Nothing)
               $ relyOnRequest itr
 
          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
@@ -85,9 +86,9 @@ postprocess itr
       relyOnRequest :: Interaction -> STM ()
       relyOnRequest itr
           = do status <- readItr itr itrResponse resStatus
+               req    <- readItr itr itrRequest fromJust
 
-               let req         = fromJust $ itrRequest itr
-                   reqVer      = reqVersion req
+               let reqVer      = reqVersion req
                    canHaveBody = if reqMethod req == HEAD then
                                      False
                                  else