{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Hspec.Wai.Matcher (
  ResponseMatcher(..)
, MatchHeader(..)
, MatchBody(..)
, Body
, (<:>)
, bodyEquals
, bodyContains
, match
, formatHeader
) where

import           Prelude ()
import "base-compat" Prelude.Compat

import           Control.Monad
import           Data.Maybe
import           Data.String
import           Data.Text.Lazy.Encoding (encodeUtf8)
import qualified Data.Text.Lazy as T
import           Data.ByteString (ByteString)
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy as LB
import           Network.HTTP.Types
import           Network.Wai.Test

import           Test.Hspec.Wai.Util

type Body = LB.ByteString

data ResponseMatcher = ResponseMatcher {
  ResponseMatcher -> Int
matchStatus :: Int
, ResponseMatcher -> [MatchHeader]
matchHeaders :: [MatchHeader]
, ResponseMatcher -> MatchBody
matchBody :: MatchBody
}

data MatchHeader = MatchHeader ([Header] -> Body -> Maybe String)

data MatchBody = MatchBody ([Header] -> Body -> Maybe String)

bodyEquals :: Body -> MatchBody
bodyEquals :: Body -> MatchBody
bodyEquals Body
body = Body -> (ByteString -> ByteString -> Bool) -> MatchBody
bodySatisfies Body
body ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==)

bodyContains :: Body -> MatchBody
bodyContains :: Body -> MatchBody
bodyContains Body
body = Body -> (ByteString -> ByteString -> Bool) -> MatchBody
bodySatisfies Body
body ByteString -> ByteString -> Bool
SB.isInfixOf

bodySatisfies :: Body -> (ByteString -> ByteString -> Bool) -> MatchBody
bodySatisfies :: Body -> (ByteString -> ByteString -> Bool) -> MatchBody
bodySatisfies Body
body ByteString -> ByteString -> Bool
prop = ([(HeaderName, ByteString)] -> Body -> Maybe [Char]) -> MatchBody
MatchBody (\[(HeaderName, ByteString)]
_ Body
actual -> Body -> Body -> Maybe [Char]
bodyMatcher Body
actual Body
body)
  where
    bodyMatcher :: Body -> Body -> Maybe String
    bodyMatcher :: Body -> Body -> Maybe [Char]
bodyMatcher (Body -> ByteString
toStrict -> ByteString
actual) (Body -> ByteString
toStrict -> ByteString
expected) = [Char] -> [Char] -> [Char] -> [Char]
actualExpected [Char]
"body mismatch:" [Char]
actual_ [Char]
expected_ [Char] -> Maybe () -> Maybe [Char]
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString
expected ByteString -> ByteString -> Bool
`prop` ByteString
actual)
      where
        ([Char]
actual_, [Char]
expected_) = case (ByteString -> Maybe [Char]
safeToString ByteString
actual, ByteString -> Maybe [Char]
safeToString ByteString
expected) of
          (Just [Char]
x, Just [Char]
y) -> ([Char]
x, [Char]
y)
          (Maybe [Char], Maybe [Char])
_ -> (ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
actual, ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
expected)

matchAny :: MatchBody
matchAny :: MatchBody
matchAny = ([(HeaderName, ByteString)] -> Body -> Maybe [Char]) -> MatchBody
MatchBody (\[(HeaderName, ByteString)]
_ Body
_ -> Maybe [Char]
forall a. Maybe a
Nothing)

instance IsString MatchBody where
  fromString :: [Char] -> MatchBody
fromString = Body -> MatchBody
bodyEquals (Body -> MatchBody) -> ([Char] -> Body) -> [Char] -> MatchBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Body
encodeUtf8 (Text -> Body) -> ([Char] -> Text) -> [Char] -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

instance IsString ResponseMatcher where
  fromString :: [Char] -> ResponseMatcher
fromString = Int -> [MatchHeader] -> MatchBody -> ResponseMatcher
ResponseMatcher Int
200 [] (MatchBody -> ResponseMatcher)
-> ([Char] -> MatchBody) -> [Char] -> ResponseMatcher
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> MatchBody
forall a. IsString a => [Char] -> a
fromString

instance Num ResponseMatcher where
  fromInteger :: Integer -> ResponseMatcher
fromInteger Integer
n = Int -> [MatchHeader] -> MatchBody -> ResponseMatcher
ResponseMatcher (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) [] MatchBody
matchAny
  + :: ResponseMatcher -> ResponseMatcher -> ResponseMatcher
(+) =    [Char] -> ResponseMatcher -> ResponseMatcher -> ResponseMatcher
forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support (+)"
  (-) =    [Char] -> ResponseMatcher -> ResponseMatcher -> ResponseMatcher
forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support (-)"
  * :: ResponseMatcher -> ResponseMatcher -> ResponseMatcher
(*) =    [Char] -> ResponseMatcher -> ResponseMatcher -> ResponseMatcher
forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support (*)"
  abs :: ResponseMatcher -> ResponseMatcher
abs =    [Char] -> ResponseMatcher -> ResponseMatcher
forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support `abs`"
  signum :: ResponseMatcher -> ResponseMatcher
signum = [Char] -> ResponseMatcher -> ResponseMatcher
forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support `signum`"

match :: SResponse -> ResponseMatcher -> Maybe String
match :: SResponse -> ResponseMatcher -> Maybe [Char]
match (SResponse (Status Int
status ByteString
_) [(HeaderName, ByteString)]
headers Body
body) (ResponseMatcher Int
expectedStatus [MatchHeader]
expectedHeaders (MatchBody [(HeaderName, ByteString)] -> Body -> Maybe [Char]
bodyMatcher)) = [Maybe [Char]] -> Maybe [Char]
forall a. Monoid a => [a] -> a
mconcat [
    [Char] -> [Char] -> [Char] -> [Char]
actualExpected [Char]
"status mismatch:" (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
status) (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
expectedStatus) [Char] -> Maybe () -> Maybe [Char]
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
expectedStatus)
  , [(HeaderName, ByteString)] -> Body -> [MatchHeader] -> Maybe [Char]
checkHeaders [(HeaderName, ByteString)]
headers Body
body [MatchHeader]
expectedHeaders
  , [(HeaderName, ByteString)] -> Body -> Maybe [Char]
bodyMatcher [(HeaderName, ByteString)]
headers Body
body
  ]

actualExpected :: String -> String -> String -> String
actualExpected :: [Char] -> [Char] -> [Char] -> [Char]
actualExpected [Char]
message [Char]
actual [Char]
expected = [[Char]] -> [Char]
unlines [
    [Char]
message
  , [Char]
"  expected: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
expected
  , [Char]
"  but got:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
actual
  ]

checkHeaders :: [Header] -> Body -> [MatchHeader] -> Maybe String
checkHeaders :: [(HeaderName, ByteString)] -> Body -> [MatchHeader] -> Maybe [Char]
checkHeaders [(HeaderName, ByteString)]
headers Body
body [MatchHeader]
m = case [MatchHeader] -> [[Char]]
go [MatchHeader]
m of
    [] -> Maybe [Char]
forall a. Maybe a
Nothing
    [[Char]]
xs -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat [[Char]]
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"the actual headers were:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines (((HeaderName, ByteString) -> [Char])
-> [(HeaderName, ByteString)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (HeaderName, ByteString) -> [Char]
formatHeader [(HeaderName, ByteString)]
headers))
  where
    go :: [MatchHeader] -> [[Char]]
go = [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]] -> [[Char]])
-> ([MatchHeader] -> [Maybe [Char]]) -> [MatchHeader] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MatchHeader -> Maybe [Char]) -> [MatchHeader] -> [Maybe [Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\(MatchHeader [(HeaderName, ByteString)] -> Body -> Maybe [Char]
p) -> [(HeaderName, ByteString)] -> Body -> Maybe [Char]
p [(HeaderName, ByteString)]
headers Body
body)

(<:>) :: HeaderName -> ByteString -> MatchHeader
HeaderName
name <:> :: HeaderName -> ByteString -> MatchHeader
<:> ByteString
value = ([(HeaderName, ByteString)] -> Body -> Maybe [Char]) -> MatchHeader
MatchHeader (([(HeaderName, ByteString)] -> Body -> Maybe [Char])
 -> MatchHeader)
-> ([(HeaderName, ByteString)] -> Body -> Maybe [Char])
-> MatchHeader
forall a b. (a -> b) -> a -> b
$ \[(HeaderName, ByteString)]
headers Body
_body -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((HeaderName, ByteString)
header (HeaderName, ByteString) -> [(HeaderName, ByteString)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(HeaderName, ByteString)]
headers) Maybe () -> Maybe [Char] -> Maybe [Char]
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> ([[Char]] -> [Char]) -> [[Char]] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines) [
    [Char]
"missing header:"
  , (HeaderName, ByteString) -> [Char]
formatHeader (HeaderName, ByteString)
header
  ]
  where
    header :: (HeaderName, ByteString)
header = (HeaderName
name, ByteString
value)