{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-unused-imports #-}

module Test.Syd.Yesod.Client where

import Control.Monad.Catch
import Control.Monad.Fail
import Control.Monad.Reader
import Control.Monad.State
import qualified Control.Monad.State as State
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Network.HTTP.Client as HTTP
import Network.HTTP.Types as HTTP
import Network.Socket (PortNumber)
import Network.URI
import Test.Syd
import Test.Syd.Wai.Client (lastRequestResponseContext)
import Yesod.Core as Yesod

-- | A client environment to call a Yesod app.
data YesodClient site = YesodClient
  { -- | The site itself
    forall site. YesodClient site -> site
yesodClientSite :: !site,
    -- | The 'HTTP.Manager' to make the requests
    forall site. YesodClient site -> Manager
yesodClientManager :: !HTTP.Manager,
    -- | The base 'URI' that the site is running on
    forall site. YesodClient site -> URI
yesodClientSiteURI :: !URI
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall site x. Rep (YesodClient site) x -> YesodClient site
forall site x. YesodClient site -> Rep (YesodClient site) x
$cto :: forall site x. Rep (YesodClient site) x -> YesodClient site
$cfrom :: forall site x. YesodClient site -> Rep (YesodClient site) x
Generic)

-- | The state that is maintained throughout a 'YesodClientM'
data YesodClientState = YesodClientState
  { -- | The last request and response pair
    YesodClientState -> Maybe (Request, Response ByteString)
yesodClientStateLast :: !(Maybe (Request, Response LB.ByteString)),
    -- | The cookies to pass along
    YesodClientState -> CookieJar
yesodClientStateCookies :: !CookieJar
  }
  deriving (forall x. Rep YesodClientState x -> YesodClientState
forall x. YesodClientState -> Rep YesodClientState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep YesodClientState x -> YesodClientState
$cfrom :: forall x. YesodClientState -> Rep YesodClientState x
Generic)

-- | The starting point of the 'YesodClientState site' of a 'YesodClientM site'
initYesodClientState :: YesodClientState
initYesodClientState :: YesodClientState
initYesodClientState =
  YesodClientState
    { yesodClientStateLast :: Maybe (Request, Response ByteString)
yesodClientStateLast = forall a. Maybe a
Nothing,
      yesodClientStateCookies :: CookieJar
yesodClientStateCookies = [Cookie] -> CookieJar
createCookieJar []
    }

-- | A monad to call a Yesod app.
--
-- This has access to a 'YesodClient site'.
newtype YesodClientM site a = YesodClientM
  { forall site a.
YesodClientM site a
-> StateT YesodClientState (ReaderT (YesodClient site) IO) a
unYesodClientM :: StateT YesodClientState (ReaderT (YesodClient site) IO) a
  }
  deriving
    ( forall a b. a -> YesodClientM site b -> YesodClientM site a
forall a b. (a -> b) -> YesodClientM site a -> YesodClientM site b
forall site a b. a -> YesodClientM site b -> YesodClientM site a
forall site a b.
(a -> b) -> YesodClientM site a -> YesodClientM site b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> YesodClientM site b -> YesodClientM site a
$c<$ :: forall site a b. a -> YesodClientM site b -> YesodClientM site a
fmap :: forall a b. (a -> b) -> YesodClientM site a -> YesodClientM site b
$cfmap :: forall site a b.
(a -> b) -> YesodClientM site a -> YesodClientM site b
Functor,
      forall site. Functor (YesodClientM site)
forall a. a -> YesodClientM site a
forall site a. a -> YesodClientM site a
forall a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site a
forall a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
forall a b.
YesodClientM site (a -> b)
-> YesodClientM site a -> YesodClientM site b
forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site a
forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
forall site a b.
YesodClientM site (a -> b)
-> YesodClientM site a -> YesodClientM site b
forall a b c.
(a -> b -> c)
-> YesodClientM site a
-> YesodClientM site b
-> YesodClientM site c
forall site a b c.
(a -> b -> c)
-> YesodClientM site a
-> YesodClientM site b
-> YesodClientM site c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site a
$c<* :: forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site a
*> :: forall a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
$c*> :: forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
liftA2 :: forall a b c.
(a -> b -> c)
-> YesodClientM site a
-> YesodClientM site b
-> YesodClientM site c
$cliftA2 :: forall site a b c.
(a -> b -> c)
-> YesodClientM site a
-> YesodClientM site b
-> YesodClientM site c
<*> :: forall a b.
YesodClientM site (a -> b)
-> YesodClientM site a -> YesodClientM site b
$c<*> :: forall site a b.
YesodClientM site (a -> b)
-> YesodClientM site a -> YesodClientM site b
pure :: forall a. a -> YesodClientM site a
$cpure :: forall site a. a -> YesodClientM site a
Applicative,
      forall site. Applicative (YesodClientM site)
forall a. a -> YesodClientM site a
forall site a. a -> YesodClientM site a
forall a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
forall a b.
YesodClientM site a
-> (a -> YesodClientM site b) -> YesodClientM site b
forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
forall site a b.
YesodClientM site a
-> (a -> YesodClientM site b) -> YesodClientM site b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> YesodClientM site a
$creturn :: forall site a. a -> YesodClientM site a
>> :: forall a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
$c>> :: forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
>>= :: forall a b.
YesodClientM site a
-> (a -> YesodClientM site b) -> YesodClientM site b
$c>>= :: forall site a b.
YesodClientM site a
-> (a -> YesodClientM site b) -> YesodClientM site b
Monad,
      forall site. Monad (YesodClientM site)
forall a. IO a -> YesodClientM site a
forall site a. IO a -> YesodClientM site a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> YesodClientM site a
$cliftIO :: forall site a. IO a -> YesodClientM site a
MonadIO,
      MonadReader (YesodClient site),
      MonadState YesodClientState,
      forall site. Monad (YesodClientM site)
forall a. String -> YesodClientM site a
forall site a. String -> YesodClientM site a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> YesodClientM site a
$cfail :: forall site a. String -> YesodClientM site a
MonadFail,
      forall site. Monad (YesodClientM site)
forall e a. Exception e => e -> YesodClientM site a
forall site e a. Exception e => e -> YesodClientM site a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> YesodClientM site a
$cthrowM :: forall site e a. Exception e => e -> YesodClientM site a
MonadThrow
    )

instance IsTest (YesodClientM site ()) where
  type Arg1 (YesodClientM site ()) = ()
  type Arg2 (YesodClientM site ()) = YesodClient site
  runTest :: YesodClientM site ()
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (YesodClientM site ())
     -> Arg2 (YesodClientM site ()) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest YesodClientM site ()
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() -> YesodClientM site ()
func)

instance IsTest (outerArgs -> YesodClientM site ()) where
  type Arg1 (outerArgs -> YesodClientM site ()) = outerArgs
  type Arg2 (outerArgs -> YesodClientM site ()) = YesodClient site
  runTest :: (outerArgs -> YesodClientM site ())
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> YesodClientM site ())
     -> Arg2 (outerArgs -> YesodClientM site ()) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest outerArgs -> YesodClientM site ()
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\outerArgs
outerArgs YesodClient site
yesodClient -> forall site a. YesodClient site -> YesodClientM site a -> IO a
runYesodClientM YesodClient site
yesodClient (outerArgs -> YesodClientM site ()
func outerArgs
outerArgs))

-- | For backward compatibility
type YesodExample site a = YesodClientM site a

-- | Run a YesodClientM site using a YesodClient site
runYesodClientM :: YesodClient site -> YesodClientM site a -> IO a
runYesodClientM :: forall site a. YesodClient site -> YesodClientM site a -> IO a
runYesodClientM YesodClient site
cenv (YesodClientM StateT YesodClientState (ReaderT (YesodClient site) IO) a
func) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT YesodClientState (ReaderT (YesodClient site) IO) a
func YesodClientState
initYesodClientState) YesodClient site
cenv

-- | Get the most recently sent request.
getRequest :: YesodClientM site (Maybe Request)
getRequest :: forall site. YesodClientM site (Maybe Request)
getRequest = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall site.
YesodClientM site (Maybe (Request, Response ByteString))
getLast

-- | Get the most recently sent request.
requireRequest :: YesodClientM site Request
requireRequest :: forall site. YesodClientM site Request
requireRequest = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall site. YesodClientM site (Request, Response ByteString)
requireLast

-- | Get the most recently received response.
getResponse :: YesodClientM site (Maybe (Response LB.ByteString))
getResponse :: forall site. YesodClientM site (Maybe (Response ByteString))
getResponse = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall site.
YesodClientM site (Maybe (Request, Response ByteString))
getLast

-- | Get the most recently received response, and assert that it already exists.
requireResponse :: YesodClientM site (Response LB.ByteString)
requireResponse :: forall site. YesodClientM site (Response ByteString)
requireResponse = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall site. YesodClientM site (Request, Response ByteString)
requireLast

-- | Get the most recently sent request and the response to it.
getLast :: YesodClientM site (Maybe (Request, Response LB.ByteString))
getLast :: forall site.
YesodClientM site (Maybe (Request, Response ByteString))
getLast = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets YesodClientState -> Maybe (Request, Response ByteString)
yesodClientStateLast

-- | Get the most recently sent request and the response to it, and assert that they already exist.
requireLast :: YesodClientM site (Request, Response LB.ByteString)
requireLast :: forall site. YesodClientM site (Request, Response ByteString)
requireLast = do
  Maybe (Request, Response ByteString)
mTup <- forall site.
YesodClientM site (Maybe (Request, Response ByteString))
getLast
  case Maybe (Request, Response ByteString)
mTup of
    Maybe (Request, Response ByteString)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure String
"Should have had a latest request/response pair by now."
    Just (Request, Response ByteString)
tup -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request, Response ByteString)
tup

-- | Get the status of the most recently received response.
getStatus :: YesodClientM site (Maybe Int)
getStatus :: forall site. YesodClientM site (Maybe Int)
getStatus = do
  Maybe (Response ByteString)
mResponse <- forall site. YesodClientM site (Maybe (Response ByteString))
getResponse
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> Status
responseStatus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Response ByteString)
mResponse

-- | Get the status of the most recently received response, and assert that it already exists.
requireStatus :: YesodClientM site Int
requireStatus :: forall site. YesodClientM site Int
requireStatus = Status -> Int
statusCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> Status
responseStatus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall site. YesodClientM site (Response ByteString)
requireResponse

-- | Get the 'Location' header of most recently received response.
getLocation :: ParseRoute site => YesodClientM localSite (Either Text (Route site))
getLocation :: forall site localSite.
ParseRoute site =>
YesodClientM localSite (Either Text (Route site))
getLocation = do
  Maybe (Response ByteString)
mr <- forall site. YesodClientM site (Maybe (Response ByteString))
getResponse
  case Maybe (Response ByteString)
mr of
    Maybe (Response ByteString)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"getLocation called, but there was no previous response, so no Location header"
    Just Response ByteString
r -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" (forall body. Response body -> ResponseHeaders
responseHeaders Response ByteString
r) of
      Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"getLocation called, but the previous response has no Location header"
      Just ByteString
h -> case forall a.
ParseRoute a =>
([Text], [(Text, Text)]) -> Maybe (Route a)
parseRoute forall a b. (a -> b) -> a -> b
$ ByteString -> ([Text], [(Text, Text)])
decodePath' ByteString
h of
        Maybe (Route site)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"getLocation called, but couldn’t parse it into a route: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show ByteString
h)
        Just Route site
l -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Route site
l
  where
    decodePath' :: ByteString -> ([Text], [(Text, Text)])
    decodePath' :: ByteString -> ([Text], [(Text, Text)])
decodePath' ByteString
b =
      let ([Text]
ss, Query
q) = ByteString -> ([Text], Query)
decodePath forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
extractPath ByteString
b
       in ([Text]
ss, forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. Monoid b => (a, Maybe b) -> (a, b)
unJust forall a b. (a -> b) -> a -> b
$ Query -> QueryText
queryToQueryText Query
q)
    unJust :: (a, Maybe b) -> (a, b)
unJust (a
a, Just b
b) = (a
a, b
b)
    unJust (a
a, Maybe b
Nothing) = (a
a, forall a. Monoid a => a
mempty)

-- | Get the 'Location' header of most recently received response, and assert that it is a valid Route.
requireLocation :: ParseRoute site => YesodClientM localSite (Route site)
requireLocation :: forall site localSite.
ParseRoute site =>
YesodClientM localSite (Route site)
requireLocation = do
  Either Text (Route site)
errOrLocation <- forall site localSite.
ParseRoute site =>
YesodClientM localSite (Either Text (Route site))
getLocation
  case Either Text (Route site)
errOrLocation of
    Left Text
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
err
    Right Route site
location -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Route site
location

-- | Annotate the given test code with the last request and its response, if one has been made already.
withLastRequestContext :: YesodClientM site a -> YesodClientM site a
withLastRequestContext :: forall site a. YesodClientM site a -> YesodClientM site a
withLastRequestContext yfunc :: YesodClientM site a
yfunc@(YesodClientM StateT YesodClientState (ReaderT (YesodClient site) IO) a
func) = do
  Maybe (Request, Response ByteString)
mLast <- forall site.
YesodClientM site (Maybe (Request, Response ByteString))
getLast
  case Maybe (Request, Response ByteString)
mLast of
    Maybe (Request, Response ByteString)
Nothing -> YesodClientM site a
yfunc
    Just (Request
req, Response ByteString
resp) ->
      forall site a.
StateT YesodClientState (ReaderT (YesodClient site) IO) a
-> YesodClientM site a
YesodClientM forall a b. (a -> b) -> a -> b
$ do
        YesodClientState
s <- forall s (m :: * -> *). MonadState s m => m s
get
        YesodClient site
c <- forall r (m :: * -> *). MonadReader r m => m r
ask
        let ctx :: String
ctx = forall respBody.
Show respBody =>
Request -> Response respBody -> String
lastRequestResponseContext Request
req Response ByteString
resp
        (a
r, YesodClientState
s') <- 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 String
ctx forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT YesodClientState (ReaderT (YesodClient site) IO) a
func YesodClientState
s) YesodClient site
c
        forall s (m :: * -> *). MonadState s m => s -> m ()
put YesodClientState
s'
        forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r