{-# 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

-- | Perform a @GET@ request to the application under test.
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
""

-- | Perform a @POST@ request to the application under test.
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 []

-- | Perform a @PUT@ request to the application under test.
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 []

-- | Perform a @PATCH@ request to the application under test.
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 []

-- | Perform an @OPTIONS@ request to the application under test.
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
""

-- | Perform a @DELETE@ request to the application under test.
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
""

-- | Perform a request to the application under test, with specified HTTP
-- method, request path, headers and body.
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, -- Safe because it is PortNumber -> INt
            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'

-- | Perform a bare 'HTTP.Request'.
--
-- You can use this to make a request to an application other than the one
-- under test.  This function does __not__ set the host and port of the request
-- like 'request' does, but it does share a 'CookieJar'.
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

-- | Make a test assertion using a 'ResponseMatcher' on the 'HTTP.Response' produced by the given action
--
-- This function is provided for backward compatibility with wai-test but this approach has been made obsolete by the way sydtest does things.
-- You should use 'shouldBe' based on the responses that you get from functions like 'get' and 'post' instead.
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)