yesod-test 1.5.0.1 → 1.5.1.0
raw patch · 4 files changed
+71/−9 lines, 4 filesdep +lifted-base
Dependencies added: lifted-base
Files
- ChangeLog.md +4/−0
- Yesod/Test.hs +37/−6
- test/main.hs +27/−1
- yesod-test.cabal +3/−2
ChangeLog.md view
@@ -1,3 +1,7 @@+## 1.5.1.0++* Better error provenance for stuff invoking withResponse' [#1191](https://github.com/yesodweb/yesod/pull/1191)+ ## 1.5.0.1 * Fixed the `application/x-www-form-urlencoded` header being added to all requests, even those sending a binary POST body [#1064](https://github.com/yesodweb/yesod/pull/1064/files)
Yesod/Test.hs view
@@ -50,6 +50,7 @@ , get , post , postBody+ , followRedirect , request , addRequestHeader , setMethod@@ -277,15 +278,21 @@ -- response-level assertions withResponse' :: MonadIO m => (state -> Maybe SResponse)+ -> [T.Text] -> (SResponse -> ST.StateT state m a) -> ST.StateT state m a-withResponse' getter f = maybe err f . getter =<< ST.get- where err = failure "There was no response, you should make a request"+withResponse' getter errTrace f = maybe err f . getter =<< ST.get+ where err = failure msg+ msg = if null errTrace+ then "There was no response, you should make a request."+ else+ "There was no response, you should make a request. A response was needed because: \n - "+ <> T.intercalate "\n - " errTrace -- | Performs a given action using the last response. Use this to create -- response-level assertions withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a-withResponse = withResponse' yedResponse+withResponse = withResponse' yedResponse [] -- | Use HXT to parse a value from an HTML tag. -- Check for usage examples in this module's source.@@ -295,16 +302,17 @@ -- | Query the last response using CSS selectors, returns a list of matched fragments htmlQuery' :: MonadIO m => (state -> Maybe SResponse)+ -> [T.Text] -> Query -> ST.StateT state m [HtmlLBS]-htmlQuery' getter query = withResponse' getter $ \ res ->+htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res -> case findBySelector (simpleBody res) query of Left err -> failure $ query <> " did not parse: " <> T.pack (show err) Right matches -> return $ map (encodeUtf8 . TL.pack) matches -- | Query the last response using CSS selectors, returns a list of matched fragments htmlQuery :: Query -> YesodExample site [HtmlLBS]-htmlQuery = htmlQuery' yedResponse+htmlQuery = htmlQuery' yedResponse [] -- | Asserts that the two given values are equal. assertEqual :: (Eq a) => String -> a -> a -> YesodExample site ()@@ -569,7 +577,7 @@ -- > addToken_ "#formID" addToken_ :: Query -> RequestBuilder site () addToken_ scope = do- matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]"+ matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> "input[name=_token][type=hidden][value]" case matches of [] -> failure $ "No CSRF token found in the current page" element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element@@ -685,6 +693,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. --
test/main.hs view
@@ -20,11 +20,13 @@ 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,9 +215,30 @@ 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 @@ 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
yesod-test.cabal view
@@ -1,10 +1,10 @@ name: yesod-test-version: 1.5.0.1+version: 1.5.1.0 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 @@ , yesod-form , text , wai+ , lifted-base , http-types source-repository head