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.*
, 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

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

@ -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.
--

7
stack.yaml
View File

@ -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: []

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

@ -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 }