Merge pull request #30 from haskell-servant/jsonEquality

Add jsonEquality to compare JSON APIs

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

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(..)

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

test/Servant/QuickCheck/InternalSpec.hs

@@ -69,6 +69,34 @@ 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 "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
+      FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
+        withServantServer jsonApi jsonServer2 $ \burl2 -> do
+          evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
+      show err `shouldContain` "Server equality failed"
+
+    it "jsonEquality considers equal JSON apis equal regardless of key 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 because any value is different" $ do
+      FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
+        withServantServer jsonApi jsonServer3 $ \burl2 -> do
+          evalExample $ 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
+      FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
+        withServantServer jsonApi jsonServer4 $ \burl2 -> do
+          evalExample $ 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 +290,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
 ------------------------------------------------------------------------------