haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Changed to new redirect system (#202)

Browse Source
This commit is contained in:
Michael Snoyman 2012-01-07 21:53:58 +02:00
parent 938f70af51
commit 95b6678e9f
4 changed files with 75 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

120
yesod-core/Yesod/Handler.hs
View File

@ -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
<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">

2
yesod-core/Yesod/Internal/Core.hs
View File

@ -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

3
yesod-core/test/YesodCoreTest/Exceptions.hs
View File

@ -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"

17
yesod-core/test/YesodCoreTest/Redirect.hs
View File

@ -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