module Servant.QuickCheck.Internal.QuickCheck where
import qualified Data.ByteString.Lazy as LBS
import Data.Proxy (Proxy)
import Data.Text (Text)
import Network.HTTP.Client (Manager, Request, checkStatus,
defaultManagerSettings, httpLbs,
newManager)
import Network.Wai.Handler.Warp (withApplication)
import Prelude.Compat
import Servant (Context (EmptyContext), HasServer,
Server, serveWithContext)
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, run)
import Servant.QuickCheck.Internal.HasGenRequest
import Servant.QuickCheck.Internal.Predicates
import Servant.QuickCheck.Internal.Equality
withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
-> (BaseUrl -> IO r) -> IO r
withServantServer api = withServantServerAndContext api EmptyContext
withServantServerAndContext :: HasServer a ctx
=> 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 "")
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)) <$> genRequest api
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
resp1 <- run $ httpLbs (noCheckStatus req1) defManager
resp2 <- run $ httpLbs (noCheckStatus req2) defManager
assert $ getResponseEquality req resp1 resp2
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"
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
serverSatisfies :: (HasGenRequest a) =>
Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
serverSatisfies api burl args preds = do
let reqs = ($ burl) <$> genRequest api
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
v <- run $ finishPredicates preds (noCheckStatus req) defManager
assert $ 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"
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
serverDoesntSatisfy :: (HasGenRequest a) =>
Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
serverDoesntSatisfy api burl args preds = do
let reqs = ($ burl) <$> genRequest api
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
v <- run $ finishPredicates preds (noCheckStatus req) defManager
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"
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
noCheckStatus :: Request -> Request
noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
defManager :: Manager
defManager = unsafePerformIO $ newManager defaultManagerSettings