{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 Network.HTTP.Client as HTTP
import Network.HTTP.Types as HTTP
import Test.Syd
import Yesod.Core as Yesod

-- | A client environment to call a Yesod app.
data YesodClient site = YesodClient
  { -- | The site itself
    YesodClient site -> site
yesodClientSite :: !site,
    -- | The 'HTTP.Manager' to make the requests
    YesodClient site -> Manager
yesodClientManager :: !HTTP.Manager,
    -- | The port that the site is running on, using @warp@
    YesodClient site -> Int
yesodClientSitePort :: !Int
  }

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

-- | The starting point of the 'YesodClientState site' of a 'YesodClientM site'
initYesodClientState :: YesodClientState site
initYesodClientState :: YesodClientState site
initYesodClientState =
  YesodClientState :: forall site.
Maybe (Request, Response ByteString)
-> CookieJar -> YesodClientState site
YesodClientState
    { yesodClientStateLast :: Maybe (Request, Response ByteString)
yesodClientStateLast = Maybe (Request, Response ByteString)
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
  { YesodClientM site a
-> StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
unYesodClientM :: StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
  }
  deriving
    ( a -> YesodClientM site b -> YesodClientM site a
(a -> b) -> YesodClientM site a -> YesodClientM site b
(forall a b.
 (a -> b) -> YesodClientM site a -> YesodClientM site b)
-> (forall a b. a -> YesodClientM site b -> YesodClientM site a)
-> Functor (YesodClientM site)
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
<$ :: a -> YesodClientM site b -> YesodClientM site a
$c<$ :: forall site a b. a -> YesodClientM site b -> YesodClientM site a
fmap :: (a -> b) -> YesodClientM site a -> YesodClientM site b
$cfmap :: forall site a b.
(a -> b) -> YesodClientM site a -> YesodClientM site b
Functor,
      Functor (YesodClientM site)
a -> YesodClientM site a
Functor (YesodClientM site)
-> (forall a. a -> YesodClientM site a)
-> (forall 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 a b.
    YesodClientM site a -> YesodClientM site b -> YesodClientM site b)
-> (forall a b.
    YesodClientM site a -> YesodClientM site b -> YesodClientM site a)
-> Applicative (YesodClientM site)
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
YesodClientM site a -> YesodClientM site b -> YesodClientM site a
YesodClientM site (a -> b)
-> YesodClientM site a -> YesodClientM site b
(a -> b -> c)
-> YesodClientM site a
-> YesodClientM site b
-> YesodClientM site c
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
<* :: YesodClientM site a -> YesodClientM site b -> YesodClientM site a
$c<* :: forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site a
*> :: YesodClientM site a -> YesodClientM site b -> YesodClientM site b
$c*> :: forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
liftA2 :: (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
<*> :: 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 :: a -> YesodClientM site a
$cpure :: forall site a. a -> YesodClientM site a
$cp1Applicative :: forall site. Functor (YesodClientM site)
Applicative,
      Applicative (YesodClientM site)
a -> YesodClientM site a
Applicative (YesodClientM site)
-> (forall a b.
    YesodClientM site a
    -> (a -> YesodClientM site b) -> YesodClientM site b)
-> (forall a b.
    YesodClientM site a -> YesodClientM site b -> YesodClientM site b)
-> (forall a. a -> YesodClientM site a)
-> Monad (YesodClientM site)
YesodClientM site a
-> (a -> YesodClientM site b) -> YesodClientM site b
YesodClientM site a -> YesodClientM site b -> YesodClientM site b
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 :: a -> YesodClientM site a
$creturn :: forall site a. a -> YesodClientM site a
>> :: YesodClientM site a -> YesodClientM site b -> YesodClientM site b
$c>> :: forall site a b.
YesodClientM site a -> YesodClientM site b -> YesodClientM site 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
$cp1Monad :: forall site. Applicative (YesodClientM site)
Monad,
      Monad (YesodClientM site)
Monad (YesodClientM site)
-> (forall a. IO a -> YesodClientM site a)
-> MonadIO (YesodClientM site)
IO a -> YesodClientM site a
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 :: IO a -> YesodClientM site a
$cliftIO :: forall site a. IO a -> YesodClientM site a
$cp1MonadIO :: forall site. Monad (YesodClientM site)
MonadIO,
      MonadReader (YesodClient site),
      MonadState (YesodClientState site),
      Monad (YesodClientM site)
Monad (YesodClientM site)
-> (forall a. String -> YesodClientM site a)
-> MonadFail (YesodClientM site)
String -> YesodClientM site a
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 :: String -> YesodClientM site a
$cfail :: forall site a. String -> YesodClientM site a
$cp1MonadFail :: forall site. Monad (YesodClientM site)
MonadFail,
      Monad (YesodClientM site)
e -> YesodClientM site a
Monad (YesodClientM site)
-> (forall e a. Exception e => e -> YesodClientM site a)
-> MonadThrow (YesodClientM site)
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 :: e -> YesodClientM site a
$cthrowM :: forall site e a. Exception e => e -> YesodClientM site a
$cp1MonadThrow :: forall site. Monad (YesodClientM site)
MonadThrow
    )

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

-- | Get the most recently sent request.
getRequest :: YesodClientM site (Maybe Request)
getRequest :: YesodClientM site (Maybe Request)
getRequest = (YesodClientState site -> Maybe Request)
-> YesodClientM site (Maybe Request)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (((Request, Response ByteString) -> Request)
-> Maybe (Request, Response ByteString) -> Maybe Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Request, Response ByteString) -> Request
forall a b. (a, b) -> a
fst (Maybe (Request, Response ByteString) -> Maybe Request)
-> (YesodClientState site -> Maybe (Request, Response ByteString))
-> YesodClientState site
-> Maybe Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodClientState site -> Maybe (Request, Response ByteString)
forall site.
YesodClientState site -> Maybe (Request, Response ByteString)
yesodClientStateLast)

-- | Get the most recently received response.
getResponse :: YesodClientM site (Maybe (Response LB.ByteString))
getResponse :: YesodClientM site (Maybe (Response ByteString))
getResponse = (YesodClientState site -> Maybe (Response ByteString))
-> YesodClientM site (Maybe (Response ByteString))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (((Request, Response ByteString) -> Response ByteString)
-> Maybe (Request, Response ByteString)
-> Maybe (Response ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Request, Response ByteString) -> Response ByteString
forall a b. (a, b) -> b
snd (Maybe (Request, Response ByteString)
 -> Maybe (Response ByteString))
-> (YesodClientState site -> Maybe (Request, Response ByteString))
-> YesodClientState site
-> Maybe (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodClientState site -> Maybe (Request, Response ByteString)
forall site.
YesodClientState site -> Maybe (Request, Response ByteString)
yesodClientStateLast)

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

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

-- | 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 :: YesodClientM site a -> YesodClientM site a
withLastRequestContext yfunc :: YesodClientM site a
yfunc@(YesodClientM StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
func) = 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 -> YesodClientM site a
yfunc
    Just (Request
req, Response ByteString
resp) ->
      StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
-> YesodClientM site a
forall site a.
StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
-> YesodClientM site a
YesodClientM (StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
 -> YesodClientM site a)
-> StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
-> YesodClientM site a
forall a b. (a -> b) -> a -> b
$ do
        YesodClientState site
s <- StateT
  (YesodClientState site)
  (ReaderT (YesodClient site) IO)
  (YesodClientState site)
forall s (m :: * -> *). MonadState s m => m s
get
        YesodClient site
c <- StateT
  (YesodClientState site)
  (ReaderT (YesodClient site) IO)
  (YesodClient site)
forall r (m :: * -> *). MonadReader r m => m r
ask
        let ctx :: String
ctx =
              [String] -> String
unlines
                [ String
"last request:",
                  Request -> String
forall a. Show a => a -> String
ppShow Request
req,
                  String
"full response:",
                  Response ByteString -> String
forall a. Show a => a -> String
ppShow Response ByteString
resp
                ]
        (a
r, YesodClientState site
s') <- IO (a, YesodClientState site)
-> StateT
     (YesodClientState site)
     (ReaderT (YesodClient site) IO)
     (a, YesodClientState site)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, YesodClientState site)
 -> StateT
      (YesodClientState site)
      (ReaderT (YesodClient site) IO)
      (a, YesodClientState site))
-> IO (a, YesodClientState site)
-> StateT
     (YesodClientState site)
     (ReaderT (YesodClient site) IO)
     (a, YesodClientState site)
forall a b. (a -> b) -> a -> b
$ String
-> IO (a, YesodClientState site) -> IO (a, YesodClientState site)
forall a. String -> IO a -> IO a
context String
ctx (IO (a, YesodClientState site) -> IO (a, YesodClientState site))
-> IO (a, YesodClientState site) -> IO (a, YesodClientState site)
forall a b. (a -> b) -> a -> b
$ ReaderT (YesodClient site) IO (a, YesodClientState site)
-> YesodClient site -> IO (a, YesodClientState site)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
-> YesodClientState site
-> ReaderT (YesodClient site) IO (a, YesodClientState site)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
func YesodClientState site
s) YesodClient site
c
        YesodClientState site
-> StateT
     (YesodClientState site) (ReaderT (YesodClient site) IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put YesodClientState site
s'
        a
-> StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r