Better failure tests

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}
 

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
+      serverDoesntSatisfy api burl args (onlyJsonObjects
-      -- predicates fail rather than one or more, we need to separate them out
+                                     <%> getsHaveCacheControlHeader
-      serverSatisfies api burl args ((not <$> onlyJsonObjects) <%> mempty)
+                                     <%> headsHaveCacheControlHeader
-      serverSatisfies api burl args ((not <$> getsHaveCacheControlHeader) <%> mempty)
+                                     <%> notAllowedContainsAllowHeader
+                                     <%> mempty)
 
 isComprehensiveSpec :: Spec
 isComprehensiveSpec = describe "HasGenRequest" $ do