module Servant.QuickCheck.Internal.Equality where

import           Data.Aeson           (Value, decode, decodeStrict)
import           Data.ByteString      (ByteString)
import qualified Data.ByteString.Lazy as LB
import           Data.Function        (on)
import           Network.HTTP.Client  (Response (..), equivCookieJar, responseBody)
import           Prelude.Compat

newtype ResponseEquality b = ResponseEquality {forall b. ResponseEquality b -> Response b -> Response b -> Bool
getResponseEquality :: Response b -> Response b -> Bool}

instance Semigroup (ResponseEquality b) where
  ResponseEquality Response b -> Response b -> Bool
a <> :: ResponseEquality b -> ResponseEquality b -> ResponseEquality b
<> ResponseEquality Response b -> Response b -> Bool
b = (Response b -> Response b -> Bool) -> ResponseEquality b
forall b. (Response b -> Response b -> Bool) -> ResponseEquality b
ResponseEquality ((Response b -> Response b -> Bool) -> ResponseEquality b)
-> (Response b -> Response b -> Bool) -> ResponseEquality b
forall a b. (a -> b) -> a -> b
$ \Response b
x Response b
y ->
    Response b -> Response b -> Bool
a Response b
x Response b
y Bool -> Bool -> Bool
&& Response b -> Response b -> Bool
b Response b
x Response b
y

instance Monoid (ResponseEquality b) where
  mempty :: ResponseEquality b
mempty = (Response b -> Response b -> Bool) -> ResponseEquality b
forall b. (Response b -> Response b -> Bool) -> ResponseEquality b
ResponseEquality ((Response b -> Response b -> Bool) -> ResponseEquality b)
-> (Response b -> Response b -> Bool) -> ResponseEquality b
forall a b. (a -> b) -> a -> b
$ \Response b
_ Response b
_ -> Bool
True
  mappend :: ResponseEquality b -> ResponseEquality b -> ResponseEquality b
mappend = ResponseEquality b -> ResponseEquality b -> ResponseEquality b
forall a. Semigroup a => a -> a -> a
(<>)

{- | Use `Eq` instance for `Response`

/Since 0.0.0.0/
-}
allEquality :: (Eq b) => ResponseEquality b
allEquality :: forall b. Eq b => ResponseEquality b
allEquality = (Response b -> Response b -> Bool) -> ResponseEquality b
forall b. (Response b -> Response b -> Bool) -> ResponseEquality b
ResponseEquality ((Response b -> Response b -> Bool) -> ResponseEquality b)
-> (Response b -> Response b -> Bool) -> ResponseEquality b
forall a b. (a -> b) -> a -> b
$ \Response b
respa Response b
respb ->
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
    [ Response b -> Status
forall body. Response body -> Status
responseStatus Response b
respa Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Response b -> Status
forall body. Response body -> Status
responseStatus Response b
respb
    , Response b -> HttpVersion
forall body. Response body -> HttpVersion
responseVersion Response b
respa HttpVersion -> HttpVersion -> Bool
forall a. Eq a => a -> a -> Bool
== Response b -> HttpVersion
forall body. Response body -> HttpVersion
responseVersion Response b
respb
    , Response b -> ResponseHeaders
forall body. Response body -> ResponseHeaders
responseHeaders Response b
respa ResponseHeaders -> ResponseHeaders -> Bool
forall a. Eq a => a -> a -> Bool
== Response b -> ResponseHeaders
forall body. Response body -> ResponseHeaders
responseHeaders Response b
respb
    , Response b -> b
forall body. Response body -> body
responseBody Response b
respa b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== Response b -> b
forall body. Response body -> body
responseBody Response b
respb
    , Response b -> CookieJar
forall body. Response body -> CookieJar
responseCookieJar Response b
respa CookieJar -> CookieJar -> Bool
`equivCookieJar` Response b -> CookieJar
forall body. Response body -> CookieJar
responseCookieJar Response b
respb
    ]

{- | ByteString `Eq` instance over the response body.

/Since 0.0.0.0/
-}
bodyEquality :: (Eq b) => ResponseEquality b
bodyEquality :: forall b. Eq b => ResponseEquality b
bodyEquality = (Response b -> Response b -> Bool) -> ResponseEquality b
forall b. (Response b -> Response b -> Bool) -> ResponseEquality b
ResponseEquality (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) (b -> b -> Bool)
-> (Response b -> b) -> Response b -> Response b -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Response b -> b
forall body. Response body -> body
responseBody)

{- | Equality as 'Value'. This means that if two bodies are equal as JSON
(e.g., insignificant whitespace difference) they are considered equal.

/Since 0.0.3.0/
-}
jsonEquality :: (JsonEq b) => ResponseEquality b
jsonEquality :: forall b. JsonEq b => ResponseEquality b
jsonEquality = (Response b -> Response b -> Bool) -> ResponseEquality b
forall b. (Response b -> Response b -> Bool) -> ResponseEquality b
ResponseEquality (b -> b -> Bool
forall a. JsonEq a => a -> a -> Bool
jsonEq (b -> b -> Bool)
-> (Response b -> b) -> Response b -> Response b -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Response b -> b
forall body. Response body -> body
responseBody)

class JsonEq a where
  decode' :: a -> Maybe Value
  jsonEq :: a -> a -> Bool
  jsonEq a
first a
second = Maybe Value -> Maybe Value -> Bool
compareDecodedResponses (a -> Maybe Value
forall a. JsonEq a => a -> Maybe Value
decode' a
first) (a -> Maybe Value
forall a. JsonEq a => a -> Maybe Value
decode' a
second)

instance JsonEq LB.ByteString where
  decode' :: ByteString -> Maybe Value
decode' = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode

instance JsonEq ByteString where
  decode' :: ByteString -> Maybe Value
decode' = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict

compareDecodedResponses :: Maybe Value -> Maybe Value -> Bool
compareDecodedResponses :: Maybe Value -> Maybe Value -> Bool
compareDecodedResponses Maybe Value
resp1 Maybe Value
resp2 =
  case Maybe Value
resp1 of
    Maybe Value
Nothing -> Bool
False -- if decoding fails we assume failure
    (Just Value
r1) -> case Maybe Value
resp2 of
      Maybe Value
Nothing   -> Bool
False -- another decode failure
      (Just Value
r2) -> Value
r1 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
r2