{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Syd.Wai.Request where
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State as State
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Time
import GHC.Stack (HasCallStack)
import Network.HTTP.Client as HTTP
import Network.HTTP.Client.Internal (httpRaw)
import Network.HTTP.Types as HTTP
import Test.Syd
import Test.Syd.Wai.Client
import Test.Syd.Wai.Matcher
get :: ByteString -> WaiSession st (HTTP.Response LB.ByteString)
get :: forall st. ByteString -> WaiSession st (Response ByteString)
get ByteString
path = forall st.
ByteString
-> ByteString
-> [Header]
-> ByteString
-> WaiSession st (Response ByteString)
request ByteString
methodGet ByteString
path [] ByteString
""
post :: ByteString -> LB.ByteString -> WaiSession st (HTTP.Response LB.ByteString)
post :: forall st.
ByteString -> ByteString -> WaiSession st (Response ByteString)
post ByteString
path = forall st.
ByteString
-> ByteString
-> [Header]
-> ByteString
-> WaiSession st (Response ByteString)
request ByteString
methodPost ByteString
path []
put :: ByteString -> LB.ByteString -> WaiSession st (HTTP.Response LB.ByteString)
put :: forall st.
ByteString -> ByteString -> WaiSession st (Response ByteString)
put ByteString
path = forall st.
ByteString
-> ByteString
-> [Header]
-> ByteString
-> WaiSession st (Response ByteString)
request ByteString
methodPut ByteString
path []
patch :: ByteString -> LB.ByteString -> WaiSession st (HTTP.Response LB.ByteString)
patch :: forall st.
ByteString -> ByteString -> WaiSession st (Response ByteString)
patch ByteString
path = forall st.
ByteString
-> ByteString
-> [Header]
-> ByteString
-> WaiSession st (Response ByteString)
request ByteString
methodPatch ByteString
path []
options :: ByteString -> WaiSession st (HTTP.Response LB.ByteString)
options :: forall st. ByteString -> WaiSession st (Response ByteString)
options ByteString
path = forall st.
ByteString
-> ByteString
-> [Header]
-> ByteString
-> WaiSession st (Response ByteString)
request ByteString
methodOptions ByteString
path [] ByteString
""
delete :: ByteString -> WaiSession st (HTTP.Response LB.ByteString)
delete :: forall st. ByteString -> WaiSession st (Response ByteString)
delete ByteString
path = forall st.
ByteString
-> ByteString
-> [Header]
-> ByteString
-> WaiSession st (Response ByteString)
request ByteString
methodDelete ByteString
path [] ByteString
""
request :: Method -> ByteString -> [Header] -> LB.ByteString -> WaiSession st (HTTP.Response LB.ByteString)
request :: forall st.
ByteString
-> ByteString
-> [Header]
-> ByteString
-> WaiSession st (Response ByteString)
request ByteString
method ByteString
path [Header]
headers ByteString
body = do
PortNumber
port <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env. WaiClient env -> PortNumber
waiClientPort
let req :: Request
req =
Request
defaultRequest
{ host :: ByteString
host = ByteString
"localhost",
port :: Int
port = forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port,
method :: ByteString
method = ByteString
method,
path :: ByteString
path = ByteString
path,
requestHeaders :: [Header]
requestHeaders = [Header]
headers,
requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body
}
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
CookieJar
cj <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets WaiClientState -> CookieJar
waiClientStateCookies
let (Request
req', CookieJar
cj') = Request -> CookieJar -> UTCTime -> (Request, CookieJar)
insertCookiesIntoRequest Request
req CookieJar
cj UTCTime
now
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (\WaiClientState
s -> WaiClientState
s {waiClientStateCookies :: CookieJar
waiClientStateCookies = CookieJar
cj'})
forall st. Request -> WaiSession st (Response ByteString)
performRequest Request
req'
performRequest :: HTTP.Request -> WaiSession st (HTTP.Response LB.ByteString)
performRequest :: forall st. Request -> WaiSession st (Response ByteString)
performRequest Request
req = do
Manager
man <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env. WaiClient env -> Manager
waiClientManager
Response ByteString
resp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response BodyReader)
httpRaw Request
req Manager
man forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> ByteString
LB.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. BodyReader -> IO [ByteString]
brConsume)
CookieJar
cj <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets WaiClientState -> CookieJar
waiClientStateCookies
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let (CookieJar
cj', Response ByteString
_) = forall a.
Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
updateCookieJar Response ByteString
resp Request
req UTCTime
now CookieJar
cj
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify'
( \WaiClientState
s ->
WaiClientState
s
{ waiClientStateLast :: Maybe (Request, Response ByteString)
waiClientStateLast = forall a. a -> Maybe a
Just (Request
req, Response ByteString
resp),
waiClientStateCookies :: CookieJar
waiClientStateCookies = CookieJar
cj'
}
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response ByteString
resp
shouldRespondWith :: HasCallStack => WaiSession st (HTTP.Response LB.ByteString) -> ResponseMatcher -> WaiExpectation st
shouldRespondWith :: forall st.
HasCallStack =>
WaiSession st (Response ByteString)
-> ResponseMatcher -> WaiExpectation st
shouldRespondWith WaiSession st (Response ByteString)
action ResponseMatcher {Int
[MatchHeader]
MatchBody
matchBody :: ResponseMatcher -> MatchBody
matchHeaders :: ResponseMatcher -> [MatchHeader]
matchStatus :: ResponseMatcher -> Int
matchBody :: MatchBody
matchHeaders :: [MatchHeader]
matchStatus :: Int
..} = do
Response ByteString
response <- WaiSession st (Response ByteString)
action
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall a. String -> IO a -> IO a
context (forall a. Show a => a -> String
ppShow Response ByteString
response) forall a b. (a -> b) -> a -> b
$ do
Status -> Int
HTTP.statusCode (forall body. Response body -> Status
responseStatus Response ByteString
response) forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
matchStatus
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [MatchHeader]
matchHeaders forall a b. (a -> b) -> a -> b
$ \(MatchHeader [Header] -> ByteString -> Maybe String
matchHeaderFunc) ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ [Header] -> ByteString -> Maybe String
matchHeaderFunc (forall body. Response body -> [Header]
responseHeaders Response ByteString
response) (forall body. Response body -> body
responseBody Response ByteString
response)
let (MatchBody [Header] -> ByteString -> Maybe String
matchBodyFunc) = MatchBody
matchBody
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ [Header] -> ByteString -> Maybe String
matchBodyFunc (forall body. Response body -> [Header]
responseHeaders Response ByteString
response) (forall body. Response body -> body
responseBody Response ByteString
response)