{-# 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
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
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
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
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
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
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)
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
)
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,
:: !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
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'
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
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
}
)
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})
addRequestHeader :: HTTP.Header -> RequestBuilder site ()
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})
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})
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 ::
Text ->
FilePath ->
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 ::
Text ->
FilePath ->
ByteString ->
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
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}
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"
addToken :: HasCallStack => RequestBuilder site ()
addToken :: RequestBuilder site ()
addToken = Text -> RequestBuilder site ()
forall site. HasCallStack => Text -> RequestBuilder site ()
addToken_ Text
""
addTokenFromCookie :: HasCallStack => RequestBuilder site ()
addTokenFromCookie :: RequestBuilder site ()
addTokenFromCookie = Method -> HeaderName -> RequestBuilder site ()
forall site.
HasCallStack =>
Method -> HeaderName -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed Method
defaultCsrfCookieName HeaderName
defaultCsrfHeaderName
addTokenFromCookieNamedToHeaderNamed ::
HasCallStack =>
ByteString ->
CI ByteString ->
RequestBuilder site ()
Method
cookieName HeaderName
headerName = do
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
]
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'
}
)
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
}
)
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
followRedirect ::
Yesod site =>
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)