git.iko.soy/servant-quickcheck
on master help sign in
Merge pull request #29 from haskell-servant/issue-27/supportHspec2.4
e7206ecJulian Arni
servant-quickcheck.cabal+2−2
compare with master
unifiedsplit
@@ -38,14 +38,14 @@ library
38 , case-insensitive == 1.2.*
38 , case-insensitive == 1.2.*
39 , clock >= 0.7 && < 0.8
39 , clock >= 0.7 && < 0.8
40 , data-default-class >= 0.0 && < 0.2
40 , data-default-class >= 0.0 && < 0.2
41− , hspec >= 2.2 && < 2.4
41+ , hspec >= 2.2 && < 2.5
42 , http-client >= 0.4.30 && < 0.6
42 , http-client >= 0.4.30 && < 0.6
43 , http-media == 0.6.*
43 , http-media == 0.6.*
44 , http-types > 0.8 && < 0.10
44 , http-types > 0.8 && < 0.10
45 , mtl > 2.1 && < 2.3
45 , mtl > 2.1 && < 2.3
46 , pretty == 1.1.*
46 , pretty == 1.1.*
47 , process >= 1.2 && < 1.5
47 , process >= 1.2 && < 1.5
48− , QuickCheck > 2.7 && < 2.10
48+ , QuickCheck > 2.7 && < 2.11
49 , servant > 0.6 && < 0.10
49 , servant > 0.6 && < 0.10
50 , servant-client > 0.6 && < 0.10
50 , servant-client > 0.6 && < 0.10
51 , servant-server > 0.6 && < 0.10
51 , servant-server > 0.6 && < 0.10
src/Servant/QuickCheck/Internal/QuickCheck.hs+4−6
@@ -14,8 +14,7 @@ import Servant (Context (EmptyContext), HasServer,
14import Servant.Client (BaseUrl (..), Scheme (..))
14import Servant.Client (BaseUrl (..), Scheme (..))
15import System.IO.Unsafe (unsafePerformIO)
15import System.IO.Unsafe (unsafePerformIO)
16import Test.Hspec (Expectation, expectationFailure)
16import Test.Hspec (Expectation, expectationFailure)
17−import Test.QuickCheck (Args (..), Result (..),
17+import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult)
18− quickCheckWithResult)
19import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
18import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
20 run)
19 run)
21import Test.QuickCheck.Property (counterexample)
20import Test.QuickCheck.Property (counterexample)
@@ -85,11 +84,10 @@ serversEqual api burl1 burl2 args req = do
85 assert False
84 assert False
86 case r of
85 case r of
87 Success {} -> return ()
86 Success {} -> return ()
88− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
87+ Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x
89− "Failed:\n" ++ show x
90 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
88 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
91− NoExpectedFailure {} -> expectationFailure $ "No expected failure"
89+ NoExpectedFailure {} -> expectationFailure "No expected failure"
92− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
90+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
93
91
94-- | Check that a server satisfies the set of properties specified.
92-- | Check that a server satisfies the set of properties specified.
95--
93--
stack.yaml+4−3
@@ -2,8 +2,9 @@ resolver: lts-8.4
2packages:
2packages:
3- '.'
3- '.'
4extra-deps:
4extra-deps:
5−- hspec-2.3.2
5+- hspec-2.4.4
6−- hspec-core-2.3.2
6+- hspec-core-2.4.4
7−- hspec-discover-2.3.2
7+- hspec-discover-2.4.4
8+- quickcheck-io-0.2.0
8flags: {}
9flags: {}
9extra-package-dbs: []
10extra-package-dbs: []
test/Servant/QuickCheck/InternalSpec.hs+64−28
@@ -1,21 +1,24 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2module Servant.QuickCheck.InternalSpec (spec) where
2module Servant.QuickCheck.InternalSpec (spec) where
3
3
4+
4−import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
5+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
6+import Control.Exception (SomeException)
5−import Control.Monad (replicateM)
7+import Control.Monad (replicateM)
6−import Control.Monad.IO.Class (liftIO)
8+import Control.Monad.IO.Class (liftIO)
7−import qualified Data.ByteString as BS
9+import qualified Data.ByteString as BS
8−import qualified Data.ByteString.Char8 as C
10+import qualified Data.ByteString.Char8 as C
9−import Data.Maybe (fromJust)
11+import Data.Maybe (fromJust)
12+import Network.HTTP.Client (path, queryString)
10import Prelude.Compat
13import Prelude.Compat
11import Servant
14import Servant
12−import Test.Hspec (Spec, context, describe, it, shouldBe,
15+import Test.Hspec (Spec, context, describe, it, shouldBe,
13− shouldContain)
16+ shouldContain)
14−import Test.Hspec.Core.Spec (Arg, Example, Result (..),
17+import Test.Hspec.Core.Spec (Arg, Example, Result (..),
15− defaultParams, evaluateExample)
18+ defaultParams)
16−import Test.QuickCheck.Gen (unGen, generate)
19+import Test.QuickCheck.Gen (generate, unGen)
17−import Test.QuickCheck.Random (mkQCGen)
20+import Test.QuickCheck.Random (mkQCGen)
18−import Network.HTTP.Client (queryString, path)
21+
19
22
20#if MIN_VERSION_servant(0,8,0)
23#if MIN_VERSION_servant(0,8,0)
21import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
24import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
@@ -24,8 +27,16 @@ import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
24 comprehensiveAPI)
27 comprehensiveAPI)
25#endif
28#endif
26
29
30+#if MIN_VERSION_hspec(2,4,0)
31+import Test.Hspec.Core.Spec (safeEvaluateExample)
32+#else
33+import Control.Exception (try)
34+import Test.Hspec.Core.Spec (evaluateExample)
35+#endif
36+
27import Servant.QuickCheck
37import Servant.QuickCheck
28−import Servant.QuickCheck.Internal (genRequest, runGenRequest, serverDoesntSatisfy)
38+import Servant.QuickCheck.Internal (genRequest, runGenRequest,
39+ serverDoesntSatisfy)
29
40
30
41
31spec :: Spec
42spec :: Spec
@@ -50,9 +61,10 @@ serversEqualSpec = describe "serversEqual" $ do
50
61
51 context "when servers are not equal" $ do
62 context "when servers are not equal" $ do
52 it "provides the failing responses in the error message" $ do
63 it "provides the failing responses in the error message" $ do
53− Fail _ err <- withServantServer api2 server2 $ \burl1 ->
64+ FailedWith err <- withServantServer api2 server2 $ \burl1 ->
54 withServantServer api2 server3 $ \burl2 -> do
65 withServantServer api2 server3 $ \burl2 -> do
55 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
66 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
67+ show err `shouldContain` "Server equality failed"
56 show err `shouldContain` "Body: 1"
68 show err `shouldContain` "Body: 1"
57 show err `shouldContain` "Body: 2"
69 show err `shouldContain` "Body: 2"
58 show err `shouldContain` "Path: /failplz"
70 show err `shouldContain` "Path: /failplz"
@@ -77,21 +89,21 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
77 context "when predicates are false" $ do
89 context "when predicates are false" $ do
78
90
79 it "fails with informative error messages" $ do
91 it "fails with informative error messages" $ do
80− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
92+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
81 evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
93 evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
82− err `shouldContain` "notAllowedContainsAllowHeader"
94+ show err `shouldContain` "notAllowedContainsAllowHeader"
83− err `shouldContain` "Headers"
95+ show err `shouldContain` "Headers"
84− err `shouldContain` "Body"
96+ show err `shouldContain` "Body"
85
97
86
98
87onlyJsonObjectSpec :: Spec
99onlyJsonObjectSpec :: Spec
88onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
100onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
89
101
90 it "fails correctly" $ do
102 it "fails correctly" $ do
91− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
103+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
92 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
104 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
93 (onlyJsonObjects <%> mempty)
105 (onlyJsonObjects <%> mempty)
94− err `shouldContain` "onlyJsonObjects"
106+ show err `shouldContain` "onlyJsonObjects"
95
107
96 it "accepts non-JSON endpoints" $ do
108 it "accepts non-JSON endpoints" $ do
97 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
109 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
@@ -101,10 +113,10 @@ notLongerThanSpec :: Spec
101notLongerThanSpec = describe "notLongerThan" $ do
113notLongerThanSpec = describe "notLongerThan" $ do
102
114
103 it "fails correctly" $ do
115 it "fails correctly" $ do
104− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
116+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
105 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
117 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
106 (notLongerThan 1 <%> mempty)
118 (notLongerThan 1 <%> mempty)
107− err `shouldContain` "notLongerThan"
119+ show err `shouldContain` "notLongerThan"
108
120
109 it "succeeds correctly" $ do
121 it "succeeds correctly" $ do
110 withServantServerAndContext api ctx server $ \burl ->
122 withServantServerAndContext api ctx server $ \burl ->
@@ -166,8 +178,8 @@ unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
166 let mean = (sum $ map fromIntegral someRequests) / runs
178 let mean = (sum $ map fromIntegral someRequests) / runs
167 let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
179 let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
168 let variance = (sum $ map variancer someRequests) / runs - 1
180 let variance = (sum $ map variancer someRequests) / runs - 1
169− -- mean should be around 8
181+ -- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
170− mean > 7 `shouldBe` True
182+ mean > 8 `shouldBe` True
171 mean < 9 `shouldBe` True
183 mean < 9 `shouldBe` True
172 -- Std dev is likely around 4. Variance is probably greater than 20.
184 -- Std dev is likely around 4. Variance is probably greater than 20.
173 variance > 19.5 `shouldBe` True
185 variance > 19.5 `shouldBe` True
@@ -255,11 +267,35 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
255------------------------------------------------------------------------------
267------------------------------------------------------------------------------
256-- Utils
268-- Utils
257------------------------------------------------------------------------------
269------------------------------------------------------------------------------
258−
259−evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
270+evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
271+#if MIN_VERSION_hspec(2,4,0)
272+evalExample e = do
260−evalExample e = evaluateExample e defaultParams ($ ()) progCallback
273+ r <- safeEvaluateExample e defaultParams ($ ()) progCallback
274+ case r of
275+ Left err -> return $ AnException err
276+ Right Success -> return $ AllGood
277+ Right (Failure _ reason) -> return $ FailedWith $ show reason
278+ Right (Pending _) -> error "should not happen"
261 where
279 where
262 progCallback _ = return ()
280 progCallback _ = return ()
281+#else
282+evalExample e = do
283+ r <- try $ evaluateExample e defaultParams ($ ()) progCallback
284+ case r of
285+ Left err -> return $ AnException err
286+ Right Success -> return $ AllGood
287+ Right (Fail _ reason) -> return $ FailedWith reason
288+ Right (Pending _) -> error "should not happen"
289+ where
290+ progCallback _ = return ()
291+#endif
292+
293+data EvalResult
294+ = AnException SomeException
295+ | AllGood
296+ | FailedWith String
297+ deriving (Show)
298+
263
299
264args :: Args
300args :: Args
265args = defaultArgs { maxSuccess = noOfTestCases }
301args = defaultArgs { maxSuccess = noOfTestCases }