194 lines
8.2 KiB
Haskell
194 lines
8.2 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE CPP #-}
|
|
module Servant.QuickCheck.Internal.QuickCheck where
|
|
|
|
import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
|
|
import Control.Monad (unless)
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import Data.Proxy (Proxy)
|
|
import qualified Network.HTTP.Client as C
|
|
import Network.Wai.Handler.Warp (withApplication)
|
|
import Prelude.Compat
|
|
import Servant (Context (EmptyContext), HasServer,
|
|
Server, serveWithContext)
|
|
#if MIN_VERSION_servant_server(0,18,0)
|
|
import Servant (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, type (.++))
|
|
#endif
|
|
import Servant.Client (BaseUrl (..), Scheme (..))
|
|
import System.IO.Unsafe (unsafePerformIO)
|
|
import Test.Hspec (Expectation, expectationFailure)
|
|
import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult)
|
|
import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
|
|
run)
|
|
import Test.QuickCheck.Property (counterexample)
|
|
|
|
import Servant.QuickCheck.Internal.Equality
|
|
import Servant.QuickCheck.Internal.ErrorTypes
|
|
import Servant.QuickCheck.Internal.HasGenRequest
|
|
import Servant.QuickCheck.Internal.Predicates
|
|
|
|
|
|
-- | Start a servant application on an open port, run the provided function,
|
|
-- then stop the application.
|
|
--
|
|
-- /Since 0.0.0.0/
|
|
withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
|
|
-> (BaseUrl -> IO r) -> IO r
|
|
withServantServer api = withServantServerAndContext api EmptyContext
|
|
|
|
-- | Like 'withServantServer', but allows passing in a 'Context' to the
|
|
-- application.
|
|
--
|
|
-- /Since 0.0.0.0/
|
|
#if MIN_VERSION_servant_server(0,18,0)
|
|
withServantServerAndContext :: (HasServer a ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters)
|
|
#else
|
|
withServantServerAndContext :: HasServer a ctx
|
|
#endif
|
|
=> Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
|
|
withServantServerAndContext api ctx server t
|
|
= withApplication (return . serveWithContext api ctx =<< server) $ \port ->
|
|
t (BaseUrl Http "localhost" port "")
|
|
|
|
-- | Check that the two servers running under the provided @BaseUrl@s behave
|
|
-- identically by randomly generating arguments (captures, query params, request bodies,
|
|
-- headers, etc.) expected by the server. If, given the same request, the
|
|
-- response is not the same (according to the definition of @==@ for the return
|
|
-- datatype), the 'Expectation' fails, printing the counterexample.
|
|
--
|
|
-- The @Int@ argument specifies maximum number of test cases to generate and
|
|
-- run.
|
|
--
|
|
-- Evidently, if the behaviour of the server is expected to be
|
|
-- non-deterministic, this function may produce spurious failures
|
|
--
|
|
-- Note that only valid requests are generated and tested. As an example of why
|
|
-- this matters, let's say your API specifies that a particular endpoint can
|
|
-- only generate @JSON@. @serversEqual@ will then not generate any requests
|
|
-- with an @Accept@ header _other_ than @application/json@. It may therefore
|
|
-- fail to notice that one application, when the request has @Accept:
|
|
-- text/html@, returns a @406 Not Acceptable@ HTTP response, and another
|
|
-- returns a @200 Success@, but with @application/json@ as the content-type.
|
|
--
|
|
-- The fact that only valid requests are tested also means that no endpoints
|
|
-- not listed in the API type are tested.
|
|
--
|
|
-- /Since 0.0.0.0/
|
|
serversEqual :: HasGenRequest a =>
|
|
Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
|
|
serversEqual api burl1 burl2 args req = do
|
|
let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
|
|
-- This MVar stuff is clunky! But there doesn't seem to be an easy way to
|
|
-- return results when a test fails, since an exception is throw.
|
|
deetsMVar <- newEmptyMVar
|
|
r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
|
|
resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
|
|
resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
|
|
unless (getResponseEquality req resp1 resp2) $ do
|
|
monitor (counterexample "hi" )
|
|
_ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
|
|
assert False
|
|
case r of
|
|
Success {} -> return ()
|
|
Failure{..} -> do
|
|
mx <- tryReadMVar deetsMVar
|
|
case mx of
|
|
Just x ->
|
|
expectationFailure $ "Failed:\n" ++ show x
|
|
Nothing ->
|
|
expectationFailure $ "We failed to record a reason for failure: " <> show r
|
|
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
|
NoExpectedFailure {} -> expectationFailure "No expected failure"
|
|
#if MIN_VERSION_QuickCheck(2,12,0)
|
|
#else
|
|
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
|
|
#endif
|
|
|
|
-- | Check that a server satisfies the set of properties specified.
|
|
--
|
|
-- Note that, rather than having separate tests for each property you'd like to
|
|
-- test, you should generally prefer to combine all properties into a single
|
|
-- test. This enables a more parsimonious generation of requests and responses
|
|
-- with the same testing depth.
|
|
--
|
|
-- Example usage:
|
|
--
|
|
-- > goodAPISpec = describe "my server" $ do
|
|
-- >
|
|
-- > it "follows best practices" $ do
|
|
-- > withServantServer api server $ \burl ->
|
|
-- > serverSatisfies api burl stdArgs (not500
|
|
-- > <%> onlyJsonObjects
|
|
-- > <%> notAllowedContainsAllowHeader
|
|
-- > <%> mempty)
|
|
--
|
|
-- /Since 0.0.0.0/
|
|
serverSatisfies :: (HasGenRequest a) =>
|
|
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
|
|
serverSatisfies api = serverSatisfiesMgr api defManager
|
|
|
|
-- | Check that a server satisfies the set of properties specified, and
|
|
-- accept a 'Manager' for running the HTTP requests through.
|
|
--
|
|
-- See 'serverSatisfies' for more details.
|
|
--
|
|
-- @since 0.0.7.2
|
|
serverSatisfiesMgr :: (HasGenRequest a) =>
|
|
Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
|
|
serverSatisfiesMgr api manager burl args preds = do
|
|
let reqs = ($ burl) <$> runGenRequest api
|
|
deetsMVar <- newEmptyMVar
|
|
r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
|
|
v <- run $ finishPredicates preds (noCheckStatus req) manager
|
|
_ <- run $ tryPutMVar deetsMVar v
|
|
case v of
|
|
Just _ -> assert False
|
|
_ -> return ()
|
|
case r of
|
|
Success {} -> return ()
|
|
Failure {..} -> do
|
|
mx <- tryReadMVar deetsMVar
|
|
case mx of
|
|
Just x ->
|
|
expectationFailure $ "Failed:\n" ++ show x
|
|
Nothing ->
|
|
expectationFailure $ "We failed to record a reason for failure: " <> show r
|
|
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
|
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
|
#if MIN_VERSION_QuickCheck(2,12,0)
|
|
#else
|
|
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
|
|
#endif
|
|
|
|
serverDoesntSatisfy :: (HasGenRequest a) =>
|
|
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
|
|
serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager
|
|
|
|
serverDoesntSatisfyMgr :: (HasGenRequest a) =>
|
|
Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
|
|
serverDoesntSatisfyMgr api manager burl args preds = do
|
|
let reqs = ($ burl) <$> runGenRequest api
|
|
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
|
|
v <- run $ finishPredicates preds (noCheckStatus req) manager
|
|
assert $ not $ null v
|
|
case r of
|
|
Success {} -> return ()
|
|
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
|
Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
|
|
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
|
#if MIN_VERSION_QuickCheck(2,12,0)
|
|
#else
|
|
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
|
|
#endif
|
|
|
|
noCheckStatus :: C.Request -> C.Request
|
|
#if MIN_VERSION_http_client(0,5,0)
|
|
noCheckStatus = id
|
|
#else
|
|
noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
|
|
#endif
|
|
|
|
defManager :: C.Manager
|
|
defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
|
{-# NOINLINE defManager #-}
|