Merge pull request #1194 from mwotton/add_followRedirect_to_yesodtest

followRedirect as discussed in https://github.com/yesodweb/yesod/issues/1190

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__

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|
         <p>
             Welcome to my test application.
-    |]
+    |]

yesod-test/yesod-test.cabal

@@ -4,7 +4,7 @@ license:            MIT
 license-file:       LICENSE
 author:             Nubis <nubis@woobiz.com.ar>
 maintainer:         Michael Snoyman, Greg Weber, Nubis <nubis@woobiz.com.ar>
-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