From d66c2d278afd0d56de8aaa71cb8a4c4ed6f13818 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 10 May 2018 10:08:06 -0600 Subject: [PATCH] Safer MVar usage (#49) * Fix stack.yaml file * Remove unfixable stack files * Resolve ambiguous import in GHCi * handle MVars without error * Consistent messaging * Add comment --- servant-quickcheck.cabal | 2 +- src/Servant/QuickCheck/Internal/QuickCheck.hs | 42 +++++++++++++------ stack-lts-6.yaml | 6 --- stack-lts-7.yaml | 6 --- stack-lts-9.yaml | 6 --- stack.yaml | 14 ++++--- 6 files changed, 39 insertions(+), 37 deletions(-) delete mode 100644 stack-lts-6.yaml delete mode 100644 stack-lts-7.yaml delete mode 100644 stack-lts-9.yaml diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index d091533..a2418db 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -93,7 +93,7 @@ test-suite spec 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/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 53d90f6..df89bf4 100644 --- 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 @@ serversEqual api burl1 burl2 args req = do 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" @@ -112,21 +117,32 @@ serverSatisfies :: (HasGenRequest a) => Proxy a -> BaseUrl -> Args -> Predicates -> Expectation 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) manager - 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" diff --git a/stack-lts-6.yaml b/stack-lts-6.yaml deleted file mode 100644 index 19f07c3..0000000 --- a/stack-lts-6.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: lts-6.30 -packages: -- '.' -extra-deps: [] -flags: {} -extra-package-dbs: [] diff --git a/stack-lts-7.yaml b/stack-lts-7.yaml deleted file mode 100644 index 5ffaec4..0000000 --- a/stack-lts-7.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: lts-7.19 -packages: -- '.' -extra-deps: [] -flags: {} -extra-package-dbs: [] diff --git a/stack-lts-9.yaml b/stack-lts-9.yaml deleted file mode 100644 index 7e860d7..0000000 --- a/stack-lts-9.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: lts-9.1 -packages: -- '.' -extra-deps: [] -flags: {} -extra-package-dbs: [] diff --git a/stack.yaml b/stack.yaml index 5dd9243..bf867f3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,14 @@ -resolver: lts-8.4 +resolver: lts-11.8 packages: - '.' extra-deps: -- hspec-2.4.4 -- hspec-core-2.4.4 -- hspec-discover-2.4.4 -- quickcheck-io-0.2.0 +- base-compat-batteries-0.10.1 +- base-compat-0.10.1 +- hspec-discover-2.5.0 +- hspec-core-2.5.0 +- hspec-2.5.0 +# aeson pre-1.3.1.0 has an upper bound on `base-compat-batteries` that preclude +# the 0.10.1 that we depend on +- aeson-1.3.1.0 flags: {} extra-package-dbs: []