@@ -2,7 +2,7 @@
22{-# LANGUAGE CPP #-}
33module Servant.QuickCheck.Internal.QuickCheck where
44
5−import Control.Concurrent (modifyMVar_, newMVar, readMVar)
5+import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
66import Control.Monad (unless)
77import qualified Data.ByteString.Lazy as LBS
88import Data.Proxy (Proxy)
@@ -73,18 +73,23 @@ serversEqual api burl1 burl2 args req = do
7373 let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
7474 -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
7575 -- return results when a test fails, since an exception is throw.
76− deetsMVar <- newMVar $ error "should not be called"
76+ deetsMVar <- newEmptyMVar
7777 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
7878 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
7979 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
8080 unless (getResponseEquality req resp1 resp2) $ do
8181 monitor (counterexample "hi" )
82− run $ modifyMVar_ deetsMVar $ const $ return $
83− ServerEqualityFailure req1 resp1 resp2
82+ _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
8483 assert False
8584 case r of
8685 Success {} -> return ()
87− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x
86+ Failure{..} -> do
87+ mx <- tryReadMVar deetsMVar
88+ case mx of
89+ Just x ->
90+ expectationFailure $ "Failed:\n" ++ show x
91+ Nothing ->
92+ expectationFailure $ "We failed to record a reason for failure: " <> show r
8893 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
8994 NoExpectedFailure {} -> expectationFailure "No expected failure"
9095 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
@@ -112,21 +117,32 @@ serverSatisfies :: (HasGenRequest a) =>
112117 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
113118serverSatisfies api = serverSatisfiesMgr api defManager
114119
120+-- | Check that a server satisfies the set of properties specified, and
121+-- accept a 'Manager' for running the HTTP requests through.
122+--
123+-- See 'serverSatisfies' for more details.
124+--
125+-- @since 0.0.7.2
115126serverSatisfiesMgr :: (HasGenRequest a) =>
116127 Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
117128serverSatisfiesMgr api manager burl args preds = do
118129 let reqs = ($ burl) <$> runGenRequest api
119− deetsMVar <- newMVar $ error "should not be called"
130+ deetsMVar <- newEmptyMVar
120131 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
121− v <- run $ finishPredicates preds (noCheckStatus req) manager
122− run $ modifyMVar_ deetsMVar $ const $ return v
123− case v of
124− Just _ -> assert False
125− _ -> return ()
132+ v <- run $ finishPredicates preds (noCheckStatus req) manager
133+ _ <- run $ tryPutMVar deetsMVar v
134+ case v of
135+ Just _ -> assert False
136+ _ -> return ()
126137 case r of
127138 Success {} -> return ()
128− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
129− "Failed:\n" ++ show x
139+ Failure {..} -> do
140+ mx <- tryReadMVar deetsMVar
141+ case mx of
142+ Just x ->
143+ expectationFailure $ "Failed:\n" ++ show x
144+ Nothing ->
145+ expectationFailure $ "We failed to record a reason for failure: " <> show r
130146 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
131147 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
132148 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"