yesod-test 1.2.3.2 → 1.7.0.2
raw patch · 9 files changed
Files
- ChangeLog.md +229/−0
- README.md +31/−40
- Yesod/Test.hs +1898/−673
- Yesod/Test/CssQuery.hs +47/−47
- Yesod/Test/Internal.hs +64/−0
- Yesod/Test/Internal/SIO.hs +93/−0
- Yesod/Test/TransversingCSS.hs +29/−9
- test/main.hs +636/−18
- yesod-test.cabal +75/−52
+ ChangeLog.md view
@@ -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
README.md view
@@ -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) ```
Yesod/Test.hs view
@@ -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 \<p\> tag exists on the page+ 'htmlAnyContain' \"p\" \"Login\"++ -- yesod-test provides a 'RequestBuilder' monad for building up HTTP requests+ 'request' $ do+ -- Lookup the HTML \<label\> 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 "<html><body><h1>Hello, World</h1></body></html>"+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 "<h1>Foo</h1>"+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 "<h1>Foo</h1>+--+-- @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 <p> tag contains the string "Hello"+--+-- > import qualified Data.Text as T+-- > get HomeR+-- > htmlAllContain (T.pack "h1#mainTitle") "Sign Up Now!" -- All <h1> 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 <p> 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 <p> 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 @\<form\>@.+-- Like HTML @\<form\>@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 @\<label>@.+ -> T.Text -- ^ The value to set the parameter to.+ -> RequestBuilder site ()+byLabelWithMatch match label value = do+ name <- genericNameFromLabel match label+ addPostParam name value++bySelectorLabelWithMatch :: HasCallStack+ => (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)+ -> T.Text -- ^ The CSS selector.+ -> T.Text -- ^ The text contained in the @\<label>@.+ -> T.Text -- ^ The value to set the parameter to.+ -> RequestBuilder site ()+bySelectorLabelWithMatch match selector label value = do+ name <- genericNameFromSelectorLabel match selector label+ addPostParam name value++-- How does this work for the alternate <label><input></label> syntax?++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter+-- for that input to the request body.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit @f1=Michael@ to the server:+--+-- > <form method="POST">+-- > <label for="user">Username</label>+-- > <input id="user" name="f1" />+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > byLabel "Username" "Michael"+--+-- This function also supports the implicit label syntax, in which+-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:+--+-- > <form method="POST">+-- > <label>Username <input name="f1"> </label>+-- > </form>+--+-- Warning: This function looks for any label that contains the provided text.+-- If multiple labels contain that text, this function will throw an error,+-- as in the example below:+--+-- > <form method="POST">+-- > <label for="nickname">Nickname</label>+-- > <input id="nickname" name="f1" />+--+-- > <label for="nickname2">Nickname2</label>+-- > <input id="nickname2" name="f2" />+-- > </form>+--+-- > request $ do+-- > byLabel "Nickname" "Snoyberger"+--+-- Then, it throws "More than one label contained" error.+--+-- Therefore, this function is deprecated. Please consider using 'byLabelExact',+-- which performs the exact match over the provided text.+byLabel :: HasCallStack+ => T.Text -- ^ The text contained in the @\<label>@.+ -> T.Text -- ^ The value to set the parameter to.+ -> RequestBuilder site ()+byLabel = byLabelWithMatch T.isInfixOf++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter+-- for that input to the request body.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit @f1=Michael@ to the server:+--+-- > <form method="POST">+-- > <label for="user">Username</label>+-- > <input id="user" name="f1" />+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > byLabel "Username" "Michael"+--+-- This function also supports the implicit label syntax, in which+-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:+--+-- > <form method="POST">+-- > <label>Username <input name="f1"> </label>+-- > </form>+--+-- @since 1.5.9+byLabelExact :: HasCallStack+ => T.Text -- ^ The text in the @\<label>@.+ -> T.Text -- ^ The value to set the parameter to.+ -> RequestBuilder site ()+byLabelExact = byLabelWithMatch (==)++-- |+-- Contain version of 'byLabelExact'+--+-- Note: Just like 'byLabel', this function throws an error if it finds multiple labels+--+-- @since 1.6.2+byLabelContain :: HasCallStack+ => T.Text -- ^ The text in the @\<label>@.+ -> T.Text -- ^ The value to set the parameter to.+ -> RequestBuilder site ()+byLabelContain = byLabelWithMatch T.isInfixOf++-- |+-- Prefix version of 'byLabelExact'+--+-- Note: Just like 'byLabel', this function throws an error if it finds multiple labels+--+-- @since 1.6.2+byLabelPrefix :: HasCallStack+ => T.Text -- ^ The text in the @\<label>@.+ -> T.Text -- ^ The value to set the parameter to.+ -> RequestBuilder site ()+byLabelPrefix = byLabelWithMatch T.isPrefixOf++-- |+-- Suffix version of 'byLabelExact'+--+-- Note: Just like 'byLabel', this function throws an error if it finds multiple labels+--+-- @since 1.6.2+byLabelSuffix :: HasCallStack+ => T.Text -- ^ The text in the @\<label>@.+ -> T.Text -- ^ The value to set the parameter to.+ -> RequestBuilder site ()+byLabelSuffix = byLabelWithMatch T.isSuffixOf++-- |+-- Note: This function throws an error if it finds multiple labels or if the+-- CSS selector fails to parse, doesn't match any fragment, or matches multiple+-- fragments.+--+-- @since 1.6.15+bySelectorLabelContain :: HasCallStack+ => T.Text -- ^ The CSS selector.+ -> T.Text -- ^ The text in the @\<label>@.+ -> T.Text -- ^ The value to set the parameter to.+ -> RequestBuilder site ()+bySelectorLabelContain = bySelectorLabelWithMatch T.isInfixOf++fileByLabelWithMatch :: 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 @\<label>@.+ -> FilePath -- ^ The path to the file.+ -> T.Text -- ^ The MIME type of the file, e.g. "image/png".+ -> RequestBuilder site ()+fileByLabelWithMatch match label path mime = do+ name <- genericNameFromLabel match label+ addFile name path mime++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit a file with the parameter name @f1@ to the server:+--+-- > <form method="POST">+-- > <label for="imageInput">Please submit an image</label>+-- > <input id="imageInput" type="file" name="f1" accept="image/*">+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > fileByLabel "Please submit an image" "static/img/picture.png" "img/png"+--+-- This function also supports the implicit label syntax, in which+-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:+--+-- > <form method="POST">+-- > <label>Please submit an image <input type="file" name="f1"> </label>+-- > </form>+--+-- Warning: This function has the same issue as 'byLabel'. Please use 'fileByLabelExact' instead.+fileByLabel :: HasCallStack+ => T.Text -- ^ The text contained in the @\<label>@.+ -> FilePath -- ^ The path to the file.+ -> T.Text -- ^ The MIME type of the file, e.g. "image/png".+ -> RequestBuilder site ()+fileByLabel = fileByLabelWithMatch T.isInfixOf++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit a file with the parameter name @f1@ to the server:+--+-- > <form method="POST">+-- > <label for="imageInput">Please submit an image</label>+-- > <input id="imageInput" type="file" name="f1" accept="image/*">+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > fileByLabel "Please submit an image" "static/img/picture.png" "img/png"+--+-- This function also supports the implicit label syntax, in which+-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:+--+-- > <form method="POST">+-- > <label>Please submit an image <input type="file" name="f1"> </label>+-- > </form>+--+-- @since 1.5.9+fileByLabelExact :: HasCallStack+ => T.Text -- ^ The text contained in the @\<label>@.+ -> FilePath -- ^ The path to the file.+ -> T.Text -- ^ The MIME type of the file, e.g. "image/png".+ -> RequestBuilder site ()+fileByLabelExact = fileByLabelWithMatch (==)++-- |+-- Contain version of 'fileByLabelExact'+--+-- Note: Just like 'fileByLabel', this function throws an error if it finds multiple labels+--+-- @since 1.6.2+fileByLabelContain :: HasCallStack+ => T.Text -- ^ The text contained in the @\<label>@.+ -> FilePath -- ^ The path to the file.+ -> T.Text -- ^ The MIME type of the file, e.g. "image/png".+ -> RequestBuilder site ()+fileByLabelContain = fileByLabelWithMatch T.isInfixOf++-- |+-- Prefix version of 'fileByLabelExact'+--+-- Note: Just like 'fileByLabel', this function throws an error if it finds multiple labels+--+-- @since 1.6.2+fileByLabelPrefix :: HasCallStack+ => T.Text -- ^ The text contained in the @\<label>@.+ -> FilePath -- ^ The path to the file.+ -> T.Text -- ^ The MIME type of the file, e.g. "image/png".+ -> RequestBuilder site ()+fileByLabelPrefix = fileByLabelWithMatch T.isPrefixOf++-- |+-- Suffix version of 'fileByLabelExact'+--+-- Note: Just like 'fileByLabel', this function throws an error if it finds multiple labels+--+-- @since 1.6.2+fileByLabelSuffix :: HasCallStack+ => T.Text -- ^ The text contained in the @\<label>@.+ -> FilePath -- ^ The path to the file.+ -> T.Text -- ^ The MIME type of the file, e.g. "image/png".+ -> RequestBuilder site ()+fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf++-- | Lookups the hidden input named "_token" and adds its value to the params.+-- Receives a CSS selector that should resolve to the form element containing the token.+--+-- ==== __Examples__+--+-- > request $ do+-- > addToken_ "#formID"+addToken_ :: HasCallStack => Query -> RequestBuilder site ()+addToken_ scope = do+ matches <-+ htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $+ scope <> " input[name=_token][type=hidden][value]"+ case matches of+ [element] ->+ case attribute "value" $ parseHTML element of+ [] -> failure "Expected at least one value in 'value' attribute"+ valAttr : _ -> addPostParam "_token" valAttr+ [] -> failure $ "No CSRF token found in the current page"+ _ -> failure $ "More than one CSRF token found in the page"++-- | For responses that display a single form, just lookup the only CSRF token available.+--+-- ==== __Examples__+--+-- > request $ do+-- > addToken+addToken :: HasCallStack => RequestBuilder site ()+addToken = addToken_ ""++-- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'.+--+-- Use this function if you're using the CSRF middleware from "Yesod.Core" and haven't customized the cookie or header name.+--+-- ==== __Examples__+--+-- > request $ do+-- > addTokenFromCookie+--+-- Since 1.4.3.2+addTokenFromCookie :: HasCallStack => RequestBuilder site ()+addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName++-- | Looks up the CSRF token stored in the cookie with the given name and adds it to the request headers. An error is thrown if the cookie can't be found.+--+-- Use this function if you're using the CSRF middleware from "Yesod.Core" and have customized the cookie or header name.+--+-- See "Yesod.Core.Handler" for details on this approach to CSRF protection.+--+-- ==== __Examples__+--+-- > import Data.CaseInsensitive (CI)+-- > request $ do+-- > addTokenFromCookieNamedToHeaderNamed "cookieName" (CI "headerName")+--+-- Since 1.4.3.2+addTokenFromCookieNamedToHeaderNamed :: HasCallStack+ => ByteString -- ^ The name of the cookie+ -> CI ByteString -- ^ The name of the header+ -> RequestBuilder site ()+addTokenFromCookieNamedToHeaderNamed cookieName headerName = do+ cookies <- getRequestCookies+ case M.lookup cookieName cookies of+ Just csrfCookie -> addRequestHeader (headerName, Cookie.setCookieValue csrfCookie)+ Nothing -> failure $ T.concat+ [ "addTokenFromCookieNamedToHeaderNamed failed to lookup CSRF cookie with name: "+ , T.pack $ show cookieName+ , ". Cookies were: "+ , T.pack $ show cookies+ ]++-- | Returns the 'Cookies' from the most recent request. If a request hasn't been made, an error is raised.+--+-- ==== __Examples__+--+-- > request $ do+-- > cookies <- getRequestCookies+-- > liftIO $ putStrLn $ "Cookies are: " ++ show cookies+--+-- Since 1.4.3.2+getRequestCookies :: HasCallStack => RequestBuilder site Cookies+getRequestCookies = do+ requestBuilderData <- getSIO+ headers <- case simpleHeaders <$> rbdResponse requestBuilderData of+ Just h -> return h+ Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up."++ return $ M.fromList $ map (\c -> (Cookie.setCookieName c, c)) (parseSetCookies headers)+++-- | Perform a POST request to @url@.+--+-- ==== __Examples__+--+-- > post HomeR+post :: (Yesod site, RedirectUrl site url)+ => url+ -> YesodExample site ()+post = performMethod "POST"++-- | Perform a POST request to @url@ with the given body.+--+-- ==== __Examples__+--+-- > postBody HomeR "foobar"+--+-- > import Data.Aeson+-- > postBody HomeR (encode $ object ["age" .= (1 :: Integer)])+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@.+--+-- ==== __Examples__+--+-- > get HomeR+--+-- > get ("http://google.com" :: Text)+get :: (Yesod site, RedirectUrl site url)+ => url+ -> YesodExample site ()+get = performMethod "GET"++-- | Perform a request using a given method to @url@.+--+-- @since 1.6.3+--+-- ==== __Examples__+--+-- > performMethod "DELETE" HomeR+performMethod :: (Yesod site, RedirectUrl site url)+ => ByteString+ -> url+ -> YesodExample site ()+performMethod method url = request $ do+ setMethod method+ setUrl url++-- | Follow a redirect, if the last response was a redirect.+-- (We consider a request a redirect if the status is+-- 301, 302, 303, 307 or 308, and the Location header is set.)+--+-- ==== __Examples__+--+-- > get HomeR+-- > followRedirect+followRedirect :: Yesod site+ => YesodExample site (Either T.Text T.Text) -- ^ 'Left' with an error message if not a redirect, 'Right' with the redirected URL if it was+followRedirect = do+ mr <- getResponse+ case mr of+ Nothing -> return $ Left "followRedirect called, but there was no previous response, so no redirect to follow"+ Just r -> do+ if not ((H.statusCode $ simpleStatus r) `elem` [301, 302, 303, 307, 308])+ then return $ Left "followRedirect called, but previous request was not a redirect"+ else do+ case lookup "Location" (simpleHeaders r) of+ Nothing -> return $ Left "followRedirect called, but no location header set"+ Just h -> let url = TE.decodeUtf8 h in+ get url >> return (Right url)++-- | Parse the Location header of the last response.+--+-- ==== __Examples__+--+-- > post ResourcesR+-- > (Right (ResourceR resourceId)) <- getLocation+--+-- @since 1.5.4+getLocation :: ParseRoute site => YesodExample site (Either T.Text (Route site))+getLocation = do+ mr <- getResponse+ case mr of+ Nothing -> return $ Left "getLocation called, but there was no previous response, so no Location header"+ Just r -> case lookup "Location" (simpleHeaders r) of+ Nothing -> return $ Left "getLocation called, but the previous response has no Location header"+ Just h -> case parseRoute $ decodePath h of+ Nothing -> return $ Left "getLocation called, but couldn’t parse it into a route"+ Just l -> return $ Right l+ where decodePath b = let (x, y) = BS8.break (== '?') b+ in (H.decodePathSegments x, unJust <$> H.parseQueryText y)+ unJust (a, Just b) = (a, b)+ unJust (a, Nothing) = (a, mempty)++-- | Sets the HTTP method used by the request.+--+-- ==== __Examples__+--+-- > request $ do+-- > setMethod "POST"+--+-- > import Network.HTTP.Types.Method+-- > request $ do+-- > setMethod methodPut+setMethod :: H.Method -> RequestBuilder site ()+setMethod m = modifySIO $ \rbd -> rbd { rbdMethod = m }++-- | Sets the URL used by the request.+--+-- ==== __Examples__+--+-- > request $ do+-- > setUrl HomeR+--+-- > request $ do+-- > setUrl ("http://google.com/" :: Text)+setUrl :: HasCallStack+ => (Yesod site, RedirectUrl site url)+ => url+ -> RequestBuilder site ()+setUrl url' = do+ site <- fmap rbdSite getSIO+ eurl <- Yesod.Core.Unsafe.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+ modifySIO $ \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)+ }+++-- | Click on a link defined by a CSS query+--+-- ==== __ Examples__+--+-- > get "/foobar"+-- > clickOn "a#idofthelink"+--+-- @since 1.5.7+clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()+clickOn query = do+ withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->+ case findAttributeBySelector (simpleBody res) query "href" of+ Left err -> failure $ query <> " did not parse: " <> T.pack (show err)+ Right [[match]] -> get match+ Right matches -> failure $ "Expected exactly one match for clickOn: got " <> T.pack (show matches)++++-- | Simple way to set HTTP request body+--+-- ==== __ Examples__+--+-- > request $ do+-- > setRequestBody "foobar"+--+-- > import Data.Aeson+-- > request $ do+-- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)]+setRequestBody :: BSL8.ByteString -> RequestBuilder site ()+setRequestBody body = modifySIO $ \rbd -> rbd { rbdPostData = BinaryPostData body }++-- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's.+--+-- ==== __Examples__+--+-- > import Network.HTTP.Types.Header+-- > request $ do+-- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0")+addRequestHeader :: H.Header -> RequestBuilder site ()+addRequestHeader header = modifySIO $ \rbd -> rbd+ { rbdHeaders = header : rbdHeaders rbd+ }++-- | Adds a header for <https://en.wikipedia.org/wiki/Basic_access_authentication HTTP Basic Authentication> to the request+--+-- ==== __Examples__+--+-- > request $ do+-- > addBasicAuthHeader "Aladdin" "OpenSesame"+--+-- @since 1.6.7+addBasicAuthHeader :: CI ByteString -- ^ Username+ -> CI ByteString -- ^ Password+ -> RequestBuilder site ()+addBasicAuthHeader username password =+ let credentials = convertToBase Base64 $ CI.original $ username <> ":" <> password+ in addRequestHeader ("Authorization", "Basic " <> credentials)++-- | The general interface for performing requests. 'request' takes a 'RequestBuilder',+-- constructs a request, and executes it.+--+-- The 'RequestBuilder' allows you to build up attributes of the request, like the+-- headers, parameters, and URL of the request.+--+-- ==== __Examples__+--+-- > request $ do+-- > addToken+-- > byLabel "First Name" "Felipe"+-- > setMethod "PUT"+-- > setUrl NameR+request :: HasCallStack+ => RequestBuilder site ()+ -> YesodExample site ()+request reqBuilder = do+ YesodExampleData app site oldCookies mRes <- getSIO++ RequestBuilderData {..} <- liftIO $ execSIO 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+ { simpleRequest = (simpleRequest req)+ { httpVersion = H.http11+ }+ }) app+ let newCookies = parseSetCookies $ simpleHeaders response+ cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies+ putSIO $ 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+ (headersForPostData rbdPostData [ ("Cookie", cookieValue) ])+ method extraHeaders urlPath urlQuery)+ simpleRequestBody' (MultipleItemsPostData x) =+ BSL8.fromChunks $ return $ H.renderSimpleQuery False+ $ reverse $ Maybe.mapMaybe 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 _ _ _ _) = Nothing+ singlepartPart (ReqKvPart k v) = Just (TE.encodeUtf8 k, TE.encodeUtf8 v)++ -- If the request appears to be submitting a form (has key-value pairs) give it the form-urlencoded Content-Type.+ -- The previous behavior was to always use the form-urlencoded Content-Type https://github.com/yesodweb/yesod/issues/1063+ headersForPostData (MultipleItemsPostData (_:_)) = (("Content-Type", "application/x-www-form-urlencoded"):)+ headersForPostData _ = id+++ -- 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+ }+++parseSetCookies :: [H.Header] -> [Cookie.SetCookie]+parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie" ==) . fst) $ headers++-- Yes, just a shortcut+failure :: (HasCallStack, MonadIO a) => T.Text -> a b+failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""++type TestApp site = (site, Middleware)+testApp :: site -> Middleware -> TestApp site+testApp site middleware = (site, middleware)+type YSpec site = Hspec.SpecWith (TestApp site)++instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) where+ type Arg (SIO (YesodExampleData site) a) = TestApp site++ evaluateExample example params action =+ Hspec.evaluateExample+ (action $ \(site, middleware) -> do+ app <- toWaiAppPlain site+ _ <- evalSIO example YesodExampleData+ { yedApp = middleware app+ , yedSite = site+ , yedCookies = M.empty+ , yedResponse = Nothing+ }+ return ())+ params+ ($ ())++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then make this input checked.+-- It is assumed the @\<input>@ has @type=radio@.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit @f1=2@ (i.e. radio button with "Blue" label) to the server:+--+-- > <form method="POST">+-- > <label for="hident2">Color</label>+-- > <div id="hident2">+-- > <div class="radio">+-- > <input id="hident2-none" type="radio" name="f1" value="none" checked>+-- > <label for="hident2-none"><None></label>+-- > </div>+-- > <div class="radio">+-- > <input id="hident2-1" type="radio" name="f1" value="1">+-- > <label for="hident2-1">Red</label>+-- > </div>+-- > <div class="radio">+-- > <input id="hident2-2" type="radio" name="f1" value="2">+-- > <label for="hident2-2">Blue</label>+-- > </div>+-- > <div class="radio">+-- > <input id="hident2-3" type="radio" name="f1" value="3">+-- > <label for="hident2-3">Gray</label>+-- > </div>+-- > <div class="radio">+-- > <input id="hident2-4" type="radio" name="f1" value="4">+-- > <label for="hident2-4">Black</label>+-- > </div>+-- > </div>+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > chooseByLabel "Blue"+--+-- @since 1.6.17+chooseByLabel :: HasCallStack => T.Text -> RequestBuilder site ()+chooseByLabel label = do+ name <- genericNameFromLabel (==) label+ value <- genericValueFromLabel (==) label+ addPostParam name value++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then make this input checked.+-- It is assumed the @\<input>@ has @type=checkbox@.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit @f1=2@ and @f1=4@ (i.e. checked checkboxes are "Blue" and "Black") to the server:+--+-- > <form method="POST">+-- > <label for="hident2">Colors</label>+-- > <span id="hident2">+-- > <input id="hident2-1" type="checkbox" name="f1" value="1">+-- > <label for="hident2-1">Red</label>+-- > <input id="hident2-2" type="checkbox" name="f1" value="2" checked>+-- > <label for="hident2-2">Blue</label>+-- > <input id="hident2-3" type="checkbox" name="f1" value="3">+-- > <label for="hident2-3">Gray</label>+-- > <input id="hident2-4" type="checkbox" name="f1" value="4" checked>+-- > <label for="hident2-4">Black</label>+-- > </span>+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > checkByLabel "Blue"+-- > checkByLabel "Black"+--+-- @since 1.6.18+checkByLabel :: HasCallStack => T.Text -> RequestBuilder site ()+checkByLabel label = do+ name <- genericNameFromLabel (==) label+ value <- genericValueFromLabel (==) label+ addPostParam name value++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<select>@,+-- then finds corresponding @\<option>@ and make this options selected.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit @f1=2@ (i.e. selected option is "Blue") to the server:+--+-- > <form method="post" action="labels-select">+-- > <label for="hident2">Selection List</label>+-- > <select id="hident2" name="f1">+-- > <option value="1">Red</option>+-- > <option value="2">Blue</option>+-- > <option value="3">Gray</option>+-- > <option value="4">Black</option>+-- > </select>+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > setMethod "POST"+-- > selectByLabel "Selection List" "Blue"+--+-- @since 1.6.19+selectByLabel :: HasCallStack => T.Text -> T.Text -> RequestBuilder site ()+selectByLabel label option = do+ name <- genericNameFromLabel (==) label+ parsedHtml <- parseHTML <$> htmlBody "selectByLabel"+ let values = parsedHtml $// C.element "select"+ >=> attributeIs "name" name+ &/ C.element "option"+ >=> isContentMatch option+ >=> attribute "value"+ case values of+ [] -> failure $ T.concat ["selectByLabel: option '" , option, "' not found in select '", label, "'"]+ [value] -> addPostParam name value+ _ -> failure $ T.concat ["selectByLabel: too many options '", option, "' found in select '", label, "'"]+ where isContentMatch x c+ | x == T.concat (c $// content) = [c]+ | otherwise = []++-- |+-- This looks up the value of a field based on the contents of the label pointing to it.+genericValueFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text+genericValueFromLabel match label = do+ body <- htmlBody "genericValueFromLabel"+ case genericValueFromHTML match label body of+ Left e -> failure e+ Right x -> pure x++genericValueFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text+genericValueFromHTML 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 mvalue = parsedHTML+ $// attributeIs "id" for+ >=> attribute "value"+ case mvalue of+ "":_ -> Left $ T.concat+ [ "Label "+ , label+ , " resolved to id "+ , for+ , " which was not found. "+ ]+ value:_ -> Right value+ [] -> Left $ "No input with id " <> for+ [] ->+ case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "value") of+ [] -> Left $ "No label contained: " <> label+ value:_ -> Right value+ _ -> Left $ "More than one label contained " <> label++htmlBody :: HasCallStack => String -> RequestBuilder site BSL8.ByteString+htmlBody funcName = do+ mres <- fmap rbdResponse getSIO+ res <-+ case mres of+ Nothing -> failure $ T.pack $ funcName ++ ": No response available"+ Just res -> return res+ return $ simpleBody res
Yesod/Test/CssQuery.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ -- | Parsing CSS selectors into queries. module Yesod.Test.CssQuery ( SelectorGroup (..)@@ -9,8 +10,11 @@ import Prelude hiding (takeWhile) import Data.Text (Text) import Data.Attoparsec.Text-import Control.Applicative (many, (<|>), optional)+import Control.Applicative (many, (<|>))+import Data.Char +import qualified Data.Text as T+ data SelectorGroup = DirectChildren [Selector] | DeepChildren [Selector]@@ -27,6 +31,13 @@ | ByAttrEnds Text Text deriving (Show, Eq) ++-- The official syntax specification for CSS2 can be found here:+-- http://www.w3.org/TR/CSS2/syndata.html+-- but that spec is tricky to fully support. Instead we do the minimal and we+-- can extend it as needed.++ -- | Parses a query into an intermediate format which is easy to feed to HXT -- -- * The top-level lists represent the top level comma separated queries.@@ -41,66 +52,55 @@ -- Below this line is the Parsec parser for css queries. cssQuery :: Parser [[SelectorGroup]]-cssQuery = sepBy rules (char ',' >> (optional (char ' ')))+cssQuery = many (char ' ') >> sepBy rules (char ',' >> many (char ' ')) rules :: Parser [SelectorGroup] rules = many $ directChildren <|> deepChildren directChildren :: Parser SelectorGroup-directChildren = do- _ <- char '>'- _ <- char ' '- sels <- selectors- _ <- optional $ char ' '- return $ DirectChildren sels+directChildren =+ string "> " >> (many (char ' ')) >> DirectChildren <$> pOptionalTrailingSpace parseSelectors deepChildren :: Parser SelectorGroup-deepChildren = do - sels <- selectors- _ <- optional $ char ' '- return $ DeepChildren sels- -selectors :: Parser [Selector]-selectors = many1 $ parseId- <|> parseClass- <|> parseTag- <|> parseAttr+deepChildren = pOptionalTrailingSpace $ DeepChildren <$> parseSelectors +parseSelectors :: Parser [Selector]+parseSelectors = many1 $+ parseId <|> parseClass <|> parseTag <|> parseAttr+ parseId :: Parser Selector-parseId = do- _ <- char '#'- x <- takeWhile $ flip notElem ",#.[ >"- return $ ById x+parseId = char '#' >> ById <$> pIdent parseClass :: Parser Selector-parseClass = do- _ <- char '.'- x <- takeWhile $ flip notElem ",#.[ >"- return $ ByClass x+parseClass = char '.' >> ByClass <$> pIdent parseTag :: Parser Selector-parseTag = do- x <- takeWhile1 $ flip notElem ",#.[ >"- return $ ByTagName x+parseTag = ByTagName <$> pIdent parseAttr :: Parser Selector-parseAttr = do- _ <- char '['- name <- takeWhile $ flip notElem ",#.=$^*]"- (parseAttrExists name)- <|> (parseAttrWith "=" ByAttrEquals name)- <|> (parseAttrWith "*=" ByAttrContains name)- <|> (parseAttrWith "^=" ByAttrStarts name)- <|> (parseAttrWith "$=" ByAttrEnds name)+parseAttr = pSquare $ choice+ [ ByAttrEquals <$> pIdent <*> (string "=" *> pAttrValue)+ , ByAttrContains <$> pIdent <*> (string "*=" *> pAttrValue)+ , ByAttrStarts <$> pIdent <*> (string "^=" *> pAttrValue)+ , ByAttrEnds <$> pIdent <*> (string "$=" *> pAttrValue)+ , ByAttrExists <$> pIdent+ ] -parseAttrExists :: Text -> Parser Selector-parseAttrExists attrname = do- _ <- char ']'- return $ ByAttrExists attrname+-- | pIdent : Parse an identifier (not yet supporting escapes and unicode as+-- part of the identifier). Basically the regex: [-]?[_a-zA-Z][_a-zA-Z0-9]*+pIdent :: Parser Text+pIdent = do+ leadingMinus <- string "-" <|> pure ""+ nmstart <- T.singleton <$> satisfy (\c -> isAlpha c || c == '_')+ nmchar <- takeWhile (\c -> isAlphaNum c || c == '_' || c == '-')+ return $ T.concat [ leadingMinus, nmstart, nmchar ] -parseAttrWith :: Text -> (Text -> Text -> Selector) -> Text -> Parser Selector-parseAttrWith sign constructor name = do- _ <- string sign- value <- takeWhile $ flip notElem ",#.]"- _ <- char ']'- return $ constructor name value++pAttrValue :: Parser Text+pAttrValue = takeWhile (/= ']')++pSquare :: Parser a -> Parser a+pSquare p = char '[' *> p <* char ']'++pOptionalTrailingSpace :: Parser a -> Parser a+pOptionalTrailingSpace p = p <* many (char ' ')
+ Yesod/Test/Internal.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++-- | This module exposes functions that are used internally by yesod-test.+-- The functions exposed here are _not_ a stable API—they may be changed or removed without any major version bump.+--+-- That said, you may find them useful if your application can accept API breakage.+module Yesod.Test.Internal+ ( getBodyTextPreview+ , contentTypeHeaderIsUtf8+ , assumedUTF8ContentTypes+ ) where++import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as DTLE+import qualified Yesod.Core.Content as Content++-- | Helper function to get the first 1024 characters of the body, assuming it is UTF-8.+-- This function is used to preview the body in case of an assertion failure.+--+-- @since 1.6.10+getBodyTextPreview :: LBS.ByteString -> T.Text+getBodyTextPreview body =+ let characterLimit = 1024+ textBody = TL.toStrict $ DTLE.decodeUtf8 body+ in if T.length textBody < characterLimit+ then textBody+ else T.take characterLimit textBody <> "... (use `printBody` to see complete response body)"++-- | Helper function to determine if we can print a body as plain text, for debugging purposes.+--+-- @since 1.6.10+contentTypeHeaderIsUtf8 :: BS8.ByteString -> Bool+contentTypeHeaderIsUtf8 contentTypeBS =+ -- Convert to Text, so we can use T.splitOn+ let contentTypeText = T.toLower $ TE.decodeUtf8 contentTypeBS+ isUTF8FromCharset = case T.splitOn "charset=" contentTypeText of+ -- Either a specific designation as UTF-8, or ASCII (which is a subset of UTF-8)+ [_, charSet] -> any (`T.isInfixOf` charSet) ["utf-8", "us-ascii"]+ _ -> False++ isInferredUTF8FromContentType = BS8.takeWhile (/= ';') contentTypeBS `Set.member` assumedUTF8ContentTypes++ in isUTF8FromCharset || isInferredUTF8FromContentType++-- | List of Content-Types that are assumed to be UTF-8 (e.g. JSON).+--+-- @since 1.6.10+assumedUTF8ContentTypes :: Set.Set BS8.ByteString+assumedUTF8ContentTypes = Set.fromList $ map Content.simpleContentType+ [ Content.typeHtml+ , Content.typePlain+ , Content.typeJson+ , Content.typeXml+ , Content.typeAtom+ , Content.typeRss+ , Content.typeSvg+ , Content.typeJavascript+ , Content.typeCss+ ]
+ Yesod/Test/Internal/SIO.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | The 'SIO' type is used by "Yesod.Test" to provide exception-safe+-- environment between requests and assertions.+--+-- This module is internal. Breaking changes to this module will not be+-- reflected in the major version of this package.+--+-- @since 1.6.13+module Yesod.Test.Internal.SIO where++import Control.Monad.Trans.Reader (ReaderT (..))+import Conduit (MonadThrow)+import qualified Control.Monad.State.Class as MS+import Yesod.Core+import Data.IORef+#if MIN_VERSION_base(4,13,0)+import GHC.Stack (HasCallStack)+#endif++-- | State + IO+--+-- @since 1.6.0+newtype SIO s a = SIO (ReaderT (IORef s) IO a)+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)++#if MIN_VERSION_base(4,13,0)+-- | @since 1.6.23+instance MonadFail (SIO s) where+ fail :: HasCallStack => String -> SIO s a+ fail = error+#endif++instance MS.MonadState s (SIO s)+ where+ get = getSIO+ put = putSIO++-- | Retrieve the current state in the 'SIO' type.+--+-- Equivalent to 'MS.get'+--+-- @since 1.6.13+getSIO :: SIO s s+getSIO = SIO $ ReaderT readIORef++-- | Put the given @s@ into the 'SIO' state for later retrieval.+--+-- Equivalent to 'MS.put', but the value is evaluated to weak head normal+-- form.+--+-- @since 1.6.13+putSIO :: s -> SIO s ()+putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s++-- | Modify the underlying @s@ state.+--+-- This is strict in the function used, and is equivalent to 'MS.modify''.+--+-- @since 1.6.13+modifySIO :: (s -> s) -> SIO s ()+modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f++-- | Run an 'SIO' action with the intial state @s@ provided, returning the+-- result, and discard the final state.+--+-- @since 1.6.13+evalSIO :: SIO s a -> s -> IO a+evalSIO action =+ fmap snd . runSIO action++-- | Run an 'SIO' action with the initial state @s@ provided, returning the+-- final state, and discarding the result.+--+-- @since 1.6.13+execSIO :: SIO s () -> s -> IO s+execSIO action =+ fmap fst . runSIO action++-- | Run an 'SIO' action with the initial state provided, returning both+-- the result of the computation as well as the final state.+--+-- @since 1.6.13+runSIO :: SIO s a -> s -> IO (s, a)+runSIO (SIO (ReaderT f)) s = do+ ref <- newIORef s+ a <- f ref+ s' <- readIORef ref+ pure (s', a)
Yesod/Test/TransversingCSS.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+ {- | This module uses HXT to transverse an HTML document using CSS selectors. @@ -10,23 +10,24 @@ Only a subset of the CSS spec is currently supported: * By tag name: /table td a/- + * By class names: /.container .content/ * By Id: /#oneId/ * By attribute: /[hasIt]/, /[exact=match]/, /[contains*=text]/, /[starts^=with]/, /[ends$=with]/- + * Union: /a, span, p/- - * Immediate children: /div > p/ + * Immediate children: /div > p/+ * Get jiggy with it: /div[data-attr=yeah] > .mon, .foo.bar div, #oneThing/ -} module Yesod.Test.TransversingCSS ( findBySelector,+ findAttributeBySelector, HtmlLBS, Query, -- * For HXT hackers@@ -41,7 +42,6 @@ import Yesod.Test.CssQuery import qualified Data.Text as T-import Control.Applicative ((<$>), (<*>)) import Text.XML import Text.XML.Cursor import qualified Data.ByteString.Lazy as L@@ -58,9 +58,29 @@ -- -- * Right: List of matching Html fragments. findBySelector :: HtmlLBS -> Query -> Either String [String]-findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x)- <$> (Right $ fromDocument $ HD.parseLBS html)- <*> parseQuery query+findBySelector html query =+ map (renderHtml . toHtml . node) <$> findCursorsBySelector html query++-- | Perform a css 'Query' on 'Html'. Returns Either+--+-- * Left: Query parse error.+--+-- * Right: List of matching Cursors+findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor]+findCursorsBySelector html query =+ runQuery (fromDocument $ HD.parseLBS html) <$> parseQuery query++-- | Perform a css 'Query' on 'Html'. Returns Either+--+-- * Left: Query parse error.+--+-- * Right: List of matching Cursors+--+-- @since 1.5.7+findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]]+findAttributeBySelector html query attr =+ map (laxAttribute attr) <$> findCursorsBySelector html query+ -- Run a compiled query on Html, returning a list of matching Html fragments. runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor]
test/main.hs view
@@ -1,9 +1,25 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- Ignore warnings about using deprecated byLabel/fileByLabel functions+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++module Main+ ( main+ -- avoid warnings+ , resourcesRoutedApp+ , Widget+ ) where+ import Test.HUnit hiding (Test) import Test.Hspec+import qualified Test.Hspec as Hspec import Yesod.Core import Yesod.Form@@ -11,20 +27,46 @@ import Yesod.Test.CssQuery import Yesod.Test.TransversingCSS import Text.XML-import Data.Text (Text)-import Data.Monoid ((<>))-import Control.Applicative-import Network.Wai (pathInfo)-import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import Data.Char (toUpper)+import Network.Wai (pathInfo, rawQueryString, requestHeaders)+import Network.Wai.Test (SResponse(simpleBody))+import Numeric (showHex)+import Data.Maybe (fromMaybe, isNothing)+import Data.Either (isLeft, isRight) +import Test.HUnit.Lang import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD+import Network.HTTP.Types.Status (status200, status301, status303, status403, status422, unsupportedMediaType415)+import UnliftIO.Exception (tryAny, SomeException, try, Exception)+import Control.Monad.IO.Unlift (toIO)+import qualified Web.Cookie as Cookie+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as B8+import Yesod.Test.Internal (contentTypeHeaderIsUtf8)+import Data.Foldable (traverse_) +parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery++findBySelector_ :: HtmlLBS -> Query -> [String] findBySelector_ x = either error id . findBySelector x-parseHtml_ = HD.parseLBS +data RoutedApp = RoutedApp { routedAppInteger :: Integer }++defaultRoutedApp :: RoutedApp+defaultRoutedApp = RoutedApp 0++mkYesod "RoutedApp" [parseRoutes|+/ HomeR GET POST+/resources ResourcesR POST+/resources/#Text ResourceR GET+/get-integer IntegerR GET+/multi-param MultiParamR GET POST+|]+ main :: IO () main = hspec $ do describe "CSS selector parsing" $ do@@ -40,6 +82,22 @@ let html = "<html><head><title>foo</title></head><body><br><p>Hello World</p></body></html>" query = "body > p" in findBySelector_ html query @?= ["<p>Hello World</p>"]+ let query = "form.foo input[name=_token][type=hidden][value]"+ html = "<input name='_token' type='hidden' value='foo'><form class='foo'><input name='_token' type='hidden' value='bar'></form>"+ expected = "<input name=\"_token\" type=\"hidden\" value=\"bar\" />"+ in it query $ findBySelector_ html (pack query) @?= [expected]+ it "descendents and children" $+ let html = "<html><p><b><i><u>hello</u></i></b></p></html>"+ query = "p > b u"+ in findBySelector_ html query @?= ["<u>hello</u>"]+ it "hyphenated classes" $+ let html = "<html><p class='foo-bar'><b><i><u>hello</u></i></b></p></html>"+ query = "p.foo-bar u"+ in findBySelector_ html query @?= ["<u>hello</u>"]+ it "descendents" $+ let html = "<html><p><b><i>hello</i></b></p></html>"+ query = "p i"+ in findBySelector_ html query @?= ["<i>hello</i>"] describe "HTML parsing" $ do it "XHTML" $ let html = "<html><head><title>foo</title></head><body><p>Hello World</p></body></html>"@@ -54,7 +112,7 @@ [NodeContent "Hello World"] ] ]- in parseHtml_ html @?= doc+ in HD.parseLBS html @?= doc it "HTML" $ let html = "<html><head><title>foo</title></head><body><br><p>Hello World</p></body></html>" doc = Document (Prologue [] Nothing []) root []@@ -69,7 +127,20 @@ [NodeContent "Hello World"] ] ]- in parseHtml_ html @?= doc+ in HD.parseLBS html @?= doc+ describe "identifying text-based bodies" $ do+ it "matches content-types with an explicit UTF-8 charset" $ do+ contentTypeHeaderIsUtf8 "application/custom; charset=UTF-8" @?= True+ contentTypeHeaderIsUtf8 "application/custom; charset=utf-8" @?= True+ it "matches content-types with an ASCII charset" $ do+ contentTypeHeaderIsUtf8 "application/custom; charset=us-ascii" @?= True+ it "matches content-types that we assume are UTF-8" $ do+ contentTypeHeaderIsUtf8 "text/html" @?= True+ contentTypeHeaderIsUtf8 "application/json" @?= True+ it "doesn't match content-type headers that are binary data" $ do+ contentTypeHeaderIsUtf8 "image/gif" @?= False+ contentTypeHeaderIsUtf8 "application/pdf" @?= False+ describe "basic usage" $ yesodSpec app $ do ydescribe "tests1" $ do yit "tests1a" $ do@@ -79,6 +150,9 @@ yit "tests1b" $ do get ("/foo" :: Text) statusIs 404+ yit "tests1c" $ do+ performMethod "DELETE" ("/" :: Text)+ statusIs 200 ydescribe "tests2" $ do yit "type-safe URLs" $ do get $ LiteAppRoute []@@ -94,9 +168,32 @@ request $ do setMethod "POST" setUrl $ LiteAppRoute ["post"]- addPostParam "foo" "foobarbaz"+ -- If value uses special characters,+ addPostParam "foo" "foo+bar%41<&baz" statusIs 200- bodyEquals "foobarbaz"+ -- They pass through the server correctly.+ bodyEquals "foo+bar%41<&baz"+ yit "get params" $ do+ get ("/query" :: Text)+ statusIs 200+ bodyEquals ""++ request $ do+ setMethod "GET"+ setUrl $ LiteAppRoute ["query"]+ -- If value uses special characters,+ addGetParam "foo" "foo+bar%41<&baz"+ addBareGetParam "goo+car%41<&caz"+ statusIs 200+ -- They pass through the server correctly.+ let pctEnc c = "%" <> (map toUpper $ showHex (fromEnum c) "")+ plus = pctEnc '+'+ pct = pctEnc '%'+ lt = pctEnc '<'+ amp = pctEnc '&'+ bodyEquals $ mconcat+ [ "goo", plus, "car", pct, "41", lt, amp, "caz",+ "&foo=foo", plus, "bar", pct, "41", lt, amp, "baz"] yit "labels" $ do get ("/form" :: Text) statusIs 200@@ -104,20 +201,95 @@ request $ do setMethod "POST" setUrl ("/form" :: Text)- byLabel "Some Label" "12345"+ byLabel "Some Label" "foo+bar%41<&baz" fileByLabel "Some File" "test/main.hs" "text/plain"- addNonce+ addToken statusIs 200+ -- The '<' and '&' get encoded to HTML entities because+ -- "/form" (unlike "/post") uses toHtml.+ bodyEquals "foo+bar%41<&baz"+ yit "labels WForm" $ do+ get ("/wform" :: Text)+ statusIs 200++ request $ do+ setMethod "POST"+ setUrl ("/wform" :: Text)+ byLabel "Some WLabel" "12345"+ fileByLabel "Some WFile" "test/main.hs" "text/plain"+ addToken+ statusIs 200 bodyEquals "12345" yit "finding html" $ do get ("/html" :: Text) statusIs 200 htmlCount "p" 2 htmlAllContain "p" "Hello"+ htmlAllContain "span" "O'Kon" htmlAnyContain "p" "World" htmlAnyContain "p" "Moon"+ htmlAnyContain "p" "O'Kon" htmlNoneContain "p" "Sun" + -- we found it so we know the+ -- matching on quotes works for NoneContain+ withRunInIO $ \runInIO ->+ shouldThrow (runInIO (htmlNoneContain "span" "O'Kon"))+ (\case HUnitFailure _ _ -> True)+ yit "finds the CSRF token by css selector" $ do+ get ("/form" :: Text)+ statusIs 200++ request $ do+ setMethod "POST"+ setUrl ("/form" :: Text)+ byLabel "Some Label" "12345"+ fileByLabel "Some File" "test/main.hs" "text/plain"+ addToken_ "body"+ statusIs 200+ bodyEquals "12345"+ yit "can follow a link via clickOn" $ do+ get ("/htmlWithLink" :: Text)+ clickOn "a#thelink"+ statusIs 200+ bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon and <span>O'Kon</span></p></body></html>"++ get ("/htmlWithLink" :: Text)+ bad <- tryAny (clickOn "a#nonexistentlink")+ assertEq "bad link" (isLeft bad) True++ ydescribe "custom error message" $ do+ yit "returns the message pass to areqMsg" $ do+ get ("/form" :: Text)+ statusIs 200++ request $ do+ setMethod "POST"+ setUrl ("/form" :: Text)+ addToken+ statusIs 200+ htmlAnyContain ".errors" "Missing Label"+ yit "returns the message pass to mreqMsg" $ do+ get ("/mform" :: Text)+ statusIs 200++ request $ do+ setMethod "POST"+ setUrl ("/mform" :: Text)+ addToken+ statusIs 200+ htmlAnyContain ".errors" "Missing MLabel"+ yit "returns the message pass to wreqMsg" $ do+ get ("/wform" :: Text)+ statusIs 200++ request $ do+ setMethod "POST"+ setUrl ("/wform" :: Text)+ addToken+ statusIs 200+ htmlAnyContain ".errors" "Missing WLabel"+ ydescribe "utf8 paths" $ do yit "from path" $ do get ("/dynamic1/שלום" :: Text)@@ -140,17 +312,281 @@ setMethod "POST" setUrl ("/labels" :: Text) byLabel "Foo Bar" "yes"+ yit "can click radio button" $ do+ get ("/labels-radio-buttons" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("/labels-radio-buttons" :: Text)+ chooseByLabel "Blue"+ addToken+ bodyContains "colorRadioButton = Just Blue"+ yit "can click check boxes" $ do+ get ("/labels-checkboxes" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("/labels-checkboxes" :: Text)+ checkByLabel "Red"+ checkByLabel "Gray"+ addToken+ bodyContains "colorCheckBoxes = [Red,Gray]"+ yit "can select from select list" $ do+ get ("/labels-select" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("/labels-select" :: Text)+ addToken+ selectByLabel "Selection List" "Blue"+ bodyContains "SelectionForm {colorSelection = Blue}"++ ydescribe "byLabel-related tests" $ do+ yit "fails with \"More than one label contained\" error" $ do+ get ("/labels2" :: Text)+ (bad :: Either SomeException ()) <- try (request $ do+ setMethod "POST"+ setUrl ("labels2" :: Text)+ byLabel "hobby" "fishing")+ assertEq "failure wasn't called" (isLeft bad) True+ yit "byLabelExact performs an exact match over the given label name" $ do+ get ("/labels2" :: Text)+ (bad :: Either SomeException ()) <- try (request $ do+ setMethod "POST"+ setUrl ("labels2" :: Text)+ byLabelExact "hobby" "fishing")+ assertEq "failure was called" (isRight bad) True+ yit "byLabelContain looks for the labels which contain the given label name" $ do+ get ("/label-contain" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("check-hobby" :: Text)+ byLabelContain "hobby" "fishing"+ res <- maybe "Couldn't get response" simpleBody <$> getResponse+ assertEq "hobby isn't set" res "fishing"+ yit "byLabelContain throws an error if it finds multiple labels" $ do+ (bad :: Either SomeException ()) <- try (request $ do+ setMethod "POST"+ setUrl ("label-contain-error" :: Text)+ byLabelContain "hobby" "fishing")+ assertEq "failure wasn't called" (isLeft bad) True+ yit "bySelectorLabelContain looks for the selector and label which contain the given label name" $ do+ get ("/selector-label-contain" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("check-hobby" :: Text)+ bySelectorLabelContain "#hobby-container" "hobby" "fishing"+ res <- maybe "Couldn't get response" simpleBody <$> getResponse+ assertEq "hobby isn't set" res "fishing"+ yit "bySelectorLabelContain throws an error if the selector matches multiple elements" $ do+ get ("selector-label-contain-error" :: Text)+ (bad :: Either SomeException ()) <- try (request $ do+ setMethod "POST"+ setUrl ("check-hobby" :: Text)+ bySelectorLabelContain "#hobby-container" "hobby" "fishing")+ assertEq "failure wasn't called" (isLeft bad) True+ yit "byLabelPrefix matches over the prefix of the labels" $ do+ get ("/label-prefix" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("check-hobby" :: Text)+ byLabelPrefix "hobby" "fishing"+ res <- maybe "Couldn't get response" simpleBody <$> getResponse+ assertEq "hobby isn't set" res "fishing"+ yit "byLabelPrefix throws an error if it finds multiple labels" $ do+ (bad :: Either SomeException ()) <- try (request $ do+ setMethod "POST"+ setUrl ("label-prefix-error" :: Text)+ byLabelPrefix "hobby" "fishing")+ assertEq "failure wasn't called" (isLeft bad) True+ yit "byLabelSuffix matches over the suffix of the labels" $ do+ get ("/label-suffix" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("check-hobby" :: Text)+ byLabelSuffix "hobby" "fishing"+ res <- maybe "Couldn't get response" simpleBody <$> getResponse+ assertEq "hobby isn't set" res "fishing"+ yit "byLabelSuffix throws an error if it finds multiple labels" $ do+ (bad :: Either SomeException ()) <- try (request $ do+ setMethod "POST"+ setUrl ("label-suffix-error" :: Text)+ byLabelSuffix "hobby" "fishing")+ assertEq "failure wasn't called" (isLeft bad) True+ ydescribe "Content-Type handling" $ do+ yit "can set a content-type" $ do+ request $ do+ setUrl ("/checkContentType" :: Text)+ addRequestHeader ("Expected-Content-Type","text/plain")+ addRequestHeader ("Content-Type","text/plain")+ statusIs 200+ yit "adds the form-urlencoded Content-Type if you add parameters" $ do+ request $ do+ setUrl ("/checkContentType" :: Text)+ addRequestHeader ("Expected-Content-Type","application/x-www-form-urlencoded")+ addPostParam "foo" "foobarbaz"+ statusIs 200+ yit "defaults to no Content-Type" $ do+ get ("/checkContentType" :: Text)+ statusIs 200+ yit "returns a 415 for the wrong Content-Type" $ do+ -- Tests that the test handler is functioning+ request $ do+ setUrl ("/checkContentType" :: Text)+ addRequestHeader ("Expected-Content-Type","application/x-www-form-urlencoded")+ addRequestHeader ("Content-Type","text/plain")+ statusIs 415+ describe "cookies" $ yesodSpec cookieApp $ do yit "should send the cookie #730" $ do get ("/" :: Text) statusIs 200 post ("/cookie/foo" :: Text)- statusIs 302+ statusIs 303 get ("/" :: Text) statusIs 200 printBody bodyContains "Foo"+ yit "should 422 on the cookie named key" $ do+ get ("cookie/check-no-cookie" :: Text)+ statusIs 200+ testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" }+ get ("cookie/check-no-cookie" :: Text)+ statusIs 422+ yit "should be able to delete a cookie" $ do+ testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" }+ get ("cookie/check-no-cookie" :: Text)+ statusIs 422+ testDeleteCookie "key"+ get ("cookie/check-no-cookie" :: Text)+ statusIs 200+ yit "should be able to clear all cookies" $ do+ testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" }+ get ("cookie/check-no-cookie" :: Text)+ statusIs 422+ testClearCookies+ get ("cookie/check-no-cookie" :: Text)+ statusIs 200+ yit "should be able to modify cookies" $ do+ testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" }+ get ("cookie/check-no-cookie" :: Text)+ statusIs 422+ testModifyCookies (\_ -> Map.empty)+ get ("cookie/check-no-cookie" :: Text)+ statusIs 200+ describe "CSRF with cookies/headers" $ yesodSpec defaultRoutedApp $ do+ yit "Should receive a CSRF cookie and add its value to the headers" $ do+ get ("/" :: Text)+ statusIs 200 + request $ do+ setMethod "POST"+ setUrl ("/" :: Text)+ addTokenFromCookie+ statusIs 200+ yit "Should 403 requests if we don't add the CSRF token" $ do+ get ("/" :: Text)+ statusIs 200++ request $ do+ setMethod "POST"+ setUrl ("/" :: Text)+ statusIs 403+ describe "test redirects" $ yesodSpec app $ do+ yit "follows 303 redirects when requested" $ do+ get ("/redirect303" :: Text)+ statusIs 303+ r <- followRedirect+ liftIO $ assertBool "expected a Right from a 303 redirect" $ isRight r+ statusIs 200+ bodyContains "we have been successfully redirected"++ yit "follows 301 redirects when requested" $ do+ get ("/redirect301" :: Text)+ statusIs 301+ r <- followRedirect+ liftIO $ assertBool "expected a Right from a 301 redirect" $ isRight r+ statusIs 200+ bodyContains "we have been successfully redirected"+++ yit "returns a Left when no redirect was returned" $ do+ get ("/" :: Text)+ statusIs 200+ r <- followRedirect+ liftIO $ assertBool "expected a Left when not a redirect" $ isLeft r++ describe "route parsing in tests" $ yesodSpec defaultRoutedApp $ do+ yit "parses location header into a route" $ do+ -- get CSRF token+ get HomeR+ statusIs 200++ request $ do+ setMethod "POST"+ setUrl $ ResourcesR+ addPostParam "foo" "bar"+ addTokenFromCookie+ statusIs 201++ loc <- getLocation+ liftIO $ assertBool "expected location to be available" $ isRight loc+ let (Right (ResourceR t)) = loc+ liftIO $ assertBool "expected location header to contain post param" $ t == "bar"++ yit "returns a Left when no redirect was returned" $ do+ get HomeR+ statusIs 200+ loc <- getLocation+ liftIO $ assertBool "expected a Left when not a redirect" $ isLeft loc++ describe "modifying site value" $ yesodSpec defaultRoutedApp $ do+ yit "can change site value" $ do+ get ("/get-integer" :: Text)+ bodyContains "0"+ testModifySite (\site -> pure (site { routedAppInteger = 1 }, id))+ get ("/get-integer" :: Text)+ bodyContains "1"++ describe "Basic Authentication" $ yesodSpec app $ do+ yit "rejects no header" $ do+ get ("checkBasicAuth" :: Text)+ statusIs 403+ yit "rejects incorrect header" $ do+ request $ do+ setUrl ("checkBasicAuth" :: Text)+ addBasicAuthHeader "Aladdin" "foo"+ statusIs 403+ yit "accepts correct header" $ do+ request $ do+ setUrl ("checkBasicAuth" :: Text)+ addBasicAuthHeader "Aladdin" "OpenSesame"+ statusIs 200+ describe "JSON parsing" $ yesodSpec app $ do+ yit "checks for a json array" $ do+ get ("get-json-response" :: Text)+ statusIs 200+ xs <- requireJSONResponse+ assertEq "The value is [1]" xs [1 :: Integer]+ yit "checks for valid content-type" $ do+ get ("get-json-wrong-content-type" :: Text)+ statusIs 200+ (requireJSONResponse :: YesodExample site [Integer]) `liftedShouldThrow` (\(e :: SomeException) -> True)+ yit "checks for valid JSON parse" $ do+ get ("get-json-response" :: Text)+ statusIs 200+ (requireJSONResponse :: YesodExample site [Text]) `liftedShouldThrow` (\(e :: SomeException) -> True)++ describe "'addPostParam' order is correct" $ yesodSpec defaultRoutedApp $ do+ yit "should add the parameters in the order they were added" $ do+ let params = [("foo", "foobarbaz"), ("bar", "barbaz"), ("baz", "bazqux")]+ get MultiParamR+ statusIs 200+ request $ do+ setMethod "POST"+ setUrl MultiParamR+ addToken+ traverse_ (uncurry addPostParam) params+ statusIs 200+ bodyContains $ T.unpack $ T.intercalate " -- " $ map (\(k, v) -> k <> ": " <> v) params+ instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage @@ -170,27 +606,209 @@ case mfoo of Nothing -> error "No foo" Just foo -> return foo+ onStatic "query" . dispatchTo $+ T.pack . B8.unpack . rawQueryString <$> waiRequest+ onStatic "redirect301" $ dispatchTo $ redirectWith status301 ("/redirectTarget" :: Text) >> return ()+ onStatic "redirect303" $ dispatchTo $ redirectWith status303 ("/redirectTarget" :: Text) >> return ()+ onStatic "redirectTarget" $ dispatchTo $ return ("we have been successfully redirected" :: Text) onStatic "form" $ dispatchTo $ do ((mfoo, widget), _) <- runFormPost $ renderDivs $ (,)- <$> areq textField "Some Label" Nothing+ <$> areqMsg textField "Some Label" ("Missing Label" :: SomeMessage LiteApp) Nothing <*> areq fileField "Some File" Nothing case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget+ onStatic "mform" $ dispatchTo $ do+ ((mfoo, widget), _) <- runFormPost $ renderDivs $ formToAForm $ do+ (field1F, field1V) <- mreqMsg textField "Some MLabel" ("Missing MLabel" :: SomeMessage LiteApp) Nothing+ (field2F, field2V) <- mreq fileField "Some MFile" Nothing++ return+ ( (,) <$> field1F <*> field2F+ , [field1V, field2V]+ )+ case mfoo of+ FormSuccess (foo, _) -> return $ toHtml foo+ _ -> defaultLayout widget+ onStatic "wform" $ dispatchTo $ do+ ((mfoo, widget), _) <- runFormPost $ renderDivs $ wFormToAForm $ do+ field1F <- wreqMsg textField "Some WLabel" ("Missing WLabel" :: SomeMessage LiteApp) Nothing+ field2F <- wreq fileField "Some WFile" Nothing++ return $ (,) <$> field1F <*> field2F+ case mfoo of+ FormSuccess (foo, _) -> return $ toHtml foo+ _ -> defaultLayout widget onStatic "html" $ dispatchTo $- return ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" :: Text)+ return ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon and <span>O'Kon</span></p></body></html>" :: Text) + onStatic "htmlWithLink" $ dispatchTo $+ return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text) onStatic "labels" $ dispatchTo $ return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)+ onStatic "labels2" $ dispatchTo $+ return ("<html><label for='hobby'>hobby</label><label for='hobby2'>hobby2</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)+ onStatic "label-contain" $ dispatchTo $+ return ("<html><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)+ onStatic "label-contain-error" $ dispatchTo $+ return ("<html><label for='hobby'>XXXhobbyXXX</label><label for='hobby2'>XXXhobby2XXX</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)+ onStatic "selector-label-contain" $ dispatchTo $+ return ("<html><div><label for='hobby-1'>XXXhobbyXXX</label><input type='text' name='hobby-1' id='hobby-1'></div><div id='hobby-container'><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></div></html>" :: Text)+ onStatic "selector-label-contain-error" $ dispatchTo $+ return ("<html><div id='hobby-container'><label for='hobby-1'>XXXhobbyXXX</label><input type='text' name='hobby-1' id='hobby-1'></div><div id='hobby-container'><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></div></html>" :: Text)+ onStatic "label-prefix" $ dispatchTo $+ return ("<html><label for='hobby'>hobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)+ onStatic "label-prefix-error" $ dispatchTo $+ return ("<html><label for='hobby'>hobbyXXX</label><label for='hobby2'>hobby2XXX</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)+ onStatic "label-suffix" $ dispatchTo $+ return ("<html><label for='hobby'>XXXhobby</label><input type='text' name='hobby' id='hobby'></html>" :: Text)+ onStatic "label-suffix-error" $ dispatchTo $+ return ("<html><label for='hobby'>XXXhobby</label><label for='hobby2'>XXXneo-hobby</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)+ onStatic "check-hobby" $ dispatchTo $ do+ hobby <- lookupPostParam "hobby"+ return $ fromMaybe "No hobby" hobby + onStatic "checkContentType" $ dispatchTo $ do+ headers <- requestHeaders <$> waiRequest + let actual = lookup "Content-Type" headers+ expected = lookup "Expected-Content-Type" headers++ if actual == expected+ then return ()+ else sendResponseStatus unsupportedMediaType415 ()+ onStatic "checkBasicAuth" $ dispatchTo $ do+ headers <- requestHeaders <$> waiRequest+ let authHeader = lookup "Authorization" headers++ -- Copied from the Wikipedia Aladdin:OpenSesame example+ if authHeader == Just "Basic QWxhZGRpbjpPcGVuU2VzYW1l"+ then return ()+ else sendResponseStatus status403 ()+ onStatic "get-json-response" $ dispatchTo $ do+ (sendStatusJSON status200 ([1] :: [Integer])) :: LiteHandler Value+ onStatic "get-json-wrong-content-type" $ dispatchTo $ do+ return ("[1]" :: Text)++ onStatic "labels-radio-buttons" $ dispatchTo $ do+ ((result, widget), _) <- runFormPost+ $ renderDivs+ $ RadioButtonForm <$> aopt (radioField' optionsEnum) "Color" Nothing+ case result of+ FormSuccess color -> return $ toHtml $ show color+ _ -> defaultLayout [whamlet|$newline never+ <p>+ ^{toHtml $ show result}+ <form method=post action="labels-radio-buttons">+ ^{widget}+ |]++ onStatic "labels-checkboxes" $ dispatchTo $ do+ ((result, widget), _) <- runFormPost+ $ renderDivs+ $ CheckboxesForm <$> areq (checkboxesField' optionsEnum) "Checkboxes" (Just [Blue, Black])+ case result of+ FormSuccess color -> return $ toHtml $ show color+ _ -> defaultLayout [whamlet|$newline never+ <p>+ ^{toHtml $ show result}+ <form method=post action="labels-checkboxes">+ ^{widget}+ |]++ onStatic "labels-select" $ dispatchTo $ do+ ((result, widget), _) <- runFormPost+ $ renderDivs+ $ SelectionForm <$> areq (selectField optionsEnum) "Selection List" Nothing+ case result of+ FormSuccess color -> return $ toHtml $ show color+ _ -> defaultLayout [whamlet|$newline never+ <p>+ ^{toHtml $ show result}+ <form method=post action="labels-checkboxes">+ ^{widget}+ |]++data Color = Red | Blue | Gray | Black+ deriving (Show, Eq, Enum, Bounded)++newtype RadioButtonForm = RadioButtonForm { colorRadioButton :: Maybe Color } deriving Show+newtype CheckboxesForm = CheckboxesForm { colorCheckBoxes :: [Color] } deriving Show+newtype SelectionForm = SelectionForm {colorSelection :: Color } deriving Show+ cookieApp :: LiteApp cookieApp = liteApp $ do dispatchTo $ fromMaybe "no message available" <$> getMessage onStatic "cookie" $ do onStatic "foo" $ dispatchTo $ do setMessage "Foo"- redirect ("/cookie/home" :: Text)+ () <- redirect ("/cookie/home" :: Text) return ()+ onStatic "check-no-cookie" $ dispatchTo $ do+ mCookie <- lookupCookie "key"+ if isNothing mCookie+ then return ()+ else sendResponseStatus status422 ()++instance Yesod RoutedApp where+ yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware++getHomeR :: Handler Html+getHomeR = defaultLayout+ [whamlet|+ <p>+ Welcome to my test application.+ |]++postHomeR :: Handler Html+postHomeR = defaultLayout+ [whamlet|+ <p>+ Welcome to my test application.+ |]++postResourcesR :: Handler ()+postResourcesR = do+ t <- runRequestBody >>= \case+ ([("foo", t)], _) -> return t+ _ -> liftIO $ fail "postResourcesR pattern match failure"+ sendResponseCreated $ ResourceR t++getResourceR :: Text -> Handler Html+getResourceR i = defaultLayout+ [whamlet|+ <p>+ Read item #{i}.+ |]++getIntegerR :: Handler Text+getIntegerR = do+ app <- getYesod+ pure $ T.pack $ show (routedAppInteger app)++getMultiParamR :: Handler Html+getMultiParamR = do+ req <- getRequest+ defaultLayout [whamlet|+ <form method=post action=@{MultiParamR}>+ <input type=hidden name=#{defaultCsrfParamName} value=#{fromMaybe mempty (reqToken req)}>+ |]++postMultiParamR :: Handler Html+postMultiParamR = do+ (reqParts,_) <- runRequestBody+ pure [shamlet|+ $forall (name, part) <- reqParts+ $if name /= "_token"+ #{name}: #{part} -- #+ |]++-- infix Copied from HSpec's version+infix 1 `liftedShouldThrow`++liftedShouldThrow :: (MonadUnliftIO m, HasCallStack, Exception e) => m a -> Hspec.Selector e -> m ()+liftedShouldThrow action sel = do+ ioAction <- toIO action+ liftIO $ ioAction `shouldThrow` sel
yesod-test.cabal view
@@ -1,67 +1,90 @@ name: yesod-test-version: 1.2.3.2+version: 1.7.0.2 license: MIT license-file: LICENSE author: Nubis <nubis@woobiz.com.ar>-maintainer: Nubis <nubis@woobiz.com.ar>, Michael Snoyman-synopsis: integration testing for WAI/Yesod Applications +maintainer: Michael Snoyman, Greg Weber, Nubis <nubis@woobiz.com.ar>+synopsis: integration testing for WAI/Yesod Applications category: Web, Yesod, Testing stability: Experimental-cabal-version: >= 1.8+cabal-version: >=1.10 build-type: Simple homepage: http://www.yesodweb.com-description: Behaviour Oriented integration Testing for Yesod Applications -extra-source-files: README.md, LICENSE, test/main.hs+description:+ API docs and the README are available at <http://www.stackage.org/package/yesod-test> +extra-source-files:+ ChangeLog.md+ LICENSE+ README.md+ test/main.hs+ library- build-depends: base >= 4.3 && < 5- , attoparsec >= 0.10- , persistent >= 1.0- , transformers >= 0.2.2- , wai >= 1.3- , wai-test >= 1.3- , wai-extra- , network >= 2.2- , http-types >= 0.7- , HUnit >= 1.2- , hspec >= 1.4- , bytestring >= 0.9- , case-insensitive >= 0.2- , text- , xml-conduit >= 1.0- , xml-types >= 0.3- , containers- , html-conduit >= 0.1- , blaze-html >= 0.5- , blaze-markup >= 0.5.1- , monad-control- , time- , blaze-builder- , cookie- , yesod-core >= 1.2+ default-language: Haskell2010+ build-depends:+ aeson >= 1.0 && < 2.3+ , attoparsec >= 0.10 && < 0.15+ , base >= 4.11 && < 5+ , blaze-builder >= 0.3.1 && < 0.5+ , blaze-html >= 0.5 && < 0.10+ , blaze-markup >= 0.6 && < 0.9+ , bytestring >= 0.9 && < 0.13+ , case-insensitive >= 0.2 && < 1.3+ , conduit >= 1.3 && < 1.4+ , containers >= 0.5 && < 0.8+ , cookie >= 0.4 && < 0.6+ , directory >= 1.2 && < 1.4+ , hspec-core >= 2 && < 3+ , html-conduit >= 0.1 && < 1.4+ , http-types >= 0.7 && < 0.13+ , HUnit >= 1.2 && < 1.7+ , memory >= 0.14 && < 0.19+ , mtl >= 2.0.0 && < 2.4+ , network >= 2.2 && < 3.3+ , pretty-show >= 1.6 && < 1.11+ , process >= 1.6 && < 1.7+ , text >= 1.2 && < 2.2+ , time >= 1.5 && < 1.15+ , transformers >= 0.2.2 && < 0.7+ , wai >= 3.0 && < 3.3+ , wai-extra >= 3.0 && < 3.2+ , xml-conduit >= 1.0 && < 1.11+ , xml-types >= 0.3 && < 0.4+ , yesod-core >= 1.6.17 && < 1.8 - exposed-modules: Yesod.Test- Yesod.Test.CssQuery- Yesod.Test.TransversingCSS- ghc-options: -Wall+ exposed-modules:+ Yesod.Test+ Yesod.Test.CssQuery+ Yesod.Test.Internal+ Yesod.Test.Internal.SIO+ Yesod.Test.TransversingCSS + ghc-options: -Wall+ test-suite test- type: exitcode-stdio-1.0- main-is: main.hs- hs-source-dirs: test- build-depends: base- , yesod-test- , hspec- , HUnit- , xml-conduit- , bytestring- , containers- , html-conduit- , yesod-core- , yesod-form- , text- , wai+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ build-depends:+ base+ , bytestring+ , containers+ , cookie+ , hspec+ , html-conduit+ , http-types+ , HUnit+ , text+ , unliftio+ , unliftio-core+ , wai+ , wai-extra+ , xml-conduit+ , yesod-core+ , yesod-form >=1.6+ , yesod-test source-repository head- type: git- location: git://github.com/yesodweb/yesod.git+ type: git+ location: https://github.com/yesodweb/yesod.git