git.iko.soy/servant-quickcheck
on 76e3b8e help sign in
servant-quickcheck/src/Servant/QuickCheck/Internal/QuickCheck.hs
95 lines 4.6 kB history raw
1-- | This module contains wrappers around lower-level functionality.
2module Servant.QuickCheck.Internal.QuickCheck where
4import qualified Data.ByteString.Lazy as LBS
5import Data.Proxy (Proxy)
6import Data.Text (Text)
7import Network.HTTP.Client (Manager, Request, checkStatus,
8 defaultManagerSettings, httpLbs,
9 newManager)
10import Network.Wai.Handler.Warp (withApplication)
11import Servant (HasServer, Server, serve)
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
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 server t
29 = withApplication (return . serve api =<< server) $ \port ->
30 t (BaseUrl Http "localhost" port "")
32-- | Check that the two servers running under the provided @BaseUrl@s behave
33-- identically by randomly generating arguments (captures, query params, request bodies,
34-- headers, etc.) expected by the server. If, given the same request, the
35-- response is not the same (according to the definition of @==@ for the return
36-- datatype), the 'Expectation' fails, printing the counterexample.
37--
38-- The @Int@ argument specifies maximum number of test cases to generate and
39-- run.
40--
41-- Evidently, if the behaviour of the server is expected to be
42-- non-deterministic, this function may produce spurious failures
43serversEqual :: HasGenRequest a =>
44 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
45serversEqual api burl1 burl2 args req = do
46 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
47 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
48 resp1 <- run $ httpLbs (noCheckStatus req1) defManager
49 resp2 <- run $ httpLbs (noCheckStatus req2) defManager
50 assert $ getResponseEquality req resp1 resp2
51 case r of
52 Success {} -> return ()
53 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
54 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
55 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
56 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
58-- | Check that a server satisfies the set of properties specified.
59--
60-- Note that, rather than having separate tests for each property you'd like to
61-- test, you should generally prefer to combine all properties into a single
62-- test. This enables a more parsimonious generation of requests and responses
63-- with the same testing depth.
64--
65-- Example usage:
66--
67-- > goodAPISpec = describe "my server" $ do
68-- >
69-- > it "follows best practices" $ do
70-- > withServantServer api server $ \burl ->
71-- > serverSatisfies api burl stdArgs (not500
72-- > <%> onlyJsonObjects
73-- > <%> notAllowedContainsAllowHeader
74-- > <%> mempty)
75serverSatisfies :: (HasGenRequest a) =>
76 Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
77serverSatisfies api burl args preds = do
78 let reqs = ($ burl) <$> genRequest api
79 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
80 v <- run $ finishPredicates preds (noCheckStatus req) defManager
81 assert $ null v
82 case r of
83 Success {} -> return ()
84 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
85 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
86 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
87 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
90noCheckStatus :: Request -> Request
91noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
93defManager :: Manager
94defManager = unsafePerformIO $ newManager defaultManagerSettings
95{-# NOINLINE defManager #-}