yesod-test 1.5.9.1 → 1.7.0.2
raw patch · 9 files changed
Files
- ChangeLog.md +140/−1
- README.md +3/−3
- Yesod/Test.hs +1898/−1162
- Yesod/Test/CssQuery.hs +2/−1
- Yesod/Test/Internal.hs +64/−0
- Yesod/Test/Internal/SIO.hs +93/−0
- Yesod/Test/TransversingCSS.hs +4/−6
- test/main.hs +410/−26
- yesod-test.cabal +73/−52
ChangeLog.md view
@@ -1,6 +1,145 @@+# 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 -* Fix broken Haddocks+* 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
README.md view
@@ -42,9 +42,9 @@ 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 request $ do
Yesod/Test.hs view
@@ -1,1162 +1,1898 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE ConstraintKinds #-}--{-|-Yesod.Test is a pragmatic framework for testing web applications built-using wai and persistent.--By pragmatic I may also mean 'dirty'. Its main goal is to encourage integration-and system testing of web applications by making everything /easy to test/.--Your tests are like browser sessions that keep track of cookies and the last-visited page. You can perform assertions on the content of HTML responses,-using CSS selectors to explore the document more easily.--You can also easily build requests using forms present in the current page.-This is very useful for testing web applications built in yesod, for example,-where your forms may have field names generated by the framework or a randomly-generated CSRF token input.--Your database is also directly available so you can use 'runDB' to set up-backend pre-conditions, or to assert that your session is having the desired effect.---}--module Yesod.Test- ( -- * Declaring and running your test suite- yesodSpec- , YesodSpec- , yesodSpecWithSiteGenerator- , yesodSpecApp- , YesodExample- , YesodExampleData(..)- , TestApp- , YSpec- , testApp- , YesodSpecTree (..)- , ydescribe- , yit-- -- * Making requests- -- | You can construct requests with the 'RequestBuilder' monad, which lets you- -- set the URL and add parameters, headers, and files. Helper functions are provided to- -- lookup fields by label and to add the current CSRF token from your forms.- -- Once built, the request can be executed with the 'request' method.- --- -- Convenience functions like 'get' and 'post' build and execute common requests.- , get- , post- , postBody- , followRedirect- , getLocation- , request- , addRequestHeader- , setMethod- , addPostParam- , addGetParam- , addFile- , setRequestBody- , RequestBuilder- , 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- , fileByLabel- , fileByLabelExact-- -- *** 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-- -- * Grab information- , getTestYesod- , getResponse- , getRequestCookies-- -- * Debug output- , printBody- , printMatches-- -- * Utils for building your own assertions- -- | Please consider generalizing and contributing the assertions you write.- , htmlQuery- , parseHTML- , withResponse- ) where--import qualified Test.Hspec.Core.Spec as Hspec-import qualified Data.List as DL-import qualified Data.ByteString.Char8 as BS8-import Data.ByteString (ByteString)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.ByteString.Lazy.Char8 as BSL8-import qualified Test.HUnit as HUnit-import qualified Network.HTTP.Types as H-import qualified Network.Socket.Internal as Sock-import Data.CaseInsensitive (CI)-import Network.Wai-import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)-import qualified Control.Monad.Trans.State as ST-import Control.Monad.IO.Class-import System.IO-import Yesod.Core.Unsafe (runFakeHandler)-import Yesod.Test.TransversingCSS-import Yesod.Core-import qualified Data.Text.Lazy as TL-import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)-import Text.XML.Cursor hiding (element)-import qualified Text.XML.Cursor as C-import qualified Text.HTML.DOM as HD-import Control.Monad.Trans.Writer-import qualified Data.Map as M-import qualified Web.Cookie as Cookie-import qualified Blaze.ByteString.Builder as Builder-import Data.Time.Clock (getCurrentTime)-import Control.Applicative ((<$>))-import Text.Show.Pretty (ppShow)-import Data.Monoid (mempty)-#if MIN_VERSION_base(4,9,0)-import GHC.Stack (HasCallStack)-#elif MIN_VERSION_base(4,8,1)-import GHC.Stack (CallStack)-type HasCallStack = (?callStack :: CallStack)-#else-import GHC.Exts (Constraint)-type HasCallStack = (() :: Constraint)-#endif--{-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact instead" #-}-{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact 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 = ST.StateT (YesodExampleData site) IO---- | Mapping from cookie name to value.------ Since 1.2.0-type Cookies = M.Map ByteString Cookie.SetCookie---- | Corresponds to hspec\'s 'Spec'.------ Since 1.2.0-type YesodSpec site = Writer [YesodSpecTree site] ()---- | Internal data structure, corresponding to hspec\'s 'YesodSpecTree'.------ Since 1.2.0-data YesodSpecTree site- = YesodSpecGroup String [YesodSpecTree site]- | YesodSpecItem String (YesodExample site ())---- | Get the foundation value used for the current test.------ Since 1.2.0-getTestYesod :: YesodExample site site-getTestYesod = fmap yedSite ST.get---- | Get the most recently provided response value, if available.------ Since 1.2.0-getResponse :: YesodExample site (Maybe SResponse)-getResponse = fmap yedResponse ST.get--data RequestBuilderData site = RequestBuilderData- { rbdPostData :: RBDPostData- , rbdResponse :: (Maybe SResponse)- , rbdMethod :: H.Method- , rbdSite :: site- , rbdPath :: [T.Text]- , rbdGets :: H.Query- , rbdHeaders :: H.RequestHeaders- }--data RBDPostData = MultipleItemsPostData [RequestPart]- | BinaryPostData BSL8.ByteString---- | Request parts let us discern regular key/values from files sent in the request.-data RequestPart- = ReqKvPart T.Text T.Text- | ReqFilePart T.Text FilePath BSL8.ByteString T.Text---- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments--- to send with your requests. Some of the functions that run on it use the current--- response to analyze the forms that the server is expecting to receive.-type RequestBuilder site = ST.StateT (RequestBuilderData site) IO---- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'--- and 'ConnectionPool'-ydescribe :: String -> YesodSpec site -> YesodSpec site-ydescribe label yspecs = tell [YesodSpecGroup label $ execWriter yspecs]--yesodSpec :: YesodDispatch site- => site- -> YesodSpec site- -> Hspec.Spec-yesodSpec site yspecs =- Hspec.fromSpecList $ map unYesod $ execWriter yspecs- where- unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y- unYesod (YesodSpecItem x y) = Hspec.specItem x $ do- app <- toWaiAppPlain site- ST.evalStateT y YesodExampleData- { yedApp = app- , yedSite = site- , yedCookies = M.empty- , yedResponse = Nothing- }---- | Same as yesodSpec, but instead of taking already built site it--- takes an action which produces site for each test.-yesodSpecWithSiteGenerator :: YesodDispatch site- => IO site- -> YesodSpec site- -> Hspec.Spec-yesodSpecWithSiteGenerator getSiteAction yspecs =- Hspec.fromSpecList $ map (unYesod getSiteAction) $ execWriter yspecs- where- unYesod getSiteAction' (YesodSpecGroup x y) = Hspec.specGroup x $ map (unYesod getSiteAction') y- unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do- site <- getSiteAction'- app <- toWaiAppPlain site- ST.evalStateT y YesodExampleData- { yedApp = app- , yedSite = site- , yedCookies = M.empty- , yedResponse = Nothing- }---- | Same as yesodSpec, but instead of taking a site it--- takes an action which produces the 'Application' for each test.--- This lets you use your middleware from makeApplication-yesodSpecApp :: YesodDispatch site- => site- -> IO Application- -> YesodSpec site- -> Hspec.Spec-yesodSpecApp site getApp yspecs =- Hspec.fromSpecList $ map unYesod $ execWriter yspecs- where- unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y- unYesod (YesodSpecItem x y) = Hspec.specItem x $ do- app <- getApp- ST.evalStateT y YesodExampleData- { yedApp = app- , yedSite = site- , yedCookies = M.empty- , yedResponse = Nothing- }---- | Describe a single test that keeps cookies, and a reference to the last response.-yit :: String -> YesodExample site () -> YesodSpec site-yit label example = tell [YesodSpecItem label example]---- Performs a given action using the last response. Use this to create--- response-level assertions-withResponse' :: MonadIO m- => (state -> Maybe SResponse)- -> [T.Text]- -> (SResponse -> ST.StateT state m a)- -> ST.StateT state m a-withResponse' getter errTrace f = maybe err f . getter =<< ST.get- where err = failure msg- msg = if null errTrace- then "There was no response, you should make a request."- else- "There was no response, you should make a request. A response was needed because: \n - "- <> T.intercalate "\n - " errTrace---- | Performs a given action using the last response. Use this to create--- response-level assertions-withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a-withResponse = withResponse' yedResponse []---- | Use HXT to parse a value from an HTML tag.--- Check for usage examples in this module's source.-parseHTML :: HtmlLBS -> Cursor-parseHTML html = fromDocument $ HD.parseLBS html---- | Query the last response using CSS selectors, returns a list of matched fragments-htmlQuery' :: MonadIO m- => (state -> Maybe SResponse)- -> [T.Text]- -> Query- -> ST.StateT state m [HtmlLBS]-htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res ->- case findBySelector (simpleBody res) query of- Left err -> failure $ query <> " did not parse: " <> T.pack (show err)- Right matches -> return $ map (encodeUtf8 . TL.pack) matches---- | Query the last response using CSS selectors, returns a list of matched fragments-htmlQuery :: Query -> YesodExample site [HtmlLBS]-htmlQuery = htmlQuery' yedResponse []---- | Asserts that the two given values are equal.------ In case they are not equal, error message includes the two values.------ @since 1.5.2-assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()-assertEq m a b =- liftIO $ HUnit.assertBool msg (a == b)- where msg = "Assertion: " ++ m ++ "\n" ++- "First argument: " ++ ppShow a ++ "\n" ++- "Second argument: " ++ ppShow b ++ "\n"---- | Asserts that the two given values are not equal.------ In case they are equal, error mesasge 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.-statusIs :: HasCallStack => 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 :: 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.-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.-bodyEquals :: HasCallStack => 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 :: HasCallStack => String -> YesodExample site ()-bodyContains text = withResponse $ \ res ->- liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $- (simpleBody res) `contains` text---- | Assert the last response doesn't have the given text. The check is performed using the response--- body in full text form.--- @since 1.5.3-bodyNotContains :: HasCallStack => String -> YesodExample site ()-bodyNotContains text = withResponse $ \ res ->- liftIO $ HUnit.assertBool ("Expected body not to contain " ++ text) $- not $ contains (simpleBody res) text--contains :: BSL8.ByteString -> String -> Bool-contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a)---- | Queries the HTML using a CSS selector, and all matched elements must contain--- the given string.-htmlAllContain :: HasCallStack => Query -> String -> YesodExample site ()-htmlAllContain query search = do- matches <- htmlQuery query- case matches of- [] -> failure $ "Nothing matched css query: " <> query- _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $- DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)---- | Queries the HTML using a CSS selector, and passes if any matched--- element contains the given string.------ Since 0.3.5-htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site ()-htmlAnyContain query search = do- matches <- htmlQuery query- case matches of- [] -> failure $ "Nothing matched css query: " <> query- _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $- DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)---- | Queries the HTML using a CSS selector, and fails if any matched--- element contains the given string (in other words, it is the logical--- inverse of htmlAnyContains).------ Since 1.2.2-htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()-htmlNoneContain query search = do- matches <- htmlQuery query- case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of- [] -> return ()- found -> failure $ "Found " <> T.pack (show $ length found) <>- " instances of " <> T.pack search <> " in " <> query <> " elements"---- | Performs a CSS query on the last response and asserts the matched elements--- are as many as expected.-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))---- | Outputs the last response body to stderr (So it doesn't get captured by HSpec)-printBody :: YesodExample site ()-printBody = withResponse $ \ SResponse { simpleBody = b } ->- liftIO $ BSL8.hPutStrLn stderr b---- | Performs a CSS query and print the matches to stderr.-printMatches :: Query -> YesodExample site ()-printMatches query = do- matches <- htmlQuery query- liftIO $ hPutStrLn stderr $ show matches---- | Add a parameter with the given name and value to the request body.-addPostParam :: T.Text -> T.Text -> RequestBuilder site ()-addPostParam name value =- ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }- where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."- addPostData (MultipleItemsPostData posts) =- MultipleItemsPostData $ ReqKvPart name value : posts---- | Add a parameter with the given name and value to the query string.-addGetParam :: T.Text -> T.Text -> RequestBuilder site ()-addGetParam name value = ST.modify $ \rbd -> rbd- { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)- : rbdGets rbd- }---- | Add a file to be posted with the current request.------ Adding a file will automatically change your request content-type to be multipart/form-data.------ ==== __Examples__------ > request $ do--- > addFile "profile_picture" "static/img/picture.png" "img/png"-addFile :: T.Text -- ^ The parameter name for the file.- -> FilePath -- ^ The path to the file.- -> T.Text -- ^ The MIME type of the file, e.g. "image/png".- -> RequestBuilder site ()-addFile name path mimetype = do- contents <- liftIO $ BSL8.readFile path- ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }- where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content."- addPostData (MultipleItemsPostData posts) contents =- MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts---- |--- This looks up the name of a field based on the contents of the label pointing to it.-genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text-genericNameFromLabel match label = do- mres <- fmap rbdResponse ST.get- res <-- case mres of- Nothing -> failure "genericNameFromLabel: No response available"- Just res -> return res- let- body = simpleBody res- mlabel = parseHTML body- $// C.element "label"- >=> isContentMatch label- mfor = mlabel >>= attribute "for"-- isContentMatch x c- | x `match` T.concat (c $// content) = [c]- | otherwise = []-- case mfor of- for:[] -> do- let mname = parseHTML body- $// attributeIs "id" for- >=> attribute "name"- case mname of- "":_ -> failure $ T.concat- [ "Label "- , label- , " resolved to id "- , for- , " which was not found. "- ]- name:_ -> return name- [] -> failure $ "No input with id " <> for- [] ->- case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of- [] -> failure $ "No label contained: " <> label- name:_ -> return name- _ -> failure $ "More than one label contained " <> label--(<>) :: T.Text -> T.Text -> T.Text-(<>) = T.append--byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)- -> T.Text -- ^ The text contained in the @\<label>@.- -> T.Text -- ^ The value to set the parameter to.- -> RequestBuilder site ()-byLabelWithMatch match label value = do- name <- genericNameFromLabel match 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 :: 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 :: T.Text -- ^ The text in the @\<label>@.- -> T.Text -- ^ The value to set the parameter to.- -> RequestBuilder site ()-byLabelExact = byLabelWithMatch (==)---- | 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 :: 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 label path mime = do- name <- genericNameFromLabel T.isInfixOf 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>------ @since 1.5.9-fileByLabelExact :: 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 label path mime = do- name <- genericNameFromLabel (==) label- addFile name path mime---- | 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_ :: 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- [] -> failure $ "No CSRF token found in the current page"- element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element- _ -> 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 :: 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 :: 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 :: 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 :: RequestBuilder site Cookies-getRequestCookies = do- requestBuilderData <- ST.get- headers <- case simpleHeaders Control.Applicative.<$> 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 url = request $ do- setMethod "POST"- setUrl url---- | 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 url = request $ do- setMethod "GET"- 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, Data.Monoid.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 = ST.modify $ \rbd -> rbd { rbdMethod = m }---- | Sets the URL used by the request.------ ==== __Examples__------ > request $ do--- > setUrl HomeR------ > request $ do--- > setUrl ("http://google.com/" :: Text)-setUrl :: (Yesod site, RedirectUrl site url)- => url- -> RequestBuilder site ()-setUrl url' = do- site <- fmap rbdSite ST.get- 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- 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)- }----- | Click on a link defined by a CSS query------ ==== __ Examples__------ > get "/foobar"--- > clickOn "a#idofthelink"------ @since 1.5.7 -clickOn :: 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 = ST.modify $ \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 = ST.modify $ \rbd -> rbd- { rbdHeaders = header : rbdHeaders rbd- }---- | 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 :: 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- { simpleRequest = (simpleRequest req)- { httpVersion = H.http11- }- }) app- let newCookies = parseSetCookies $ 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) ] ++ headersForPostData rbdPostData)- 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]-- -- 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 []) = []- headersForPostData (MultipleItemsPostData _ ) = [("Content-Type", "application/x-www-form-urlencoded")]- headersForPostData (BinaryPostData _ ) = []--- -- 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 :: (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 (ST.StateT (YesodExampleData site) IO a) where- type Arg (ST.StateT (YesodExampleData site) IO a) = TestApp site-- evaluateExample example params action =- Hspec.evaluateExample- (action $ \(site, middleware) -> do- app <- toWaiAppPlain site- _ <- ST.evalStateT example YesodExampleData- { yedApp = middleware app- , yedSite = site- , yedCookies = M.empty- , yedResponse = Nothing- }- return ())- params- ($ ())+{-# 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,7 +10,7 @@ import Prelude hiding (takeWhile) import Data.Text (Text) import Data.Attoparsec.Text-import Control.Applicative+import Control.Applicative (many, (<|>)) import Data.Char import qualified Data.Text as T
+ 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. @@ -42,7 +42,6 @@ import Yesod.Test.CssQuery import qualified Data.Text as T-import qualified Control.Applicative import Text.XML import Text.XML.Cursor import qualified Data.ByteString.Lazy as L@@ -60,7 +59,7 @@ -- * Right: List of matching Html fragments. findBySelector :: HtmlLBS -> Query -> Either String [String] findBySelector html query =- map (renderHtml . toHtml . node) Control.Applicative.<$> findCursorsBySelector html query+ map (renderHtml . toHtml . node) <$> findCursorsBySelector html query -- | Perform a css 'Query' on 'Html'. Returns Either --@@ -69,8 +68,7 @@ -- * Right: List of matching Cursors findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor] findCursorsBySelector html query =- runQuery (fromDocument $ HD.parseLBS html)- Control.Applicative.<$> parseQuery query+ runQuery (fromDocument $ HD.parseLBS html) <$> parseQuery query -- | Perform a css 'Query' on 'Html'. Returns Either --@@ -81,7 +79,7 @@ -- @since 1.5.7 findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]] findAttributeBySelector html query attr =- map (laxAttribute attr) Control.Applicative.<$> findCursorsBySelector html query+ map (laxAttribute attr) <$> findCursorsBySelector html query -- Run a compiled query on Html, returning a list of matching Html fragments.
test/main.hs view
@@ -1,12 +1,15 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-} {-# 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@@ -16,6 +19,7 @@ import Test.HUnit hiding (Test) import Test.Hspec+import qualified Test.Hspec as Hspec import Yesod.Core import Yesod.Form@@ -24,17 +28,25 @@ import Yesod.Test.TransversingCSS import Text.XML import Data.Text (Text, pack)-import Data.Monoid ((<>))-import Control.Applicative-import Network.Wai (pathInfo, requestHeaders)-import Data.Maybe (fromMaybe)+import Data.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 (status301, status303, unsupportedMediaType415)-import Control.Exception.Lifted(SomeException, try)+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@@ -42,12 +54,17 @@ findBySelector_ :: HtmlLBS -> Query -> [String] findBySelector_ x = either error id . findBySelector x -data RoutedApp = RoutedApp+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 ()@@ -111,6 +128,19 @@ ] ] 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@@ -120,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 []@@ -135,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@@ -145,11 +201,13 @@ 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" addToken statusIs 200- bodyEquals "12345"+ -- 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@@ -167,9 +225,17 @@ 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@@ -186,13 +252,44 @@ get ("/htmlWithLink" :: Text) clickOn "a#thelink" statusIs 200- bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>"+ 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 :: Either SomeException ()) <- try (clickOn "a#nonexistentlink")+ 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)@@ -215,7 +312,33 @@ setMethod "POST" setUrl ("/labels" :: Text) byLabel "Foo Bar" "yes"- ydescribe "labels2" $ do+ 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@@ -230,7 +353,63 @@ 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@@ -265,7 +444,34 @@ statusIs 200 printBody bodyContains "Foo"- describe "CSRF with cookies/headers" $ yesodSpec RoutedApp $ do+ 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@@ -307,7 +513,7 @@ r <- followRedirect liftIO $ assertBool "expected a Left when not a redirect" $ isLeft r - describe "route parsing in tests" $ yesodSpec RoutedApp $ do+ describe "route parsing in tests" $ yesodSpec defaultRoutedApp $ do yit "parses location header into a route" $ do -- get CSRF token get HomeR@@ -331,6 +537,56 @@ 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 @@ -350,6 +606,8 @@ 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)@@ -357,22 +615,34 @@ ((mfoo, widget), _) <- runFormPost $ renderDivs $ (,)- Control.Applicative.<$> 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 <- wreq textField "Some WLabel" Nothing+ field1F <- wreqMsg textField "Some WLabel" ("Missing WLabel" :: SomeMessage LiteApp) Nothing field2F <- wreq fileField "Some WFile" Nothing - return $ (,) Control.Applicative.<$> field1F <*> field2F+ 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)@@ -380,6 +650,25 @@ 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@@ -390,7 +679,65 @@ 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@@ -399,6 +746,11 @@ setMessage "Foo" () <- 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@@ -419,8 +771,10 @@ postResourcesR :: Handler () postResourcesR = do- ([("foo", t)], _) <- runRequestBody- sendResponseCreated $ ResourceR t+ t <- runRequestBody >>= \case+ ([("foo", t)], _) -> return t+ _ -> liftIO $ fail "postResourcesR pattern match failure"+ sendResponseCreated $ ResourceR t getResourceR :: Text -> Handler Html getResourceR i = defaultLayout@@ -428,3 +782,33 @@ <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,5 +1,5 @@ name: yesod-test-version: 1.5.9.1+version: 1.7.0.2 license: MIT license-file: LICENSE author: Nubis <nubis@woobiz.com.ar>@@ -7,63 +7,84 @@ 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: API docs and the README are available at <http://www.stackage.org/package/yesod-test>-extra-source-files: README.md, LICENSE, test/main.hs, ChangeLog.md+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: HUnit >= 1.2- , attoparsec >= 0.10- , base >= 4.3 && < 5- , blaze-builder- , blaze-html >= 0.5- , blaze-markup >= 0.5.1- , bytestring >= 0.9- , case-insensitive >= 0.2- , containers- , cookie- , hspec-core == 2.*- , html-conduit >= 0.1- , http-types >= 0.7- , monad-control- , network >= 2.2- , persistent >= 1.0- , pretty-show >= 1.6- , text- , time- , transformers >= 0.2.2- , wai >= 3.0- , wai-extra- , xml-conduit >= 1.0- , xml-types >= 0.3- , yesod-core >= 1.4.14+ 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 >= 1.4.14- , text- , wai- , lifted-base- , http-types+ 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