getRequestURI should always return an absolute URI

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 1f26ec40c095c9af4c0718e1f95525de5abdb94d..7c1ceb0f027ee03d7aacbdb565cb81b16944a237 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -108,6 +108,7 @@ module Network.HTTP.Lucu.Resource
     , setHeader
     , redirect
     , setContentType
+    , setLocation
 
     -- ** Writing a response body
 
@@ -161,7 +162,8 @@ getConfig = do itr <- ask
 -- the request header. In general you don't have to use this action.
 getRequest :: Resource Request
 getRequest = do itr <- ask
-                return $ fromJust $ itrRequest itr
+                req <- liftIO $ atomically $ readItr itr itrRequest fromJust
+                return req
 
 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
 getMethod :: Resource Method
@@ -227,8 +229,8 @@ getQueryForm = do reqURI <- getRequestURI
 -- so frequently: there should be actions like 'getContentType' for
 -- every common headers.
 getHeader :: String -> Resource (Maybe String)
-getHeader name = do itr <- ask
-                    return $ H.getHeader name $ fromJust $ itrRequest itr
+getHeader name = do req <- getRequest
+                    return $ H.getHeader name req
 
 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
 -- header \"Accept\".
@@ -392,17 +394,13 @@ foundTimeStamp timeStamp
 --
 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
 -- test and aborts with status \"412 Precondition Failed\" when it
--- failed. If this is a GET, HEAD or DELETE request, 'foundNoEntity'
--- always aborts with status \"404 Not Found\". It is an error to
--- compute 'foundNoEntity' if this is a POST request.
+-- failed. If this is a GET, HEAD, POST or DELETE request,
+-- 'foundNoEntity' always aborts with status \"404 Not Found\".
 foundNoEntity :: Maybe String -> Resource ()
 foundNoEntity msgM
     = do driftTo ExaminingRequest
 
          method <- getMethod
-         when (method == POST)
-                  $ abort InternalServerError []
-                        (Just "Illegal computation of foundNoEntity for POST request.")
          when (method /= PUT)
                   $ abort NotFound [] msgM
 
@@ -645,7 +643,7 @@ redirect code uri
                   $ abort InternalServerError []
                         $ Just ("Attempted to redirect with status " ++ show code)
          setStatus code
-         setHeader "Location" (uriToString id uri $ "")
+         setLocation uri
 
 -- | Computation of @'setContentType' mType@ sets the response header
 -- \"Content-Type\" to @mType@.
@@ -653,6 +651,12 @@ setContentType :: MIMEType -> Resource ()
 setContentType mType
     = setHeader "Content-Type" $ show mType
 
+-- | Computation of @'setLocation' uri@ sets the response header
+-- \"Location\" to @uri@.
+setLocation :: URI -> Resource ()
+setLocation uri
+    = setHeader "Location" $ uriToString id uri $ ""
+
 
 {- DecidingBody 時に使用するアクション群 -}