@@ -1,21 +1,24 @@
11{-# LANGUAGE CPP #-}
22module Servant.QuickCheck.InternalSpec (spec) where
33
4−import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
5−import Control.Monad (replicateM)
6−import Control.Monad.IO.Class (liftIO)
7−import qualified Data.ByteString as BS
8−import qualified Data.ByteString.Char8 as C
9−import Data.Maybe (fromJust)
4+
5+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
6+import Control.Exception (SomeException)
7+import Control.Monad (replicateM)
8+import Control.Monad.IO.Class (liftIO)
9+import qualified Data.ByteString as BS
10+import qualified Data.ByteString.Char8 as C
11+import Data.Maybe (fromJust)
12+import Network.HTTP.Client (path, queryString)
1013import Prelude.Compat
1114import Servant
12−import Test.Hspec (Spec, context, describe, it, shouldBe,
13− shouldContain)
14−import Test.Hspec.Core.Spec (Arg, Example, Result (..),
15− defaultParams, evaluateExample)
16−import Test.QuickCheck.Gen (unGen, generate)
17−import Test.QuickCheck.Random (mkQCGen)
18−import Network.HTTP.Client (queryString, path)
15+import Test.Hspec (Spec, context, describe, it, shouldBe,
16+ shouldContain)
17+import Test.Hspec.Core.Spec (Arg, Example, Result (..),
18+ defaultParams)
19+import Test.QuickCheck.Gen (generate, unGen)
20+import Test.QuickCheck.Random (mkQCGen)
21+
1922
2023#if MIN_VERSION_servant(0,8,0)
2124import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
@@ -24,8 +27,16 @@ import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
2427 comprehensiveAPI)
2528#endif
2629
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+
2737import Servant.QuickCheck
28−import Servant.QuickCheck.Internal (genRequest, runGenRequest, serverDoesntSatisfy)
38+import Servant.QuickCheck.Internal (genRequest, runGenRequest,
39+ serverDoesntSatisfy)
2940
3041
3142spec :: Spec
@@ -50,9 +61,10 @@ serversEqualSpec = describe "serversEqual" $ do
5061
5162 context "when servers are not equal" $ do
5263 it "provides the failing responses in the error message" $ do
53− Fail _ err <- withServantServer api2 server2 $ \burl1 ->
64+ FailedWith err <- withServantServer api2 server2 $ \burl1 ->
5465 withServantServer api2 server3 $ \burl2 -> do
5566 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
67+ show err `shouldContain` "Server equality failed"
5668 show err `shouldContain` "Body: 1"
5769 show err `shouldContain` "Body: 2"
5870 show err `shouldContain` "Path: /failplz"
@@ -77,21 +89,21 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
7789 context "when predicates are false" $ do
7890
7991 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
8193 evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
82− err `shouldContain` "notAllowedContainsAllowHeader"
83− err `shouldContain` "Headers"
84− err `shouldContain` "Body"
94+ show err `shouldContain` "notAllowedContainsAllowHeader"
95+ show err `shouldContain` "Headers"
96+ show err `shouldContain` "Body"
8597
8698
8799onlyJsonObjectSpec :: Spec
88100onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
89101
90102 it "fails correctly" $ do
91− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
103+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
92104 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
93105 (onlyJsonObjects <%> mempty)
94− err `shouldContain` "onlyJsonObjects"
106+ show err `shouldContain` "onlyJsonObjects"
95107
96108 it "accepts non-JSON endpoints" $ do
97109 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
@@ -101,10 +113,10 @@ notLongerThanSpec :: Spec
101113notLongerThanSpec = describe "notLongerThan" $ do
102114
103115 it "fails correctly" $ do
104− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
116+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
105117 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
106118 (notLongerThan 1 <%> mempty)
107− err `shouldContain` "notLongerThan"
119+ show err `shouldContain` "notLongerThan"
108120
109121 it "succeeds correctly" $ do
110122 withServantServerAndContext api ctx server $ \burl ->
@@ -166,8 +178,8 @@ unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
166178 let mean = (sum $ map fromIntegral someRequests) / runs
167179 let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
168180 let variance = (sum $ map variancer someRequests) / runs - 1
169− -- mean should be around 8
170− mean > 7 `shouldBe` True
181+ -- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
182+ mean > 8 `shouldBe` True
171183 mean < 9 `shouldBe` True
172184 -- Std dev is likely around 4. Variance is probably greater than 20.
173185 variance > 19.5 `shouldBe` True
@@ -255,11 +267,35 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
255267------------------------------------------------------------------------------
256268-- Utils
257269------------------------------------------------------------------------------
258−
259−evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
260−evalExample e = evaluateExample e defaultParams ($ ()) progCallback
270+evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
271+#if MIN_VERSION_hspec(2,4,0)
272+evalExample e = do
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"
261279 where
262280 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+
263299
264300args :: Args
265301args = defaultArgs { maxSuccess = noOfTestCases }