haskell/servant-quickcheck
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Bump HSpec to 2.4.4 and make tests use safeEvaluateExample to capture failure msg

Browse Source
This commit is contained in:
Erik Aker 2017-07-15 15:03:06 -07:00
parent e1a9db4924
commit f052dc149b
4 changed files with 34 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
servant-quickcheck.cabal
View File

@ -38,14 +38,15 @@ library
, case-insensitive == 1.2.* , case-insensitive == 1.2.*
, clock >= 0.7 && < 0.8 , clock >= 0.7 && < 0.8
, data-default-class >= 0.0 && < 0.2 , 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-client >= 0.4.30 && < 0.6
, http-media == 0.6.* , http-media == 0.6.*
, http-types > 0.8 && < 0.10 , http-types > 0.8 && < 0.10
, mtl > 2.1 && < 2.3 , mtl > 2.1 && < 2.3
, pretty == 1.1.* , pretty == 1.1.*
, process >= 1.2 && < 1.5 , process >= 1.2 && < 1.5
, QuickCheck > 2.7 && < 2.10 , QuickCheck > 2.9 && < 2.11
, servant > 0.6 && < 0.10 , servant > 0.6 && < 0.10
, servant-client > 0.6 && < 0.10 , servant-client > 0.6 && < 0.10
, servant-server > 0.6 && < 0.10 , servant-server > 0.6 && < 0.10

10
src/Servant/QuickCheck/Internal/QuickCheck.hs
View File

@ -14,8 +14,7 @@ import Servant (Context (EmptyContext), HasServer,
import Servant.Client (BaseUrl (..), Scheme (..)) import Servant.Client (BaseUrl (..), Scheme (..))
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec (Expectation, expectationFailure) import Test.Hspec (Expectation, expectationFailure)
import Test.QuickCheck (Args (..), Result (..), import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult)
quickCheckWithResult)
import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor, import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
run) run)
import Test.QuickCheck.Property (counterexample) import Test.QuickCheck.Property (counterexample)
@ -85,11 +84,10 @@ serversEqual api burl1 burl2 args req = do
assert False assert False
case r of case r of
Success {} -> return () Success {} -> return ()
Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x
"Failed:\n" ++ show x
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests" GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
NoExpectedFailure {} -> expectationFailure $ "No expected failure" NoExpectedFailure {} -> expectationFailure "No expected failure"
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
-- | Check that a server satisfies the set of properties specified. -- | Check that a server satisfies the set of properties specified.
-- --

7
stack.yaml
View File

@ -2,8 +2,9 @@ resolver: lts-8.4
packages: packages:
- '.' - '.'
extra-deps: extra-deps:
- hspec-2.3.2 - hspec-2.4.4
- hspec-core-2.3.2 - hspec-core-2.4.4
- hspec-discover-2.3.2 - hspec-discover-2.4.4
- quickcheck-io-0.2.0
flags: {} flags: {}
extra-package-dbs: [] extra-package-dbs: []

39
test/Servant/QuickCheck/InternalSpec.hs
View File

@ -2,6 +2,7 @@
module Servant.QuickCheck.InternalSpec (spec) where module Servant.QuickCheck.InternalSpec (spec) where
import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
import Control.Exception
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Char8 as C
@ -9,8 +10,8 @@ import Prelude.Compat
import Servant import Servant
import Test.Hspec (Spec, context, describe, it, shouldBe, import Test.Hspec (Spec, context, describe, it, shouldBe,
shouldContain) shouldContain)
import Test.Hspec.Core.Spec (Arg, Example, Result (..), import Test.Hspec.Core.Spec (Arg, Example, Result (..), FailureReason (..),
defaultParams, evaluateExample) defaultParams, evaluateExample, safeEvaluateExample)
import Test.QuickCheck.Gen (unGen) import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Random (mkQCGen) import Test.QuickCheck.Random (mkQCGen)
import Network.HTTP.Client (queryString, path) import Network.HTTP.Client (queryString, path)
@ -46,11 +47,11 @@ serversEqualSpec = describe "serversEqual" $ do
context "when servers are not equal" $ do context "when servers are not equal" $ do
it "provides the failing responses in the error message" $ 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 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: 1"
show err `shouldContain` "Body: 2" show err `shouldContain` "Body: 2"
show err `shouldContain` "Path: /failplz" show err `shouldContain` "Path: /failplz"
@ -75,20 +76,20 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
context "when predicates are false" $ do context "when predicates are false" $ do
it "fails with informative error messages" $ do it "fails with informative error messages" $ do
Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty) safeEvalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
err `shouldContain` "getsHaveCacheControlHeader" show err `shouldContain` "getsHaveCacheControlHeader"
err `shouldContain` "Headers" show err `shouldContain` "Headers"
err `shouldContain` "Body" show err `shouldContain` "Body"
onlyJsonObjectSpec :: Spec onlyJsonObjectSpec :: Spec
onlyJsonObjectSpec = describe "onlyJsonObjects" $ do onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
it "fails correctly" $ do it "fails correctly" $ do
Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
(onlyJsonObjects <%> mempty) (onlyJsonObjects <%> mempty)
err `shouldContain` "onlyJsonObjects" show err `shouldContain` "onlyJsonObjects"
it "accepts non-JSON endpoints" $ do it "accepts non-JSON endpoints" $ do
withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl -> withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
@ -98,10 +99,10 @@ notLongerThanSpec :: Spec
notLongerThanSpec = describe "notLongerThan" $ do notLongerThanSpec = describe "notLongerThan" $ do
it "fails correctly" $ do it "fails correctly" $ do
Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
(notLongerThan 1 <%> mempty) (notLongerThan 1 <%> mempty)
err `shouldContain` "notLongerThan" show err `shouldContain` "notLongerThan"
it "succeeds correctly" $ do it "succeeds correctly" $ do
withServantServerAndContext api ctx server $ \burl -> withServantServerAndContext api ctx server $ \burl ->
@ -213,6 +214,12 @@ evalExample e = evaluateExample e defaultParams ($ ()) progCallback
where where
progCallback _ = return () progCallback _ = return ()
safeEvalExample :: (Example e, Arg e ~ ()) => e -> IO (Either SomeException Result)
safeEvalExample e = safeEvaluateExample e defaultParams ($ ()) progCallback
where
progCallback _ = return ()
args :: Args args :: Args
args = defaultArgs { maxSuccess = noOfTestCases } args = defaultArgs { maxSuccess = noOfTestCases }