yesod-test-1.5.3/0000755000000000000000000000000012762243123012010 5ustar0000000000000000yesod-test-1.5.3/ChangeLog.md0000644000000000000000000000336112762243123014164 0ustar0000000000000000## 1.5.3 * Added bodyNotContains [#1271](https://github.com/yesodweb/yesod/pull/1271) ## 1.5.2 * Added assertEq, deprecated assertEqual [#1259](https://github.com/yesodweb/yesod/pull/1259) ## 1.5.1.1 * Fix `addToken_` needing a trailing space and allows multiples spaces in css selector. ## 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) * The `application/x-www-form-urlencoded` Content-Type header is now only added if key-value POST parameters are added * If no key-values pairs are added, or the request body is set with `setRequestBody`, no default Content-Type header is set ## 1.5 * remove deprecated addNonce functions * You can now configure testing middleware Configuring middleware makes it easy to add logging among other things. middleware is applied to the wai app before each test. If you follow the yesod scaffold, you probably have a withApp function in TestImport.hs. This function should now return (foundation, middleware). `id` is an acceptable value for middleware. ## 1.4.4 test helpers for CRSF middleware such as addTokenFromCookie ## 1.4.3.2 * Add `addTokenFromCookie` and `addTokenFromCookieNamedToHeaderNamed`, which support the new CSRF token middleware [#1058](https://github.com/yesodweb/yesod/pull/1058) * Add `getRequestCookies`, which returns the cookies from the most recent request [#1058](https://github.com/yesodweb/yesod/pull/1058) ## 1.4.3.1 * Improved README ## 1.4.2 Provide `Example` instance for `YesodExample`. ## 1.4.1.1 Upgrade to hspec 2 yesod-test-1.5.3/LICENSE0000644000000000000000000000207512762243123013021 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. yesod-test-1.5.3/README.md0000644000000000000000000000553612762243123013300 0ustar0000000000000000# yesod-test Pragmatic integration tests for haskell web applications using WAI and optionally a database (Persistent). Its main goal is to encourage integration and system testing of web applications by making everything *easy to test*. Your tests are like browser sessions that keep track of cookies and the last visited page. You can perform assertions on the content of HTML responses using CSS selectors. You can also easily build requests using forms present in the current page. This is very useful for testing web applications built in yesod for example, where your forms may have field names generated by the framework or a randomly generated CSRF "\_token" field. Your database is also directly available so you can use runDB to set up backend pre-conditions, or to assert that your session is having the desired effect. The testing facilities behind the scenes are HSpec (on top of HUnit). The code sample below covers the core concepts of yesod-test. Check out the [yesod-scaffolding for usage in a complete application](https://github.com/yesodweb/yesod-scaffold/tree/postgres/test). ```haskell spec :: Spec spec = withApp $ do describe "Basic navigation and assertions" $ do it "Gets a page that has a form, with auto generated fields and token" $ do get ("url/to/page/with/form" :: Text) -- Load a page. statusIs 200 -- Assert the status was success. bodyContains "Hello Person" -- Assert any part of the document contains some text. -- Perform CSS queries and assertions. htmlCount "form .main" 1 -- It matches 1 element. htmlAllContain "h1#mainTitle" "Sign Up Now!" -- All matches have some text. -- Performs the POST using the current page to extract field values: request $ do setMethod "POST" setUrl SignupR addToken -- Add the CSRF _token field with the currently shown value. -- Lookup field by the text on the labels pointing to them. byLabel "Email:" "gustavo@cerati.com" byLabel "Password:" "secret" byLabel "Confirm:" "secret" it "Sends another form, this one has a file" $ do request $ do setMethod "POST" setUrl ("url/to/post/file/to" :: Text) -- You can easily add files, though you still need to provide the MIME type for them. addFile "file_field_name" "path/to/local/file" "image/jpeg" -- And of course you can add any field if you know its name. addPostParam "answer" "42" statusIs 302 describe "Database access" $ do it "selects the list" $ do -- See the Yesod scaffolding for the runDB implementation msgs <- runDB $ selectList ([] :: [Filter Message]) [] assertEqual "One Message in the DB" 1 (length msgs) ``` yesod-test-1.5.3/Setup.lhs0000644000000000000000000000016212762243123013617 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain yesod-test-1.5.3/yesod-test.cabal0000644000000000000000000000521312762243123015075 0ustar0000000000000000name: yesod-test version: 1.5.3 license: MIT license-file: LICENSE author: Nubis maintainer: Michael Snoyman, Greg Weber, Nubis synopsis: integration testing for WAI/Yesod Applications category: Web, Yesod, Testing stability: Experimental cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com description: API docs and the README are available at extra-source-files: README.md, LICENSE, test/main.hs, ChangeLog.md library build-depends: HUnit >= 1.2 , attoparsec >= 0.10 , base >= 4.3 && < 5 , blaze-builder , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , bytestring >= 0.9 , case-insensitive >= 0.2 , containers , cookie , hspec-core == 2.* , html-conduit >= 0.1 , http-types >= 0.7 , monad-control , network >= 2.2 , persistent >= 1.0 , pretty-show >= 1.6 , text , time , transformers >= 0.2.2 , wai >= 3.0 , wai-extra , xml-conduit >= 1.0 , xml-types >= 0.3 , yesod-core >= 1.4.14 exposed-modules: Yesod.Test Yesod.Test.CssQuery Yesod.Test.TransversingCSS ghc-options: -Wall test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test build-depends: base , yesod-test , hspec , HUnit , xml-conduit , bytestring , containers , html-conduit , yesod-core , yesod-form , text , wai , lifted-base , http-types source-repository head type: git location: git://github.com/yesodweb/yesod.git yesod-test-1.5.3/test/0000755000000000000000000000000012762243123012767 5ustar0000000000000000yesod-test-1.5.3/test/main.hs0000644000000000000000000003157312762243123014260 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} import Test.HUnit hiding (Test) import Test.Hspec import Yesod.Core import Yesod.Form import Yesod.Test import Yesod.Test.CssQuery import Yesod.Test.TransversingCSS import Text.XML import Data.Text (Text, pack) 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 (status301, status303, unsupportedMediaType415) parseQuery_ = either error id . parseQuery findBySelector_ x = either error id . findBySelector x parseHtml_ = HD.parseLBS main :: IO () main = hspec $ do describe "CSS selector parsing" $ do it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]] it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]] it "comma" $ parseQuery_ "strong.bar, #foo" @?= [[DeepChildren [ByTagName "strong", ByClass "bar"]], [DeepChildren [ById "foo"]]] describe "find by selector" $ do it "XHTML" $ let html = "foo

Hello World

" query = "body > p" in findBySelector_ html query @?= ["

Hello World

"] it "HTML" $ let html = "foo

Hello World

" query = "body > p" in findBySelector_ html query @?= ["

Hello World

"] let query = "form.foo input[name=_token][type=hidden][value]" html = "
" expected = "" in it query $ findBySelector_ html (pack query) @?= [expected] it "descendents and children" $ let html = "

hello

" query = "p > b u" in findBySelector_ html query @?= ["hello"] it "hyphenated classes" $ let html = "

hello

" query = "p.foo-bar u" in findBySelector_ html query @?= ["hello"] it "descendents" $ let html = "

hello

" query = "p i" in findBySelector_ html query @?= ["hello"] describe "HTML parsing" $ do it "XHTML" $ let html = "foo

Hello World

" doc = Document (Prologue [] Nothing []) root [] root = Element "html" Map.empty [ NodeElement $ Element "head" Map.empty [ NodeElement $ Element "title" Map.empty [NodeContent "foo"] ] , NodeElement $ Element "body" Map.empty [ NodeElement $ Element "p" Map.empty [NodeContent "Hello World"] ] ] in parseHtml_ html @?= doc it "HTML" $ let html = "foo

Hello World

" doc = Document (Prologue [] Nothing []) root [] root = Element "html" Map.empty [ NodeElement $ Element "head" Map.empty [ NodeElement $ Element "title" Map.empty [NodeContent "foo"] ] , NodeElement $ Element "body" Map.empty [ NodeElement $ Element "br" Map.empty [] , NodeElement $ Element "p" Map.empty [NodeContent "Hello World"] ] ] in parseHtml_ html @?= doc describe "basic usage" $ yesodSpec app $ do ydescribe "tests1" $ do yit "tests1a" $ do get ("/" :: Text) statusIs 200 bodyEquals "Hello world!" yit "tests1b" $ do get ("/foo" :: Text) statusIs 404 ydescribe "tests2" $ do yit "type-safe URLs" $ do get $ LiteAppRoute [] statusIs 200 yit "type-safe URLs with query-string" $ do get (LiteAppRoute [], [("foo", "bar")]) statusIs 200 bodyEquals "foo=bar" yit "post params" $ do post ("/post" :: Text) statusIs 500 request $ do setMethod "POST" setUrl $ LiteAppRoute ["post"] addPostParam "foo" "foobarbaz" statusIs 200 bodyEquals "foobarbaz" yit "labels" $ do get ("/form" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/form" :: Text) byLabel "Some Label" "12345" fileByLabel "Some File" "test/main.hs" "text/plain" addToken statusIs 200 bodyEquals "12345" yit "finding html" $ do get ("/html" :: Text) statusIs 200 htmlCount "p" 2 htmlAllContain "p" "Hello" htmlAnyContain "p" "World" htmlAnyContain "p" "Moon" htmlNoneContain "p" "Sun" yit "finds the CSRF token by css selector" $ do get ("/form" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/form" :: Text) byLabel "Some Label" "12345" fileByLabel "Some File" "test/main.hs" "text/plain" addToken_ "body" statusIs 200 bodyEquals "12345" ydescribe "utf8 paths" $ do yit "from path" $ do get ("/dynamic1/שלום" :: Text) statusIs 200 bodyEquals "שלום" yit "from path, type-safe URL" $ do get $ LiteAppRoute ["dynamic1", "שלום"] statusIs 200 printBody bodyEquals "שלום" yit "from WAI" $ do get ("/dynamic2/שלום" :: Text) statusIs 200 bodyEquals "שלום" ydescribe "labels" $ do yit "can click checkbox" $ do get ("/labels" :: Text) request $ do setMethod "POST" setUrl ("/labels" :: Text) byLabel "Foo Bar" "yes" ydescribe "Content-Type handling" $ do yit "can set a content-type" $ do request $ do setUrl ("/checkContentType" :: Text) addRequestHeader ("Expected-Content-Type","text/plain") addRequestHeader ("Content-Type","text/plain") statusIs 200 yit "adds the form-urlencoded Content-Type if you add parameters" $ do request $ do setUrl ("/checkContentType" :: Text) addRequestHeader ("Expected-Content-Type","application/x-www-form-urlencoded") addPostParam "foo" "foobarbaz" statusIs 200 yit "defaults to no Content-Type" $ do get ("/checkContentType" :: Text) statusIs 200 yit "returns a 415 for the wrong Content-Type" $ do -- Tests that the test handler is functioning request $ do setUrl ("/checkContentType" :: Text) addRequestHeader ("Expected-Content-Type","application/x-www-form-urlencoded") addRequestHeader ("Content-Type","text/plain") statusIs 415 describe "cookies" $ yesodSpec cookieApp $ do yit "should send the cookie #730" $ do get ("/" :: Text) statusIs 200 post ("/cookie/foo" :: Text) statusIs 303 get ("/" :: Text) statusIs 200 printBody bodyContains "Foo" describe "CSRF with cookies/headers" $ yesodSpec CsrfApp $ do yit "Should receive a CSRF cookie and add its value to the headers" $ do get ("/" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/" :: Text) addTokenFromCookie statusIs 200 yit "Should 403 requests if we don't add the CSRF token" $ do get ("/" :: Text) statusIs 200 request $ 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 app :: LiteApp app = liteApp $ do dispatchTo $ do mfoo <- lookupGetParam "foo" case mfoo of Nothing -> return "Hello world!" Just foo -> return $ "foo=" <> foo onStatic "dynamic1" $ withDynamic $ \d -> dispatchTo $ return (d :: Text) onStatic "dynamic2" $ onStatic "שלום" $ dispatchTo $ do req <- waiRequest return $ pathInfo req !! 1 onStatic "post" $ dispatchTo $ do mfoo <- lookupPostParam "foo" 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 $ (,) <$> areq textField "Some Label" Nothing <*> areq fileField "Some File" Nothing case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget onStatic "html" $ dispatchTo $ return ("Hello

Hello World

Hello Moon

" :: Text) onStatic "labels" $ dispatchTo $ return ("" :: Text) onStatic "checkContentType" $ dispatchTo $ do headers <- requestHeaders <$> waiRequest let actual = lookup "Content-Type" headers expected = lookup "Expected-Content-Type" headers if actual == expected then return () else sendResponseStatus unsupportedMediaType415 () cookieApp :: LiteApp cookieApp = liteApp $ do dispatchTo $ fromMaybe "no message available" <$> getMessage onStatic "cookie" $ do onStatic "foo" $ dispatchTo $ do setMessage "Foo" redirect ("/cookie/home" :: Text) return () data CsrfApp = CsrfApp mkYesod "CsrfApp" [parseRoutes| / HomeR GET POST |] instance Yesod CsrfApp where yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware getHomeR :: Handler Html getHomeR = defaultLayout [whamlet|

Welcome to my test application. |] postHomeR :: Handler Html postHomeR = defaultLayout [whamlet|

Welcome to my test application. |] yesod-test-1.5.3/Yesod/0000755000000000000000000000000012762243123013073 5ustar0000000000000000yesod-test-1.5.3/Yesod/Test.hs0000644000000000000000000010740612762243123014356 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-| Yesod.Test is a pragmatic framework for testing web applications built using wai and persistent. By pragmatic I may also mean 'dirty'. Its main goal is to encourage integration and system testing of web applications by making everything /easy to test/. Your tests are like browser sessions that keep track of cookies and the last visited page. You can perform assertions on the content of HTML responses, using CSS selectors to explore the document more easily. You can also easily build requests using forms present in the current page. This is very useful for testing web applications built in yesod, for example, where your forms may have field names generated by the framework or a randomly generated CSRF token input. Your database is also directly available so you can use 'runDB' to set up backend pre-conditions, or to assert that your session is having the desired effect. -} module Yesod.Test ( -- * Declaring and running your test suite yesodSpec , YesodSpec , yesodSpecWithSiteGenerator , yesodSpecApp , YesodExample , YesodExampleData(..) , TestApp , YSpec , testApp , YesodSpecTree (..) , ydescribe , yit -- * Making requests -- | You can construct requests with the 'RequestBuilder' monad, which lets you -- set the URL and add parameters, headers, and files. Helper functions are provided to -- lookup fields by label and to add the current CSRF token from your forms. -- Once built, the request can be executed with the 'request' method. -- -- Convenience functions like 'get' and 'post' build and execute common requests. , get , post , postBody , followRedirect , request , addRequestHeader , setMethod , addPostParam , addGetParam , addFile , setRequestBody , RequestBuilder , setUrl -- *** Adding fields by label -- | Yesod can auto generate field names, so you are never sure what -- the argument name should be for each one of your inputs when constructing -- your requests. What you do know is the /label/ of the field. -- These functions let you add parameters to your request based -- on currently displayed label names. , byLabel , fileByLabel -- *** CSRF Tokens -- | In order to prevent CSRF exploits, yesod-form adds a hidden input -- to your forms with the name "_token". This token is a randomly generated, -- per-session value. -- -- In order to prevent your forms from being rejected in tests, use one of -- these functions to add the token to your request. , addToken , addToken_ , addTokenFromCookie , addTokenFromCookieNamedToHeaderNamed -- * Assertions , assertEqual , assertEqualNoShow , assertEq , assertHeader , assertNoHeader , statusIs , bodyEquals , bodyContains , bodyNotContains , htmlAllContain , htmlAnyContain , htmlNoneContain , htmlCount -- * Grab information , getTestYesod , getResponse , getRequestCookies -- * Debug output , printBody , printMatches -- * Utils for building your own assertions -- | Please consider generalizing and contributing the assertions you write. , htmlQuery , parseHTML , withResponse ) where import qualified Test.Hspec.Core.Spec as Hspec import qualified Data.List as DL import qualified Data.ByteString.Char8 as BS8 import Data.ByteString (ByteString) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Test.HUnit as HUnit import qualified Network.HTTP.Types as H import qualified Network.Socket.Internal as Sock import Data.CaseInsensitive (CI) import Network.Wai import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) import qualified Control.Monad.Trans.State as ST import Control.Monad.IO.Class import System.IO import Yesod.Test.TransversingCSS import Yesod.Core import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) import Text.XML.Cursor hiding (element) import qualified Text.XML.Cursor as C import qualified Text.HTML.DOM as HD import Control.Monad.Trans.Writer import qualified Data.Map as M import qualified Web.Cookie as Cookie import qualified Blaze.ByteString.Builder as Builder import Data.Time.Clock (getCurrentTime) import Control.Applicative ((<$>)) import Text.Show.Pretty (ppShow) -- | The state used in a single test case defined using 'yit' -- -- Since 1.2.4 data YesodExampleData site = YesodExampleData { yedApp :: !Application , yedSite :: !site , yedCookies :: !Cookies , yedResponse :: !(Maybe SResponse) } -- | A single test case, to be run with 'yit'. -- -- Since 1.2.0 type YesodExample site = ST.StateT (YesodExampleData site) IO -- | Mapping from cookie name to value. -- -- Since 1.2.0 type Cookies = M.Map ByteString Cookie.SetCookie -- | Corresponds to hspec\'s 'Spec'. -- -- Since 1.2.0 type YesodSpec site = Writer [YesodSpecTree site] () -- | Internal data structure, corresponding to hspec\'s 'YesodSpecTree'. -- -- Since 1.2.0 data YesodSpecTree site = YesodSpecGroup String [YesodSpecTree site] | YesodSpecItem String (YesodExample site ()) -- | Get the foundation value used for the current test. -- -- Since 1.2.0 getTestYesod :: YesodExample site site getTestYesod = fmap yedSite ST.get -- | Get the most recently provided response value, if available. -- -- Since 1.2.0 getResponse :: YesodExample site (Maybe SResponse) getResponse = fmap yedResponse ST.get data RequestBuilderData site = RequestBuilderData { rbdPostData :: RBDPostData , rbdResponse :: (Maybe SResponse) , rbdMethod :: H.Method , rbdSite :: site , rbdPath :: [T.Text] , rbdGets :: H.Query , rbdHeaders :: H.RequestHeaders } data RBDPostData = MultipleItemsPostData [RequestPart] | BinaryPostData BSL8.ByteString -- | Request parts let us discern regular key/values from files sent in the request. data RequestPart = ReqKvPart T.Text T.Text | ReqFilePart T.Text FilePath BSL8.ByteString T.Text -- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments -- to send with your requests. Some of the functions that run on it use the current -- response to analyze the forms that the server is expecting to receive. type RequestBuilder site = ST.StateT (RequestBuilderData site) IO -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool' ydescribe :: String -> YesodSpec site -> YesodSpec site ydescribe label yspecs = tell [YesodSpecGroup label $ execWriter yspecs] yesodSpec :: YesodDispatch site => site -> YesodSpec site -> Hspec.Spec yesodSpec site yspecs = Hspec.fromSpecList $ map unYesod $ execWriter yspecs where unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecItem x y) = Hspec.specItem x $ do app <- toWaiAppPlain site ST.evalStateT y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty , yedResponse = Nothing } -- | Same as yesodSpec, but instead of taking already built site it -- takes an action which produces site for each test. yesodSpecWithSiteGenerator :: YesodDispatch site => IO site -> YesodSpec site -> Hspec.Spec yesodSpecWithSiteGenerator getSiteAction yspecs = Hspec.fromSpecList $ map (unYesod getSiteAction) $ execWriter yspecs where unYesod getSiteAction' (YesodSpecGroup x y) = Hspec.specGroup x $ map (unYesod getSiteAction') y unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do site <- getSiteAction' app <- toWaiAppPlain site ST.evalStateT y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty , yedResponse = Nothing } -- | Same as yesodSpec, but instead of taking a site it -- takes an action which produces the 'Application' for each test. -- This lets you use your middleware from makeApplication yesodSpecApp :: YesodDispatch site => site -> IO Application -> YesodSpec site -> Hspec.Spec yesodSpecApp site getApp yspecs = Hspec.fromSpecList $ map unYesod $ execWriter yspecs where unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecItem x y) = Hspec.specItem x $ do app <- getApp ST.evalStateT y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty , yedResponse = Nothing } -- | Describe a single test that keeps cookies, and a reference to the last response. yit :: String -> YesodExample site () -> YesodSpec site yit label example = tell [YesodSpecItem label example] -- Performs a given action using the last response. Use this to create -- response-level assertions withResponse' :: MonadIO m => (state -> Maybe SResponse) -> [T.Text] -> (SResponse -> ST.StateT state m a) -> ST.StateT state m a 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 [] -- | Use HXT to parse a value from an HTML tag. -- Check for usage examples in this module's source. parseHTML :: HtmlLBS -> Cursor parseHTML html = fromDocument $ HD.parseLBS html -- | 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 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 [] -- | Asserts that the two given values are equal. -- -- In case they are not equal, error mesasge includes the two values. -- -- @since 1.5.2 assertEq :: (Eq a, Show a) => String -> a -> a -> YesodExample site () assertEq m a b = liftIO $ HUnit.assertBool msg (a == b) where msg = "Assertion: " ++ m ++ "\n" ++ "First argument: " ++ ppShow a ++ "\n" ++ "Second argument: " ++ ppShow b ++ "\n" {-# DEPRECATED assertEqual "Use assertEq instead" #-} assertEqual :: (Eq a) => String -> a -> a -> YesodExample site () assertEqual = assertEqualNoShow -- | Asserts that the two given values are equal. -- -- @since 1.5.2 assertEqualNoShow :: (Eq a) => String -> a -> a -> YesodExample site () assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b) -- | Assert the last response status is as expected. statusIs :: Int -> YesodExample site () statusIs number = withResponse $ \ SResponse { simpleStatus = s } -> liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat [ "Expected status was ", show number , " but received status was ", show $ H.statusCode s ] -- | Assert the given header key/value pair was returned. assertHeader :: CI BS8.ByteString -> BS8.ByteString -> YesodExample site () assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> failure $ T.pack $ concat [ "Expected header " , show header , " to be " , show value , ", but it was not present" ] Just value' -> liftIO $ flip HUnit.assertBool (value == value') $ concat [ "Expected header " , show header , " to be " , show value , ", but received " , show value' ] -- | Assert the given header was not included in the response. assertNoHeader :: CI BS8.ByteString -> YesodExample site () assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> return () Just s -> failure $ T.pack $ concat [ "Unexpected header " , show header , " containing " , show s ] -- | Assert the last response is exactly equal to the given text. This is -- useful for testing API responses. bodyEquals :: String -> YesodExample site () bodyEquals text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $ (simpleBody res) == encodeUtf8 (TL.pack text) -- | Assert the last response has the given text. The check is performed using the response -- body in full text form. bodyContains :: String -> YesodExample site () bodyContains text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $ (simpleBody res) `contains` text -- | Assert the last response doesn't have the given text. The check is performed using the response -- body in full text form. -- @since 1.5.3 bodyNotContains :: String -> YesodExample site () bodyNotContains text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body not to contain " ++ text) $ not $ contains (simpleBody res) text contains :: BSL8.ByteString -> String -> Bool contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a) -- | Queries the HTML using a CSS selector, and all matched elements must contain -- the given string. htmlAllContain :: Query -> String -> YesodExample site () htmlAllContain query search = do matches <- htmlQuery query case matches of [] -> failure $ "Nothing matched css query: " <> query _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $ DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) -- | Queries the HTML using a CSS selector, and passes if any matched -- element contains the given string. -- -- Since 0.3.5 htmlAnyContain :: Query -> String -> YesodExample site () htmlAnyContain query search = do matches <- htmlQuery query case matches of [] -> failure $ "Nothing matched css query: " <> query _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $ DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) -- | Queries the HTML using a CSS selector, and fails if any matched -- element contains the given string (in other words, it is the logical -- inverse of htmlAnyContains). -- -- Since 1.2.2 htmlNoneContain :: Query -> String -> YesodExample site () htmlNoneContain query search = do matches <- htmlQuery query case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of [] -> return () found -> failure $ "Found " <> T.pack (show $ length found) <> " instances of " <> T.pack search <> " in " <> query <> " elements" -- | Performs a CSS query on the last response and asserts the matched elements -- are as many as expected. htmlCount :: Query -> Int -> YesodExample site () htmlCount query count = do matches <- fmap DL.length $ htmlQuery query liftIO $ flip HUnit.assertBool (matches == count) ("Expected "++(show count)++" elements to match "++T.unpack query++", found "++(show matches)) -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) printBody :: YesodExample site () printBody = withResponse $ \ SResponse { simpleBody = b } -> liftIO $ BSL8.hPutStrLn stderr b -- | Performs a CSS query and print the matches to stderr. printMatches :: Query -> YesodExample site () printMatches query = do matches <- htmlQuery query liftIO $ hPutStrLn stderr $ show matches -- | Add a parameter with the given name and value to the request body. addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam name value = ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } where addPostData (BinaryPostData _) = error "Trying to add post param to binary content." addPostData (MultipleItemsPostData posts) = MultipleItemsPostData $ ReqKvPart name value : posts -- | Add a parameter with the given name and value to the query string. addGetParam :: T.Text -> T.Text -> RequestBuilder site () addGetParam name value = ST.modify $ \rbd -> rbd { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) : rbdGets rbd } -- | Add a file to be posted with the current request. -- -- Adding a file will automatically change your request content-type to be multipart/form-data. -- -- ==== __Examples__ -- -- > request $ do -- > addFile "profile_picture" "static/img/picture.png" "img/png" addFile :: T.Text -- ^ The parameter name for the file. -> FilePath -- ^ The path to the file. -> T.Text -- ^ The MIME type of the file, e.g. "image/png". -> RequestBuilder site () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content." addPostData (MultipleItemsPostData posts) contents = MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts -- This looks up the name of a field based on the contents of the label pointing to it. nameFromLabel :: T.Text -> RequestBuilder site T.Text nameFromLabel label = do mres <- fmap rbdResponse ST.get res <- case mres of Nothing -> failure "nameFromLabel: No response available" Just res -> return res let body = simpleBody res mlabel = parseHTML body $// C.element "label" >=> contentContains label mfor = mlabel >>= attribute "for" contentContains x c | x `T.isInfixOf` T.concat (c $// content) = [c] | otherwise = [] case mfor of for:[] -> do let mname = parseHTML body $// attributeIs "id" for >=> attribute "name" case mname of "":_ -> failure $ T.concat [ "Label " , label , " resolved to id " , for , " which was not found. " ] name:_ -> return name [] -> failure $ "No input with id " <> for [] -> case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of [] -> failure $ "No label contained: " <> label name:_ -> return name _ -> failure $ "More than one label contained " <> label (<>) :: T.Text -> T.Text -> T.Text (<>) = T.append -- How does this work for the alternate syntax? -- | Finds the @\

-- > -- > -- >
-- -- You can set this parameter like so: -- -- > request $ do -- > byLabel "Username" "Michael" -- -- This function also supports the implicit label syntax, in which -- the @\@ is nested inside the @\