From 482656b35e61d55f314e369e036c8e13b7a7223e Mon Sep 17 00:00:00 2001
From: Erik Aker <eraker@gmail.com>
Date: Sun, 16 Jul 2017 08:51:17 -0700
Subject: [PATCH] Create jsonEqaulity function and add some tests for similar
 JSON values but slightly different whitespace, ordering

---
 servant-quickcheck.cabal                    |  1 +
 src/Servant/QuickCheck.hs                   |  1 +
 src/Servant/QuickCheck/Internal/Equality.hs | 25 +++++++++++++
 test/Servant/QuickCheck/InternalSpec.hs     | 40 +++++++++++++++++++++
 4 files changed, 67 insertions(+)

diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal
index d6e4659..bbe954f 100644
--- a/servant-quickcheck.cabal
+++ b/servant-quickcheck.cabal
@@ -84,6 +84,7 @@ test-suite spec
   other-modules:       Servant.QuickCheck.InternalSpec
   build-depends:       base == 4.*
                      , base-compat
+                     , aeson
                      , servant-quickcheck
                      , bytestring
                      , hspec
diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs
index 962615e..7e8379b 100644
--- a/src/Servant/QuickCheck.hs
+++ b/src/Servant/QuickCheck.hs
@@ -49,6 +49,7 @@ module Servant.QuickCheck
   -- represents other means of checking equality
   -- *** Useful @ResponseEquality@s
   , bodyEquality
+  , jsonEquality
   , allEquality
   -- ** Response equality type
   , ResponseEquality(..)
diff --git a/src/Servant/QuickCheck/Internal/Equality.hs b/src/Servant/QuickCheck/Internal/Equality.hs
index 9aaf00a..a4ae9d6 100644
--- a/src/Servant/QuickCheck/Internal/Equality.hs
+++ b/src/Servant/QuickCheck/Internal/Equality.hs
@@ -1,5 +1,8 @@
 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, responseBody)
 import Prelude.Compat
@@ -23,3 +26,25 @@ allEquality = ResponseEquality (==)
 -- /Since 0.0.0.0/
 bodyEquality :: Eq b => ResponseEquality b
 bodyEquality = ResponseEquality ((==) `on` responseBody)
+
+jsonEquality :: (JsonEq b) => ResponseEquality b
+jsonEquality = ResponseEquality (jsonEq `on` responseBody)
+
+class JsonEq a where
+  decode' :: a -> Maybe Value
+  jsonEq :: a -> a -> Bool
+  jsonEq first second = compareDecodedResponses (decode' first) (decode' second)
+
+instance JsonEq LB.ByteString where
+  decode' = decode
+
+instance JsonEq ByteString where
+  decode' = decodeStrict
+
+compareDecodedResponses :: Maybe Value -> Maybe Value -> Bool
+compareDecodedResponses resp1 resp2 =
+  case resp1 of
+    Nothing -> False  -- if decoding fails we assume failure
+    (Just r1) -> case resp2 of
+      Nothing -> False  -- another decode failure
+      (Just r2) -> r1 == r2
diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs
index fa98eea..76ef168 100644
--- a/test/Servant/QuickCheck/InternalSpec.hs
+++ b/test/Servant/QuickCheck/InternalSpec.hs
@@ -69,6 +69,28 @@ serversEqualSpec = describe "serversEqual" $ do
       show err `shouldContain` "Body: 2"
       show err `shouldContain` "Path: /failplz"
 
+  context "when JSON is equal but looks a bit different as a ByteString" $ do
+
+    it "considers equal JSON apis equal regardless of ordering or whitespace" $ do
+      withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
+        withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
+          serversEqual jsonApi burl1 burl2 args jsonEquality
+
+    it "sees when JSON apis are not equal regardless of ordering or whitespace" $ do
+      Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
+        withServantServer jsonApi jsonServer3 $ \burl2 -> do
+          safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
+      show err `shouldContain` "Server equality failed"
+      show err `shouldContain` "Path: /jsonComparison"
+
+    it "sees when JSON apis are not equal due to different keys but same values" $ do
+      Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
+        withServantServer jsonApi jsonServer4 $ \burl2 -> do
+          safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
+      show err `shouldContain` "Server equality failed"
+      show err `shouldContain` "Path: /jsonComparison"
+
+
 serverSatisfiesSpec :: Spec
 serverSatisfiesSpec = describe "serverSatisfies" $ do
 
@@ -262,6 +284,24 @@ octetAPI = Proxy
 serverOctetAPI :: IO (Server OctetAPI)
 serverOctetAPI = return $ return "blah"
 
+type JsonApi = "jsonComparison" :> Get '[OctetStream] BS.ByteString
+
+jsonApi :: Proxy JsonApi
+jsonApi = Proxy
+
+jsonServer1 :: IO (Server JsonApi)
+jsonServer1 = return $ return "{ \"b\": [\"b\"], \"a\": 1 }"  -- whitespace, ordering different
+
+jsonServer2 :: IO (Server JsonApi)
+jsonServer2 = return $ return "{\"a\": 1,\"b\":[\"b\"]}"
+
+jsonServer3 :: IO (Server JsonApi)
+jsonServer3 = return $ return "{\"a\": 2, \"b\": [\"b\"]}"
+
+jsonServer4 :: IO (Server JsonApi)
+jsonServer4 = return $ return "{\"c\": 1, \"d\": [\"b\"]}"
+
+
 ctx :: Context '[BasicAuthCheck ()]
 ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
 ------------------------------------------------------------------------------