{-# 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
    , chooseByLabel
    , checkByLabel
    , selectByLabel

    -- *** CSRF Tokens
    -- | In order to prevent CSRF exploits, yesod-form adds a hidden input
    -- to your forms with the name "_token". This token is a randomly generated,
    -- per-session value.
    --
    -- In order to prevent your forms from being rejected in tests, use one of
    -- these functions to add the token to your request.
    , addToken
    , addToken_
    , addTokenFromCookie
    , addTokenFromCookieNamedToHeaderNamed

    -- * Assertions
    , assertEqual
    , assertNotEq
    , assertEqualNoShow
    , assertEq

    , assertHeader
    , assertNoHeader
    , statusIs
    , bodyEquals
    , bodyContains
    , bodyNotContains
    , htmlAllContain
    , htmlAnyContain
    , htmlNoneContain
    , htmlCount
    , requireJSONResponse

    -- * Grab information
    , getTestYesod
    , getResponse
    , getRequestCookies

    -- * Debug output
    , printBody
    , 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)
#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 (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
    { forall site. YesodExampleData site -> Application
yedApp :: !Application
    , forall site. YesodExampleData site -> site
yedSite :: !site
    , forall site. YesodExampleData site -> Cookies
yedCookies :: !Cookies
    , forall site. YesodExampleData site -> Maybe SResponse
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 :: forall site. YesodExample site site
getTestYesod = (YesodExampleData site -> site)
-> SIO (YesodExampleData site) (YesodExampleData site)
-> SIO (YesodExampleData site) site
forall a b.
(a -> b)
-> SIO (YesodExampleData site) a -> SIO (YesodExampleData site) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap YesodExampleData site -> site
forall site. YesodExampleData site -> site
yedSite SIO (YesodExampleData site) (YesodExampleData site)
forall s. SIO s s
getSIO

-- | Get the most recently provided response value, if available.
--
-- Since 1.2.0
getResponse :: YesodExample site (Maybe SResponse)
getResponse :: forall site. YesodExample site (Maybe SResponse)
getResponse = (YesodExampleData site -> Maybe SResponse)
-> SIO (YesodExampleData site) (YesodExampleData site)
-> SIO (YesodExampleData site) (Maybe SResponse)
forall a b.
(a -> b)
-> SIO (YesodExampleData site) a -> SIO (YesodExampleData site) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap YesodExampleData site -> Maybe SResponse
forall site. YesodExampleData site -> Maybe SResponse
yedResponse SIO (YesodExampleData site) (YesodExampleData site)
forall s. SIO s s
getSIO

data RequestBuilderData site = RequestBuilderData
    { forall site. RequestBuilderData site -> RBDPostData
rbdPostData :: RBDPostData
    , forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse :: (Maybe SResponse)
    , forall site. RequestBuilderData site -> ByteString
rbdMethod :: H.Method
    , forall site. RequestBuilderData site -> site
rbdSite :: site
    , forall site. RequestBuilderData site -> [Text]
rbdPath :: [T.Text]
    , forall site. RequestBuilderData site -> Query
rbdGets :: H.Query
    , forall site. RequestBuilderData site -> RequestHeaders
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 :: forall site. String -> YesodSpec site -> YesodSpec site
ydescribe String
label YesodSpec site
yspecs = [YesodSpecTree site] -> YesodSpec site
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [String -> [YesodSpecTree site] -> YesodSpecTree site
forall site. String -> [YesodSpecTree site] -> YesodSpecTree site
YesodSpecGroup String
label ([YesodSpecTree site] -> YesodSpecTree site)
-> [YesodSpecTree site] -> YesodSpecTree site
forall a b. (a -> b) -> a -> b
$ YesodSpec site -> [YesodSpecTree site]
forall w a. Writer w a -> w
execWriter YesodSpec site
yspecs]

yesodSpec :: YesodDispatch site
          => site
          -> YesodSpec site
          -> Hspec.Spec
yesodSpec :: forall site. YesodDispatch site => site -> YesodSpec site -> Spec
yesodSpec site
site YesodSpec site
yspecs =
    [SpecTree ()] -> Spec
forall a. [SpecTree a] -> SpecWith a
Hspec.fromSpecList ([SpecTree ()] -> Spec) -> [SpecTree ()] -> Spec
forall a b. (a -> b) -> a -> b
$ (YesodSpecTree site -> SpecTree ())
-> [YesodSpecTree site] -> [SpecTree ()]
forall a b. (a -> b) -> [a] -> [b]
map YesodSpecTree site -> SpecTree ()
unYesod ([YesodSpecTree site] -> [SpecTree ()])
-> [YesodSpecTree site] -> [SpecTree ()]
forall a b. (a -> b) -> a -> b
$ YesodSpec site -> [YesodSpecTree site]
forall w a. Writer w a -> w
execWriter YesodSpec site
yspecs
  where
    unYesod :: YesodSpecTree site -> SpecTree ()
unYesod (YesodSpecGroup String
x [YesodSpecTree site]
y) = String -> [SpecTree ()] -> SpecTree ()
forall a. HasCallStack => String -> [SpecTree a] -> SpecTree a
Hspec.specGroup String
x ([SpecTree ()] -> SpecTree ()) -> [SpecTree ()] -> SpecTree ()
forall a b. (a -> b) -> a -> b
$ (YesodSpecTree site -> SpecTree ())
-> [YesodSpecTree site] -> [SpecTree ()]
forall a b. (a -> b) -> [a] -> [b]
map YesodSpecTree site -> SpecTree ()
unYesod [YesodSpecTree site]
y
    unYesod (YesodSpecItem String
x YesodExample site ()
y) = String -> IO () -> SpecTree (Arg (IO ()))
forall e.
(HasCallStack, Example e) =>
String -> e -> SpecTree (Arg e)
Hspec.specItem String
x (IO () -> SpecTree (Arg (IO ())))
-> IO () -> SpecTree (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        app <- site -> IO Application
forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
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 :: forall site.
YesodDispatch site =>
IO site -> YesodSpec site -> Spec
yesodSpecWithSiteGenerator IO site
getSiteAction =
    (() -> IO site) -> YesodSpec site -> Spec
forall site a.
YesodDispatch site =>
(a -> IO site) -> YesodSpec site -> SpecWith a
yesodSpecWithSiteGeneratorAndArgument (IO site -> () -> IO site
forall a b. a -> b -> a
const IO site
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 :: forall site a.
YesodDispatch site =>
(a -> IO site) -> YesodSpec site -> SpecWith a
yesodSpecWithSiteGeneratorAndArgument a -> IO site
getSiteAction YesodSpec site
yspecs =
    [SpecTree a] -> SpecWith a
forall a. [SpecTree a] -> SpecWith a
Hspec.fromSpecList ([SpecTree a] -> SpecWith a) -> [SpecTree a] -> SpecWith a
forall a b. (a -> b) -> a -> b
$ (YesodSpecTree site -> SpecTree a)
-> [YesodSpecTree site] -> [SpecTree a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> IO site) -> YesodSpecTree site -> SpecTree a
forall {site} {t}.
YesodDispatch site =>
(t -> IO site) -> YesodSpecTree site -> SpecTree t
unYesod a -> IO site
getSiteAction) ([YesodSpecTree site] -> [SpecTree a])
-> [YesodSpecTree site] -> [SpecTree a]
forall a b. (a -> b) -> a -> b
$ YesodSpec site -> [YesodSpecTree site]
forall w a. Writer w a -> w
execWriter YesodSpec site
yspecs
    where
      unYesod :: (t -> IO site) -> YesodSpecTree site -> SpecTree (Arg (t -> IO ()))
unYesod t -> IO site
getSiteAction' (YesodSpecGroup String
x [YesodSpecTree site]
y) = String
-> [SpecTree (Arg (t -> IO ()))] -> SpecTree (Arg (t -> IO ()))
forall a. HasCallStack => String -> [SpecTree a] -> SpecTree a
Hspec.specGroup String
x ([SpecTree (Arg (t -> IO ()))] -> SpecTree (Arg (t -> IO ())))
-> [SpecTree (Arg (t -> IO ()))] -> SpecTree (Arg (t -> IO ()))
forall a b. (a -> b) -> a -> b
$ (YesodSpecTree site -> SpecTree (Arg (t -> IO ())))
-> [YesodSpecTree site] -> [SpecTree (Arg (t -> IO ()))]
forall a b. (a -> b) -> [a] -> [b]
map ((t -> IO site) -> YesodSpecTree site -> SpecTree (Arg (t -> IO ()))
unYesod t -> IO site
getSiteAction') [YesodSpecTree site]
y
      unYesod t -> IO site
getSiteAction' (YesodSpecItem String
x YesodExample site ()
y) = String -> (t -> IO ()) -> SpecTree (Arg (t -> IO ()))
forall e.
(HasCallStack, Example e) =>
String -> e -> SpecTree (Arg e)
Hspec.specItem String
x ((t -> IO ()) -> SpecTree (Arg (t -> IO ())))
-> (t -> IO ()) -> SpecTree (Arg (t -> IO ()))
forall a b. (a -> b) -> a -> b
$ \t
a -> do
        site <- t -> IO site
getSiteAction' t
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 :: forall site.
YesodDispatch site =>
site -> IO Application -> YesodSpec site -> Spec
yesodSpecApp site
site IO Application
getApp YesodSpec site
yspecs =
    [SpecTree ()] -> Spec
forall a. [SpecTree a] -> SpecWith a
Hspec.fromSpecList ([SpecTree ()] -> Spec) -> [SpecTree ()] -> Spec
forall a b. (a -> b) -> a -> b
$ (YesodSpecTree site -> SpecTree ())
-> [YesodSpecTree site] -> [SpecTree ()]
forall a b. (a -> b) -> [a] -> [b]
map YesodSpecTree site -> SpecTree ()
unYesod ([YesodSpecTree site] -> [SpecTree ()])
-> [YesodSpecTree site] -> [SpecTree ()]
forall a b. (a -> b) -> a -> b
$ YesodSpec site -> [YesodSpecTree site]
forall w a. Writer w a -> w
execWriter YesodSpec site
yspecs
  where
    unYesod :: YesodSpecTree site -> SpecTree ()
unYesod (YesodSpecGroup String
x [YesodSpecTree site]
y) = String -> [SpecTree ()] -> SpecTree ()
forall a. HasCallStack => String -> [SpecTree a] -> SpecTree a
Hspec.specGroup String
x ([SpecTree ()] -> SpecTree ()) -> [SpecTree ()] -> SpecTree ()
forall a b. (a -> b) -> a -> b
$ (YesodSpecTree site -> SpecTree ())
-> [YesodSpecTree site] -> [SpecTree ()]
forall a b. (a -> b) -> [a] -> [b]
map YesodSpecTree site -> SpecTree ()
unYesod [YesodSpecTree site]
y
    unYesod (YesodSpecItem String
x YesodExample site ()
y) = String -> IO () -> SpecTree (Arg (IO ()))
forall e.
(HasCallStack, Example e) =>
String -> e -> SpecTree (Arg e)
Hspec.specItem String
x (IO () -> SpecTree (Arg (IO ())))
-> IO () -> SpecTree (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        app <- IO Application
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 :: forall site. String -> YesodExample site () -> YesodSpec site
yit String
label YesodExample site ()
example = [YesodSpecTree site] -> WriterT [YesodSpecTree site] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [String -> YesodExample site () -> YesodSpecTree site
forall site. String -> YesodExample site () -> YesodSpecTree site
YesodSpecItem String
label YesodExample site ()
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 :: forall site.
YesodDispatch site =>
(site -> IO (site, Middleware)) -> YesodExample site ()
testModifySite site -> IO (site, Middleware)
newSiteFn = do
  currentSite <- YesodExample site site
forall site. YesodExample site site
getTestYesod
  (newSite, middleware) <- liftIO $ newSiteFn currentSite
  app <- liftIO $ toWaiAppPlain newSite
  modifySIO $ \YesodExampleData site
yed -> YesodExampleData site
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 :: forall site. SetCookie -> YesodExample site ()
testSetCookie SetCookie
cookie = do
  let key :: ByteString
key = SetCookie -> ByteString
Cookie.setCookieName SetCookie
cookie
  (YesodExampleData site -> YesodExampleData site)
-> SIO (YesodExampleData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
 -> SIO (YesodExampleData site) ())
-> (YesodExampleData site -> YesodExampleData site)
-> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
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 :: forall site. ByteString -> YesodExample site ()
testDeleteCookie ByteString
k = do
  (YesodExampleData site -> YesodExampleData site)
-> SIO (YesodExampleData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
 -> SIO (YesodExampleData site) ())
-> (YesodExampleData site -> YesodExampleData site)
-> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
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 :: forall site. (Cookies -> Cookies) -> YesodExample site ()
testModifyCookies Cookies -> Cookies
f = do
  (YesodExampleData site -> YesodExampleData site)
-> SIO (YesodExampleData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
 -> SIO (YesodExampleData site) ())
-> (YesodExampleData site -> YesodExampleData site)
-> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies = f (yedCookies yed) }

-- | Clears the current cookies
--
-- @since 1.6.6
testClearCookies :: YesodExample site ()
testClearCookies :: forall site. YesodExample site ()
testClearCookies = do
  (YesodExampleData site -> YesodExampleData site)
-> SIO (YesodExampleData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
 -> SIO (YesodExampleData site) ())
-> (YesodExampleData site -> YesodExampleData site)
-> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
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' :: forall state a.
HasCallStack =>
(state -> Maybe SResponse)
-> [Text] -> (SResponse -> SIO state a) -> SIO state a
withResponse' state -> Maybe SResponse
getter [Text]
errTrace SResponse -> SIO state a
f = SIO state a
-> (SResponse -> SIO state a) -> Maybe SResponse -> SIO state a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SIO state a
err SResponse -> SIO state a
f (Maybe SResponse -> SIO state a)
-> (state -> Maybe SResponse) -> state -> SIO state a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state -> Maybe SResponse
getter (state -> SIO state a) -> SIO state state -> SIO state a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SIO state state
forall s. SIO s s
getSIO
 where err :: SIO state a
err = Text -> SIO state a
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
msg
       msg :: Text
msg = if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errTrace
             then Text
"There was no response, you should make a request."
             else
               Text
"There was no response, you should make a request. A response was needed because: \n - "
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n - " [Text]
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 :: forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse = (YesodExampleData site -> Maybe SResponse)
-> [Text]
-> (SResponse -> SIO (YesodExampleData site) a)
-> SIO (YesodExampleData site) a
forall state a.
HasCallStack =>
(state -> Maybe SResponse)
-> [Text] -> (SResponse -> SIO state a) -> SIO state a
withResponse' YesodExampleData site -> Maybe SResponse
forall site. YesodExampleData site -> Maybe SResponse
yedResponse []

-- | Use HXT to parse a value from an HTML tag.
-- Check for usage examples in this module's source.
parseHTML :: HtmlLBS -> Cursor
parseHTML :: HtmlLBS -> Cursor
parseHTML HtmlLBS
html = Document -> Cursor
fromDocument (Document -> Cursor) -> Document -> Cursor
forall a b. (a -> b) -> a -> b
$ HtmlLBS -> Document
HD.parseLBS HtmlLBS
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' :: forall state.
HasCallStack =>
(state -> Maybe SResponse) -> [Text] -> Text -> SIO state [HtmlLBS]
htmlQuery' state -> Maybe SResponse
getter [Text]
errTrace Text
query = (state -> Maybe SResponse)
-> [Text]
-> (SResponse -> SIO state [HtmlLBS])
-> SIO state [HtmlLBS]
forall state a.
HasCallStack =>
(state -> Maybe SResponse)
-> [Text] -> (SResponse -> SIO state a) -> SIO state a
withResponse' state -> Maybe SResponse
getter (Text
"Tried to invoke htmlQuery' in order to read HTML of a previous response." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
errTrace) ((SResponse -> SIO state [HtmlLBS]) -> SIO state [HtmlLBS])
-> (SResponse -> SIO state [HtmlLBS]) -> SIO state [HtmlLBS]
forall a b. (a -> b) -> a -> b
$ \ SResponse
res ->
  case HtmlLBS -> Text -> Either String [String]
findBySelector (SResponse -> HtmlLBS
simpleBody SResponse
res) Text
query of
    Left String
err -> Text -> SIO state [HtmlLBS]
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO state [HtmlLBS]) -> Text -> SIO state [HtmlLBS]
forall a b. (a -> b) -> a -> b
$ Text
query Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" did not parse: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
err)
    Right [String]
matches -> [HtmlLBS] -> SIO state [HtmlLBS]
forall a. a -> SIO state a
forall (m :: * -> *) a. Monad m => a -> m a
return ([HtmlLBS] -> SIO state [HtmlLBS])
-> [HtmlLBS] -> SIO state [HtmlLBS]
forall a b. (a -> b) -> a -> b
$ (String -> HtmlLBS) -> [String] -> [HtmlLBS]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> HtmlLBS
encodeUtf8 (Text -> HtmlLBS) -> (String -> Text) -> String -> HtmlLBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack) [String]
matches

-- | Query the last response using CSS selectors, returns a list of matched fragments
htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]
htmlQuery :: forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery = (YesodExampleData site -> Maybe SResponse)
-> [Text] -> Text -> SIO (YesodExampleData site) [HtmlLBS]
forall state.
HasCallStack =>
(state -> Maybe SResponse) -> [Text] -> Text -> SIO state [HtmlLBS]
htmlQuery' YesodExampleData site -> Maybe SResponse
forall site. YesodExampleData site -> Maybe SResponse
yedResponse []

-- | Asserts that the two given values are equal.
--
-- In case they are not equal, the error message includes the two values.
--
-- @since 1.5.2
assertEq :: (HasCallStack, Eq a, Show a)
  => String -- ^ The message prefix
  -> a      -- ^ The expected value
  -> a      -- ^ The actual value
  -> YesodExample site ()
assertEq :: forall a site.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> YesodExample site ()
assertEq String
m a
a a
b =
  IO () -> SIO (YesodExampleData site) ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SIO (YesodExampleData site) ())
-> IO () -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ String -> a -> a -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
HUnit.assertEqual String
msg a
a a
b
  where msg :: String
msg = String
"Assertion: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\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 :: forall a site.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> YesodExample site ()
assertNotEq String
m a
a a
b =
  IO () -> SIO (YesodExampleData site) ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SIO (YesodExampleData site) ())
-> IO () -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool String
msg (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b)
  where msg :: String
msg = String
"Assertion: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"Both arguments:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
ppShow a
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

{-# DEPRECATED assertEqual "Use assertEq instead" #-}
assertEqual :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
assertEqual :: forall a site.
(HasCallStack, Eq a) =>
String -> a -> a -> YesodExample site ()
assertEqual = String -> a -> a -> YesodExample site ()
forall a site.
(HasCallStack, Eq a) =>
String -> a -> a -> YesodExample site ()
assertEqualNoShow

-- | Asserts that the two given values are equal.
--
-- @since 1.5.2
assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
assertEqualNoShow :: forall a site.
(HasCallStack, Eq a) =>
String -> a -> a -> YesodExample site ()
assertEqualNoShow String
msg a
a a
b = IO () -> SIO (YesodExampleData site) ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SIO (YesodExampleData site) ())
-> IO () -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool String
msg (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 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 :: forall site. HasCallStack => Int -> YesodExample site ()
statusIs Int
number = do
  (SResponse -> YesodExample site ()) -> YesodExample site ()
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse ((SResponse -> YesodExample site ()) -> YesodExample site ())
-> (SResponse -> YesodExample site ()) -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \(SResponse Status
status RequestHeaders
headers HtmlLBS
body) -> do
    let mContentType :: Maybe ByteString
mContentType = HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType RequestHeaders
headers
        isUTF8ContentType :: Bool
isUTF8ContentType = Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ByteString -> Bool
contentTypeHeaderIsUtf8 Maybe ByteString
mContentType

    IO () -> YesodExample site ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodExample site ()) -> IO () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ (String -> Bool -> IO ()) -> Bool -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool (Status -> Int
H.statusCode Status
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
number) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"Expected status was ", Int -> String
forall a. Show a => a -> String
show Int
number
      , String
" but received status was ", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Status -> Int
H.statusCode Status
status
      , if Bool
isUTF8ContentType
          then String
". For debugging, the body was: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ HtmlLBS -> Text
getBodyTextPreview HtmlLBS
body)
          else String
""
      ]

-- | 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 :: forall site.
HasCallStack =>
HeaderName -> ByteString -> YesodExample site ()
assertHeader HeaderName
header ByteString
value = (SResponse -> YesodExample site ()) -> YesodExample site ()
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse ((SResponse -> YesodExample site ()) -> YesodExample site ())
-> (SResponse -> YesodExample site ()) -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \ SResponse { simpleHeaders :: SResponse -> RequestHeaders
simpleHeaders = RequestHeaders
h } ->
  case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header RequestHeaders
h of
    Maybe ByteString
Nothing -> Text -> YesodExample site ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> YesodExample site ()) -> Text -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Expected header "
        , HeaderName -> String
forall a. Show a => a -> String
show HeaderName
header
        , String
" to be "
        , ByteString -> String
forall a. Show a => a -> String
show ByteString
value
        , String
", but it was not present"
        ]
    Just ByteString
value' -> IO () -> YesodExample site ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodExample site ()) -> IO () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ (String -> Bool -> IO ()) -> Bool -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool (ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
value') (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Expected header "
        , HeaderName -> String
forall a. Show a => a -> String
show HeaderName
header
        , String
" to be "
        , ByteString -> String
forall a. Show a => a -> String
show ByteString
value
        , String
", but received "
        , ByteString -> String
forall a. Show a => a -> String
show ByteString
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 :: forall site. HasCallStack => HeaderName -> YesodExample site ()
assertNoHeader HeaderName
header = (SResponse -> YesodExample site ()) -> YesodExample site ()
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse ((SResponse -> YesodExample site ()) -> YesodExample site ())
-> (SResponse -> YesodExample site ()) -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \ SResponse { simpleHeaders :: SResponse -> RequestHeaders
simpleHeaders = RequestHeaders
h } ->
  case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header RequestHeaders
h of
    Maybe ByteString
Nothing -> () -> YesodExample site ()
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just ByteString
s  -> Text -> YesodExample site ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> YesodExample site ()) -> Text -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Unexpected header "
        , HeaderName -> String
forall a. Show a => a -> String
show HeaderName
header
        , String
" containing "
        , ByteString -> String
forall a. Show a => a -> String
show ByteString
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 :: forall site. HasCallStack => String -> YesodExample site ()
bodyEquals String
text = (SResponse -> YesodExample site ()) -> YesodExample site ()
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse ((SResponse -> YesodExample site ()) -> YesodExample site ())
-> (SResponse -> YesodExample site ()) -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \ SResponse
res -> do
  let actual :: HtmlLBS
actual = SResponse -> HtmlLBS
simpleBody SResponse
res
      msg :: String
msg    = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Expected body to equal:\n\t"
                      , String
text String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                      , String
"Actual is:\n\t"
                      , Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> HtmlLBS -> Text
decodeUtf8With OnDecodeError
TErr.lenientDecode HtmlLBS
actual
                      ]
  IO () -> YesodExample site ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodExample site ()) -> IO () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool String
msg (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ HtmlLBS
actual HtmlLBS -> HtmlLBS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> HtmlLBS
encodeUtf8 (String -> Text
TL.pack String
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 :: forall site. HasCallStack => String -> YesodExample site ()
bodyContains String
text = (SResponse -> YesodExample site ()) -> YesodExample site ()
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse ((SResponse -> YesodExample site ()) -> YesodExample site ())
-> (SResponse -> YesodExample site ()) -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \ SResponse
res ->
  IO () -> YesodExample site ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodExample site ()) -> IO () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool (String
"Expected body to contain " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
text) (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
    (SResponse -> HtmlLBS
simpleBody SResponse
res) HtmlLBS -> String -> Bool
`contains` String
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 :: forall site. HasCallStack => String -> YesodExample site ()
bodyNotContains String
text = (SResponse -> YesodExample site ()) -> YesodExample site ()
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse ((SResponse -> YesodExample site ()) -> YesodExample site ())
-> (SResponse -> YesodExample site ()) -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \ SResponse
res ->
  IO () -> YesodExample site ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodExample site ()) -> IO () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool (String
"Expected body not to contain " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
text) (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
    Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HtmlLBS -> String -> Bool
contains (SResponse -> HtmlLBS
simpleBody SResponse
res) String
text

contains :: BSL8.ByteString -> String -> Bool
contains :: HtmlLBS -> String -> Bool
contains HtmlLBS
a String
b = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
DL.isInfixOf String
b (Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ HtmlLBS -> Text
decodeUtf8 HtmlLBS
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 :: forall site. HasCallStack => Text -> String -> YesodExample site ()
htmlAllContain Text
query String
search = do
  matches <- Text -> YesodExample site [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
  case matches of
    [] -> Text -> SIO (YesodExampleData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (YesodExampleData site) ())
-> Text -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ Text
"Nothing matched css query: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
query
    [HtmlLBS]
_ -> IO () -> SIO (YesodExampleData site) ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SIO (YesodExampleData site) ())
-> IO () -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool (String
"Not all "String -> String -> String
forall a. [a] -> [a] -> [a]
++Text -> String
T.unpack Text
queryString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" contain "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
search  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" matches: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [HtmlLBS] -> String
forall a. Show a => a -> String
show [HtmlLBS]
matches) (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
          (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
DL.all (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
DL.isInfixOf (String -> String
escape String
search)) ((HtmlLBS -> String) -> [HtmlLBS] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
TL.unpack (Text -> String) -> (HtmlLBS -> Text) -> HtmlLBS -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlLBS -> Text
decodeUtf8) [HtmlLBS]
matches)

-- | puts the search trough the same escaping as the matches are.
--   this helps with matching on special characters
escape :: String -> String
escape :: String -> String
escape = Markup -> String
Blaze.renderMarkup (Markup -> String) -> (String -> Markup) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Markup
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 :: forall site. HasCallStack => Text -> String -> YesodExample site ()
htmlAnyContain Text
query String
search = do
  matches <- Text -> YesodExample site [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
  case matches of
    [] -> Text -> SIO (YesodExampleData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (YesodExampleData site) ())
-> Text -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ Text
"Nothing matched css query: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
query
    [HtmlLBS]
_ -> IO () -> SIO (YesodExampleData site) ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SIO (YesodExampleData site) ())
-> IO () -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool (String
"None of "String -> String -> String
forall a. [a] -> [a] -> [a]
++Text -> String
T.unpack Text
queryString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" contain "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
search String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" matches: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [HtmlLBS] -> String
forall a. Show a => a -> String
show [HtmlLBS]
matches) (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
          (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
DL.any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
DL.isInfixOf (String -> String
escape String
search)) ((HtmlLBS -> String) -> [HtmlLBS] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
TL.unpack (Text -> String) -> (HtmlLBS -> Text) -> HtmlLBS -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlLBS -> Text
decodeUtf8) [HtmlLBS]
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 :: forall site. HasCallStack => Text -> String -> YesodExample site ()
htmlNoneContain Text
query String
search = do
  matches <- Text -> YesodExample site [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
  case DL.filter (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) of
    [] -> () -> SIO (YesodExampleData site) ()
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [String]
found -> Text -> SIO (YesodExampleData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (YesodExampleData site) ())
-> Text -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ Text
"Found " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
found) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                Text
" instances of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
search Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
query Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" 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 :: forall site. HasCallStack => Text -> Int -> YesodExample site ()
htmlCount Text
query Int
count = do
  matches <- ([HtmlLBS] -> Int)
-> SIO (YesodExampleData site) [HtmlLBS]
-> SIO (YesodExampleData site) Int
forall a b.
(a -> b)
-> SIO (YesodExampleData site) a -> SIO (YesodExampleData site) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [HtmlLBS] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
DL.length (SIO (YesodExampleData site) [HtmlLBS]
 -> SIO (YesodExampleData site) Int)
-> SIO (YesodExampleData site) [HtmlLBS]
-> SIO (YesodExampleData site) Int
forall a b. (a -> b) -> a -> b
$ Text -> SIO (YesodExampleData site) [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
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 :: forall a site. (HasCallStack, FromJSON a) => YesodExample site a
requireJSONResponse = do
  (SResponse -> YesodExample site a) -> YesodExample site a
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse ((SResponse -> YesodExample site a) -> YesodExample site a)
-> (SResponse -> YesodExample site a) -> YesodExample site a
forall a b. (a -> b) -> a -> b
$ \(SResponse Status
_status RequestHeaders
headers HtmlLBS
body) -> do
    let mContentType :: Maybe ByteString
mContentType = HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType RequestHeaders
headers
        isJSONContentType :: Bool
isJSONContentType = Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ByteString -> Bool
contentTypeHeaderIsJson Maybe ByteString
mContentType
    Bool
-> SIO (YesodExampleData site) () -> SIO (YesodExampleData site) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        Bool
isJSONContentType
        (Text -> SIO (YesodExampleData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (YesodExampleData site) ())
-> Text -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Expected `Content-Type: application/json` in the headers, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RequestHeaders -> String
forall a. Show a => a -> String
show RequestHeaders
headers)
    case HtmlLBS -> Either String a
forall a. FromJSON a => HtmlLBS -> Either String a
eitherDecode' HtmlLBS
body of
        Left String
err -> Text -> YesodExample site a
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> YesodExample site a) -> Text -> YesodExample site a
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Failed to parse JSON response; error: ", String -> Text
T.pack String
err, Text
"JSON: ", HtmlLBS -> Text
getBodyTextPreview HtmlLBS
body]
        Right a
v -> a -> YesodExample site a
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: forall site. YesodExample site ()
printBody = (SResponse -> YesodExample site ()) -> YesodExample site ()
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse ((SResponse -> YesodExample site ()) -> YesodExample site ())
-> (SResponse -> YesodExample site ()) -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \ SResponse { simpleBody :: SResponse -> HtmlLBS
simpleBody = HtmlLBS
b } ->
  IO () -> YesodExample site ()
forall a. IO a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodExample site ()) -> IO () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ Handle -> HtmlLBS -> IO ()
BSL8.hPutStrLn Handle
stderr HtmlLBS
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 :: forall site. HasCallStack => Text -> YesodExample site ()
printMatches Text
query = do
  matches <- Text -> YesodExample site [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
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 :: forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
name Text
value =
  (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
 -> SIO (RequestBuilderData site) ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
  where addPostData :: RBDPostData -> RBDPostData
addPostData (BinaryPostData HtmlLBS
_) = String -> RBDPostData
forall a. HasCallStack => String -> a
error String
"Trying to add post param to binary content."
        addPostData (MultipleItemsPostData [RequestPart]
posts) =
          [RequestPart] -> RBDPostData
MultipleItemsPostData ([RequestPart] -> RBDPostData) -> [RequestPart] -> RBDPostData
forall a b. (a -> b) -> a -> b
$ Text -> Text -> RequestPart
ReqKvPart Text
name Text
value RequestPart -> [RequestPart] -> [RequestPart]
forall a. a -> [a] -> [a]
: [RequestPart]
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 :: forall site. Text -> Text -> RequestBuilder site ()
addGetParam Text
name Text
value = (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
 -> SIO (RequestBuilderData site) ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
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 :: forall site. Text -> RequestBuilder site ()
addBareGetParam Text
name = (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
 -> SIO (RequestBuilderData site) ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd ->
    RequestBuilderData site
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 :: forall site. Text -> String -> Text -> RequestBuilder site ()
addFile Text
name String
path Text
mimetype = do
  contents <- IO HtmlLBS -> SIO (RequestBuilderData site) HtmlLBS
forall a. IO a -> SIO (RequestBuilderData site) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HtmlLBS -> SIO (RequestBuilderData site) HtmlLBS)
-> IO HtmlLBS -> SIO (RequestBuilderData site) HtmlLBS
forall a b. (a -> b) -> a -> b
$ String -> IO HtmlLBS
BSL8.readFile String
path
  modifySIO $ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
    where addPostData :: RBDPostData -> HtmlLBS -> RBDPostData
addPostData (BinaryPostData HtmlLBS
_) HtmlLBS
_ = String -> RBDPostData
forall a. HasCallStack => String -> a
error String
"Trying to add file after setting binary content."
          addPostData (MultipleItemsPostData [RequestPart]
posts) HtmlLBS
contents =
            [RequestPart] -> RBDPostData
MultipleItemsPostData ([RequestPart] -> RBDPostData) -> [RequestPart] -> RBDPostData
forall a b. (a -> b) -> a -> b
$ Text -> String -> HtmlLBS -> Text -> RequestPart
ReqFilePart Text
name String
path HtmlLBS
contents Text
mimetype RequestPart -> [RequestPart] -> [RequestPart]
forall a. a -> [a] -> [a]
: [RequestPart]
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 :: forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
match Text
label = do
  mres <- (RequestBuilderData site -> Maybe SResponse)
-> SIO (RequestBuilderData site) (RequestBuilderData site)
-> SIO (RequestBuilderData site) (Maybe SResponse)
forall a b.
(a -> b)
-> SIO (RequestBuilderData site) a
-> SIO (RequestBuilderData site) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RequestBuilderData site -> Maybe SResponse
forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse SIO (RequestBuilderData site) (RequestBuilderData site)
forall s. SIO s s
getSIO
  res <-
    case mres of
      Maybe SResponse
Nothing -> Text -> SIO (RequestBuilderData site) SResponse
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
"genericNameFromLabel: No response available"
      Just SResponse
res -> SResponse -> SIO (RequestBuilderData site) SResponse
forall a. a -> SIO (RequestBuilderData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return SResponse
res
  let body = SResponse -> HtmlLBS
simpleBody SResponse
res
  case genericNameFromHTML match label body of
    Left Text
e -> Text -> SIO (RequestBuilderData site) Text
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
e
    Right Text
x -> Text -> SIO (RequestBuilderData site) Text
forall a. a -> SIO (RequestBuilderData site) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
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 :: forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site Text
genericNameFromSelectorLabel Text -> Text -> Bool
match Text
selector Text
label = do
  body <- String -> RequestBuilder site HtmlLBS
forall site. String -> RequestBuilder site HtmlLBS
htmlBody String
"genericNameSelectorFromLabel"
  html <-
    case findBySelector body selector of
        Left String
parseError -> Text -> RequestBuilder site HtmlLBS
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site HtmlLBS)
-> Text -> RequestBuilder site HtmlLBS
forall a b. (a -> b) -> a -> b
$ Text
"genericNameFromSelectorLabel: Parse error" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
parseError
        Right [] -> Text -> RequestBuilder site HtmlLBS
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site HtmlLBS)
-> Text -> RequestBuilder site HtmlLBS
forall a b. (a -> b) -> a -> b
$ Text
"genericNameFromSelectorLabel: No fragments match selector " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
selector
        Right [String
matchingFragment] -> HtmlLBS -> RequestBuilder site HtmlLBS
forall a. a -> SIO (RequestBuilderData site) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HtmlLBS -> RequestBuilder site HtmlLBS)
-> HtmlLBS -> RequestBuilder site HtmlLBS
forall a b. (a -> b) -> a -> b
$ String -> HtmlLBS
BSL8.pack String
matchingFragment
        Right [String]
_matchingFragments -> Text -> RequestBuilder site HtmlLBS
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site HtmlLBS)
-> Text -> RequestBuilder site HtmlLBS
forall a b. (a -> b) -> a -> b
$ Text
"genericNameFromSelectorLabel: Multiple fragments match selector " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
selector
  case genericNameFromHTML match label html of
    Left Text
e -> Text -> SIO (RequestBuilderData site) Text
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
e
    Right Text
x -> Text -> SIO (RequestBuilderData site) Text
forall a. a -> SIO (RequestBuilderData site) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x

genericNameFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
genericNameFromHTML :: (Text -> Text -> Bool) -> Text -> HtmlLBS -> Either Text Text
genericNameFromHTML Text -> Text -> Bool
match Text
label HtmlLBS
html =
  let
    parsedHTML :: Cursor
parsedHTML = HtmlLBS -> Cursor
parseHTML HtmlLBS
html
    mlabel :: [Cursor]
mlabel = Cursor
parsedHTML
                Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Cursor -> [Cursor]
C.element Name
"label"
                (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Cursor -> [Cursor]
isContentMatch Text
label
    mfor :: [Text]
mfor = [Cursor]
mlabel [Cursor] -> (Cursor -> [Text]) -> [Text]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Cursor -> [Text]
attribute Name
"for"

    isContentMatch :: Text -> Cursor -> [Cursor]
isContentMatch Text
x Cursor
c
        | Text
x Text -> Text -> Bool
`match` [Text] -> Text
T.concat (Cursor
c Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Cursor -> [Text]
content) = [Cursor
c]
        | Bool
otherwise = []

  in case [Text]
mfor of
    Text
for:[] -> do
      let mname :: [Text]
mname = Cursor
parsedHTML
                    Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Text -> Cursor -> [Cursor]
attributeIs Name
"id" Text
for
                    (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"name"
      case [Text]
mname of
        Text
"":[Text]
_ -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
            [ Text
"Label "
            , Text
label
            , Text
" resolved to id "
            , Text
for
            , Text
" which was not found. "
            ]
        Text
name:[Text]
_ -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
name
        [] -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"No input with id " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
for
    [] ->
      case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Cursor]
mlabel [Cursor] -> (Cursor -> [Text]) -> [Text]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Cursor -> [Cursor]
forall node. Cursor node -> [Cursor node]
child (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Cursor]
C.element Name
"input" (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"name") of
        [] -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"No label contained: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label
        Text
name:[Text]
_ -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
name
    [Text]
_ -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"More than one label contained " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 :: forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
match Text
label Text
value = do
  name <- (Text -> Text -> Bool) -> Text -> RequestBuilder site Text
forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
match Text
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 :: forall site.
(Text -> Text -> Bool)
-> Text -> Text -> Text -> RequestBuilder site ()
bySelectorLabelWithMatch Text -> Text -> Bool
match Text
selector Text
label Text
value = do
  name <- (Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site Text
forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site Text
genericNameFromSelectorLabel Text -> Text -> Bool
match Text
selector Text
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 :: forall site. Text -> Text -> RequestBuilder site ()
byLabel = (Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
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 :: forall site. Text -> Text -> RequestBuilder site ()
byLabelExact = (Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- |
-- 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 :: forall site. Text -> Text -> RequestBuilder site ()
byLabelContain = (Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
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 :: forall site. Text -> Text -> RequestBuilder site ()
byLabelPrefix = (Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
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 :: forall site. Text -> Text -> RequestBuilder site ()
byLabelSuffix = (Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
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 :: forall site. Text -> Text -> Text -> RequestBuilder site ()
bySelectorLabelContain = (Text -> Text -> Bool)
-> Text -> Text -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool)
-> Text -> Text -> Text -> RequestBuilder site ()
bySelectorLabelWithMatch Text -> Text -> Bool
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 :: forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
match Text
label String
path Text
mime = do
  name <- (Text -> Text -> Bool) -> Text -> RequestBuilder site Text
forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
match Text
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 :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabel = (Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
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 :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabelExact = (Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- |
-- 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 :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabelContain = (Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
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 :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabelPrefix = (Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
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 :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabelSuffix = (Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
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_ :: forall site. HasCallStack => Text -> RequestBuilder site ()
addToken_ Text
scope = do
  matches <- (RequestBuilderData site -> Maybe SResponse)
-> [Text] -> Text -> SIO (RequestBuilderData site) [HtmlLBS]
forall state.
HasCallStack =>
(state -> Maybe SResponse) -> [Text] -> Text -> SIO state [HtmlLBS]
htmlQuery' RequestBuilderData site -> Maybe SResponse
forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse [Text
"Tried to get CSRF token with addToken'"] (Text -> SIO (RequestBuilderData site) [HtmlLBS])
-> Text -> SIO (RequestBuilderData site) [HtmlLBS]
forall a b. (a -> b) -> a -> b
$ Text
scope Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" input[name=_token][type=hidden][value]"
  case matches of
    [] -> Text -> SIO (RequestBuilderData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (RequestBuilderData site) ())
-> Text -> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ Text
"No CSRF token found in the current page"
    HtmlLBS
element:[] -> Text -> Text -> SIO (RequestBuilderData site) ()
forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
"_token" (Text -> SIO (RequestBuilderData site) ())
-> Text -> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. HasCallStack => [a] -> a
head ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"value" (Cursor -> [Text]) -> Cursor -> [Text]
forall a b. (a -> b) -> a -> b
$ HtmlLBS -> Cursor
parseHTML HtmlLBS
element
    [HtmlLBS]
_ -> Text -> SIO (RequestBuilderData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (RequestBuilderData site) ())
-> Text -> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ Text
"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 :: forall site. HasCallStack => RequestBuilder site ()
addToken = Text -> RequestBuilder site ()
forall site. HasCallStack => Text -> RequestBuilder site ()
addToken_ Text
""

-- | 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 :: forall site. HasCallStack => RequestBuilder site ()
addTokenFromCookie = ByteString -> HeaderName -> RequestBuilder site ()
forall site.
HasCallStack =>
ByteString -> HeaderName -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed ByteString
defaultCsrfCookieName HeaderName
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 :: forall site.
HasCallStack =>
ByteString -> HeaderName -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed ByteString
cookieName HeaderName
headerName = do
  cookies <- RequestBuilder site Cookies
forall site. HasCallStack => RequestBuilder site Cookies
getRequestCookies
  case M.lookup cookieName cookies of
        Just SetCookie
csrfCookie -> (HeaderName, ByteString) -> SIO (RequestBuilderData site) ()
forall site. (HeaderName, ByteString) -> RequestBuilder site ()
addRequestHeader (HeaderName
headerName, SetCookie -> ByteString
Cookie.setCookieValue SetCookie
csrfCookie)
        Maybe SetCookie
Nothing -> Text -> SIO (RequestBuilderData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (RequestBuilderData site) ())
-> Text -> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
          [ Text
"addTokenFromCookieNamedToHeaderNamed failed to lookup CSRF cookie with name: "
          , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
cookieName
          , Text
". Cookies were: "
          , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Cookies -> String
forall a. Show a => a -> String
show Cookies
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 :: forall site. HasCallStack => RequestBuilder site Cookies
getRequestCookies = do
  requestBuilderData <- SIO (RequestBuilderData site) (RequestBuilderData site)
forall s. SIO s s
getSIO
  headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
                  Just RequestHeaders
h -> RequestHeaders -> SIO (RequestBuilderData site) RequestHeaders
forall a. a -> SIO (RequestBuilderData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return RequestHeaders
h
                  Maybe RequestHeaders
Nothing -> Text -> SIO (RequestBuilderData site) RequestHeaders
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
"getRequestCookies: No request has been made yet; the cookies can't be looked up."

  return $ M.fromList $ map (\SetCookie
c -> (SetCookie -> ByteString
Cookie.setCookieName SetCookie
c, SetCookie
c)) (parseSetCookies headers)


-- | Perform a POST request to @url@.
--
-- ==== __Examples__
--
-- > post HomeR
post :: (Yesod site, RedirectUrl site url)
     => url
     -> YesodExample site ()
post :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
post = ByteString -> url -> YesodExample site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
ByteString -> url -> YesodExample site ()
performMethod ByteString
"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 :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> HtmlLBS -> YesodExample site ()
postBody url
url HtmlLBS
body = RequestBuilder site () -> YesodExample site ()
forall site. RequestBuilder site () -> YesodExample site ()
request (RequestBuilder site () -> YesodExample site ())
-> RequestBuilder site () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ do
  ByteString -> RequestBuilder site ()
forall site. ByteString -> RequestBuilder site ()
setMethod ByteString
"POST"
  url -> RequestBuilder site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> RequestBuilder site ()
setUrl url
url
  HtmlLBS -> RequestBuilder site ()
forall site. HtmlLBS -> RequestBuilder site ()
setRequestBody HtmlLBS
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 :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
get = ByteString -> url -> YesodExample site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
ByteString -> url -> YesodExample site ()
performMethod ByteString
"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 :: forall site url.
(Yesod site, RedirectUrl site url) =>
ByteString -> url -> YesodExample site ()
performMethod ByteString
method url
url = RequestBuilder site () -> YesodExample site ()
forall site. RequestBuilder site () -> YesodExample site ()
request (RequestBuilder site () -> YesodExample site ())
-> RequestBuilder site () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ do
  ByteString -> RequestBuilder site ()
forall site. ByteString -> RequestBuilder site ()
setMethod ByteString
method
  url -> RequestBuilder site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> RequestBuilder site ()
setUrl url
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 :: forall site. Yesod site => YesodExample site (Either Text Text)
followRedirect = do
  mr <- YesodExample site (Maybe SResponse)
forall site. YesodExample site (Maybe SResponse)
getResponse
  case mr of
   Maybe SResponse
Nothing ->  Either Text Text -> SIO (YesodExampleData site) (Either Text Text)
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text
 -> SIO (YesodExampleData site) (Either Text Text))
-> Either Text Text
-> SIO (YesodExampleData site) (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"followRedirect called, but there was no previous response, so no redirect to follow"
   Just SResponse
r -> do
     if Bool -> Bool
not ((Status -> Int
H.statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ SResponse -> Status
simpleStatus SResponse
r) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
301, Int
302, Int
303, Int
307, Int
308])
       then Either Text Text -> SIO (YesodExampleData site) (Either Text Text)
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text
 -> SIO (YesodExampleData site) (Either Text Text))
-> Either Text Text
-> SIO (YesodExampleData site) (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"followRedirect called, but previous request was not a redirect"
       else do
         case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" (SResponse -> RequestHeaders
simpleHeaders SResponse
r) of
          Maybe ByteString
Nothing -> Either Text Text -> SIO (YesodExampleData site) (Either Text Text)
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text
 -> SIO (YesodExampleData site) (Either Text Text))
-> Either Text Text
-> SIO (YesodExampleData site) (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"followRedirect called, but no location header set"
          Just ByteString
h -> let url :: Text
url = ByteString -> Text
TE.decodeUtf8 ByteString
h in
                     Text -> YesodExample site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
get Text
url  YesodExample site ()
-> SIO (YesodExampleData site) (Either Text Text)
-> SIO (YesodExampleData site) (Either Text Text)
forall a b.
SIO (YesodExampleData site) a
-> SIO (YesodExampleData site) b -> SIO (YesodExampleData site) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Text Text -> SIO (YesodExampleData site) (Either Text Text)
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
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 :: forall site.
ParseRoute site =>
YesodExample site (Either Text (Route site))
getLocation = do
  mr <- YesodExample site (Maybe SResponse)
forall site. YesodExample site (Maybe SResponse)
getResponse
  case mr of
    Maybe SResponse
Nothing -> Either Text (Route site)
-> SIO (YesodExampleData site) (Either Text (Route site))
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Route site)
 -> SIO (YesodExampleData site) (Either Text (Route site)))
-> Either Text (Route site)
-> SIO (YesodExampleData site) (Either Text (Route site))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Route site)
forall a b. a -> Either a b
Left Text
"getLocation called, but there was no previous response, so no Location header"
    Just SResponse
r -> case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" (SResponse -> RequestHeaders
simpleHeaders SResponse
r) of
      Maybe ByteString
Nothing -> Either Text (Route site)
-> SIO (YesodExampleData site) (Either Text (Route site))
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Route site)
 -> SIO (YesodExampleData site) (Either Text (Route site)))
-> Either Text (Route site)
-> SIO (YesodExampleData site) (Either Text (Route site))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Route site)
forall a b. a -> Either a b
Left Text
"getLocation called, but the previous response has no Location header"
      Just ByteString
h -> case ([Text], [(Text, Text)]) -> Maybe (Route site)
forall a.
ParseRoute a =>
([Text], [(Text, Text)]) -> Maybe (Route a)
parseRoute (([Text], [(Text, Text)]) -> Maybe (Route site))
-> ([Text], [(Text, Text)]) -> Maybe (Route site)
forall a b. (a -> b) -> a -> b
$ ByteString -> ([Text], [(Text, Text)])
decodePath ByteString
h of
        Maybe (Route site)
Nothing -> Either Text (Route site)
-> SIO (YesodExampleData site) (Either Text (Route site))
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Route site)
 -> SIO (YesodExampleData site) (Either Text (Route site)))
-> Either Text (Route site)
-> SIO (YesodExampleData site) (Either Text (Route site))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Route site)
forall a b. a -> Either a b
Left Text
"getLocation called, but couldn’t parse it into a route"
        Just Route site
l -> Either Text (Route site)
-> SIO (YesodExampleData site) (Either Text (Route site))
forall a. a -> SIO (YesodExampleData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Route site)
 -> SIO (YesodExampleData site) (Either Text (Route site)))
-> Either Text (Route site)
-> SIO (YesodExampleData site) (Either Text (Route site))
forall a b. (a -> b) -> a -> b
$ Route site -> Either Text (Route site)
forall a b. b -> Either a b
Right Route site
l
  where decodePath :: ByteString -> ([Text], [(Text, Text)])
decodePath ByteString
b = let (ByteString
x, ByteString
y) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'?') ByteString
b
                       in (ByteString -> [Text]
H.decodePathSegments ByteString
x, (Text, Maybe Text) -> (Text, Text)
forall {b} {a}. Monoid b => (a, Maybe b) -> (a, b)
unJust ((Text, Maybe Text) -> (Text, Text))
-> [(Text, Maybe Text)] -> [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [(Text, Maybe Text)]
H.parseQueryText ByteString
y)
        unJust :: (a, Maybe b) -> (a, b)
unJust (a
a, Just b
b) = (a
a, b
b)
        unJust (a
a, Maybe b
Nothing) = (a
a, b
forall a. Monoid a => 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 :: forall site. ByteString -> RequestBuilder site ()
setMethod ByteString
m = (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
 -> SIO (RequestBuilderData site) ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
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 :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> RequestBuilder site ()
setUrl url
url' = do
    site <- (RequestBuilderData site -> site)
-> SIO (RequestBuilderData site) (RequestBuilderData site)
-> SIO (RequestBuilderData site) site
forall a b.
(a -> b)
-> SIO (RequestBuilderData site) a
-> SIO (RequestBuilderData site) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RequestBuilderData site -> site
forall site. RequestBuilderData site -> site
rbdSite SIO (RequestBuilderData site) (RequestBuilderData site)
forall s. SIO s s
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 $ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd
        { rbdPath =
            case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
                (Text
"http:":Text
_:[Text]
rest) -> [Text]
rest
                (Text
"https:":Text
_:[Text]
rest) -> [Text]
rest
                [Text]
x -> [Text]
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 :: forall site.
(HasCallStack, Yesod site) =>
Text -> YesodExample site ()
clickOn Text
query = do
  (YesodExampleData site -> Maybe SResponse)
-> [Text]
-> (SResponse -> SIO (YesodExampleData site) ())
-> SIO (YesodExampleData site) ()
forall state a.
HasCallStack =>
(state -> Maybe SResponse)
-> [Text] -> (SResponse -> SIO state a) -> SIO state a
withResponse' YesodExampleData site -> Maybe SResponse
forall site. YesodExampleData site -> Maybe SResponse
yedResponse [Text
"Tried to invoke clickOn in order to read HTML of a previous response."] ((SResponse -> SIO (YesodExampleData site) ())
 -> SIO (YesodExampleData site) ())
-> (SResponse -> SIO (YesodExampleData site) ())
-> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ \ SResponse
res ->
    case HtmlLBS -> Text -> Text -> Either String [[Text]]
findAttributeBySelector (SResponse -> HtmlLBS
simpleBody SResponse
res) Text
query Text
"href" of
      Left String
err -> Text -> SIO (YesodExampleData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (YesodExampleData site) ())
-> Text -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ Text
query Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" did not parse: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
err)
      Right [[Text
match]] -> Text -> SIO (YesodExampleData site) ()
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
get Text
match
      Right [[Text]]
matches -> Text -> SIO (YesodExampleData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (YesodExampleData site) ())
-> Text -> SIO (YesodExampleData site) ()
forall a b. (a -> b) -> a -> b
$ Text
"Expected exactly one match for clickOn: got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([[Text]] -> String
forall a. Show a => a -> String
show [[Text]]
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 :: forall site. HtmlLBS -> RequestBuilder site ()
setRequestBody HtmlLBS
body = (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
 -> SIO (RequestBuilderData site) ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
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 :: forall site. (HeaderName, ByteString) -> RequestBuilder site ()
addRequestHeader (HeaderName, ByteString)
header = (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
 -> SIO (RequestBuilderData site) ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
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 :: forall site. HeaderName -> HeaderName -> RequestBuilder site ()
addBasicAuthHeader HeaderName
username HeaderName
password =
  let credentials :: ByteString
credentials = Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
CI.original (HeaderName -> ByteString) -> HeaderName -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName
username HeaderName -> HeaderName -> HeaderName
forall a. Semigroup a => a -> a -> a
<> HeaderName
":" HeaderName -> HeaderName -> HeaderName
forall a. Semigroup a => a -> a -> a
<> HeaderName
password
  in (HeaderName, ByteString) -> RequestBuilder site ()
forall site. (HeaderName, ByteString) -> RequestBuilder site ()
addRequestHeader (HeaderName
"Authorization", ByteString
"Basic " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
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 :: forall site. RequestBuilder site () -> YesodExample site ()
request RequestBuilder site ()
reqBuilder = do
    YesodExampleData app site oldCookies mRes <- SIO (YesodExampleData site) (YesodExampleData site)
forall s. SIO s s
getSIO

    RequestBuilderData {..} <- liftIO $ execSIO reqBuilder RequestBuilderData
      { rbdPostData = MultipleItemsPostData []
      , rbdResponse = mRes
      , rbdMethod = "GET"
      , rbdSite = site
      , rbdPath = []
      , rbdGets = []
      , rbdHeaders = []
      }
    let path
            | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rbdPath = Text
"/"
            | Bool
otherwise = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Builder
H.encodePathSegments [Text]
rbdPath

    -- expire cookies and filter them for the current path. TODO: support max age
    currentUtc <- liftIO getCurrentTime
    let cookies = (SetCookie -> Bool) -> Cookies -> Cookies
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (UTCTime -> SetCookie -> Bool
checkCookieTime UTCTime
currentUtc) Cookies
oldCookies
        cookiesForPath = (SetCookie -> Bool) -> Cookies -> Cookies
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Text -> SetCookie -> Bool
checkCookiePath Text
path) Cookies
cookies

    let req = case RBDPostData
rbdPostData of
          MultipleItemsPostData [RequestPart]
x ->
            if (RequestPart -> Bool) -> [RequestPart] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
DL.any RequestPart -> Bool
isFile [RequestPart]
x
            then ([RequestPart] -> SRequest
multipart [RequestPart]
x)
            else SRequest
singlepart
          BinaryPostData HtmlLBS
_ -> SRequest
singlepart
          where singlepart :: SRequest
singlepart = Cookies
-> RBDPostData
-> ByteString
-> RequestHeaders
-> Text
-> Query
-> SRequest
forall a0.
Map a0 SetCookie
-> RBDPostData
-> ByteString
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeSinglepart Cookies
cookiesForPath RBDPostData
rbdPostData ByteString
rbdMethod RequestHeaders
rbdHeaders Text
path Query
rbdGets
                multipart :: [RequestPart] -> SRequest
multipart [RequestPart]
x = Cookies
-> [RequestPart]
-> ByteString
-> RequestHeaders
-> Text
-> Query
-> SRequest
forall a0.
Map a0 SetCookie
-> [RequestPart]
-> ByteString
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeMultipart Cookies
cookiesForPath [RequestPart]
x ByteString
rbdMethod RequestHeaders
rbdHeaders Text
path Query
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 = RequestHeaders -> [SetCookie]
parseSetCookies (RequestHeaders -> [SetCookie]) -> RequestHeaders -> [SetCookie]
forall a b. (a -> b) -> a -> b
$ SResponse -> RequestHeaders
simpleHeaders SResponse
response
        cookies' = [(ByteString, SetCookie)] -> Cookies
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(SetCookie -> ByteString
Cookie.setCookieName SetCookie
c, SetCookie
c) | SetCookie
c <- [SetCookie]
newCookies] Cookies -> Cookies -> Cookies
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Cookies
cookies
    putSIO $ YesodExampleData app site cookies' (Just response)
  where
    isFile :: RequestPart -> Bool
isFile (ReqFilePart Text
_ String
_ HtmlLBS
_ Text
_) = Bool
True
    isFile RequestPart
_ = Bool
False

    checkCookieTime :: UTCTime -> SetCookie -> Bool
checkCookieTime UTCTime
t SetCookie
c = case SetCookie -> Maybe UTCTime
Cookie.setCookieExpires SetCookie
c of
                              Maybe UTCTime
Nothing -> Bool
True
                              Just UTCTime
t' -> UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
t'
    checkCookiePath :: Text -> SetCookie -> Bool
checkCookiePath Text
url SetCookie
c =
      case SetCookie -> Maybe ByteString
Cookie.setCookiePath SetCookie
c of
        Maybe ByteString
Nothing -> Bool
True
        Just ByteString
x  -> ByteString
x ByteString -> ByteString -> Bool
`BS8.isPrefixOf` Text -> ByteString
TE.encodeUtf8 Text
url

    -- For building the multi-part requests
    boundary :: String
    boundary :: String
boundary = String
"*******noneedtomakethisrandom"
    separator :: ByteString
separator = [ByteString] -> ByteString
BS8.concat [ByteString
"--", String -> ByteString
BS8.pack String
boundary, ByteString
"\r\n"]
    makeMultipart :: M.Map a0 Cookie.SetCookie
                  -> [RequestPart]
                  -> H.Method
                  -> [H.Header]
                  -> T.Text
                  -> H.Query
                  -> SRequest
    makeMultipart :: forall a0.
Map a0 SetCookie
-> [RequestPart]
-> ByteString
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeMultipart Map a0 SetCookie
cookies [RequestPart]
parts ByteString
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery =
      Request -> HtmlLBS -> SRequest
SRequest Request
simpleRequest' ([RequestPart] -> HtmlLBS
simpleRequestBody' [RequestPart]
parts)
      where simpleRequestBody' :: [RequestPart] -> HtmlLBS
simpleRequestBody' [RequestPart]
x =
              [ByteString] -> HtmlLBS
BSL8.fromChunks [[RequestPart] -> ByteString
multiPartBody [RequestPart]
x]
            simpleRequest' :: Request
simpleRequest' = RequestHeaders
-> ByteString -> RequestHeaders -> Text -> Query -> Request
mkRequest
                             [ (HeaderName
"Cookie", ByteString
cookieValue)
                             , (HeaderName
"Content-Type", ByteString
contentTypeValue)]
                             ByteString
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery
            cookieValue :: ByteString
cookieValue = Builder -> ByteString
Builder.toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Cookies -> Builder
Cookie.renderCookies Cookies
cookiePairs
            cookiePairs :: Cookies
cookiePairs = [ (SetCookie -> ByteString
Cookie.setCookieName SetCookie
c, SetCookie -> ByteString
Cookie.setCookieValue SetCookie
c)
                          | SetCookie
c <- ((a0, SetCookie) -> SetCookie) -> [(a0, SetCookie)] -> [SetCookie]
forall a b. (a -> b) -> [a] -> [b]
map (a0, SetCookie) -> SetCookie
forall a b. (a, b) -> b
snd ([(a0, SetCookie)] -> [SetCookie])
-> [(a0, SetCookie)] -> [SetCookie]
forall a b. (a -> b) -> a -> b
$ Map a0 SetCookie -> [(a0, SetCookie)]
forall k a. Map k a -> [(k, a)]
M.toList Map a0 SetCookie
cookies ]
            contentTypeValue :: ByteString
contentTypeValue = String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"multipart/form-data; boundary=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
boundary
    multiPartBody :: [RequestPart] -> ByteString
multiPartBody [RequestPart]
parts =
      [ByteString] -> ByteString
BS8.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
separator ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [[ByteString] -> ByteString
BS8.concat [RequestPart -> ByteString
multipartPart RequestPart
p, ByteString
separator] | RequestPart
p <- [RequestPart]
parts]
    multipartPart :: RequestPart -> ByteString
multipartPart (ReqKvPart Text
k Text
v) = [ByteString] -> ByteString
BS8.concat
      [ ByteString
"Content-Disposition: form-data; "
      , ByteString
"name=\"", Text -> ByteString
TE.encodeUtf8 Text
k, ByteString
"\"\r\n\r\n"
      , Text -> ByteString
TE.encodeUtf8 Text
v, ByteString
"\r\n"]
    multipartPart (ReqFilePart Text
k String
v HtmlLBS
bytes Text
mime) = [ByteString] -> ByteString
BS8.concat
      [ ByteString
"Content-Disposition: form-data; "
      , ByteString
"name=\"", Text -> ByteString
TE.encodeUtf8 Text
k, ByteString
"\"; "
      , ByteString
"filename=\"", String -> ByteString
BS8.pack String
v, ByteString
"\"\r\n"
      , ByteString
"Content-Type: ", Text -> ByteString
TE.encodeUtf8 Text
mime, ByteString
"\r\n\r\n"
      , [ByteString] -> ByteString
BS8.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ HtmlLBS -> [ByteString]
BSL8.toChunks HtmlLBS
bytes, ByteString
"\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 :: forall a0.
Map a0 SetCookie
-> RBDPostData
-> ByteString
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeSinglepart Map a0 SetCookie
cookies RBDPostData
rbdPostData ByteString
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery =
      Request -> HtmlLBS -> SRequest
SRequest Request
simpleRequest' (RBDPostData -> HtmlLBS
simpleRequestBody' RBDPostData
rbdPostData)
      where
        simpleRequest' :: Request
simpleRequest' = (RequestHeaders
-> ByteString -> RequestHeaders -> Text -> Query -> Request
mkRequest
                          ([ (HeaderName
"Cookie", ByteString
cookieValue) ] RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RBDPostData -> RequestHeaders
forall {a} {b}. (IsString a, IsString b) => RBDPostData -> [(a, b)]
headersForPostData RBDPostData
rbdPostData)
                          ByteString
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery)
        simpleRequestBody' :: RBDPostData -> HtmlLBS
simpleRequestBody' (MultipleItemsPostData [RequestPart]
x) =
          [ByteString] -> HtmlLBS
BSL8.fromChunks ([ByteString] -> HtmlLBS) -> [ByteString] -> HtmlLBS
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Bool -> Cookies -> ByteString
H.renderSimpleQuery Bool
False
          (Cookies -> ByteString) -> Cookies -> ByteString
forall a b. (a -> b) -> a -> b
$ (RequestPart -> Cookies) -> [RequestPart] -> Cookies
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RequestPart -> Cookies
singlepartPart [RequestPart]
x
        simpleRequestBody' (BinaryPostData HtmlLBS
x) = HtmlLBS
x
        cookieValue :: ByteString
cookieValue = Builder -> ByteString
Builder.toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Cookies -> Builder
Cookie.renderCookies Cookies
cookiePairs
        cookiePairs :: Cookies
cookiePairs = [ (SetCookie -> ByteString
Cookie.setCookieName SetCookie
c, SetCookie -> ByteString
Cookie.setCookieValue SetCookie
c)
                      | SetCookie
c <- ((a0, SetCookie) -> SetCookie) -> [(a0, SetCookie)] -> [SetCookie]
forall a b. (a -> b) -> [a] -> [b]
map (a0, SetCookie) -> SetCookie
forall a b. (a, b) -> b
snd ([(a0, SetCookie)] -> [SetCookie])
-> [(a0, SetCookie)] -> [SetCookie]
forall a b. (a -> b) -> a -> b
$ Map a0 SetCookie -> [(a0, SetCookie)]
forall k a. Map k a -> [(k, a)]
M.toList Map a0 SetCookie
cookies ]
        singlepartPart :: RequestPart -> Cookies
singlepartPart (ReqFilePart Text
_ String
_ HtmlLBS
_ Text
_) = []
        singlepartPart (ReqKvPart Text
k Text
v) = [(Text -> ByteString
TE.encodeUtf8 Text
k, Text -> ByteString
TE.encodeUtf8 Text
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 :: RBDPostData -> [(a, b)]
headersForPostData (MultipleItemsPostData []) = []
        headersForPostData (MultipleItemsPostData [RequestPart]
_ ) = [(a
"Content-Type", b
"application/x-www-form-urlencoded")]
        headersForPostData (BinaryPostData HtmlLBS
_ ) = []


    -- General request making
    mkRequest :: RequestHeaders
-> ByteString -> RequestHeaders -> Text -> Query -> Request
mkRequest RequestHeaders
headers ByteString
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery = Request
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 :: RequestHeaders -> [SetCookie]
parseSetCookies RequestHeaders
headers = ((HeaderName, ByteString) -> SetCookie)
-> RequestHeaders -> [SetCookie]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> SetCookie
Cookie.parseSetCookie (ByteString -> SetCookie)
-> ((HeaderName, ByteString) -> ByteString)
-> (HeaderName, ByteString)
-> SetCookie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) (RequestHeaders -> [SetCookie]) -> RequestHeaders -> [SetCookie]
forall a b. (a -> b) -> a -> b
$ ((HeaderName, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
DL.filter ((HeaderName
"Set-Cookie"HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
==) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders
headers

-- Yes, just a shortcut
failure :: (HasCallStack, MonadIO a) => T.Text -> a b
failure :: forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
reason = (IO (ZonkAny 0) -> a (ZonkAny 0)
forall a. IO a -> a a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ZonkAny 0) -> a (ZonkAny 0))
-> IO (ZonkAny 0) -> a (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ String -> IO (ZonkAny 0)
forall a. HasCallStack => String -> IO a
HUnit.assertFailure (String -> IO (ZonkAny 0)) -> String -> IO (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
reason) a (ZonkAny 0) -> a b -> a b
forall a b. a a -> a b -> a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> a b
forall a. HasCallStack => String -> a
error String
""

type TestApp site = (site, Middleware)
testApp :: site -> Middleware -> TestApp site
testApp :: forall site. site -> Middleware -> TestApp site
testApp site
site Middleware
middleware = (site
site, Middleware
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 :: SIO (YesodExampleData site) a
-> Params
-> (ActionWith (Arg (SIO (YesodExampleData site) a)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample SIO (YesodExampleData site) a
example Params
params ActionWith (Arg (SIO (YesodExampleData site) a)) -> IO ()
action =
        IO ()
-> Params
-> (ActionWith (Arg (IO ())) -> IO ())
-> ProgressCallback
-> IO Result
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
Hspec.evaluateExample
            (ActionWith (Arg (SIO (YesodExampleData site) a)) -> IO ()
action (ActionWith (Arg (SIO (YesodExampleData site) a)) -> IO ())
-> ActionWith (Arg (SIO (YesodExampleData site) a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(site
site, Middleware
middleware) -> do
                app <- site -> IO Application
forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
site
                _ <- evalSIO example YesodExampleData
                    { yedApp = middleware app
                    , yedSite = site
                    , yedCookies = M.empty
                    , yedResponse = Nothing
                    }
                return ())
            Params
params
            ((() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ ())

-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then make this input checked.
-- It is assumed the @\<input>@ has @type=radio@.
--
-- ==== __Examples__
--
-- Given this HTML, we want to submit @f1=2@ (i.e. radio button with "Blue" label) to the server:
--
-- > <form method="POST">
-- >   <label for="hident2">Color</label>
-- >   <div id="hident2">
-- >     <div class="radio">
-- >       <input id="hident2-none" type="radio" name="f1" value="none" checked>
-- >       <label for="hident2-none">&lt;None&gt;</label>
-- >     </div>
-- >     <div class="radio">
-- >       <input id="hident2-1" type="radio" name="f1" value="1">
-- >       <label for="hident2-1">Red</label>
-- >     </div>
-- >     <div class="radio">
-- >       <input id="hident2-2" type="radio" name="f1" value="2">
-- >       <label for="hident2-2">Blue</label>
-- >     </div>
-- >     <div class="radio">
-- >       <input id="hident2-3" type="radio" name="f1" value="3">
-- >       <label for="hident2-3">Gray</label>
-- >     </div>
-- >     <div class="radio">
-- >       <input id="hident2-4" type="radio" name="f1" value="4">
-- >       <label for="hident2-4">Black</label>
-- >     </div>
-- >   </div>
-- > </form>
--
-- You can set this parameter like so:
--
-- > request $ do
-- >   chooseByLabel "Blue"
--
-- @since 1.6.17
chooseByLabel :: T.Text -> RequestBuilder site ()
chooseByLabel :: forall site. Text -> RequestBuilder site ()
chooseByLabel Text
label = do
    name <- (Text -> Text -> Bool) -> Text -> RequestBuilder site Text
forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
label
    value <- genericValueFromLabel (==) label
    addPostParam name value

-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then make this input checked.
-- It is assumed the @\<input>@ has @type=checkbox@.
--
-- ==== __Examples__
--
-- Given this HTML, we want to submit @f1=2@ and @f1=4@ (i.e. checked checkboxes are "Blue" and "Black") to the server:
--
-- > <form method="POST">
-- >   <label for="hident2">Colors</label>
-- >   <span id="hident2">
-- >     <input id="hident2-1" type="checkbox" name="f1" value="1">
-- >     <label for="hident2-1">Red</label>
-- >     <input id="hident2-2" type="checkbox" name="f1" value="2" checked>
-- >     <label for="hident2-2">Blue</label>
-- >     <input id="hident2-3" type="checkbox" name="f1" value="3">
-- >     <label for="hident2-3">Gray</label>
-- >     <input id="hident2-4" type="checkbox" name="f1" value="4" checked>
-- >     <label for="hident2-4">Black</label>
-- >   </span>
-- > </form>
--
-- You can set this parameter like so:
--
-- > request $ do
-- >   checkByLabel "Blue"
-- >   checkByLabel "Black"
--
-- @since 1.6.18
checkByLabel :: T.Text -> RequestBuilder site ()
checkByLabel :: forall site. Text -> RequestBuilder site ()
checkByLabel Text
label = do
    name <- (Text -> Text -> Bool) -> Text -> RequestBuilder site Text
forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
label
    value <- genericValueFromLabel (==) label
    addPostParam name value

-- | Finds the @\<label>@ with the given value, finds its corresponding @\<select>@,
-- then finds corresponding @\<option>@ and make this options selected.
--
-- ==== __Examples__
--
-- Given this HTML, we want to submit @f1=2@ (i.e. selected option is "Blue") to the server:
--
-- > <form method="post" action="labels-select">
-- >   <label for="hident2">Selection List</label>
-- >   <select id="hident2" name="f1">
-- >     <option value="1">Red</option>
-- >     <option value="2">Blue</option>
-- >     <option value="3">Gray</option>
-- >     <option value="4">Black</option>
-- >   </select>
-- > </form>
--
-- You can set this parameter like so:
--
-- > request $ do
-- >   setMethod "POST"
-- >   selectByLabel "Selection List" "Blue"
--
-- @since 1.6.19
selectByLabel :: T.Text -> T.Text -> RequestBuilder site ()
selectByLabel :: forall site. Text -> Text -> RequestBuilder site ()
selectByLabel Text
label Text
option = do
    name <- (Text -> Text -> Bool) -> Text -> RequestBuilder site Text
forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
label
    parsedHtml <- parseHTML <$> htmlBody "selectByLabel"
    let values = Cursor
parsedHtml Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Cursor -> [Cursor]
C.element Name
"select"
                            (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Text -> Cursor -> [Cursor]
attributeIs Name
"name" Text
name
                            (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Cursor -> [Cursor]
C.element Name
"option"
                            (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Cursor -> [Cursor]
isContentMatch Text
option
                            (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"value"
    case values of
      [] -> Text -> SIO (RequestBuilderData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (RequestBuilderData site) ())
-> Text -> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"selectByLabel: option '" , Text
option, Text
"' not found in select '", Text
label, Text
"'"]
      [Text
value] -> Text -> Text -> SIO (RequestBuilderData site) ()
forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
name Text
value
      [Text]
_ -> Text -> SIO (RequestBuilderData site) ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (RequestBuilderData site) ())
-> Text -> SIO (RequestBuilderData site) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"selectByLabel: too many options '", Text
option, Text
"' found in select '", Text
label, Text
"'"]
    where isContentMatch :: Text -> Cursor -> [Cursor]
isContentMatch Text
x Cursor
c
              | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Text
T.concat (Cursor
c Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Cursor -> [Text]
content) = [Cursor
c]
              | Bool
otherwise = []

-- |
-- This looks up the value of a field based on the contents of the label pointing to it.
genericValueFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericValueFromLabel :: forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericValueFromLabel Text -> Text -> Bool
match Text
label = do
  body <- String -> RequestBuilder site HtmlLBS
forall site. String -> RequestBuilder site HtmlLBS
htmlBody String
"genericValueFromLabel"
  case genericValueFromHTML match label body of
    Left Text
e -> Text -> SIO (RequestBuilderData site) Text
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
e
    Right Text
x -> Text -> SIO (RequestBuilderData site) Text
forall a. a -> SIO (RequestBuilderData site) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x

genericValueFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
genericValueFromHTML :: (Text -> Text -> Bool) -> Text -> HtmlLBS -> Either Text Text
genericValueFromHTML Text -> Text -> Bool
match Text
label HtmlLBS
html =
  let
    parsedHTML :: Cursor
parsedHTML = HtmlLBS -> Cursor
parseHTML HtmlLBS
html
    mlabel :: [Cursor]
mlabel = Cursor
parsedHTML
                Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Cursor -> [Cursor]
C.element Name
"label"
                (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Cursor -> [Cursor]
isContentMatch Text
label
    mfor :: [Text]
mfor = [Cursor]
mlabel [Cursor] -> (Cursor -> [Text]) -> [Text]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Cursor -> [Text]
attribute Name
"for"

    isContentMatch :: Text -> Cursor -> [Cursor]
isContentMatch Text
x Cursor
c
        | Text
x Text -> Text -> Bool
`match` [Text] -> Text
T.concat (Cursor
c Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Cursor -> [Text]
content) = [Cursor
c]
        | Bool
otherwise = []

  in case [Text]
mfor of
    Text
for:[] -> do
      let mvalue :: [Text]
mvalue = Cursor
parsedHTML
                    Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Text -> Cursor -> [Cursor]
attributeIs Name
"id" Text
for
                    (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"value"
      case [Text]
mvalue of
        Text
"":[Text]
_ -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
            [ Text
"Label "
            , Text
label
            , Text
" resolved to id "
            , Text
for
            , Text
" which was not found. "
            ]
        Text
value:[Text]
_ -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
value
        [] -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"No input with id " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
for
    [] ->
      case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Cursor]
mlabel [Cursor] -> (Cursor -> [Text]) -> [Text]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Cursor -> [Cursor]
forall node. Cursor node -> [Cursor node]
child (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Cursor]
C.element Name
"input" (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"value") of
        [] -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"No label contained: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label
        Text
value:[Text]
_ -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
value
    [Text]
_ -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"More than one label contained " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label

htmlBody :: String -> RequestBuilder site BSL8.ByteString
htmlBody :: forall site. String -> RequestBuilder site HtmlLBS
htmlBody String
funcName = do
  mres <- (RequestBuilderData site -> Maybe SResponse)
-> SIO (RequestBuilderData site) (RequestBuilderData site)
-> SIO (RequestBuilderData site) (Maybe SResponse)
forall a b.
(a -> b)
-> SIO (RequestBuilderData site) a
-> SIO (RequestBuilderData site) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RequestBuilderData site -> Maybe SResponse
forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse SIO (RequestBuilderData site) (RequestBuilderData site)
forall s. SIO s s
getSIO
  res <-
    case mres of
      Maybe SResponse
Nothing -> Text -> SIO (RequestBuilderData site) SResponse
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> SIO (RequestBuilderData site) SResponse)
-> Text -> SIO (RequestBuilderData site) SResponse
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
funcName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": No response available"
      Just SResponse
res -> SResponse -> SIO (RequestBuilderData site) SResponse
forall a. a -> SIO (RequestBuilderData site) a
forall (m :: * -> *) a. Monad m => a -> m a
return SResponse
res
  return $ simpleBody res