From 482656b35e61d55f314e369e036c8e13b7a7223e Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Sun, 16 Jul 2017 08:51:17 -0700 Subject: [PATCH 1/3] 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 ------------------------------------------------------------------------------ From 3f6856103a284859a552a2cc91f1209b14444217 Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Sun, 16 Jul 2017 08:59:09 -0700 Subject: [PATCH 2/3] Add sanity check test in there to prove jsonEquality really is doing something different --- test/Servant/QuickCheck/InternalSpec.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 76ef168..b7188d4 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -71,12 +71,18 @@ serversEqualSpec = describe "serversEqual" $ do 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 + it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do + Right (Failure _ err) <- withServantServer jsonApi jsonServer1 $ \burl1 -> + withServantServer jsonApi jsonServer2 $ \burl2 -> do + safeEvalExample $ 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 regardless of ordering or whitespace" $ do + it "sees when JSON apis are not equal because any value is different" $ do Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 -> withServantServer jsonApi jsonServer3 $ \burl2 -> do safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality From 6c163dc98136add4b6e485489994a69802751c15 Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Sun, 15 Oct 2017 20:31:52 -0700 Subject: [PATCH 3/3] Utilize new FailedWith constructor to fix json equality tests --- test/Servant/QuickCheck/InternalSpec.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index b7188d4..9892f41 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -72,9 +72,9 @@ serversEqualSpec = describe "serversEqual" $ do 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 - Right (Failure _ err) <- withServantServer jsonApi jsonServer1 $ \burl1 -> + FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 -> withServantServer jsonApi jsonServer2 $ \burl2 -> do - safeEvalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality + 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 @@ -83,16 +83,16 @@ serversEqualSpec = describe "serversEqual" $ do serversEqual jsonApi burl1 burl2 args jsonEquality it "sees when JSON apis are not equal because any value is different" $ do - Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 -> + FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 -> withServantServer jsonApi jsonServer3 $ \burl2 -> do - safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality + 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 - Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 -> + FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 -> withServantServer jsonApi jsonServer4 $ \burl2 -> do - safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality + evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality show err `shouldContain` "Server equality failed" show err `shouldContain` "Path: /jsonComparison"