diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 0b995485..a865348b 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -39,11 +39,9 @@ module Yesod.Handler , runRequestBody -- * Special responses -- ** Redirecting - , RedirectType (..) + , RedirectUrl (..) , redirect - , redirectParams - , redirectString - , redirectText + , redirectWith , redirectToPost -- ** Errors , notFound @@ -77,8 +75,6 @@ module Yesod.Handler , deleteSession -- ** Ultimate destination , setUltDest - , setUltDestString - , setUltDestText , setUltDest' , setUltDestReferer , redirectUltDest @@ -298,7 +294,7 @@ data HandlerContents = HCContent H.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath (Maybe W.FilePart) -- FIXME replace FilePath with opaque type from system-filepath? - | HCRedirect RedirectType Text + | HCRedirect H.Status Text | HCCreated Text | HCWai W.Response deriving Typeable @@ -416,10 +412,10 @@ runHandler handler mrender sroute tomr master sub = (ct, c) <- liftIO $ a cts return $ YARPlain status (appEndo headers []) ct c finalSession HCError e -> handleError e - HCRedirect rt loc -> do + HCRedirect status loc -> do let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] return $ YARPlain - (getRedirectStatus rt $ reqWaiRequest rr) hs typePlain emptyContent + status hs typePlain emptyContent finalSession HCSendFile ct fp p -> catch (sendFile' ct fp p) @@ -444,22 +440,28 @@ safeEh er = YesodApp $ \_ _ _ session -> do (toContent ("Internal Server Error" :: S.ByteString)) session --- | Redirect to the given route. -redirect :: RedirectType -> Route master -> GHandler sub master a -redirect rt url = redirectParams rt url [] +-- | Redirect to the given route. The redirect will be a temporary redirect to +-- a GET request. This is the appropriate choice for a get-following-post +-- technique, which should be the usual use case. This function currently uses +-- a 302 status code, though the implementation is free to change in the future +-- to an equivalent code with the same semantics (e.g., 303). +-- +-- If you want direct control of the final status code, or need a different +-- status code, please use 'redirectWith'. +-- +-- Note: According to the HTTP spec, a 302 does /not/ have the semantics +-- described here. However, this has been historically how clients treated a +-- 302. 303 is not understood by older clients, which is why we have opted for +-- a 302. If at some future date it is determined that virtually all clients +-- understand 303, this implementation will switch to that status code. +redirect :: RedirectUrl master url => url -> GHandler sub master a +redirect = redirectWith H.status302 --- | Redirects to the given route with the associated query-string parameters. -redirectParams :: RedirectType -> Route master -> [(Text, Text)] - -> GHandler sub master a -redirectParams rt url params = do - r <- getUrlRenderParams - redirectString rt $ r url params - --- | Redirect to the given URL. -redirectString, redirectText :: RedirectType -> Text -> GHandler sub master a -redirectText rt = liftIO . throwIO . HCRedirect rt -redirectString = redirectText -{-# DEPRECATED redirectString "Use redirectText instead" #-} +-- | Redirect to the given URL with the specified status code. +redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a +redirectWith status url = do + urlText <- toTextUrl url + liftIO $ throwIO $ HCRedirect status urlText ultDestKey :: Text ultDestKey = "_ULT" @@ -468,18 +470,10 @@ ultDestKey = "_ULT" -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. -setUltDest :: Route master -> GHandler sub master () -setUltDest dest = do - render <- getUrlRender - setUltDestString $ render dest - --- | Same as 'setUltDest', but use the given string. -setUltDestText :: Text -> GHandler sub master () -setUltDestText = setSession ultDestKey - -setUltDestString :: Text -> GHandler sub master () -setUltDestString = setSession ultDestKey -{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-} +setUltDest :: RedirectUrl master url => url -> GHandler sub master () +setUltDest url = do + urlText <- toTextUrl url + setSession ultDestKey urlText -- | Same as 'setUltDest', but uses the current page. -- @@ -493,8 +487,7 @@ setUltDest' = do Just r -> do tm <- getRouteToMaster gets' <- reqGetParams `liftM` handlerRequest `liftM` ask - render <- getUrlRenderParams - setUltDestString $ render (tm r) gets' + setUltDest (tm r, gets') -- | Sets the ultimate destination to the referer request header, if present. -- @@ -507,19 +500,22 @@ setUltDestReferer = do (const $ return ()) mdest where - setUltDestBS = setUltDestText . T.pack . S8.unpack + setUltDestBS = setUltDest . T.pack . S8.unpack -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. -- -- The ultimate destination is set with 'setUltDest'. -redirectUltDest :: RedirectType - -> Route master -- ^ default destination if nothing in session +-- +-- This function uses 'redirect', and thus will perform a temporary redirect to +-- a GET request. +redirectUltDest :: RedirectUrl master url + => url -- ^ default destination if nothing in session -> GHandler sub master a -redirectUltDest rt def = do +redirectUltDest def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey - maybe (redirect rt def) (redirectText rt) mdest + maybe (redirect def) redirect mdest -- | Remove a previously set ultimate destination. See 'setUltDest'. clearUltDest :: GHandler sub master () @@ -703,18 +699,26 @@ getStatus (InvalidArgs _) = H.status400 getStatus (PermissionDenied _) = H.status403 getStatus (BadMethod _) = H.status405 -getRedirectStatus :: RedirectType -> W.Request -> H.Status -getRedirectStatus RedirectPermanent _ = H.status301 -getRedirectStatus RedirectTemporary r - | W.httpVersion r == H.http11 = H.status307 - | otherwise = H.status302 -getRedirectStatus RedirectSeeOther _ = H.status303 +-- | Some value which can be turned into a URL for redirects. +class RedirectUrl master a where + -- | Converts the value to the URL and a list of query-string parameters. + toTextUrl :: a -> GHandler sub master Text --- | Different types of redirects. -data RedirectType = RedirectPermanent - | RedirectTemporary - | RedirectSeeOther - deriving (Show, Eq) +instance RedirectUrl master Text where + toTextUrl = return + +instance RedirectUrl master String where + toTextUrl = toTextUrl . T.pack + +instance RedirectUrl master (Route master) where + toTextUrl u = do + r <- getUrlRender + return $ r u + +instance t ~ Text => RedirectUrl master (Route master, [(t, t)]) where + toTextUrl (u, ps) = do + r <- getUrlRenderParams + return $ r u ps localNoCurrent :: GHandler s m a -> GHandler s m a localNoCurrent = @@ -835,8 +839,10 @@ newIdent = do -- POST form, and some Javascript to automatically submit the form. This can be -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. -redirectToPost :: Route master -> GHandler sub master a -redirectToPost dest = hamletToRepHtml +redirectToPost :: RedirectUrl master url => url -> GHandler sub master a +redirectToPost url = do + urlText <- toTextUrl url + hamletToRepHtml #if GHC7 [hamlet| #else @@ -848,7 +854,7 @@ redirectToPost dest = hamletToRepHtml Redirecting... <body onload="document.getElementById('form').submit()"> - <form id="form" method="post" action="@{dest}"> + <form id="form" method="post" action=#{urlText}> <noscript> <p>Javascript has been disabled; please click on the button below to be redirected. <input type="submit" value="Continue"> diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 1db7854a..261566f8 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -375,7 +375,7 @@ defaultYesodRunner handler master sub murl toMasterRoute mkey req = do permissionDenied "Authentication required" Just url' -> do setUltDest' - redirect RedirectTemporary url' + redirect url' Unauthorized s' -> permissionDenied s' handler let sessionMap = Map.fromList diff --git a/yesod-core/test/YesodCoreTest/Exceptions.hs b/yesod-core/test/YesodCoreTest/Exceptions.hs index 0ebda270..2f0e25ef 100644 --- a/yesod-core/test/YesodCoreTest/Exceptions.hs +++ b/yesod-core/test/YesodCoreTest/Exceptions.hs @@ -9,6 +9,7 @@ import Test.Hspec.HUnit () import Yesod.Core hiding (Request) import Network.Wai import Network.Wai.Test +import Network.HTTP.Types (status301) data Y = Y mkYesod "Y" [parseRoutes| @@ -27,7 +28,7 @@ getRootR = error "FOOBAR" >> return () getRedirR :: Handler () getRedirR = do setHeader "foo" "bar" - redirect RedirectPermanent RootR + redirectWith status301 RootR exceptionsTest :: [Spec] exceptionsTest = describe "Test.Exceptions" diff --git a/yesod-core/test/YesodCoreTest/Redirect.hs b/yesod-core/test/YesodCoreTest/Redirect.hs index 9a869a93..914be120 100644 --- a/yesod-core/test/YesodCoreTest/Redirect.hs +++ b/yesod-core/test/YesodCoreTest/Redirect.hs @@ -2,7 +2,7 @@ module YesodCoreTest.Redirect (specs, Widget) where import YesodCoreTest.YesodTest -import Yesod.Handler (RedirectType(..)) +import Yesod.Handler (redirectWith) import qualified Network.HTTP.Types as H data Y = Y @@ -11,6 +11,7 @@ mkYesod "Y" [parseRoutes| /r301 R301 GET /r303 R303 GET /r307 R307 GET +/rregular RRegular GET |] instance Yesod Y where approot _ = "http://test" app :: Session () -> IO () @@ -19,11 +20,11 @@ app = yesod Y getRootR :: Handler () getRootR = return () -getR301, getR303, getR307 :: Handler () -getR301 = redirect RedirectPermanent RootR -getR303 = redirect RedirectSeeOther RootR -getR307 = redirect RedirectTemporary RootR - +getR301, getR303, getR307, getRRegular :: Handler () +getR301 = redirectWith H.status301 RootR +getR303 = redirectWith H.status303 RootR +getR307 = redirectWith H.status307 RootR +getRRegular = redirect RootR specs :: [Spec] specs = describe "Redirect" [ @@ -42,9 +43,9 @@ specs = describe "Redirect" [ assertStatus 307 res assertBodyContains "" res - , it "302 redirect instead of 307 for http 1.0" $ app $ do + , it "302 redirect for regular" $ app $ do res <- request defaultRequest { - pathInfo = ["r307"], httpVersion = H.http10 + pathInfo = ["rregular"] } assertStatus 302 res assertBodyContains "" res