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

Merge pull request #29 from haskell-servant/issue-27/supportHspec2.4

Browse Source 
Upgrade hspec to 2.4.4 and use safeEvaluateExample for tests
This commit is contained in:
Julian Arni 2017-10-15 18:45:03 -07:00 committed by GitHub
commit e7206ec875
4 changed files with 74 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
servant-quickcheck.cabal
View File

@ -38,14 +38,14 @@ 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.2 && < 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.7 && < 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: []

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

@ -1,21 +1,24 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Servant.QuickCheck.InternalSpec (spec) where module Servant.QuickCheck.InternalSpec (spec) where
import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
import Control.Monad (replicateM) import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
import Control.Monad.IO.Class (liftIO) import Control.Exception (SomeException)
import qualified Data.ByteString as BS import Control.Monad (replicateM)
import qualified Data.ByteString.Char8 as C import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromJust) 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 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 (..),
defaultParams, evaluateExample) defaultParams)
import Test.QuickCheck.Gen (unGen, generate) import Test.QuickCheck.Gen (generate, unGen)
import Test.QuickCheck.Random (mkQCGen) import Test.QuickCheck.Random (mkQCGen)
import Network.HTTP.Client (queryString, path)
#if MIN_VERSION_servant(0,8,0) #if MIN_VERSION_servant(0,8,0)
import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw) import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
@ -24,8 +27,16 @@ import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
comprehensiveAPI) comprehensiveAPI)
#endif #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
import Servant.QuickCheck.Internal (genRequest, runGenRequest, serverDoesntSatisfy) import Servant.QuickCheck.Internal (genRequest, runGenRequest,
serverDoesntSatisfy)
spec :: Spec spec :: Spec
@ -50,9 +61,10 @@ 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 -> FailedWith err <- withServantServer api2 server2 $ \burl1 ->
withServantServer api2 server3 $ \burl2 -> do withServantServer api2 server3 $ \burl2 -> do
evalExample $ 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: 1"
show err `shouldContain` "Body: 2" show err `shouldContain` "Body: 2"
show err `shouldContain` "Path: /failplz" show err `shouldContain` "Path: /failplz"
@ -77,21 +89,21 @@ 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 FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty) evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
err `shouldContain` "notAllowedContainsAllowHeader" show err `shouldContain` "notAllowedContainsAllowHeader"
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 FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args evalExample $ 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 ->
@ -101,10 +113,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 FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args evalExample $ 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 ->
@ -166,8 +178,8 @@ unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
let mean = (sum $ map fromIntegral someRequests) / runs let mean = (sum $ map fromIntegral someRequests) / runs
let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean) let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
let variance = (sum $ map variancer someRequests) / runs - 1 let variance = (sum $ map variancer someRequests) / runs - 1
-- mean should be around 8 -- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
mean > 7 `shouldBe` True mean > 8 `shouldBe` True
mean < 9 `shouldBe` True mean < 9 `shouldBe` True
-- Std dev is likely around 4. Variance is probably greater than 20. -- Std dev is likely around 4. Variance is probably greater than 20.
variance > 19.5 `shouldBe` True variance > 19.5 `shouldBe` True
@ -255,11 +267,35 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Utils -- Utils
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
evalExample :: (Example e, Arg e ~ ()) => e -> IO Result #if MIN_VERSION_hspec(2,4,0)
evalExample e = evaluateExample e defaultParams ($ ()) progCallback 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 where
progCallback _ = return () 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 args :: Args
args = defaultArgs { maxSuccess = noOfTestCases } args = defaultArgs { maxSuccess = noOfTestCases }