diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,229 @@ +# ChangeLog for yesod-test + +## 1.7.0.2 + +* Support `yesod-core` 1.7 + +## 1.7.0.1 + +* When `bodyContains` or `bodyNotContains` fail and the content is UTF-8, a partial body is printed to aid debugging. This matches the behavior of `statusIs`. [#1900](https://github.com/yesodweb/yesod/pull/1900) + +## 1.7.0 + +* Make post params be added in addition order like normal forms. [#1867](https://github.com/yesodweb/yesod/pull/1867) + +## 1.6.23.1 + +* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876) + +## 1.6.23 + +* Add `MonadFail` to `SIO` so tests can fail on pattern match failure. [#1874](https://github.com/yesodweb/yesod/pull/1874) + +## 1.6.22 + +- Add upper bounds to all build dependencies to comply with Hackage upload requirements. [#1873](https://github.com/yesodweb/yesod/pull/1873) + +## 1.6.21 + +* Add `browseBody` to yesod-test. [#1872](https://github.com/yesodweb/yesod/pull/1872) + +## 1.6.20 + +* Add `HasCallStack` to more functions. [#1858](https://github.com/yesodweb/yesod/pull/1858) + +## 1.6.19 + +* Add `selectByLabel` to yesod-test. [#1845](https://github.com/yesodweb/yesod/pull/1845) + +## 1.6.18 + +* Add `checkByLabel` to yesod-test. [#1843](https://github.com/yesodweb/yesod/pull/1843) + +## 1.6.17 + +* Add `chooseByLabel` to yesod-test. [#1842](https://github.com/yesodweb/yesod/pull/1842) + +## 1.6.16 + +* Add `addBareGetParam` to yesod-test. [#1821](https://github.com/yesodweb/yesod/pull/1821) + +## 1.6.15 + +* Add `bySelectorLabelContain`. [#1781](https://github.com/yesodweb/yesod/pull/1781) + +## 1.6.14 + +* Fix quotes not matching in htmlContain* functions [#1768](https://github.com/yesodweb/yesod/pull/1768). +* Add logging of the matches found of these functions [#1768](https://github.com/yesodweb/yesod/pull/1768). +* Improved failure messages from `assertEq`. [#1767](https://github.com/yesodweb/yesod/pull/1767) + +## 1.6.13 + +* Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type. + +## 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,75 +2,66 @@ Pragmatic integration tests for haskell web applications using WAI and optionally a database (Persistent). -It's main goal is to encourage integration and system testing of web applications by making everything /easy to test/. +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. +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, -were your forms may have field names generated by the framework or a randomly -generated "\_token" field. +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). -This is the helloworld and kitchen sink. In this case for testing a yesod app. +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 - - import Yesod - import Yesod.Static - import qualified MySite.Settings as Settings - import MySite.Models - - main :: IO a - main = do - cfg <- (loadConfig Test) >>= either fail return - st <- static Settings.staticDir - Settings.withConnectionPool (connStr cfg) $ \cnPool -> do - -- ... Perhaps some code here to truncate your test database? - app <- toWaiApp $ MyApp st cfg - runTests app cnPool $ mySuite - - mySuite = do +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/of/page/with/form" -- Load a page - statusIs 200 -- Assert the status was success + 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 a css queries and assertions. - htmlCount "form .main" 1 -- It matches 1 element - htmlAllContain "h1#mainTitle" "Sign Up Now!" -- All matches have 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: - post "url/to/post/to" $ do - addNonce -- Add the _nonce field with the currently shown value + -- 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" + byLabelExact "Email:" "gustavo@cerati.com" + byLabelExact "Password:" "secret" + byLabelExact "Confirm:" "secret" it "Sends another form, this one has a file" $ do - post "url/to/post/file/to" $ do - -- You can add files this easy, you still have to provide the mime type manually though. + 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 it's name - byName "answer" "42" + -- And of course you can add any field if you know its name. + addPostParam "answer" "42" statusIs 302 - describe "Db access, still very raw" $ do + describe "Database access" $ do it "selects the list" $ do - msgs <- testDB $ do (selectList [] [] :: SqlPersist IO [(Key SqlPersist Message, Message)]) - assertEqual "One Message in the DB" 1 (DL.length msgs) - + -- 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/Test.hs b/Yesod/Test.hs --- a/Yesod/Test.hs +++ b/Yesod/Test.hs @@ -1,673 +1,1898 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-| -Yesod.Test is a pragmatic framework for testing web applications built -using wai and persistent. - -By pragmatic I may also mean 'dirty'. It's 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, -were your forms may have field names generated by the framework or a randomly -generated '_nonce' field. - -Your database is also directly available so you can use runDBRunner 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 - , YesodExample - , YesodSpecTree (..) - , ydescribe - , yit - - -- * Making requests - -- | To make a request you need to point to an url and pass in some parameters. - -- - -- To build your parameters you will use the RequestBuilder monad that lets you - -- add values, add files, lookup fields by label and find the current - -- nonce value and add it to your request too. - -- - , get - , post - , postBody - , request - , addRequestHeader - , setMethod - , addPostParam - , addGetParam - , addFile - , setRequestBody - , RequestBuilder - , setUrl - - -- | Yesod can auto generate field ids, so you are never sure what - -- the argument name should be for each one of your args 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 - - -- | Does the current form have a _nonce? Use any of these to add it to your - -- request parameters. - , addNonce - , addNonce_ - - -- * Assertions - , assertEqual - , assertHeader - , assertNoHeader - , statusIs - , bodyEquals - , bodyContains - , htmlAllContain - , htmlAnyContain - , htmlNoneContain - , htmlCount - - -- * Grab information - , getTestYesod - , getResponse - - -- * 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 as Hspec -import qualified Test.Hspec.Core as Core -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) - --- | The state used in a single test case defined using 'yit' --- --- Since 1.2.0 -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 an 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 = - Core.fromSpecList $ map unYesod $ execWriter yspecs - where - unYesod (YesodSpecGroup x y) = Core.SpecGroup x $ map unYesod y - unYesod (YesodSpecItem x y) = Core.it 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 = - Core.fromSpecList $ map (unYesod getSiteAction) $ execWriter yspecs - where - unYesod :: YesodDispatch t - => IO t -> YesodSpecTree t -> Core.SpecTree - unYesod getSiteAction' (YesodSpecGroup x y) = Core.SpecGroup x $ map (unYesod getSiteAction') y - unYesod getSiteAction' (YesodSpecItem x y) = Core.it x $ do - site <- getSiteAction' - app <- toWaiAppPlain site - 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) - -> (SResponse -> ST.StateT state m a) - -> ST.StateT state m a -withResponse' getter f = maybe err f . getter =<< ST.get - where err = failure "There was no response, you should make a request" - --- | 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) - -> Query - -> ST.StateT state m [HtmlLBS] -htmlQuery' getter query = withResponse' getter $ \ 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. -assertEqual :: (Eq a) => String -> a -> a -> YesodExample site () -assertEqual 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 - -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. -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 - -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 -addFile :: T.Text -> FilePath -> T.Text -> 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 - -byLabel :: T.Text -> T.Text -> RequestBuilder site () -byLabel label value = do - name <- nameFromLabel label - addPostParam name value - -fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site () -fileByLabel label path mime = do - name <- nameFromLabel label - addFile name path mime - --- | Lookup a _nonce form field and add it's value to the params. --- Receives a CSS selector that should resolve to the form element containing the nonce. -addNonce_ :: Query -> RequestBuilder site () -addNonce_ scope = do - matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]" - case matches of - [] -> failure $ "No nonce found in the current page" - element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element - _ -> failure $ "More than one nonce found in the page" - --- | For responses that display a single form, just lookup the only nonce available. -addNonce :: RequestBuilder site () -addNonce = addNonce_ "" - --- | Perform a POST request to url -post :: (Yesod site, RedirectUrl site url) - => url - -> YesodExample site () -post url = request $ do - setMethod "POST" - setUrl url - --- | Perform a POST request to url with sending a body into it. -postBody :: (Yesod site, RedirectUrl site url) - => url - -> BSL8.ByteString - -> YesodExample site () -postBody url body = request $ do - setMethod "POST" - setUrl url - setRequestBody body - --- | Perform a GET request to url, using params -get :: (Yesod site, RedirectUrl site url) - => url - -> YesodExample site () -get url = request $ do - setMethod "GET" - setUrl url - -setMethod :: H.Method -> RequestBuilder site () -setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m } - -setUrl :: (Yesod site, RedirectUrl site url) - => url - -> RequestBuilder site () -setUrl url' = do - site <- fmap rbdSite ST.get - eurl <- runFakeHandler - M.empty - (const $ error "Yesod.Test: No logger available") - site - (toTextUrl url') - url <- either (error . show) return eurl - let (urlPath, urlQuery) = T.break (== '?') url - ST.modify $ \rbd -> rbd - { rbdPath = - case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of - ("http:":_:rest) -> rest - ("https:":_:rest) -> rest - x -> x - , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery) - } - --- | Simple way to set HTTP request body -setRequestBody :: (Yesod site) - => BSL8.ByteString - -> RequestBuilder site () -setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body } - -addRequestHeader :: H.Header -> RequestBuilder site () -addRequestHeader header = ST.modify $ \rbd -> rbd - { rbdHeaders = header : rbdHeaders rbd - } - --- | General interface to performing requests, allowing you to add extra --- headers as well as letting you specify the request method. -request :: Yesod site - => RequestBuilder site () - -> YesodExample site () -request reqBuilder = do - YesodExampleData app site oldCookies mRes <- ST.get - - RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData - { rbdPostData = MultipleItemsPostData [] - , rbdResponse = mRes - , rbdMethod = "GET" - , rbdSite = site - , rbdPath = [] - , rbdGets = [] - , rbdHeaders = [] - } - let path - | null rbdPath = "/" - | otherwise = TE.decodeUtf8 $ Builder.toByteString $ H.encodePathSegments rbdPath - - -- expire cookies and filter them for the current path. TODO: support max age - currentUtc <- liftIO getCurrentTime - let cookies = M.filter (checkCookieTime currentUtc) oldCookies - cookiesForPath = M.filter (checkCookiePath path) cookies - - let req = case rbdPostData of - MultipleItemsPostData x -> - if DL.any isFile x - then (multipart x) - else singlepart - BinaryPostData _ -> singlepart - where singlepart = makeSinglepart cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets - multipart x = makeMultipart cookiesForPath x rbdMethod rbdHeaders path rbdGets - -- let maker = case rbdPostData of - -- MultipleItemsPostData x -> - -- if DL.any isFile x - -- then makeMultipart - -- else makeSinglepart - -- BinaryPostData _ -> makeSinglepart - -- let req = maker cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets - response <- liftIO $ runSession (srequest req) app - let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response - cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies - ST.put $ YesodExampleData app site cookies' (Just response) - where - isFile (ReqFilePart _ _ _ _) = True - isFile _ = False - - checkCookieTime t c = case Cookie.setCookieExpires c of - Nothing -> True - Just t' -> t < t' - checkCookiePath url c = - case Cookie.setCookiePath c of - Nothing -> True - Just x -> x `BS8.isPrefixOf` TE.encodeUtf8 url - - -- For building the multi-part requests - boundary :: String - boundary = "*******noneedtomakethisrandom" - separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] - makeMultipart :: M.Map a0 Cookie.SetCookie - -> [RequestPart] - -> H.Method - -> [H.Header] - -> T.Text - -> H.Query - -> SRequest - makeMultipart cookies parts method extraHeaders urlPath urlQuery = - SRequest simpleRequest' (simpleRequestBody' parts) - where simpleRequestBody' x = - BSL8.fromChunks [multiPartBody x] - simpleRequest' = mkRequest - [ ("Cookie", cookieValue) - , ("Content-Type", contentTypeValue)] - method extraHeaders urlPath urlQuery - cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs - cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) - | c <- map snd $ M.toList cookies ] - contentTypeValue = BS8.pack $ "multipart/form-data; boundary=" ++ boundary - multiPartBody parts = - BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] - multipartPart (ReqKvPart k v) = BS8.concat - [ "Content-Disposition: form-data; " - , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n" - , TE.encodeUtf8 v, "\r\n"] - multipartPart (ReqFilePart k v bytes mime) = BS8.concat - [ "Content-Disposition: form-data; " - , "name=\"", TE.encodeUtf8 k, "\"; " - , "filename=\"", BS8.pack v, "\"\r\n" - , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n" - , BS8.concat $ BSL8.toChunks bytes, "\r\n"] - - -- For building the regular non-multipart requests - makeSinglepart :: M.Map a0 Cookie.SetCookie - -> RBDPostData - -> H.Method - -> [H.Header] - -> T.Text - -> H.Query - -> SRequest - makeSinglepart cookies rbdPostData method extraHeaders urlPath urlQuery = - SRequest simpleRequest' (simpleRequestBody' rbdPostData) - where - simpleRequest' = (mkRequest - [ ("Cookie", cookieValue) - , ("Content-Type", "application/x-www-form-urlencoded")] - method extraHeaders urlPath urlQuery) - simpleRequestBody' (MultipleItemsPostData x) = - BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" - $ map singlepartPart x - simpleRequestBody' (BinaryPostData x) = x - cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs - cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) - | c <- map snd $ M.toList cookies ] - singlepartPart (ReqFilePart _ _ _ _) = "" - singlepartPart (ReqKvPart k v) = T.concat [k,"=",v] - - -- General request making - mkRequest headers method extraHeaders urlPath urlQuery = defaultRequest - { requestMethod = method - , remoteHost = Sock.SockAddrInet 1 2 - , requestHeaders = headers ++ extraHeaders - , rawPathInfo = TE.encodeUtf8 urlPath - , pathInfo = H.decodePathSegments $ TE.encodeUtf8 urlPath - , rawQueryString = H.renderQuery False urlQuery - , queryString = urlQuery - } - --- Yes, just a shortcut -failure :: (MonadIO a) => T.Text -> a b -failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error "" +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Yesod.Test 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.Test + ( -- * Declaring and running your test suite + yesodSpec + , YesodSpec + , yesodSpecWithSiteGenerator + , yesodSpecWithSiteGeneratorAndArgument + , yesodSpecApp + , YesodExample + , YesodExampleData(..) + , TestApp + , YSpec + , testApp + , YesodSpecTree (..) + , ydescribe + , yit + + -- * 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 + , addBareGetParam + , 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. + , byLabel + , byLabelExact + , byLabelContain + , byLabelPrefix + , byLabelSuffix + , bySelectorLabelContain + , fileByLabel + , fileByLabelExact + , fileByLabelContain + , fileByLabelPrefix + , fileByLabelSuffix + , chooseByLabel + , checkByLabel + , selectByLabel + + -- *** 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 + , assertNotEq + , assertEqualNoShow + , assertEq + + , assertHeader + , assertNoHeader + , statusIs + , bodyEquals + , bodyContains + , bodyNotContains + , htmlAllContain + , htmlAnyContain + , htmlNoneContain + , htmlCount + , requireJSONResponse + + -- * Grab information + , getTestYesod + , getResponse + , getRequestCookies + + -- * Debug output + , printBody + , browseBody + , 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.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 + +#if MIN_VERSION_network(3, 0, 0) +import qualified Network.Socket as Sock +#else +import qualified Network.Socket.Internal as Sock +#endif + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import qualified Text.Blaze.Renderer.String as Blaze +import qualified Text.Blaze as Blaze +import Network.Wai +import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) +import Control.Monad.IO.Class +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 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 Text.Show.Pretty (ppShow) +import GHC.Stack (HasCallStack) +import Data.ByteArray.Encoding (convertToBase, Base(..)) +import Network.HTTP.Types.Header (hContentType) +import Data.Aeson (eitherDecode') +import Control.Monad (unless) + +import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8) +import Yesod.Test.Internal.SIO +import qualified Data.Maybe as Maybe + +import System.Directory (getTemporaryDirectory) +import System.Info (os) +import System.Process (callCommand) + +{-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-} +{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-} + +-- | 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 = SIO (YesodExampleData site) + +-- | 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 "SpecTree". +-- +-- 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 getSIO + +-- | Get the most recently provided response value, if available. +-- +-- Since 1.2.0 +getResponse :: YesodExample site (Maybe SResponse) +getResponse = fmap yedResponse getSIO + +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 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 + evalSIO 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 = + 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 + -> Hspec.SpecWith a +yesodSpecWithSiteGeneratorAndArgument 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 $ \a -> do + site <- getSiteAction' a + app <- toWaiAppPlain site + evalSIO 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 + evalSIO 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] + +-- | 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 (site { siteSettingsStoreEmail = True }, id)) +-- > post SendEmailR +-- > -- Assert email created in database +-- +-- > testModifySite (\site -> do +-- > middleware <- makeLogware site +-- > pure (site { appRedisConnection = Nothing }, middleware) +-- > ) +-- +-- @since 1.6.8 +testModifySite :: YesodDispatch site + => (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 + app <- liftIO $ toWaiAppPlain newSite + modifySIO $ \yed -> yed { yedSite = newSite, yedApp = middleware app } + +-- | 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 + modifySIO $ \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 + modifySIO $ \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 + modifySIO $ \yed -> yed { yedCookies = f (yedCookies yed) } + +-- | Clears the current cookies +-- +-- @since 1.6.6 +testClearCookies :: YesodExample site () +testClearCookies = do + modifySIO $ \yed -> yed { yedCookies = M.empty } + +-- Performs a given action using the last response. Use this to create +-- response-level assertions +withResponse' :: HasCallStack + => (state -> Maybe SResponse) + -> [T.Text] + -> (SResponse -> SIO state a) + -> SIO state a +withResponse' getter errTrace f = maybe err f . getter =<< getSIO + 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 -> 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' :: HasCallStack + => (state -> Maybe SResponse) + -> [T.Text] + -> Query + -> SIO state [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 :: 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) + => String -- ^ The message prefix + -> a -- ^ The expected value + -> a -- ^ The actual value + -> YesodExample site () +assertEq m a b = + liftIO $ HUnit.assertEqual msg a b + where msg = "Assertion: " ++ m ++ "\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) => String -> a -> a -> YesodExample site () +assertNotEq m a b = + liftIO $ HUnit.assertBool msg (a /= b) + where msg = "Assertion: " ++ m ++ "\n" ++ + "Both arguments: " ++ ppShow a ++ "\n" + +{-# DEPRECATED assertEqual "Use assertEq instead" #-} +assertEqual :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site () +assertEqual = assertEqualNoShow + +-- | Asserts that the two given values are equal. +-- +-- @since 1.5.2 +assertEqualNoShow :: (HasCallStack, 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. +-- 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 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 => 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 $ \(SResponse status headers body) -> do + let mContentType = lookup hContentType headers + isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType + + liftIO $ flip HUnit.assertBool (body `contains` text) $ concat + [ "Expected body to contain `" + , text + , "`" + , if isUTF8ContentType + then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body) + else "" + ] + +-- | 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 $ \(SResponse status headers body) -> do + let mContentType = lookup hContentType headers + isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType + + liftIO $ flip HUnit.assertBool (not $ body `contains` text) $ concat + [ "Expected body to not contain `" + , text + , "`" + , if isUTF8ContentType + then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body) + else "" + ] + +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 ++ " matches: " ++ show matches) $ + DL.all (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) + +-- | puts the search trough the same escaping as the matches are. +-- this helps with matching on special characters +escape :: String -> String +escape = Blaze.renderMarkup . Blaze.string + +-- | 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 ++ " matches: " ++ show matches) $ + DL.any (DL.isInfixOf (escape 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 (escape 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: ", 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 + +-- | Render the last response and open it in a web browser +-- +-- This is similar to 'printBody', except that it opens the markup in your web +-- browser instead, which may be easier to read than seeing it printed in the +-- terminal. +-- +-- @since 1.6.21 +browseBody :: YesodExample site () +browseBody = withResponse $ \SResponse{ simpleBody = b } -> liftIO $ do + tempDir <- getTemporaryDirectory + (fp, h) <- openTempFile tempDir "yesod-test-response.html" + BSL8.hPutStrLn h b + hFlush h + hClose h + openInBrowser fp + where + openInBrowser path = callCommand $ cmd ++ " " ++ path + cmd = case os of + "darwin" -> "open" + "linux" -> "xdg-open" + "mingw32" -> "start" + _ -> error $ "Unsupported OS: " ++ os + +-- | 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 :: HasCallStack => 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 bare parameter with the given name and no value to the query +-- string. The parameter is added without an @=@ sign. +-- +-- You can specify the entire query string literally by adding a single bare +-- parameter and no other parameters. +-- +-- @since 1.6.16 +-- +-- ==== __Examples__ +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > request $ do +-- > addBareGetParam "key" -- Adds ?key to the URL +addBareGetParam :: T.Text -> RequestBuilder site () +addBareGetParam name = modifySIO $ \rbd -> + rbd {rbdGets = (TE.encodeUtf8 name, Nothing) : 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 :: HasCallStack + => 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 + case genericNameFromHTML match label body of + Left e -> failure e + Right x -> pure x + +-- | +-- This looks up the name of a field based on a CSS selector and the contents of the label pointing to it. +genericNameFromSelectorLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> T.Text -> RequestBuilder site T.Text +genericNameFromSelectorLabel match selector label = do + body <- htmlBody "genericNameSelectorFromLabel" + html <- + case findBySelector body selector of + Left parseError -> failure $ "genericNameFromSelectorLabel: Parse error" <> T.pack parseError + Right [] -> failure $ "genericNameFromSelectorLabel: No fragments match selector " <> selector + Right [matchingFragment] -> pure $ BSL8.pack matchingFragment + Right _matchingFragments -> failure $ "genericNameFromSelectorLabel: Multiple fragments match selector " <> selector + case genericNameFromHTML match label html of + Left e -> failure e + Right x -> pure x + +genericNameFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text +genericNameFromHTML match label html = + let + parsedHTML = parseHTML html + mlabel = parsedHTML + $// C.element "label" + >=> isContentMatch label + mfor = mlabel >>= attribute "for" + + isContentMatch x c + | x `match` T.concat (c $// content) = [c] + | otherwise = [] + + in case mfor of + for:[] -> do + let mname = parsedHTML + $// attributeIs "id" for + >=> attribute "name" + case mname of + "":_ -> Left $ T.concat + [ "Label " + , label + , " resolved to id " + , for + , " which was not found. " + ] + name:_ -> Right name + [] -> Left $ "No input with id " <> for + [] -> + case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of + [] -> Left $ "No label contained: " <> label + name:_ -> Right name + _ -> Left $ "More than one label contained " <> label + +byLabelWithMatch :: HasCallStack + => (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 +-- > byLabel "Username" "Michael" +-- +-- This function also supports the implicit label syntax, in which +-- the @\@ is nested inside the @\