@@ -2,7 +2,7 @@
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3module Servant.QuickCheck.Internal.QuickCheck where
3module Servant.QuickCheck.Internal.QuickCheck where
5−import Control.Concurrent (modifyMVar_, newMVar, readMVar)
5+import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
6import Control.Monad (unless)
6import Control.Monad (unless)
7import qualified Data.ByteString.Lazy as LBS
7import qualified Data.ByteString.Lazy as LBS
8import Data.Proxy (Proxy)
8import Data.Proxy (Proxy)
@@ -73,18 +73,23 @@ serversEqual api burl1 burl2 args req = do
73 let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
73 let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
74 -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
74 -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
75 -- return results when a test fails, since an exception is throw.
75 -- return results when a test fails, since an exception is throw.
76− deetsMVar <- newMVar $ error "should not be called"
76+ deetsMVar <- newEmptyMVar
77 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
77 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
78 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
78 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
79 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
79 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
80 unless (getResponseEquality req resp1 resp2) $ do
80 unless (getResponseEquality req resp1 resp2) $ do
81 monitor (counterexample "hi" )
81 monitor (counterexample "hi" )
82− run $ modifyMVar_ deetsMVar $ const $ return $
83− ServerEqualityFailure req1 resp1 resp2
82+ _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
84 assert False
83 assert False
86 Success {} -> return ()
85 Success {} -> return ()
87+ mx <- tryReadMVar deetsMVar
87− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x
90+ expectationFailure $ "Failed:\n" ++ show x
92+ expectationFailure $ "We failed to record a reason for failure: " <> show r
88 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
93 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
89 NoExpectedFailure {} -> expectationFailure "No expected failure"
94 NoExpectedFailure {} -> expectationFailure "No expected failure"
90 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
95 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
@@ -112,21 +117,32 @@ serverSatisfies :: (HasGenRequest a) =>
112 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
117 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
113serverSatisfies api = serverSatisfiesMgr api defManager
118serverSatisfies api = serverSatisfiesMgr api defManager
120+-- | Check that a server satisfies the set of properties specified, and
121+-- accept a 'Manager' for running the HTTP requests through.
123+-- See 'serverSatisfies' for more details.
115serverSatisfiesMgr :: (HasGenRequest a) =>
126serverSatisfiesMgr :: (HasGenRequest a) =>
116 Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
127 Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
117serverSatisfiesMgr api manager burl args preds = do
128serverSatisfiesMgr api manager burl args preds = do
118 let reqs = ($ burl) <$> runGenRequest api
129 let reqs = ($ burl) <$> runGenRequest api
119− deetsMVar <- newMVar $ error "should not be called"
130+ deetsMVar <- newEmptyMVar
120 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
131 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
121− v <- run $ finishPredicates preds (noCheckStatus req) manager
132+ v <- run $ finishPredicates preds (noCheckStatus req) manager
122− run $ modifyMVar_ deetsMVar $ const $ return v
133+ _ <- run $ tryPutMVar deetsMVar v
123− case v of
134+ case v of
124− Just _ -> assert False
135+ Just _ -> assert False
125− _ -> return ()
136+ _ -> return ()
126 case r of
137 case r of
127 Success {} -> return ()
138 Success {} -> return ()
128− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
139+ Failure {..} -> do
140+ mx <- tryReadMVar deetsMVar
129− "Failed:\n" ++ show x
143+ expectationFailure $ "Failed:\n" ++ show x
145+ expectationFailure $ "We failed to record a reason for failure: " <> show r
130 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
146 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
131 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
147 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
132 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
148 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"