servant-quickcheck 0.0.4 → 0.0.4.1

raw patch · 3 files changed

+38/−15 lines, 3 filesnew-uploader

Files

• CHANGELOG.yaml +7/−0
• servant-quickcheck.cabal +1/−1
• src/Servant/QuickCheck/Internal/QuickCheck.hs +30/−14

@@ -1,6 +1,13 @@ upcoming:  releases:+  - version: "0.0.4.1"+    changes:+      - description: Backport "should not happen" error fixes and configurable manager+        issue: 47, 48+        authors: parsonsmatt+        date: 2018-05-10+   - version: "0.0.4"     changes: 

@@ -1,5 +1,5 @@ name:                servant-quickcheck-version:             0.0.4+version:             0.0.4.1 synopsis:            QuickCheck entire APIs description:  This packages provides QuickCheck properties that are tested across an entire

@@ -2,9 +2,10 @@ {-# 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.Monoid              ((<>)) import           Data.Proxy               (Proxy) import qualified Network.HTTP.Client      as C import           Network.Wai.Handler.Warp (withApplication)@@ -73,18 +74,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 +116,40 @@ -- /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++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+     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 $ "Failed to retrieve error. QC 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 ()