2c1152a · servant-quickcheck

git.iko.soy/servant-quickcheck

on master help sign in

Much better errors

2c1152aJulian K. Arni10 years ago

src/Servant/QuickCheck/Internal/ErrorTypes.hs+64−32

compare with master

unifiedsplit

@@ -1,40 +1,72 @@

1module Servant.QuickCheck.Internal.ErrorTypes where

3−import Text.PrettyPrint

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)

4−import Prelude.Compat

10+import Prelude.Compat

5−import Data.String (IsString(fromString))

11+import Text.PrettyPrint

6−import GHC.Generics (Generic)

12+

7−

13+prettyHeaders :: [Header] -> Doc

8−data Request = Request

14+prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs

9− { requestBody :: String

15+ where

10− , requestHeaders :: [String]

16+ prettyHdr (hn, h) = text (show hn) <> colon <+> text (show h)

11− , requestUrl :: String

17+

12− } deriving (Eq, Show, Read, Generic)

13−

14−prettyReq :: Request -> Doc

18+prettyReq :: C.Request -> Doc

15prettyReq r =

19prettyReq r =

16 text "Request:" $$ (nest 5 $

20 text "Request:" $$ (nest 5 $

17− text "URL:" <+> (nest 5 $ text $ requestUrl r)

21+ text "Method:" <+> (nest 5 $ text . show $ C.method r)

22+ $$ text "Path:" <+> (nest 5 $ text . cs $ C.path r)

18− $$ text "Headers:" <+> (nest 5 $ hsep $ text <$> requestHeaders r)

23+ $$ text "Headers:" <+> (nest 5 $ prettyHeaders $ C.requestHeaders r)

19− $$ text "Body:" <+> (nest 5 $ text $ requestBody r))

24+ $$ text "Body:" <+> (nest 5 $ text . getReqBody $ C.requestBody r))

20−

25+ where

21−instance IsString Request where

26+ getReqBody (C.RequestBodyLBS lbs ) = cs lbs

22− fromString url = Request "" [] url

27+ getReqBody (C.RequestBodyBS bs ) = cs bs

28+ getReqBody _ = error "expected bytestring body"

30+prettyResp :: C.Response LBS.ByteString -> Doc

31+prettyResp r =

24−data Response = Response

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)

25− { responseBody :: String

35+ $$ text "Body:" <+> (nest 5 $ text . cs $ C.responseBody r))

26− , responseHeaders :: [String]

27− } deriving (Eq, Show, Read, Generic)

29−instance IsString Response where

30− fromString body = Response body []

32-- The error that occurred.

38-- The error that occurred.

33−data Failure

34− = PredicateFailure String Request Response

39+data PredicateFailure = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)

40+ deriving (Generic)

41+

35− | ServerEqualityFailure Request Response Response

42+data ServerEqualityFailure = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)

36− deriving (Eq, Read, Generic)

43+ deriving (Generic)

37−

44+

38−instance Show Failure where

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

39− show (PredicateFailure pred req resp)

54+prettyPredicateFailure (PredicateFailure predicate req resp) =

40− = "Predicate failed for " ++ pred

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 @@

1module Servant.QuickCheck.Internal.Predicates where

3+import Control.Exception (catch, SomeException, throw)

3−import Control.Monad (liftM2)

4+import Control.Monad (liftM2, guard, ap)

5+import Control.Monad.Reader

4import Data.Aeson (Object, decode)

6import Data.Aeson (Object, decode)

5import Data.Bifunctor (Bifunctor (..))

7import Data.Bifunctor (Bifunctor (..))

6import Prelude.Compat

8import Prelude.Compat

@@ -24,6 +26,9 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod,

24 status300, status401, status405,

26 status300, status401, status405,

25 status500, status100)

27 status500, status100)

29+import Servant.QuickCheck.Internal.ErrorTypes

30+

31+

27-- | [__Best Practice__]

32-- | [__Best Practice__]

28--

33--

29-- @500 Internal Server Error@ should be avoided - it may represent some

34-- @500 Internal Server Error@ should be avoided - it may represent some

@@ -33,8 +38,9 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod,

33-- This function checks that the response code is not 500.

38-- This function checks that the response code is not 500.

34--

39--

35-- /Since 0.0.0.0/

40-- /Since 0.0.0.0/

36−not500 :: ResponsePredicate Text Bool

41+not500 :: ResponsePredicate

37−not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)

42+not500 = ResponsePredicate $ \resp ->

43+ when (responseStatus resp == status500) $ fail "not500"

39-- | [__Best Practice__]

45-- | [__Best Practice__]

40--

46--

@@ -57,11 +63,11 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu

57-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>

63-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>

58--

64--

59-- /Since 0.0.0.0/

65-- /Since 0.0.0.0/

60−onlyJsonObjects :: ResponsePredicate Text Bool

66+onlyJsonObjects :: ResponsePredicate

61onlyJsonObjects

67onlyJsonObjects

62− = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of

68+ = ResponsePredicate (\resp -> case decode (responseBody resp) of

63− Nothing -> False

69+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp

64− Just (_ :: Object) -> True)

70+ Just (_ :: Object) -> return ())

66-- | __Optional__

72-- | __Optional__

67--

73--

@@ -82,25 +88,24 @@ onlyJsonObjects

82-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>

88-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>

83--

89--

84-- /Since 0.0.0.0/

90-- /Since 0.0.0.0/

85−createContainsValidLocation :: RequestPredicate Text Bool

91+createContainsValidLocation :: RequestPredicate

86createContainsValidLocation

92createContainsValidLocation

87− = RequestPredicate

93+ = RequestPredicate $ \req mgr -> do

88− { reqPredName = "createContainsValidLocation"

94+ let n = "createContainsValidLocation"

89− , reqResps = \req mgr -> do

90− resp <- httpLbs req mgr

95+ resp <- httpLbs req mgr

91− if responseStatus resp == status201

96+ if responseStatus resp == status201

92− then case lookup "Location" $ responseHeaders resp of

97+ then case lookup "Location" $ responseHeaders resp of

93− Nothing -> return (False, [resp])

98+ Nothing -> fail n

94− Just l -> case parseUrl $ SBSC.unpack l of

99+ Just l -> case parseUrl $ SBSC.unpack l of

95− Nothing -> return (False, [resp])

100+ Nothing -> fail n

96− Just x -> do

101+ Just x -> do

97− resp2 <- httpLbs x mgr

102+ resp2 <- httpLbs x mgr

98− return (status2XX resp2, [resp, resp2])

103+ status2XX resp2 n

104+ return [resp, resp2]

99− else return (True, [resp])

105+ else return [resp]

100− }

101

106

102{-

107{-

103−getsHaveLastModifiedHeader :: ResponsePredicate Text Bool

108+getsHaveLastModifiedHeader :: ResponsePredicate

104getsHaveLastModifiedHeader

109getsHaveLastModifiedHeader

105 = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->

110 = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->

106

111

@@ -122,18 +127,17 @@ getsHaveLastModifiedHeader

122-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>

127-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>

123--

128--

124-- /Since 0.0.0.0/

129-- /Since 0.0.0.0/

125−notAllowedContainsAllowHeader :: RequestPredicate Text Bool

130+notAllowedContainsAllowHeader :: RequestPredicate

126notAllowedContainsAllowHeader

131notAllowedContainsAllowHeader

127− = RequestPredicate

132+ = RequestPredicate $ \req mgr -> do

128− { reqPredName = "notAllowedContainsAllowHeader"

129− , reqResps = \req mgr -> do

130− resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }

133+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }

131− | m <- [minBound .. maxBound ]

134+ | m <- [minBound .. maxBound ]

132− , renderStdMethod m /= method req ]

135+ , renderStdMethod m /= method req ]

133− return (all pred' resp, resp)

136+ case filter pred' resp of

134− }

137+ (x:xs) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x

138+ [] -> return resp

135 where

139 where

136− pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp

140+ pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)

137 where

141 where

138 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)

142 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)

139 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)

143 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)

@@ -154,19 +158,19 @@ notAllowedContainsAllowHeader

154-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>

158-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>

155--

159--

156-- /Since 0.0.0.0/

160-- /Since 0.0.0.0/

157−honoursAcceptHeader :: RequestPredicate Text Bool

161+honoursAcceptHeader :: RequestPredicate

158honoursAcceptHeader

162honoursAcceptHeader

159− = RequestPredicate

163+ = RequestPredicate $ \req mgr -> do

160− { reqPredName = "honoursAcceptHeader"

161− , reqResps = \req mgr -> do

162− resp <- httpLbs req mgr

164+ resp <- httpLbs req mgr

163− let scode = responseStatus resp

165+ let scode = responseStatus resp

164− sctype = lookup "Content-Type" $ responseHeaders resp

166+ sctype = lookup "Content-Type" $ responseHeaders resp

165− sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)

167+ sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)

166− if status100 < scode && scode < status300

168+ if status100 < scode && scode < status300

167− then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])

169+ then if isJust $ sctype >>= \x -> matchAccept [x] sacc

170+ then fail "honoursAcceptHeader"

171+ else return [resp]

168− else return (True, [resp])

172+ else return [resp]

169− }

173+

170

174

171-- | [__Best Practice__]

175-- | [__Best Practice__]

172--

176--

@@ -182,34 +186,32 @@ honoursAcceptHeader

182-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>

186-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>

183--

187--

184-- /Since 0.0.0.0/

188-- /Since 0.0.0.0/

185−getsHaveCacheControlHeader :: RequestPredicate Text Bool

189+getsHaveCacheControlHeader :: RequestPredicate

186getsHaveCacheControlHeader

190getsHaveCacheControlHeader

187− = RequestPredicate

191+ = RequestPredicate $ \req mgr ->

188− { reqPredName = "getsHaveCacheControlHeader"

189− , reqResps = \req mgr -> if method req == methodGet

192+ if (method req == methodGet)

190− then do

193+ then do

191− resp <- httpLbs req mgr

194+ resp <- httpLbs req mgr

192− let good = isJust $ lookup "Cache-Control" $ responseHeaders resp

195+ unless (hasValidHeader "Cache-Control" (const True) resp) $ do

193− return (good, [resp])

196+ throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp

194− else return (True, [])

197+ return [resp]

195− }

198+ else return []

196

199

197-- | [__Best Practice__]

200-- | [__Best Practice__]

198--

201--

199-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.

202-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.

200--

203--

201-- /Since 0.0.0.0/

204-- /Since 0.0.0.0/

202−headsHaveCacheControlHeader :: RequestPredicate Text Bool

205+headsHaveCacheControlHeader :: RequestPredicate

203headsHaveCacheControlHeader

206headsHaveCacheControlHeader

204− = RequestPredicate

207+ = RequestPredicate $ \req mgr ->

205− { reqPredName = "headsHaveCacheControlHeader"

206− , reqResps = \req mgr -> if method req == methodHead

208+ if (method req == methodHead)

207− then do

209+ then do

208− resp <- httpLbs req mgr

210+ resp <- httpLbs req mgr

209− let good = hasValidHeader "Cache-Control" (const True) resp

211+ unless (hasValidHeader "Cache-Control" (const True) resp) $

210− return (good, [resp])

212+ throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp

213+ return [resp]

211− else return (True, [])

214+ else return []

212− }

213{-

215{-

214-- |

216-- |

215--

217--

@@ -271,12 +273,13 @@ linkHeadersAreValid

271-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>

273-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>

272--

274--

273-- /Since 0.0.0.0/

275-- /Since 0.0.0.0/

274−unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool

276+unauthorizedContainsWWWAuthenticate :: ResponsePredicate

275unauthorizedContainsWWWAuthenticate

277unauthorizedContainsWWWAuthenticate

276− = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->

278+ = ResponsePredicate $ \resp ->

277 if responseStatus resp == status401

279 if responseStatus resp == status401

278− then hasValidHeader "WWW-Authenticate" (const True) resp

280+ then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $

281+ fail "unauthorizedContainsWWWAuthenticate"

279− else True)

282+ else return ()

280

283

281-- * Predicate logic

284-- * Predicate logic

282

285

@@ -289,67 +292,46 @@ unauthorizedContainsWWWAuthenticate

289-- | A predicate that depends only on the response.

292-- | A predicate that depends only on the response.

290--

293--

291-- /Since 0.0.0.0/

294-- /Since 0.0.0.0/

292−data ResponsePredicate n r = ResponsePredicate

295+data ResponsePredicate = ResponsePredicate

293− { respPredName :: n

294− , respPred :: Response LBS.ByteString -> r

296+ { getResponsePredicate :: Response LBS.ByteString -> IO ()

295− } deriving (Functor, Generic)

297+ } deriving (Generic)

296−

298+

297−instance Bifunctor ResponsePredicate where

299+instance Monoid ResponsePredicate where

298− first f (ResponsePredicate a b) = ResponsePredicate (f a) b

300+ mempty = ResponsePredicate $ const $ return ()

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

301+ ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x

304− { respPredName = respPredName a <> respPredName b

305− , respPred = respPred a <> respPred b

306− }

307

302

308-- | A predicate that depends on both the request and the response.

303-- | A predicate that depends on both the request and the response.

309--

304--

310-- /Since 0.0.0.0/

305-- /Since 0.0.0.0/

311−data RequestPredicate n r = RequestPredicate

306+data RequestPredicate = RequestPredicate

312− { reqPredName :: n

313− , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])

307+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]

314− } deriving (Generic, Functor)

308+ } deriving (Generic)

315−

316−instance Bifunctor RequestPredicate where

317− first f (RequestPredicate a b) = RequestPredicate (f a) b

318− second = fmap

319

309

320-- TODO: This isn't actually a monoid

310-- TODO: This isn't actually a monoid

321−instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where

311+instance Monoid RequestPredicate where

322− mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))

312+ mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))

323− a `mappend` b = RequestPredicate

313+ RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->

324− { reqPredName = reqPredName a <> reqPredName b

314+ liftM2 (<>) (a r mgr) (b r mgr)

325− , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)

326− }

327

315

328-- | A set of predicates. Construct one with 'mempty' and '<%>'.

316-- | A set of predicates. Construct one with 'mempty' and '<%>'.

329−data Predicates n r = Predicates

317+data Predicates = Predicates

330− { reqPreds :: RequestPredicate n r

318+ { requestPredicates :: RequestPredicate

331− , respPreds :: ResponsePredicate n r

319+ , responsePredicates :: ResponsePredicate

332− } deriving (Generic, Functor)

320+ } deriving (Generic)

333

321

334−instance (Monoid n, Monoid r) => Monoid (Predicates n r) where

322+instance Monoid Predicates where

335 mempty = Predicates mempty mempty

323 mempty = Predicates mempty mempty

336− a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)

324+ a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)

337−

325+ (responsePredicates a <> responsePredicates b)

338−

339

326

340class JoinPreds a where

327class JoinPreds a where

341− joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]

328+ joinPreds :: a -> Predicates -> Predicates

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'

347

329

348−instance JoinPreds (ResponsePredicate Text Bool) where

330+instance JoinPreds (RequestPredicate ) where

349− joinPreds p (Predicates x y) = Predicates x (go <> y)

331+ joinPreds p (Predicates x y) = Predicates (p <> x) y

350− where go = let p' = first return p

351− in fmap (\z -> if z then [] else respPredName p') p'

352

332

333+instance JoinPreds (ResponsePredicate ) where

334+ joinPreds p (Predicates x y) = Predicates x (p <> y)

353

335

354-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to

336-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to

355-- the existing predicates.

337-- the existing predicates.

@@ -357,14 +339,17 @@ instance JoinPreds (ResponsePredicate Text Bool) where

357-- > not500 <%> onlyJsonObjects <%> empty

339-- > not500 <%> onlyJsonObjects <%> empty

358--

340--

359-- /Since 0.0.0.0/

341-- /Since 0.0.0.0/

360−(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]

342+(<%>) :: JoinPreds a => a -> Predicates -> Predicates

361(<%>) = joinPreds

343(<%>) = joinPreds

362infixr 6 <%>

344infixr 6 <%>

363

345

364−finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]

346+finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)

365−finishPredicates p req mgr = do

347+finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e

366− (soFar, resps) <- reqResps (reqPreds p) req mgr

348+ where

367− return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]

349+ go = do

350+ resps <- getRequestPredicate (requestPredicates p) req mgr

351+ mapM_ (getResponsePredicate $ responsePredicates p) resps

352+ return Nothing

368

353

369-- * helpers

354-- * helpers

370

355

@@ -373,5 +358,8 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of

373 Nothing -> False

358 Nothing -> False

374 Just v -> p v

359 Just v -> p v

375

360

376−status2XX :: Response b -> Bool

361+status2XX :: Monad m => Response b -> String -> m ()

362+status2XX r t

377−status2XX r = status200 <= responseStatus r && responseStatus r < status300

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 #-}

1module Servant.QuickCheck.Internal.QuickCheck where

2module Servant.QuickCheck.Internal.QuickCheck where

3import qualified Data.ByteString.Lazy as LBS

4import qualified Data.ByteString.Lazy as LBS

@@ -18,6 +19,7 @@ import Test.QuickCheck (Args (..), Result (..),

18import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run, monitor)

19import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run, monitor)

19import Test.QuickCheck.Property (counterexample)

20import Test.QuickCheck.Property (counterexample)

20import Control.Monad (unless)

21import Control.Monad (unless)

22+import Control.Concurrent (newMVar, modifyMVar_, readMVar)

22import Servant.QuickCheck.Internal.Equality

24import Servant.QuickCheck.Internal.Equality

23import Servant.QuickCheck.Internal.HasGenRequest

25import Servant.QuickCheck.Internal.HasGenRequest

@@ -60,17 +62,22 @@ serversEqual :: HasGenRequest a =>

60 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation

62 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation

61serversEqual api burl1 burl2 args req = do

63serversEqual api burl1 burl2 args req = do

62 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api

64 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api

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"

63− r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do

68+ r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do

64 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager

69 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager

65 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager

70 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager

66 unless (getResponseEquality req resp1 resp2) $ do

71 unless (getResponseEquality req resp1 resp2) $ do

67 monitor (counterexample "hi" )

72 monitor (counterexample "hi" )

73+ run $ modifyMVar_ deetsMVar $ const $ return $

74+ ServerEqualityFailure req1 resp1 resp2

68 assert False

75 assert False

69−

70 case r of

76 case r of

71 Success {} -> return ()

77 Success {} -> return ()

78+ f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $

79+ "Failed:\n" ++ show x

72 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

80 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

73− Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m

74 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

81 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

75 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

82 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

@@ -94,22 +101,27 @@ serversEqual api burl1 burl2 args req = do

94--

101--

95-- /Since 0.0.0.0/

102-- /Since 0.0.0.0/

96serverSatisfies :: (HasGenRequest a) =>

103serverSatisfies :: (HasGenRequest a) =>

97− Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation

104+ Proxy a -> BaseUrl -> Args -> Predicates -> Expectation

98serverSatisfies api burl args preds = do

105serverSatisfies api burl args preds = do

99 let reqs = ($ burl) <$> genRequest api

106 let reqs = ($ burl) <$> genRequest api

107+ deetsMVar <- newMVar $ error "should not be called"

100− r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do

108+ r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do

101 v <- run $ finishPredicates preds (noCheckStatus req) defManager

109 v <- run $ finishPredicates preds (noCheckStatus req) defManager

110+ run $ modifyMVar_ deetsMVar $ const $ return v

111+ case v of

102− assert $ null v

112+ Just x -> assert False

113+ _ -> return ()

103 case r of

114 case r of

104 Success {} -> return ()

115 Success {} -> return ()

116+ f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $

117+ "Failed:\n" ++ show x

105 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

118 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"

119 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

108 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

120 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

109

121

110

122

111serverDoesntSatisfy :: (HasGenRequest a) =>

123serverDoesntSatisfy :: (HasGenRequest a) =>

112− Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation

124+ Proxy a -> BaseUrl -> Args -> Predicates -> Expectation

113serverDoesntSatisfy api burl args preds = do

125serverDoesntSatisfy api burl args preds = do

114 let reqs = ($ burl) <$> genRequest api

126 let reqs = ($ burl) <$> genRequest api

115 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do

127 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do

test/Servant/QuickCheck/InternalSpec.hs+38−37

@@ -1,28 +1,27 @@

1{-# LANGUAGE CPP #-}

2module Servant.QuickCheck.InternalSpec (spec) where

4−import Control.Concurrent.MVar (newMVar, readMVar,

4+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)

5− swapMVar)

6−import Control.Monad.IO.Class (liftIO)

5+import Control.Monad.IO.Class (liftIO)

7−import Prelude.Compat

6+import Prelude.Compat

8−import Servant

7+import Servant

9−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)

8+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)

10−import Test.Hspec (Spec, context,

9+import Test.Hspec (Spec, context, describe, it,

11− describe, it,

12− pending, shouldBe)

10+ pending, shouldBe,

11+ shouldContain)

13−import Test.Hspec.Core.Spec (Arg, Example,

12+import Test.Hspec.Core.Spec (Arg, Example, Result (..),

14− Result (..),

15− defaultParams,

13+ defaultParams,

16− evaluateExample)

14+ evaluateExample)

17−

15+

18−import Servant.QuickCheck

16+import Servant.QuickCheck

19−import Servant.QuickCheck.Internal (genRequest, Failure(..), serverDoesntSatisfy)

17+import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)

21spec :: Spec

19spec :: Spec

22spec = do

20spec = do

23 serversEqualSpec

21 serversEqualSpec

24 serverSatisfiesSpec

22 serverSatisfiesSpec

25 isComprehensiveSpec

23 isComprehensiveSpec

24+ onlyJsonObjectSpec

27serversEqualSpec :: Spec

26serversEqualSpec :: Spec

28serversEqualSpec = describe "serversEqual" $ do

27serversEqualSpec = describe "serversEqual" $ do

@@ -34,28 +33,14 @@ serversEqualSpec = describe "serversEqual" $ do

35 context "when servers are not equal" $ do

34 context "when servers are not equal" $ do

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

43− it "provides the failing requests in the error message" $ do

37+ it "provides the failing responses in the error message" $ do

44 Fail _ err <- withServantServer api2 server2 $ \burl1 ->

38 Fail _ err <- withServantServer api2 server2 $ \burl1 ->

45 withServantServer api2 server3 $ \burl2 -> do

39 withServantServer api2 server3 $ \burl2 -> do

46 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality

40 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality

47− print err

41+ show err `shouldContain` "Body: 1"

48− let ServerEqualityFailure req _ _ = read err

42+ show err `shouldContain` "Body: 2"

49− req `shouldBe` "failplz"

43+ show err `shouldContain` "Path: 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−

60serverSatisfiesSpec :: Spec

45serverSatisfiesSpec :: Spec

61serverSatisfiesSpec = describe "serverSatisfies" $ do

46serverSatisfiesSpec = describe "serverSatisfies" $ do

@@ -74,8 +59,24 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do

74 <%> notAllowedContainsAllowHeader

59 <%> notAllowedContainsAllowHeader

75 <%> mempty)

60 <%> mempty)

77− context "when predicates are false" $

62+ context "when predicates are false" $ do

63+

78− it "fails with informative error messages" $ pending

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+

80isComprehensiveSpec :: Spec

81isComprehensiveSpec :: Spec

81isComprehensiveSpec = describe "HasGenRequest" $ do

82isComprehensiveSpec = describe "HasGenRequest" $ do

@@ -133,5 +134,5 @@ noOfTestCases :: Int

133#if LONG_TESTS

134#if LONG_TESTS

134noOfTestCases = 20000

135noOfTestCases = 20000

135#else

136#else

136−noOfTestCases = 500

137+noOfTestCases = 1000

137#endif

138#endif