{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Network.Wai.Test
    ( -- * Session
      Session
    , runSession
      -- * Client Cookies
    , ClientCookies
    , getClientCookies
    , modifyClientCookies
    , setClientCookie
    , deleteClientCookie
      -- * Requests
    , request
    , srequest
    , SRequest (..)
    , SResponse (..)
    , defaultRequest
    , setPath
    , setRawPathInfo
      -- * Assertions
    , assertStatus
    , assertContentType
    , assertBody
    , assertBodyContains
    , assertHeader
    , assertNoHeader
    , assertClientCookieExists
    , assertNoClientCookieExists
    , assertClientCookieValue
    , WaiTestFailure (..)
    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
import Data.Monoid (mempty, mappend)
#endif

import Network.Wai
import Network.Wai.Internal (ResponseReceived (ResponseReceived))
import Network.Wai.Test.Internal
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as ST
import Control.Monad.Trans.Reader (runReaderT, ask)
import Control.Monad (unless)
import Control.DeepSeq (deepseq)
import Control.Exception (throwIO, Exception)
import Data.Typeable (Typeable)
import qualified Data.Map as Map
import qualified Web.Cookie as Cookie
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Network.HTTP.Types as H
import Data.CaseInsensitive (CI)
import qualified Data.ByteString as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.IORef
import Data.Time.Clock (getCurrentTime)

-- |
--
-- Since 3.0.6
getClientCookies :: Session ClientCookies
getClientCookies :: Session ClientCookies
getClientCookies = ClientState -> ClientCookies
clientCookies (ClientState -> ClientCookies)
-> ReaderT Application (StateT ClientState IO) ClientState
-> Session ClientCookies
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ClientState IO ClientState
-> ReaderT Application (StateT ClientState IO) ClientState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT ClientState IO ClientState
forall (m :: * -> *) s. Monad m => StateT s m s
ST.get

-- |
--
-- Since 3.0.6
modifyClientCookies :: (ClientCookies -> ClientCookies) -> Session ()
modifyClientCookies :: (ClientCookies -> ClientCookies) -> Session ()
modifyClientCookies f :: ClientCookies -> ClientCookies
f =
  StateT ClientState IO () -> Session ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((ClientState -> ClientState) -> StateT ClientState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
ST.modify (\cs :: ClientState
cs -> ClientState
cs { clientCookies :: ClientCookies
clientCookies = ClientCookies -> ClientCookies
f (ClientCookies -> ClientCookies) -> ClientCookies -> ClientCookies
forall a b. (a -> b) -> a -> b
$ ClientState -> ClientCookies
clientCookies ClientState
cs }))

-- |
--
-- Since 3.0.6
setClientCookie :: Cookie.SetCookie -> Session ()
setClientCookie :: SetCookie -> Session ()
setClientCookie c :: SetCookie
c =
  (ClientCookies -> ClientCookies) -> Session ()
modifyClientCookies
    (ByteString -> SetCookie -> ClientCookies -> ClientCookies
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (SetCookie -> ByteString
Cookie.setCookieName SetCookie
c) SetCookie
c)

-- |
--
-- Since 3.0.6
deleteClientCookie :: ByteString -> Session ()
deleteClientCookie :: ByteString -> Session ()
deleteClientCookie cookieName :: ByteString
cookieName =
  (ClientCookies -> ClientCookies) -> Session ()
modifyClientCookies
    (ByteString -> ClientCookies -> ClientCookies
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ByteString
cookieName)

-- | See also: 'runSessionWith'.
runSession :: Session a -> Application -> IO a
runSession :: Session a -> Application -> IO a
runSession session :: Session a
session app :: Application
app = StateT ClientState IO a -> ClientState -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
ST.evalStateT (Session a -> Application -> StateT ClientState IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Session a
session Application
app) ClientState
initState

data SRequest = SRequest
    { SRequest -> Request
simpleRequest :: Request
    , SRequest -> ByteString
simpleRequestBody :: L.ByteString
    -- ^ Request body that will override the one set in 'simpleRequest'.
    --
    -- This is usually simpler than setting the body as a stateful IO-action
    -- in 'simpleRequest'.
    }
data SResponse = SResponse
    { SResponse -> Status
simpleStatus :: H.Status
    , SResponse -> ResponseHeaders
simpleHeaders :: H.ResponseHeaders
    , SResponse -> ByteString
simpleBody :: L.ByteString
    }
    deriving (Int -> SResponse -> ShowS
[SResponse] -> ShowS
SResponse -> String
(Int -> SResponse -> ShowS)
-> (SResponse -> String)
-> ([SResponse] -> ShowS)
-> Show SResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SResponse] -> ShowS
$cshowList :: [SResponse] -> ShowS
show :: SResponse -> String
$cshow :: SResponse -> String
showsPrec :: Int -> SResponse -> ShowS
$cshowsPrec :: Int -> SResponse -> ShowS
Show, SResponse -> SResponse -> Bool
(SResponse -> SResponse -> Bool)
-> (SResponse -> SResponse -> Bool) -> Eq SResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SResponse -> SResponse -> Bool
$c/= :: SResponse -> SResponse -> Bool
== :: SResponse -> SResponse -> Bool
$c== :: SResponse -> SResponse -> Bool
Eq)

request :: Request -> Session SResponse
request :: Request -> Session SResponse
request req :: Request
req = do
    Application
app <- ReaderT Application (StateT ClientState IO) Application
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Request
req' <- Request -> Session Request
addCookiesToRequest Request
req
    SResponse
response <- IO SResponse -> Session SResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SResponse -> Session SResponse)
-> IO SResponse -> Session SResponse
forall a b. (a -> b) -> a -> b
$ do
        IORef SResponse
ref <- SResponse -> IO (IORef SResponse)
forall a. a -> IO (IORef a)
newIORef (SResponse -> IO (IORef SResponse))
-> SResponse -> IO (IORef SResponse)
forall a b. (a -> b) -> a -> b
$ String -> SResponse
forall a. HasCallStack => String -> a
error "runResponse gave no result"
        ResponseReceived
ResponseReceived <- Application
app Request
req' (IORef SResponse -> Response -> IO ResponseReceived
runResponse IORef SResponse
ref)
        IORef SResponse -> IO SResponse
forall a. IORef a -> IO a
readIORef IORef SResponse
ref
    SResponse -> Session SResponse
extractSetCookieFromSResponse SResponse
response

-- | Set whole path (request path + query string).
setPath :: Request -> S8.ByteString -> Request
setPath :: Request -> ByteString -> Request
setPath req :: Request
req path :: ByteString
path = Request
req {
    pathInfo :: [Text]
pathInfo = [Text]
segments
  , rawPathInfo :: ByteString
rawPathInfo = (ByteString -> ByteString
L8.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString) ([Text] -> Builder
H.encodePathSegments [Text]
segments)
  , queryString :: Query
queryString = Query
query
  , rawQueryString :: ByteString
rawQueryString = (Bool -> Query -> ByteString
H.renderQuery Bool
True Query
query)
  }
  where
    (segments :: [Text]
segments, query :: Query
query) = ByteString -> ([Text], Query)
H.decodePath ByteString
path

setRawPathInfo :: Request -> S8.ByteString -> Request
setRawPathInfo :: Request -> ByteString -> Request
setRawPathInfo r :: Request
r rawPinfo :: ByteString
rawPinfo =
    let pInfo :: [Text]
pInfo = [Text] -> [Text]
forall a. (Eq a, IsString a) => [a] -> [a]
dropFrontSlash ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/') (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
rawPinfo
    in  Request
r { rawPathInfo :: ByteString
rawPathInfo = ByteString
rawPinfo, pathInfo :: [Text]
pathInfo = [Text]
pInfo }
  where
    dropFrontSlash :: [a] -> [a]
dropFrontSlash ("":"":[]) = [] -- homepage, a single slash
    dropFrontSlash ("":path :: [a]
path) = [a]
path
    dropFrontSlash path :: [a]
path = [a]
path

addCookiesToRequest :: Request -> Session Request
addCookiesToRequest :: Request -> Session Request
addCookiesToRequest req :: Request
req = do
  ClientCookies
oldClientCookies <- Session ClientCookies
getClientCookies
  let requestPath :: Text
requestPath = "/" Text -> Text -> Text
`T.append` Text -> [Text] -> Text
T.intercalate "/" (Request -> [Text]
pathInfo Request
req)
  UTCTime
currentUTCTime <- IO UTCTime -> ReaderT Application (StateT ClientState IO) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let cookiesForRequest :: ClientCookies
cookiesForRequest =
        (SetCookie -> Bool) -> ClientCookies -> ClientCookies
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter
          (\c :: SetCookie
c -> UTCTime -> SetCookie -> Bool
checkCookieTime UTCTime
currentUTCTime SetCookie
c
              Bool -> Bool -> Bool
&& Text -> SetCookie -> Bool
checkCookiePath Text
requestPath SetCookie
c)
          ClientCookies
oldClientCookies
  let cookiePairs :: [(ByteString, ByteString)]
cookiePairs = [ (SetCookie -> ByteString
Cookie.setCookieName SetCookie
c, SetCookie -> ByteString
Cookie.setCookieValue SetCookie
c)
                    | SetCookie
c <- ((ByteString, SetCookie) -> SetCookie)
-> [(ByteString, SetCookie)] -> [SetCookie]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, SetCookie) -> SetCookie
forall a b. (a, b) -> b
snd ([(ByteString, SetCookie)] -> [SetCookie])
-> [(ByteString, SetCookie)] -> [SetCookie]
forall a b. (a -> b) -> a -> b
$ ClientCookies -> [(ByteString, SetCookie)]
forall k a. Map k a -> [(k, a)]
Map.toList ClientCookies
cookiesForRequest
                    ]
  let cookieValue :: ByteString
cookieValue = ByteString -> ByteString
L8.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> Builder
Cookie.renderCookies [(ByteString, ByteString)]
cookiePairs
      addCookieHeader :: [(a, ByteString)] -> [(a, ByteString)]
addCookieHeader rest :: [(a, ByteString)]
rest
        | [(ByteString, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ByteString, ByteString)]
cookiePairs = [(a, ByteString)]
rest
        | Bool
otherwise = ("Cookie", ByteString
cookieValue) (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
: [(a, ByteString)]
rest
  Request -> Session Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Session Request) -> Request -> Session Request
forall a b. (a -> b) -> a -> b
$ Request
req { requestHeaders :: ResponseHeaders
requestHeaders = ResponseHeaders -> ResponseHeaders
forall a. IsString a => [(a, ByteString)] -> [(a, ByteString)]
addCookieHeader (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req }
    where checkCookieTime :: UTCTime -> SetCookie -> Bool
checkCookieTime t :: UTCTime
t c :: SetCookie
c =
            case SetCookie -> Maybe UTCTime
Cookie.setCookieExpires SetCookie
c of
              Nothing -> Bool
True
              Just t' :: UTCTime
t' -> UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
t'
          checkCookiePath :: Text -> SetCookie -> Bool
checkCookiePath p :: Text
p c :: SetCookie
c =
            case SetCookie -> Maybe ByteString
Cookie.setCookiePath SetCookie
c of
              Nothing -> Bool
True
              Just p' :: ByteString
p' -> ByteString
p' ByteString -> ByteString -> Bool
`S8.isPrefixOf` Text -> ByteString
TE.encodeUtf8 Text
p

extractSetCookieFromSResponse :: SResponse -> Session SResponse
extractSetCookieFromSResponse :: SResponse -> Session SResponse
extractSetCookieFromSResponse response :: SResponse
response = do
  let setCookieHeaders :: ResponseHeaders
setCookieHeaders =
        ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (("Set-Cookie"HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
==) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ SResponse -> ResponseHeaders
simpleHeaders SResponse
response
  let newClientCookies :: [SetCookie]
newClientCookies = ((HeaderName, ByteString) -> SetCookie)
-> ResponseHeaders -> [SetCookie]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> SetCookie
Cookie.parseSetCookie (ByteString -> SetCookie)
-> ((HeaderName, ByteString) -> ByteString)
-> (HeaderName, ByteString)
-> SetCookie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) ResponseHeaders
setCookieHeaders
  (ClientCookies -> ClientCookies) -> Session ()
modifyClientCookies
    (ClientCookies -> ClientCookies -> ClientCookies
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
       ([(ByteString, SetCookie)] -> ClientCookies
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(SetCookie -> ByteString
Cookie.setCookieName SetCookie
c, SetCookie
c) | SetCookie
c <- [SetCookie]
newClientCookies ]))
  SResponse -> Session SResponse
forall (m :: * -> *) a. Monad m => a -> m a
return SResponse
response

-- | Similar to 'request', but allows setting the request body as a plain
-- 'L.ByteString'.
srequest :: SRequest -> Session SResponse
srequest :: SRequest -> Session SResponse
srequest (SRequest req :: Request
req bod :: ByteString
bod) = do
    IORef [ByteString]
refChunks <- IO (IORef [ByteString])
-> ReaderT Application (StateT ClientState IO) (IORef [ByteString])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [ByteString])
 -> ReaderT
      Application (StateT ClientState IO) (IORef [ByteString]))
-> IO (IORef [ByteString])
-> ReaderT Application (StateT ClientState IO) (IORef [ByteString])
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef ([ByteString] -> IO (IORef [ByteString]))
-> [ByteString] -> IO (IORef [ByteString])
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
bod
    Request -> Session SResponse
request (Request -> Session SResponse) -> Request -> Session SResponse
forall a b. (a -> b) -> a -> b
$
      Request
req
        { requestBody :: IO ByteString
requestBody = IORef [ByteString]
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
refChunks (([ByteString] -> ([ByteString], ByteString)) -> IO ByteString)
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \bss :: [ByteString]
bss ->
            case [ByteString]
bss of
                [] -> ([], ByteString
S.empty)
                x :: ByteString
x:y :: [ByteString]
y -> ([ByteString]
y, ByteString
x)
        }

runResponse :: IORef SResponse -> Response -> IO ResponseReceived
runResponse :: IORef SResponse -> Response -> IO ResponseReceived
runResponse ref :: IORef SResponse
ref res :: Response
res = do
    IORef Builder
refBuilder <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
    let add :: Builder -> IO ()
add y :: Builder
y = IORef Builder -> (Builder -> (Builder, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Builder
refBuilder ((Builder -> (Builder, ())) -> IO ())
-> (Builder -> (Builder, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \x :: Builder
x -> (Builder
x Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
y, ())
    (StreamingBody -> IO ()) -> IO ()
forall a. (StreamingBody -> IO a) -> IO a
withBody ((StreamingBody -> IO ()) -> IO ())
-> (StreamingBody -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \body :: StreamingBody
body -> StreamingBody
body Builder -> IO ()
add (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    Builder
builder <- IORef Builder -> IO Builder
forall a. IORef a -> IO a
readIORef IORef Builder
refBuilder
    let lbs :: ByteString
lbs = Builder -> ByteString
toLazyByteString Builder
builder
        len :: Int64
len = ByteString -> Int64
L.length ByteString
lbs
    -- Force evaluation of the body to have exceptions thrown at the right
    -- time.
    Int64 -> IO () -> IO ()
forall a b. a -> b -> b
seq Int64
len (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef SResponse -> SResponse -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef SResponse
ref (SResponse -> IO ()) -> SResponse -> IO ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> SResponse
SResponse Status
s ResponseHeaders
h (ByteString -> SResponse) -> ByteString -> SResponse
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
builder
    ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
  where
    (s :: Status
s, h :: ResponseHeaders
h, withBody :: (StreamingBody -> IO a) -> IO a
withBody) = Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
res

assertBool :: String -> Bool -> Session ()
assertBool :: String -> Bool -> Session ()
assertBool s :: String
s b :: Bool
b = Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> Session ()
assertFailure String
s

assertString :: String -> Session ()
assertString :: String -> Session ()
assertString s :: String
s = Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> Session ()
assertFailure String
s

assertFailure :: String -> Session ()
assertFailure :: String -> Session ()
assertFailure msg :: String
msg = String
msg String -> Session () -> Session ()
forall a b. NFData a => a -> b -> b
`deepseq` IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (WaiTestFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> WaiTestFailure
WaiTestFailure String
msg))

data WaiTestFailure = WaiTestFailure String
    deriving (Int -> WaiTestFailure -> ShowS
[WaiTestFailure] -> ShowS
WaiTestFailure -> String
(Int -> WaiTestFailure -> ShowS)
-> (WaiTestFailure -> String)
-> ([WaiTestFailure] -> ShowS)
-> Show WaiTestFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WaiTestFailure] -> ShowS
$cshowList :: [WaiTestFailure] -> ShowS
show :: WaiTestFailure -> String
$cshow :: WaiTestFailure -> String
showsPrec :: Int -> WaiTestFailure -> ShowS
$cshowsPrec :: Int -> WaiTestFailure -> ShowS
Show, WaiTestFailure -> WaiTestFailure -> Bool
(WaiTestFailure -> WaiTestFailure -> Bool)
-> (WaiTestFailure -> WaiTestFailure -> Bool) -> Eq WaiTestFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WaiTestFailure -> WaiTestFailure -> Bool
$c/= :: WaiTestFailure -> WaiTestFailure -> Bool
== :: WaiTestFailure -> WaiTestFailure -> Bool
$c== :: WaiTestFailure -> WaiTestFailure -> Bool
Eq, Typeable)
instance Exception WaiTestFailure

assertContentType :: ByteString -> SResponse -> Session ()
assertContentType :: ByteString -> SResponse -> Session ()
assertContentType ct :: ByteString
ct SResponse{simpleHeaders :: SResponse -> ResponseHeaders
simpleHeaders = ResponseHeaders
h} =
    case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "content-type" ResponseHeaders
h of
        Nothing -> String -> Session ()
assertString (String -> Session ()) -> String -> Session ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ "Expected content type "
            , ByteString -> String
forall a. Show a => a -> String
show ByteString
ct
            , ", but no content type provided"
            ]
        Just ct' :: ByteString
ct' -> String -> Bool -> Session ()
assertBool ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ "Expected content type "
            , ByteString -> String
forall a. Show a => a -> String
show ByteString
ct
            , ", but received "
            , ByteString -> String
forall a. Show a => a -> String
show ByteString
ct'
            ]) (ByteString -> ByteString
go ByteString
ct ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
go ByteString
ct')
  where
    go :: ByteString -> ByteString
go = (Char -> Bool) -> ByteString -> ByteString
S8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ';')

assertStatus :: Int -> SResponse -> Session ()
assertStatus :: Int -> SResponse -> Session ()
assertStatus i :: Int
i SResponse{simpleStatus :: SResponse -> Status
simpleStatus = Status
s} = String -> Bool -> Session ()
assertBool ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ "Expected status code "
    , Int -> String
forall a. Show a => a -> String
show Int
i
    , ", but received "
    , Int -> String
forall a. Show a => a -> String
show Int
sc
    ]) (Bool -> Session ()) -> Bool -> Session ()
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sc
  where
    sc :: Int
sc = Status -> Int
H.statusCode Status
s

assertBody :: L.ByteString -> SResponse -> Session ()
assertBody :: ByteString -> SResponse -> Session ()
assertBody lbs :: ByteString
lbs SResponse{simpleBody :: SResponse -> ByteString
simpleBody = ByteString
lbs'} = String -> Bool -> Session ()
assertBool ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ "Expected response body "
    , ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L8.unpack ByteString
lbs
    , ", but received "
    , ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L8.unpack ByteString
lbs'
    ]) (Bool -> Session ()) -> Bool -> Session ()
forall a b. (a -> b) -> a -> b
$ ByteString
lbs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
lbs'

assertBodyContains :: L.ByteString -> SResponse -> Session ()
assertBodyContains :: ByteString -> SResponse -> Session ()
assertBodyContains lbs :: ByteString
lbs SResponse{simpleBody :: SResponse -> ByteString
simpleBody = ByteString
lbs'} = String -> Bool -> Session ()
assertBool ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ "Expected response body to contain "
    , ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L8.unpack ByteString
lbs
    , ", but received "
    , ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L8.unpack ByteString
lbs'
    ]) (Bool -> Session ()) -> Bool -> Session ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
strict ByteString
lbs ByteString -> ByteString -> Bool
`S.isInfixOf` ByteString -> ByteString
strict ByteString
lbs'
  where
    strict :: ByteString -> ByteString
strict = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks

assertHeader :: CI ByteString -> ByteString -> SResponse -> Session ()
assertHeader :: HeaderName -> ByteString -> SResponse -> Session ()
assertHeader header :: HeaderName
header value :: ByteString
value SResponse{simpleHeaders :: SResponse -> ResponseHeaders
simpleHeaders = ResponseHeaders
h} =
    case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header ResponseHeaders
h of
        Nothing -> String -> Session ()
assertString (String -> Session ()) -> String -> Session ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ "Expected header "
            , HeaderName -> String
forall a. Show a => a -> String
show HeaderName
header
            , " to be "
            , ByteString -> String
forall a. Show a => a -> String
show ByteString
value
            , ", but it was not present"
            ]
        Just value' :: ByteString
value' -> String -> Bool -> Session ()
assertBool ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ "Expected header "
            , HeaderName -> String
forall a. Show a => a -> String
show HeaderName
header
            , " to be "
            , ByteString -> String
forall a. Show a => a -> String
show ByteString
value
            , ", but received "
            , ByteString -> String
forall a. Show a => a -> String
show ByteString
value'
            ]) (ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
value')

assertNoHeader :: CI ByteString -> SResponse -> Session ()
assertNoHeader :: HeaderName -> SResponse -> Session ()
assertNoHeader header :: HeaderName
header SResponse{simpleHeaders :: SResponse -> ResponseHeaders
simpleHeaders = ResponseHeaders
h} =
    case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header ResponseHeaders
h of
        Nothing -> () -> Session ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just s :: ByteString
s -> String -> Session ()
assertString (String -> Session ()) -> String -> Session ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ "Unexpected header "
            , HeaderName -> String
forall a. Show a => a -> String
show HeaderName
header
            , " containing "
            , ByteString -> String
forall a. Show a => a -> String
show ByteString
s
            ]

-- |
--
-- Since 3.0.6
assertClientCookieExists :: String -> ByteString -> Session ()
assertClientCookieExists :: String -> ByteString -> Session ()
assertClientCookieExists s :: String
s cookieName :: ByteString
cookieName = do
  ClientCookies
cookies <- Session ClientCookies
getClientCookies
  String -> Bool -> Session ()
assertBool String
s (Bool -> Session ()) -> Bool -> Session ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ClientCookies -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member ByteString
cookieName ClientCookies
cookies

-- |
--
-- Since 3.0.6
assertNoClientCookieExists :: String -> ByteString -> Session ()
assertNoClientCookieExists :: String -> ByteString -> Session ()
assertNoClientCookieExists s :: String
s cookieName :: ByteString
cookieName = do
  ClientCookies
cookies <- Session ClientCookies
getClientCookies
  String -> Bool -> Session ()
assertBool String
s (Bool -> Session ()) -> Bool -> Session ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> ClientCookies -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member ByteString
cookieName ClientCookies
cookies

-- |
--
-- Since 3.0.6
assertClientCookieValue :: String -> ByteString -> ByteString -> Session ()
assertClientCookieValue :: String -> ByteString -> ByteString -> Session ()
assertClientCookieValue s :: String
s cookieName :: ByteString
cookieName cookieValue :: ByteString
cookieValue = do
  ClientCookies
cookies <- Session ClientCookies
getClientCookies
  case ByteString -> ClientCookies -> Maybe SetCookie
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
cookieName ClientCookies
cookies of
    Nothing ->
      String -> Session ()
assertFailure (String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (cookie does not exist)")
    Just c :: SetCookie
c  ->
      String -> Bool -> Session ()
assertBool
        ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ String
s
          , " (actual value "
          , ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ SetCookie -> ByteString
Cookie.setCookieValue SetCookie
c
          , " expected value "
          , ByteString -> String
forall a. Show a => a -> String
show ByteString
cookieValue
          , ")"
          ]
        )
        (SetCookie -> ByteString
Cookie.setCookieValue SetCookie
c ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
cookieValue)