From f052dc149b0fcec9eff17ff88bb1b68c9c0e147c Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Sat, 15 Jul 2017 15:03:06 -0700 Subject: [PATCH 1/3] Bump HSpec to 2.4.4 and make tests use safeEvaluateExample to capture failure msg --- servant-quickcheck.cabal | 5 ++- src/Servant/QuickCheck/Internal/QuickCheck.hs | 10 ++--- stack.yaml | 7 ++-- test/Servant/QuickCheck/InternalSpec.hs | 39 +++++++++++-------- 4 files changed, 34 insertions(+), 27 deletions(-) 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 } From 0e23a2eba7b2f3f14b58f2c11707c4ea1b6d2456 Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Sat, 15 Jul 2017 15:11:18 -0700 Subject: [PATCH 2/3] Code cleanup: remove unused imports and code --- servant-quickcheck.cabal | 1 - test/Servant/QuickCheck/InternalSpec.hs | 10 ++-------- 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 922dc23..82d0496 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -39,7 +39,6 @@ library , clock >= 0.7 && < 0.8 , data-default-class >= 0.0 && < 0.2 , 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 diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 83a19fb..0906bfc 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -10,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 (..), FailureReason (..), - defaultParams, evaluateExample, safeEvaluateExample) +import Test.Hspec.Core.Spec (Arg, Example, Result (..), + defaultParams, safeEvaluateExample) import Test.QuickCheck.Gen (unGen) import Test.QuickCheck.Random (mkQCGen) import Network.HTTP.Client (queryString, path) @@ -208,12 +208,6 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext ------------------------------------------------------------------------------ -- Utils ------------------------------------------------------------------------------ - -evalExample :: (Example e, Arg e ~ ()) => e -> IO Result -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 From a0ec1777a7405165211a80b6f88f7ec0edf5e0b9 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 15 Oct 2017 17:00:04 -0700 Subject: [PATCH 3/3] Compatibility with earlier versions of hspec. Adds CPP to the tests to allow for upstream changes to the 'Result' type. --- servant-quickcheck.cabal | 4 +- test/Servant/QuickCheck/InternalSpec.hs | 82 +++++++++++++++++-------- 2 files changed, 59 insertions(+), 27 deletions(-) diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 82d0496..d6e4659 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -38,14 +38,14 @@ library , case-insensitive == 1.2.* , clock >= 0.7 && < 0.8 , data-default-class >= 0.0 && < 0.2 - , hspec >= 2.4.4 && < 2.5 + , hspec >= 2.2 && < 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.9 && < 2.11 + , QuickCheck > 2.7 && < 2.11 , servant > 0.6 && < 0.10 , servant-client > 0.6 && < 0.10 , servant-server > 0.6 && < 0.10 diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index e871a65..fa98eea 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -2,22 +2,22 @@ module Servant.QuickCheck.InternalSpec (spec) where -import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) -import Control.Exception (SomeException) -import Control.Monad (replicateM) -import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C -import Data.Maybe (fromJust) +import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) +import Control.Exception (SomeException) +import Control.Monad (replicateM) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import Data.Maybe (fromJust) +import Network.HTTP.Client (path, queryString) import Prelude.Compat import Servant -import Test.Hspec (Spec, context, describe, it, shouldBe, - shouldContain) -import Test.Hspec.Core.Spec (Arg, Example, Result (..), - defaultParams, safeEvaluateExample) -import Test.QuickCheck.Gen (unGen, generate) -import Test.QuickCheck.Random (mkQCGen) -import Network.HTTP.Client (queryString, path) +import Test.Hspec (Spec, context, describe, it, shouldBe, + shouldContain) +import Test.Hspec.Core.Spec (Arg, Example, Result (..), + defaultParams) +import Test.QuickCheck.Gen (generate, unGen) +import Test.QuickCheck.Random (mkQCGen) #if MIN_VERSION_servant(0,8,0) @@ -27,8 +27,16 @@ import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI, comprehensiveAPI) #endif +#if MIN_VERSION_hspec(2,4,0) +import Test.Hspec.Core.Spec (safeEvaluateExample) +#else +import Control.Exception (try) +import Test.Hspec.Core.Spec (evaluateExample) +#endif + import Servant.QuickCheck -import Servant.QuickCheck.Internal (genRequest, runGenRequest, serverDoesntSatisfy) +import Servant.QuickCheck.Internal (genRequest, runGenRequest, + serverDoesntSatisfy) spec :: Spec @@ -53,9 +61,9 @@ serversEqualSpec = describe "serversEqual" $ do context "when servers are not equal" $ do it "provides the failing responses in the error message" $ do - Right (Failure _ err) <- withServantServer api2 server2 $ \burl1 -> + FailedWith err <- withServantServer api2 server2 $ \burl1 -> withServantServer api2 server3 $ \burl2 -> do - safeEvalExample $ serversEqual api2 burl1 burl2 args bodyEquality + evalExample $ serversEqual api2 burl1 burl2 args bodyEquality show err `shouldContain` "Server equality failed" show err `shouldContain` "Body: 1" show err `shouldContain` "Body: 2" @@ -81,8 +89,8 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do context "when predicates are false" $ do it "fails with informative error messages" $ do - Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do - safeEvalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty) + FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do + evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty) show err `shouldContain` "notAllowedContainsAllowHeader" show err `shouldContain` "Headers" show err `shouldContain` "Body" @@ -92,8 +100,8 @@ onlyJsonObjectSpec :: Spec onlyJsonObjectSpec = describe "onlyJsonObjects" $ do it "fails correctly" $ do - Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do - safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args + FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do + evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args (onlyJsonObjects <%> mempty) show err `shouldContain` "onlyJsonObjects" @@ -105,8 +113,8 @@ notLongerThanSpec :: Spec notLongerThanSpec = describe "notLongerThan" $ do it "fails correctly" $ do - Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do - safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args + FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do + evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args (notLongerThan 1 <%> mempty) show err `shouldContain` "notLongerThan" @@ -259,10 +267,34 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext ------------------------------------------------------------------------------ -- Utils ------------------------------------------------------------------------------ -safeEvalExample :: (Example e, Arg e ~ ()) => e -> IO (Either SomeException Result) -safeEvalExample e = safeEvaluateExample e defaultParams ($ ()) progCallback +evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult +#if MIN_VERSION_hspec(2,4,0) +evalExample e = do + r <- safeEvaluateExample e defaultParams ($ ()) progCallback + case r of + Left err -> return $ AnException err + Right Success -> return $ AllGood + Right (Failure _ reason) -> return $ FailedWith $ show reason + Right (Pending _) -> error "should not happen" where progCallback _ = return () +#else +evalExample e = do + r <- try $ evaluateExample e defaultParams ($ ()) progCallback + case r of + Left err -> return $ AnException err + Right Success -> return $ AllGood + Right (Fail _ reason) -> return $ FailedWith reason + Right (Pending _) -> error "should not happen" + where + progCallback _ = return () +#endif + +data EvalResult + = AnException SomeException + | AllGood + | FailedWith String + deriving (Show) args :: Args