diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 33d60364..36bbb582 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -50,6 +50,7 @@ module Yesod.Test , get , post , postBody + , followRedirect , request , addRequestHeader , setMethod @@ -693,6 +694,29 @@ get url = request $ do setMethod "GET" setUrl url +-- | Follow a redirect, if the last response was a redirect. +-- (We consider a request a redirect if the status is +-- 301, 302, 303, 307 or 308, and the Location header is set.) +-- +-- ==== __Examples__ +-- +-- > get HomeR +-- > followRedirect +followRedirect :: Yesod site + => YesodExample site (Either T.Text T.Text) -- ^ 'Left' with an error message if not a redirect, 'Right' with the redirected URL if it was +followRedirect = do + mr <- getResponse + case mr of + Nothing -> return $ Left "followRedirect called, but there was no previous response, so no redirect to follow" + Just r -> do + if not ((H.statusCode $ simpleStatus r) `elem` [301, 302, 303, 307, 308]) + then return $ Left "followRedirect called, but previous request was not a redirect" + else do + case lookup "Location" (simpleHeaders r) of + Nothing -> return $ Left "followRedirect called, but no location header set" + Just h -> let url = TE.decodeUtf8 h in + get url >> return (Right url) + -- | Sets the HTTP method used by the request. -- -- ==== __Examples__ diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 5461e8bd..0ef4354c 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -20,11 +20,13 @@ import Data.Monoid ((<>)) import Control.Applicative import Network.Wai (pathInfo, requestHeaders) import Data.Maybe (fromMaybe) +import Data.Either (isLeft, isRight) +import Control.Exception.Lifted(try, SomeException) import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD -import Network.HTTP.Types.Status (unsupportedMediaType415) +import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415) parseQuery_ = either error id . parseQuery findBySelector_ x = either error id . findBySelector x @@ -213,8 +215,29 @@ main = hspec $ do setMethod "POST" setUrl ("/" :: Text) statusIs 403 + describe "test redirects" $ yesodSpec app $ do + yit "follows 303 redirects when requested" $ do + get ("/redirect303" :: Text) + statusIs 303 + r <- followRedirect + liftIO $ assertBool "expected a Right from a 303 redirect" $ isRight r + statusIs 200 + bodyContains "we have been successfully redirected" + + yit "follows 301 redirects when requested" $ do + get ("/redirect301" :: Text) + statusIs 301 + r <- followRedirect + liftIO $ assertBool "expected a Right from a 301 redirect" $ isRight r + statusIs 200 + bodyContains "we have been successfully redirected" + yit "returns a Left when no redirect was returned" $ do + get ("/" :: Text) + statusIs 200 + r <- followRedirect + liftIO $ assertBool "expected a Left when not a redirect" $ isLeft r instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage @@ -235,6 +258,9 @@ app = liteApp $ do case mfoo of Nothing -> error "No foo" Just foo -> return foo + onStatic "redirect301" $ dispatchTo $ redirectWith status301 ("/redirectTarget" :: Text) >> return () + onStatic "redirect303" $ dispatchTo $ redirectWith status303 ("/redirectTarget" :: Text) >> return () + onStatic "redirectTarget" $ dispatchTo $ return ("we have been successfully redirected" :: Text) onStatic "form" $ dispatchTo $ do ((mfoo, widget), _) <- runFormPost $ renderDivs @@ -290,4 +316,4 @@ postHomeR = defaultLayout [whamlet|

Welcome to my test application. - |] \ No newline at end of file + |] diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 907624e5..9f2ee0da 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -4,7 +4,7 @@ license: MIT license-file: LICENSE author: Nubis maintainer: Michael Snoyman, Greg Weber, Nubis -synopsis: integration testing for WAI/Yesod Applications +synopsis: integration testing for WAI/Yesod Applications category: Web, Yesod, Testing stability: Experimental cabal-version: >= 1.8 @@ -60,6 +60,7 @@ test-suite test , yesod-form , text , wai + , lifted-base , http-types source-repository head