{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Syd.Wai.Matcher where
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as LB
import qualified Data.CaseInsensitive as CI
import Data.Char as Char (isPrint, isSpace)
import Data.Maybe
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Network.HTTP.Types as HTTP
type Body = LB.ByteString
data ResponseMatcher = ResponseMatcher
{ ResponseMatcher -> Int
matchStatus :: Int,
:: [MatchHeader],
ResponseMatcher -> MatchBody
matchBody :: MatchBody
}
data = ([Header] -> Body -> Maybe String)
data MatchBody = MatchBody ([Header] -> Body -> Maybe String)
bodyEquals :: Body -> MatchBody
bodyEquals :: Body -> MatchBody
bodyEquals Body
body = ([Header] -> Body -> Maybe [Char]) -> MatchBody
MatchBody (\[Header]
_ 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
LB.toStrict -> ByteString
actual) (Body -> ByteString
LB.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 (ByteString
actual ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
expected)
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 = ([Header] -> Body -> Maybe [Char]) -> MatchBody
MatchBody (\[Header]
_ 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
. ByteString -> Body
LB.fromStrict (ByteString -> Body) -> ([Char] -> ByteString) -> [Char] -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> ([Char] -> Text) -> [Char] -> ByteString
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`"
(<:>) :: HeaderName -> ByteString -> MatchHeader
CI ByteString
name <:> :: CI ByteString -> ByteString -> MatchHeader
<:> ByteString
value = ([Header] -> Body -> Maybe [Char]) -> MatchHeader
MatchHeader (([Header] -> Body -> Maybe [Char]) -> MatchHeader)
-> ([Header] -> Body -> Maybe [Char]) -> MatchHeader
forall a b. (a -> b) -> a -> b
$ \[Header]
headers Body
_body ->
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Header
header Header -> [Header] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Header]
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:",
Header -> [Char]
formatHeader Header
header
]
where
header :: Header
header = (CI ByteString
name, ByteString
value)
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
]
formatHeader :: Header -> String
header :: Header
header@(CI ByteString
name, ByteString
value) = [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe (Header -> [Char]
forall a. Show a => a -> [Char]
show Header
header) (ByteString -> Maybe [Char]
safeToString (ByteString -> Maybe [Char]) -> ByteString -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B8.concat [CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
name, ByteString
": ", ByteString
value])
safeToString :: ByteString -> Maybe String
safeToString :: ByteString -> Maybe [Char]
safeToString ByteString
bs = do
[Char]
str <- (UnicodeException -> Maybe [Char])
-> (Text -> Maybe [Char])
-> Either UnicodeException Text
-> Maybe [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [Char] -> UnicodeException -> Maybe [Char]
forall a b. a -> b -> a
const Maybe [Char]
forall a. Maybe a
Nothing) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> (Text -> [Char]) -> Text -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) (ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bs)
let isSafe :: Bool
isSafe = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ case [Char]
str of
[] -> Bool
True
[Char]
_ -> Char -> Bool
Char.isSpace ([Char] -> Char
forall a. HasCallStack => [a] -> a
last [Char]
str) Bool -> Bool -> Bool
|| Bool -> Bool
not ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
Char.isPrint [Char]
str)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isSafe 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
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
str