{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

-- | This entire module only serves to be backwards compatible with Test.Hspec.Wai.Matcher
--
-- This approach of asserting what the response looks like is obsolete because of the way sydtest does things.
-- You should use `shouldBe` instead.
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,
    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 = ([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_ forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString
actual 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])
_ -> (forall a. Show a => a -> [Char]
show ByteString
actual, forall a. Show a => a -> [Char]
show ByteString
expected)

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

instance IsString MatchBody where
  fromString :: [Char] -> MatchBody
fromString = Body -> MatchBody
bodyEquals forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Body
LB.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 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 [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString

instance Num ResponseMatcher where
  fromInteger :: Integer -> ResponseMatcher
fromInteger Integer
n = Int -> [MatchHeader] -> MatchBody -> ResponseMatcher
ResponseMatcher (forall a. Num a => Integer -> a
fromInteger Integer
n) [] MatchBody
matchAny
  + :: ResponseMatcher -> ResponseMatcher -> ResponseMatcher
(+) = forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support (+)"
  (-) = forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support (-)"
  * :: ResponseMatcher -> ResponseMatcher -> ResponseMatcher
(*) = forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support (*)"
  abs :: ResponseMatcher -> ResponseMatcher
abs = forall a. HasCallStack => [Char] -> a
error [Char]
"ResponseMatcher does not support `abs`"
  signum :: ResponseMatcher -> ResponseMatcher
signum = 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 forall a b. (a -> b) -> a -> b
$ \[Header]
headers Body
_body ->
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Header
header forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Header]
headers)
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall a. a -> Maybe a
Just 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: " forall a. [a] -> [a] -> [a]
++ [Char]
expected,
      [Char]
"  but got:  " forall a. [a] -> [a] -> [a]
++ [Char]
actual
    ]

formatHeader :: Header -> String
formatHeader :: Header -> [Char]
formatHeader header :: Header
header@(CI ByteString
name, ByteString
value) = [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe (forall a. Show a => a -> [Char]
show Header
header) (ByteString -> Maybe [Char]
safeToString forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B8.concat [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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just 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 forall a b. (a -> b) -> a -> b
$ case [Char]
str of
        [] -> Bool
True
        [Char]
_ -> Char -> Bool
Char.isSpace (forall a. [a] -> a
last [Char]
str) Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
Char.isPrint [Char]
str)
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isSafe forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
str