mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-09-11 18:37:09 +03:00
Add ResponseEquality
This commit is contained in:
parent
c1b92215c3
commit
c187be434d
@ -24,6 +24,7 @@ library
|
|||||||
, Servant.QuickCheck.Internal.Predicates
|
, Servant.QuickCheck.Internal.Predicates
|
||||||
, Servant.QuickCheck.Internal.HasGenRequest
|
, Servant.QuickCheck.Internal.HasGenRequest
|
||||||
, Servant.QuickCheck.Internal.QuickCheck
|
, Servant.QuickCheck.Internal.QuickCheck
|
||||||
|
, Servant.QuickCheck.Internal.Equality
|
||||||
build-depends: base >=4.8 && <4.9
|
build-depends: base >=4.8 && <4.9
|
||||||
, QuickCheck == 2.8.*
|
, QuickCheck == 2.8.*
|
||||||
, bytestring == 0.10.*
|
, bytestring == 0.10.*
|
||||||
|
@ -3,4 +3,5 @@ module Servant.QuickCheck.Internal (module X) where
|
|||||||
import Servant.QuickCheck.Internal.HasGenRequest as X
|
import Servant.QuickCheck.Internal.HasGenRequest as X
|
||||||
import Servant.QuickCheck.Internal.Predicates as X
|
import Servant.QuickCheck.Internal.Predicates as X
|
||||||
import Servant.QuickCheck.Internal.QuickCheck as X
|
import Servant.QuickCheck.Internal.QuickCheck as X
|
||||||
|
import Servant.QuickCheck.Internal.Equality as X
|
||||||
import Servant.QuickCheck.Internal.Benchmarking as X
|
import Servant.QuickCheck.Internal.Benchmarking as X
|
||||||
|
22
src/Servant/QuickCheck/Internal/Equality.hs
Normal file
22
src/Servant/QuickCheck/Internal/Equality.hs
Normal file
@ -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)
|
@ -23,10 +23,12 @@ import Test.QuickCheck (Args (..), Property, forAll, Result (
|
|||||||
quickCheckWithResult, stdArgs)
|
quickCheckWithResult, stdArgs)
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
import Test.QuickCheck.Monadic
|
import Test.QuickCheck.Monadic
|
||||||
|
import qualified Data.ByteString.Lazy as BSL
|
||||||
|
|
||||||
import Servant.QuickCheck.Internal.HasGenRequest
|
import Servant.QuickCheck.Internal.HasGenRequest
|
||||||
import Servant.QuickCheck.Internal.Predicates
|
import Servant.QuickCheck.Internal.Predicates
|
||||||
import Servant.QuickCheck.Internal.Benchmarking
|
import Servant.QuickCheck.Internal.Benchmarking
|
||||||
|
import Servant.QuickCheck.Internal.Equality
|
||||||
|
|
||||||
|
|
||||||
-- | Start a servant application on an open port, run the provided function,
|
-- | 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
|
-- Evidently, if the behaviour of the server is expected to be
|
||||||
-- non-deterministic, this function may produce spurious failures
|
-- non-deterministic, this function may produce spurious failures
|
||||||
serversEqual :: HasGenRequest a =>
|
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
|
let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
|
||||||
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
|
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
|
||||||
resp1 <- run $ httpLbs req1 defManager
|
resp1 <- run $ httpLbs req1 defManager
|
||||||
resp2 <- run $ httpLbs req2 defManager
|
resp2 <- run $ httpLbs req2 defManager
|
||||||
assert $ resp1 == resp2
|
assert $ getResponseEquality req resp1 resp2
|
||||||
case r of
|
case r of
|
||||||
Success {} -> return ()
|
Success {} -> return ()
|
||||||
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
||||||
|
@ -25,7 +25,7 @@ serversEqualSpec = describe "serversEqual" $ do
|
|||||||
it "considers equal servers equal" $ do
|
it "considers equal servers equal" $ do
|
||||||
withServantServer api server $ \burl1 ->
|
withServantServer api server $ \burl1 ->
|
||||||
withServantServer api server $ \burl2 -> do
|
withServantServer api server $ \burl2 -> do
|
||||||
serversEqual api burl1 burl2 stdArgs { maxSuccess = 10000 }
|
serversEqual api burl1 burl2 stdArgs { maxSuccess = 10000 } bodyEquality
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user