{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.Test
(
yesodSpec
, YesodSpec
, yesodSpecWithSiteGenerator
, yesodSpecWithSiteGeneratorAndArgument
, yesodSpecApp
, YesodExample
, YesodExampleData(..)
, TestApp
, YSpec
, testApp
, YesodSpecTree (..)
, ydescribe
, yit
, testModifySite
, testSetCookie
, testDeleteCookie
, testModifyCookies
, testClearCookies
, get
, post
, postBody
, performMethod
, followRedirect
, getLocation
, request
, addRequestHeader
, addBasicAuthHeader
, setMethod
, addPostParam
, addGetParam
, addBareGetParam
, addFile
, setRequestBody
, RequestBuilder
, SIO
, setUrl
, clickOn
, byLabel
, byLabelExact
, byLabelContain
, byLabelPrefix
, byLabelSuffix
, bySelectorLabelContain
, fileByLabel
, fileByLabelExact
, fileByLabelContain
, fileByLabelPrefix
, fileByLabelSuffix
, addToken
, addToken_
, addTokenFromCookie
, addTokenFromCookieNamedToHeaderNamed
, assertEqual
, assertNotEq
, assertEqualNoShow
, assertEq
, assertHeader
, assertNoHeader
, statusIs
, bodyEquals
, bodyContains
, bodyNotContains
, htmlAllContain
, htmlAnyContain
, htmlNoneContain
, htmlCount
, requireJSONResponse
, getTestYesod
, getResponse
, getRequestCookies
, printBody
, printMatches
, htmlQuery
, parseHTML
, withResponse
) where
import qualified Test.Hspec.Core.Spec as Hspec
import qualified Data.List as DL
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TErr
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Test.HUnit as HUnit
import qualified Network.HTTP.Types as H
#if MIN_VERSION_network(3, 0, 0)
import qualified Network.Socket as Sock
#else
import qualified Network.Socket.Internal as Sock
#endif
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Text.Blaze.Renderer.String as Blaze
import qualified Text.Blaze as Blaze
import Network.Wai
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
import Control.Monad.IO.Class
import System.IO
import Yesod.Core.Unsafe (runFakeHandler)
import Yesod.Test.TransversingCSS
import Yesod.Core
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
import Text.XML.Cursor hiding (element)
import qualified Text.XML.Cursor as C
import qualified Text.HTML.DOM as HD
import Control.Monad.Trans.Writer
import qualified Data.Map as M
import qualified Web.Cookie as Cookie
import qualified Blaze.ByteString.Builder as Builder
import Data.Time.Clock (getCurrentTime)
import Control.Applicative ((<$>))
import Text.Show.Pretty (ppShow)
import Data.Monoid (mempty)
import Data.Semigroup (Semigroup(..))
#if MIN_VERSION_base(4,9,0)
import GHC.Stack (HasCallStack)
#elif MIN_VERSION_base(4,8,1)
import GHC.Stack (CallStack)
type HasCallStack = (?callStack :: CallStack)
#else
import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint)
#endif
import Data.ByteArray.Encoding (convertToBase, Base(..))
import Network.HTTP.Types.Header (hContentType)
import Data.Aeson (FromJSON, eitherDecode')
import Control.Monad (unless)
import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)
import Yesod.Test.Internal.SIO
{-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
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)
}
type YesodExample site = SIO (YesodExampleData site)
type Cookies = M.Map ByteString Cookie.SetCookie
type YesodSpec site = Writer [YesodSpecTree site] ()
data YesodSpecTree site
= YesodSpecGroup String [YesodSpecTree site]
| YesodSpecItem String (YesodExample site ())
getTestYesod :: YesodExample site site
getTestYesod :: forall site. YesodExample site site
getTestYesod = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall site. YesodExampleData site -> site
yedSite forall s. SIO s s
getSIO
getResponse :: YesodExample site (Maybe SResponse)
getResponse :: forall site. YesodExample site (Maybe SResponse)
getResponse = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall site. YesodExampleData site -> Maybe SResponse
yedResponse 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
, :: H.RequestHeaders
}
data RBDPostData = MultipleItemsPostData [RequestPart]
| BinaryPostData BSL8.ByteString
data RequestPart
= ReqKvPart T.Text T.Text
| ReqFilePart T.Text FilePath BSL8.ByteString T.Text
type RequestBuilder site = SIO (RequestBuilderData site)
ydescribe :: String -> YesodSpec site -> YesodSpec site
ydescribe :: forall site. String -> YesodSpec site -> YesodSpec site
ydescribe String
label YesodSpec site
yspecs = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [forall site. String -> [YesodSpecTree site] -> YesodSpecTree site
YesodSpecGroup String
label forall a b. (a -> b) -> a -> b
$ 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 =
forall a. [SpecTree a] -> SpecWith a
Hspec.fromSpecList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map YesodSpecTree site -> SpecTree ()
unYesod forall a b. (a -> b) -> a -> b
$ forall w a. Writer w a -> w
execWriter YesodSpec site
yspecs
where
unYesod :: YesodSpecTree site -> SpecTree ()
unYesod (YesodSpecGroup String
x [YesodSpecTree site]
y) = forall a. HasCallStack => String -> [SpecTree a] -> SpecTree a
Hspec.specGroup String
x forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map YesodSpecTree site -> SpecTree ()
unYesod [YesodSpecTree site]
y
unYesod (YesodSpecItem String
x YesodExample site ()
y) = forall e.
(HasCallStack, Example e) =>
String -> e -> SpecTree (Arg e)
Hspec.specItem String
x forall a b. (a -> b) -> a -> b
$ do
Application
app <- forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
site
forall s a. SIO s a -> s -> IO a
evalSIO YesodExample site ()
y YesodExampleData
{ yedApp :: Application
yedApp = Application
app
, yedSite :: site
yedSite = site
site
, yedCookies :: Cookies
yedCookies = forall k a. Map k a
M.empty
, yedResponse :: Maybe SResponse
yedResponse = forall a. Maybe a
Nothing
}
yesodSpecWithSiteGenerator :: YesodDispatch site
=> IO site
-> YesodSpec site
-> Hspec.Spec
yesodSpecWithSiteGenerator :: forall site.
YesodDispatch site =>
IO site -> YesodSpec site -> Spec
yesodSpecWithSiteGenerator IO site
getSiteAction =
forall site a.
YesodDispatch site =>
(a -> IO site) -> YesodSpec site -> SpecWith a
yesodSpecWithSiteGeneratorAndArgument (forall a b. a -> b -> a
const IO site
getSiteAction)
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 =
forall a. [SpecTree a] -> SpecWith a
Hspec.fromSpecList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {site} {t}.
YesodDispatch site =>
(t -> IO site) -> YesodSpecTree site -> SpecTree t
unYesod a -> IO site
getSiteAction) forall a b. (a -> b) -> a -> b
$ 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) = forall a. HasCallStack => String -> [SpecTree a] -> SpecTree a
Hspec.specGroup String
x forall a b. (a -> b) -> a -> b
$ 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) = forall e.
(HasCallStack, Example e) =>
String -> e -> SpecTree (Arg e)
Hspec.specItem String
x forall a b. (a -> b) -> a -> b
$ \t
a -> do
site
site <- t -> IO site
getSiteAction' t
a
Application
app <- forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
site
forall s a. SIO s a -> s -> IO a
evalSIO YesodExample site ()
y YesodExampleData
{ yedApp :: Application
yedApp = Application
app
, yedSite :: site
yedSite = site
site
, yedCookies :: Cookies
yedCookies = forall k a. Map k a
M.empty
, yedResponse :: Maybe SResponse
yedResponse = forall a. Maybe a
Nothing
}
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 =
forall a. [SpecTree a] -> SpecWith a
Hspec.fromSpecList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map YesodSpecTree site -> SpecTree ()
unYesod forall a b. (a -> b) -> a -> b
$ forall w a. Writer w a -> w
execWriter YesodSpec site
yspecs
where
unYesod :: YesodSpecTree site -> SpecTree ()
unYesod (YesodSpecGroup String
x [YesodSpecTree site]
y) = forall a. HasCallStack => String -> [SpecTree a] -> SpecTree a
Hspec.specGroup String
x forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map YesodSpecTree site -> SpecTree ()
unYesod [YesodSpecTree site]
y
unYesod (YesodSpecItem String
x YesodExample site ()
y) = forall e.
(HasCallStack, Example e) =>
String -> e -> SpecTree (Arg e)
Hspec.specItem String
x forall a b. (a -> b) -> a -> b
$ do
Application
app <- IO Application
getApp
forall s a. SIO s a -> s -> IO a
evalSIO YesodExample site ()
y YesodExampleData
{ yedApp :: Application
yedApp = Application
app
, yedSite :: site
yedSite = site
site
, yedCookies :: Cookies
yedCookies = forall k a. Map k a
M.empty
, yedResponse :: Maybe SResponse
yedResponse = forall a. Maybe a
Nothing
}
yit :: String -> YesodExample site () -> YesodSpec site
yit :: forall site. String -> YesodExample site () -> YesodSpec site
yit String
label YesodExample site ()
example = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [forall site. String -> YesodExample site () -> YesodSpecTree site
YesodSpecItem String
label YesodExample site ()
example]
testModifySite :: YesodDispatch site
=> (site -> IO (site, Middleware))
-> YesodExample site ()
testModifySite :: forall site.
YesodDispatch site =>
(site -> IO (site, Middleware)) -> YesodExample site ()
testModifySite site -> IO (site, Middleware)
newSiteFn = do
site
currentSite <- forall site. YesodExample site site
getTestYesod
(site
newSite, Middleware
middleware) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ site -> IO (site, Middleware)
newSiteFn site
currentSite
Application
app <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
newSite
forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedSite :: site
yedSite = site
newSite, yedApp :: Application
yedApp = Middleware
middleware Application
app }
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
forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies :: Cookies
yedCookies = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ByteString
key SetCookie
cookie (forall site. YesodExampleData site -> Cookies
yedCookies YesodExampleData site
yed) }
testDeleteCookie :: ByteString -> YesodExample site ()
testDeleteCookie :: forall site. ByteString -> YesodExample site ()
testDeleteCookie ByteString
k = do
forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies :: Cookies
yedCookies = forall k a. Ord k => k -> Map k a -> Map k a
M.delete ByteString
k (forall site. YesodExampleData site -> Cookies
yedCookies YesodExampleData site
yed) }
testModifyCookies :: (Cookies -> Cookies) -> YesodExample site ()
testModifyCookies :: forall site. (Cookies -> Cookies) -> YesodExample site ()
testModifyCookies Cookies -> Cookies
f = do
forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies :: Cookies
yedCookies = Cookies -> Cookies
f (forall site. YesodExampleData site -> Cookies
yedCookies YesodExampleData site
yed) }
testClearCookies :: YesodExample site ()
testClearCookies :: forall site. YesodExample site ()
testClearCookies = do
forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies :: Cookies
yedCookies = forall k a. Map k a
M.empty }
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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe SIO state a
err SResponse -> SIO state a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. state -> Maybe SResponse
getter forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. SIO s s
getSIO
where err :: SIO state a
err = forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
msg
msg :: Text
msg = if 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 - "
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n - " [Text]
errTrace
withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a
withResponse :: forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse = forall state a.
HasCallStack =>
(state -> Maybe SResponse)
-> [Text] -> (SResponse -> SIO state a) -> SIO state a
withResponse' forall site. YesodExampleData site -> Maybe SResponse
yedResponse []
parseHTML :: HtmlLBS -> Cursor
parseHTML :: HtmlLBS -> Cursor
parseHTML HtmlLBS
html = Document -> Cursor
fromDocument forall a b. (a -> b) -> a -> b
$ HtmlLBS -> Document
HD.parseLBS HtmlLBS
html
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 = 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." forall a. a -> [a] -> [a]
: [Text]
errTrace) 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 -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
query forall a. Semigroup a => a -> a -> a
<> Text
" did not parse: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show String
err)
Right [String]
matches -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> HtmlLBS
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack) [String]
matches
htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]
htmlQuery :: forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery = forall state.
HasCallStack =>
(state -> Maybe SResponse) -> [Text] -> Text -> SIO state [HtmlLBS]
htmlQuery' forall site. YesodExampleData site -> Maybe SResponse
yedResponse []
assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
assertEq :: forall a site.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> YesodExample site ()
assertEq String
m a
a a
b =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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: " forall a. [a] -> [a] -> [a]
++ String
m forall a. [a] -> [a] -> [a]
++ String
"\n"
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 =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
HUnit.assertBool String
msg (a
a forall a. Eq a => a -> a -> Bool
/= a
b)
where msg :: String
msg = String
"Assertion: " forall a. [a] -> [a] -> [a]
++ String
m forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
String
"Both arguments: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
ppShow a
a 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 = forall a site.
(HasCallStack, Eq a) =>
String -> a -> a -> YesodExample site ()
assertEqualNoShow
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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
HUnit.assertBool String
msg (a
a forall a. Eq a => a -> a -> Bool
== a
b)
statusIs :: HasCallStack => Int -> YesodExample site ()
statusIs :: forall site. HasCallStack => Int -> YesodExample site ()
statusIs Int
number = do
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse forall a b. (a -> b) -> a -> b
$ \(SResponse Status
status RequestHeaders
headers HtmlLBS
body) -> do
let mContentType :: Maybe ByteString
mContentType = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType RequestHeaders
headers
isUTF8ContentType :: Bool
isUTF8ContentType = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ByteString -> Bool
contentTypeHeaderIsUtf8 Maybe ByteString
mContentType
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip HasCallStack => String -> Bool -> IO ()
HUnit.assertBool (Status -> Int
H.statusCode Status
status forall a. Eq a => a -> a -> Bool
== Int
number) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Expected status was ", forall a. Show a => a -> String
show Int
number
, String
" but received status was ", forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Status -> Int
H.statusCode Status
status
, if Bool
isUTF8ContentType
then String
". For debugging, the body was: " forall a. Semigroup a => a -> a -> a
<> (Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ HtmlLBS -> Text
getBodyTextPreview HtmlLBS
body)
else String
""
]
assertHeader :: HasCallStack => CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
HeaderName
header ByteString
value = forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse forall a b. (a -> b) -> a -> b
$ \ SResponse { simpleHeaders :: SResponse -> RequestHeaders
simpleHeaders = RequestHeaders
h } ->
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header RequestHeaders
h of
Maybe ByteString
Nothing -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Expected header "
, forall a. Show a => a -> String
show HeaderName
header
, String
" to be "
, forall a. Show a => a -> String
show ByteString
value
, String
", but it was not present"
]
Just ByteString
value' -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip HasCallStack => String -> Bool -> IO ()
HUnit.assertBool (ByteString
value forall a. Eq a => a -> a -> Bool
== ByteString
value') forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Expected header "
, forall a. Show a => a -> String
show HeaderName
header
, String
" to be "
, forall a. Show a => a -> String
show ByteString
value
, String
", but received "
, forall a. Show a => a -> String
show ByteString
value'
]
assertNoHeader :: HasCallStack => CI BS8.ByteString -> YesodExample site ()
HeaderName
header = forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse forall a b. (a -> b) -> a -> b
$ \ SResponse { simpleHeaders :: SResponse -> RequestHeaders
simpleHeaders = RequestHeaders
h } ->
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header RequestHeaders
h of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
s -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Unexpected header "
, forall a. Show a => a -> String
show HeaderName
header
, String
" containing "
, forall a. Show a => a -> String
show ByteString
s
]
bodyEquals :: HasCallStack => String -> YesodExample site ()
bodyEquals :: forall site. HasCallStack => String -> YesodExample site ()
bodyEquals String
text = forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse forall a b. (a -> b) -> a -> b
$ \ SResponse
res -> do
let actual :: HtmlLBS
actual = SResponse -> HtmlLBS
simpleBody SResponse
res
msg :: String
msg = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Expected body to equal:\n\t"
, String
text forall a. [a] -> [a] -> [a]
++ String
"\n"
, String
"Actual is:\n\t"
, Text -> String
TL.unpack forall a b. (a -> b) -> a -> b
$ OnDecodeError -> HtmlLBS -> Text
decodeUtf8With OnDecodeError
TErr.lenientDecode HtmlLBS
actual
]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
HUnit.assertBool String
msg forall a b. (a -> b) -> a -> b
$ HtmlLBS
actual forall a. Eq a => a -> a -> Bool
== Text -> HtmlLBS
encodeUtf8 (String -> Text
TL.pack String
text)
bodyContains :: HasCallStack => String -> YesodExample site ()
bodyContains :: forall site. HasCallStack => String -> YesodExample site ()
bodyContains String
text = forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse forall a b. (a -> b) -> a -> b
$ \ SResponse
res ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
HUnit.assertBool (String
"Expected body to contain " forall a. [a] -> [a] -> [a]
++ String
text) forall a b. (a -> b) -> a -> b
$
(SResponse -> HtmlLBS
simpleBody SResponse
res) HtmlLBS -> String -> Bool
`contains` String
text
bodyNotContains :: HasCallStack => String -> YesodExample site ()
bodyNotContains :: forall site. HasCallStack => String -> YesodExample site ()
bodyNotContains String
text = forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse forall a b. (a -> b) -> a -> b
$ \ SResponse
res ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
HUnit.assertBool (String
"Expected body not to contain " forall a. [a] -> [a] -> [a]
++ String
text) forall a b. (a -> b) -> a -> b
$
Bool -> Bool
not 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 = forall a. Eq a => [a] -> [a] -> Bool
DL.isInfixOf String
b (Text -> String
TL.unpack forall a b. (a -> b) -> a -> b
$ HtmlLBS -> Text
decodeUtf8 HtmlLBS
a)
htmlAllContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlAllContain :: forall site. HasCallStack => Text -> String -> YesodExample site ()
htmlAllContain Text
query String
search = do
[HtmlLBS]
matches <- forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
case [HtmlLBS]
matches of
[] -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"Nothing matched css query: " forall a. Semigroup a => a -> a -> a
<> Text
query
[HtmlLBS]
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
HUnit.assertBool (String
"Not all "forall a. [a] -> [a] -> [a]
++Text -> String
T.unpack Text
queryforall a. [a] -> [a] -> [a]
++String
" contain "forall a. [a] -> [a] -> [a]
++String
search forall a. [a] -> [a] -> [a]
++ String
" matches: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [HtmlLBS]
matches) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
DL.all (forall a. Eq a => [a] -> [a] -> Bool
DL.isInfixOf (String -> String
escape String
search)) (forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlLBS -> Text
decodeUtf8) [HtmlLBS]
matches)
escape :: String -> String
escape :: String -> String
escape = Markup -> String
Blaze.renderMarkup forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Markup
Blaze.string
htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlAnyContain :: forall site. HasCallStack => Text -> String -> YesodExample site ()
htmlAnyContain Text
query String
search = do
[HtmlLBS]
matches <- forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
case [HtmlLBS]
matches of
[] -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"Nothing matched css query: " forall a. Semigroup a => a -> a -> a
<> Text
query
[HtmlLBS]
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
HUnit.assertBool (String
"None of "forall a. [a] -> [a] -> [a]
++Text -> String
T.unpack Text
queryforall a. [a] -> [a] -> [a]
++String
" contain "forall a. [a] -> [a] -> [a]
++String
search forall a. [a] -> [a] -> [a]
++ String
" matches: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [HtmlLBS]
matches) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
DL.any (forall a. Eq a => [a] -> [a] -> Bool
DL.isInfixOf (String -> String
escape String
search)) (forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlLBS -> Text
decodeUtf8) [HtmlLBS]
matches)
htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlNoneContain :: forall site. HasCallStack => Text -> String -> YesodExample site ()
htmlNoneContain Text
query String
search = do
[HtmlLBS]
matches <- forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
case forall a. (a -> Bool) -> [a] -> [a]
DL.filter (forall a. Eq a => [a] -> [a] -> Bool
DL.isInfixOf (String -> String
escape String
search)) (forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlLBS -> Text
decodeUtf8) [HtmlLBS]
matches) of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[String]
found -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"Found " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
found) forall a. Semigroup a => a -> a -> a
<>
Text
" instances of " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
search forall a. Semigroup a => a -> a -> a
<> Text
" in " forall a. Semigroup a => a -> a -> a
<> Text
query forall a. Semigroup a => a -> a -> a
<> Text
" elements"
htmlCount :: HasCallStack => Query -> Int -> YesodExample site ()
htmlCount :: forall site. HasCallStack => Text -> Int -> YesodExample site ()
htmlCount Text
query Int
count = do
Int
matches <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> Int
DL.length forall a b. (a -> b) -> a -> b
$ forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip HasCallStack => String -> Bool -> IO ()
HUnit.assertBool (Int
matches forall a. Eq a => a -> a -> Bool
== Int
count)
(String
"Expected "forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> String
show Int
count)forall a. [a] -> [a] -> [a]
++String
" elements to match "forall a. [a] -> [a] -> [a]
++Text -> String
T.unpack Text
queryforall a. [a] -> [a] -> [a]
++String
", found "forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> String
show Int
matches))
requireJSONResponse :: (HasCallStack, FromJSON a) => YesodExample site a
requireJSONResponse :: forall a site. (HasCallStack, FromJSON a) => YesodExample site a
requireJSONResponse = do
forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse forall a b. (a -> b) -> a -> b
$ \(SResponse Status
_status RequestHeaders
headers HtmlLBS
body) -> do
let mContentType :: Maybe ByteString
mContentType = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType RequestHeaders
headers
isJSONContentType :: Bool
isJSONContentType = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ByteString -> Bool
contentTypeHeaderIsJson Maybe ByteString
mContentType
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
Bool
isJSONContentType
(forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Expected `Content-Type: application/json` in the headers, got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RequestHeaders
headers)
case forall a. FromJSON a => HtmlLBS -> Either String a
eitherDecode' HtmlLBS
body of
Left String
err -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v
printBody :: YesodExample site ()
printBody :: forall site. YesodExample site ()
printBody = forall site a.
HasCallStack =>
(SResponse -> YesodExample site a) -> YesodExample site a
withResponse forall a b. (a -> b) -> a -> b
$ \ SResponse { simpleBody :: SResponse -> HtmlLBS
simpleBody = HtmlLBS
b } ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> HtmlLBS -> IO ()
BSL8.hPutStrLn Handle
stderr HtmlLBS
b
printMatches :: HasCallStack => Query -> YesodExample site ()
printMatches :: forall site. HasCallStack => Text -> YesodExample site ()
printMatches Text
query = do
[HtmlLBS]
matches <- forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show [HtmlLBS]
matches
addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
addPostParam :: forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
name Text
value =
forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdPostData :: RBDPostData
rbdPostData = (RBDPostData -> RBDPostData
addPostData (forall site. RequestBuilderData site -> RBDPostData
rbdPostData RequestBuilderData site
rbd)) }
where addPostData :: RBDPostData -> RBDPostData
addPostData (BinaryPostData HtmlLBS
_) = forall a. HasCallStack => String -> a
error String
"Trying to add post param to binary content."
addPostData (MultipleItemsPostData [RequestPart]
posts) =
[RequestPart] -> RBDPostData
MultipleItemsPostData forall a b. (a -> b) -> a -> b
$ Text -> Text -> RequestPart
ReqKvPart Text
name Text
value forall a. a -> [a] -> [a]
: [RequestPart]
posts
addGetParam :: T.Text -> T.Text -> RequestBuilder site ()
addGetParam :: forall site. Text -> Text -> RequestBuilder site ()
addGetParam Text
name Text
value = forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd
{ rbdGets :: Query
rbdGets = (Text -> ByteString
TE.encodeUtf8 Text
name, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
value)
forall a. a -> [a] -> [a]
: forall site. RequestBuilderData site -> Query
rbdGets RequestBuilderData site
rbd
}
addBareGetParam :: T.Text -> RequestBuilder site ()
addBareGetParam :: forall site. Text -> RequestBuilder site ()
addBareGetParam Text
name = forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd ->
RequestBuilderData site
rbd {rbdGets :: Query
rbdGets = (Text -> ByteString
TE.encodeUtf8 Text
name, forall a. Maybe a
Nothing) forall a. a -> [a] -> [a]
: forall site. RequestBuilderData site -> Query
rbdGets RequestBuilderData site
rbd}
addFile :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
addFile :: forall site. Text -> String -> Text -> RequestBuilder site ()
addFile Text
name String
path Text
mimetype = do
HtmlLBS
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO HtmlLBS
BSL8.readFile String
path
forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdPostData :: RBDPostData
rbdPostData = (RBDPostData -> HtmlLBS -> RBDPostData
addPostData (forall site. RequestBuilderData site -> RBDPostData
rbdPostData RequestBuilderData site
rbd) HtmlLBS
contents) }
where addPostData :: RBDPostData -> HtmlLBS -> RBDPostData
addPostData (BinaryPostData HtmlLBS
_) HtmlLBS
_ = forall a. HasCallStack => String -> a
error String
"Trying to add file after setting binary content."
addPostData (MultipleItemsPostData [RequestPart]
posts) HtmlLBS
contents =
[RequestPart] -> RBDPostData
MultipleItemsPostData forall a b. (a -> b) -> a -> b
$ Text -> String -> HtmlLBS -> Text -> RequestPart
ReqFilePart Text
name String
path HtmlLBS
contents Text
mimetype forall a. a -> [a] -> [a]
: [RequestPart]
posts
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
Maybe SResponse
mres <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse forall s. SIO s s
getSIO
SResponse
res <-
case Maybe SResponse
mres of
Maybe SResponse
Nothing -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
"genericNameFromLabel: No response available"
Just SResponse
res -> forall (m :: * -> *) a. Monad m => a -> m a
return SResponse
res
let body :: HtmlLBS
body = SResponse -> HtmlLBS
simpleBody SResponse
res
case (Text -> Text -> Bool) -> Text -> HtmlLBS -> Either Text Text
genericNameFromHTML Text -> Text -> Bool
match Text
label HtmlLBS
body of
Left Text
e -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
e
Right Text
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
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
Maybe SResponse
mres <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse forall s. SIO s s
getSIO
SResponse
res <-
case Maybe SResponse
mres of
Maybe SResponse
Nothing -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
"genericNameSelectorFromLabel: No response available"
Just SResponse
res -> forall (m :: * -> *) a. Monad m => a -> m a
return SResponse
res
let body :: HtmlLBS
body = SResponse -> HtmlLBS
simpleBody SResponse
res
HtmlLBS
html <-
case HtmlLBS -> Text -> Either String [String]
findBySelector HtmlLBS
body Text
selector of
Left String
parseError -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"genericNameFromSelectorLabel: Parse error" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
parseError
Right [] -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"genericNameFromSelectorLabel: No fragments match selector " forall a. Semigroup a => a -> a -> a
<> Text
selector
Right [String
matchingFragment] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> HtmlLBS
BSL8.pack String
matchingFragment
Right [String]
_matchingFragments -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"genericNameFromSelectorLabel: Multiple fragments match selector " forall a. Semigroup a => a -> a -> a
<> Text
selector
case (Text -> Text -> Bool) -> Text -> HtmlLBS -> Either Text Text
genericNameFromHTML Text -> Text -> Bool
match Text
label HtmlLBS
html of
Left Text
e -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
e
Right Text
x -> 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
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Cursor -> [Cursor]
C.element Name
"label"
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 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 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
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Text -> Cursor -> [Cursor]
attributeIs Name
"id" Text
for
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]
_ -> forall a b. a -> Either a b
Left 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]
_ -> forall a b. b -> Either a b
Right Text
name
[] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"No input with id " forall a. Semigroup a => a -> a -> a
<> Text
for
[] ->
case forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Text
"") forall a b. (a -> b) -> a -> b
$ [Cursor]
mlabel forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall node. Cursor node -> [Cursor node]
child forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Cursor]
C.element Name
"input" forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"name") of
[] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"No label contained: " forall a. Semigroup a => a -> a -> a
<> Text
label
Text
name:[Text]
_ -> forall a b. b -> Either a b
Right Text
name
[Text]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"More than one label contained " forall a. Semigroup a => a -> a -> a
<> Text
label
byLabelWithMatch :: (T.Text -> T.Text -> Bool)
-> T.Text
-> T.Text
-> RequestBuilder site ()
byLabelWithMatch :: forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
match Text
label Text
value = do
Text
name <- forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
match Text
label
forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
name Text
value
bySelectorLabelWithMatch :: (T.Text -> T.Text -> Bool)
-> T.Text
-> T.Text
-> T.Text
-> 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
Text
name <- forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site Text
genericNameFromSelectorLabel Text -> Text -> Bool
match Text
selector Text
label
forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
name Text
value
byLabel :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabel :: forall site. Text -> Text -> RequestBuilder site ()
byLabel = forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
T.isInfixOf
byLabelExact :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelExact :: forall site. Text -> Text -> RequestBuilder site ()
byLabelExact = forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch forall a. Eq a => a -> a -> Bool
(==)
byLabelContain :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelContain :: forall site. Text -> Text -> RequestBuilder site ()
byLabelContain = forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
T.isInfixOf
byLabelPrefix :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelPrefix :: forall site. Text -> Text -> RequestBuilder site ()
byLabelPrefix = forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
T.isPrefixOf
byLabelSuffix :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelSuffix :: forall site. Text -> Text -> RequestBuilder site ()
byLabelSuffix = forall site.
(Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
T.isSuffixOf
bySelectorLabelContain :: T.Text
-> T.Text
-> T.Text
-> RequestBuilder site ()
bySelectorLabelContain :: forall site. Text -> Text -> Text -> RequestBuilder site ()
bySelectorLabelContain = forall site.
(Text -> Text -> Bool)
-> Text -> Text -> Text -> RequestBuilder site ()
bySelectorLabelWithMatch Text -> Text -> Bool
T.isInfixOf
fileByLabelWithMatch :: (T.Text -> T.Text -> Bool)
-> T.Text
-> FilePath
-> T.Text
-> 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
Text
name <- forall site.
HasCallStack =>
(Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
match Text
label
forall site. Text -> String -> Text -> RequestBuilder site ()
addFile Text
name String
path Text
mime
fileByLabel :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabel :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabel = forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
T.isInfixOf
fileByLabelExact :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelExact :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabelExact = forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch forall a. Eq a => a -> a -> Bool
(==)
fileByLabelContain :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelContain :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabelContain = forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
T.isInfixOf
fileByLabelPrefix :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelPrefix :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabelPrefix = forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
T.isPrefixOf
fileByLabelSuffix :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelSuffix :: forall site. Text -> String -> Text -> RequestBuilder site ()
fileByLabelSuffix = forall site.
(Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
T.isSuffixOf
addToken_ :: HasCallStack => Query -> RequestBuilder site ()
addToken_ :: forall site. HasCallStack => Text -> RequestBuilder site ()
addToken_ Text
scope = do
[HtmlLBS]
matches <- forall state.
HasCallStack =>
(state -> Maybe SResponse) -> [Text] -> Text -> SIO state [HtmlLBS]
htmlQuery' forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse [Text
"Tried to get CSRF token with addToken'"] forall a b. (a -> b) -> a -> b
$ Text
scope forall a. Semigroup a => a -> a -> a
<> Text
" input[name=_token][type=hidden][value]"
case [HtmlLBS]
matches of
[] -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"No CSRF token found in the current page"
HtmlLBS
element:[] -> forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
"_token" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"value" forall a b. (a -> b) -> a -> b
$ HtmlLBS -> Cursor
parseHTML HtmlLBS
element
[HtmlLBS]
_ -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"More than one CSRF token found in the page"
addToken :: HasCallStack => RequestBuilder site ()
addToken :: forall site. HasCallStack => RequestBuilder site ()
addToken = forall site. HasCallStack => Text -> RequestBuilder site ()
addToken_ Text
""
addTokenFromCookie :: HasCallStack => RequestBuilder site ()
addTokenFromCookie :: forall site. HasCallStack => RequestBuilder site ()
addTokenFromCookie = forall site.
HasCallStack =>
ByteString -> HeaderName -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed ByteString
defaultCsrfCookieName HeaderName
defaultCsrfHeaderName
addTokenFromCookieNamedToHeaderNamed :: HasCallStack
=> ByteString
-> CI ByteString
-> RequestBuilder site ()
ByteString
cookieName HeaderName
headerName = do
Cookies
cookies <- forall site. HasCallStack => RequestBuilder site Cookies
getRequestCookies
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
cookieName Cookies
cookies of
Just SetCookie
csrfCookie -> forall site. (HeaderName, ByteString) -> RequestBuilder site ()
addRequestHeader (HeaderName
headerName, SetCookie -> ByteString
Cookie.setCookieValue SetCookie
csrfCookie)
Maybe SetCookie
Nothing -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"addTokenFromCookieNamedToHeaderNamed failed to lookup CSRF cookie with name: "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ByteString
cookieName
, Text
". Cookies were: "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Cookies
cookies
]
getRequestCookies :: HasCallStack => RequestBuilder site Cookies
getRequestCookies :: forall site. HasCallStack => RequestBuilder site Cookies
getRequestCookies = do
RequestBuilderData site
requestBuilderData <- forall s. SIO s s
getSIO
RequestHeaders
headers <- case SResponse -> RequestHeaders
simpleHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse RequestBuilderData site
requestBuilderData of
Just RequestHeaders
h -> forall (m :: * -> *) a. Monad m => a -> m a
return RequestHeaders
h
Maybe RequestHeaders
Nothing -> 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."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\SetCookie
c -> (SetCookie -> ByteString
Cookie.setCookieName SetCookie
c, SetCookie
c)) (RequestHeaders -> [SetCookie]
parseSetCookies RequestHeaders
headers)
post :: (Yesod site, RedirectUrl site url)
=> url
-> YesodExample site ()
post :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
post = forall site url.
(Yesod site, RedirectUrl site url) =>
ByteString -> url -> YesodExample site ()
performMethod ByteString
"POST"
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 = forall site. RequestBuilder site () -> YesodExample site ()
request forall a b. (a -> b) -> a -> b
$ do
forall site. ByteString -> RequestBuilder site ()
setMethod ByteString
"POST"
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> RequestBuilder site ()
setUrl url
url
forall site. HtmlLBS -> RequestBuilder site ()
setRequestBody HtmlLBS
body
get :: (Yesod site, RedirectUrl site url)
=> url
-> YesodExample site ()
get :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
get = forall site url.
(Yesod site, RedirectUrl site url) =>
ByteString -> url -> YesodExample site ()
performMethod ByteString
"GET"
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 = forall site. RequestBuilder site () -> YesodExample site ()
request forall a b. (a -> b) -> a -> b
$ do
forall site. ByteString -> RequestBuilder site ()
setMethod ByteString
method
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> RequestBuilder site ()
setUrl url
url
followRedirect :: Yesod site
=> YesodExample site (Either T.Text T.Text)
followRedirect :: forall site. Yesod site => YesodExample site (Either Text Text)
followRedirect = do
Maybe SResponse
mr <- forall site. YesodExample site (Maybe SResponse)
getResponse
case Maybe SResponse
mr of
Maybe SResponse
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ SResponse -> Status
simpleStatus SResponse
r) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
301, Int
302, Int
303, Int
307, Int
308])
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"followRedirect called, but previous request was not a redirect"
else do
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" (SResponse -> RequestHeaders
simpleHeaders SResponse
r) of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
get Text
url forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Text
url)
getLocation :: ParseRoute site => YesodExample site (Either T.Text (Route site))
getLocation :: forall site.
ParseRoute site =>
YesodExample site (Either Text (Route site))
getLocation = do
Maybe SResponse
mr <- forall site. YesodExample site (Maybe SResponse)
getResponse
case Maybe SResponse
mr of
Maybe SResponse
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" (SResponse -> RequestHeaders
simpleHeaders SResponse
r) of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"getLocation called, but the previous response has no Location header"
Just ByteString
h -> case forall a.
ParseRoute a =>
([Text], [(Text, Text)]) -> Maybe (Route a)
parseRoute forall a b. (a -> b) -> a -> b
$ ByteString -> ([Text], [(Text, Text)])
decodePath ByteString
h of
Maybe (Route site)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"getLocation called, but couldn’t parse it into a route"
Just Route site
l -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 (forall a. Eq a => a -> a -> Bool
==Char
'?') ByteString
b
in (ByteString -> [Text]
H.decodePathSegments ByteString
x, forall {b} {a}. Monoid b => (a, Maybe b) -> (a, b)
unJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> QueryText
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, forall a. Monoid a => a
Data.Monoid.mempty)
setMethod :: H.Method -> RequestBuilder site ()
setMethod :: forall site. ByteString -> RequestBuilder site ()
setMethod ByteString
m = forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdMethod :: ByteString
rbdMethod = ByteString
m }
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
site <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall site. RequestBuilderData site -> site
rbdSite forall s. SIO s s
getSIO
Either ErrorResponse Text
eurl <- forall site (m :: * -> *) a.
(Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> HandlerFor site a
-> m (Either ErrorResponse a)
Yesod.Core.Unsafe.runFakeHandler
forall k a. Map k a
M.empty
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"Yesod.Test: No logger available")
site
site
(forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
toTextUrl url
url')
Text
url <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorResponse Text
eurl
let (Text
urlPath, Text
urlQuery) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'?') Text
url
forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd
{ rbdPath :: [Text]
rbdPath =
case forall a. (a -> Bool) -> [a] -> [a]
DL.filter (forall a. Eq a => a -> a -> Bool
/=Text
"") forall a b. (a -> b) -> a -> b
$ ByteString -> [Text]
H.decodePathSegments forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
urlPath of
(Text
"http:":Text
_:[Text]
rest) -> [Text]
rest
(Text
"https:":Text
_:[Text]
rest) -> [Text]
rest
[Text]
x -> [Text]
x
, rbdGets :: Query
rbdGets = forall site. RequestBuilderData site -> Query
rbdGets RequestBuilderData site
rbd forall a. [a] -> [a] -> [a]
++ ByteString -> Query
H.parseQuery (Text -> ByteString
TE.encodeUtf8 Text
urlQuery)
}
clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()
clickOn :: forall site.
(HasCallStack, Yesod site) =>
Text -> YesodExample site ()
clickOn Text
query = do
forall state a.
HasCallStack =>
(state -> Maybe SResponse)
-> [Text] -> (SResponse -> SIO state a) -> SIO state a
withResponse' forall site. YesodExampleData site -> Maybe SResponse
yedResponse [Text
"Tried to invoke clickOn in order to read HTML of a previous response."] 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 -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
query forall a. Semigroup a => a -> a -> a
<> Text
" did not parse: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show String
err)
Right [[Text
match]] -> forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
get Text
match
Right [[Text]]
matches -> forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure forall a b. (a -> b) -> a -> b
$ Text
"Expected exactly one match for clickOn: got " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show [[Text]]
matches)
setRequestBody :: BSL8.ByteString -> RequestBuilder site ()
setRequestBody :: forall site. HtmlLBS -> RequestBuilder site ()
setRequestBody HtmlLBS
body = forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdPostData :: RBDPostData
rbdPostData = HtmlLBS -> RBDPostData
BinaryPostData HtmlLBS
body }
addRequestHeader :: H.Header -> RequestBuilder site ()
(HeaderName, ByteString)
header = forall s. (s -> s) -> SIO s ()
modifySIO forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd
{ rbdHeaders :: RequestHeaders
rbdHeaders = (HeaderName, ByteString)
header forall a. a -> [a] -> [a]
: forall site. RequestBuilderData site -> RequestHeaders
rbdHeaders RequestBuilderData site
rbd
}
addBasicAuthHeader :: CI ByteString
-> CI ByteString
-> RequestBuilder site ()
HeaderName
username HeaderName
password =
let credentials :: ByteString
credentials = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
CI.original forall a b. (a -> b) -> a -> b
$ HeaderName
username forall a. Semigroup a => a -> a -> a
<> HeaderName
":" forall a. Semigroup a => a -> a -> a
<> HeaderName
password
in forall site. (HeaderName, ByteString) -> RequestBuilder site ()
addRequestHeader (HeaderName
"Authorization", ByteString
"Basic " forall a. Semigroup a => a -> a -> a
<> ByteString
credentials)
request :: RequestBuilder site ()
-> YesodExample site ()
request :: forall site. RequestBuilder site () -> YesodExample site ()
request RequestBuilder site ()
reqBuilder = do
YesodExampleData Application
app site
site Cookies
oldCookies Maybe SResponse
mRes <- forall s. SIO s s
getSIO
RequestBuilderData {site
Query
RequestHeaders
[Text]
Maybe SResponse
ByteString
RBDPostData
rbdHeaders :: RequestHeaders
rbdGets :: Query
rbdPath :: [Text]
rbdSite :: site
rbdMethod :: ByteString
rbdResponse :: Maybe SResponse
rbdPostData :: RBDPostData
rbdHeaders :: forall site. RequestBuilderData site -> RequestHeaders
rbdGets :: forall site. RequestBuilderData site -> Query
rbdPath :: forall site. RequestBuilderData site -> [Text]
rbdSite :: forall site. RequestBuilderData site -> site
rbdMethod :: forall site. RequestBuilderData site -> ByteString
rbdResponse :: forall site. RequestBuilderData site -> Maybe SResponse
rbdPostData :: forall site. RequestBuilderData site -> RBDPostData
..} <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall s. SIO s () -> s -> IO s
execSIO RequestBuilder site ()
reqBuilder RequestBuilderData
{ rbdPostData :: RBDPostData
rbdPostData = [RequestPart] -> RBDPostData
MultipleItemsPostData []
, rbdResponse :: Maybe SResponse
rbdResponse = Maybe SResponse
mRes
, rbdMethod :: ByteString
rbdMethod = ByteString
"GET"
, rbdSite :: site
rbdSite = site
site
, rbdPath :: [Text]
rbdPath = []
, rbdGets :: Query
rbdGets = []
, rbdHeaders :: RequestHeaders
rbdHeaders = []
}
let path :: Text
path
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rbdPath = Text
"/"
| Bool
otherwise = ByteString -> Text
TE.decodeUtf8 forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toByteString forall a b. (a -> b) -> a -> b
$ [Text] -> Builder
H.encodePathSegments [Text]
rbdPath
UTCTime
currentUtc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let cookies :: Cookies
cookies = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (UTCTime -> SetCookie -> Bool
checkCookieTime UTCTime
currentUtc) Cookies
oldCookies
cookiesForPath :: Cookies
cookiesForPath = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Text -> SetCookie -> Bool
checkCookiePath Text
path) Cookies
cookies
let req :: SRequest
req = case RBDPostData
rbdPostData of
MultipleItemsPostData [RequestPart]
x ->
if 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 = 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 = forall a0.
Map a0 SetCookie
-> [RequestPart]
-> ByteString
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeMultipart Cookies
cookiesForPath [RequestPart]
x ByteString
rbdMethod RequestHeaders
rbdHeaders Text
path Query
rbdGets
SResponse
response <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Session a -> Application -> IO a
runSession (SRequest -> Session SResponse
srequest SRequest
req
{ simpleRequest :: Request
simpleRequest = (SRequest -> Request
simpleRequest SRequest
req)
{ httpVersion :: HttpVersion
httpVersion = HttpVersion
H.http11
}
}) Application
app
let newCookies :: [SetCookie]
newCookies = RequestHeaders -> [SetCookie]
parseSetCookies forall a b. (a -> b) -> a -> b
$ SResponse -> RequestHeaders
simpleHeaders SResponse
response
cookies' :: Cookies
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] forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Cookies
cookies
forall s. s -> SIO s ()
putSIO forall a b. (a -> b) -> a -> b
$ forall site.
Application
-> site -> Cookies -> Maybe SResponse -> YesodExampleData site
YesodExampleData Application
app site
site Cookies
cookies' (forall a. a -> Maybe a
Just SResponse
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 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
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 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 <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map a0 SetCookie
cookies ]
contentTypeValue :: ByteString
contentTypeValue = String -> ByteString
BS8.pack forall a b. (a -> b) -> a -> b
$ String
"multipart/form-data; boundary=" forall a. [a] -> [a] -> [a]
++ String
boundary
multiPartBody :: [RequestPart] -> ByteString
multiPartBody [RequestPart]
parts =
[ByteString] -> ByteString
BS8.concat forall a b. (a -> b) -> a -> b
$ ByteString
separator 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 forall a b. (a -> b) -> a -> b
$ HtmlLBS -> [ByteString]
BSL8.toChunks HtmlLBS
bytes, ByteString
"\r\n"]
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) ] forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Cookies -> ByteString
H.renderSimpleQuery Bool
False
forall a b. (a -> b) -> a -> b
$ 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 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 <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ 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)]
headersForPostData :: RBDPostData -> [(a, b)]
headersForPostData (MultipleItemsPostData []) = []
headersForPostData (MultipleItemsPostData [RequestPart]
_ ) = [(a
"Content-Type", b
"application/x-www-form-urlencoded")]
headersForPostData (BinaryPostData HtmlLBS
_ ) = []
mkRequest :: RequestHeaders
-> ByteString -> RequestHeaders -> Text -> Query -> Request
mkRequest RequestHeaders
headers ByteString
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery = Request
defaultRequest
{ requestMethod :: ByteString
requestMethod = ByteString
method
, remoteHost :: SockAddr
remoteHost = PortNumber -> HostAddress -> SockAddr
Sock.SockAddrInet PortNumber
1 HostAddress
2
, requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
headers forall a. [a] -> [a] -> [a]
++ RequestHeaders
extraHeaders
, rawPathInfo :: ByteString
rawPathInfo = Text -> ByteString
TE.encodeUtf8 Text
urlPath
, pathInfo :: [Text]
pathInfo = ByteString -> [Text]
H.decodePathSegments forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
urlPath
, rawQueryString :: ByteString
rawQueryString = Bool -> Query -> ByteString
H.renderQuery Bool
False Query
urlQuery
, queryString :: Query
queryString = Query
urlQuery
}
parseSetCookies :: [H.Header] -> [Cookie.SetCookie]
parseSetCookies :: RequestHeaders -> [SetCookie]
parseSetCookies RequestHeaders
headers = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> SetCookie
Cookie.parseSetCookie forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
DL.filter ((HeaderName
"Set-Cookie"forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ RequestHeaders
headers
failure :: (HasCallStack, MonadIO a) => T.Text -> a b
failure :: forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure Text
reason = (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
HUnit.assertFailure forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
reason) forall (m :: * -> *) a b. Monad m => m a -> m b -> m 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 =
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
Hspec.evaluateExample
(ActionWith (Arg (SIO (YesodExampleData site) a)) -> IO ()
action forall a b. (a -> b) -> a -> b
$ \(site
site, Middleware
middleware) -> do
Application
app <- forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
site
a
_ <- forall s a. SIO s a -> s -> IO a
evalSIO SIO (YesodExampleData site) a
example YesodExampleData
{ yedApp :: Application
yedApp = Middleware
middleware Application
app
, yedSite :: site
yedSite = site
site
, yedCookies :: Cookies
yedCookies = forall k a. Map k a
M.empty
, yedResponse :: Maybe SResponse
yedResponse = forall a. Maybe a
Nothing
}
forall (m :: * -> *) a. Monad m => a -> m a
return ())
Params
params
(forall a b. (a -> b) -> a -> b
$ ())