hspec-yesod (empty) → 0.1.0

raw patch · 7 files changed

+2405/−0 lines, 7 filesdep +HUnitdep +aesondep +attoparsecsetup-changed

Dependencies added: HUnit, aeson, attoparsec, base, blaze-builder, blaze-html, bytestring, case-insensitive, conduit, containers, cookie, exceptions, hspec, hspec-core, hspec-yesod, html-conduit, http-types, memory, mtl, network, pretty-show, text, time, transformers, unliftio, unliftio-core, wai, wai-extra, xml-conduit, xml-types, yesod-core, yesod-form, yesod-test

Files

• ChangeLog.md +5/−0
• LICENSE +20/−0
• README.md +71/−0
• Setup.lhs +7/−0
• hspec-yesod.cabal +77/−0
• src/Test/Hspec/Yesod.hs +1563/−0
• test/main.hs +662/−0

@@ -0,0 +1,5 @@+# ChangeLog for hspec-yesod++## 0.1.0++- Initial release and fork from `yesod-test`.

@@ -0,0 +1,20 @@+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,71 @@+# hspec-yesod
+
+A fork of [`yesod-test`](https://hackage.haskell.org/package/yesod-test) that provides more integration with `hspec` features, like hooks.
+
+## README of `yesod-test`
+
+Pragmatic integration tests for haskell web applications using WAI and optionally a database (Persistent).
+
+Its main goal is to encourage integration and system testing of web applications by making everything *easy to test*. 
+
+Your tests are like browser sessions that keep track of cookies and the last
+visited page. You can perform assertions on the content of HTML responses
+using CSS selectors.
+
+You can also easily build requests using forms present in the current page.
+This is very useful for testing web applications built in yesod for example,
+where your forms may have field names generated by the framework or a randomly
+generated CSRF "\_token" field.
+
+Your database is also directly available so you can use runDB to set up
+backend pre-conditions, or to assert that your session is having the desired effect.
+
+The testing facilities behind the scenes are HSpec (on top of HUnit).
+
+The code sample below covers the core concepts of yesod-test. Check out the
+[yesod-scaffolding for usage in a complete application](https://github.com/yesodweb/yesod-scaffold/tree/postgres/test).
+
+```haskell
+spec :: Spec
+spec = withApp $ do
+    describe "Basic navigation and assertions" $ do
+      it "Gets a page that has a form, with auto generated fields and token" $ do
+        get ("url/to/page/with/form" :: Text) -- Load a page.
+        statusIs 200 -- Assert the status was success.
+
+        bodyContains "Hello Person" -- Assert any part of the document contains some text.
+        
+        -- Perform CSS queries and assertions.
+        htmlCount "form .main" 1 -- It matches 1 element.
+        htmlAllContain "h1#mainTitle" "Sign Up Now!" -- All matches have some text.
+
+        -- Performs the POST using the current page to extract field values:
+        request $ do
+          setMethod "POST"
+          setUrl SignupR
+          addToken -- Add the CSRF _token field with the currently shown value.
+
+          -- Lookup field by the text on the labels pointing to them.
+          byLabel "Email:" "gustavo@cerati.com"
+          byLabel "Password:" "secret"
+          byLabel "Confirm:" "secret"
+
+      it "Sends another form, this one has a file" $ do
+        request $ do
+          setMethod "POST"
+          setUrl ("url/to/post/file/to" :: Text)
+          -- You can easily add files, though you still need to provide the MIME type for them.
+          addFile "file_field_name" "path/to/local/file" "image/jpeg"
+          
+          -- And of course you can add any field if you know its name.
+          addPostParam "answer" "42"
+
+        statusIs 302
+
+    describe "Database access" $ do
+      it "selects the list" $ do
+        -- See the Yesod scaffolding for the runDB implementation
+        msgs <- runDB $ selectList ([] :: [Filter Message]) []
+        assertEqual "One Message in the DB" 1 (length msgs)
+```
+

@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain

@@ -0,0 +1,77 @@+name:               hspec-yesod+version:            0.1.0+license:            MIT+license-file:       LICENSE+author:             Nubis <nubis@woobiz.com.ar>, Matt Parsons <parsonsmatt@gmail.com>+maintainer:         Matt Parsons <parsonsmatt@gmail.com>+synopsis:           A variation of yesod-test that follows hspec idioms more closely+category:           Web, Yesod, Testing+stability:          Experimental+cabal-version:      >= 1.10+build-type:         Simple+homepage:           https://www.github.com/parsonsmatt/hspec-yesod+description:        Please see the README on GitHub for more information+extra-source-files: README.md, LICENSE, test/main.hs, ChangeLog.md++library+    default-language: Haskell2010+    build-depends:   HUnit                     >= 1.2+                   , aeson+                   , attoparsec                >= 0.10+                   , base                      >= 4.10     && < 5+                   , blaze-builder+                   , blaze-html                >= 0.5+                   , bytestring                >= 0.9+                   , case-insensitive          >= 0.2+                   , conduit+                   , containers+                   , cookie+                   , exceptions   +                   , hspec-core                == 2.*+                   , html-conduit              >= 0.1+                   , http-types                >= 0.7+                   , network                   >= 3.0+                   , memory+                   , pretty-show               >= 1.6+                   , text+                   , time+                   , mtl                       >= 2.0.0+                   , transformers              >= 0.2.2+                   , wai                       >= 3.0+                   , wai-extra+                   , xml-conduit               >= 1.0+                   , xml-types                 >= 0.3+                   , yesod-core                >= 1.6.17+                   , yesod-test                 ++    exposed-modules: Test.Hspec.Yesod+    ghc-options:  -Wall -fwarn-redundant-constraints+    hs-source-dirs: src++test-suite test+    default-language: Haskell2010+    type: exitcode-stdio-1.0+    main-is: main.hs+    hs-source-dirs: test+    build-depends:          base+                          , yesod-test+                          , hspec+                          , hspec-yesod+                          , HUnit+                          , xml-conduit+                          , bytestring+                          , containers+                          , html-conduit+                          , yesod-core+                          , yesod-form >= 1.6+                          , text+                          , wai+                          , wai-extra+                          , http-types+                          , unliftio+                          , cookie+                          , unliftio-core++source-repository head+  type: git+  location: git://github.com/yesodweb/yesod.git

@@ -0,0 +1,1563 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|++"Test.Hspec.Yesod" is a fork of "Yesod.Test" that is designed to be a mostly drop-in replacement that follows the @hspec@ idioms more closely.+The intention is to provide a test framework that allows for easier integration testing of your web application.++Your tests are like browser sessions that keep track of cookies and the last+visited page. You can perform assertions on the content of HTML responses,+using CSS selectors to explore the document more easily.++You can also easily build requests using forms present in the current page.+This is very useful for testing web applications built in yesod, for example,+where your forms may have field names generated by the framework or a randomly+generated CSRF token input.++=== Example project++The best way to see an example project using yesod-test is to create a scaffolded Yesod project:++@stack new projectname yesod-sqlite@++(See https://github.com/commercialhaskell/stack-templates/wiki#yesod for the full list of Yesod templates)++The scaffolded project makes your database directly available in tests, so you can use 'runDB' to set up+backend pre-conditions, or to assert that your session is having the desired effect.+It also handles wiping your database between each test.++=== Example code++The code below should give you a high-level idea of yesod-test's capabilities.+Note that it uses helper functions like @withApp@ and @runDB@ from the scaffolded project; these aren't provided by yesod-test.++@+spec :: Spec+spec = withApp $ do+  describe \"Homepage\" $ do+    it "loads the homepage with a valid status code" $ do+      'get' HomeR+      'statusIs' 200+  describe \"Login Form\" $ do+    it "Only allows dashboard access after logging in" $ do+      'get' DashboardR+      'statusIs' 401++      'get' HomeR+      -- Assert a \<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.++== Scaling++One problem with this approach is that the test suite doesn't scale particularly well.+In order to call a @withApp :: SpecWith (YesodExampleData App) -> Spec@ sort of function, you need to depend on every single module that any @Handler@ modules depends on.+This slows down compilation significantly in very large projects, especially if you're combining your tests and library into a package component (which generally greatly improves build/test cycles).++As a result, it is generally better to separate your integration tests and your unit tests into different modules.++-}++module Test.Hspec.Yesod+    ( -- * Declaring and running your test suite+      yesodSpec+    , YesodSpec+    , yesodSpecWithSiteGenerator+    , yesodSpecWithSiteGeneratorAndArgument+    , YesodExample+    , YesodExampleData(..)+    , TestApp (..)+    , YSpec+    , mkTestApp+    , ydescribe+    , yit++    -- * Hspec Hooks+    , ybefore_+    , ybefore+    , ybeforeWith+    , addYesodTestCleanupHook++    -- * Modify test site+    , testModifySite++    -- * Modify test state+    , testSetCookie+    , testDeleteCookie+    , testModifyCookies+    , testClearCookies++    -- * Constructing 'YesodExampleData'+    , siteToYesodExampleData++    -- * Making requests+    -- | You can construct requests with the 'RequestBuilder' monad, which lets you+    -- set the URL and add parameters, headers, and files. Helper functions are provided to+    -- lookup fields by label and to add the current CSRF token from your forms.+    -- Once built, the request can be executed with the 'request' method.+    --+    -- Convenience functions like 'get' and 'post' build and execute common requests.+    , get+    , post+    , postBody+    , performMethod+    , followRedirect+    , getLocation+    , request+    , addRequestHeader+    , addBasicAuthHeader+    , setMethod+    , addPostParam+    , addGetParam+    , addFile+    , setRequestBody+    , RequestBuilder+    , SIO+    , setUrl+    , clickOn++    -- *** Adding fields by label+    -- | Yesod can auto generate field names, so you are never sure what+    -- the argument name should be for each one of your inputs when constructing+    -- your requests. What you do know is the /label/ of the field.+    -- These functions let you add parameters to your request based+    -- on currently displayed label names.+    , byLabelExact+    , byLabelContain+    , byLabelPrefix+    , byLabelSuffix+    , fileByLabelExact+    , fileByLabelContain+    , fileByLabelPrefix+    , fileByLabelSuffix++    -- *** CSRF Tokens+    -- | In order to prevent CSRF exploits, yesod-form adds a hidden input+    -- to your forms with the name "_token". This token is a randomly generated,+    -- per-session value.+    --+    -- In order to prevent your forms from being rejected in tests, use one of+    -- these functions to add the token to your request.+    , addToken+    , addToken_+    , addTokenFromCookie+    , addTokenFromCookieNamedToHeaderNamed++    -- * Assertions+    , assertNotEq+    , assertEqualNoShow+    , assertEq++    , assertHeader+    , assertNoHeader+    , statusIs+    , bodyEquals+    , bodyContains+    , bodyNotContains+    , htmlAllContain+    , htmlAnyContain+    , htmlNoneContain+    , htmlCount+    , requireJSONResponse++    -- * Grab information+    , getTestYesod+    , getResponse+    , getRequestCookies++    -- * Debug output+    , printBody+    , printMatches++    -- * Utils for building your own assertions+    -- | Please consider generalizing and contributing the assertions you write.+    , htmlQuery+    , parseHTML+    , withResponse+    ) where++import Control.Monad.Catch (finally)+import Test.Hspec.Core.Spec+import Test.Hspec.Core.Hooks+import qualified Data.List as DL+import qualified Data.ByteString.Char8 as BS8+import Data.ByteString (ByteString)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TErr+import qualified Data.ByteString.Lazy.Char8 as BSL8+import qualified Test.HUnit as HUnit+import qualified Network.HTTP.Types as H+import qualified Network.Socket as Sock+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Network.Wai+import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)+import Control.Monad.IO.Class+import qualified Control.Monad.State.Class as MS+import Control.Monad.State.Class hiding (get)+import System.IO+import Yesod.Core.Unsafe (runFakeHandler)+import Yesod.Core+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)+import Text.XML.Cursor hiding (element)+import qualified Text.XML.Cursor as C+import qualified Text.HTML.DOM as HD+import qualified Data.Map as M+import qualified Web.Cookie as Cookie+import qualified Blaze.ByteString.Builder as Builder+import Data.Time.Clock (getCurrentTime)+import Control.Applicative ((<$>))+import Text.Show.Pretty (ppShow)+import Data.Monoid (mempty)+import Data.ByteArray.Encoding (convertToBase, Base(..))+import Network.HTTP.Types.Header (hContentType)+import Data.Aeson (eitherDecode')+import Control.Monad++import qualified Yesod.Test.TransversingCSS as YT.CSS+import Yesod.Test.TransversingCSS (HtmlLBS, Query)+import qualified Yesod.Test.Internal.SIO as YT.SIO+import Yesod.Test.Internal.SIO (SIO, execSIO, runSIO)+import qualified Yesod.Test.Internal as YT.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)++-- | The state used in a single test case defined using 'yit'+--+-- Since 1.2.4+data YesodExampleData site = YesodExampleData+    { yedCreateApplication :: !(site -> Middleware -> IO Application)+    , yedMiddleware :: !Middleware+    , yedSite :: !site+    , yedCookies :: !Cookies+    , yedResponse :: !(Maybe SResponse)+    , yedTestCleanup :: !(IO ())+    }++-- | A single test case, to be run with 'yit'.+--+-- Since 1.2.0+type YesodExample site = YT.SIO.SIO (YesodExampleData site)++unYesodExample :: YT.SIO.SIO (YesodExampleData site) a -> YT.SIO.SIO (YesodExampleData site) a+unYesodExample = id++-- | Mapping from cookie name to value.+--+-- Since 1.2.0+type Cookies = M.Map ByteString Cookie.SetCookie++-- | Corresponds to hspec\'s 'Spec'.+--+-- Since 1.2.0+type YesodSpec site = SpecWith (YesodExampleData site)++type YesodSpecWith site r = SpecWith (YesodExampleData site, r)++-- | Get the foundation value used for the current test.+--+-- Since 1.2.0+getTestYesod :: YesodExample site site+getTestYesod = fmap yedSite MS.get++-- | Get the most recently provided response value, if available.+--+-- Since 1.2.0+getResponse :: YesodExample site (Maybe SResponse)+getResponse = fmap yedResponse MS.get++data RequestBuilderData site = RequestBuilderData+    { rbdPostData :: RBDPostData+    , rbdResponse :: (Maybe SResponse)+    , rbdMethod :: H.Method+    , rbdSite :: site+    , rbdPath :: [T.Text]+    , rbdGets :: H.Query+    , rbdHeaders :: H.RequestHeaders+    }++data RBDPostData = MultipleItemsPostData [RequestPart]+                 | BinaryPostData BSL8.ByteString++-- | Request parts let us discern regular key/values from files sent in the request.+data RequestPart+  = ReqKvPart T.Text T.Text+  | ReqFilePart T.Text FilePath BSL8.ByteString T.Text++-- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments+-- to send with your requests. Some of the functions that run on it use the current+-- response to analyze the forms that the server is expecting to receive.+type RequestBuilder site = YT.SIO.SIO (RequestBuilderData site)++-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'+-- and 'ConnectionPool'+ydescribe :: String -> YesodSpec site -> YesodSpec site+ydescribe = describe++yesodSpec :: YesodDispatch site+          => site+          -> YesodSpec site+          -> Spec+yesodSpec site =+    before $ do+        pure YesodExampleData+            { yedCreateApplication = \finalSite middleware -> middleware <$> toWaiAppPlain finalSite+            , yedMiddleware = id+            , yedSite = site+            , yedCookies = M.empty+            , yedResponse = Nothing+            , yedTestCleanup = pure ()+            }++-- | Same as yesodSpec, but instead of taking already built site it+-- takes an action which produces site for each test.+yesodSpecWithSiteGenerator+    :: YesodDispatch site+    => IO site+    -> YesodSpec site+    -> Spec+yesodSpecWithSiteGenerator getSiteAction =+    yesodSpecWithSiteGeneratorAndArgument (const getSiteAction)++-- | Same as yesodSpecWithSiteGenerator, but also takes an argument to build the site+-- and makes that argument available to the tests.+--+-- @since 1.6.4+yesodSpecWithSiteGeneratorAndArgument+    :: YesodDispatch site+    => (a -> IO site)+    -> YesodSpec site+    -> SpecWith a+yesodSpecWithSiteGeneratorAndArgument getSiteAction =+    beforeWith $ \a -> do+        site <- getSiteAction a+        pure YesodExampleData+            { yedCreateApplication = \finalSite middleware -> middleware <$> toWaiAppPlain finalSite+            , yedMiddleware = id+            , yedSite = site+            , yedCookies = M.empty+            , yedResponse = Nothing+            , yedTestCleanup = pure ()+            }++ybefore_+    :: YesodExample site ()+    -> YesodSpec site+    -> YesodSpec site+ybefore_ action =+    beforeWith $+        execSIO (unYesodExample action)++-- | Add a cleanup hook to the yesod test. This will be run after the other+-- hooks already defined.+addYesodTestCleanupHook+    :: (YesodExampleData site -> IO ())+    -> YesodSpec site+    -> YesodSpec site+addYesodTestCleanupHook mkCleanupHook =+    beforeWith $ \yed -> do+        pure yed+            { yedTestCleanup = do+                yedTestCleanup yed+                mkCleanupHook yed+            }++ybefore+    :: YesodExample site a+    -> YesodSpecWith site a+    -> YesodSpec site+ybefore action =+    beforeWith $ \yed -> do+        runSIO (unYesodExample action) yed++ybeforeWith+    :: (a -> YesodExample site b)+    -> YesodSpecWith site b+    -> YesodSpecWith site a+ybeforeWith mkAction =+    beforeWith $ \(yed, a) ->+        runSIO (unYesodExample (mkAction a)) yed++-- | Describe a single test that keeps cookies, and a reference to the last response.+yit :: (HasCallStack) => String -> YesodExample site () -> YesodSpec site+yit = it++-- | Modifies the site ('yedSite') of the test, and creates a new WAI app ('yedApp') for it.+--+-- yesod-test allows sending requests to your application to test that it handles them correctly.+-- In rare cases, you may wish to modify that application in the middle of a test.+-- This may be useful if you wish to, for example, test your application under a certain configuration,+-- then change that configuration to see if your app responds differently.+--+-- ==== __Examples__+--+-- > post SendEmailR+-- > -- Assert email not created in database+-- > testModifySite (\site -> pure )+-- > post SendEmailR+-- > -- Assert email created in database+--+-- > testModifySite (\site -> do+-- >   middleware <- makeLogware site+-- >   pure (site { appRedisConnection = Nothing }, middleware)+-- > )+--+-- @since 1.6.8+testModifySite+    :: (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app.+    -> YesodExample site ()+testModifySite newSiteFn = do+  currentSite <- getTestYesod+  (newSite, middleware) <- liftIO $ newSiteFn currentSite+  modify $ \yed -> yed+    { yedSite = newSite+    , yedMiddleware = middleware+    }++-- | Sets a cookie+--+-- ==== __Examples__+--+-- > import qualified Web.Cookie as Cookie+-- > :set -XOverloadedStrings+-- > testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "name" }+--+-- @since 1.6.6+testSetCookie ::  Cookie.SetCookie -> YesodExample site ()+testSetCookie cookie = do+  let key = Cookie.setCookieName cookie+  modify $ \yed -> yed { yedCookies = M.insert key cookie (yedCookies yed) }++-- | Deletes the cookie of the given name+--+-- ==== __Examples__+--+-- > :set -XOverloadedStrings+-- > testDeleteCookie "name"+--+-- @since 1.6.6+testDeleteCookie :: ByteString -> YesodExample site ()+testDeleteCookie k = do+  modify $ \yed -> yed { yedCookies = M.delete k (yedCookies yed) }++-- | Modify the current cookies with the given mapping function+--+-- @since 1.6.6+testModifyCookies :: (Cookies -> Cookies) -> YesodExample site ()+testModifyCookies f = do+  modify $ \yed -> yed { yedCookies = f (yedCookies yed) }++-- | Clears the current cookies+--+-- @since 1.6.6+testClearCookies :: YesodExample site ()+testClearCookies = do+  modify $ \yed -> yed { yedCookies = M.empty }++-- Performs a given action using the last response. Use this to create+-- response-level assertions+withResponse'+    :: (HasCallStack)+    => (s -> Maybe SResponse)+    -> [T.Text]+    -> (SResponse -> SIO s a)+    -> SIO s a+withResponse' getter errTrace f = maybe err f . getter =<< MS.get+ where err = failure msg+       msg = if null errTrace+             then "There was no response, you should make a request."+             else+               "There was no response, you should make a request. A response was needed because: \n - "+               <> T.intercalate "\n - " errTrace++-- | Performs a given action using the last response. Use this to create+-- response-level assertions+withResponse :: (HasCallStack) => (SResponse -> SIO (YesodExampleData site) a) -> SIO (YesodExampleData site) a+withResponse = withResponse' yedResponse []++-- | Use HXT to parse a value from an HTML tag.+-- Check for usage examples in this module's source.+parseHTML :: HtmlLBS -> Cursor+parseHTML html = fromDocument $ HD.parseLBS html++-- | Query the last response using CSS selectors, returns a list of matched fragments+htmlQuery'+    :: (HasCallStack)+    => (site -> Maybe SResponse)+    -> [T.Text]+    -> Query+    -> SIO site [HtmlLBS]+htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res ->+  case YT.CSS.findBySelector (simpleBody res) query of+    Left err -> failure $ query <> " did not parse: " <> T.pack (show err)+    Right matches -> return $ map (encodeUtf8 . TL.pack) matches++-- | Query the last response using CSS selectors, returns a list of matched fragments+htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]+htmlQuery = htmlQuery' yedResponse []++-- | Asserts that the two given values are equal.+--+-- In case they are not equal, the error message includes the two values.+--+-- @since 1.5.2+assertEq :: (HasCallStack, Eq a, Show a, MonadIO m) => String -> a -> a -> m ()+assertEq m a b =+  liftIO $ HUnit.assertBool msg (a == b)+  where msg = "Assertion: " ++ m ++ "\n" +++              "First argument:  " ++ ppShow a ++ "\n" +++              "Second argument: " ++ ppShow b ++ "\n"++-- | Asserts that the two given values are not equal.+--+-- In case they are equal, the error message includes the values.+--+-- @since 1.5.6+assertNotEq :: (HasCallStack, Eq a, Show a, MonadIO m) => String -> a -> a -> m ()+assertNotEq m a b =+  liftIO $ HUnit.assertBool msg (a /= b)+  where msg = "Assertion: " ++ m ++ "\n" +++              "Both arguments:  " ++ ppShow a ++ "\n"++-- | Asserts that the two given values are equal.+--+-- @since 1.5.2+assertEqualNoShow :: (HasCallStack, Eq a, MonadIO m) => String -> a -> a -> m ()+assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b)++-- | Assert the last response status is as expected.+-- If the status code doesn't match, a portion of the body is also printed to aid in debugging.+--+-- ==== __Examples__+--+-- > get HomeR+-- > statusIs 200+statusIs :: HasCallStack => Int -> YesodExample site ()+statusIs number = do+  withResponse $ \(SResponse status headers body) -> do+    let mContentType = lookup hContentType headers+        isUTF8ContentType = maybe False YT.Internal.contentTypeHeaderIsUtf8 mContentType++    liftIO $ flip HUnit.assertBool (H.statusCode status == number) $ concat+      [ "Expected status was ", show number+      , " but received status was ", show $ H.statusCode status+      , if isUTF8ContentType+          then ". For debugging, the body was: " <> (T.unpack $ YT.Internal.getBodyTextPreview body)+          else ""+      ]++-- | Assert the given header key/value pair was returned.+--+-- ==== __Examples__+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > get HomeR+-- > assertHeader "key" "value"+--+-- > import qualified Data.CaseInsensitive as CI+-- > import qualified Data.ByteString.Char8 as BS8+-- > getHomeR+-- > assertHeader (CI.mk (BS8.pack "key")) (BS8.pack "value")+assertHeader :: (HasCallStack) => CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()+assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->+  case lookup header h of+    Nothing -> failure $ T.pack $ concat+        [ "Expected header "+        , show header+        , " to be "+        , show value+        , ", but it was not present"+        ]+    Just value' -> liftIO $ flip HUnit.assertBool (value == value') $ concat+        [ "Expected header "+        , show header+        , " to be "+        , show value+        , ", but received "+        , show value'+        ]++-- | Assert the given header was not included in the response.+--+-- ==== __Examples__+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > get HomeR+-- > assertNoHeader "key"+--+-- > import qualified Data.CaseInsensitive as CI+-- > import qualified Data.ByteString.Char8 as BS8+-- > getHomeR+-- > assertNoHeader (CI.mk (BS8.pack "key"))+assertNoHeader :: (HasCallStack) => CI BS8.ByteString -> YesodExample site ()+assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->+  case lookup header h of+    Nothing -> return ()+    Just s  -> failure $ T.pack $ concat+        [ "Unexpected header "+        , show header+        , " containing "+        , show s+        ]++-- | Assert the last response is exactly equal to the given text. This is+-- useful for testing API responses.+--+-- ==== __Examples__+--+-- > get HomeR+-- > bodyEquals "<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 $ \ res ->+  liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $+    (simpleBody res) `contains` text++-- | Assert the last response doesn't have the given text. The check is performed using the response+-- body in full text form.+--+-- ==== __Examples__+--+-- > get HomeR+-- > bodyNotContains "<h1>Foo</h1>+--+-- @since 1.5.3+bodyNotContains :: (HasCallStack) => String -> YesodExample site ()+bodyNotContains text = withResponse $ \ res ->+  liftIO $ HUnit.assertBool ("Expected body not to contain " ++ text) $+    not $ contains (simpleBody res) text++contains :: BSL8.ByteString -> String -> Bool+contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a)++-- | Queries the HTML using a CSS selector, and all matched elements must contain+-- the given string.+--+-- ==== __Examples__+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > get HomeR+-- > htmlAllContain "p" "Hello" -- Every <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) $+          DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)++-- | Queries the HTML using a CSS selector, and passes if any matched+-- element contains the given string.+--+-- ==== __Examples__+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > get HomeR+-- > htmlAnyContain "p" "Hello" -- At least one <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) $+          DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)++-- | Queries the HTML using a CSS selector, and fails if any matched+-- element contains the given string (in other words, it is the logical+-- inverse of htmlAnyContain).+--+-- ==== __Examples__+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > get HomeR+-- > htmlNoneContain ".my-class" "Hello" -- No tags with the class "my-class" contain the string "Hello"+--+-- Since 1.2.2+htmlNoneContain :: (HasCallStack) => Query -> String -> YesodExample site ()+htmlNoneContain query search = do+  matches <- htmlQuery query+  case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of+    [] -> return ()+    found -> failure $ "Found " <> T.pack (show $ length found) <>+                " instances of " <> T.pack search <> " in " <> query <> " elements"++-- | Performs a CSS query on the last response and asserts the matched elements+-- are as many as expected.+--+-- ==== __Examples__+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > get HomeR+-- > htmlCount "p" 3 -- There are exactly 3 <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: ", YT.Internal.getBodyTextPreview body]+        Right v -> return v++-- | Outputs the last response body to stderr (So it doesn't get captured by HSpec). Useful for debugging.+--+-- ==== __Examples__+--+-- > get HomeR+-- > printBody+printBody ::  YesodExample site ()+printBody = withResponse $ \ SResponse { simpleBody = b } ->+  liftIO $ BSL8.hPutStrLn stderr b++-- | Performs a CSS query and print the matches to stderr.+--+-- ==== __Examples__+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > get HomeR+-- > printMatches "h1" -- Prints all h1 tags+printMatches :: (HasCallStack) => Query -> YesodExample site ()+printMatches query = do+  matches <- htmlQuery query+  liftIO $ hPutStrLn stderr $ show matches++-- | Add a parameter with the given name and value to the request body.+-- This function can be called multiple times to add multiple parameters, and be mixed with calls to 'addFile'.+--+-- "Post parameter" is an informal description of what is submitted by making an HTTP POST with an HTML @\<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 :: T.Text -> T.Text -> RequestBuilder site ()+addPostParam name value =+  YT.SIO.modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }+  where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."+        addPostData (MultipleItemsPostData posts) =+          MultipleItemsPostData $ ReqKvPart name value : posts++-- | Add a parameter with the given name and value to the query string.+--+-- ==== __Examples__+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > request $ do+-- >   addGetParam "key" "value" -- Adds ?key=value to the URL+addGetParam :: T.Text -> T.Text -> RequestBuilder site ()+addGetParam name value = YT.SIO.modifySIO $ \rbd -> rbd+    { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)+              : rbdGets rbd+    }++-- | Add a file to be posted with the current request.+--+-- Adding a file will automatically change your request content-type to be multipart/form-data.+--+-- ==== __Examples__+--+-- > request $ do+-- >   addFile "profile_picture" "static/img/picture.png" "img/png"+addFile :: T.Text -- ^ The parameter name for the file.+        -> FilePath -- ^ The path to the file.+        -> T.Text -- ^ The MIME type of the file, e.g. "image/png".+        -> RequestBuilder site ()+addFile name path mimetype = do+  contents <- liftIO $ BSL8.readFile path+  YT.SIO.modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }+    where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content."+          addPostData (MultipleItemsPostData posts) contents =+            MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts++-- |+-- This looks up the name of a field based on the contents of the label pointing to it.+genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text+genericNameFromLabel match label = do+  mres <- fmap rbdResponse YT.SIO.getSIO+  res <-+    case mres of+      Nothing -> failure "genericNameFromLabel: No response available"+      Just res -> return res+  let+    body = simpleBody res+    mlabel = parseHTML body+                $// C.element "label"+                >=> isContentMatch label+    mfor = mlabel >>= attribute "for"++    isContentMatch x c+        | x `match` T.concat (c $// content) = [c]+        | otherwise = []++  case mfor of+    for:[] -> do+      let mname = parseHTML body+                    $// attributeIs "id" for+                    >=> attribute "name"+      case mname of+        "":_ -> failure $ T.concat+            [ "Label "+            , label+            , " resolved to id "+            , for+            , " which was not found. "+            ]+        name:_ -> return name+        [] -> failure $ "No input with id " <> for+    [] ->+      case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of+        [] -> failure $ "No label contained: " <> label+        name:_ -> return name+    _ -> failure $ "More than one label contained " <> label++byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)+                 -> T.Text                     -- ^ The text contained in the @\<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+-- >   byLabelExact "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 (==)++-- |+-- Contain version of 'byLabelExact'+--+-- Note: Just like 'byLabel', this function throws an error if it finds multiple labels+--+-- @since 1.6.2+byLabelContain :: 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 :: 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 :: T.Text -- ^ The text in the @\<label>@.+              -> T.Text -- ^ The value to set the parameter to.+              -> RequestBuilder site ()+byLabelSuffix = byLabelWithMatch T.isSuffixOf++fileByLabelWithMatch  :: (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+-- >   fileByLabelExact "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 = fileByLabelWithMatch (==)++-- |+-- Contain version of 'fileByLabelExact'+--+-- Note: Just like 'fileByLabel', this function throws an error if it finds multiple labels+--+-- @since 1.6.2+fileByLabelContain :: 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 :: 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 :: 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+    [] -> 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 :: 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 <- YT.SIO.getSIO+  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 = 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, 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 = YT.SIO.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 :: (Yesod site, RedirectUrl site url)+       => url+       -> RequestBuilder site ()+setUrl url' = do+    site <- fmap rbdSite YT.SIO.getSIO+    eurl <- Yesod.Core.Unsafe.runFakeHandler+        M.empty+        (const $ error "Test.Hspec.Yesod: No logger available")+        site+        (toTextUrl url')+    url <- either (error . show) return eurl+    let (urlPath, urlQuery) = T.break (== '?') url+    YT.SIO.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 YT.CSS.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 = YT.SIO.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 = YT.SIO.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)++yesodExampleDataToApplication :: YesodExampleData site -> IO Application+yesodExampleDataToApplication YesodExampleData {..} =+    yedCreateApplication yedSite yedMiddleware++mkApplication :: YesodExample site Application+mkApplication = do+    liftIO . yesodExampleDataToApplication =<< MS.get++-- | 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+    app <- mkApplication+    site <- MS.gets yedSite+    mRes <- MS.gets yedResponse+    oldCookies <- MS.gets yedCookies++    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+    modify $ \e -> e { yedCookies = cookies', yedResponse = 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 $ H.renderSimpleQuery False+          $ concatMap 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) = [(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 []) = []+        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 :: (HasCallStack, MonadIO a) => T.Text -> a b+failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""++data TestApp site = TestApp+    { testAppSite :: site+    , testAppMiddleware :: Middleware+    }++mkTestApp :: site -> TestApp site+mkTestApp site = TestApp+    { testAppSite = site+    , testAppMiddleware = id+    }++type YSpec site = SpecWith (YesodExampleData site)++-- | This creates a minimal 'YesodExampleData' for a given @site@. No+-- middlewares are applied.+siteToYesodExampleData+    :: (YesodDispatch site)+    => site+    -> YesodExampleData site+siteToYesodExampleData site =+    YesodExampleData+        { yedCreateApplication = \site' middleware -> middleware <$> toWaiAppPlain site'+        , yedMiddleware = id+        , yedSite = site+        , yedCookies = M.empty+        , yedResponse = Nothing+        , yedTestCleanup = pure ()+        }++instance Example (SIO (YesodExampleData site) a) where+    type Arg (SIO (YesodExampleData site) a) = YesodExampleData site++    evaluateExample example params action =+        evaluateExample+            (action $ \yed -> do+                void $ YT.SIO.evalSIO example yed+                    `finally` do+                        yedTestCleanup yed+            )+            params+            ($ ())

@@ -0,0 +1,662 @@+-- Ignore warnings about using deprecated byLabel/fileByLabel functions+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main+    ( main+    -- avoid warnings+    , resourcesRoutedApp+    , Widget+    ) where++import Test.HUnit hiding (Test)+import Test.Hspec+import qualified Test.Hspec as Hspec++import Yesod.Core+import Yesod.Form+import Test.Hspec.Yesod+import Yesod.Test.CssQuery+import Yesod.Test.TransversingCSS+import Text.XML+import Data.Text (Text, pack)+import Data.Monoid ((<>))+import Control.Applicative+import Network.Wai (pathInfo, requestHeaders)+import Network.Wai.Test (SResponse(simpleBody))+import Data.Maybe (fromMaybe)+import Data.Either (isLeft, isRight)++import Data.ByteString.Lazy.Char8 ()+import qualified Data.Map as Map+import qualified Text.HTML.DOM as HD+import Network.HTTP.Types.Status (status200, status301, status303, status403, status422, unsupportedMediaType415)+import UnliftIO.Exception (tryAny, SomeException, try, Exception)+import Control.Monad.IO.Unlift (toIO)+import qualified Web.Cookie as Cookie+import Data.Maybe (isNothing)+import qualified Data.Text as T+import Yesod.Test.Internal (contentTypeHeaderIsUtf8)++parseQuery_ :: Text -> [[SelectorGroup]]+parseQuery_ = either error id . parseQuery++findBySelector_ :: HtmlLBS -> Query -> [String]+findBySelector_ x = either error id . findBySelector x++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+|]++main :: IO ()+main = hspec $ do+    describe "CSS selector parsing" $ do+        it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]]+        it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]]+        it "comma" $ parseQuery_ "strong.bar, #foo" @?= [[DeepChildren [ByTagName "strong", ByClass "bar"]], [DeepChildren [ById "foo"]]]+    describe "find by selector" $ do+        it "XHTML" $+            let html = "<html><head><title>foo</title></head><body><p>Hello World</p></body></html>"+                query = "body > p"+             in findBySelector_ html query @?= ["<p>Hello World</p>"]+        it "HTML" $+            let html = "<html><head><title>foo</title></head><body><br><p>Hello World</p></body></html>"+                query = "body > p"+             in findBySelector_ html query @?= ["<p>Hello World</p>"]+        let query = "form.foo input[name=_token][type=hidden][value]"+            html = "<input name='_token' type='hidden' value='foo'><form class='foo'><input name='_token' type='hidden' value='bar'></form>"+            expected = "<input name=\"_token\" type=\"hidden\" value=\"bar\" />"+         in it query $ findBySelector_ html (pack query) @?= [expected]+        it "descendents and children" $+            let html = "<html><p><b><i><u>hello</u></i></b></p></html>"+                query = "p > b u"+             in findBySelector_ html query @?= ["<u>hello</u>"]+        it "hyphenated classes" $+            let html = "<html><p class='foo-bar'><b><i><u>hello</u></i></b></p></html>"+                query = "p.foo-bar u"+             in findBySelector_ html query @?= ["<u>hello</u>"]+        it "descendents" $+            let html = "<html><p><b><i>hello</i></b></p></html>"+                query = "p i"+             in findBySelector_ html query @?= ["<i>hello</i>"]+    describe "HTML parsing" $ do+        it "XHTML" $+            let html = "<html><head><title>foo</title></head><body><p>Hello World</p></body></html>"+                doc = Document (Prologue [] Nothing []) root []+                root = Element "html" Map.empty+                    [ NodeElement $ Element "head" Map.empty+                        [ NodeElement $ Element "title" Map.empty+                            [NodeContent "foo"]+                        ]+                    , NodeElement $ Element "body" Map.empty+                        [ NodeElement $ Element "p" Map.empty+                            [NodeContent "Hello World"]+                        ]+                    ]+             in HD.parseLBS html @?= doc+        it "HTML" $+            let html = "<html><head><title>foo</title></head><body><br><p>Hello World</p></body></html>"+                doc = Document (Prologue [] Nothing []) root []+                root = Element "html" Map.empty+                    [ NodeElement $ Element "head" Map.empty+                        [ NodeElement $ Element "title" Map.empty+                            [NodeContent "foo"]+                        ]+                    , NodeElement $ Element "body" Map.empty+                        [ NodeElement $ Element "br" Map.empty []+                        , NodeElement $ Element "p" Map.empty+                            [NodeContent "Hello World"]+                        ]+                    ]+             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+                get ("/" :: Text)+                statusIs 200+                bodyEquals "Hello world!"+            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 []+                statusIs 200+            yit "type-safe URLs with query-string" $ do+                get (LiteAppRoute [], [("foo", "bar")])+                statusIs 200+                bodyEquals "foo=bar"+            yit "post params" $ do+                post ("/post" :: Text)+                statusIs 500++                request $ do+                    setMethod "POST"+                    setUrl $ LiteAppRoute ["post"]+                    -- If value uses special characters,+                    addPostParam "foo" "foo+bar%41<&baz"+                statusIs 200+                -- They pass through the server correctly.+                bodyEquals "foo+bar%41<&baz"+            yit "labels" $ do+                get ("/form" :: Text)+                statusIs 200++                request $ do+                    setMethod "POST"+                    setUrl ("/form" :: Text)+                    byLabelExact "Some Label" "foo+bar%41<&baz"+                    fileByLabelExact "Some File" "test/main.hs" "text/plain"+                    addToken+                statusIs 200+                -- The '<' and '&' get encoded to HTML entities because+                -- "/form" (unlike "/post") uses toHtml.+                bodyEquals "foo+bar%41&lt;&amp;baz"+            yit "labels WForm" $ do+                get ("/wform" :: Text)+                statusIs 200++                request $ do+                    setMethod "POST"+                    setUrl ("/wform" :: Text)+                    byLabelExact "Some WLabel" "12345"+                    fileByLabelExact "Some WFile" "test/main.hs" "text/plain"+                    addToken+                statusIs 200+                bodyEquals "12345"+            yit "finding html" $ do+                get ("/html" :: Text)+                statusIs 200+                htmlCount "p" 2+                htmlAllContain "p" "Hello"+                htmlAnyContain "p" "World"+                htmlAnyContain "p" "Moon"+                htmlNoneContain "p" "Sun"+            yit "finds the CSRF token by css selector" $ do+                get ("/form" :: Text)+                statusIs 200++                request $ do+                    setMethod "POST"+                    setUrl ("/form" :: Text)+                    byLabelExact "Some Label" "12345"+                    fileByLabelExact "Some File" "test/main.hs" "text/plain"+                    addToken_ "body"+                statusIs 200+                bodyEquals "12345"+            yit "can follow a link via clickOn" $ do+              get ("/htmlWithLink" :: Text)+              clickOn "a#thelink"+              statusIs 200+              bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>"++              get ("/htmlWithLink" :: Text)+              bad <- tryAny (clickOn "a#nonexistentlink")+              assertEq "bad link" (isLeft bad) True++        ydescribe "custom error message" $ do+            yit "returns the message pass to areqMsg" $ do+                get ("/form" :: Text)+                statusIs 200++                request $ do+                    setMethod "POST"+                    setUrl ("/form" :: Text)+                    addToken+                statusIs 200+                htmlAnyContain ".errors" "Missing Label"+            yit "returns the message pass to mreqMsg" $ do+                get ("/mform" :: Text)+                statusIs 200++                request $ do+                    setMethod "POST"+                    setUrl ("/mform" :: Text)+                    addToken+                statusIs 200+                htmlAnyContain ".errors" "Missing MLabel"+            yit "returns the message pass to wreqMsg" $ do+                get ("/wform" :: Text)+                statusIs 200++                request $ do+                    setMethod "POST"+                    setUrl ("/wform" :: Text)+                    addToken+                statusIs 200+                htmlAnyContain ".errors" "Missing WLabel"++        ydescribe "utf8 paths" $ do+            yit "from path" $ do+                get ("/dynamic1/שלום" :: Text)+                statusIs 200+                bodyEquals "שלום"+            yit "from path, type-safe URL" $ do+                get $ LiteAppRoute ["dynamic1", "שלום"]+                statusIs 200+                printBody+                bodyEquals "שלום"+            yit "from WAI" $ do+                get ("/dynamic2/שלום" :: Text)+                statusIs 200+                bodyEquals "שלום"++        ydescribe "labels" $ do+            yit "can click checkbox" $ do+                get ("/labels" :: Text)+                request $ do+                    setMethod "POST"+                    setUrl ("/labels" :: Text)+                    byLabelExact "Foo Bar" "yes"+        ydescribe "byLabel-related tests" $ do+            yit "byLabelExact performs an exact match over the given label name" $ do+                get ("/labels2" :: Text)+                (bad :: Either SomeException ()) <- try (request $ do+                    setMethod "POST"+                    setUrl ("labels2" :: Text)+                    byLabelExact "hobby" "fishing")+                assertEq "failure was called" (isRight bad) True+            yit "byLabelContain looks for the labels which contain the given label name" $ do+                get ("/label-contain" :: Text)+                request $ do+                    setMethod "POST"+                    setUrl ("check-hobby" :: Text)+                    byLabelContain "hobby" "fishing"+                res <- maybe "Couldn't get response" simpleBody <$> getResponse+                assertEq "hobby isn't set" res "fishing"+            yit "byLabelContain throws an error if it finds multiple labels" $ do+                (bad :: Either SomeException ()) <- try (request $ do+                    setMethod "POST"+                    setUrl ("label-contain-error" :: Text)+                    byLabelContain "hobby" "fishing")+                assertEq "failure wasn't called" (isLeft bad) True+            yit "byLabelPrefix matches over the prefix of the labels" $ do+                get ("/label-prefix" :: Text)+                request $ do+                    setMethod "POST"+                    setUrl ("check-hobby" :: Text)+                    byLabelPrefix "hobby" "fishing"+                res <- maybe "Couldn't get response" simpleBody <$> getResponse+                assertEq "hobby isn't set" res "fishing"+            yit "byLabelPrefix throws an error if it finds multiple labels" $ do+                (bad :: Either SomeException ()) <- try (request $ do+                    setMethod "POST"+                    setUrl ("label-prefix-error" :: Text)+                    byLabelPrefix "hobby" "fishing")+                assertEq "failure wasn't called" (isLeft bad) True+            yit "byLabelSuffix matches over the suffix of the labels" $ do+                get ("/label-suffix" :: Text)+                request $ do+                    setMethod "POST"+                    setUrl ("check-hobby" :: Text)+                    byLabelSuffix "hobby" "fishing"+                res <- maybe "Couldn't get response" simpleBody <$> getResponse+                assertEq "hobby isn't set" res "fishing"+            yit "byLabelSuffix throws an error if it finds multiple labels" $ do+                (bad :: Either SomeException ()) <- try (request $ do+                    setMethod "POST"+                    setUrl ("label-suffix-error" :: Text)+                    byLabelSuffix "hobby" "fishing")+                assertEq "failure wasn't called" (isLeft bad) True+        ydescribe "Content-Type handling" $ do+            yit "can set a content-type" $ do+                request $ do+                    setUrl ("/checkContentType" :: Text)+                    addRequestHeader ("Expected-Content-Type","text/plain")+                    addRequestHeader ("Content-Type","text/plain")+                statusIs 200+            yit "adds the form-urlencoded Content-Type if you add parameters" $ do+                request $ do+                    setUrl ("/checkContentType" :: Text)+                    addRequestHeader ("Expected-Content-Type","application/x-www-form-urlencoded")+                    addPostParam "foo" "foobarbaz"+                statusIs 200+            yit "defaults to no Content-Type" $ do+                get ("/checkContentType" :: Text)+                statusIs 200+            yit "returns a 415 for the wrong Content-Type" $ do+                -- Tests that the test handler is functioning+                request $ do+                    setUrl ("/checkContentType" :: Text)+                    addRequestHeader ("Expected-Content-Type","application/x-www-form-urlencoded")+                    addRequestHeader ("Content-Type","text/plain")+                statusIs 415++    describe "hooks" $ yesodSpec app $ do+        ybefore_ (get ("/" :: Text)) $ do+            yit "works" $ do+                statusIs 200+            ybefore_ (post ("/cookie/foo" :: Text)) $ do+                yit "works again" $ do+                    statusIs 404++    describe "cookies" $ yesodSpec cookieApp $ do+        yit "should send the cookie #730" $ do+            get ("/" :: Text)+            statusIs 200+            post ("/cookie/foo" :: Text)+            statusIs 303+            get ("/" :: Text)+            statusIs 200+            printBody+            bodyContains "Foo"+        yit "should 422 on the cookie named key" $ do+            get ("cookie/check-no-cookie" :: Text)+            statusIs 200+            testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" }+            get ("cookie/check-no-cookie" :: Text)+            statusIs 422+        yit "should be able to delete a cookie" $ do+            testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" }+            get ("cookie/check-no-cookie" :: Text)+            statusIs 422+            testDeleteCookie "key"+            get ("cookie/check-no-cookie" :: Text)+            statusIs 200+        yit "should be able to clear all cookies" $ do+            testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" }+            get ("cookie/check-no-cookie" :: Text)+            statusIs 422+            testClearCookies+            get ("cookie/check-no-cookie" :: Text)+            statusIs 200+        yit "should be able to modify cookies" $ do+            testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" }+            get ("cookie/check-no-cookie" :: Text)+            statusIs 422+            testModifyCookies (\_ -> Map.empty)+            get ("cookie/check-no-cookie" :: Text)+            statusIs 200+    describe "CSRF with cookies/headers" $ yesodSpec defaultRoutedApp $ do+        yit "Should receive a CSRF cookie and add its value to the headers" $ do+            get ("/" :: Text)+            statusIs 200++            request $ do+                setMethod "POST"+                setUrl ("/" :: Text)+                addTokenFromCookie+            statusIs 200+        yit "Should 403 requests if we don't add the CSRF token" $ do+            get ("/" :: Text)+            statusIs 200++            request $ do+                setMethod "POST"+                setUrl ("/" :: Text)+            statusIs 403+    describe "test redirects" $ yesodSpec app $ do+        yit "follows 303 redirects when requested" $ do+            get ("/redirect303" :: Text)+            statusIs 303+            r <- followRedirect+            liftIO $ assertBool "expected a Right from a 303 redirect" $ isRight r+            statusIs 200+            bodyContains "we have been successfully redirected"++        yit "follows 301 redirects when requested" $ do+            get ("/redirect301" :: Text)+            statusIs 301+            r <- followRedirect+            liftIO $ assertBool "expected a Right from a 301 redirect" $ isRight r+            statusIs 200+            bodyContains "we have been successfully redirected"+++        yit "returns a Left when no redirect was returned" $ do+            get ("/" :: Text)+            statusIs 200+            r <- followRedirect+            liftIO $ assertBool "expected a Left when not a redirect" $ isLeft r++    describe "route parsing in tests" $ yesodSpec defaultRoutedApp $ do+        yit "parses location header into a route" $ do+            -- get CSRF token+            get HomeR+            statusIs 200++            request $ do+                setMethod "POST"+                setUrl $ ResourcesR+                addPostParam "foo" "bar"+                addTokenFromCookie+            statusIs 201++            loc <- getLocation+            liftIO $ assertBool "expected location to be available" $ isRight loc+            let (Right (ResourceR t)) = loc+            liftIO $ assertBool "expected location header to contain post param" $ t == "bar"++        yit "returns a Left when no redirect was returned" $ do+            get HomeR+            statusIs 200+            loc <- getLocation+            liftIO $ assertBool "expected a Left when not a redirect" $ isLeft loc++    describe "modifying site value" $ yesodSpec defaultRoutedApp $ do+        yit "can change site value" $ do+            get ("/get-integer" :: Text)+            bodyContains "0"+            testModifySite (\site -> pure (site { routedAppInteger = 1 }, id))+            get ("/get-integer" :: Text)+            bodyContains "1"++    describe "Basic Authentication" $ yesodSpec app $ do+        yit "rejects no header" $ do+            get ("checkBasicAuth" :: Text)+            statusIs 403+        yit "rejects incorrect header" $ do+            request $ do+                setUrl ("checkBasicAuth" :: Text)+                addBasicAuthHeader "Aladdin" "foo"+            statusIs 403+        yit "accepts correct header" $ do+            request $ do+                setUrl ("checkBasicAuth" :: Text)+                addBasicAuthHeader "Aladdin" "OpenSesame"+            statusIs 200+    describe "JSON parsing" $ yesodSpec app $ do+        yit "checks for a json array" $ do+            get ("get-json-response" :: Text)+            statusIs 200+            xs <- requireJSONResponse+            assertEq "The value is [1]" xs [1 :: Integer]+        yit "checks for valid content-type" $ do+            get ("get-json-wrong-content-type" :: Text)+            statusIs 200+            (requireJSONResponse :: YesodExample site [Integer]) `liftedShouldThrow` (\(e :: SomeException) -> True)+        yit "checks for valid JSON parse" $ do+            get ("get-json-response" :: Text)+            statusIs 200+            (requireJSONResponse :: YesodExample site [Text]) `liftedShouldThrow` (\(e :: SomeException) -> True)++instance RenderMessage LiteApp FormMessage where+    renderMessage _ _ = defaultFormMessage++app :: LiteApp+app = liteApp $ do+    dispatchTo $ do+        mfoo <- lookupGetParam "foo"+        case mfoo of+            Nothing -> return "Hello world!"+            Just foo -> return $ "foo=" <> foo+    onStatic "dynamic1" $ withDynamic $ \d -> dispatchTo $ return (d :: Text)+    onStatic "dynamic2" $ onStatic "שלום" $ dispatchTo $ do+        req <- waiRequest+        return $ pathInfo req !! 1+    onStatic "post" $ dispatchTo $ do+        mfoo <- lookupPostParam "foo"+        case mfoo of+            Nothing -> error "No foo"+            Just foo -> return foo+    onStatic "redirect301" $ dispatchTo $ redirectWith status301 ("/redirectTarget" :: Text) >> return ()+    onStatic "redirect303" $ dispatchTo $ redirectWith status303 ("/redirectTarget" :: Text) >> return ()+    onStatic "redirectTarget" $ dispatchTo $ return ("we have been successfully redirected" :: Text)+    onStatic "form" $ dispatchTo $ do+        ((mfoo, widget), _) <- runFormPost+                        $ renderDivs+                        $ (,)+                      Control.Applicative.<$> 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+            ( (,) Control.Applicative.<$> field1F <*> field2F+            , [field1V, field2V]+            )+        case mfoo of+            FormSuccess (foo, _) -> return $ toHtml foo+            _                    -> defaultLayout widget+    onStatic "wform" $ dispatchTo $ do+        ((mfoo, widget), _) <- runFormPost $ renderDivs $ wFormToAForm $ do+          field1F <- wreqMsg textField "Some WLabel" ("Missing WLabel" :: SomeMessage LiteApp) Nothing+          field2F <- wreq fileField "Some WFile" Nothing++          return $ (,) Control.Applicative.<$> 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)++    onStatic "htmlWithLink" $ dispatchTo $+        return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text)+    onStatic "labels" $ dispatchTo $+        return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)+    onStatic "labels2" $ dispatchTo $+        return ("<html><label for='hobby'>hobby</label><label for='hobby2'>hobby2</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)+    onStatic "label-contain" $ dispatchTo $+        return ("<html><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)+    onStatic "label-contain-error" $ dispatchTo $+        return ("<html><label for='hobby'>XXXhobbyXXX</label><label for='hobby2'>XXXhobby2XXX</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)+    onStatic "label-prefix" $ dispatchTo $+        return ("<html><label for='hobby'>hobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)+    onStatic "label-prefix-error" $ dispatchTo $+        return ("<html><label for='hobby'>hobbyXXX</label><label for='hobby2'>hobby2XXX</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)+    onStatic "label-suffix" $ dispatchTo $+        return ("<html><label for='hobby'>XXXhobby</label><input type='text' name='hobby' id='hobby'></html>" :: Text)+    onStatic "label-suffix-error" $ dispatchTo $+        return ("<html><label for='hobby'>XXXhobby</label><label for='hobby2'>XXXneo-hobby</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)+    onStatic "check-hobby" $ dispatchTo $ do+        hobby <- lookupPostParam "hobby"+        return $ fromMaybe "No hobby" hobby++    onStatic "checkContentType" $ dispatchTo $ do+        headers <- requestHeaders <$> waiRequest++        let actual   = lookup "Content-Type" headers+            expected = lookup "Expected-Content-Type" headers++        if actual == expected+            then return ()+            else sendResponseStatus unsupportedMediaType415 ()+    onStatic "checkBasicAuth" $ dispatchTo $ do+        headers <- requestHeaders <$> waiRequest+        let authHeader = lookup "Authorization" headers++        -- Copied from the Wikipedia Aladdin:OpenSesame example+        if authHeader == Just "Basic QWxhZGRpbjpPcGVuU2VzYW1l"+            then return ()+            else sendResponseStatus status403 ()+    onStatic "get-json-response" $ dispatchTo $ do+        (sendStatusJSON status200 ([1] :: [Integer])) :: LiteHandler Value+    onStatic "get-json-wrong-content-type" $ dispatchTo $ do+        return ("[1]" :: Text)++cookieApp :: LiteApp+cookieApp = liteApp $ do+    dispatchTo $ fromMaybe "no message available" <$> getMessage+    onStatic "cookie" $ do+        onStatic "foo" $ dispatchTo $ do+            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++getHomeR :: Handler Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]++postHomeR :: Handler Html+postHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]++postResourcesR :: Handler ()+postResourcesR = do+    t <- runRequestBody >>= \case+        ([("foo", t)], _) -> return t+        _ -> liftIO $ fail "postResourcesR pattern match failure"+    sendResponseCreated $ ResourceR t++getResourceR :: Text -> Handler Html+getResourceR i = defaultLayout+    [whamlet|+        <p>+            Read item #{i}.+    |]++getIntegerR :: Handler Text+getIntegerR = do+    app <- getYesod+    pure $ T.pack $ show (routedAppInteger app)+++-- 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