mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-08-16 22:00:32 +03:00
Better failure tests
This commit is contained in:
parent
5840ae7856
commit
c85d41ad79
@ -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}
|
||||
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user