{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-unused-imports #-}

module Test.Syd.Yesod.Request where

import Control.Applicative
import Control.Monad.Catch
import Control.Monad.Fail
import Control.Monad.Reader
import Control.Monad.State (MonadState, StateT (..), execStateT)
import qualified Control.Monad.State as State
import Data.ByteString (ByteString)
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy as LB
import Data.CaseInsensitive (CI)
import Data.Functor.Identity
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time
import GHC.Stack
import Network.HTTP.Client as HTTP
import Network.HTTP.Client.Internal (httpRaw, toHttpException)
import Network.HTTP.Client.MultipartFormData
import Network.HTTP.Types as HTTP
import Test.Syd
import Test.Syd.Yesod.Client
import qualified Text.XML.Cursor as C
import Web.Cookie as Cookie
import Yesod.Core as Yesod
import Yesod.Core.Unsafe
import qualified Yesod.Test as YesodTest
import Yesod.Test.TransversingCSS as CSS

-- | Make a @GET@ request for the given route
--
-- > it "returns 200 on the home route" $ do
-- >   get HomeR
-- >   statusIs 200
get :: (Yesod site, RedirectUrl site url) => url -> YesodClientM site ()
get :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodClientM site ()
get = forall site url.
(Yesod site, RedirectUrl site url) =>
Method -> url -> YesodClientM site ()
performMethod Method
methodGet

-- | Make a @POST@ request for the given route
--
-- > it "returns 200 on the start processing route" $ do
-- >   post StartProcessingR
-- >   statusIs 200
post :: (Yesod site, RedirectUrl site url) => url -> YesodClientM site ()
post :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodClientM site ()
post = forall site url.
(Yesod site, RedirectUrl site url) =>
Method -> url -> YesodClientM site ()
performMethod Method
methodPost

-- | Perform a request using an arbitrary method for the given route.
performMethod :: (Yesod site, RedirectUrl site url) => Method -> url -> YesodClientM site ()
performMethod :: forall site url.
(Yesod site, RedirectUrl site url) =>
Method -> url -> YesodClientM site ()
performMethod Method
method url
route = forall site a. RequestBuilder site a -> YesodClientM site ()
request forall a b. (a -> b) -> a -> b
$ do
  forall site url.
(Yesod site, RedirectUrl site url) =>
url -> RequestBuilder site ()
setUrl url
route
  forall site. Method -> RequestBuilder site ()
setMethod Method
method

-- | Synonym of 'statusShouldBe' for compatibility with yesod-test
statusIs :: HasCallStack => Int -> YesodClientM site ()
statusIs :: forall site. HasCallStack => Int -> YesodClientM site ()
statusIs = forall site. HasCallStack => Int -> YesodClientM site ()
statusShouldBe

-- | Assert the status of the most recently received response.
--
-- > it "returns 200 on the home route" $ do
-- >   get HomeR
-- >   statusShouldBe 200
statusShouldBe :: HasCallStack => Int -> YesodClientM site ()
statusShouldBe :: forall site. HasCallStack => Int -> YesodClientM site ()
statusShouldBe Int
expected =
  forall site a. YesodClientM site a -> YesodClientM site a
withLastRequestContext forall a b. (a -> b) -> a -> b
$ do
    Int
actual <- forall site. YesodClientM site Int
requireStatus
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
actual forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
expected

-- | Assert the redirect location of the most recently received response.
--
-- > it "redirects to the overview on the home route" $ do
-- >   get HomeR
-- >   statusIs 301
-- >   locationShouldBe OverviewR
locationShouldBe :: (ParseRoute site, Show (Route site)) => Route site -> YesodClientM localSite ()
locationShouldBe :: forall site localSite.
(ParseRoute site, Show (Route site)) =>
Route site -> YesodClientM localSite ()
locationShouldBe Route site
expected =
  forall site a. YesodClientM site a -> YesodClientM site a
withLastRequestContext forall a b. (a -> b) -> a -> b
$ do
    Route site
actual <- forall site localSite.
ParseRoute site =>
YesodClientM localSite (Route site)
requireLocation
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Route site
actual forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Route site
expected

-- | Assert the last response has the given text.
--
-- The check is performed using the response body in full text form without any html parsing.
bodyContains :: HasCallStack => String -> YesodExample site ()
bodyContains :: forall site. HasCallStack => String -> YesodExample site ()
bodyContains String
text =
  forall site a. YesodClientM site a -> YesodClientM site a
withLastRequestContext forall a b. (a -> b) -> a -> b
$ do
    Response ByteString
resp <- forall site. YesodClientM site (Response ByteString)
requireResponse
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, Show a) =>
a -> String -> (a -> Bool) -> IO ()
shouldSatisfyNamed
        (forall body. Response body -> body
responseBody Response ByteString
resp)
        ([String] -> String
unwords [String
"bodyContains", forall a. Show a => a -> String
show String
text])
        (\ByteString
body -> Text -> Method
TE.encodeUtf8 (String -> Text
T.pack String
text) Method -> Method -> Bool
`SB.isInfixOf` ByteString -> Method
LB.toStrict ByteString
body)

-- | A request builder monad that allows you to monadically build a request using `runRequestBuilder`.
--
-- This request builder has access to the entire `YesodClientM` underneath.
-- This includes the `Site` under test, as well as cookies etc.
--
-- See 'YesodClientM' for more details.
newtype RequestBuilder site a = RequestBuilder
  { forall site a.
RequestBuilder site a
-> StateT (RequestBuilderData site) (YesodClientM site) a
unRequestBuilder ::
      StateT
        (RequestBuilderData site)
        (YesodClientM site)
        a
  }
  deriving
    ( forall a b. a -> RequestBuilder site b -> RequestBuilder site a
forall a b.
(a -> b) -> RequestBuilder site a -> RequestBuilder site b
forall site a b.
a -> RequestBuilder site b -> RequestBuilder site a
forall site a b.
(a -> b) -> RequestBuilder site a -> RequestBuilder site b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RequestBuilder site b -> RequestBuilder site a
$c<$ :: forall site a b.
a -> RequestBuilder site b -> RequestBuilder site a
fmap :: forall a b.
(a -> b) -> RequestBuilder site a -> RequestBuilder site b
$cfmap :: forall site a b.
(a -> b) -> RequestBuilder site a -> RequestBuilder site b
Functor,
      forall site. Functor (RequestBuilder site)
forall a. a -> RequestBuilder site a
forall site a. a -> RequestBuilder site a
forall a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site a
forall a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
forall a b.
RequestBuilder site (a -> b)
-> RequestBuilder site a -> RequestBuilder site b
forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site a
forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
forall site a b.
RequestBuilder site (a -> b)
-> RequestBuilder site a -> RequestBuilder site b
forall a b c.
(a -> b -> c)
-> RequestBuilder site a
-> RequestBuilder site b
-> RequestBuilder site c
forall site a b c.
(a -> b -> c)
-> RequestBuilder site a
-> RequestBuilder site b
-> RequestBuilder site c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site a
$c<* :: forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site a
*> :: forall a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
$c*> :: forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
liftA2 :: forall a b c.
(a -> b -> c)
-> RequestBuilder site a
-> RequestBuilder site b
-> RequestBuilder site c
$cliftA2 :: forall site a b c.
(a -> b -> c)
-> RequestBuilder site a
-> RequestBuilder site b
-> RequestBuilder site c
<*> :: forall a b.
RequestBuilder site (a -> b)
-> RequestBuilder site a -> RequestBuilder site b
$c<*> :: forall site a b.
RequestBuilder site (a -> b)
-> RequestBuilder site a -> RequestBuilder site b
pure :: forall a. a -> RequestBuilder site a
$cpure :: forall site a. a -> RequestBuilder site a
Applicative,
      forall site. Applicative (RequestBuilder site)
forall a. a -> RequestBuilder site a
forall site a. a -> RequestBuilder site a
forall a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
forall a b.
RequestBuilder site a
-> (a -> RequestBuilder site b) -> RequestBuilder site b
forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
forall site a b.
RequestBuilder site a
-> (a -> RequestBuilder site b) -> RequestBuilder site b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> RequestBuilder site a
$creturn :: forall site a. a -> RequestBuilder site a
>> :: forall a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
$c>> :: forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
>>= :: forall a b.
RequestBuilder site a
-> (a -> RequestBuilder site b) -> RequestBuilder site b
$c>>= :: forall site a b.
RequestBuilder site a
-> (a -> RequestBuilder site b) -> RequestBuilder site b
Monad,
      forall site. Monad (RequestBuilder site)
forall a. IO a -> RequestBuilder site a
forall site a. IO a -> RequestBuilder site a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> RequestBuilder site a
$cliftIO :: forall site a. IO a -> RequestBuilder site a
MonadIO,
      MonadReader (YesodClient site),
      MonadState (RequestBuilderData site),
      forall site. Monad (RequestBuilder site)
forall a. String -> RequestBuilder site a
forall site a. String -> RequestBuilder site a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> RequestBuilder site a
$cfail :: forall site a. String -> RequestBuilder site a
MonadFail,
      forall site. Monad (RequestBuilder site)
forall e a. Exception e => e -> RequestBuilder site a
forall site e a. Exception e => e -> RequestBuilder site a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> RequestBuilder site a
$cthrowM :: forall site e a. Exception e => e -> RequestBuilder site a
MonadThrow
    )

-- | Run a 'YesodClientM' function as part of a 'RequestBuilder'.
liftClient :: YesodClientM site a -> RequestBuilder site a
liftClient :: forall site a. YesodClientM site a -> RequestBuilder site a
liftClient = forall site a.
StateT (RequestBuilderData site) (YesodClientM site) a
-> RequestBuilder site a
RequestBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

data RequestBuilderData site = RequestBuilderData
  { forall site. RequestBuilderData site -> Method
requestBuilderDataMethod :: !Method,
    forall site. RequestBuilderData site -> Text
requestBuilderDataUrl :: !Text,
    forall site. RequestBuilderData site -> RequestHeaders
requestBuilderDataHeaders :: !HTTP.RequestHeaders,
    forall site. RequestBuilderData site -> Query
requestBuilderDataGetParams :: !HTTP.Query,
    forall site. RequestBuilderData site -> PostData
requestBuilderDataPostData :: !PostData
  }

data PostData
  = MultipleItemsPostData [RequestPart]
  | BinaryPostData ByteString

data RequestPart
  = ReqKvPart Text Text
  | ReqFilePart Text FilePath ByteString (Maybe Text)

initialRequestBuilderData :: RequestBuilderData site
initialRequestBuilderData :: forall site. RequestBuilderData site
initialRequestBuilderData =
  RequestBuilderData
    { requestBuilderDataMethod :: Method
requestBuilderDataMethod = Method
"GET",
      requestBuilderDataUrl :: Text
requestBuilderDataUrl = Text
"",
      requestBuilderDataHeaders :: RequestHeaders
requestBuilderDataHeaders = [],
      requestBuilderDataGetParams :: Query
requestBuilderDataGetParams = [],
      requestBuilderDataPostData :: PostData
requestBuilderDataPostData = [RequestPart] -> PostData
MultipleItemsPostData []
    }

isFile :: RequestPart -> Bool
isFile :: RequestPart -> Bool
isFile = \case
  ReqKvPart {} -> Bool
False
  ReqFilePart {} -> Bool
True

-- | Run a 'RequestBuilder' to make the 'Request' that it defines.
runRequestBuilder :: RequestBuilder site a -> YesodClientM site Request
runRequestBuilder :: forall site a. RequestBuilder site a -> YesodClientM site Request
runRequestBuilder (RequestBuilder StateT (RequestBuilderData site) (YesodClientM site) a
func) = do
  URI
baseURI <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall site. YesodClient site -> URI
yesodClientSiteURI
  RequestBuilderData {Query
RequestHeaders
Method
Text
PostData
requestBuilderDataPostData :: PostData
requestBuilderDataGetParams :: Query
requestBuilderDataHeaders :: RequestHeaders
requestBuilderDataUrl :: Text
requestBuilderDataMethod :: Method
requestBuilderDataPostData :: forall site. RequestBuilderData site -> PostData
requestBuilderDataGetParams :: forall site. RequestBuilderData site -> Query
requestBuilderDataHeaders :: forall site. RequestBuilderData site -> RequestHeaders
requestBuilderDataUrl :: forall site. RequestBuilderData site -> Text
requestBuilderDataMethod :: forall site. RequestBuilderData site -> Method
..} <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT StateT (RequestBuilderData site) (YesodClientM site) a
func forall site. RequestBuilderData site
initialRequestBuilderData
  let requestStr :: String
requestStr = Text -> String
T.unpack Text
requestBuilderDataUrl

  -- We try without the base URI first, just in case:
  --
  -- There is an absolute URI in a redirect that we're following
  -- OR
  -- you want to contact any URI other than the server under test
  Request
req <- case forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
requestStr of
    Just Request
req -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
    Maybe Request
Nothing ->
      case forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show URI
baseURI forall a. Semigroup a => a -> a -> a
<> String
requestStr of
        Maybe Request
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Failed to parse url: " forall a. Semigroup a => a -> a -> a
<> String
requestStr
        Just Request
req -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
  Method
boundary <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Method
webkitBoundary
  (RequestBody
body, Maybe Method
contentTypeHeader) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case PostData
requestBuilderDataPostData of
    MultipleItemsPostData [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Method -> RequestBody
RequestBodyBS Method
SB.empty, forall a. Maybe a
Nothing)
    MultipleItemsPostData [RequestPart]
dat ->
      if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RequestPart -> Bool
isFile [RequestPart]
dat
        then do
          RequestBody
ps <-
            forall (m :: * -> *).
Applicative m =>
Method -> [PartM m] -> m RequestBody
renderParts
              Method
boundary
              ( forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [RequestPart]
dat forall a b. (a -> b) -> a -> b
$ \case
                  ReqKvPart Text
k Text
v -> forall (m :: * -> *). Applicative m => Text -> Method -> PartM m
partBS Text
k (Text -> Method
TE.encodeUtf8 Text
v)
                  ReqFilePart Text
k String
path Method
contents Maybe Text
mime ->
                    (forall (m :: * -> *).
Applicative m =>
Text -> String -> RequestBody -> PartM m
partFileRequestBody Text
k String
path (Method -> RequestBody
RequestBodyBS Method
contents))
                      { partContentType :: Maybe Method
partContentType = Text -> Method
TE.encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mime
                      }
              )
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( RequestBody
ps,
              forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Method
"multipart/form-data; boundary=" forall a. Semigroup a => a -> a -> a
<> Method
boundary
            )
        else
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Method -> RequestBody
RequestBodyBS forall a b. (a -> b) -> a -> b
$
                Bool -> SimpleQuery -> Method
renderSimpleQuery Bool
False forall a b. (a -> b) -> a -> b
$
                  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [RequestPart]
dat forall a b. (a -> b) -> a -> b
$ \case
                    ReqKvPart Text
k Text
v -> forall a. a -> Maybe a
Just (Text -> Method
TE.encodeUtf8 Text
k, Text -> Method
TE.encodeUtf8 Text
v)
                    ReqFilePart {} -> forall a. Maybe a
Nothing,
              forall a. a -> Maybe a
Just Method
"application/x-www-form-urlencoded"
            )
    BinaryPostData Method
sb -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Method -> RequestBody
RequestBodyBS Method
sb, forall a. Maybe a
Nothing)
  CookieJar
cj <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets YesodClientState -> CookieJar
yesodClientStateCookies
  UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let (Request
req', CookieJar
cj') =
        Request -> CookieJar -> UTCTime -> (Request, CookieJar)
insertCookiesIntoRequest
          ( Request
req
              { method :: Method
method = Method
requestBuilderDataMethod,
                requestHeaders :: RequestHeaders
requestHeaders =
                  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ RequestHeaders
requestBuilderDataHeaders,
                      [(HeaderName
"Content-Type", Method
cth) | Method
cth <- forall a. Maybe a -> [a]
maybeToList Maybe Method
contentTypeHeader]
                    ],
                requestBody :: RequestBody
requestBody = RequestBody
body,
                queryString :: Method
queryString = Bool -> Query -> Method
HTTP.renderQuery Bool
False Query
requestBuilderDataGetParams
              }
          )
          CookieJar
cj
          UTCTime
now
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (\YesodClientState
s -> YesodClientState
s {yesodClientStateCookies :: CookieJar
yesodClientStateCookies = CookieJar
cj'})
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req'

-- | Perform the request that is built by the given 'RequestBuilder'.
--
-- > it "returns 200 on this post request" $ do
-- >   request $ do
-- >     setUrl StartProcessingR
-- >     setMethod "POST"
-- >     addPostParam "key" "value"
-- >   statusIs 200
request :: RequestBuilder site a -> YesodClientM site ()
request :: forall site a. RequestBuilder site a -> YesodClientM site ()
request RequestBuilder site a
rb = do
  Request
req <- forall site a. RequestBuilder site a -> YesodClientM site Request
runRequestBuilder RequestBuilder site a
rb
  forall site. Request -> YesodClientM site ()
performRequest Request
req

-- | Set the url of the 'RequestBuilder' to the given route.
setUrl :: (Yesod site, RedirectUrl site url) => url -> RequestBuilder site ()
setUrl :: forall site url.
(Yesod site, RedirectUrl site url) =>
url -> RequestBuilder site ()
setUrl url
route = do
  site
site <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall site. YesodClient site -> site
yesodClientSite
  Right Text
url <-
    forall site (m :: * -> *) a.
(Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> HandlerFor site a
-> m (Either ErrorResponse a)
Yesod.Core.Unsafe.runFakeHandler
      forall k a. Map k a
M.empty
      (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"Test.Syd.Yesod: No logger available")
      site
site
      (forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
toTextUrl url
route)
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify'
    ( \RequestBuilderData site
oldReq ->
        RequestBuilderData site
oldReq
          { requestBuilderDataUrl :: Text
requestBuilderDataUrl = Text
url
          }
    )

-- | Set the method of the 'RequestBuilder'.
setMethod :: Method -> RequestBuilder site ()
setMethod :: forall site. Method -> RequestBuilder site ()
setMethod Method
m = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (\RequestBuilderData site
r -> RequestBuilderData site
r {requestBuilderDataMethod :: Method
requestBuilderDataMethod = Method
m})

-- | Add the given request header to the 'RequestBuilder'.
addRequestHeader :: HTTP.Header -> RequestBuilder site ()
addRequestHeader :: forall site. Header -> RequestBuilder site ()
addRequestHeader Header
h = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (\RequestBuilderData site
r -> RequestBuilderData site
r {requestBuilderDataHeaders :: RequestHeaders
requestBuilderDataHeaders = Header
h forall a. a -> [a] -> [a]
: forall site. RequestBuilderData site -> RequestHeaders
requestBuilderDataHeaders RequestBuilderData site
r})

-- | Add the given GET parameter to the 'RequestBuilder'.
addGetParam :: Text -> Text -> RequestBuilder site ()
addGetParam :: forall site. Text -> Text -> RequestBuilder site ()
addGetParam Text
k Text
v = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (\RequestBuilderData site
r -> RequestBuilderData site
r {requestBuilderDataGetParams :: Query
requestBuilderDataGetParams = (Text -> Method
TE.encodeUtf8 Text
k, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Method
TE.encodeUtf8 Text
v) forall a. a -> [a] -> [a]
: forall site. RequestBuilderData site -> Query
requestBuilderDataGetParams RequestBuilderData site
r})

-- | Add the given POST parameter to the 'RequestBuilder'.
addPostParam :: Text -> Text -> RequestBuilder site ()
addPostParam :: forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
name Text
value =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
r -> RequestBuilderData site
r {requestBuilderDataPostData :: PostData
requestBuilderDataPostData = PostData -> PostData
addPostData (forall site. RequestBuilderData site -> PostData
requestBuilderDataPostData RequestBuilderData site
r)}
  where
    addPostData :: PostData -> PostData
addPostData (BinaryPostData Method
_) = forall a. HasCallStack => String -> a
error String
"Trying to add post param to binary content."
    addPostData (MultipleItemsPostData [RequestPart]
posts) =
      [RequestPart] -> PostData
MultipleItemsPostData forall a b. (a -> b) -> a -> b
$ Text -> Text -> RequestPart
ReqKvPart Text
name Text
value forall a. a -> [a] -> [a]
: [RequestPart]
posts

addFile ::
  -- | The parameter name for the file.
  Text ->
  -- | The path to the file.
  FilePath ->
  -- | The MIME type of the file, e.g. "image/png".
  Text ->
  RequestBuilder site ()
addFile :: forall site. Text -> String -> Text -> RequestBuilder site ()
addFile Text
name String
path Text
mimetype = do
  Method
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Method
SB.readFile String
path
  forall site.
Text -> String -> Method -> Maybe Text -> RequestBuilder site ()
addFileWith Text
name String
path Method
contents (forall a. a -> Maybe a
Just Text
mimetype)

addFileWith ::
  -- | The parameter name for the file.
  Text ->
  -- | The path to the file.
  FilePath ->
  -- | The contents of the file.
  ByteString ->
  -- | The MIME type of the file, e.g. "image/png".
  Maybe Text ->
  RequestBuilder site ()
addFileWith :: forall site.
Text -> String -> Method -> Maybe Text -> RequestBuilder site ()
addFileWith Text
name String
path Method
contents Maybe Text
mMimetype =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
r -> RequestBuilderData site
r {requestBuilderDataPostData :: PostData
requestBuilderDataPostData = PostData -> PostData
addPostData (forall site. RequestBuilderData site -> PostData
requestBuilderDataPostData RequestBuilderData site
r)}
  where
    addPostData :: PostData -> PostData
addPostData (BinaryPostData Method
_) = forall a. HasCallStack => String -> a
error String
"Trying to add file after setting binary content."
    addPostData (MultipleItemsPostData [RequestPart]
posts) =
      [RequestPart] -> PostData
MultipleItemsPostData forall a b. (a -> b) -> a -> b
$ Text -> String -> Method -> Maybe Text -> RequestPart
ReqFilePart Text
name String
path Method
contents Maybe Text
mMimetype forall a. a -> [a] -> [a]
: [RequestPart]
posts

-- | Set the request body of the 'RequestBuilder'.
--
-- Note that this invalidates any of the other post parameters that may have been set.
setRequestBody :: ByteString -> RequestBuilder site ()
setRequestBody :: forall site. Method -> RequestBuilder site ()
setRequestBody Method
body = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
r -> RequestBuilderData site
r {requestBuilderDataPostData :: PostData
requestBuilderDataPostData = Method -> PostData
BinaryPostData Method
body}

-- | Look up the CSRF token from the given form data and add it to the request header
addToken_ :: HasCallStack => Text -> RequestBuilder site ()
addToken_ :: forall site. HasCallStack => Text -> RequestBuilder site ()
addToken_ Text
scope = do
  [ByteString]
matches <- forall site a. YesodClientM site a -> RequestBuilder site a
liftClient forall a b. (a -> b) -> a -> b
$ forall site. HasCallStack => Text -> YesodExample site [ByteString]
htmlQuery forall a b. (a -> b) -> a -> b
$ Text
scope forall a. Semigroup a => a -> a -> a
<> Text
" input[name=_token][type=hidden][value]"
  case [ByteString]
matches of
    [] -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure String
"No CSRF token found in the current page"
    [ByteString
element] -> do
      Text
t <- case forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
C.attribute Name
"value" forall a b. (a -> b) -> a -> b
$ ByteString -> Cursor
YesodTest.parseHTML ByteString
element of
        Maybe Text
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure String
"Expected a value attribute"
        Just Text
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
      forall site. Text -> Text -> RequestBuilder site ()
addPostParam Text
"_token" Text
t
    [ByteString]
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure String
"More than one CSRF token found in the page"

-- | Look up the CSRF token from the only form data and add it to the request header
addToken :: HasCallStack => RequestBuilder site ()
addToken :: forall site. HasCallStack => RequestBuilder site ()
addToken = forall site. HasCallStack => Text -> RequestBuilder site ()
addToken_ Text
""

-- | Look up the CSRF token from the cookie with name 'defaultCsrfCookieName' and add it to the request header with name 'defaultCsrfHeaderName'.
addTokenFromCookie :: HasCallStack => RequestBuilder site ()
addTokenFromCookie :: forall site. HasCallStack => RequestBuilder site ()
addTokenFromCookie = forall site.
HasCallStack =>
Method -> HeaderName -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed Method
defaultCsrfCookieName HeaderName
defaultCsrfHeaderName

-- | Looks up the CSRF token stored in the cookie with the given name and adds it to the given request header.
addTokenFromCookieNamedToHeaderNamed ::
  HasCallStack =>
  -- | The name of the cookie
  ByteString ->
  -- | The name of the header
  CI ByteString ->
  RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed :: forall site.
HasCallStack =>
Method -> HeaderName -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed Method
cookieName HeaderName
headerName = do
  Map Method SetCookie
cookies <- forall site. RequestBuilder site (Map Method SetCookie)
getRequestCookies
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Method
cookieName Map Method SetCookie
cookies of
    Just SetCookie
csrfCookie -> forall site. Header -> RequestBuilder site ()
addRequestHeader (HeaderName
headerName, SetCookie -> Method
setCookieValue SetCookie
csrfCookie)
    Maybe SetCookie
Nothing ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"addTokenFromCookieNamedToHeaderNamed failed to lookup CSRF cookie with name: ",
              forall a. Show a => a -> String
show Method
cookieName,
              String
". Cookies were: ",
              forall a. Show a => a -> String
show Map Method SetCookie
cookies
            ]

-- | Perform the given request as-is.
--
-- Note that this function does not check whether you are making a request to the site under test.
-- You could make a request to https://example.com if you wanted.
performRequest :: Request -> YesodClientM site ()
performRequest :: forall site. Request -> YesodClientM site ()
performRequest Request
req = do
  Manager
man <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall site. YesodClient site -> Manager
yesodClientManager
  Either HttpException (Response ByteString)
errOrResp <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Request -> Manager -> IO (Response (IO Method))
httpRaw Request
req Manager
man forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Method] -> ByteString
LB.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Method -> IO [Method]
brConsume)))
        forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
`catches` [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \HttpExceptionContentWrapper
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContentWrapper -> HttpException
toHttpException Request
req HttpExceptionContentWrapper
e,
                    forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \HttpException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (HttpException
e :: HttpException)
                  ]
  case Either HttpException (Response ByteString)
errOrResp of
    Left HttpException
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"HTTPException: " forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
displayException HttpException
err
    Right Response ByteString
resp -> do
      CookieJar
cj <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets YesodClientState -> CookieJar
yesodClientStateCookies
      UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let (CookieJar
cj', Response ByteString
_) = forall a.
Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
updateCookieJar Response ByteString
resp Request
req UTCTime
now CookieJar
cj
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify'
        ( \YesodClientState
s ->
            YesodClientState
s
              { yesodClientStateLast :: Maybe (Request, Response ByteString)
yesodClientStateLast = forall a. a -> Maybe a
Just (Request
req, Response ByteString
resp),
                yesodClientStateCookies :: CookieJar
yesodClientStateCookies = CookieJar
cj'
              }
        )

-- | For backward compatibiilty, you can use the 'MonadState' constraint to get access to the 'CookieJar' directly.
getRequestCookies :: RequestBuilder site (Map ByteString SetCookie)
getRequestCookies :: forall site. RequestBuilder site (Map Method SetCookie)
getRequestCookies = do
  CookieJar
cj <- forall site a. YesodClientM site a -> RequestBuilder site a
liftClient forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets YesodClientState -> CookieJar
yesodClientStateCookies
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (CookieJar -> [Cookie]
destroyCookieJar CookieJar
cj) forall a b. (a -> b) -> a -> b
$ \Cookie {Bool
UTCTime
Method
cookie_name :: Cookie -> Method
cookie_value :: Cookie -> Method
cookie_expiry_time :: Cookie -> UTCTime
cookie_domain :: Cookie -> Method
cookie_path :: Cookie -> Method
cookie_creation_time :: Cookie -> UTCTime
cookie_last_access_time :: Cookie -> UTCTime
cookie_persistent :: Cookie -> Bool
cookie_host_only :: Cookie -> Bool
cookie_secure_only :: Cookie -> Bool
cookie_http_only :: Cookie -> Bool
cookie_http_only :: Bool
cookie_secure_only :: Bool
cookie_host_only :: Bool
cookie_persistent :: Bool
cookie_last_access_time :: UTCTime
cookie_creation_time :: UTCTime
cookie_path :: Method
cookie_domain :: Method
cookie_expiry_time :: UTCTime
cookie_value :: Method
cookie_name :: Method
..} ->
        ( Method
cookie_name,
          SetCookie
defaultSetCookie
            { setCookieName :: Method
setCookieName = Method
cookie_name,
              setCookieValue :: Method
setCookieValue = Method
cookie_value
            }
        )

-- | Query the last response using CSS selectors, returns a list of matched fragments
htmlQuery :: HasCallStack => CSS.Query -> YesodExample site [CSS.HtmlLBS]
htmlQuery :: forall site. HasCallStack => Text -> YesodExample site [ByteString]
htmlQuery Text
query = do
  Maybe (Response ByteString)
mResp <- forall site. YesodClientM site (Maybe (Response ByteString))
getResponse
  case Maybe (Response ByteString)
mResp of
    Maybe (Response ByteString)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure String
"No request made yet."
    Just Response ByteString
resp -> case ByteString -> Text -> Either String [String]
CSS.findBySelector (forall body. Response body -> body
responseBody Response ByteString
resp) Text
query of
      Left String
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Text
query forall a. Semigroup a => a -> a -> a
<> String
" did not parse: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
err
      Right [String]
matches -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Method -> ByteString
LB.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Method
TE.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [String]
matches

-- | Follow a redirect, if the last response was a redirect.
--
-- (We consider a request a redirect if the status is
-- 301, 302, 303, 307 or 308, and the Location header is set.)
--
-- >  it "redirects home" $ do
-- >    get RedirectHomeR
-- >    statusIs 303
-- >    locationShouldBe HomeR
-- >    _ <- followRedirect
-- >    statusIs 200
followRedirect ::
  Yesod site =>
  -- | 'Left' with an error message if not a redirect, 'Right' with the redirected URL if it was
  YesodExample site (Either Text Text)
followRedirect :: forall site. Yesod site => YesodExample site (Either Text Text)
followRedirect = do
  Response ByteString
r <- forall site. YesodClientM site (Response ByteString)
requireResponse
  if Status -> Int
HTTP.statusCode (forall body. Response body -> Status
responseStatus Response ByteString
r) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int
301, Int
302, Int
303, Int
307, Int
308]
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"followRedirect called, but previous request was not a redirect"
    else do
      case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" (forall body. Response body -> RequestHeaders
responseHeaders Response ByteString
r) of
        Maybe Method
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"followRedirect called, but no location header set"
        Just Method
h ->
          let url :: Text
url = Method -> Text
TE.decodeUtf8 Method
h
           in forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodClientM site ()
get Text
url forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Text
url)

followRedirect_ ::
  Yesod site =>
  YesodExample site ()
followRedirect_ :: forall site. Yesod site => YesodExample site ()
followRedirect_ = do
  Either Text Text
errOrRedirect <- forall site. Yesod site => YesodExample site (Either Text Text)
followRedirect
  case Either Text Text
errOrRedirect of
    Left Text
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure (Text -> String
T.unpack Text
err)
    Right Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()