@@ -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)
@@ -11,6 +11,9 @@ import Network.Wai.Handler.Warp (withApplication)
11import Prelude.Compat
11import Prelude.Compat
12import Servant (Context (EmptyContext), HasServer,
12import Servant (Context (EmptyContext), HasServer,
13 Server, serveWithContext)
13 Server, serveWithContext)
14+#if MIN_VERSION_servant_server(0,18,0)
15+import Servant (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, type (.++))
14import Servant.Client (BaseUrl (..), Scheme (..))
17import Servant.Client (BaseUrl (..), Scheme (..))
15import System.IO.Unsafe (unsafePerformIO)
18import System.IO.Unsafe (unsafePerformIO)
16import Test.Hspec (Expectation, expectationFailure)
19import Test.Hspec (Expectation, expectationFailure)
@@ -37,7 +40,11 @@ withServantServer api = withServantServerAndContext api EmptyContext
37-- application.
40-- application.
39-- /Since 0.0.0.0/
42-- /Since 0.0.0.0/
43+#if MIN_VERSION_servant_server(0,18,0)
44+withServantServerAndContext :: (HasServer a ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters)
40withServantServerAndContext :: HasServer a ctx
46withServantServerAndContext :: HasServer a ctx
41 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
48 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
42withServantServerAndContext api ctx server t
49withServantServerAndContext api ctx server t
43 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
50 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
@@ -73,21 +80,29 @@ serversEqual api burl1 burl2 args req = do
73 let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
80 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
81 -- 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.
82 -- return results when a test fails, since an exception is throw.
76− deetsMVar <- newMVar $ error "should not be called"
83+ deetsMVar <- newEmptyMVar
77 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
84 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
78 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
85 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
79 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
86 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
80 unless (getResponseEquality req resp1 resp2) $ do
87 unless (getResponseEquality req resp1 resp2) $ do
81 monitor (counterexample "hi" )
88 monitor (counterexample "hi" )
82− run $ modifyMVar_ deetsMVar $ const $ return $
83− ServerEqualityFailure req1 resp1 resp2
89+ _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
84 assert False
90 assert False
86 Success {} -> return ()
92 Success {} -> return ()
94+ mx <- tryReadMVar deetsMVar
87− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x
97+ expectationFailure $ "Failed:\n" ++ show x
99+ expectationFailure $ "We failed to record a reason for failure: " <> show r
88 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
100 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
89 NoExpectedFailure {} -> expectationFailure "No expected failure"
101 NoExpectedFailure {} -> expectationFailure "No expected failure"
102+#if MIN_VERSION_QuickCheck(2,12,0)
90 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
104 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
92-- | Check that a server satisfies the set of properties specified.
107-- | Check that a server satisfies the set of properties specified.
@@ -110,37 +125,61 @@ serversEqual api burl1 burl2 args req = do
110-- /Since 0.0.0.0/
125-- /Since 0.0.0.0/
111serverSatisfies :: (HasGenRequest a) =>
126serverSatisfies :: (HasGenRequest a) =>
112 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
127 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
113−serverSatisfies api burl args preds = do
128+serverSatisfies api = serverSatisfiesMgr api defManager
130+-- | Check that a server satisfies the set of properties specified, and
131+-- accept a 'Manager' for running the HTTP requests through.
133+-- See 'serverSatisfies' for more details.
136+serverSatisfiesMgr :: (HasGenRequest a) =>
137+ Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
138+serverSatisfiesMgr api manager burl args preds = do
114 let reqs = ($ burl) <$> runGenRequest api
139 let reqs = ($ burl) <$> runGenRequest api
115− deetsMVar <- newMVar $ error "should not be called"
140+ deetsMVar <- newEmptyMVar
116 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
141 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
117− v <- run $ finishPredicates preds (noCheckStatus req) defManager
142+ v <- run $ finishPredicates preds (noCheckStatus req) manager
118− run $ modifyMVar_ deetsMVar $ const $ return v
143+ _ <- run $ tryPutMVar deetsMVar v
119− case v of
144+ case v of
120− Just _ -> assert False
145+ Just _ -> assert False
121− _ -> return ()
146+ _ -> return ()
122 case r of
147 case r of
123 Success {} -> return ()
148 Success {} -> return ()
124− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
149+ Failure {..} -> do
150+ mx <- tryReadMVar deetsMVar
125− "Failed:\n" ++ show x
153+ expectationFailure $ "Failed:\n" ++ show x
155+ expectationFailure $ "We failed to record a reason for failure: " <> show r
126 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
156 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
127 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
157 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
158+#if MIN_VERSION_QuickCheck(2,12,0)
128− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
160+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
131serverDoesntSatisfy :: (HasGenRequest a) =>
163serverDoesntSatisfy :: (HasGenRequest a) =>
132 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
164 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
133−serverDoesntSatisfy api burl args preds = do
165+serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager
167+serverDoesntSatisfyMgr :: (HasGenRequest a) =>
168+ Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
169+serverDoesntSatisfyMgr api manager burl args preds = do
134 let reqs = ($ burl) <$> runGenRequest api
170 let reqs = ($ burl) <$> runGenRequest api
135 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
171 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
136− v <- run $ finishPredicates preds (noCheckStatus req) defManager
172+ v <- run $ finishPredicates preds (noCheckStatus req) manager
137 assert $ not $ null v
173 assert $ not $ null v
138 case r of
174 case r of
139 Success {} -> return ()
175 Success {} -> return ()
140 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
176 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
141 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
177 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
142 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
178 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
179+#if MIN_VERSION_QuickCheck(2,12,0)
143− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
181+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
145noCheckStatus :: C.Request -> C.Request
184noCheckStatus :: C.Request -> C.Request
146#if MIN_VERSION_http_client(0,5,0)
185#if MIN_VERSION_http_client(0,5,0)