diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 7b6e004..51b6cb6 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -93,6 +93,20 @@ serverSatisfies api burl args preds = do InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" +serverDoesntSatisfy :: (HasGenRequest a) => + Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation +serverDoesntSatisfy api burl args preds = do + let reqs = ($ burl) <$> genRequest api + r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do + v <- run $ finishPredicates preds (noCheckStatus req) defManager + assert $ not $ null v + case r of + Success {} -> return () + GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests" + Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m + NoExpectedFailure {} -> expectationFailure $ "No expected failure" + InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" + noCheckStatus :: Request -> Request noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing} diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 7955094..0f72b7c 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -12,7 +12,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI import Servant.QuickCheck -import Servant.QuickCheck.Internal (genRequest) +import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy) spec :: Spec spec = do @@ -40,10 +40,11 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do it "fails for false predicates" $ do withServantServerAndContext api ctx server $ \burl -> do - -- Since this is the negation, and we want to check that all of the - -- predicates fail rather than one or more, we need to separate them out - serverSatisfies api burl args ((not <$> onlyJsonObjects) <%> mempty) - serverSatisfies api burl args ((not <$> getsHaveCacheControlHeader) <%> mempty) + serverDoesntSatisfy api burl args (onlyJsonObjects + <%> getsHaveCacheControlHeader + <%> headsHaveCacheControlHeader + <%> notAllowedContainsAllowHeader + <%> mempty) isComprehensiveSpec :: Spec isComprehensiveSpec = describe "HasGenRequest" $ do