Changed to new redirect system (#202)

yesod-core/Yesod/Handler.hs

@@ -39,11 +39,9 @@ module Yesod.Handler
     , runRequestBody
       -- * Special responses
       -- ** Redirecting
-    , RedirectType (..)
+    , RedirectUrl (..)
     , redirect
-    , redirectParams
+    , redirectWith
-    , redirectString
-    , redirectText
     , 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 to the given route. The redirect will be a temporary redirect to
-redirect :: RedirectType -> Route master -> GHandler sub master a
+-- a GET request. This is the appropriate choice for a get-following-post
-redirect rt url = redirectParams rt url []
+-- 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.
+-- | Redirect to the given URL with the specified status code.
-redirectParams :: RedirectType -> Route master -> [(Text, Text)]
+redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a
-               -> GHandler sub master a
+redirectWith status url = do
-redirectParams rt url params = do
+    urlText <- toTextUrl url
-    r <- getUrlRenderParams
+    liftIO $ throwIO $ HCRedirect status urlText
-    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" #-}
 
 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 :: RedirectUrl master url => url -> GHandler sub master ()
-setUltDest dest = do
+setUltDest url = do
-    render <- getUrlRender
+    urlText <- toTextUrl url
-    setUltDestString $ render dest
+    setSession ultDestKey urlText
-
--- | 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" #-}
 
 -- | 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
+            setUltDest (tm r, gets')
-            setUltDestString $ render (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
+-- | Some value which can be turned into a URL for redirects.
-getRedirectStatus RedirectPermanent _ = H.status301
+class RedirectUrl master a where
-getRedirectStatus RedirectTemporary r
+    -- | Converts the value to the URL and a list of query-string parameters.
-    | W.httpVersion r == H.http11 = H.status307
+    toTextUrl :: a -> GHandler sub master Text
-    | otherwise                  = H.status302
-getRedirectStatus RedirectSeeOther  _ = H.status303
 
--- | Different types of redirects.
+instance RedirectUrl master Text where
-data RedirectType = RedirectPermanent
+    toTextUrl = return
-                  | RedirectTemporary
+
-                  | RedirectSeeOther
+instance RedirectUrl master String where
-    deriving (Show, Eq)
+    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 :: RedirectUrl master url => url -> GHandler sub master a
-redirectToPost dest = hamletToRepHtml
+redirectToPost url = do
+    urlText <- toTextUrl url
+    hamletToRepHtml
 #if GHC7
             [hamlet|
 #else
@@ -848,7 +854,7 @@ redirectToPost dest = hamletToRepHtml
     <head>
         <title>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">

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

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"

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, getR303, getR307, getRRegular :: Handler ()
-getR301 = redirect RedirectPermanent RootR
+getR301 = redirectWith H.status301 RootR
-getR303 = redirect RedirectSeeOther RootR
+getR303 = redirectWith H.status303 RootR
-getR307 = redirect RedirectTemporary 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