Add ResponseEquality

servant-quickcheck.cabal

@@ -24,6 +24,7 @@ library
                      , Servant.QuickCheck.Internal.Predicates
                      , Servant.QuickCheck.Internal.HasGenRequest
                      , Servant.QuickCheck.Internal.QuickCheck
+                     , Servant.QuickCheck.Internal.Equality
   build-depends:       base >=4.8 && <4.9
                      , QuickCheck == 2.8.*
                      , bytestring == 0.10.*

src/Servant/QuickCheck/Internal.hs

@@ -3,4 +3,5 @@ module Servant.QuickCheck.Internal (module X) where
 import Servant.QuickCheck.Internal.HasGenRequest as X
 import Servant.QuickCheck.Internal.Predicates as X
 import Servant.QuickCheck.Internal.QuickCheck as X
+import Servant.QuickCheck.Internal.Equality as X
 import Servant.QuickCheck.Internal.Benchmarking as X

src/Servant/QuickCheck/Internal/Equality.hs

@@ -0,0 +1,22 @@
+module Servant.QuickCheck.Internal.Equality where
+
+import Network.HTTP.Client
+import Data.Function (on)
+
+-- | Often the normal equality of responses is not what we want. For example,
+-- if responses contain a @Date@ header with the time of the response,
+-- responses will fail to be equal even though they morally are. This datatype
+-- represents other means of checking equality
+newtype ResponseEquality b
+  = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
+
+instance Monoid (ResponseEquality b) where
+  mempty = ResponseEquality $ \_ _ -> True
+  ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->
+    a x y && b x y
+
+allEquality :: Eq b => ResponseEquality b
+allEquality = ResponseEquality (==)
+
+bodyEquality :: Eq b => ResponseEquality b
+bodyEquality = ResponseEquality ((==) `on` responseBody)

src/Servant/QuickCheck/Internal/QuickCheck.hs

@@ -23,10 +23,12 @@ import           Test.QuickCheck          (Args (..), Property, forAll, Result (
                                            quickCheckWithResult, stdArgs)
 import System.IO.Unsafe (unsafePerformIO)
 import Test.QuickCheck.Monadic
+import qualified Data.ByteString.Lazy as BSL
 
 import Servant.QuickCheck.Internal.HasGenRequest
 import Servant.QuickCheck.Internal.Predicates
 import Servant.QuickCheck.Internal.Benchmarking
+import Servant.QuickCheck.Internal.Equality
 
 
 -- | Start a servant application on an open port, run the provided function,
@@ -49,13 +51,13 @@ withServantServer api server t
 -- Evidently, if the behaviour of the server is expected to be
 -- non-deterministic,  this function may produce spurious failures
 serversEqual :: HasGenRequest a =>
-  Proxy a -> BaseUrl -> BaseUrl -> Args -> Expectation
+  Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality BSL.ByteString -> Expectation
-serversEqual api burl1 burl2 args = do
+serversEqual api burl1 burl2 args req = do
   let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
   r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
     resp1 <- run $ httpLbs req1 defManager
     resp2 <- run $ httpLbs req2 defManager
-    assert $ resp1 == resp2
+    assert $ getResponseEquality req resp1 resp2
   case r of
     Success {} -> return ()
     GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

test/Servant/QuickCheck/InternalSpec.hs

@@ -25,7 +25,7 @@ serversEqualSpec = describe "serversEqual" $ do
   it "considers equal servers equal" $ do
     withServantServer api server $ \burl1 ->
       withServantServer api server $ \burl2 -> do
-        serversEqual api burl1 burl2 stdArgs { maxSuccess = 10000 }
+        serversEqual api burl1 burl2 stdArgs { maxSuccess = 10000 } bodyEquality