diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 05f1d03..da03b53 100644 --- a/servant-quickcheck.cabal +++ b/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.* diff --git a/src/Servant/QuickCheck/Internal.hs b/src/Servant/QuickCheck/Internal.hs index feee693..3663748 100644 --- a/src/Servant/QuickCheck/Internal.hs +++ b/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 diff --git a/src/Servant/QuickCheck/Internal/Equality.hs b/src/Servant/QuickCheck/Internal/Equality.hs new file mode 100644 index 0000000..25a60fe --- /dev/null +++ b/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) diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index bc425ea..f550ba3 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/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 -serversEqual api burl1 burl2 args = do + Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality BSL.ByteString -> Expectation +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" diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 55c9559..5ec7ada 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/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