diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 8ff3862..922dc23 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -38,14 +38,15 @@ library , case-insensitive == 1.2.* , clock >= 0.7 && < 0.8 , data-default-class >= 0.0 && < 0.2 - , hspec >= 2.2 && < 2.4 + , hspec >= 2.4.4 && < 2.5 + , hspec-core >= 2.4.4 && < 2.5 , http-client >= 0.4.30 && < 0.6 , http-media == 0.6.* , http-types > 0.8 && < 0.10 , mtl > 2.1 && < 2.3 , pretty == 1.1.* , process >= 1.2 && < 1.5 - , QuickCheck > 2.7 && < 2.10 + , QuickCheck > 2.9 && < 2.11 , servant > 0.6 && < 0.10 , servant-client > 0.6 && < 0.10 , servant-server > 0.6 && < 0.10 diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index fe30188..9f9344e 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -14,8 +14,7 @@ import Servant (Context (EmptyContext), HasServer, import Servant.Client (BaseUrl (..), Scheme (..)) import System.IO.Unsafe (unsafePerformIO) import Test.Hspec (Expectation, expectationFailure) -import Test.QuickCheck (Args (..), Result (..), - quickCheckWithResult) +import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult) import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor, run) import Test.QuickCheck.Property (counterexample) @@ -85,11 +84,10 @@ serversEqual api burl1 burl2 args req = do assert False case r of Success {} -> return () - Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ - "Failed:\n" ++ show x + Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests" - NoExpectedFailure {} -> expectationFailure $ "No expected failure" - InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" + NoExpectedFailure {} -> expectationFailure "No expected failure" + InsufficientCoverage {} -> expectationFailure "Insufficient coverage" -- | Check that a server satisfies the set of properties specified. -- diff --git a/stack.yaml b/stack.yaml index 3a28603..5dd9243 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,8 +2,9 @@ resolver: lts-8.4 packages: - '.' extra-deps: -- hspec-2.3.2 -- hspec-core-2.3.2 -- hspec-discover-2.3.2 +- hspec-2.4.4 +- hspec-core-2.4.4 +- hspec-discover-2.4.4 +- quickcheck-io-0.2.0 flags: {} extra-package-dbs: [] diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 3cf9716..83a19fb 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -2,6 +2,7 @@ module Servant.QuickCheck.InternalSpec (spec) where import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) +import Control.Exception import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C @@ -9,8 +10,8 @@ import Prelude.Compat import Servant import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) -import Test.Hspec.Core.Spec (Arg, Example, Result (..), - defaultParams, evaluateExample) +import Test.Hspec.Core.Spec (Arg, Example, Result (..), FailureReason (..), + defaultParams, evaluateExample, safeEvaluateExample) import Test.QuickCheck.Gen (unGen) import Test.QuickCheck.Random (mkQCGen) import Network.HTTP.Client (queryString, path) @@ -46,11 +47,11 @@ serversEqualSpec = describe "serversEqual" $ do context "when servers are not equal" $ do - it "provides the failing responses in the error message" $ do - Fail _ err <- withServantServer api2 server2 $ \burl1 -> + Right (Failure _ err) <- withServantServer api2 server2 $ \burl1 -> withServantServer api2 server3 $ \burl2 -> do - evalExample $ serversEqual api2 burl1 burl2 args bodyEquality + safeEvalExample $ serversEqual api2 burl1 burl2 args bodyEquality + show err `shouldContain` "Server equality failed" show err `shouldContain` "Body: 1" show err `shouldContain` "Body: 2" show err `shouldContain` "Path: /failplz" @@ -75,20 +76,20 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do context "when predicates are false" $ do it "fails with informative error messages" $ do - Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do - evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty) - err `shouldContain` "getsHaveCacheControlHeader" - err `shouldContain` "Headers" - err `shouldContain` "Body" + Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do + safeEvalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty) + show err `shouldContain` "getsHaveCacheControlHeader" + show err `shouldContain` "Headers" + show err `shouldContain` "Body" onlyJsonObjectSpec :: Spec onlyJsonObjectSpec = describe "onlyJsonObjects" $ do it "fails correctly" $ do - Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do - evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args + Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do + safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args (onlyJsonObjects <%> mempty) - err `shouldContain` "onlyJsonObjects" + show err `shouldContain` "onlyJsonObjects" it "accepts non-JSON endpoints" $ do withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl -> @@ -98,10 +99,10 @@ notLongerThanSpec :: Spec notLongerThanSpec = describe "notLongerThan" $ do it "fails correctly" $ do - Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do - evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args + Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do + safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args (notLongerThan 1 <%> mempty) - err `shouldContain` "notLongerThan" + show err `shouldContain` "notLongerThan" it "succeeds correctly" $ do withServantServerAndContext api ctx server $ \burl -> @@ -213,6 +214,12 @@ evalExample e = evaluateExample e defaultParams ($ ()) progCallback where progCallback _ = return () +safeEvalExample :: (Example e, Arg e ~ ()) => e -> IO (Either SomeException Result) +safeEvalExample e = safeEvaluateExample e defaultParams ($ ()) progCallback + where + progCallback _ = return () + + args :: Args args = defaultArgs { maxSuccess = noOfTestCases }