diff --git a/stack.yaml b/stack.yaml index 8078ababc..990f44e2e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,3 +14,4 @@ packages: - ./yesod - ./yesod-eventsource - ./yesod-websockets +- ./yesod-hspec diff --git a/yesod-hspec/ChangeLog.md b/yesod-hspec/ChangeLog.md new file mode 100644 index 000000000..a343b3660 --- /dev/null +++ b/yesod-hspec/ChangeLog.md @@ -0,0 +1,167 @@ +# ChangeLog for yesod-test + +## 1.6.12 + +* Fix import in cookie example [#1713](https://github.com/yesodweb/yesod/pull/1713) +* Add `MonadState` instance for `SIO` + +## 1.6.11 + +* Add missing `HasCallStack`s [#1710](https://github.com/yesodweb/yesod/pull/1710) + +## 1.6.10 + +* `statusIs` assertion failures now print a preview of the response body, if the response body is UTF-8 or ASCII. [#1680](https://github.com/yesodweb/yesod/pull/1680/files) +* Adds an `Yesod.Test.Internal`, which exposes functions that yesod-test uses. These functions do _not_ constitute a stable API. + +## 1.6.9.1 + +* Improve documentation [#1676](https://github.com/yesodweb/yesod/pull/1676) +* Require GHC 8.2 (base >= 4.10) + +## 1.6.9 + +Add `requireJSONResponse` function [#1646](https://github.com/yesodweb/yesod/pull/1646) + +## 1.6.8 + +Add `testModifySite` function [#1642](https://github.com/yesodweb/yesod/pull/1642) + +## 1.6.7 + +Add `addBasicAuthHeader` function [#1632](https://github.com/yesodweb/yesod/pull/1632) + +## 1.6.6.2 + +addPostParam will now URL-encode keys and values to prevent corruption +when special characters such as `&` are used +[#1617](https://github.com/yesodweb/yesod/pull/1617) + +## 1.6.6.1 + +* Documentation fixes +* Support for network 3 + +## 1.6.6 + +* Add utility functions to modify cookies [$1570](https://github.com/yesodweb/yesod/pull/1570) + +## 1.6.5.1 + +* Make test suite build with GHC 8.6 [#1561](https://github.com/yesodweb/yesod/pull/1561) + +## 1.6.5 +bodyEquals prints out actual body in addition to expected body in failure msg +[#1525](https://github.com/yesodweb/yesod/pull/1525) + +## 1.6.4 +Add yesodSpecWithSiteGeneratorAndArgument +[#1485](https://github.com/yesodweb/yesod/pull/1485) + +## 1.6.3 +Add performMethod +[#1502](https://github.com/yesodweb/yesod/pull/1502) + +## 1.6.2 + +* Add byLabel-related functions like byLabelContain +[#1482](https://github.com/yesodweb/yesod/pull/1482) + +## 1.6.1 + +* Fix the build with `base-4.11` (GHC 8.4). + +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + +## 1.5.9.1 + +* Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473) + +## 1.5.9 +* Add byLabelExact and related functions +[#1459](https://github.com/yesodweb/yesod/pull/1459) + +## 1.5.8 +* Added implicit parameter HasCallStack to assertions. +[#1421](https://github.com/yesodweb/yesod/pull/1421) + +## 1.5.7 + +* Add clickOn. +[#1408](https://github.com/yesodweb/yesod/pull/1408) + +## 1.5.6 + +* Add assertNotEq. +[#1375](https://github.com/yesodweb/yesod/pull/1375) + +## 1.5.5 + +* Fix warnings + +## 1.5.4.1 + +* Compilation fix for GHC 7.8 + +## 1.5.4 + +* yesod-test: add getLocation test helper. [#1314](https://github.com/yesodweb/yesod/pull/1314) + +## 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 diff --git a/yesod-hspec/LICENSE b/yesod-hspec/LICENSE new file mode 100644 index 000000000..d9f041796 --- /dev/null +++ b/yesod-hspec/LICENSE @@ -0,0 +1,20 @@ +Copyright (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. diff --git a/yesod-hspec/README.md b/yesod-hspec/README.md new file mode 100644 index 000000000..5f7aa9a36 --- /dev/null +++ b/yesod-hspec/README.md @@ -0,0 +1,67 @@ +# 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) +``` + diff --git a/yesod-hspec/Setup.lhs b/yesod-hspec/Setup.lhs new file mode 100755 index 000000000..06e2708f2 --- /dev/null +++ b/yesod-hspec/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/yesod-hspec/Yesod/Hspec.hs b/yesod-hspec/Yesod/Hspec.hs new file mode 100644 index 000000000..d97fb1a25 --- /dev/null +++ b/yesod-hspec/Yesod/Hspec.hs @@ -0,0 +1,1593 @@ +{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Yesod.Hspec is a pragmatic framework for testing web applications built +using wai. + +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. + +=== Example project + +The best way to see an example project using yesod-test is to create a scaffolded Yesod project: + +@stack new projectname yesod-sqlite@ + +(See https://github.com/commercialhaskell/stack-templates/wiki#yesod for the full list of Yesod templates) + +The scaffolded project makes your database directly available in tests, so you can use 'runDB' to set up +backend pre-conditions, or to assert that your session is having the desired effect. +It also handles wiping your database between each test. + +=== Example code + +The code below should give you a high-level idea of yesod-test's capabilities. +Note that it uses helper functions like @withApp@ and @runDB@ from the scaffolded project; these aren't provided by yesod-test. + +@ +spec :: Spec +spec = withApp $ do + describe \"Homepage\" $ do + it "loads the homepage with a valid status code" $ do + 'get' HomeR + 'statusIs' 200 + describe \"Login Form\" $ do + it "Only allows dashboard access after logging in" $ do + 'get' DashboardR + 'statusIs' 401 + + 'get' HomeR + -- Assert a \ tag exists on the page + 'htmlAnyContain' \"p\" \"Login\" + + -- yesod-test provides a 'RequestBuilder' monad for building up HTTP requests + 'request' $ do + -- Lookup the HTML \ with the text Username, and set a POST parameter for that field with the value Felipe + 'byLabelExact' \"Username\" \"Felipe\" + 'byLabelExact' \"Password\" "pass\" + 'setMethod' \"POST\" + 'setUrl' SignupR + 'statusIs' 200 + + -- The previous request will have stored a session cookie, so we can access the dashboard now + 'get' DashboardR + 'statusIs' 200 + + -- Assert a user with the name Felipe was added to the database + [Entity userId user] <- runDB $ selectList [] [] + 'assertEq' "A single user named Felipe is created" (userUsername user) \"Felipe\" + describe \"JSON\" $ do + it "Can make requests using JSON, and parse JSON responses" $ do + -- Precondition: Create a user with the name \"George\" + runDB $ insert_ $ User \"George\" "pass" + + 'request' $ do + -- Use the Aeson library to send JSON to the server + 'setRequestBody' ('Data.Aeson.encode' $ LoginRequest \"George\" "pass") + 'addRequestHeader' (\"Accept\", "application/json") + 'addRequestHeader' ("Content-Type", "application/json") + 'setUrl' LoginR + 'statusIs' 200 + + -- Parse the request's response as JSON + (signupResponse :: SignupResponse) <- 'requireJSONResponse' +@ + +=== HUnit / HSpec integration + +yesod-test is built on top of hspec, which is itself built on top of HUnit. +You can use existing assertion functions from those libraries, but you'll need to use `liftIO` with them: + +@ +liftIO $ actualTimesCalled `'Test.Hspec.Expectations.shouldBe'` expectedTimesCalled -- hspec assertion +@ + +@ +liftIO $ 'Test.HUnit.Base.assertBool' "a is greater than b" (a > b) -- HUnit assertion +@ + +yesod-test provides a handful of assertion functions that are already lifted, such as 'assertEq', as well. + +-} + +module Yesod.Hspec + ( -- * Declaring and running your test suite + yesodSpec + , YesodSpec + , yesodSpecWithSiteGenerator + , yesodSpecWithSiteGeneratorAndArgument + , yesodSpecApp + , YesodExample + , YesodExampleData(..) + , TestApp (..) + , YSpec + , mkTestApp + , ydescribe + , yit + + -- * Hspec Hooks + , ybefore_ + , ybefore + , ybeforeWith + + -- * Modify test site + , testModifySite + + -- * Modify test state + , testSetCookie + , testDeleteCookie + , testModifyCookies + , testClearCookies + + -- * 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 + , performMethod + , followRedirect + , getLocation + , request + , addRequestHeader + , addBasicAuthHeader + , setMethod + , addPostParam + , addGetParam + , addFile + , setRequestBody + , RequestBuilder + , SIO + , setUrl + , clickOn + + -- *** 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. + , byLabelExact + , byLabelContain + , byLabelPrefix + , byLabelSuffix + , fileByLabelExact + , fileByLabelContain + , fileByLabelPrefix + , fileByLabelSuffix + + -- *** 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 + , assertNotEq + , assertEqualNoShow + , assertEq + + , assertHeader + , assertNoHeader + , statusIs + , bodyEquals + , bodyContains + , bodyNotContains + , htmlAllContain + , htmlAnyContain + , htmlNoneContain + , htmlCount + , requireJSONResponse + + -- * 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 Test.Hspec.Core.Spec +import Test.Hspec.Core.Hooks +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.Text.Encoding.Error as TErr +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 as Sock +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Network.Wai +import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Conduit (MonadThrow) +import Control.Monad.IO.Class +import qualified Control.Monad.State.Class as MS +import Control.Monad.State.Class hiding (get) +import System.IO +import Yesod.Core.Unsafe (runFakeHandler) +import Yesod.Test.TransversingCSS +import Yesod.Core +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) +import Text.XML.Cursor hiding (element) +import qualified Text.XML.Cursor as C +import qualified Text.HTML.DOM as HD +import Data.IORef +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) +import Data.Monoid (mempty) +import Data.Semigroup (Semigroup(..)) +import GHC.Stack (HasCallStack) +import Data.ByteArray.Encoding (convertToBase, Base(..)) +import Network.HTTP.Types.Header (hContentType) +import Data.Aeson (FromJSON, eitherDecode') +import Control.Monad + +import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8) + +-- | The state used in a single test case defined using 'yit' +-- +-- Since 1.2.4 +data YesodExampleData site = YesodExampleData + { yedApp :: !(site -> IO Application) + , yedSite :: !site + , yedCookies :: !Cookies + , yedResponse :: !(Maybe SResponse) + } + +-- | A single test case, to be run with 'yit'. +-- +-- Since 1.2.0 +newtype YesodExample site a = YesodExample { unYesodExample :: SIO (YesodExampleData site) a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadState (YesodExampleData site), MonadUnliftIO) + +-- | 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 = SpecWith (YesodExampleData site) + +type YesodSpecWith site r = SpecWith (YesodExampleData site, r) + +-- | Get the foundation value used for the current test. +-- +-- Since 1.2.0 +getTestYesod :: (MonadState (YesodExampleData site) m) => m site +getTestYesod = fmap yedSite MS.get + +-- | Get the most recently provided response value, if available. +-- +-- Since 1.2.0 +getResponse :: (MonadState (YesodExampleData site) m) => m (Maybe SResponse) +getResponse = fmap yedResponse MS.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 = SIO (RequestBuilderData site) + +-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' +-- and 'ConnectionPool' +ydescribe :: String -> YesodSpec site -> YesodSpec site +ydescribe = describe + +yesodSpec :: YesodDispatch site + => site + -> YesodSpec site + -> Spec +yesodSpec site = + before $ do + pure YesodExampleData + { yedApp = toWaiAppPlain + , 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 + -> Spec +yesodSpecWithSiteGenerator getSiteAction = + yesodSpecWithSiteGeneratorAndArgument (const getSiteAction) + +-- | Same as yesodSpecWithSiteGenerator, but also takes an argument to build the site +-- and makes that argument available to the tests. +-- +-- @since 1.6.4 +yesodSpecWithSiteGeneratorAndArgument + :: YesodDispatch site + => (a -> IO site) + -> YesodSpec site + -> SpecWith a +yesodSpecWithSiteGeneratorAndArgument getSiteAction = + beforeWith $ \a -> do + site <- getSiteAction a + pure YesodExampleData + { yedApp = toWaiAppPlain + , yedSite = site + , yedCookies = M.empty + , yedResponse = Nothing + } + +ybefore_ + :: (YesodDispatch site) + => YesodExample site () + -> YesodSpec site + -> YesodSpec site +ybefore_ action = + beforeWith $ + execSIO (unYesodExample action) + + +ybefore + :: (YesodDispatch site) + => YesodExample site a + -> YesodSpecWith site a + -> YesodSpec site +ybefore action = + beforeWith $ \yed -> do + runSIO (unYesodExample action) yed + +ybeforeWith + :: (YesodDispatch site) + => (a -> YesodExample site b) + -> YesodSpecWith site b + -> YesodSpecWith site a +ybeforeWith mkAction = + beforeWith $ \(yed, a) -> + runSIO (unYesodExample (mkAction a)) yed + +-- | 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 + -> Spec +yesodSpecApp site getApp = + before $ do + pure YesodExampleData + { yedApp = const getApp + , yedSite = site + , yedCookies = M.empty + , yedResponse = Nothing + } + +-- | Describe a single test that keeps cookies, and a reference to the last response. +yit :: (HasCallStack, YesodDispatch site) => String -> YesodExample site () -> YesodSpec site +yit = it + +-- | Modifies the site ('yedSite') of the test, and creates a new WAI app ('yedApp') for it. +-- +-- yesod-test allows sending requests to your application to test that it handles them correctly. +-- In rare cases, you may wish to modify that application in the middle of a test. +-- This may be useful if you wish to, for example, test your application under a certain configuration, +-- then change that configuration to see if your app responds differently. +-- +-- ==== __Examples__ +-- +-- > post SendEmailR +-- > -- Assert email not created in database +-- > testModifySite (\site -> pure ) +-- > post SendEmailR +-- > -- Assert email created in database +-- +-- > testModifySite (\site -> do +-- > middleware <- makeLogware site +-- > pure (site { appRedisConnection = Nothing }, middleware) +-- > ) +-- +-- @since 1.6.8 +testModifySite + :: (MonadIO m, MonadState (YesodExampleData site) m, YesodDispatch site) + => (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app. + -> m () +testModifySite newSiteFn = do + currentSite <- getTestYesod + (newSite, middleware) <- liftIO $ newSiteFn currentSite + modify $ \yed -> yed + { yedSite = newSite + , yedApp = \_ -> middleware <$> toWaiAppPlain newSite + } + +-- | Sets a cookie +-- +-- ==== __Examples__ +-- +-- > import qualified Web.Cookie as Cookie +-- > :set -XOverloadedStrings +-- > testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "name" } +-- +-- @since 1.6.6 +testSetCookie :: (MonadState (YesodExampleData site) m) => Cookie.SetCookie -> m () +testSetCookie cookie = do + let key = Cookie.setCookieName cookie + modify $ \yed -> yed { yedCookies = M.insert key cookie (yedCookies yed) } + +-- | Deletes the cookie of the given name +-- +-- ==== __Examples__ +-- +-- > :set -XOverloadedStrings +-- > testDeleteCookie "name" +-- +-- @since 1.6.6 +testDeleteCookie :: (MonadState (YesodExampleData site) m) => ByteString -> m () +testDeleteCookie k = do + modify $ \yed -> yed { yedCookies = M.delete k (yedCookies yed) } + +-- | Modify the current cookies with the given mapping function +-- +-- @since 1.6.6 +testModifyCookies :: (MonadState (YesodExampleData site) m) => (Cookies -> Cookies) -> m () +testModifyCookies f = do + modify $ \yed -> yed { yedCookies = f (yedCookies yed) } + +-- | Clears the current cookies +-- +-- @since 1.6.6 +testClearCookies :: MonadState (YesodExampleData site) m => m () +testClearCookies = do + modify $ \yed -> yed { yedCookies = M.empty } + +-- Performs a given action using the last response. Use this to create +-- response-level assertions +withResponse' + :: (HasCallStack, MonadState state m, MonadIO m) + => (state -> Maybe SResponse) + -> [T.Text] + -> (SResponse -> m a) + -> m a +withResponse' getter errTrace f = maybe err f . getter =<< MS.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 :: (MonadState (YesodExampleData site) m, MonadIO m, HasCallStack) => (SResponse -> m a) -> m 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' + :: (HasCallStack, MonadState state m, MonadIO m) + => (state -> Maybe SResponse) + -> [T.Text] + -> Query + -> 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 :: (MonadState (YesodExampleData site) m, HasCallStack, MonadIO m) => Query -> m [HtmlLBS] +htmlQuery = htmlQuery' yedResponse [] + +-- | Asserts that the two given values are equal. +-- +-- In case they are not equal, the error message includes the two values. +-- +-- @since 1.5.2 +assertEq :: (HasCallStack, Eq a, Show a, MonadIO m) => String -> a -> a -> m () +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" + +-- | Asserts that the two given values are not equal. +-- +-- In case they are equal, the error message includes the values. +-- +-- @since 1.5.6 +assertNotEq :: (HasCallStack, Eq a, Show a, MonadIO m) => String -> a -> a -> m () +assertNotEq m a b = + liftIO $ HUnit.assertBool msg (a /= b) + where msg = "Assertion: " ++ m ++ "\n" ++ + "Both arguments: " ++ ppShow a ++ "\n" + +-- | Asserts that the two given values are equal. +-- +-- @since 1.5.2 +assertEqualNoShow :: (HasCallStack, Eq a, MonadIO m) => String -> a -> a -> m () +assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b) + +-- | Assert the last response status is as expected. +-- If the status code doesn't match, a portion of the body is also printed to aid in debugging. +-- +-- ==== __Examples__ +-- +-- > get HomeR +-- > statusIs 200 +statusIs :: (MonadIO m, MonadState (YesodExampleData site) m, HasCallStack) => Int -> m () +statusIs number = do + withResponse $ \(SResponse status headers body) -> do + let mContentType = lookup hContentType headers + isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType + + liftIO $ flip HUnit.assertBool (H.statusCode status == number) $ concat + [ "Expected status was ", show number + , " but received status was ", show $ H.statusCode status + , if isUTF8ContentType + then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body) + else "" + ] + +-- | Assert the given header key/value pair was returned. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > assertHeader "key" "value" +-- +-- > import qualified Data.CaseInsensitive as CI +-- > import qualified Data.ByteString.Char8 as BS8 +-- > getHomeR +-- > assertHeader (CI.mk (BS8.pack "key")) (BS8.pack "value") +assertHeader :: (HasCallStack, MonadIO m, MonadState (YesodExampleData site) m) => CI BS8.ByteString -> BS8.ByteString -> m () +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. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > assertNoHeader "key" +-- +-- > import qualified Data.CaseInsensitive as CI +-- > import qualified Data.ByteString.Char8 as BS8 +-- > getHomeR +-- > assertNoHeader (CI.mk (BS8.pack "key")) +assertNoHeader :: (HasCallStack, MonadIO m, MonadState (YesodExampleData site) m) => CI BS8.ByteString -> m () +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. +-- +-- ==== __Examples__ +-- +-- > get HomeR +-- > bodyEquals "

Hello, World

" +bodyEquals :: (MonadIO m, MonadState (YesodExampleData site) m, HasCallStack) => String -> m () +bodyEquals text = withResponse $ \ res -> do + let actual = simpleBody res + msg = concat [ "Expected body to equal:\n\t" + , text ++ "\n" + , "Actual is:\n\t" + , TL.unpack $ decodeUtf8With TErr.lenientDecode actual + ] + liftIO $ HUnit.assertBool msg $ actual == encodeUtf8 (TL.pack text) + +-- | Assert the last response has the given text. The check is performed using the response +-- body in full text form. +-- +-- ==== __Examples__ +-- +-- > get HomeR +-- > bodyContains "

Foo

" +bodyContains :: (MonadIO m, MonadState (YesodExampleData site) m, HasCallStack) => String -> m () +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. +-- +-- ==== __Examples__ +-- +-- > get HomeR +-- > bodyNotContains "

Foo

+-- +-- @since 1.5.3 +bodyNotContains :: (MonadIO m, MonadState (YesodExampleData site) m, HasCallStack) => String -> m () +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. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > htmlAllContain "p" "Hello" -- Every

tag contains the string "Hello" +-- +-- > import qualified Data.Text as T +-- > get HomeR +-- > htmlAllContain (T.pack "h1#mainTitle") "Sign Up Now!" -- All

tags with the ID mainTitle contain the string "Sign Up Now!" +htmlAllContain :: (HasCallStack, MonadState (YesodExampleData site) m, MonadIO m) => Query -> String -> m () +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. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > htmlAnyContain "p" "Hello" -- At least one

tag contains the string "Hello" +-- +-- Since 0.3.5 +htmlAnyContain :: (HasCallStack, MonadState (YesodExampleData site) m, MonadIO m) => Query -> String -> m () +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 htmlAnyContain). +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > htmlNoneContain ".my-class" "Hello" -- No tags with the class "my-class" contain the string "Hello" +-- +-- Since 1.2.2 +htmlNoneContain :: (HasCallStack, MonadState (YesodExampleData site) m, MonadIO m) => Query -> String -> m () +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. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > htmlCount "p" 3 -- There are exactly 3

tags in the response +htmlCount :: (HasCallStack, MonadState (YesodExampleData site) m, MonadIO m) => Query -> Int -> m () +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)) + +-- | Parses the response body from JSON into a Haskell value, throwing an error if parsing fails. +-- +-- This function also checks that the @Content-Type@ of the response is @application/json@. +-- +-- ==== __Examples__ +-- +-- > get CommentR +-- > (comment :: Comment) <- requireJSONResponse +-- +-- > post UserR +-- > (json :: Value) <- requireJSONResponse +-- +-- @since 1.6.9 +requireJSONResponse :: (HasCallStack, FromJSON a, MonadIO m, MonadState (YesodExampleData site) m) => m a +requireJSONResponse = do + withResponse $ \(SResponse _status headers body) -> do + let mContentType = lookup hContentType headers + isJSONContentType = maybe False contentTypeHeaderIsJson mContentType + unless + isJSONContentType + (failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers) + case eitherDecode' body of + Left err -> failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", getBodyTextPreview body] + Right v -> return v + +-- | Outputs the last response body to stderr (So it doesn't get captured by HSpec). Useful for debugging. +-- +-- ==== __Examples__ +-- +-- > get HomeR +-- > printBody +printBody :: (MonadIO m, MonadState (YesodExampleData site) m) => m () +printBody = withResponse $ \ SResponse { simpleBody = b } -> + liftIO $ BSL8.hPutStrLn stderr b + +-- | Performs a CSS query and print the matches to stderr. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > printMatches "h1" -- Prints all h1 tags +printMatches :: (HasCallStack, MonadState (YesodExampleData site) m, MonadIO m) => Query -> m () +printMatches query = do + matches <- htmlQuery query + liftIO $ hPutStrLn stderr $ show matches + +-- | Add a parameter with the given name and value to the request body. +-- This function can be called multiple times to add multiple parameters, and be mixed with calls to 'addFile'. +-- +-- "Post parameter" is an informal description of what is submitted by making an HTTP POST with an HTML @\@. +-- Like HTML @\@s, yesod-test will default to a @Content-Type@ of @application/x-www-form-urlencoded@ if no files are added, +-- and switch to @multipart/form-data@ if files are added. +-- +-- Calling this function after using 'setRequestBody' will raise an error. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > post $ do +-- > addPostParam "key" "value" +addPostParam :: T.Text -> T.Text -> RequestBuilder site () +addPostParam name value = + modifySIO $ \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. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > request $ do +-- > addGetParam "key" "value" -- Adds ?key=value to the URL +addGetParam :: T.Text -> T.Text -> RequestBuilder site () +addGetParam name value = modifySIO $ \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 + modifySIO $ \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. +genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text +genericNameFromLabel match label = do + mres <- fmap rbdResponse getSIO + res <- + case mres of + Nothing -> failure "genericNameFromLabel: No response available" + Just res -> return res + let + body = simpleBody res + mlabel = parseHTML body + $// C.element "label" + >=> isContentMatch label + mfor = mlabel >>= attribute "for" + + isContentMatch x c + | x `match` 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 + +byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains) + -> T.Text -- ^ The text contained in the @\

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