git.iko.soy/servant-quickcheck
on 64c845c help sign in
servant-quickcheck/src/Servant/QuickCheck/Internal/QuickCheck.hs
115 lines 5.6 kB history raw
1module Servant.QuickCheck.Internal.QuickCheck where
3import qualified Data.ByteString.Lazy as LBS
4import Data.Proxy (Proxy)
5import Data.Text (Text)
6import Network.HTTP.Client (Manager, Request, checkStatus,
7 defaultManagerSettings, httpLbs,
8 newManager)
9import Network.Wai.Handler.Warp (withApplication)
10import Servant (Context (EmptyContext), HasServer,
11 Server, serveWithContext)
12import Servant.Client (BaseUrl (..), Scheme (..))
13import System.IO.Unsafe (unsafePerformIO)
14import Test.Hspec (Expectation, expectationFailure)
15import Test.QuickCheck (Args (..), Result (..),
16 quickCheckWithResult)
17import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)
19import Servant.QuickCheck.Internal.HasGenRequest
20import Servant.QuickCheck.Internal.Predicates
21import Servant.QuickCheck.Internal.Equality
24-- | Start a servant application on an open port, run the provided function,
25-- then stop the application.
26withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
27 -> (BaseUrl -> IO r) -> IO r
28withServantServer api = withServantServerAndContext api EmptyContext
30-- | Like 'withServantServer', but allows passing in a 'Context' to the
31-- application.
32withServantServerAndContext :: HasServer a ctx
33 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
34withServantServerAndContext api ctx server t
35 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
36 t (BaseUrl Http "localhost" port "")
38-- | Check that the two servers running under the provided @BaseUrl@s behave
39-- identically by randomly generating arguments (captures, query params, request bodies,
40-- headers, etc.) expected by the server. If, given the same request, the
41-- response is not the same (according to the definition of @==@ for the return
42-- datatype), the 'Expectation' fails, printing the counterexample.
43--
44-- The @Int@ argument specifies maximum number of test cases to generate and
45-- run.
46--
47-- Evidently, if the behaviour of the server is expected to be
48-- non-deterministic, this function may produce spurious failures
49serversEqual :: HasGenRequest a =>
50 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
51serversEqual api burl1 burl2 args req = do
52 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
53 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
54 resp1 <- run $ httpLbs (noCheckStatus req1) defManager
55 resp2 <- run $ httpLbs (noCheckStatus req2) defManager
56 assert $ getResponseEquality req resp1 resp2
57 case r of
58 Success {} -> return ()
59 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
60 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
61 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
62 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
64-- | Check that a server satisfies the set of properties specified.
65--
66-- Note that, rather than having separate tests for each property you'd like to
67-- test, you should generally prefer to combine all properties into a single
68-- test. This enables a more parsimonious generation of requests and responses
69-- with the same testing depth.
70--
71-- Example usage:
72--
73-- > goodAPISpec = describe "my server" $ do
74-- >
75-- > it "follows best practices" $ do
76-- > withServantServer api server $ \burl ->
77-- > serverSatisfies api burl stdArgs (not500
78-- > <%> onlyJsonObjects
79-- > <%> notAllowedContainsAllowHeader
80-- > <%> mempty)
81serverSatisfies :: (HasGenRequest a) =>
82 Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
83serverSatisfies api burl args preds = do
84 let reqs = ($ burl) <$> genRequest api
85 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
86 v <- run $ finishPredicates preds (noCheckStatus req) defManager
87 assert $ null v
88 case r of
89 Success {} -> return ()
90 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
91 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
92 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
93 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
96serverDoesntSatisfy :: (HasGenRequest a) =>
97 Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
98serverDoesntSatisfy api burl args preds = do
99 let reqs = ($ burl) <$> genRequest api
100 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
101 v <- run $ finishPredicates preds (noCheckStatus req) defManager
102 assert $ not $ null v
103 case r of
104 Success {} -> return ()
105 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
106 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
107 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
108 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
110noCheckStatus :: Request -> Request
111noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
113defManager :: Manager
114defManager = unsafePerformIO $ newManager defaultManagerSettings
115{-# NOINLINE defManager #-}