diff --git a/CHANGELOG.yaml b/CHANGELOG.yaml --- a/CHANGELOG.yaml +++ b/CHANGELOG.yaml @@ -1,5 +1,26 @@ releases: + - version: "0.0.7.2" + changes: + + - description: Allow client to pass an HTTP Manager in to functions + issue: 47 + authors: parsonsmatt + date: 2018-05-10 + + - description: Fix "should not happen" error when exceptions are thrown + issue: 48 + authors: parsonsmatt + date: 2018-05-10 + + - version: "0.0.7.0" + changes: + + - description: Support for base-compat-0.10 + issue: none + authors: phadej + date: 2018-04-12 + - version: "0.0.7.0" changes: diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -1,5 +1,5 @@ name: servant-quickcheck -version: 0.0.7.0 +version: 0.0.7.2 synopsis: QuickCheck entire APIs description: This packages provides QuickCheck properties that are tested across an entire @@ -37,7 +37,7 @@ , Servant.QuickCheck.Internal.Equality , Servant.QuickCheck.Internal.ErrorTypes build-depends: base >=4.8 && <4.12 - , base-compat == 0.9.* + , base-compat-batteries >= 0.10.1 && <0.11 , aeson > 0.8 && < 2 , bytestring == 0.10.* , case-insensitive == 1.2.* @@ -56,7 +56,7 @@ , servant-server >= 0.13 && < 0.14 , split == 0.2.* , string-conversions > 0.3 && < 0.5 - , temporary == 1.2.* + , temporary >= 1.2 && <1.4 , text == 1.* , time >= 1.5 && < 1.9 , warp >= 3.2.4 && < 3.3 @@ -93,7 +93,7 @@ other-modules: Servant.QuickCheck.InternalSpec build-tool-depends: hspec-discover:hspec-discover build-depends: base - , base-compat + , base-compat-batteries , aeson , servant-quickcheck , bytestring diff --git a/src/Servant/QuickCheck/Internal/ErrorTypes.hs b/src/Servant/QuickCheck/Internal/ErrorTypes.hs --- a/src/Servant/QuickCheck/Internal/ErrorTypes.hs +++ b/src/Servant/QuickCheck/Internal/ErrorTypes.hs @@ -11,11 +11,7 @@ import Network.HTTP.Types (Header, statusCode) import Text.PrettyPrint -#if MIN_VERSION_base(4,11,0) import Prelude.Compat hiding ((<>)) -#else -import Prelude.Compat -#endif data PredicateFailure = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString) diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -2,7 +2,6 @@ {-# LANGUAGE PolyKinds #-} module Servant.QuickCheck.Internal.HasGenRequest where -import Data.Monoid ((<>)) import Data.String (fromString) import Data.String.Conversions (cs) import GHC.TypeLits (KnownSymbol, Nat, symbolVal) diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -2,7 +2,7 @@ {-# LANGUAGE CPP #-} module Servant.QuickCheck.Internal.QuickCheck where -import Control.Concurrent (modifyMVar_, newMVar, readMVar) +import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar) import Control.Monad (unless) import qualified Data.ByteString.Lazy as LBS import Data.Proxy (Proxy) @@ -73,18 +73,23 @@ let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api -- This MVar stuff is clunky! But there doesn't seem to be an easy way to -- return results when a test fails, since an exception is throw. - deetsMVar <- newMVar $ error "should not be called" + deetsMVar <- newEmptyMVar r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager unless (getResponseEquality req resp1 resp2) $ do monitor (counterexample "hi" ) - run $ modifyMVar_ deetsMVar $ const $ return $ - ServerEqualityFailure req1 resp1 resp2 + _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2 assert False case r of Success {} -> return () - Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x + Failure{..} -> do + mx <- tryReadMVar deetsMVar + case mx of + Just x -> + expectationFailure $ "Failed:\n" ++ show x + Nothing -> + expectationFailure $ "We failed to record a reason for failure: " <> show r GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests" NoExpectedFailure {} -> expectationFailure "No expected failure" InsufficientCoverage {} -> expectationFailure "Insufficient coverage" @@ -110,30 +115,48 @@ -- /Since 0.0.0.0/ serverSatisfies :: (HasGenRequest a) => Proxy a -> BaseUrl -> Args -> Predicates -> Expectation -serverSatisfies api burl args preds = do +serverSatisfies api = serverSatisfiesMgr api defManager + +-- | Check that a server satisfies the set of properties specified, and +-- accept a 'Manager' for running the HTTP requests through. +-- +-- See 'serverSatisfies' for more details. +-- +-- @since 0.0.7.2 +serverSatisfiesMgr :: (HasGenRequest a) => + Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation +serverSatisfiesMgr api manager burl args preds = do let reqs = ($ burl) <$> runGenRequest api - deetsMVar <- newMVar $ error "should not be called" + deetsMVar <- newEmptyMVar r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do - v <- run $ finishPredicates preds (noCheckStatus req) defManager - run $ modifyMVar_ deetsMVar $ const $ return v - case v of - Just _ -> assert False - _ -> return () + v <- run $ finishPredicates preds (noCheckStatus req) manager + _ <- run $ tryPutMVar deetsMVar v + case v of + Just _ -> assert False + _ -> return () case r of Success {} -> return () - Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ - "Failed:\n" ++ show x + Failure {..} -> do + mx <- tryReadMVar deetsMVar + case mx of + Just x -> + expectationFailure $ "Failed:\n" ++ show x + Nothing -> + expectationFailure $ "We failed to record a reason for failure: " <> show r GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests" NoExpectedFailure {} -> expectationFailure $ "No expected failure" InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" - serverDoesntSatisfy :: (HasGenRequest a) => Proxy a -> BaseUrl -> Args -> Predicates -> Expectation -serverDoesntSatisfy api burl args preds = do +serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager + +serverDoesntSatisfyMgr :: (HasGenRequest a) => + Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation +serverDoesntSatisfyMgr api manager burl args preds = do let reqs = ($ burl) <$> runGenRequest api r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do - v <- run $ finishPredicates preds (noCheckStatus req) defManager + v <- run $ finishPredicates preds (noCheckStatus req) manager assert $ not $ null v case r of Success {} -> return ()