git.iko.soy/servant-quickcheck
on master help sign in
Better failure tests
commitc85d41ad794f878734b27e1f25821257d3dcc9d1 authorJulian K. Arni <jkarni@gmail.com> dateTue 26 Apr 2016, 14:43 (11 years ago) parent5840ae7
2 files changed+20−5
compare with master
unifiedsplit
src/Servant/QuickCheck/Internal/QuickCheck.hs+14 test/Servant/QuickCheck/InternalSpec.hs+6−5
src/Servant/QuickCheck/Internal/QuickCheck.hs+14
@@ -93,6 +93,20 @@ serverSatisfies api burl args preds = do
9393 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
9494
9595
96+serverDoesntSatisfy :: (HasGenRequest a) =>
97+ Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
98+serverDoesntSatisfy api burl args preds = do
99+ let reqs = ($ burl) <$> genRequest api
100+ r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
101+ v <- run $ finishPredicates preds (noCheckStatus req) defManager
102+ assert $ not $ null v
103+ case r of
104+ Success {} -> return ()
105+ GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
106+ Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
107+ NoExpectedFailure {} -> expectationFailure $ "No expected failure"
108+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
109+
96110noCheckStatus :: Request -> Request
97111noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
98112
test/Servant/QuickCheck/InternalSpec.hs+6−5
@@ -12,7 +12,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI
1212
1313import Servant.QuickCheck
1414
15−import Servant.QuickCheck.Internal (genRequest)
15+import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
1616
1717spec :: Spec
1818spec = do
@@ -40,10 +40,11 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
4040
4141 it "fails for false predicates" $ do
4242 withServantServerAndContext api ctx server $ \burl -> do
43− -- Since this is the negation, and we want to check that all of the
44− -- predicates fail rather than one or more, we need to separate them out
45− serverSatisfies api burl args ((not <$> onlyJsonObjects) <%> mempty)
46− serverSatisfies api burl args ((not <$> getsHaveCacheControlHeader) <%> mempty)
43+ serverDoesntSatisfy api burl args (onlyJsonObjects
44+ <%> getsHaveCacheControlHeader
45+ <%> headsHaveCacheControlHeader
46+ <%> notAllowedContainsAllowHeader
47+ <%> mempty)
4748
4849isComprehensiveSpec :: Spec
4950isComprehensiveSpec = describe "HasGenRequest" $ do