{-# 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_ [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
formatHeader :: Header -> [Char]
formatHeader 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