1668 lines
60 KiB
Haskell
1668 lines
60 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE CPP #-}
|
||
{-# LANGUAGE FlexibleContexts #-}
|
||
{-# LANGUAGE RecordWildCards #-}
|
||
{-# LANGUAGE FlexibleInstances #-}
|
||
{-# LANGUAGE TypeFamilies #-}
|
||
{-# LANGUAGE ImplicitParams #-}
|
||
{-# LANGUAGE ConstraintKinds #-}
|
||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||
|
||
{-|
|
||
Yesod.Test is a pragmatic framework for testing web applications built
|
||
using wai.
|
||
|
||
By pragmatic I may also mean 'dirty'. Its main goal is to encourage integration
|
||
and system testing of web applications by making everything /easy to test/.
|
||
|
||
Your tests are like browser sessions that keep track of cookies and the last
|
||
visited page. You can perform assertions on the content of HTML responses,
|
||
using CSS selectors to explore the document more easily.
|
||
|
||
You can also easily build requests using forms present in the current page.
|
||
This is very useful for testing web applications built in yesod, for example,
|
||
where your forms may have field names generated by the framework or a randomly
|
||
generated CSRF token input.
|
||
|
||
=== Example project
|
||
|
||
The best way to see an example project using yesod-test is to create a scaffolded Yesod project:
|
||
|
||
@stack new projectname yesod-sqlite@
|
||
|
||
(See https://github.com/commercialhaskell/stack-templates/wiki#yesod for the full list of Yesod templates)
|
||
|
||
The scaffolded project makes your database directly available in tests, so you can use 'runDB' to set up
|
||
backend pre-conditions, or to assert that your session is having the desired effect.
|
||
It also handles wiping your database between each test.
|
||
|
||
=== Example code
|
||
|
||
The code below should give you a high-level idea of yesod-test's capabilities.
|
||
Note that it uses helper functions like @withApp@ and @runDB@ from the scaffolded project; these aren't provided by yesod-test.
|
||
|
||
@
|
||
spec :: Spec
|
||
spec = withApp $ do
|
||
describe \"Homepage\" $ do
|
||
it "loads the homepage with a valid status code" $ do
|
||
'get' HomeR
|
||
'statusIs' 200
|
||
describe \"Login Form\" $ do
|
||
it "Only allows dashboard access after logging in" $ do
|
||
'get' DashboardR
|
||
'statusIs' 401
|
||
|
||
'get' HomeR
|
||
-- Assert a \<p\> tag exists on the page
|
||
'htmlAnyContain' \"p\" \"Login\"
|
||
|
||
-- yesod-test provides a 'RequestBuilder' monad for building up HTTP requests
|
||
'request' $ do
|
||
-- Lookup the HTML \<label\> with the text Username, and set a POST parameter for that field with the value Felipe
|
||
'byLabelExact' \"Username\" \"Felipe\"
|
||
'byLabelExact' \"Password\" "pass\"
|
||
'setMethod' \"POST\"
|
||
'setUrl' SignupR
|
||
'statusIs' 200
|
||
|
||
-- The previous request will have stored a session cookie, so we can access the dashboard now
|
||
'get' DashboardR
|
||
'statusIs' 200
|
||
|
||
-- Assert a user with the name Felipe was added to the database
|
||
[Entity userId user] <- runDB $ selectList [] []
|
||
'assertEq' "A single user named Felipe is created" (userUsername user) \"Felipe\"
|
||
describe \"JSON\" $ do
|
||
it "Can make requests using JSON, and parse JSON responses" $ do
|
||
-- Precondition: Create a user with the name \"George\"
|
||
runDB $ insert_ $ User \"George\" "pass"
|
||
|
||
'request' $ do
|
||
-- Use the Aeson library to send JSON to the server
|
||
'setRequestBody' ('Data.Aeson.encode' $ LoginRequest \"George\" "pass")
|
||
'addRequestHeader' (\"Accept\", "application/json")
|
||
'addRequestHeader' ("Content-Type", "application/json")
|
||
'setUrl' LoginR
|
||
'statusIs' 200
|
||
|
||
-- Parse the request's response as JSON
|
||
(signupResponse :: SignupResponse) <- 'requireJSONResponse'
|
||
@
|
||
|
||
=== HUnit / HSpec integration
|
||
|
||
yesod-test is built on top of hspec, which is itself built on top of HUnit.
|
||
You can use existing assertion functions from those libraries, but you'll need to use `liftIO` with them:
|
||
|
||
@
|
||
liftIO $ actualTimesCalled `'Test.Hspec.Expectations.shouldBe'` expectedTimesCalled -- hspec assertion
|
||
@
|
||
|
||
@
|
||
liftIO $ 'Test.HUnit.Base.assertBool' "a is greater than b" (a > b) -- HUnit assertion
|
||
@
|
||
|
||
yesod-test provides a handful of assertion functions that are already lifted, such as 'assertEq', as well.
|
||
|
||
-}
|
||
|
||
module Yesod.Test
|
||
( -- * Declaring and running your test suite
|
||
yesodSpec
|
||
, YesodSpec
|
||
, yesodSpecWithSiteGenerator
|
||
, yesodSpecWithSiteGeneratorAndArgument
|
||
, yesodSpecApp
|
||
, YesodExample
|
||
, YesodExampleData(..)
|
||
, TestApp
|
||
, YSpec
|
||
, testApp
|
||
, YesodSpecTree (..)
|
||
, ydescribe
|
||
, yit
|
||
|
||
-- * Modify test site
|
||
, testModifySite
|
||
|
||
-- * Modify test state
|
||
, testSetCookie
|
||
, testDeleteCookie
|
||
, testModifyCookies
|
||
, testClearCookies
|
||
|
||
-- * Making requests
|
||
-- | You can construct requests with the 'RequestBuilder' monad, which lets you
|
||
-- set the URL and add parameters, headers, and files. Helper functions are provided to
|
||
-- lookup fields by label and to add the current CSRF token from your forms.
|
||
-- Once built, the request can be executed with the 'request' method.
|
||
--
|
||
-- Convenience functions like 'get' and 'post' build and execute common requests.
|
||
, get
|
||
, post
|
||
, postBody
|
||
, performMethod
|
||
, followRedirect
|
||
, getLocation
|
||
, request
|
||
, addRequestHeader
|
||
, addBasicAuthHeader
|
||
, setMethod
|
||
, addPostParam
|
||
, addGetParam
|
||
, addBareGetParam
|
||
, addFile
|
||
, setRequestBody
|
||
, RequestBuilder
|
||
, SIO
|
||
, setUrl
|
||
, clickOn
|
||
|
||
-- *** Adding fields by label
|
||
-- | Yesod can auto generate field names, so you are never sure what
|
||
-- the argument name should be for each one of your inputs when constructing
|
||
-- your requests. What you do know is the /label/ of the field.
|
||
-- These functions let you add parameters to your request based
|
||
-- on currently displayed label names.
|
||
, byLabel
|
||
, byLabelExact
|
||
, byLabelContain
|
||
, byLabelPrefix
|
||
, byLabelSuffix
|
||
, bySelectorLabelContain
|
||
, fileByLabel
|
||
, fileByLabelExact
|
||
, fileByLabelContain
|
||
, fileByLabelPrefix
|
||
, fileByLabelSuffix
|
||
|
||
-- *** CSRF Tokens
|
||
-- | In order to prevent CSRF exploits, yesod-form adds a hidden input
|
||
-- to your forms with the name "_token". This token is a randomly generated,
|
||
-- per-session value.
|
||
--
|
||
-- In order to prevent your forms from being rejected in tests, use one of
|
||
-- these functions to add the token to your request.
|
||
, addToken
|
||
, addToken_
|
||
, addTokenFromCookie
|
||
, addTokenFromCookieNamedToHeaderNamed
|
||
|
||
-- * Assertions
|
||
, assertEqual
|
||
, assertNotEq
|
||
, assertEqualNoShow
|
||
, assertEq
|
||
|
||
, assertHeader
|
||
, assertNoHeader
|
||
, statusIs
|
||
, bodyEquals
|
||
, bodyContains
|
||
, bodyNotContains
|
||
, htmlAllContain
|
||
, htmlAnyContain
|
||
, htmlNoneContain
|
||
, htmlCount
|
||
, requireJSONResponse
|
||
|
||
-- * Grab information
|
||
, getTestYesod
|
||
, getResponse
|
||
, getRequestCookies
|
||
|
||
-- * Debug output
|
||
, printBody
|
||
, printMatches
|
||
|
||
-- * Utils for building your own assertions
|
||
-- | Please consider generalizing and contributing the assertions you write.
|
||
, htmlQuery
|
||
, parseHTML
|
||
, withResponse
|
||
) where
|
||
|
||
import qualified Test.Hspec.Core.Spec as Hspec
|
||
import qualified Data.List as DL
|
||
import qualified Data.ByteString.Char8 as BS8
|
||
import Data.ByteString (ByteString)
|
||
import qualified Data.Text as T
|
||
import qualified Data.Text.Encoding as TE
|
||
import qualified Data.Text.Encoding.Error as TErr
|
||
import qualified Data.ByteString.Lazy.Char8 as BSL8
|
||
import qualified Test.HUnit as HUnit
|
||
import qualified Network.HTTP.Types as H
|
||
|
||
#if MIN_VERSION_network(3, 0, 0)
|
||
import qualified Network.Socket as Sock
|
||
#else
|
||
import qualified Network.Socket.Internal as Sock
|
||
#endif
|
||
|
||
import Data.CaseInsensitive (CI)
|
||
import qualified Data.CaseInsensitive as CI
|
||
import qualified Text.Blaze.Renderer.String as Blaze
|
||
import qualified Text.Blaze as Blaze
|
||
import Network.Wai
|
||
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
|
||
import Control.Monad.IO.Class
|
||
import System.IO
|
||
import Yesod.Core.Unsafe (runFakeHandler)
|
||
import Yesod.Test.TransversingCSS
|
||
import Yesod.Core
|
||
import qualified Data.Text.Lazy as TL
|
||
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
|
||
import Text.XML.Cursor hiding (element)
|
||
import qualified Text.XML.Cursor as C
|
||
import qualified Text.HTML.DOM as HD
|
||
import Control.Monad.Trans.Writer
|
||
import qualified Data.Map as M
|
||
import qualified Web.Cookie as Cookie
|
||
import qualified Blaze.ByteString.Builder as Builder
|
||
import Data.Time.Clock (getCurrentTime)
|
||
import Control.Applicative ((<$>))
|
||
import Text.Show.Pretty (ppShow)
|
||
import Data.Monoid (mempty)
|
||
import Data.Semigroup (Semigroup(..))
|
||
#if MIN_VERSION_base(4,9,0)
|
||
import GHC.Stack (HasCallStack)
|
||
#elif MIN_VERSION_base(4,8,1)
|
||
import GHC.Stack (CallStack)
|
||
type HasCallStack = (?callStack :: CallStack)
|
||
#else
|
||
import GHC.Exts (Constraint)
|
||
type HasCallStack = (() :: Constraint)
|
||
#endif
|
||
import Data.ByteArray.Encoding (convertToBase, Base(..))
|
||
import Network.HTTP.Types.Header (hContentType)
|
||
import Data.Aeson (FromJSON, eitherDecode')
|
||
import Control.Monad (unless)
|
||
|
||
import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)
|
||
import Yesod.Test.Internal.SIO
|
||
|
||
{-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
|
||
{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
|
||
|
||
-- | The state used in a single test case defined using 'yit'
|
||
--
|
||
-- Since 1.2.4
|
||
data YesodExampleData site = YesodExampleData
|
||
{ yedApp :: !Application
|
||
, yedSite :: !site
|
||
, yedCookies :: !Cookies
|
||
, yedResponse :: !(Maybe SResponse)
|
||
}
|
||
|
||
-- | A single test case, to be run with 'yit'.
|
||
--
|
||
-- Since 1.2.0
|
||
type YesodExample site = SIO (YesodExampleData site)
|
||
|
||
-- | Mapping from cookie name to value.
|
||
--
|
||
-- Since 1.2.0
|
||
type Cookies = M.Map ByteString Cookie.SetCookie
|
||
|
||
-- | Corresponds to hspec\'s 'Spec'.
|
||
--
|
||
-- Since 1.2.0
|
||
type YesodSpec site = Writer [YesodSpecTree site] ()
|
||
|
||
-- | Internal data structure, corresponding to hspec\'s "SpecTree".
|
||
--
|
||
-- Since 1.2.0
|
||
data YesodSpecTree site
|
||
= YesodSpecGroup String [YesodSpecTree site]
|
||
| YesodSpecItem String (YesodExample site ())
|
||
|
||
-- | Get the foundation value used for the current test.
|
||
--
|
||
-- Since 1.2.0
|
||
getTestYesod :: YesodExample site site
|
||
getTestYesod = fmap yedSite getSIO
|
||
|
||
-- | Get the most recently provided response value, if available.
|
||
--
|
||
-- Since 1.2.0
|
||
getResponse :: YesodExample site (Maybe SResponse)
|
||
getResponse = fmap yedResponse getSIO
|
||
|
||
data RequestBuilderData site = RequestBuilderData
|
||
{ rbdPostData :: RBDPostData
|
||
, rbdResponse :: (Maybe SResponse)
|
||
, rbdMethod :: H.Method
|
||
, rbdSite :: site
|
||
, rbdPath :: [T.Text]
|
||
, rbdGets :: H.Query
|
||
, rbdHeaders :: H.RequestHeaders
|
||
}
|
||
|
||
data RBDPostData = MultipleItemsPostData [RequestPart]
|
||
| BinaryPostData BSL8.ByteString
|
||
|
||
-- | Request parts let us discern regular key/values from files sent in the request.
|
||
data RequestPart
|
||
= ReqKvPart T.Text T.Text
|
||
| ReqFilePart T.Text FilePath BSL8.ByteString T.Text
|
||
|
||
-- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments
|
||
-- to send with your requests. Some of the functions that run on it use the current
|
||
-- response to analyze the forms that the server is expecting to receive.
|
||
type RequestBuilder site = SIO (RequestBuilderData site)
|
||
|
||
-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
|
||
-- and 'ConnectionPool'
|
||
ydescribe :: String -> YesodSpec site -> YesodSpec site
|
||
ydescribe label yspecs = tell [YesodSpecGroup label $ execWriter yspecs]
|
||
|
||
yesodSpec :: YesodDispatch site
|
||
=> site
|
||
-> YesodSpec site
|
||
-> Hspec.Spec
|
||
yesodSpec site yspecs =
|
||
Hspec.fromSpecList $ map unYesod $ execWriter yspecs
|
||
where
|
||
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
|
||
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
|
||
app <- toWaiAppPlain site
|
||
evalSIO y YesodExampleData
|
||
{ yedApp = app
|
||
, yedSite = site
|
||
, yedCookies = M.empty
|
||
, yedResponse = Nothing
|
||
}
|
||
|
||
-- | Same as yesodSpec, but instead of taking already built site it
|
||
-- takes an action which produces site for each test.
|
||
yesodSpecWithSiteGenerator :: YesodDispatch site
|
||
=> IO site
|
||
-> YesodSpec site
|
||
-> Hspec.Spec
|
||
yesodSpecWithSiteGenerator getSiteAction =
|
||
yesodSpecWithSiteGeneratorAndArgument (const getSiteAction)
|
||
|
||
-- | Same as yesodSpecWithSiteGenerator, but also takes an argument to build the site
|
||
-- and makes that argument available to the tests.
|
||
--
|
||
-- @since 1.6.4
|
||
yesodSpecWithSiteGeneratorAndArgument :: YesodDispatch site
|
||
=> (a -> IO site)
|
||
-> YesodSpec site
|
||
-> Hspec.SpecWith a
|
||
yesodSpecWithSiteGeneratorAndArgument getSiteAction yspecs =
|
||
Hspec.fromSpecList $ map (unYesod getSiteAction) $ execWriter yspecs
|
||
where
|
||
unYesod getSiteAction' (YesodSpecGroup x y) = Hspec.specGroup x $ map (unYesod getSiteAction') y
|
||
unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ \a -> do
|
||
site <- getSiteAction' a
|
||
app <- toWaiAppPlain site
|
||
evalSIO y YesodExampleData
|
||
{ yedApp = app
|
||
, yedSite = site
|
||
, yedCookies = M.empty
|
||
, yedResponse = Nothing
|
||
}
|
||
|
||
-- | Same as yesodSpec, but instead of taking a site it
|
||
-- takes an action which produces the 'Application' for each test.
|
||
-- This lets you use your middleware from makeApplication
|
||
yesodSpecApp :: YesodDispatch site
|
||
=> site
|
||
-> IO Application
|
||
-> YesodSpec site
|
||
-> Hspec.Spec
|
||
yesodSpecApp site getApp yspecs =
|
||
Hspec.fromSpecList $ map unYesod $ execWriter yspecs
|
||
where
|
||
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
|
||
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
|
||
app <- getApp
|
||
evalSIO y YesodExampleData
|
||
{ yedApp = app
|
||
, yedSite = site
|
||
, yedCookies = M.empty
|
||
, yedResponse = Nothing
|
||
}
|
||
|
||
-- | Describe a single test that keeps cookies, and a reference to the last response.
|
||
yit :: String -> YesodExample site () -> YesodSpec site
|
||
yit label example = tell [YesodSpecItem label example]
|
||
|
||
-- | Modifies the site ('yedSite') of the test, and creates a new WAI app ('yedApp') for it.
|
||
--
|
||
-- yesod-test allows sending requests to your application to test that it handles them correctly.
|
||
-- In rare cases, you may wish to modify that application in the middle of a test.
|
||
-- This may be useful if you wish to, for example, test your application under a certain configuration,
|
||
-- then change that configuration to see if your app responds differently.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > post SendEmailR
|
||
-- > -- Assert email not created in database
|
||
-- > testModifySite (\site -> pure (site { siteSettingsStoreEmail = True }, id))
|
||
-- > post SendEmailR
|
||
-- > -- Assert email created in database
|
||
--
|
||
-- > testModifySite (\site -> do
|
||
-- > middleware <- makeLogware site
|
||
-- > pure (site { appRedisConnection = Nothing }, middleware)
|
||
-- > )
|
||
--
|
||
-- @since 1.6.8
|
||
testModifySite :: YesodDispatch site
|
||
=> (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app.
|
||
-> YesodExample site ()
|
||
testModifySite newSiteFn = do
|
||
currentSite <- getTestYesod
|
||
(newSite, middleware) <- liftIO $ newSiteFn currentSite
|
||
app <- liftIO $ toWaiAppPlain newSite
|
||
modifySIO $ \yed -> yed { yedSite = newSite, yedApp = middleware app }
|
||
|
||
-- | Sets a cookie
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > import qualified Web.Cookie as Cookie
|
||
-- > :set -XOverloadedStrings
|
||
-- > testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "name" }
|
||
--
|
||
-- @since 1.6.6
|
||
testSetCookie :: Cookie.SetCookie -> YesodExample site ()
|
||
testSetCookie cookie = do
|
||
let key = Cookie.setCookieName cookie
|
||
modifySIO $ \yed -> yed { yedCookies = M.insert key cookie (yedCookies yed) }
|
||
|
||
-- | Deletes the cookie of the given name
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > :set -XOverloadedStrings
|
||
-- > testDeleteCookie "name"
|
||
--
|
||
-- @since 1.6.6
|
||
testDeleteCookie :: ByteString -> YesodExample site ()
|
||
testDeleteCookie k = do
|
||
modifySIO $ \yed -> yed { yedCookies = M.delete k (yedCookies yed) }
|
||
|
||
-- | Modify the current cookies with the given mapping function
|
||
--
|
||
-- @since 1.6.6
|
||
testModifyCookies :: (Cookies -> Cookies) -> YesodExample site ()
|
||
testModifyCookies f = do
|
||
modifySIO $ \yed -> yed { yedCookies = f (yedCookies yed) }
|
||
|
||
-- | Clears the current cookies
|
||
--
|
||
-- @since 1.6.6
|
||
testClearCookies :: YesodExample site ()
|
||
testClearCookies = do
|
||
modifySIO $ \yed -> yed { yedCookies = M.empty }
|
||
|
||
-- Performs a given action using the last response. Use this to create
|
||
-- response-level assertions
|
||
withResponse' :: HasCallStack
|
||
=> (state -> Maybe SResponse)
|
||
-> [T.Text]
|
||
-> (SResponse -> SIO state a)
|
||
-> SIO state a
|
||
withResponse' getter errTrace f = maybe err f . getter =<< getSIO
|
||
where err = failure msg
|
||
msg = if null errTrace
|
||
then "There was no response, you should make a request."
|
||
else
|
||
"There was no response, you should make a request. A response was needed because: \n - "
|
||
<> T.intercalate "\n - " errTrace
|
||
|
||
-- | Performs a given action using the last response. Use this to create
|
||
-- response-level assertions
|
||
withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a
|
||
withResponse = withResponse' yedResponse []
|
||
|
||
-- | Use HXT to parse a value from an HTML tag.
|
||
-- Check for usage examples in this module's source.
|
||
parseHTML :: HtmlLBS -> Cursor
|
||
parseHTML html = fromDocument $ HD.parseLBS html
|
||
|
||
-- | Query the last response using CSS selectors, returns a list of matched fragments
|
||
htmlQuery' :: HasCallStack
|
||
=> (state -> Maybe SResponse)
|
||
-> [T.Text]
|
||
-> Query
|
||
-> SIO state [HtmlLBS]
|
||
htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res ->
|
||
case findBySelector (simpleBody res) query of
|
||
Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
|
||
Right matches -> return $ map (encodeUtf8 . TL.pack) matches
|
||
|
||
-- | Query the last response using CSS selectors, returns a list of matched fragments
|
||
htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]
|
||
htmlQuery = htmlQuery' yedResponse []
|
||
|
||
-- | Asserts that the two given values are equal.
|
||
--
|
||
-- In case they are not equal, the error message includes the two values.
|
||
--
|
||
-- @since 1.5.2
|
||
assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
|
||
assertEq m a b =
|
||
liftIO $ HUnit.assertEqual msg a b
|
||
where msg = "Assertion: " ++ m ++ "\n"
|
||
|
||
-- | Asserts that the two given values are not equal.
|
||
--
|
||
-- In case they are equal, the error message includes the values.
|
||
--
|
||
-- @since 1.5.6
|
||
assertNotEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
|
||
assertNotEq m a b =
|
||
liftIO $ HUnit.assertBool msg (a /= b)
|
||
where msg = "Assertion: " ++ m ++ "\n" ++
|
||
"Both arguments: " ++ ppShow a ++ "\n"
|
||
|
||
{-# DEPRECATED assertEqual "Use assertEq instead" #-}
|
||
assertEqual :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
|
||
assertEqual = assertEqualNoShow
|
||
|
||
-- | Asserts that the two given values are equal.
|
||
--
|
||
-- @since 1.5.2
|
||
assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
|
||
assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b)
|
||
|
||
-- | Assert the last response status is as expected.
|
||
-- If the status code doesn't match, a portion of the body is also printed to aid in debugging.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > get HomeR
|
||
-- > statusIs 200
|
||
statusIs :: HasCallStack => Int -> YesodExample site ()
|
||
statusIs number = do
|
||
withResponse $ \(SResponse status headers body) -> do
|
||
let mContentType = lookup hContentType headers
|
||
isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType
|
||
|
||
liftIO $ flip HUnit.assertBool (H.statusCode status == number) $ concat
|
||
[ "Expected status was ", show number
|
||
, " but received status was ", show $ H.statusCode status
|
||
, if isUTF8ContentType
|
||
then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body)
|
||
else ""
|
||
]
|
||
|
||
-- | Assert the given header key/value pair was returned.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||
-- > get HomeR
|
||
-- > assertHeader "key" "value"
|
||
--
|
||
-- > import qualified Data.CaseInsensitive as CI
|
||
-- > import qualified Data.ByteString.Char8 as BS8
|
||
-- > getHomeR
|
||
-- > assertHeader (CI.mk (BS8.pack "key")) (BS8.pack "value")
|
||
assertHeader :: HasCallStack => CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
|
||
assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||
case lookup header h of
|
||
Nothing -> failure $ T.pack $ concat
|
||
[ "Expected header "
|
||
, show header
|
||
, " to be "
|
||
, show value
|
||
, ", but it was not present"
|
||
]
|
||
Just value' -> liftIO $ flip HUnit.assertBool (value == value') $ concat
|
||
[ "Expected header "
|
||
, show header
|
||
, " to be "
|
||
, show value
|
||
, ", but received "
|
||
, show value'
|
||
]
|
||
|
||
-- | Assert the given header was not included in the response.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||
-- > get HomeR
|
||
-- > assertNoHeader "key"
|
||
--
|
||
-- > import qualified Data.CaseInsensitive as CI
|
||
-- > import qualified Data.ByteString.Char8 as BS8
|
||
-- > getHomeR
|
||
-- > assertNoHeader (CI.mk (BS8.pack "key"))
|
||
assertNoHeader :: HasCallStack => CI BS8.ByteString -> YesodExample site ()
|
||
assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||
case lookup header h of
|
||
Nothing -> return ()
|
||
Just s -> failure $ T.pack $ concat
|
||
[ "Unexpected header "
|
||
, show header
|
||
, " containing "
|
||
, show s
|
||
]
|
||
|
||
-- | Assert the last response is exactly equal to the given text. This is
|
||
-- useful for testing API responses.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > get HomeR
|
||
-- > bodyEquals "<html><body><h1>Hello, World</h1></body></html>"
|
||
bodyEquals :: HasCallStack => String -> YesodExample site ()
|
||
bodyEquals text = withResponse $ \ res -> do
|
||
let actual = simpleBody res
|
||
msg = concat [ "Expected body to equal:\n\t"
|
||
, text ++ "\n"
|
||
, "Actual is:\n\t"
|
||
, TL.unpack $ decodeUtf8With TErr.lenientDecode actual
|
||
]
|
||
liftIO $ HUnit.assertBool msg $ actual == encodeUtf8 (TL.pack text)
|
||
|
||
-- | Assert the last response has the given text. The check is performed using the response
|
||
-- body in full text form.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > get HomeR
|
||
-- > bodyContains "<h1>Foo</h1>"
|
||
bodyContains :: HasCallStack => String -> YesodExample site ()
|
||
bodyContains text = withResponse $ \ 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 ++ " matches: " ++ show matches) $
|
||
DL.all (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
|
||
|
||
-- | puts the search trough the same escaping as the matches are.
|
||
-- this helps with matching on special characters
|
||
escape :: String -> String
|
||
escape = Blaze.renderMarkup . Blaze.string
|
||
|
||
-- | Queries the HTML using a CSS selector, and passes if any matched
|
||
-- element contains the given string.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||
-- > get HomeR
|
||
-- > htmlAnyContain "p" "Hello" -- At least one <p> tag contains the string "Hello"
|
||
--
|
||
-- Since 0.3.5
|
||
htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site ()
|
||
htmlAnyContain query search = do
|
||
matches <- htmlQuery query
|
||
case matches of
|
||
[] -> failure $ "Nothing matched css query: " <> query
|
||
_ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $
|
||
DL.any (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
|
||
|
||
-- | Queries the HTML using a CSS selector, and fails if any matched
|
||
-- element contains the given string (in other words, it is the logical
|
||
-- inverse of htmlAnyContain).
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||
-- > get HomeR
|
||
-- > htmlNoneContain ".my-class" "Hello" -- No tags with the class "my-class" contain the string "Hello"
|
||
--
|
||
-- Since 1.2.2
|
||
htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
|
||
htmlNoneContain query search = do
|
||
matches <- htmlQuery query
|
||
case DL.filter (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) of
|
||
[] -> return ()
|
||
found -> failure $ "Found " <> T.pack (show $ length found) <>
|
||
" instances of " <> T.pack search <> " in " <> query <> " elements"
|
||
|
||
-- | Performs a CSS query on the last response and asserts the matched elements
|
||
-- are as many as expected.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||
-- > get HomeR
|
||
-- > htmlCount "p" 3 -- There are exactly 3 <p> tags in the response
|
||
htmlCount :: HasCallStack => Query -> Int -> YesodExample site ()
|
||
htmlCount query count = do
|
||
matches <- fmap DL.length $ htmlQuery query
|
||
liftIO $ flip HUnit.assertBool (matches == count)
|
||
("Expected "++(show count)++" elements to match "++T.unpack query++", found "++(show matches))
|
||
|
||
-- | Parses the response body from JSON into a Haskell value, throwing an error if parsing fails.
|
||
--
|
||
-- This function also checks that the @Content-Type@ of the response is @application/json@.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > get CommentR
|
||
-- > (comment :: Comment) <- requireJSONResponse
|
||
--
|
||
-- > post UserR
|
||
-- > (json :: Value) <- requireJSONResponse
|
||
--
|
||
-- @since 1.6.9
|
||
requireJSONResponse :: (HasCallStack, FromJSON a) => YesodExample site a
|
||
requireJSONResponse = do
|
||
withResponse $ \(SResponse _status headers body) -> do
|
||
let mContentType = lookup hContentType headers
|
||
isJSONContentType = maybe False contentTypeHeaderIsJson mContentType
|
||
unless
|
||
isJSONContentType
|
||
(failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers)
|
||
case eitherDecode' body of
|
||
Left err -> failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", getBodyTextPreview body]
|
||
Right v -> return v
|
||
|
||
-- | Outputs the last response body to stderr (So it doesn't get captured by HSpec). Useful for debugging.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > get HomeR
|
||
-- > printBody
|
||
printBody :: YesodExample site ()
|
||
printBody = withResponse $ \ SResponse { simpleBody = b } ->
|
||
liftIO $ BSL8.hPutStrLn stderr b
|
||
|
||
-- | 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 =
|
||
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
|
||
where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."
|
||
addPostData (MultipleItemsPostData posts) =
|
||
MultipleItemsPostData $ ReqKvPart name value : posts
|
||
|
||
-- | Add a parameter with the given name and value to the query string.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||
-- > request $ do
|
||
-- > addGetParam "key" "value" -- Adds ?key=value to the URL
|
||
addGetParam :: T.Text -> T.Text -> RequestBuilder site ()
|
||
addGetParam name value = modifySIO $ \rbd -> rbd
|
||
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
|
||
: rbdGets rbd
|
||
}
|
||
|
||
-- | Add a bare parameter with the given name and no value to the query
|
||
-- string. The parameter is added without an @=@ sign.
|
||
--
|
||
-- You can specify the entire query string literally by adding a single bare
|
||
-- parameter and no other parameters.
|
||
--
|
||
-- @since 1.6.16
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||
-- > request $ do
|
||
-- > addBareGetParam "key" -- Adds ?key to the URL
|
||
addBareGetParam :: T.Text -> RequestBuilder site ()
|
||
addBareGetParam name = modifySIO $ \rbd ->
|
||
rbd {rbdGets = (TE.encodeUtf8 name, Nothing) : rbdGets rbd}
|
||
|
||
-- | Add a file to be posted with the current request.
|
||
--
|
||
-- Adding a file will automatically change your request content-type to be multipart/form-data.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > request $ do
|
||
-- > addFile "profile_picture" "static/img/picture.png" "img/png"
|
||
addFile :: T.Text -- ^ The parameter name for the file.
|
||
-> FilePath -- ^ The path to the file.
|
||
-> T.Text -- ^ The MIME type of the file, e.g. "image/png".
|
||
-> RequestBuilder site ()
|
||
addFile name path mimetype = do
|
||
contents <- liftIO $ BSL8.readFile path
|
||
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
|
||
where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content."
|
||
addPostData (MultipleItemsPostData posts) contents =
|
||
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
|
||
|
||
-- |
|
||
-- This looks up the name of a field based on the contents of the label pointing to it.
|
||
genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
|
||
genericNameFromLabel match label = do
|
||
mres <- fmap rbdResponse getSIO
|
||
res <-
|
||
case mres of
|
||
Nothing -> failure "genericNameFromLabel: No response available"
|
||
Just res -> return res
|
||
let body = simpleBody res
|
||
case genericNameFromHTML match label body of
|
||
Left e -> failure e
|
||
Right x -> pure x
|
||
|
||
-- |
|
||
-- This looks up the name of a field based on a CSS selector and the contents of the label pointing to it.
|
||
genericNameFromSelectorLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> T.Text -> RequestBuilder site T.Text
|
||
genericNameFromSelectorLabel match selector label = do
|
||
mres <- fmap rbdResponse getSIO
|
||
res <-
|
||
case mres of
|
||
Nothing -> failure "genericNameSelectorFromLabel: No response available"
|
||
Just res -> return res
|
||
let body = simpleBody res
|
||
html <-
|
||
case findBySelector body selector of
|
||
Left parseError -> failure $ "genericNameFromSelectorLabel: Parse error" <> T.pack parseError
|
||
Right [] -> failure $ "genericNameFromSelectorLabel: No fragments match selector " <> selector
|
||
Right [matchingFragment] -> pure $ BSL8.pack matchingFragment
|
||
Right _matchingFragments -> failure $ "genericNameFromSelectorLabel: Multiple fragments match selector " <> selector
|
||
case genericNameFromHTML match label html of
|
||
Left e -> failure e
|
||
Right x -> pure x
|
||
|
||
genericNameFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
|
||
genericNameFromHTML match label html =
|
||
let
|
||
parsedHTML = parseHTML html
|
||
mlabel = parsedHTML
|
||
$// C.element "label"
|
||
>=> isContentMatch label
|
||
mfor = mlabel >>= attribute "for"
|
||
|
||
isContentMatch x c
|
||
| x `match` T.concat (c $// content) = [c]
|
||
| otherwise = []
|
||
|
||
in case mfor of
|
||
for:[] -> do
|
||
let mname = parsedHTML
|
||
$// attributeIs "id" for
|
||
>=> attribute "name"
|
||
case mname of
|
||
"":_ -> Left $ T.concat
|
||
[ "Label "
|
||
, label
|
||
, " resolved to id "
|
||
, for
|
||
, " which was not found. "
|
||
]
|
||
name:_ -> Right name
|
||
[] -> Left $ "No input with id " <> for
|
||
[] ->
|
||
case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of
|
||
[] -> Left $ "No label contained: " <> label
|
||
name:_ -> Right name
|
||
_ -> Left $ "More than one label contained " <> label
|
||
|
||
byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||
-> T.Text -- ^ The value to set the parameter to.
|
||
-> RequestBuilder site ()
|
||
byLabelWithMatch match label value = do
|
||
name <- genericNameFromLabel match label
|
||
addPostParam name value
|
||
|
||
bySelectorLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||
-> T.Text -- ^ The CSS selector.
|
||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||
-> T.Text -- ^ The value to set the parameter to.
|
||
-> RequestBuilder site ()
|
||
bySelectorLabelWithMatch match selector label value = do
|
||
name <- genericNameFromSelectorLabel match selector label
|
||
addPostParam name value
|
||
|
||
-- How does this work for the alternate <label><input></label> syntax?
|
||
|
||
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
|
||
-- for that input to the request body.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- Given this HTML, we want to submit @f1=Michael@ to the server:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label for="user">Username</label>
|
||
-- > <input id="user" name="f1" />
|
||
-- > </form>
|
||
--
|
||
-- You can set this parameter like so:
|
||
--
|
||
-- > request $ do
|
||
-- > byLabel "Username" "Michael"
|
||
--
|
||
-- This function also supports the implicit label syntax, in which
|
||
-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label>Username <input name="f1"> </label>
|
||
-- > </form>
|
||
--
|
||
-- Warning: This function looks for any label that contains the provided text.
|
||
-- If multiple labels contain that text, this function will throw an error,
|
||
-- as in the example below:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label for="nickname">Nickname</label>
|
||
-- > <input id="nickname" name="f1" />
|
||
--
|
||
-- > <label for="nickname2">Nickname2</label>
|
||
-- > <input id="nickname2" name="f2" />
|
||
-- > </form>
|
||
--
|
||
-- > request $ do
|
||
-- > byLabel "Nickname" "Snoyberger"
|
||
--
|
||
-- Then, it throws "More than one label contained" error.
|
||
--
|
||
-- Therefore, this function is deprecated. Please consider using 'byLabelExact',
|
||
-- which performs the exact match over the provided text.
|
||
byLabel :: T.Text -- ^ The text contained in the @\<label>@.
|
||
-> T.Text -- ^ The value to set the parameter to.
|
||
-> RequestBuilder site ()
|
||
byLabel = byLabelWithMatch T.isInfixOf
|
||
|
||
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
|
||
-- for that input to the request body.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- Given this HTML, we want to submit @f1=Michael@ to the server:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label for="user">Username</label>
|
||
-- > <input id="user" name="f1" />
|
||
-- > </form>
|
||
--
|
||
-- You can set this parameter like so:
|
||
--
|
||
-- > request $ do
|
||
-- > byLabel "Username" "Michael"
|
||
--
|
||
-- This function also supports the implicit label syntax, in which
|
||
-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label>Username <input name="f1"> </label>
|
||
-- > </form>
|
||
--
|
||
-- @since 1.5.9
|
||
byLabelExact :: T.Text -- ^ The text in the @\<label>@.
|
||
-> T.Text -- ^ The value to set the parameter to.
|
||
-> RequestBuilder site ()
|
||
byLabelExact = byLabelWithMatch (==)
|
||
|
||
-- |
|
||
-- 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
|
||
|
||
-- |
|
||
-- Note: This function throws an error if it finds multiple labels or if the
|
||
-- CSS selector fails to parse, doesn't match any fragment, or matches multiple
|
||
-- fragments.
|
||
--
|
||
-- @since 1.6.15
|
||
bySelectorLabelContain :: T.Text -- ^ The CSS selector.
|
||
-> T.Text -- ^ The text in the @\<label>@.
|
||
-> T.Text -- ^ The value to set the parameter to.
|
||
-> RequestBuilder site ()
|
||
bySelectorLabelContain = bySelectorLabelWithMatch T.isInfixOf
|
||
|
||
fileByLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||
-> FilePath -- ^ The path to the file.
|
||
-> T.Text -- ^ The MIME type of the file, e.g. "image/png".
|
||
-> RequestBuilder site ()
|
||
fileByLabelWithMatch match label path mime = do
|
||
name <- genericNameFromLabel match label
|
||
addFile name path mime
|
||
|
||
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- Given this HTML, we want to submit a file with the parameter name @f1@ to the server:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label for="imageInput">Please submit an image</label>
|
||
-- > <input id="imageInput" type="file" name="f1" accept="image/*">
|
||
-- > </form>
|
||
--
|
||
-- You can set this parameter like so:
|
||
--
|
||
-- > request $ do
|
||
-- > fileByLabel "Please submit an image" "static/img/picture.png" "img/png"
|
||
--
|
||
-- This function also supports the implicit label syntax, in which
|
||
-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label>Please submit an image <input type="file" name="f1"> </label>
|
||
-- > </form>
|
||
--
|
||
-- Warning: This function has the same issue as 'byLabel'. Please use 'fileByLabelExact' instead.
|
||
fileByLabel :: T.Text -- ^ The text contained in the @\<label>@.
|
||
-> FilePath -- ^ The path to the file.
|
||
-> T.Text -- ^ The MIME type of the file, e.g. "image/png".
|
||
-> RequestBuilder site ()
|
||
fileByLabel = fileByLabelWithMatch T.isInfixOf
|
||
|
||
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- Given this HTML, we want to submit a file with the parameter name @f1@ to the server:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label for="imageInput">Please submit an image</label>
|
||
-- > <input id="imageInput" type="file" name="f1" accept="image/*">
|
||
-- > </form>
|
||
--
|
||
-- You can set this parameter like so:
|
||
--
|
||
-- > request $ do
|
||
-- > fileByLabel "Please submit an image" "static/img/picture.png" "img/png"
|
||
--
|
||
-- This function also supports the implicit label syntax, in which
|
||
-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:
|
||
--
|
||
-- > <form method="POST">
|
||
-- > <label>Please submit an image <input type="file" name="f1"> </label>
|
||
-- > </form>
|
||
--
|
||
-- @since 1.5.9
|
||
fileByLabelExact :: 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 <- 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 = 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 getSIO
|
||
eurl <- Yesod.Core.Unsafe.runFakeHandler
|
||
M.empty
|
||
(const $ error "Yesod.Test: No logger available")
|
||
site
|
||
(toTextUrl url')
|
||
url <- either (error . show) return eurl
|
||
let (urlPath, urlQuery) = T.break (== '?') url
|
||
modifySIO $ \rbd -> rbd
|
||
{ rbdPath =
|
||
case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
|
||
("http:":_:rest) -> rest
|
||
("https:":_:rest) -> rest
|
||
x -> x
|
||
, rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery)
|
||
}
|
||
|
||
|
||
-- | Click on a link defined by a CSS query
|
||
--
|
||
-- ==== __ Examples__
|
||
--
|
||
-- > get "/foobar"
|
||
-- > clickOn "a#idofthelink"
|
||
--
|
||
-- @since 1.5.7
|
||
clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()
|
||
clickOn query = do
|
||
withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->
|
||
case findAttributeBySelector (simpleBody res) query "href" of
|
||
Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
|
||
Right [[match]] -> get match
|
||
Right matches -> failure $ "Expected exactly one match for clickOn: got " <> T.pack (show matches)
|
||
|
||
|
||
|
||
-- | Simple way to set HTTP request body
|
||
--
|
||
-- ==== __ Examples__
|
||
--
|
||
-- > request $ do
|
||
-- > setRequestBody "foobar"
|
||
--
|
||
-- > import Data.Aeson
|
||
-- > request $ do
|
||
-- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)]
|
||
setRequestBody :: BSL8.ByteString -> RequestBuilder site ()
|
||
setRequestBody body = modifySIO $ \rbd -> rbd { rbdPostData = BinaryPostData body }
|
||
|
||
-- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > import Network.HTTP.Types.Header
|
||
-- > request $ do
|
||
-- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0")
|
||
addRequestHeader :: H.Header -> RequestBuilder site ()
|
||
addRequestHeader header = modifySIO $ \rbd -> rbd
|
||
{ rbdHeaders = header : rbdHeaders rbd
|
||
}
|
||
|
||
-- | Adds a header for <https://en.wikipedia.org/wiki/Basic_access_authentication HTTP Basic Authentication> to the request
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > request $ do
|
||
-- > addBasicAuthHeader "Aladdin" "OpenSesame"
|
||
--
|
||
-- @since 1.6.7
|
||
addBasicAuthHeader :: CI ByteString -- ^ Username
|
||
-> CI ByteString -- ^ Password
|
||
-> RequestBuilder site ()
|
||
addBasicAuthHeader username password =
|
||
let credentials = convertToBase Base64 $ CI.original $ username <> ":" <> password
|
||
in addRequestHeader ("Authorization", "Basic " <> credentials)
|
||
|
||
-- | The general interface for performing requests. 'request' takes a 'RequestBuilder',
|
||
-- constructs a request, and executes it.
|
||
--
|
||
-- The 'RequestBuilder' allows you to build up attributes of the request, like the
|
||
-- headers, parameters, and URL of the request.
|
||
--
|
||
-- ==== __Examples__
|
||
--
|
||
-- > request $ do
|
||
-- > addToken
|
||
-- > byLabel "First Name" "Felipe"
|
||
-- > setMethod "PUT"
|
||
-- > setUrl NameR
|
||
request :: RequestBuilder site ()
|
||
-> YesodExample site ()
|
||
request reqBuilder = do
|
||
YesodExampleData app site oldCookies mRes <- getSIO
|
||
|
||
RequestBuilderData {..} <- liftIO $ execSIO reqBuilder RequestBuilderData
|
||
{ rbdPostData = MultipleItemsPostData []
|
||
, rbdResponse = mRes
|
||
, rbdMethod = "GET"
|
||
, rbdSite = site
|
||
, rbdPath = []
|
||
, rbdGets = []
|
||
, rbdHeaders = []
|
||
}
|
||
let path
|
||
| null rbdPath = "/"
|
||
| otherwise = TE.decodeUtf8 $ Builder.toByteString $ H.encodePathSegments rbdPath
|
||
|
||
-- expire cookies and filter them for the current path. TODO: support max age
|
||
currentUtc <- liftIO getCurrentTime
|
||
let cookies = M.filter (checkCookieTime currentUtc) oldCookies
|
||
cookiesForPath = M.filter (checkCookiePath path) cookies
|
||
|
||
let req = case rbdPostData of
|
||
MultipleItemsPostData x ->
|
||
if DL.any isFile x
|
||
then (multipart x)
|
||
else singlepart
|
||
BinaryPostData _ -> singlepart
|
||
where singlepart = makeSinglepart cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets
|
||
multipart x = makeMultipart cookiesForPath x rbdMethod rbdHeaders path rbdGets
|
||
-- let maker = case rbdPostData of
|
||
-- MultipleItemsPostData x ->
|
||
-- if DL.any isFile x
|
||
-- then makeMultipart
|
||
-- else makeSinglepart
|
||
-- BinaryPostData _ -> makeSinglepart
|
||
-- let req = maker cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets
|
||
response <- liftIO $ runSession (srequest req
|
||
{ simpleRequest = (simpleRequest req)
|
||
{ httpVersion = H.http11
|
||
}
|
||
}) app
|
||
let newCookies = parseSetCookies $ simpleHeaders response
|
||
cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies
|
||
putSIO $ YesodExampleData app site cookies' (Just response)
|
||
where
|
||
isFile (ReqFilePart _ _ _ _) = True
|
||
isFile _ = False
|
||
|
||
checkCookieTime t c = case Cookie.setCookieExpires c of
|
||
Nothing -> True
|
||
Just t' -> t < t'
|
||
checkCookiePath url c =
|
||
case Cookie.setCookiePath c of
|
||
Nothing -> True
|
||
Just x -> x `BS8.isPrefixOf` TE.encodeUtf8 url
|
||
|
||
-- For building the multi-part requests
|
||
boundary :: String
|
||
boundary = "*******noneedtomakethisrandom"
|
||
separator = BS8.concat ["--", BS8.pack boundary, "\r\n"]
|
||
makeMultipart :: M.Map a0 Cookie.SetCookie
|
||
-> [RequestPart]
|
||
-> H.Method
|
||
-> [H.Header]
|
||
-> T.Text
|
||
-> H.Query
|
||
-> SRequest
|
||
makeMultipart cookies parts method extraHeaders urlPath urlQuery =
|
||
SRequest simpleRequest' (simpleRequestBody' parts)
|
||
where simpleRequestBody' x =
|
||
BSL8.fromChunks [multiPartBody x]
|
||
simpleRequest' = mkRequest
|
||
[ ("Cookie", cookieValue)
|
||
, ("Content-Type", contentTypeValue)]
|
||
method extraHeaders urlPath urlQuery
|
||
cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs
|
||
cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
|
||
| c <- map snd $ M.toList cookies ]
|
||
contentTypeValue = BS8.pack $ "multipart/form-data; boundary=" ++ boundary
|
||
multiPartBody parts =
|
||
BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]
|
||
multipartPart (ReqKvPart k v) = BS8.concat
|
||
[ "Content-Disposition: form-data; "
|
||
, "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"
|
||
, TE.encodeUtf8 v, "\r\n"]
|
||
multipartPart (ReqFilePart k v bytes mime) = BS8.concat
|
||
[ "Content-Disposition: form-data; "
|
||
, "name=\"", TE.encodeUtf8 k, "\"; "
|
||
, "filename=\"", BS8.pack v, "\"\r\n"
|
||
, "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"
|
||
, BS8.concat $ BSL8.toChunks bytes, "\r\n"]
|
||
|
||
-- For building the regular non-multipart requests
|
||
makeSinglepart :: M.Map a0 Cookie.SetCookie
|
||
-> RBDPostData
|
||
-> H.Method
|
||
-> [H.Header]
|
||
-> T.Text
|
||
-> H.Query
|
||
-> SRequest
|
||
makeSinglepart cookies rbdPostData method extraHeaders urlPath urlQuery =
|
||
SRequest simpleRequest' (simpleRequestBody' rbdPostData)
|
||
where
|
||
simpleRequest' = (mkRequest
|
||
([ ("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 ""
|
||
|
||
type TestApp site = (site, Middleware)
|
||
testApp :: site -> Middleware -> TestApp site
|
||
testApp site middleware = (site, middleware)
|
||
type YSpec site = Hspec.SpecWith (TestApp site)
|
||
|
||
instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) where
|
||
type Arg (SIO (YesodExampleData site) a) = TestApp site
|
||
|
||
evaluateExample example params action =
|
||
Hspec.evaluateExample
|
||
(action $ \(site, middleware) -> do
|
||
app <- toWaiAppPlain site
|
||
_ <- evalSIO example YesodExampleData
|
||
{ yedApp = middleware app
|
||
, yedSite = site
|
||
, yedCookies = M.empty
|
||
, yedResponse = Nothing
|
||
}
|
||
return ())
|
||
params
|
||
($ ())
|