{-# 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)
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
--
-- > yit "returns 200 on the home route" $ do
-- >   get HomeR
-- >   statusIs 200
get :: (Yesod site, RedirectUrl site url) => url -> YesodClientM site ()
get :: url -> YesodClientM site ()
get = Method -> url -> YesodClientM site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
Method -> url -> YesodClientM site ()
performMethod Method
methodGet

-- | Make a @POST@ request for the given route
--
-- > yit "returns 200 on the start processing route" $ do
-- >   post StartProcessingR
-- >   statusIs 200
post :: (Yesod site, RedirectUrl site url) => url -> YesodClientM site ()
post :: url -> YesodClientM site ()
post = Method -> url -> YesodClientM site ()
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 :: Method -> url -> YesodClientM site ()
performMethod Method
method url
route = RequestBuilder site () -> YesodClientM site ()
forall site a. RequestBuilder site a -> YesodClientM site ()
request (RequestBuilder site () -> YesodClientM site ())
-> RequestBuilder site () -> YesodClientM site ()
forall a b. (a -> b) -> a -> b
$ do
  url -> RequestBuilder site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> RequestBuilder site ()
setUrl url
route
  Method -> RequestBuilder site ()
forall site. Method -> RequestBuilder site ()
setMethod Method
method

-- | Assert the status of the most recently received response.
--
-- > yit "returns 200 on the home route" $ do
-- >   get HomeR
-- >   statusIs 200
statusIs :: HasCallStack => Int -> YesodClientM site ()
statusIs :: Int -> YesodClientM site ()
statusIs Int
i = do
  Maybe (Request, Response ByteString)
mLast <- YesodClientM site (Maybe (Request, Response ByteString))
forall site.
YesodClientM site (Maybe (Request, Response ByteString))
getLast
  case Maybe (Request, Response ByteString)
mLast of
    Maybe (Request, Response ByteString)
Nothing -> IO () -> YesodClientM site ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodClientM site ()) -> IO () -> YesodClientM site ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> IO a
expectationFailure String
"statusIs: No request made yet."
    Just (Request
_, Response ByteString
resp) ->
      let c :: Int
c = Status -> Int
statusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp)
       in YesodClientM site () -> YesodClientM site ()
forall site a. YesodClientM site a -> YesodClientM site a
withLastRequestContext (YesodClientM site () -> YesodClientM site ())
-> YesodClientM site () -> YesodClientM site ()
forall a b. (a -> b) -> a -> b
$ IO () -> YesodClientM site ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodClientM site ()) -> IO () -> YesodClientM site ()
forall a b. (a -> b) -> a -> b
$ Int
c Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
i

-- | Assert the redirect location of the most recently received response.
--
-- > yit "redirects to the overview on the home route" $ do
-- >   get HomeR
-- >   statusIs 301
-- >   locationShouldBe OverviewR
locationShouldBe :: (ParseRoute site, Show (Route site)) => Route site -> YesodClientM site ()
locationShouldBe :: Route site -> YesodClientM site ()
locationShouldBe Route site
expected =
  YesodClientM site () -> YesodClientM site ()
forall site a. YesodClientM site a -> YesodClientM site a
withLastRequestContext (YesodClientM site () -> YesodClientM site ())
-> YesodClientM site () -> YesodClientM site ()
forall a b. (a -> b) -> a -> b
$ do
    Either Text (Route site)
errOrLoc <- YesodClientM site (Either Text (Route site))
forall site.
ParseRoute site =>
YesodClientM site (Either Text (Route site))
getLocation
    IO () -> YesodClientM site ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> YesodClientM site ()) -> IO () -> YesodClientM site ()
forall a b. (a -> b) -> a -> b
$ case Either Text (Route site)
errOrLoc of
      Left Text
err -> String -> IO ()
forall a. HasCallStack => String -> IO a
expectationFailure (Text -> String
T.unpack Text
err)
      Right Route site
actual -> Route site
expected Route site -> Route site -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Route site
actual

-- | 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 :: String -> YesodExample site ()
bodyContains String
text = do
  Maybe (Request, Response ByteString)
mResp <- YesodClientM site (Maybe (Request, Response ByteString))
forall site.
YesodClientM site (Maybe (Request, Response ByteString))
getLast
  case Maybe (Request, Response ByteString)
mResp of
    Maybe (Request, Response ByteString)
Nothing -> 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 -> IO ()
forall a. HasCallStack => String -> IO a
expectationFailure String
"bodyContains: No request made yet."
    Just (Request
_, Response ByteString
resp) ->
      YesodExample site () -> YesodExample site ()
forall site a. YesodClientM site a -> YesodClientM site a
withLastRequestContext (YesodExample site () -> YesodExample site ())
-> YesodExample site () -> YesodExample site ()
forall a b. (a -> b) -> 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
$
          ByteString -> String -> (ByteString -> Bool) -> IO ()
forall a.
(HasCallStack, Show a) =>
a -> String -> (a -> Bool) -> IO ()
shouldSatisfyNamed (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp) ([String] -> String
unwords [String
"bodyContains", String -> String
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
  { RequestBuilder site a
-> StateT (RequestBuilderData site) (YesodClientM site) a
unRequestBuilder ::
      StateT
        (RequestBuilderData site)
        (YesodClientM site)
        a
  }
  deriving
    ( a -> RequestBuilder site b -> RequestBuilder site a
(a -> b) -> RequestBuilder site a -> RequestBuilder site b
(forall a b.
 (a -> b) -> RequestBuilder site a -> RequestBuilder site b)
-> (forall a b.
    a -> RequestBuilder site b -> RequestBuilder site a)
-> Functor (RequestBuilder site)
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
<$ :: a -> RequestBuilder site b -> RequestBuilder site a
$c<$ :: forall site a b.
a -> RequestBuilder site b -> RequestBuilder site a
fmap :: (a -> b) -> RequestBuilder site a -> RequestBuilder site b
$cfmap :: forall site a b.
(a -> b) -> RequestBuilder site a -> RequestBuilder site b
Functor,
      Functor (RequestBuilder site)
a -> RequestBuilder site a
Functor (RequestBuilder site)
-> (forall a. a -> RequestBuilder site a)
-> (forall 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 a b.
    RequestBuilder site a
    -> RequestBuilder site b -> RequestBuilder site b)
-> (forall a b.
    RequestBuilder site a
    -> RequestBuilder site b -> RequestBuilder site a)
-> Applicative (RequestBuilder site)
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site a
RequestBuilder site (a -> b)
-> RequestBuilder site a -> RequestBuilder site b
(a -> b -> c)
-> RequestBuilder site a
-> RequestBuilder site b
-> RequestBuilder site c
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
<* :: RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site a
$c<* :: forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site a
*> :: RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
$c*> :: forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
liftA2 :: (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
<*> :: 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 :: a -> RequestBuilder site a
$cpure :: forall site a. a -> RequestBuilder site a
$cp1Applicative :: forall site. Functor (RequestBuilder site)
Applicative,
      Applicative (RequestBuilder site)
a -> RequestBuilder site a
Applicative (RequestBuilder site)
-> (forall a b.
    RequestBuilder site a
    -> (a -> RequestBuilder site b) -> RequestBuilder site b)
-> (forall a b.
    RequestBuilder site a
    -> RequestBuilder site b -> RequestBuilder site b)
-> (forall a. a -> RequestBuilder site a)
-> Monad (RequestBuilder site)
RequestBuilder site a
-> (a -> RequestBuilder site b) -> RequestBuilder site b
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
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 :: a -> RequestBuilder site a
$creturn :: forall site a. a -> RequestBuilder site a
>> :: RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site b
$c>> :: forall site a b.
RequestBuilder site a
-> RequestBuilder site b -> RequestBuilder site 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
$cp1Monad :: forall site. Applicative (RequestBuilder site)
Monad,
      Monad (RequestBuilder site)
Monad (RequestBuilder site)
-> (forall a. IO a -> RequestBuilder site a)
-> MonadIO (RequestBuilder site)
IO a -> RequestBuilder site a
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 :: IO a -> RequestBuilder site a
$cliftIO :: forall site a. IO a -> RequestBuilder site a
$cp1MonadIO :: forall site. Monad (RequestBuilder site)
MonadIO,
      MonadReader (YesodClient site),
      MonadState (RequestBuilderData site),
      Monad (RequestBuilder site)
Monad (RequestBuilder site)
-> (forall a. String -> RequestBuilder site a)
-> MonadFail (RequestBuilder site)
String -> RequestBuilder site a
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 :: String -> RequestBuilder site a
$cfail :: forall site a. String -> RequestBuilder site a
$cp1MonadFail :: forall site. Monad (RequestBuilder site)
MonadFail,
      Monad (RequestBuilder site)
e -> RequestBuilder site a
Monad (RequestBuilder site)
-> (forall e a. Exception e => e -> RequestBuilder site a)
-> MonadThrow (RequestBuilder site)
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 :: e -> RequestBuilder site a
$cthrowM :: forall site e a. Exception e => e -> RequestBuilder site a
$cp1MonadThrow :: forall site. Monad (RequestBuilder site)
MonadThrow
    )

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

data RequestBuilderData site = RequestBuilderData
  { RequestBuilderData site -> Method
requestBuilderDataMethod :: !Method,
    RequestBuilderData site -> Text
requestBuilderDataUrl :: !Text,
    RequestBuilderData site -> RequestHeaders
requestBuilderDataHeaders :: !HTTP.RequestHeaders,
    RequestBuilderData site -> Query
requestBuilderDataGetParams :: !HTTP.Query,
    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 :: RequestBuilderData site
initialRequestBuilderData =
  RequestBuilderData :: forall site.
Method
-> Text
-> RequestHeaders
-> Query
-> PostData
-> RequestBuilderData site
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 :: RequestBuilder site a -> YesodClientM site Request
runRequestBuilder (RequestBuilder StateT (RequestBuilderData site) (YesodClientM site) a
func) = do
  Int
p <- (YesodClient site -> Int) -> YesodClientM site Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks YesodClient site -> Int
forall site. YesodClient site -> Int
yesodClientSitePort
  CookieJar
cj <- (YesodClientState site -> CookieJar) -> YesodClientM site CookieJar
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets YesodClientState site -> CookieJar
forall site. YesodClientState site -> CookieJar
yesodClientStateCookies
  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
..} <- StateT (RequestBuilderData site) (YesodClientM site) a
-> RequestBuilderData site
-> YesodClientM site (RequestBuilderData site)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT StateT (RequestBuilderData site) (YesodClientM site) a
func RequestBuilderData site
forall site. RequestBuilderData site
initialRequestBuilderData
  let requestStr :: String
requestStr = Text -> String
T.unpack Text
requestBuilderDataUrl

  Request
req <- case String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
requestStr Maybe Request -> Maybe Request -> Maybe Request
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String
"http://localhost" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
requestStr) of
    Maybe Request
Nothing -> IO Request -> YesodClientM site Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> YesodClientM site Request)
-> IO Request -> YesodClientM site Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse url: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
requestStr
    Just Request
req -> Request -> YesodClientM site Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
  Method
boundary <- IO Method -> YesodClientM site Method
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Method
webkitBoundary
  (RequestBody
body, Maybe Method
contentTypeHeader) <- IO (RequestBody, Maybe Method)
-> YesodClientM site (RequestBody, Maybe Method)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RequestBody, Maybe Method)
 -> YesodClientM site (RequestBody, Maybe Method))
-> IO (RequestBody, Maybe Method)
-> YesodClientM site (RequestBody, Maybe Method)
forall a b. (a -> b) -> a -> b
$ case PostData
requestBuilderDataPostData of
    MultipleItemsPostData [] -> (RequestBody, Maybe Method) -> IO (RequestBody, Maybe Method)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Method -> RequestBody
RequestBodyBS Method
SB.empty, Maybe Method
forall a. Maybe a
Nothing)
    MultipleItemsPostData [RequestPart]
dat ->
      if (RequestPart -> Bool) -> [RequestPart] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RequestPart -> Bool
isFile [RequestPart]
dat
        then do
          RequestBody
ps <-
            Method -> [PartM IO] -> IO RequestBody
forall (m :: * -> *).
Applicative m =>
Method -> [PartM m] -> m RequestBody
renderParts
              Method
boundary
              ( ((RequestPart -> PartM IO) -> [RequestPart] -> [PartM IO])
-> [RequestPart] -> (RequestPart -> PartM IO) -> [PartM IO]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RequestPart -> PartM IO) -> [RequestPart] -> [PartM IO]
forall a b. (a -> b) -> [a] -> [b]
map [RequestPart]
dat ((RequestPart -> PartM IO) -> [PartM IO])
-> (RequestPart -> PartM IO) -> [PartM IO]
forall a b. (a -> b) -> a -> b
$ \case
                  ReqKvPart Text
k Text
v -> Text -> Method -> PartM IO
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 ->
                    (Text -> String -> RequestBody -> PartM IO
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 (Text -> Method) -> Maybe Text -> Maybe Method
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mime
                      }
              )
          (RequestBody, Maybe Method) -> IO (RequestBody, Maybe Method)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( RequestBody
ps,
              Method -> Maybe Method
forall a. a -> Maybe a
Just (Method -> Maybe Method) -> Method -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Method
"multipart/form-data; boundary=" Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
boundary
            )
        else
          (RequestBody, Maybe Method) -> IO (RequestBody, Maybe Method)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Method -> RequestBody
RequestBodyBS (Method -> RequestBody) -> Method -> RequestBody
forall a b. (a -> b) -> a -> b
$
                Bool -> SimpleQuery -> Method
renderSimpleQuery Bool
False (SimpleQuery -> Method) -> SimpleQuery -> Method
forall a b. (a -> b) -> a -> b
$
                  ((RequestPart -> Maybe (Method, Method))
 -> [RequestPart] -> SimpleQuery)
-> [RequestPart]
-> (RequestPart -> Maybe (Method, Method))
-> SimpleQuery
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RequestPart -> Maybe (Method, Method))
-> [RequestPart] -> SimpleQuery
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [RequestPart]
dat ((RequestPart -> Maybe (Method, Method)) -> SimpleQuery)
-> (RequestPart -> Maybe (Method, Method)) -> SimpleQuery
forall a b. (a -> b) -> a -> b
$ \case
                    ReqKvPart Text
k Text
v -> (Method, Method) -> Maybe (Method, Method)
forall a. a -> Maybe a
Just (Text -> Method
TE.encodeUtf8 Text
k, Text -> Method
TE.encodeUtf8 Text
v)
                    ReqFilePart {} -> Maybe (Method, Method)
forall a. Maybe a
Nothing,
              Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"application/x-www-form-urlencoded"
            )
    BinaryPostData Method
sb -> (RequestBody, Maybe Method) -> IO (RequestBody, Maybe Method)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Method -> RequestBody
RequestBodyBS Method
sb, Maybe Method
forall a. Maybe a
Nothing)
  UTCTime
now <- IO UTCTime -> YesodClientM site UTCTime
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
              { port :: Int
port = Int
p,
                method :: Method
method = Method
requestBuilderDataMethod,
                requestHeaders :: RequestHeaders
requestHeaders =
                  [RequestHeaders] -> RequestHeaders
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ RequestHeaders
requestBuilderDataHeaders,
                      [(HeaderName
"Content-Type", Method
cth) | Method
cth <- Maybe Method -> [Method]
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
  (YesodClientState site -> YesodClientState site)
-> YesodClientM site ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (\YesodClientState site
s -> YesodClientState site
s {yesodClientStateCookies :: CookieJar
yesodClientStateCookies = CookieJar
cj'})
  Request -> YesodClientM site Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req'

-- | Perform the request that is built by the given 'RequestBuilder'.
--
-- > yit "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 :: RequestBuilder site a -> YesodClientM site ()
request RequestBuilder site a
rb = do
  Request
req <- RequestBuilder site a -> YesodClientM site Request
forall site a. RequestBuilder site a -> YesodClientM site Request
runRequestBuilder RequestBuilder site a
rb
  Request -> YesodClientM site ()
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 :: url -> RequestBuilder site ()
setUrl url
route = do
  site
site <- (YesodClient site -> site) -> RequestBuilder site site
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks YesodClient site -> site
forall site. YesodClient site -> site
yesodClientSite
  Right Text
url <-
    SessionMap
-> (site -> Logger)
-> site
-> HandlerFor site Text
-> RequestBuilder 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
"Test.Syd.Yesod: 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
route)
  (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
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 :: Method -> RequestBuilder site ()
setMethod Method
m = (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
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 :: Header -> RequestBuilder site ()
addRequestHeader Header
h = (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (\RequestBuilderData site
r -> RequestBuilderData site
r {requestBuilderDataHeaders :: RequestHeaders
requestBuilderDataHeaders = Header
h Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestBuilderData site -> RequestHeaders
forall site. RequestBuilderData site -> RequestHeaders
requestBuilderDataHeaders RequestBuilderData site
r})

-- | Add the given GET parameter to the 'RequestBuilder'.
addGetParam :: Text -> Text -> RequestBuilder site ()
addGetParam :: Text -> Text -> RequestBuilder site ()
addGetParam Text
k Text
v = (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
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, 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
v) (Method, Maybe Method) -> Query -> Query
forall a. a -> [a] -> [a]
: RequestBuilderData site -> Query
forall site. RequestBuilderData site -> Query
requestBuilderDataGetParams RequestBuilderData site
r})

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

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 :: Text -> String -> Text -> RequestBuilder site ()
addFile Text
name String
path Text
mimetype = do
  Method
contents <- IO Method -> RequestBuilder site Method
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Method -> RequestBuilder site Method)
-> IO Method -> RequestBuilder site Method
forall a b. (a -> b) -> a -> b
$ String -> IO Method
SB.readFile String
path
  Text -> String -> Method -> Maybe Text -> RequestBuilder site ()
forall site.
Text -> String -> Method -> Maybe Text -> RequestBuilder site ()
addFileWith Text
name String
path Method
contents (Text -> Maybe Text
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 :: Text -> String -> Method -> Maybe Text -> RequestBuilder site ()
addFileWith Text
name String
path Method
contents Maybe Text
mMimetype =
  (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((RequestBuilderData site -> RequestBuilderData site)
 -> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ \RequestBuilderData site
r -> RequestBuilderData site
r {requestBuilderDataPostData :: PostData
requestBuilderDataPostData = PostData -> PostData
addPostData (RequestBuilderData site -> PostData
forall site. RequestBuilderData site -> PostData
requestBuilderDataPostData RequestBuilderData site
r)}
  where
    addPostData :: PostData -> PostData
addPostData (BinaryPostData Method
_) = String -> PostData
forall a. HasCallStack => String -> a
error String
"Trying to add file after setting binary content."
    addPostData (MultipleItemsPostData [RequestPart]
posts) =
      [RequestPart] -> PostData
MultipleItemsPostData ([RequestPart] -> PostData) -> [RequestPart] -> PostData
forall a b. (a -> b) -> a -> b
$ Text -> String -> Method -> Maybe Text -> RequestPart
ReqFilePart Text
name String
path Method
contents Maybe Text
mMimetype RequestPart -> [RequestPart] -> [RequestPart]
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 :: Method -> RequestBuilder site ()
setRequestBody Method
body = (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((RequestBuilderData site -> RequestBuilderData site)
 -> RequestBuilder site ())
-> (RequestBuilderData site -> RequestBuilderData site)
-> RequestBuilder site ()
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_ :: Text -> RequestBuilder site ()
addToken_ Text
scope = do
  [ByteString]
matches <- YesodClientM site [ByteString] -> RequestBuilder site [ByteString]
forall site a. YesodClientM site a -> RequestBuilder site a
liftClient (YesodClientM site [ByteString]
 -> RequestBuilder site [ByteString])
-> YesodClientM site [ByteString]
-> RequestBuilder site [ByteString]
forall a b. (a -> b) -> a -> b
$ Text -> YesodClientM site [ByteString]
forall site. HasCallStack => Text -> YesodExample site [ByteString]
htmlQuery (Text -> YesodClientM site [ByteString])
-> Text -> YesodClientM site [ByteString]
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 [ByteString]
matches of
    [] -> IO () -> RequestBuilder site ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RequestBuilder site ())
-> IO () -> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> IO a
expectationFailure String
"No CSRF token found in the current page"
    [ByteString
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]
C.attribute Name
"value" (Cursor -> [Text]) -> Cursor -> [Text]
forall a b. (a -> b) -> a -> b
$ ByteString -> Cursor
YesodTest.parseHTML ByteString
element
    [ByteString]
_ -> IO () -> RequestBuilder site ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RequestBuilder site ())
-> IO () -> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
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 :: RequestBuilder site ()
addToken = Text -> RequestBuilder site ()
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 :: RequestBuilder site ()
addTokenFromCookie = Method -> HeaderName -> RequestBuilder site ()
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 :: Method -> HeaderName -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed Method
cookieName HeaderName
headerName = do
  Map Method SetCookie
cookies <- RequestBuilder site (Map Method SetCookie)
forall site. RequestBuilder site (Map Method SetCookie)
getRequestCookies
  case Method -> Map Method SetCookie -> Maybe SetCookie
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Method
cookieName Map Method SetCookie
cookies of
    Just SetCookie
csrfCookie -> Header -> RequestBuilder site ()
forall site. Header -> RequestBuilder site ()
addRequestHeader (HeaderName
headerName, SetCookie -> Method
setCookieValue SetCookie
csrfCookie)
    Maybe SetCookie
Nothing ->
      IO () -> RequestBuilder site ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RequestBuilder site ())
-> IO () -> RequestBuilder site ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"addTokenFromCookieNamedToHeaderNamed failed to lookup CSRF cookie with name: ",
              Method -> String
forall a. Show a => a -> String
show Method
cookieName,
              String
". Cookies were: ",
              Map Method SetCookie -> String
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://google.com if you wanted.
performRequest :: Request -> YesodClientM site ()
performRequest :: Request -> YesodClientM site ()
performRequest Request
req = do
  Manager
man <- (YesodClient site -> Manager) -> YesodClientM site Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks YesodClient site -> Manager
forall site. YesodClient site -> Manager
yesodClientManager
  Response ByteString
resp <- IO (Response ByteString) -> YesodClientM site (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString)
 -> YesodClientM site (Response ByteString))
-> IO (Response ByteString)
-> YesodClientM site (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response (IO Method))
httpRaw Request
req Manager
man IO (Response (IO Method))
-> (Response (IO Method) -> IO (Response ByteString))
-> IO (Response ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IO Method -> IO ByteString)
-> Response (IO Method) -> IO (Response ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([Method] -> ByteString) -> IO [Method] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Method] -> ByteString
LB.fromChunks (IO [Method] -> IO ByteString)
-> (IO Method -> IO [Method]) -> IO Method -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Method -> IO [Method]
brConsume)
  CookieJar
cj <- (YesodClientState site -> CookieJar) -> YesodClientM site CookieJar
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets YesodClientState site -> CookieJar
forall site. YesodClientState site -> CookieJar
yesodClientStateCookies
  UTCTime
now <- IO UTCTime -> YesodClientM site UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let (CookieJar
cj', Response ByteString
_) = Response ByteString
-> Request
-> UTCTime
-> CookieJar
-> (CookieJar, Response ByteString)
forall a.
Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
updateCookieJar Response ByteString
resp Request
req UTCTime
now CookieJar
cj
  (YesodClientState site -> YesodClientState site)
-> YesodClientM site ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify'
    ( \YesodClientState site
s ->
        YesodClientState site
s
          { yesodClientStateLast :: Maybe (Request, Response ByteString)
yesodClientStateLast = (Request, Response ByteString)
-> Maybe (Request, Response ByteString)
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 :: RequestBuilder site (Map Method SetCookie)
getRequestCookies = do
  CookieJar
cj <- YesodClientM site CookieJar -> RequestBuilder site CookieJar
forall site a. YesodClientM site a -> RequestBuilder site a
liftClient (YesodClientM site CookieJar -> RequestBuilder site CookieJar)
-> YesodClientM site CookieJar -> RequestBuilder site CookieJar
forall a b. (a -> b) -> a -> b
$ (YesodClientState site -> CookieJar) -> YesodClientM site CookieJar
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets YesodClientState site -> CookieJar
forall site. YesodClientState site -> CookieJar
yesodClientStateCookies
  Map Method SetCookie -> RequestBuilder site (Map Method SetCookie)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Method SetCookie
 -> RequestBuilder site (Map Method SetCookie))
-> Map Method SetCookie
-> RequestBuilder site (Map Method SetCookie)
forall a b. (a -> b) -> a -> b
$
    [(Method, SetCookie)] -> Map Method SetCookie
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Method, SetCookie)] -> Map Method SetCookie)
-> [(Method, SetCookie)] -> Map Method SetCookie
forall a b. (a -> b) -> a -> b
$
      ((Cookie -> (Method, SetCookie))
 -> [Cookie] -> [(Method, SetCookie)])
-> [Cookie]
-> (Cookie -> (Method, SetCookie))
-> [(Method, SetCookie)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Cookie -> (Method, SetCookie))
-> [Cookie] -> [(Method, SetCookie)]
forall a b. (a -> b) -> [a] -> [b]
map (CookieJar -> [Cookie]
destroyCookieJar CookieJar
cj) ((Cookie -> (Method, SetCookie)) -> [(Method, SetCookie)])
-> (Cookie -> (Method, SetCookie)) -> [(Method, SetCookie)]
forall a b. (a -> b) -> a -> b
$ \Cookie {Bool
Method
UTCTime
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 :: Text -> YesodExample site [ByteString]
htmlQuery Text
query = do
  Maybe (Response ByteString)
mResp <- YesodClientM site (Maybe (Response ByteString))
forall site. YesodClientM site (Maybe (Response ByteString))
getResponse
  case Maybe (Response ByteString)
mResp of
    Maybe (Response ByteString)
Nothing -> IO [ByteString] -> YesodExample site [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> YesodExample site [ByteString])
-> IO [ByteString] -> YesodExample site [ByteString]
forall a b. (a -> b) -> a -> b
$ String -> IO [ByteString]
forall a. HasCallStack => String -> IO a
expectationFailure String
"No request made yet."
    Just Response ByteString
resp -> case ByteString -> Text -> Either String [String]
CSS.findBySelector (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp) Text
query of
      Left String
err -> IO [ByteString] -> YesodExample site [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> YesodExample site [ByteString])
-> IO [ByteString] -> YesodExample site [ByteString]
forall a b. (a -> b) -> a -> b
$ String -> IO [ByteString]
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO [ByteString]) -> String -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
query String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" did not parse: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
err
      Right [String]
matches -> [ByteString] -> YesodExample site [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> YesodExample site [ByteString])
-> [ByteString] -> YesodExample site [ByteString]
forall a b. (a -> b) -> a -> b
$ (String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Method -> ByteString
LB.fromStrict (Method -> ByteString)
-> (String -> Method) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Method
TE.encodeUtf8 (Text -> Method) -> (String -> Text) -> String -> Method
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.)
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 :: YesodExample site (Either Text Text)
followRedirect = do
  Maybe (Response ByteString)
mr <- YesodClientM site (Maybe (Response ByteString))
forall site. YesodClientM site (Maybe (Response ByteString))
getResponse
  case Maybe (Response ByteString)
mr of
    Maybe (Response ByteString)
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 Response ByteString
r -> do
      if Status -> Int
HTTP.statusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
r) Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [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" (Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response ByteString
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 -> YesodClientM site ()
forall site url.
(Yesod site, RedirectUrl site url) =>
url -> YesodClientM site ()
get Text
url YesodClientM 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)