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

Compatibility with earlier versions of hspec.

Browse Source 
Adds CPP to the tests to allow for upstream changes to the 'Result'
    type.
This commit is contained in:
Julian K. Arni 2017-10-15 17:00:04 -07:00
parent f3b4fcf7a9
commit a0ec1777a7
2 changed files with 59 additions and 27 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.4.4 && < 2.5 , 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.9 && < 2.11 , 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

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

@ -2,22 +2,22 @@
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 (SomeException) import Control.Exception (SomeException)
import Control.Monad (replicateM) import Control.Monad (replicateM)
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
import Data.Maybe (fromJust) 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, safeEvaluateExample) 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)
@ -27,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
@ -53,9 +61,9 @@ 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
Right (Failure _ err) <- withServantServer api2 server2 $ \burl1 -> FailedWith err <- withServantServer api2 server2 $ \burl1 ->
withServantServer api2 server3 $ \burl2 -> do 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` "Server equality failed"
show err `shouldContain` "Body: 1" show err `shouldContain` "Body: 1"
show err `shouldContain` "Body: 2" show err `shouldContain` "Body: 2"
@ -81,8 +89,8 @@ 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
Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
safeEvalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty) evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
show err `shouldContain` "notAllowedContainsAllowHeader" show err `shouldContain` "notAllowedContainsAllowHeader"
show err `shouldContain` "Headers" show err `shouldContain` "Headers"
show err `shouldContain` "Body" show err `shouldContain` "Body"
@ -92,8 +100,8 @@ onlyJsonObjectSpec :: Spec
onlyJsonObjectSpec = describe "onlyJsonObjects" $ do onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
it "fails correctly" $ do it "fails correctly" $ do
Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
(onlyJsonObjects <%> mempty) (onlyJsonObjects <%> mempty)
show err `shouldContain` "onlyJsonObjects" show err `shouldContain` "onlyJsonObjects"
@ -105,8 +113,8 @@ notLongerThanSpec :: Spec
notLongerThanSpec = describe "notLongerThan" $ do notLongerThanSpec = describe "notLongerThan" $ do
it "fails correctly" $ do it "fails correctly" $ do
Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
(notLongerThan 1 <%> mempty) (notLongerThan 1 <%> mempty)
show err `shouldContain` "notLongerThan" show err `shouldContain` "notLongerThan"
@ -259,10 +267,34 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Utils -- Utils
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
safeEvalExample :: (Example e, Arg e ~ ()) => e -> IO (Either SomeException Result) evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
safeEvalExample e = safeEvaluateExample e defaultParams ($ ()) progCallback #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 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