{-# 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
, addFile
, setRequestBody
, RequestBuilder
, SIO
, setUrl
, clickOn
, byLabel
, byLabelExact
, byLabelContain
, byLabelPrefix
, byLabelSuffix
, 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 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
{ YesodExampleData site -> Application
yedApp :: !Application
, YesodExampleData site -> site
yedSite :: !site
, YesodExampleData site -> Cookies
yedCookies :: !Cookies
, 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 :: YesodExample site site
getTestYesod = (YesodExampleData site -> site)
-> SIO (YesodExampleData site) (YesodExampleData site)
-> YesodExample site site
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
getResponse :: YesodExample site (Maybe SResponse)
getResponse :: YesodExample site (Maybe SResponse)
getResponse = (YesodExampleData site -> Maybe SResponse)
-> SIO (YesodExampleData site) (YesodExampleData site)
-> YesodExample site (Maybe SResponse)
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
{ RequestBuilderData site -> RBDPostData
rbdPostData :: RBDPostData
, RequestBuilderData site -> Maybe SResponse
rbdResponse :: (Maybe SResponse)
, RequestBuilderData site -> Method
rbdMethod :: H.Method
, RequestBuilderData site -> site
rbdSite :: site
, RequestBuilderData site -> [Text]
rbdPath :: [T.Text]
, 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 :: 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 :: 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 a.
(HasCallStack, Example a) =>
String -> a -> SpecTree (Arg a)
Hspec.specItem String
x (IO () -> SpecTree (Arg (IO ())))
-> IO () -> SpecTree (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
Application
app <- site -> IO Application
forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
site
YesodExample site () -> YesodExampleData site -> IO ()
forall s a. SIO s a -> s -> IO a
evalSIO YesodExample site ()
y YesodExampleData :: forall site.
Application
-> site -> Cookies -> Maybe SResponse -> YesodExampleData site
YesodExampleData
{ yedApp :: Application
yedApp = Application
app
, yedSite :: site
yedSite = site
site
, yedCookies :: Cookies
yedCookies = Cookies
forall k a. Map k a
M.empty
, yedResponse :: Maybe SResponse
yedResponse = Maybe SResponse
forall a. Maybe a
Nothing
}
yesodSpecWithSiteGenerator :: YesodDispatch site
=> IO site
-> YesodSpec site
-> Hspec.Spec
yesodSpecWithSiteGenerator :: 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)
yesodSpecWithSiteGeneratorAndArgument :: YesodDispatch site
=> (a -> IO site)
-> YesodSpec site
-> Hspec.SpecWith a
yesodSpecWithSiteGeneratorAndArgument :: (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 a.
(HasCallStack, Example a) =>
String -> a -> SpecTree (Arg a)
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
site <- t -> IO site
getSiteAction' t
a
Application
app <- site -> IO Application
forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
site
YesodExample site () -> YesodExampleData site -> IO ()
forall s a. SIO s a -> s -> IO a
evalSIO YesodExample site ()
y YesodExampleData :: forall site.
Application
-> site -> Cookies -> Maybe SResponse -> YesodExampleData site
YesodExampleData
{ yedApp :: Application
yedApp = Application
app
, yedSite :: site
yedSite = site
site
, yedCookies :: Cookies
yedCookies = Cookies
forall k a. Map k a
M.empty
, yedResponse :: Maybe SResponse
yedResponse = Maybe SResponse
forall a. Maybe a
Nothing
}
yesodSpecApp :: YesodDispatch site
=> site
-> IO Application
-> YesodSpec site
-> Hspec.Spec
yesodSpecApp :: 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 a.
(HasCallStack, Example a) =>
String -> a -> SpecTree (Arg a)
Hspec.specItem String
x (IO () -> SpecTree (Arg (IO ())))
-> IO () -> SpecTree (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
Application
app <- IO Application
getApp
YesodExample site () -> YesodExampleData site -> IO ()
forall s a. SIO s a -> s -> IO a
evalSIO YesodExample site ()
y YesodExampleData :: forall site.
Application
-> site -> Cookies -> Maybe SResponse -> YesodExampleData site
YesodExampleData
{ yedApp :: Application
yedApp = Application
app
, yedSite :: site
yedSite = site
site
, yedCookies :: Cookies
yedCookies = Cookies
forall k a. Map k a
M.empty
, yedResponse :: Maybe SResponse
yedResponse = Maybe SResponse
forall a. Maybe a
Nothing
}
yit :: String -> YesodExample site () -> YesodSpec site
yit :: String -> YesodExample site () -> YesodSpec site
yit String
label YesodExample site ()
example = [YesodSpecTree site] -> YesodSpec site
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]
testModifySite :: YesodDispatch site
=> (site -> IO (site, Middleware))
-> YesodExample site ()
testModifySite :: (site -> IO (site, Middleware)) -> YesodExample site ()
testModifySite site -> IO (site, Middleware)
newSiteFn = do
site
currentSite <- YesodExample site site
forall site. YesodExample site site
getTestYesod
(site
newSite, Middleware
middleware) <- IO (site, Middleware)
-> SIO (YesodExampleData site) (site, Middleware)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (site, Middleware)
-> SIO (YesodExampleData site) (site, Middleware))
-> IO (site, Middleware)
-> SIO (YesodExampleData site) (site, Middleware)
forall a b. (a -> b) -> a -> b
$ site -> IO (site, Middleware)
newSiteFn site
currentSite
Application
app <- IO Application -> SIO (YesodExampleData site) Application
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Application -> SIO (YesodExampleData site) Application)
-> IO Application -> SIO (YesodExampleData site) Application
forall a b. (a -> b) -> a -> b
$ site -> IO Application
forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
newSite
(YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
-> YesodExample site ())
-> (YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
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 :: SetCookie -> YesodExample site ()
testSetCookie SetCookie
cookie = do
let key :: Method
key = SetCookie -> Method
Cookie.setCookieName SetCookie
cookie
(YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
-> YesodExample site ())
-> (YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies :: Cookies
yedCookies = Method -> SetCookie -> Cookies -> Cookies
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Method
key SetCookie
cookie (YesodExampleData site -> Cookies
forall site. YesodExampleData site -> Cookies
yedCookies YesodExampleData site
yed) }
testDeleteCookie :: ByteString -> YesodExample site ()
testDeleteCookie :: Method -> YesodExample site ()
testDeleteCookie Method
k = do
(YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
-> YesodExample site ())
-> (YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies :: Cookies
yedCookies = Method -> Cookies -> Cookies
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Method
k (YesodExampleData site -> Cookies
forall site. YesodExampleData site -> Cookies
yedCookies YesodExampleData site
yed) }
testModifyCookies :: (Cookies -> Cookies) -> YesodExample site ()
testModifyCookies :: (Cookies -> Cookies) -> YesodExample site ()
testModifyCookies Cookies -> Cookies
f = do
(YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
-> YesodExample site ())
-> (YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies :: Cookies
yedCookies = Cookies -> Cookies
f (YesodExampleData site -> Cookies
forall site. YesodExampleData site -> Cookies
yedCookies YesodExampleData site
yed) }
testClearCookies :: YesodExample site ()
testClearCookies :: YesodExample site ()
testClearCookies = do
(YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((YesodExampleData site -> YesodExampleData site)
-> YesodExample site ())
-> (YesodExampleData site -> YesodExampleData site)
-> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ \YesodExampleData site
yed -> YesodExampleData site
yed { yedCookies :: Cookies
yedCookies = Cookies
forall k a. Map k a
M.empty }
withResponse' :: HasCallStack
=> (state -> Maybe SResponse)
-> [T.Text]
-> (SResponse -> SIO state a)
-> SIO state a
withResponse' :: (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 (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
withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a
withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a
withResponse = (YesodExampleData site -> Maybe SResponse)
-> [Text]
-> (SResponse -> YesodExample site a)
-> YesodExample 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 []
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
htmlQuery' :: HasCallStack
=> (state -> Maybe SResponse)
-> [T.Text]
-> Query
-> SIO state [HtmlLBS]
htmlQuery' :: (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 (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
htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]
htmlQuery :: Text -> YesodExample site [HtmlLBS]
htmlQuery = (YesodExampleData site -> Maybe SResponse)
-> [Text] -> Text -> YesodExample 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 []
assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
assertEq :: String -> a -> a -> YesodExample site ()
assertEq String
m a
a a
b =
IO () -> YesodExample site ()
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 (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
"First argument: " 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" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"Second argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
ppShow a
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
assertNotEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
assertNotEq :: String -> a -> a -> YesodExample site ()
assertNotEq String
m a
a a
b =
IO () -> YesodExample site ()
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 (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 :: String -> a -> a -> YesodExample site ()
assertEqual = String -> a -> a -> YesodExample site ()
forall a site.
(HasCallStack, Eq a) =>
String -> a -> a -> YesodExample site ()
assertEqualNoShow
assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
assertEqualNoShow :: String -> a -> a -> YesodExample site ()
assertEqualNoShow String
msg a
a a
b = IO () -> YesodExample site ()
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 (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b)
statusIs :: HasCallStack => Int -> YesodExample site ()
statusIs :: 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 Method
mContentType = HeaderName -> RequestHeaders -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType RequestHeaders
headers
isUTF8ContentType :: Bool
isUTF8ContentType = Bool -> (Method -> Bool) -> Maybe Method -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Method -> Bool
contentTypeHeaderIsUtf8 Maybe Method
mContentType
IO () -> YesodExample site ()
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
""
]
assertHeader :: HasCallStack => CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
HeaderName
header Method
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 Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header RequestHeaders
h of
Maybe Method
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 "
, Method -> String
forall a. Show a => a -> String
show Method
value
, String
", but it was not present"
]
Just Method
value' -> IO () -> YesodExample site ()
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 (Method
value Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
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 "
, Method -> String
forall a. Show a => a -> String
show Method
value
, String
", but received "
, Method -> String
forall a. Show a => a -> String
show Method
value'
]
assertNoHeader :: HasCallStack => CI BS8.ByteString -> YesodExample site ()
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 Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header RequestHeaders
h of
Maybe Method
Nothing -> () -> YesodExample site ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Method
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 "
, Method -> String
forall a. Show a => a -> String
show Method
s
]
bodyEquals :: HasCallStack => String -> YesodExample site ()
bodyEquals :: 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 (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)
bodyContains :: HasCallStack => String -> YesodExample site ()
bodyContains :: 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 (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
bodyNotContains :: HasCallStack => String -> YesodExample site ()
bodyNotContains :: 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 (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)
htmlAllContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlAllContain :: Text -> String -> YesodExample site ()
htmlAllContain Text
query String
search = do
[HtmlLBS]
matches <- Text -> YesodExample site [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
case [HtmlLBS]
matches of
[] -> 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
$ Text
"Nothing matched css query: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
query
[HtmlLBS]
_ -> IO () -> YesodExample site ()
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
"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) (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
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)
htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlAnyContain :: Text -> String -> YesodExample site ()
htmlAnyContain Text
query String
search = do
[HtmlLBS]
matches <- Text -> YesodExample site [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
case [HtmlLBS]
matches of
[] -> 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
$ Text
"Nothing matched css query: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
query
[HtmlLBS]
_ -> IO () -> YesodExample site ()
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
"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) (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
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)
htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlNoneContain :: Text -> String -> YesodExample site ()
htmlNoneContain Text
query String
search = do
[HtmlLBS]
matches <- Text -> YesodExample site [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
DL.filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
DL.isInfixOf 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) of
[] -> () -> YesodExample site ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[String]
found -> 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
$ 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 (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"
htmlCount :: HasCallStack => Query -> Int -> YesodExample site ()
htmlCount :: Text -> Int -> YesodExample site ()
htmlCount Text
query Int
count = do
Int
matches <- ([HtmlLBS] -> Int)
-> SIO (YesodExampleData site) [HtmlLBS]
-> SIO (YesodExampleData site) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [HtmlLBS] -> 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
IO () -> YesodExample site ()
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 (Int
matches Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
count)
(String
"Expected "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
count)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" elements to match "String -> String -> String
forall a. [a] -> [a] -> [a]
++Text -> String
T.unpack Text
queryString -> String -> String
forall a. [a] -> [a] -> [a]
++String
", found "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
matches))
requireJSONResponse :: (HasCallStack, FromJSON a) => YesodExample site a
requireJSONResponse :: 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 Method
mContentType = HeaderName -> RequestHeaders -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType RequestHeaders
headers
isJSONContentType :: Bool
isJSONContentType = Bool -> (Method -> Bool) -> Maybe Method -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Method -> Bool
contentTypeHeaderIsJson Maybe Method
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 (m :: * -> *) a. Monad m => a -> m a
return a
v
printBody :: YesodExample site ()
printBody :: 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 (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
printMatches :: HasCallStack => Query -> YesodExample site ()
printMatches :: Text -> YesodExample site ()
printMatches Text
query = do
[HtmlLBS]
matches <- Text -> YesodExample site [HtmlLBS]
forall site. HasCallStack => Text -> YesodExample site [HtmlLBS]
htmlQuery Text
query
IO () -> YesodExample site ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodExample site ()) -> IO () -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [HtmlLBS] -> String
forall a. Show a => a -> String
show [HtmlLBS]
matches
addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
addPostParam :: Text -> Text -> RequestBuilder site ()
addPostParam Text
name Text
value =
(RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdPostData :: RBDPostData
rbdPostData = (RBDPostData -> RBDPostData
addPostData (RequestBuilderData site -> RBDPostData
forall site. RequestBuilderData site -> RBDPostData
rbdPostData RequestBuilderData site
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
addGetParam :: T.Text -> T.Text -> RequestBuilder site ()
addGetParam :: Text -> Text -> RequestBuilder site ()
addGetParam Text
name Text
value = (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd
{ rbdGets :: Query
rbdGets = (Text -> Method
TE.encodeUtf8 Text
name, Method -> Maybe Method
forall a. a -> Maybe a
Just (Method -> Maybe Method) -> Method -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Text -> Method
TE.encodeUtf8 Text
value)
(Method, Maybe Method) -> Query -> Query
forall a. a -> [a] -> [a]
: RequestBuilderData site -> Query
forall site. RequestBuilderData site -> Query
rbdGets RequestBuilderData site
rbd
}
addFile :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
addFile :: Text -> String -> Text -> RequestBuilder site ()
addFile Text
name String
path Text
mimetype = do
HtmlLBS
contents <- IO HtmlLBS -> SIO (RequestBuilderData site) HtmlLBS
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
(RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdPostData :: RBDPostData
rbdPostData = (RBDPostData -> HtmlLBS -> RBDPostData
addPostData (RequestBuilderData site -> RBDPostData
forall site. RequestBuilderData site -> RBDPostData
rbdPostData RequestBuilderData site
rbd) HtmlLBS
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
genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericNameFromLabel :: (Text -> Text -> Bool) -> Text -> RequestBuilder site Text
genericNameFromLabel Text -> Text -> Bool
match Text
label = do
Maybe SResponse
mres <- (RequestBuilderData site -> Maybe SResponse)
-> SIO (RequestBuilderData site) (RequestBuilderData site)
-> SIO (RequestBuilderData site) (Maybe SResponse)
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
SResponse
res <-
case Maybe SResponse
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 (m :: * -> *) a. Monad m => a -> m a
return SResponse
res
let
body :: HtmlLBS
body = SResponse -> HtmlLBS
simpleBody SResponse
res
mlabel :: [Cursor]
mlabel = HtmlLBS -> Cursor
parseHTML HtmlLBS
body
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 (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 = []
case [Text]
mfor of
Text
for:[] -> do
let mname :: [Text]
mname = HtmlLBS -> Cursor
parseHTML HtmlLBS
body
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 -> RequestBuilder site Text
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site Text)
-> Text -> RequestBuilder site 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 -> RequestBuilder site Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name
[] -> Text -> RequestBuilder site Text
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site Text)
-> Text -> RequestBuilder site 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 (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 -> RequestBuilder site Text
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site Text)
-> Text -> RequestBuilder site 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 -> RequestBuilder site Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name
[Text]
_ -> Text -> RequestBuilder site Text
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site Text)
-> Text -> RequestBuilder site 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)
-> T.Text
-> T.Text
-> RequestBuilder site ()
byLabelWithMatch :: (Text -> Text -> Bool) -> Text -> Text -> RequestBuilder site ()
byLabelWithMatch Text -> Text -> Bool
match Text
label Text
value = do
Text
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
Text -> Text -> RequestBuilder site ()
forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
name Text
value
byLabel :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabel :: 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
byLabelExact :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelExact :: 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
(==)
byLabelContain :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelContain :: 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
byLabelPrefix :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelPrefix :: 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
byLabelSuffix :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelSuffix :: 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
fileByLabelWithMatch :: (T.Text -> T.Text -> Bool)
-> T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelWithMatch :: (Text -> Text -> Bool)
-> Text -> String -> Text -> RequestBuilder site ()
fileByLabelWithMatch Text -> Text -> Bool
match Text
label String
path Text
mime = do
Text
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
Text -> String -> Text -> RequestBuilder site ()
forall site. Text -> String -> Text -> RequestBuilder site ()
addFile Text
name String
path Text
mime
fileByLabel :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabel :: 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
fileByLabelExact :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelExact :: 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
(==)
fileByLabelContain :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelContain :: 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
fileByLabelPrefix :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelPrefix :: 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
fileByLabelSuffix :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelSuffix :: 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
addToken_ :: HasCallStack => Query -> RequestBuilder site ()
addToken_ :: Text -> RequestBuilder site ()
addToken_ Text
scope = do
[HtmlLBS]
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 [HtmlLBS]
matches of
[] -> Text -> RequestBuilder site ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site ()) -> Text -> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ Text
"No CSRF token found in the current page"
HtmlLBS
element:[] -> Text -> Text -> RequestBuilder site ()
forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
"_token" (Text -> RequestBuilder site ()) -> Text -> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. [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 -> RequestBuilder site ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site ()) -> Text -> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ Text
"More than one CSRF token found in the page"
addToken :: HasCallStack => RequestBuilder site ()
addToken :: RequestBuilder site ()
addToken = Text -> RequestBuilder site ()
forall site. HasCallStack => Text -> RequestBuilder site ()
addToken_ Text
""
addTokenFromCookie :: HasCallStack => RequestBuilder site ()
addTokenFromCookie :: RequestBuilder site ()
addTokenFromCookie = Method -> HeaderName -> RequestBuilder site ()
forall site.
HasCallStack =>
Method -> HeaderName -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed Method
defaultCsrfCookieName HeaderName
defaultCsrfHeaderName
addTokenFromCookieNamedToHeaderNamed :: HasCallStack
=> ByteString
-> CI ByteString
-> RequestBuilder site ()
Method
cookieName HeaderName
headerName = do
Cookies
cookies <- RequestBuilder site Cookies
forall site. HasCallStack => RequestBuilder site Cookies
getRequestCookies
case Method -> Cookies -> Maybe SetCookie
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Method
cookieName Cookies
cookies of
Just SetCookie
csrfCookie -> Header -> RequestBuilder site ()
forall site. Header -> RequestBuilder site ()
addRequestHeader (HeaderName
headerName, SetCookie -> Method
Cookie.setCookieValue SetCookie
csrfCookie)
Maybe SetCookie
Nothing -> Text -> RequestBuilder site ()
forall (a :: * -> *) b. (HasCallStack, MonadIO a) => Text -> a b
failure (Text -> RequestBuilder site ()) -> Text -> RequestBuilder 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
$ Method -> String
forall a. Show a => a -> String
show Method
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
]
getRequestCookies :: HasCallStack => RequestBuilder site Cookies
getRequestCookies :: RequestBuilder site Cookies
getRequestCookies = do
RequestBuilderData site
requestBuilderData <- SIO (RequestBuilderData site) (RequestBuilderData site)
forall s. SIO s s
getSIO
RequestHeaders
headers <- case SResponse -> RequestHeaders
simpleHeaders (SResponse -> RequestHeaders)
-> Maybe SResponse -> Maybe RequestHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> RequestBuilderData site -> Maybe SResponse
forall site. RequestBuilderData site -> Maybe SResponse
rbdResponse RequestBuilderData site
requestBuilderData of
Just RequestHeaders
h -> RequestHeaders -> SIO (RequestBuilderData site) RequestHeaders
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."
Cookies -> RequestBuilder site Cookies
forall (m :: * -> *) a. Monad m => a -> m a
return (Cookies -> RequestBuilder site Cookies)
-> Cookies -> RequestBuilder site Cookies
forall a b. (a -> b) -> a -> b
$ [(Method, SetCookie)] -> Cookies
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Method, SetCookie)] -> Cookies)
-> [(Method, SetCookie)] -> Cookies
forall a b. (a -> b) -> a -> b
$ (SetCookie -> (Method, SetCookie))
-> [SetCookie] -> [(Method, SetCookie)]
forall a b. (a -> b) -> [a] -> [b]
map (\SetCookie
c -> (SetCookie -> Method
Cookie.setCookieName SetCookie
c, SetCookie
c)) (RequestHeaders -> [SetCookie]
parseSetCookies RequestHeaders
headers)
post :: (Yesod site, RedirectUrl site url)
=> url
-> YesodExample site ()
post :: url -> YesodExample site ()
post = Method -> url -> YesodExample site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
Method -> url -> YesodExample site ()
performMethod Method
"POST"
postBody :: (Yesod site, RedirectUrl site url)
=> url
-> BSL8.ByteString
-> YesodExample site ()
postBody :: 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
Method -> RequestBuilder site ()
forall site. Method -> RequestBuilder site ()
setMethod Method
"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
get :: (Yesod site, RedirectUrl site url)
=> url
-> YesodExample site ()
get :: url -> YesodExample site ()
get = Method -> url -> YesodExample site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
Method -> url -> YesodExample site ()
performMethod Method
"GET"
performMethod :: (Yesod site, RedirectUrl site url)
=> ByteString
-> url
-> YesodExample site ()
performMethod :: Method -> url -> YesodExample site ()
performMethod Method
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
Method -> RequestBuilder site ()
forall site. Method -> RequestBuilder site ()
setMethod Method
method
url -> RequestBuilder site ()
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 :: YesodExample site (Either Text Text)
followRedirect = do
Maybe SResponse
mr <- YesodExample site (Maybe SResponse)
forall site. YesodExample site (Maybe SResponse)
getResponse
case Maybe SResponse
mr of
Maybe SResponse
Nothing -> Either Text Text -> YesodExample site (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text -> YesodExample site (Either Text Text))
-> Either Text Text -> YesodExample 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 (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 -> YesodExample site (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text -> YesodExample site (Either Text Text))
-> Either Text Text -> YesodExample 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 Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" (SResponse -> RequestHeaders
simpleHeaders SResponse
r) of
Maybe Method
Nothing -> Either Text Text -> YesodExample site (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text -> YesodExample site (Either Text Text))
-> Either Text Text -> YesodExample 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 Method
h -> let url :: Text
url = Method -> Text
TE.decodeUtf8 Method
h in
Text -> YesodExample site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
get Text
url YesodExample site ()
-> YesodExample site (Either Text Text)
-> YesodExample site (Either Text Text)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Text Text -> YesodExample site (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
url)
getLocation :: ParseRoute site => YesodExample site (Either T.Text (Route site))
getLocation :: YesodExample site (Either Text (Route site))
getLocation = do
Maybe SResponse
mr <- YesodExample site (Maybe SResponse)
forall site. YesodExample site (Maybe SResponse)
getResponse
case Maybe SResponse
mr of
Maybe SResponse
Nothing -> Either Text (Route site)
-> YesodExample site (Either Text (Route site))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Route site)
-> YesodExample site (Either Text (Route site)))
-> Either Text (Route site)
-> YesodExample 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 Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" (SResponse -> RequestHeaders
simpleHeaders SResponse
r) of
Maybe Method
Nothing -> Either Text (Route site)
-> YesodExample site (Either Text (Route site))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Route site)
-> YesodExample site (Either Text (Route site)))
-> Either Text (Route site)
-> YesodExample 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 Method
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
$ Method -> ([Text], [(Text, Text)])
decodePath Method
h of
Maybe (Route site)
Nothing -> Either Text (Route site)
-> YesodExample site (Either Text (Route site))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Route site)
-> YesodExample site (Either Text (Route site)))
-> Either Text (Route site)
-> YesodExample 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)
-> YesodExample site (Either Text (Route site))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Route site)
-> YesodExample site (Either Text (Route site)))
-> Either Text (Route site)
-> YesodExample 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 :: Method -> ([Text], [(Text, Text)])
decodePath Method
b = let (Method
x, Method
y) = (Char -> Bool) -> Method -> (Method, Method)
BS8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'?') Method
b
in (Method -> [Text]
H.decodePathSegments Method
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
<$> Method -> [(Text, Maybe Text)]
H.parseQueryText Method
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)
setMethod :: H.Method -> RequestBuilder site ()
setMethod :: Method -> RequestBuilder site ()
setMethod Method
m = (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd { rbdMethod :: Method
rbdMethod = Method
m }
setUrl :: (Yesod site, RedirectUrl site url)
=> url
-> RequestBuilder site ()
setUrl :: url -> RequestBuilder site ()
setUrl url
url' = do
site
site <- (RequestBuilderData site -> site)
-> SIO (RequestBuilderData site) (RequestBuilderData site)
-> SIO (RequestBuilderData site) site
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
Either ErrorResponse Text
eurl <- SessionMap
-> (site -> Logger)
-> site
-> HandlerFor site Text
-> SIO (RequestBuilderData site) (Either ErrorResponse Text)
forall site (m :: * -> *) a.
(Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> HandlerFor site a
-> m (Either ErrorResponse a)
Yesod.Core.Unsafe.runFakeHandler
SessionMap
forall k a. Map k a
M.empty
(Logger -> site -> Logger
forall a b. a -> b -> a
const (Logger -> site -> Logger) -> Logger -> site -> Logger
forall a b. (a -> b) -> a -> b
$ String -> Logger
forall a. HasCallStack => String -> a
error String
"Yesod.Test: No logger available")
site
site
(url -> HandlerFor site Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
toTextUrl url
url')
Text
url <- (ErrorResponse -> SIO (RequestBuilderData site) Text)
-> (Text -> SIO (RequestBuilderData site) Text)
-> Either ErrorResponse Text
-> SIO (RequestBuilderData site) Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> SIO (RequestBuilderData site) Text
forall a. HasCallStack => String -> a
error (String -> SIO (RequestBuilderData site) Text)
-> (ErrorResponse -> String)
-> ErrorResponse
-> SIO (RequestBuilderData site) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorResponse -> String
forall a. Show a => a -> String
show) Text -> SIO (RequestBuilderData site) Text
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?') Text
url
(RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd
{ rbdPath :: [Text]
rbdPath =
case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
DL.filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Text
"") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Method -> [Text]
H.decodePathSegments (Method -> [Text]) -> Method -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Method
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 = RequestBuilderData site -> Query
forall site. RequestBuilderData site -> Query
rbdGets RequestBuilderData site
rbd Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++ Method -> Query
H.parseQuery (Text -> Method
TE.encodeUtf8 Text
urlQuery)
}
clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()
clickOn :: Text -> YesodExample site ()
clickOn Text
query = do
(YesodExampleData site -> Maybe SResponse)
-> [Text]
-> (SResponse -> YesodExample site ())
-> YesodExample 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 -> YesodExample site ()) -> YesodExample site ())
-> (SResponse -> YesodExample site ()) -> YesodExample 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 -> 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
$ 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 -> YesodExample site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodExample site ()
get Text
match
Right [[Text]]
matches -> 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
$ 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)
setRequestBody :: BSL8.ByteString -> RequestBuilder site ()
setRequestBody :: HtmlLBS -> RequestBuilder site ()
setRequestBody HtmlLBS
body = (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
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 ()
Header
header = (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s. (s -> s) -> SIO s ()
modifySIO ((RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
rbd -> RequestBuilderData site
rbd
{ rbdHeaders :: RequestHeaders
rbdHeaders = Header
header Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestBuilderData site -> RequestHeaders
forall site. RequestBuilderData site -> RequestHeaders
rbdHeaders RequestBuilderData site
rbd
}
addBasicAuthHeader :: CI ByteString
-> CI ByteString
-> RequestBuilder site ()
HeaderName
username HeaderName
password =
let credentials :: Method
credentials = Base -> Method -> Method
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ HeaderName -> Method
forall s. CI s -> s
CI.original (HeaderName -> Method) -> HeaderName -> Method
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 Header -> RequestBuilder site ()
forall site. Header -> RequestBuilder site ()
addRequestHeader (HeaderName
"Authorization", Method
"Basic " Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
credentials)
request :: RequestBuilder site ()
-> YesodExample site ()
request :: RequestBuilder site () -> YesodExample site ()
request RequestBuilder site ()
reqBuilder = do
YesodExampleData Application
app site
site Cookies
oldCookies Maybe SResponse
mRes <- SIO (YesodExampleData site) (YesodExampleData site)
forall s. SIO s s
getSIO
RequestBuilderData {site
Query
RequestHeaders
[Text]
Maybe SResponse
Method
RBDPostData
rbdHeaders :: RequestHeaders
rbdGets :: Query
rbdPath :: [Text]
rbdSite :: site
rbdMethod :: Method
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 -> Method
rbdResponse :: forall site. RequestBuilderData site -> Maybe SResponse
rbdPostData :: forall site. RequestBuilderData site -> RBDPostData
..} <- IO (RequestBuilderData site)
-> SIO (YesodExampleData site) (RequestBuilderData site)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RequestBuilderData site)
-> SIO (YesodExampleData site) (RequestBuilderData site))
-> IO (RequestBuilderData site)
-> SIO (YesodExampleData site) (RequestBuilderData site)
forall a b. (a -> b) -> a -> b
$ RequestBuilder site ()
-> RequestBuilderData site -> IO (RequestBuilderData site)
forall s. SIO s () -> s -> IO s
execSIO RequestBuilder site ()
reqBuilder RequestBuilderData :: forall site.
RBDPostData
-> Maybe SResponse
-> Method
-> site
-> [Text]
-> Query
-> RequestHeaders
-> RequestBuilderData site
RequestBuilderData
{ rbdPostData :: RBDPostData
rbdPostData = [RequestPart] -> RBDPostData
MultipleItemsPostData []
, rbdResponse :: Maybe SResponse
rbdResponse = Maybe SResponse
mRes
, rbdMethod :: Method
rbdMethod = Method
"GET"
, rbdSite :: site
rbdSite = site
site
, rbdPath :: [Text]
rbdPath = []
, rbdGets :: Query
rbdGets = []
, rbdHeaders :: RequestHeaders
rbdHeaders = []
}
let path :: Text
path
| [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rbdPath = Text
"/"
| Bool
otherwise = Method -> Text
TE.decodeUtf8 (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Method
Builder.toByteString (Builder -> Method) -> Builder -> Method
forall a b. (a -> b) -> a -> b
$ [Text] -> Builder
H.encodePathSegments [Text]
rbdPath
UTCTime
currentUtc <- IO UTCTime -> SIO (YesodExampleData site) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let cookies :: Cookies
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 :: Cookies
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 :: SRequest
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
-> Method
-> RequestHeaders
-> Text
-> Query
-> SRequest
forall a0.
Map a0 SetCookie
-> RBDPostData
-> Method
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeSinglepart Cookies
cookiesForPath RBDPostData
rbdPostData Method
rbdMethod RequestHeaders
rbdHeaders Text
path Query
rbdGets
multipart :: [RequestPart] -> SRequest
multipart [RequestPart]
x = Cookies
-> [RequestPart]
-> Method
-> RequestHeaders
-> Text
-> Query
-> SRequest
forall a0.
Map a0 SetCookie
-> [RequestPart]
-> Method
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeMultipart Cookies
cookiesForPath [RequestPart]
x Method
rbdMethod RequestHeaders
rbdHeaders Text
path Query
rbdGets
SResponse
response <- IO SResponse -> SIO (YesodExampleData site) SResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SResponse -> SIO (YesodExampleData site) SResponse)
-> IO SResponse -> SIO (YesodExampleData site) SResponse
forall a b. (a -> b) -> a -> b
$ Session SResponse -> Application -> IO SResponse
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 (RequestHeaders -> [SetCookie]) -> RequestHeaders -> [SetCookie]
forall a b. (a -> b) -> a -> b
$ SResponse -> RequestHeaders
simpleHeaders SResponse
response
cookies' :: Cookies
cookies' = [(Method, SetCookie)] -> Cookies
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(SetCookie -> Method
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
YesodExampleData site -> YesodExample site ()
forall s. s -> SIO s ()
putSIO (YesodExampleData site -> YesodExample site ())
-> YesodExampleData site -> YesodExample site ()
forall a b. (a -> b) -> a -> b
$ Application
-> site -> Cookies -> Maybe SResponse -> YesodExampleData site
forall site.
Application
-> site -> Cookies -> Maybe SResponse -> YesodExampleData site
YesodExampleData Application
app site
site Cookies
cookies' (SResponse -> Maybe SResponse
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 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
t'
checkCookiePath :: Text -> SetCookie -> Bool
checkCookiePath Text
url SetCookie
c =
case SetCookie -> Maybe Method
Cookie.setCookiePath SetCookie
c of
Maybe Method
Nothing -> Bool
True
Just Method
x -> Method
x Method -> Method -> Bool
`BS8.isPrefixOf` Text -> Method
TE.encodeUtf8 Text
url
boundary :: String
boundary :: String
boundary = String
"*******noneedtomakethisrandom"
separator :: Method
separator = [Method] -> Method
BS8.concat [Method
"--", String -> Method
BS8.pack String
boundary, Method
"\r\n"]
makeMultipart :: M.Map a0 Cookie.SetCookie
-> [RequestPart]
-> H.Method
-> [H.Header]
-> T.Text
-> H.Query
-> SRequest
makeMultipart :: Map a0 SetCookie
-> [RequestPart]
-> Method
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeMultipart Map a0 SetCookie
cookies [RequestPart]
parts Method
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 =
[Method] -> HtmlLBS
BSL8.fromChunks [[RequestPart] -> Method
multiPartBody [RequestPart]
x]
simpleRequest' :: Request
simpleRequest' = RequestHeaders
-> Method -> RequestHeaders -> Text -> Query -> Request
mkRequest
[ (HeaderName
"Cookie", Method
cookieValue)
, (HeaderName
"Content-Type", Method
contentTypeValue)]
Method
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery
cookieValue :: Method
cookieValue = Builder -> Method
Builder.toByteString (Builder -> Method) -> Builder -> Method
forall a b. (a -> b) -> a -> b
$ Cookies -> Builder
Cookie.renderCookies Cookies
cookiePairs
cookiePairs :: Cookies
cookiePairs = [ (SetCookie -> Method
Cookie.setCookieName SetCookie
c, SetCookie -> Method
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 :: Method
contentTypeValue = String -> Method
BS8.pack (String -> Method) -> String -> Method
forall a b. (a -> b) -> a -> b
$ String
"multipart/form-data; boundary=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
boundary
multiPartBody :: [RequestPart] -> Method
multiPartBody [RequestPart]
parts =
[Method] -> Method
BS8.concat ([Method] -> Method) -> [Method] -> Method
forall a b. (a -> b) -> a -> b
$ Method
separator Method -> [Method] -> [Method]
forall a. a -> [a] -> [a]
: [[Method] -> Method
BS8.concat [RequestPart -> Method
multipartPart RequestPart
p, Method
separator] | RequestPart
p <- [RequestPart]
parts]
multipartPart :: RequestPart -> Method
multipartPart (ReqKvPart Text
k Text
v) = [Method] -> Method
BS8.concat
[ Method
"Content-Disposition: form-data; "
, Method
"name=\"", Text -> Method
TE.encodeUtf8 Text
k, Method
"\"\r\n\r\n"
, Text -> Method
TE.encodeUtf8 Text
v, Method
"\r\n"]
multipartPart (ReqFilePart Text
k String
v HtmlLBS
bytes Text
mime) = [Method] -> Method
BS8.concat
[ Method
"Content-Disposition: form-data; "
, Method
"name=\"", Text -> Method
TE.encodeUtf8 Text
k, Method
"\"; "
, Method
"filename=\"", String -> Method
BS8.pack String
v, Method
"\"\r\n"
, Method
"Content-Type: ", Text -> Method
TE.encodeUtf8 Text
mime, Method
"\r\n\r\n"
, [Method] -> Method
BS8.concat ([Method] -> Method) -> [Method] -> Method
forall a b. (a -> b) -> a -> b
$ HtmlLBS -> [Method]
BSL8.toChunks HtmlLBS
bytes, Method
"\r\n"]
makeSinglepart :: M.Map a0 Cookie.SetCookie
-> RBDPostData
-> H.Method
-> [H.Header]
-> T.Text
-> H.Query
-> SRequest
makeSinglepart :: Map a0 SetCookie
-> RBDPostData
-> Method
-> RequestHeaders
-> Text
-> Query
-> SRequest
makeSinglepart Map a0 SetCookie
cookies RBDPostData
rbdPostData Method
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery =
Request -> HtmlLBS -> SRequest
SRequest Request
simpleRequest' (RBDPostData -> HtmlLBS
simpleRequestBody' RBDPostData
rbdPostData)
where
simpleRequest' :: Request
simpleRequest' = (RequestHeaders
-> Method -> RequestHeaders -> Text -> Query -> Request
mkRequest
([ (HeaderName
"Cookie", Method
cookieValue) ] RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RBDPostData -> RequestHeaders
forall a b. (IsString a, IsString b) => RBDPostData -> [(a, b)]
headersForPostData RBDPostData
rbdPostData)
Method
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery)
simpleRequestBody' :: RBDPostData -> HtmlLBS
simpleRequestBody' (MultipleItemsPostData [RequestPart]
x) =
[Method] -> HtmlLBS
BSL8.fromChunks ([Method] -> HtmlLBS) -> [Method] -> HtmlLBS
forall a b. (a -> b) -> a -> b
$ Method -> [Method]
forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> [Method]) -> Method -> [Method]
forall a b. (a -> b) -> a -> b
$ Bool -> Cookies -> Method
H.renderSimpleQuery Bool
False
(Cookies -> Method) -> Cookies -> Method
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 :: Method
cookieValue = Builder -> Method
Builder.toByteString (Builder -> Method) -> Builder -> Method
forall a b. (a -> b) -> a -> b
$ Cookies -> Builder
Cookie.renderCookies Cookies
cookiePairs
cookiePairs :: Cookies
cookiePairs = [ (SetCookie -> Method
Cookie.setCookieName SetCookie
c, SetCookie -> Method
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 -> Method
TE.encodeUtf8 Text
k, Text -> Method
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
-> Method -> RequestHeaders -> Text -> Query -> Request
mkRequest RequestHeaders
headers Method
method RequestHeaders
extraHeaders Text
urlPath Query
urlQuery = Request
defaultRequest
{ requestMethod :: Method
requestMethod = Method
method
, remoteHost :: SockAddr
remoteHost = PortNumber -> HostAddress -> SockAddr
Sock.SockAddrInet PortNumber
1 HostAddress
2
, requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
headers RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RequestHeaders
extraHeaders
, rawPathInfo :: Method
rawPathInfo = Text -> Method
TE.encodeUtf8 Text
urlPath
, pathInfo :: [Text]
pathInfo = Method -> [Text]
H.decodePathSegments (Method -> [Text]) -> Method -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Method
TE.encodeUtf8 Text
urlPath
, rawQueryString :: Method
rawQueryString = Bool -> Query -> Method
H.renderQuery Bool
False Query
urlQuery
, queryString :: Query
queryString = Query
urlQuery
}
parseSetCookies :: [H.Header] -> [Cookie.SetCookie]
parseSetCookies :: RequestHeaders -> [SetCookie]
parseSetCookies RequestHeaders
headers = (Header -> SetCookie) -> RequestHeaders -> [SetCookie]
forall a b. (a -> b) -> [a] -> [b]
map (Method -> SetCookie
Cookie.parseSetCookie (Method -> SetCookie) -> (Header -> Method) -> Header -> SetCookie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> Method
forall a b. (a, b) -> b
snd) (RequestHeaders -> [SetCookie]) -> RequestHeaders -> [SetCookie]
forall a b. (a -> b) -> a -> b
$ (Header -> 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) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders
headers
failure :: (HasCallStack, MonadIO a) => T.Text -> a b
failure :: Text -> a b
failure Text
reason = (IO Any -> a Any
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Any -> a Any) -> IO Any -> a Any
forall a b. (a -> b) -> a -> b
$ String -> IO Any
forall a. HasCallStack => String -> IO a
HUnit.assertFailure (String -> IO Any) -> String -> IO Any
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
reason) a Any -> 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 :: 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, middleware) -> do
Application
app <- site -> IO Application
forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
site
a
_ <- SIO (YesodExampleData site) a -> YesodExampleData site -> IO a
forall s a. SIO s a -> s -> IO a
evalSIO SIO (YesodExampleData site) a
example YesodExampleData :: forall site.
Application
-> site -> Cookies -> Maybe SResponse -> YesodExampleData site
YesodExampleData
{ yedApp :: Application
yedApp = Middleware
middleware Application
app
, yedSite :: site
yedSite = site
site
, yedCookies :: Cookies
yedCookies = Cookies
forall k a. Map k a
M.empty
, yedResponse :: Maybe SResponse
yedResponse = Maybe SResponse
forall a. Maybe a
Nothing
}
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
Params
params
((() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ ())