diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# ChangeLog for hspec-yesod + +## 0.1.0 + +- Initial release and fork from `yesod-test`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,71 @@ +# hspec-yesod + +A fork of [`yesod-test`](https://hackage.haskell.org/package/yesod-test) that provides more integration with `hspec` features, like hooks. + +## README of `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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/hspec-yesod.cabal b/hspec-yesod.cabal new file mode 100644 --- /dev/null +++ b/hspec-yesod.cabal @@ -0,0 +1,77 @@ +name: hspec-yesod +version: 0.1.0 +license: MIT +license-file: LICENSE +author: Nubis , Matt Parsons +maintainer: Matt Parsons +synopsis: A variation of yesod-test that follows hspec idioms more closely +category: Web, Yesod, Testing +stability: Experimental +cabal-version: >= 1.10 +build-type: Simple +homepage: https://www.github.com/parsonsmatt/hspec-yesod +description: Please see the README on GitHub for more information +extra-source-files: README.md, LICENSE, test/main.hs, ChangeLog.md + +library + default-language: Haskell2010 + build-depends: HUnit >= 1.2 + , aeson + , attoparsec >= 0.10 + , base >= 4.10 && < 5 + , blaze-builder + , blaze-html >= 0.5 + , bytestring >= 0.9 + , case-insensitive >= 0.2 + , conduit + , containers + , cookie + , exceptions + , hspec-core == 2.* + , html-conduit >= 0.1 + , http-types >= 0.7 + , network >= 3.0 + , memory + , pretty-show >= 1.6 + , text + , time + , mtl >= 2.0.0 + , transformers >= 0.2.2 + , wai >= 3.0 + , wai-extra + , xml-conduit >= 1.0 + , xml-types >= 0.3 + , yesod-core >= 1.6.17 + , yesod-test + + exposed-modules: Test.Hspec.Yesod + ghc-options: -Wall -fwarn-redundant-constraints + hs-source-dirs: src + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + build-depends: base + , yesod-test + , hspec + , hspec-yesod + , HUnit + , xml-conduit + , bytestring + , containers + , html-conduit + , yesod-core + , yesod-form >= 1.6 + , text + , wai + , wai-extra + , http-types + , unliftio + , cookie + , unliftio-core + +source-repository head + type: git + location: git://github.com/yesodweb/yesod.git diff --git a/src/Test/Hspec/Yesod.hs b/src/Test/Hspec/Yesod.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Yesod.hs @@ -0,0 +1,1563 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| + +"Test.Hspec.Yesod" is a fork of "Yesod.Test" that is designed to be a mostly drop-in replacement that follows the @hspec@ idioms more closely. +The intention is to provide a test framework that allows for easier integration testing of your web application. + +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. + +== Scaling + +One problem with this approach is that the test suite doesn't scale particularly well. +In order to call a @withApp :: SpecWith (YesodExampleData App) -> Spec@ sort of function, you need to depend on every single module that any @Handler@ modules depends on. +This slows down compilation significantly in very large projects, especially if you're combining your tests and library into a package component (which generally greatly improves build/test cycles). + +As a result, it is generally better to separate your integration tests and your unit tests into different modules. + +-} + +module Test.Hspec.Yesod + ( -- * Declaring and running your test suite + yesodSpec + , YesodSpec + , yesodSpecWithSiteGenerator + , yesodSpecWithSiteGeneratorAndArgument + , YesodExample + , YesodExampleData(..) + , TestApp (..) + , YSpec + , mkTestApp + , ydescribe + , yit + + -- * Hspec Hooks + , ybefore_ + , ybefore + , ybeforeWith + , addYesodTestCleanupHook + + -- * Modify test site + , testModifySite + + -- * Modify test state + , testSetCookie + , testDeleteCookie + , testModifyCookies + , testClearCookies + + -- * Constructing 'YesodExampleData' + , siteToYesodExampleData + + -- * 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 Control.Monad.Catch (finally) +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.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.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 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.ByteArray.Encoding (convertToBase, Base(..)) +import Network.HTTP.Types.Header (hContentType) +import Data.Aeson (eitherDecode') +import Control.Monad + +import qualified Yesod.Test.TransversingCSS as YT.CSS +import Yesod.Test.TransversingCSS (HtmlLBS, Query) +import qualified Yesod.Test.Internal.SIO as YT.SIO +import Yesod.Test.Internal.SIO (SIO, execSIO, runSIO) +import qualified Yesod.Test.Internal as YT.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8) + +-- | The state used in a single test case defined using 'yit' +-- +-- Since 1.2.4 +data YesodExampleData site = YesodExampleData + { yedCreateApplication :: !(site -> Middleware -> IO Application) + , yedMiddleware :: !Middleware + , yedSite :: !site + , yedCookies :: !Cookies + , yedResponse :: !(Maybe SResponse) + , yedTestCleanup :: !(IO ()) + } + +-- | A single test case, to be run with 'yit'. +-- +-- Since 1.2.0 +type YesodExample site = YT.SIO.SIO (YesodExampleData site) + +unYesodExample :: YT.SIO.SIO (YesodExampleData site) a -> YT.SIO.SIO (YesodExampleData site) a +unYesodExample = id + +-- | 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 :: YesodExample site site +getTestYesod = fmap yedSite MS.get + +-- | Get the most recently provided response value, if available. +-- +-- Since 1.2.0 +getResponse :: YesodExample site (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 = YT.SIO.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 + { yedCreateApplication = \finalSite middleware -> middleware <$> toWaiAppPlain finalSite + , yedMiddleware = id + , yedSite = site + , yedCookies = M.empty + , yedResponse = Nothing + , yedTestCleanup = pure () + } + +-- | 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 + { yedCreateApplication = \finalSite middleware -> middleware <$> toWaiAppPlain finalSite + , yedMiddleware = id + , yedSite = site + , yedCookies = M.empty + , yedResponse = Nothing + , yedTestCleanup = pure () + } + +ybefore_ + :: YesodExample site () + -> YesodSpec site + -> YesodSpec site +ybefore_ action = + beforeWith $ + execSIO (unYesodExample action) + +-- | Add a cleanup hook to the yesod test. This will be run after the other +-- hooks already defined. +addYesodTestCleanupHook + :: (YesodExampleData site -> IO ()) + -> YesodSpec site + -> YesodSpec site +addYesodTestCleanupHook mkCleanupHook = + beforeWith $ \yed -> do + pure yed + { yedTestCleanup = do + yedTestCleanup yed + mkCleanupHook yed + } + +ybefore + :: YesodExample site a + -> YesodSpecWith site a + -> YesodSpec site +ybefore action = + beforeWith $ \yed -> do + runSIO (unYesodExample action) yed + +ybeforeWith + :: (a -> YesodExample site b) + -> YesodSpecWith site b + -> YesodSpecWith site a +ybeforeWith mkAction = + beforeWith $ \(yed, a) -> + runSIO (unYesodExample (mkAction a)) yed + +-- | Describe a single test that keeps cookies, and a reference to the last response. +yit :: (HasCallStack) => 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 + :: (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app. + -> YesodExample site () +testModifySite newSiteFn = do + currentSite <- getTestYesod + (newSite, middleware) <- liftIO $ newSiteFn currentSite + modify $ \yed -> yed + { yedSite = newSite + , yedMiddleware = middleware + } + +-- | Sets a cookie +-- +-- ==== __Examples__ +-- +-- > import qualified Web.Cookie as Cookie +-- > :set -XOverloadedStrings +-- > testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "name" } +-- +-- @since 1.6.6 +testSetCookie :: Cookie.SetCookie -> YesodExample site () +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 :: ByteString -> YesodExample site () +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 :: (Cookies -> Cookies) -> YesodExample site () +testModifyCookies f = do + modify $ \yed -> yed { yedCookies = f (yedCookies yed) } + +-- | Clears the current cookies +-- +-- @since 1.6.6 +testClearCookies :: YesodExample site () +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) + => (s -> Maybe SResponse) + -> [T.Text] + -> (SResponse -> SIO s a) + -> SIO s 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 :: (HasCallStack) => (SResponse -> SIO (YesodExampleData site) a) -> SIO (YesodExampleData 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' + :: (HasCallStack) + => (site -> Maybe SResponse) + -> [T.Text] + -> Query + -> SIO site [HtmlLBS] +htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res -> + case YT.CSS.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 :: HasCallStack => Query -> YesodExample site [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 :: HasCallStack => Int -> YesodExample site () +statusIs number = do + withResponse $ \(SResponse status headers body) -> do + let mContentType = lookup hContentType headers + isUTF8ContentType = maybe False YT.Internal.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 $ YT.Internal.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) => 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. +-- +-- ==== __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) => 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. +-- +-- ==== __Examples__ +-- +-- > get HomeR +-- > bodyEquals "

Hello, World

" +bodyEquals :: HasCallStack => String -> YesodExample site () +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 :: (HasCallStack) => 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. +-- +-- ==== __Examples__ +-- +-- > get HomeR +-- > bodyNotContains "

Foo

+-- +-- @since 1.5.3 +bodyNotContains :: (HasCallStack) => 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. +-- +-- ==== __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) => 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. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > htmlAnyContain "p" "Hello" -- At least one

tag contains the string "Hello" +-- +-- Since 0.3.5 +htmlAnyContain :: (HasCallStack) => 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 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) => 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. +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > get HomeR +-- > htmlCount "p" 3 -- There are exactly 3

tags in the response +htmlCount :: (HasCallStack) => 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)) + +-- | 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) => YesodExample site 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: ", YT.Internal.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 :: YesodExample site () +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) => 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. +-- 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 = + YT.SIO.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 = YT.SIO.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 + YT.SIO.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 YT.SIO.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 @\