git.iko.soy/servant-quickcheck
on master help sign in
Much better errors
commit2c1152a8c0cda0909045bc1553970b4ae85a1b7c authorJulian K. Arni <jkarni@gmail.com> dateSun 28 Aug 2016, 19:15 (10 years ago) parentb7df33f
4 files changed+233−200
compare with master
unifiedsplit
src/Servant/QuickCheck/Internal/ErrorTypes.hs+64−32 src/Servant/QuickCheck/Internal/Predicates.hs+111−123 src/Servant/QuickCheck/Internal/QuickCheck.hs+20−8 test/Servant/QuickCheck/InternalSpec.hs+38−37
src/Servant/QuickCheck/Internal/ErrorTypes.hs+64−32
@@ -1,40 +1,72 @@
11module Servant.QuickCheck.Internal.ErrorTypes where
22
3−import Text.PrettyPrint
4−import Prelude.Compat
5−import Data.String (IsString(fromString))
6−import GHC.Generics (Generic)
7−
8−data Request = Request
9− { requestBody :: String
10− , requestHeaders :: [String]
11− , requestUrl :: String
12− } deriving (Eq, Show, Read, Generic)
13−
14−prettyReq :: Request -> Doc
3+import Control.Exception (Exception (..))
4+import qualified Data.ByteString.Lazy as LBS
5+import Data.String.Conversions (cs)
6+import qualified Data.Text as T
7+import GHC.Generics (Generic)
8+import qualified Network.HTTP.Client as C
9+import Network.HTTP.Types (Header, statusCode)
10+import Prelude.Compat
11+import Text.PrettyPrint
12+
13+prettyHeaders :: [Header] -> Doc
14+prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs
15+ where
16+ prettyHdr (hn, h) = text (show hn) <> colon <+> text (show h)
17+
18+prettyReq :: C.Request -> Doc
1519prettyReq r =
1620 text "Request:" $$ (nest 5 $
17− text "URL:" <+> (nest 5 $ text $ requestUrl r)
18− $$ text "Headers:" <+> (nest 5 $ hsep $ text <$> requestHeaders r)
19− $$ text "Body:" <+> (nest 5 $ text $ requestBody r))
20−
21−instance IsString Request where
22− fromString url = Request "" [] url
21+ text "Method:" <+> (nest 5 $ text . show $ C.method r)
22+ $$ text "Path:" <+> (nest 5 $ text . cs $ C.path r)
23+ $$ text "Headers:" <+> (nest 5 $ prettyHeaders $ C.requestHeaders r)
24+ $$ text "Body:" <+> (nest 5 $ text . getReqBody $ C.requestBody r))
25+ where
26+ getReqBody (C.RequestBodyLBS lbs ) = cs lbs
27+ getReqBody (C.RequestBodyBS bs ) = cs bs
28+ getReqBody _ = error "expected bytestring body"
2329
24−data Response = Response
25− { responseBody :: String
26− , responseHeaders :: [String]
27− } deriving (Eq, Show, Read, Generic)
30+prettyResp :: C.Response LBS.ByteString -> Doc
31+prettyResp r =
32+ text "Response:" $$ (nest 5 $
33+ text "Status code:" <+> (nest 5 $ text . show . statusCode $ C.responseStatus r)
34+ $$ text "Headers:" $$ (nest 10 $ prettyHeaders $ C.responseHeaders r)
35+ $$ text "Body:" <+> (nest 5 $ text . cs $ C.responseBody r))
2836
29−instance IsString Response where
30− fromString body = Response body []
3137
3238-- The error that occurred.
33−data Failure
34− = PredicateFailure String Request Response
35− | ServerEqualityFailure Request Response Response
36− deriving (Eq, Read, Generic)
37−
38−instance Show Failure where
39− show (PredicateFailure pred req resp)
40− = "Predicate failed for " ++ pred
39+data PredicateFailure = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
40+ deriving (Generic)
41+
42+data ServerEqualityFailure = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)
43+ deriving (Generic)
44+
45+prettyServerEqualityFailure :: ServerEqualityFailure -> Doc
46+prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =
47+ text "Server equality failed" $$ (nest 5 $
48+ prettyReq req
49+ $$ prettyResp resp1
50+ $$ prettyResp resp2)
51+
52+
53+prettyPredicateFailure :: PredicateFailure -> Doc
54+prettyPredicateFailure (PredicateFailure predicate req resp) =
55+ text "Predicate failed" $$ (nest 5 $
56+ text "Predicate:" <+> (text $ T.unpack predicate)
57+ $$ r
58+ $$ prettyResp resp)
59+ where
60+ r = case req of
61+ Nothing -> text ""
62+ Just v -> prettyReq v
63+
64+instance Show ServerEqualityFailure where
65+ show = render . prettyServerEqualityFailure
66+
67+instance Exception ServerEqualityFailure where
68+
69+instance Show PredicateFailure where
70+ show = render . prettyPredicateFailure
71+
72+instance Exception PredicateFailure where
src/Servant/QuickCheck/Internal/Predicates.hs+111−123
@@ -1,6 +1,8 @@
11module Servant.QuickCheck.Internal.Predicates where
22
3−import Control.Monad (liftM2)
3+import Control.Exception (catch, SomeException, throw)
4+import Control.Monad (liftM2, guard, ap)
5+import Control.Monad.Reader
46import Data.Aeson (Object, decode)
57import Data.Bifunctor (Bifunctor (..))
68import Prelude.Compat
@@ -24,6 +26,9 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod,
2426 status300, status401, status405,
2527 status500, status100)
2628
29+import Servant.QuickCheck.Internal.ErrorTypes
30+
31+
2732-- | [__Best Practice__]
2833--
2934-- @500 Internal Server Error@ should be avoided - it may represent some
@@ -33,8 +38,9 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod,
3338-- This function checks that the response code is not 500.
3439--
3540-- /Since 0.0.0.0/
36−not500 :: ResponsePredicate Text Bool
37−not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
41+not500 :: ResponsePredicate
42+not500 = ResponsePredicate $ \resp ->
43+ when (responseStatus resp == status500) $ fail "not500"
3844
3945-- | [__Best Practice__]
4046--
@@ -57,11 +63,11 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu
5763-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
5864--
5965-- /Since 0.0.0.0/
60−onlyJsonObjects :: ResponsePredicate Text Bool
66+onlyJsonObjects :: ResponsePredicate
6167onlyJsonObjects
62− = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
63− Nothing -> False
64− Just (_ :: Object) -> True)
68+ = ResponsePredicate (\resp -> case decode (responseBody resp) of
69+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
70+ Just (_ :: Object) -> return ())
6571
6672-- | __Optional__
6773--
@@ -82,25 +88,24 @@ onlyJsonObjects
8288-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
8389--
8490-- /Since 0.0.0.0/
85−createContainsValidLocation :: RequestPredicate Text Bool
91+createContainsValidLocation :: RequestPredicate
8692createContainsValidLocation
87− = RequestPredicate
88− { reqPredName = "createContainsValidLocation"
89− , reqResps = \req mgr -> do
90− resp <- httpLbs req mgr
91− if responseStatus resp == status201
92− then case lookup "Location" $ responseHeaders resp of
93− Nothing -> return (False, [resp])
94− Just l -> case parseUrl $ SBSC.unpack l of
95− Nothing -> return (False, [resp])
96− Just x -> do
97− resp2 <- httpLbs x mgr
98− return (status2XX resp2, [resp, resp2])
99− else return (True, [resp])
100− }
93+ = RequestPredicate $ \req mgr -> do
94+ let n = "createContainsValidLocation"
95+ resp <- httpLbs req mgr
96+ if responseStatus resp == status201
97+ then case lookup "Location" $ responseHeaders resp of
98+ Nothing -> fail n
99+ Just l -> case parseUrl $ SBSC.unpack l of
100+ Nothing -> fail n
101+ Just x -> do
102+ resp2 <- httpLbs x mgr
103+ status2XX resp2 n
104+ return [resp, resp2]
105+ else return [resp]
101106
102107{-
103−getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
108+getsHaveLastModifiedHeader :: ResponsePredicate
104109getsHaveLastModifiedHeader
105110 = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
106111
@@ -122,18 +127,17 @@ getsHaveLastModifiedHeader
122127-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
123128--
124129-- /Since 0.0.0.0/
125−notAllowedContainsAllowHeader :: RequestPredicate Text Bool
130+notAllowedContainsAllowHeader :: RequestPredicate
126131notAllowedContainsAllowHeader
127− = RequestPredicate
128− { reqPredName = "notAllowedContainsAllowHeader"
129− , reqResps = \req mgr -> do
130− resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
131− | m <- [minBound .. maxBound ]
132− , renderStdMethod m /= method req ]
133− return (all pred' resp, resp)
134− }
132+ = RequestPredicate $ \req mgr -> do
133+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
134+ | m <- [minBound .. maxBound ]
135+ , renderStdMethod m /= method req ]
136+ case filter pred' resp of
137+ (x:xs) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x
138+ [] -> return resp
135139 where
136− pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp
140+ pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
137141 where
138142 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
139143 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -154,19 +158,19 @@ notAllowedContainsAllowHeader
154158-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
155159--
156160-- /Since 0.0.0.0/
157−honoursAcceptHeader :: RequestPredicate Text Bool
161+honoursAcceptHeader :: RequestPredicate
158162honoursAcceptHeader
159− = RequestPredicate
160− { reqPredName = "honoursAcceptHeader"
161− , reqResps = \req mgr -> do
162− resp <- httpLbs req mgr
163− let scode = responseStatus resp
164− sctype = lookup "Content-Type" $ responseHeaders resp
165− sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
166− if status100 < scode && scode < status300
167− then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])
168− else return (True, [resp])
169− }
163+ = RequestPredicate $ \req mgr -> do
164+ resp <- httpLbs req mgr
165+ let scode = responseStatus resp
166+ sctype = lookup "Content-Type" $ responseHeaders resp
167+ sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
168+ if status100 < scode && scode < status300
169+ then if isJust $ sctype >>= \x -> matchAccept [x] sacc
170+ then fail "honoursAcceptHeader"
171+ else return [resp]
172+ else return [resp]
173+
170174
171175-- | [__Best Practice__]
172176--
@@ -182,34 +186,32 @@ honoursAcceptHeader
182186-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
183187--
184188-- /Since 0.0.0.0/
185−getsHaveCacheControlHeader :: RequestPredicate Text Bool
189+getsHaveCacheControlHeader :: RequestPredicate
186190getsHaveCacheControlHeader
187− = RequestPredicate
188− { reqPredName = "getsHaveCacheControlHeader"
189− , reqResps = \req mgr -> if method req == methodGet
190− then do
191− resp <- httpLbs req mgr
192− let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
193− return (good, [resp])
194− else return (True, [])
195− }
191+ = RequestPredicate $ \req mgr ->
192+ if (method req == methodGet)
193+ then do
194+ resp <- httpLbs req mgr
195+ unless (hasValidHeader "Cache-Control" (const True) resp) $ do
196+ throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp
197+ return [resp]
198+ else return []
196199
197200-- | [__Best Practice__]
198201--
199202-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
200203--
201204-- /Since 0.0.0.0/
202−headsHaveCacheControlHeader :: RequestPredicate Text Bool
205+headsHaveCacheControlHeader :: RequestPredicate
203206headsHaveCacheControlHeader
204− = RequestPredicate
205− { reqPredName = "headsHaveCacheControlHeader"
206− , reqResps = \req mgr -> if method req == methodHead
207− then do
208− resp <- httpLbs req mgr
209− let good = hasValidHeader "Cache-Control" (const True) resp
210− return (good, [resp])
211− else return (True, [])
212− }
207+ = RequestPredicate $ \req mgr ->
208+ if (method req == methodHead)
209+ then do
210+ resp <- httpLbs req mgr
211+ unless (hasValidHeader "Cache-Control" (const True) resp) $
212+ throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp
213+ return [resp]
214+ else return []
213215{-
214216-- |
215217--
@@ -271,12 +273,13 @@ linkHeadersAreValid
271273-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
272274--
273275-- /Since 0.0.0.0/
274−unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool
276+unauthorizedContainsWWWAuthenticate :: ResponsePredicate
275277unauthorizedContainsWWWAuthenticate
276− = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->
278+ = ResponsePredicate $ \resp ->
277279 if responseStatus resp == status401
278− then hasValidHeader "WWW-Authenticate" (const True) resp
279− else True)
280+ then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
281+ fail "unauthorizedContainsWWWAuthenticate"
282+ else return ()
280283
281284-- * Predicate logic
282285
@@ -289,67 +292,46 @@ unauthorizedContainsWWWAuthenticate
289292-- | A predicate that depends only on the response.
290293--
291294-- /Since 0.0.0.0/
292−data ResponsePredicate n r = ResponsePredicate
293− { respPredName :: n
294− , respPred :: Response LBS.ByteString -> r
295− } deriving (Functor, Generic)
296−
297−instance Bifunctor ResponsePredicate where
298− first f (ResponsePredicate a b) = ResponsePredicate (f a) b
299− second = fmap
300−
301−instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
302− mempty = ResponsePredicate mempty mempty
303− a `mappend` b = ResponsePredicate
304− { respPredName = respPredName a <> respPredName b
305− , respPred = respPred a <> respPred b
306− }
295+data ResponsePredicate = ResponsePredicate
296+ { getResponsePredicate :: Response LBS.ByteString -> IO ()
297+ } deriving (Generic)
298+
299+instance Monoid ResponsePredicate where
300+ mempty = ResponsePredicate $ const $ return ()
301+ ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
307302
308303-- | A predicate that depends on both the request and the response.
309304--
310305-- /Since 0.0.0.0/
311−data RequestPredicate n r = RequestPredicate
312− { reqPredName :: n
313− , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])
314− } deriving (Generic, Functor)
315−
316−instance Bifunctor RequestPredicate where
317− first f (RequestPredicate a b) = RequestPredicate (f a) b
318− second = fmap
306+data RequestPredicate = RequestPredicate
307+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
308+ } deriving (Generic)
319309
320310-- TODO: This isn't actually a monoid
321−instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
322− mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))
323− a `mappend` b = RequestPredicate
324− { reqPredName = reqPredName a <> reqPredName b
325− , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
326− }
311+instance Monoid RequestPredicate where
312+ mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
313+ RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->
314+ liftM2 (<>) (a r mgr) (b r mgr)
327315
328316-- | A set of predicates. Construct one with 'mempty' and '<%>'.
329−data Predicates n r = Predicates
330− { reqPreds :: RequestPredicate n r
331− , respPreds :: ResponsePredicate n r
332− } deriving (Generic, Functor)
317+data Predicates = Predicates
318+ { requestPredicates :: RequestPredicate
319+ , responsePredicates :: ResponsePredicate
320+ } deriving (Generic)
333321
334−instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
322+instance Monoid Predicates where
335323 mempty = Predicates mempty mempty
336− a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
337−
338−
324+ a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
325+ (responsePredicates a <> responsePredicates b)
339326
340327class JoinPreds a where
341− joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
342−
343−instance JoinPreds (RequestPredicate Text Bool) where
344− joinPreds p (Predicates x y) = Predicates (go <> x) y
345− where go = let p' = first return p
346− in fmap (\z -> if z then [] else reqPredName p') p'
328+ joinPreds :: a -> Predicates -> Predicates
347329
348−instance JoinPreds (ResponsePredicate Text Bool) where
349− joinPreds p (Predicates x y) = Predicates x (go <> y)
350− where go = let p' = first return p
351− in fmap (\z -> if z then [] else respPredName p') p'
330+instance JoinPreds (RequestPredicate ) where
331+ joinPreds p (Predicates x y) = Predicates (p <> x) y
352332
333+instance JoinPreds (ResponsePredicate ) where
334+ joinPreds p (Predicates x y) = Predicates x (p <> y)
353335
354336-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
355337-- the existing predicates.
@@ -357,14 +339,17 @@ instance JoinPreds (ResponsePredicate Text Bool) where
357339-- > not500 <%> onlyJsonObjects <%> empty
358340--
359341-- /Since 0.0.0.0/
360−(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
342+(<%>) :: JoinPreds a => a -> Predicates -> Predicates
361343(<%>) = joinPreds
362344infixr 6 <%>
363345
364−finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
365−finishPredicates p req mgr = do
366− (soFar, resps) <- reqResps (reqPreds p) req mgr
367− return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]
346+finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
347+finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
348+ where
349+ go = do
350+ resps <- getRequestPredicate (requestPredicates p) req mgr
351+ mapM_ (getResponsePredicate $ responsePredicates p) resps
352+ return Nothing
368353
369354-- * helpers
370355
@@ -373,5 +358,8 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
373358 Nothing -> False
374359 Just v -> p v
375360
376−status2XX :: Response b -> Bool
377−status2XX r = status200 <= responseStatus r && responseStatus r < status300
361+status2XX :: Monad m => Response b -> String -> m ()
362+status2XX r t
363+ | status200 <= responseStatus r && responseStatus r < status300
364+ = return ()
365+ | otherwise = fail t
src/Servant/QuickCheck/Internal/QuickCheck.hs+20−8
@@ -1,3 +1,4 @@
1+{-# LANGUAGE RecordWildCards #-}
12module Servant.QuickCheck.Internal.QuickCheck where
23
34import qualified Data.ByteString.Lazy as LBS
@@ -18,6 +19,7 @@ import Test.QuickCheck (Args (..), Result (..),
1819import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run, monitor)
1920import Test.QuickCheck.Property (counterexample)
2021import Control.Monad (unless)
22+import Control.Concurrent (newMVar, modifyMVar_, readMVar)
2123
2224import Servant.QuickCheck.Internal.Equality
2325import Servant.QuickCheck.Internal.HasGenRequest
@@ -60,17 +62,22 @@ serversEqual :: HasGenRequest a =>
6062 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
6163serversEqual api burl1 burl2 args req = do
6264 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
63− r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
65+ -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
66+ -- return results when a test fails, since an exception is throw.
67+ deetsMVar <- newMVar $ error "should not be called"
68+ r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
6469 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
6570 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
6671 unless (getResponseEquality req resp1 resp2) $ do
6772 monitor (counterexample "hi" )
73+ run $ modifyMVar_ deetsMVar $ const $ return $
74+ ServerEqualityFailure req1 resp1 resp2
6875 assert False
69−
7076 case r of
7177 Success {} -> return ()
78+ f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
79+ "Failed:\n" ++ show x
7280 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
73− Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
7481 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
7582 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
7683
@@ -94,22 +101,27 @@ serversEqual api burl1 burl2 args req = do
94101--
95102-- /Since 0.0.0.0/
96103serverSatisfies :: (HasGenRequest a) =>
97− Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
104+ Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
98105serverSatisfies api burl args preds = do
99106 let reqs = ($ burl) <$> genRequest api
100− r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
107+ deetsMVar <- newMVar $ error "should not be called"
108+ r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
101109 v <- run $ finishPredicates preds (noCheckStatus req) defManager
102− assert $ null v
110+ run $ modifyMVar_ deetsMVar $ const $ return v
111+ case v of
112+ Just x -> assert False
113+ _ -> return ()
103114 case r of
104115 Success {} -> return ()
116+ f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
117+ "Failed:\n" ++ show x
105118 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
106− Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
107119 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
108120 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
109121
110122
111123serverDoesntSatisfy :: (HasGenRequest a) =>
112− Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
124+ Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
113125serverDoesntSatisfy api burl args preds = do
114126 let reqs = ($ burl) <$> genRequest api
115127 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
test/Servant/QuickCheck/InternalSpec.hs+38−37
@@ -1,28 +1,27 @@
11{-# LANGUAGE CPP #-}
22module Servant.QuickCheck.InternalSpec (spec) where
33
4−import Control.Concurrent.MVar (newMVar, readMVar,
5− swapMVar)
6−import Control.Monad.IO.Class (liftIO)
7−import Prelude.Compat
8−import Servant
9−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
10−import Test.Hspec (Spec, context,
11− describe, it,
12− pending, shouldBe)
13−import Test.Hspec.Core.Spec (Arg, Example,
14− Result (..),
15− defaultParams,
16− evaluateExample)
17−
18−import Servant.QuickCheck
19−import Servant.QuickCheck.Internal (genRequest, Failure(..), serverDoesntSatisfy)
4+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
5+import Control.Monad.IO.Class (liftIO)
6+import Prelude.Compat
7+import Servant
8+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
9+import Test.Hspec (Spec, context, describe, it,
10+ pending, shouldBe,
11+ shouldContain)
12+import Test.Hspec.Core.Spec (Arg, Example, Result (..),
13+ defaultParams,
14+ evaluateExample)
15+
16+import Servant.QuickCheck
17+import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
2018
2119spec :: Spec
2220spec = do
2321 serversEqualSpec
2422 serverSatisfiesSpec
2523 isComprehensiveSpec
24+ onlyJsonObjectSpec
2625
2726serversEqualSpec :: Spec
2827serversEqualSpec = describe "serversEqual" $ do
@@ -34,28 +33,14 @@ serversEqualSpec = describe "serversEqual" $ do
3433
3534 context "when servers are not equal" $ do
3635
37− it "provides the failing requests in the error message" $ do
38− e <- withServantServer api2 server2 $ \burl1 ->
39− withServantServer api2 server3 $ \burl2 -> do
40− evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
41− e `shouldBe` e
4236
43− it "provides the failing requests in the error message" $ do
37+ it "provides the failing responses in the error message" $ do
4438 Fail _ err <- withServantServer api2 server2 $ \burl1 ->
4539 withServantServer api2 server3 $ \burl2 -> do
4640 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
47− print err
48− let ServerEqualityFailure req _ _ = read err
49− req `shouldBe` "failplz"
50−
51− {-it "provides the failing responses in the error message" $ do-}
52− {-Fail _ err <- withServantServer api2 server2 $ \burl1 ->-}
53− {-withServantServer api2 server3 $ \burl2 -> do-}
54− {-evalExample $ serversEqual api2 burl1 burl2 args bodyEquality-}
55− {-let ServerEqualityFailure _ r1 r2 = read err-}
56− {-r1 `shouldBe` "1"-}
57− {-r2 `shouldBe` "2"-}
58−
41+ show err `shouldContain` "Body: 1"
42+ show err `shouldContain` "Body: 2"
43+ show err `shouldContain` "Path: failplz/"
5944
6045serverSatisfiesSpec :: Spec
6146serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -74,8 +59,24 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
7459 <%> notAllowedContainsAllowHeader
7560 <%> mempty)
7661
77− context "when predicates are false" $
78− it "fails with informative error messages" $ pending
62+ context "when predicates are false" $ do
63+
64+ it "fails with informative error messages" $ do
65+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
66+ evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
67+ err `shouldContain` "getsHaveCacheControlHeader"
68+ err `shouldContain` "Headers"
69+ err `shouldContain` "Body"
70+
71+onlyJsonObjectSpec :: Spec
72+onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
73+
74+ it "fails correctly" $ do
75+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
76+ evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
77+ (onlyJsonObjects <%> mempty)
78+ err `shouldContain` "onlyJsonObjects"
79+
7980
8081isComprehensiveSpec :: Spec
8182isComprehensiveSpec = describe "HasGenRequest" $ do
@@ -133,5 +134,5 @@ noOfTestCases :: Int
133134#if LONG_TESTS
134135noOfTestCases = 20000
135136#else
136−noOfTestCases = 500
137+noOfTestCases = 1000
137138#endif