{-# 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
withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
-> (BaseUrl -> IO r) -> IO r
withServantServer :: forall a r.
HasServer a '[] =>
Proxy a -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
withServantServer Proxy a
api = Proxy a
-> Context '[]
-> IO (ServerT a Handler)
-> (BaseUrl -> IO r)
-> IO r
forall a (ctx :: [*]) r.
(HasServer a ctx,
HasContextEntry
(ctx .++ DefaultErrorFormatters) ErrorFormatters) =>
Proxy a
-> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
withServantServerAndContext Proxy a
api Context '[]
EmptyContext
#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 :: forall a (ctx :: [*]) r.
(HasServer a ctx,
HasContextEntry
(ctx .++ DefaultErrorFormatters) ErrorFormatters) =>
Proxy a
-> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
withServantServerAndContext Proxy a
api Context ctx
ctx IO (Server a)
server BaseUrl -> IO r
t
= IO Application -> (Port -> IO r) -> IO r
forall a. IO Application -> (Port -> IO a) -> IO a
withApplication (Proxy a -> Context ctx -> Server a -> Application
forall {k} (api :: k) (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext Proxy a
api Context ctx
ctx (Server a -> Application) -> IO (Server a) -> IO Application
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Server a)
server) ((Port -> IO r) -> IO r) -> (Port -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Port
port ->
BaseUrl -> IO r
t (Scheme -> String -> Port -> String -> BaseUrl
BaseUrl Scheme
Http String
"localhost" Port
port String
"")
serversEqual :: HasGenRequest a =>
Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
serversEqual :: forall a.
HasGenRequest a =>
Proxy a
-> BaseUrl
-> BaseUrl
-> Args
-> ResponseEquality ByteString
-> Expectation
serversEqual Proxy a
api BaseUrl
burl1 BaseUrl
burl2 Args
args ResponseEquality ByteString
req = do
let reqs :: Gen (Request, Request)
reqs = (\BaseUrl -> Request
f -> (BaseUrl -> Request
f BaseUrl
burl1, BaseUrl -> Request
f BaseUrl
burl2)) ((BaseUrl -> Request) -> (Request, Request))
-> Gen (BaseUrl -> Request) -> Gen (Request, Request)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Gen (BaseUrl -> Request)
forall {k} (a :: k).
HasGenRequest a =>
Proxy a -> Gen (BaseUrl -> Request)
runGenRequest Proxy a
api
MVar ServerEqualityFailure
deetsMVar <- IO (MVar ServerEqualityFailure)
forall a. IO (MVar a)
newEmptyMVar
Result
r <- Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
args { chatty = False } (Property -> IO Result) -> Property -> IO Result
forall a b. (a -> b) -> a -> b
$ PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ Gen (Request, Request)
-> ((Request, Request) -> PropertyM IO ()) -> PropertyM IO ()
forall (m :: * -> *) a b.
(Monad m, Show a) =>
Gen a -> (a -> PropertyM m b) -> PropertyM m b
forAllM Gen (Request, Request)
reqs (((Request, Request) -> PropertyM IO ()) -> PropertyM IO ())
-> ((Request, Request) -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \(Request
req1, Request
req2) -> do
Response ByteString
resp1 <- IO (Response ByteString) -> PropertyM IO (Response ByteString)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Response ByteString) -> PropertyM IO (Response ByteString))
-> IO (Response ByteString) -> PropertyM IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
C.httpLbs (Request -> Request
noCheckStatus Request
req1) Manager
defManager
Response ByteString
resp2 <- IO (Response ByteString) -> PropertyM IO (Response ByteString)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Response ByteString) -> PropertyM IO (Response ByteString))
-> IO (Response ByteString) -> PropertyM IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
C.httpLbs (Request -> Request
noCheckStatus Request
req2) Manager
defManager
Bool -> PropertyM IO () -> PropertyM IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ResponseEquality ByteString
-> Response ByteString -> Response ByteString -> Bool
forall b. ResponseEquality b -> Response b -> Response b -> Bool
getResponseEquality ResponseEquality ByteString
req Response ByteString
resp1 Response ByteString
resp2) (PropertyM IO () -> PropertyM IO ())
-> PropertyM IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ do
(Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"hi" )
Bool
_ <- IO Bool -> PropertyM IO Bool
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Bool -> PropertyM IO Bool) -> IO Bool -> PropertyM IO Bool
forall a b. (a -> b) -> a -> b
$ MVar ServerEqualityFailure -> ServerEqualityFailure -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ServerEqualityFailure
deetsMVar (ServerEqualityFailure -> IO Bool)
-> ServerEqualityFailure -> IO Bool
forall a b. (a -> b) -> a -> b
$ Request
-> Response ByteString
-> Response ByteString
-> ServerEqualityFailure
ServerEqualityFailure Request
req1 Response ByteString
resp1 Response ByteString
resp2
Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert Bool
False
case Result
r of
Success {} -> () -> Expectation
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Failure {} -> do
Maybe ServerEqualityFailure
mx <- MVar ServerEqualityFailure -> IO (Maybe ServerEqualityFailure)
forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar ServerEqualityFailure
deetsMVar
case Maybe ServerEqualityFailure
mx of
Just ServerEqualityFailure
x ->
HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ServerEqualityFailure -> String
forall a. Show a => a -> String
show ServerEqualityFailure
x
Maybe ServerEqualityFailure
Nothing ->
HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"We failed to record a reason for failure: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Result -> String
forall a. Show a => a -> String
show Result
r
GaveUp { numTests :: Result -> Port
numTests = Port
n } -> HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Gave up after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Port -> String
forall a. Show a => a -> String
show Port
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests"
NoExpectedFailure {} -> HasCallStack => String -> Expectation
String -> Expectation
expectationFailure String
"No expected failure"
#if MIN_VERSION_QuickCheck(2,12,0)
#else
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
#endif
serverSatisfies :: (HasGenRequest a) =>
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
serverSatisfies :: forall a.
HasGenRequest a =>
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
serverSatisfies Proxy a
api = Proxy a -> Manager -> BaseUrl -> Args -> Predicates -> Expectation
forall a.
HasGenRequest a =>
Proxy a -> Manager -> BaseUrl -> Args -> Predicates -> Expectation
serverSatisfiesMgr Proxy a
api Manager
defManager
serverSatisfiesMgr :: (HasGenRequest a) =>
Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
serverSatisfiesMgr :: forall a.
HasGenRequest a =>
Proxy a -> Manager -> BaseUrl -> Args -> Predicates -> Expectation
serverSatisfiesMgr Proxy a
api Manager
manager BaseUrl
burl Args
args Predicates
preds = do
let reqs :: Gen Request
reqs = ((BaseUrl -> Request) -> BaseUrl -> Request
forall a b. (a -> b) -> a -> b
$ BaseUrl
burl) ((BaseUrl -> Request) -> Request)
-> Gen (BaseUrl -> Request) -> Gen Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Gen (BaseUrl -> Request)
forall {k} (a :: k).
HasGenRequest a =>
Proxy a -> Gen (BaseUrl -> Request)
runGenRequest Proxy a
api
MVar (Maybe PredicateFailure)
deetsMVar <- IO (MVar (Maybe PredicateFailure))
forall a. IO (MVar a)
newEmptyMVar
Result
r <- Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
args { chatty = False } (Property -> IO Result) -> Property -> IO Result
forall a b. (a -> b) -> a -> b
$ PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ Gen Request -> (Request -> PropertyM IO ()) -> PropertyM IO ()
forall (m :: * -> *) a b.
(Monad m, Show a) =>
Gen a -> (a -> PropertyM m b) -> PropertyM m b
forAllM Gen Request
reqs ((Request -> PropertyM IO ()) -> PropertyM IO ())
-> (Request -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \Request
req -> do
Maybe PredicateFailure
v <- IO (Maybe PredicateFailure)
-> PropertyM IO (Maybe PredicateFailure)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Maybe PredicateFailure)
-> PropertyM IO (Maybe PredicateFailure))
-> IO (Maybe PredicateFailure)
-> PropertyM IO (Maybe PredicateFailure)
forall a b. (a -> b) -> a -> b
$ Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
finishPredicates Predicates
preds (Request -> Request
noCheckStatus Request
req) Manager
manager
Bool
_ <- IO Bool -> PropertyM IO Bool
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Bool -> PropertyM IO Bool) -> IO Bool -> PropertyM IO Bool
forall a b. (a -> b) -> a -> b
$ MVar (Maybe PredicateFailure) -> Maybe PredicateFailure -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (Maybe PredicateFailure)
deetsMVar Maybe PredicateFailure
v
case Maybe PredicateFailure
v of
Just PredicateFailure
_ -> Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert Bool
False
Maybe PredicateFailure
_ -> () -> PropertyM IO ()
forall a. a -> PropertyM IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case Result
r of
Success {} -> () -> Expectation
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Failure {} -> do
Maybe (Maybe PredicateFailure)
mx <- MVar (Maybe PredicateFailure)
-> IO (Maybe (Maybe PredicateFailure))
forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar (Maybe PredicateFailure)
deetsMVar
case Maybe (Maybe PredicateFailure)
mx of
Just Maybe PredicateFailure
x ->
HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe PredicateFailure -> String
forall a. Show a => a -> String
show Maybe PredicateFailure
x
Maybe (Maybe PredicateFailure)
Nothing ->
HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"We failed to record a reason for failure: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Result -> String
forall a. Show a => a -> String
show Result
r
GaveUp { numTests :: Result -> Port
numTests = Port
n } -> HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Gave up after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Port -> String
forall a. Show a => a -> String
show Port
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests"
NoExpectedFailure {} -> HasCallStack => String -> Expectation
String -> Expectation
expectationFailure String
"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 :: forall a.
HasGenRequest a =>
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
serverDoesntSatisfy Proxy a
api = Proxy a -> Manager -> BaseUrl -> Args -> Predicates -> Expectation
forall a.
HasGenRequest a =>
Proxy a -> Manager -> BaseUrl -> Args -> Predicates -> Expectation
serverDoesntSatisfyMgr Proxy a
api Manager
defManager
serverDoesntSatisfyMgr :: (HasGenRequest a) =>
Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
serverDoesntSatisfyMgr :: forall a.
HasGenRequest a =>
Proxy a -> Manager -> BaseUrl -> Args -> Predicates -> Expectation
serverDoesntSatisfyMgr Proxy a
api Manager
manager BaseUrl
burl Args
args Predicates
preds = do
let reqs :: Gen Request
reqs = ((BaseUrl -> Request) -> BaseUrl -> Request
forall a b. (a -> b) -> a -> b
$ BaseUrl
burl) ((BaseUrl -> Request) -> Request)
-> Gen (BaseUrl -> Request) -> Gen Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Gen (BaseUrl -> Request)
forall {k} (a :: k).
HasGenRequest a =>
Proxy a -> Gen (BaseUrl -> Request)
runGenRequest Proxy a
api
Result
r <- Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
args (Property -> IO Result) -> Property -> IO Result
forall a b. (a -> b) -> a -> b
$ PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ Gen Request -> (Request -> PropertyM IO ()) -> PropertyM IO ()
forall (m :: * -> *) a b.
(Monad m, Show a) =>
Gen a -> (a -> PropertyM m b) -> PropertyM m b
forAllM Gen Request
reqs ((Request -> PropertyM IO ()) -> PropertyM IO ())
-> (Request -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \Request
req -> do
Maybe PredicateFailure
v <- IO (Maybe PredicateFailure)
-> PropertyM IO (Maybe PredicateFailure)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Maybe PredicateFailure)
-> PropertyM IO (Maybe PredicateFailure))
-> IO (Maybe PredicateFailure)
-> PropertyM IO (Maybe PredicateFailure)
forall a b. (a -> b) -> a -> b
$ Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
finishPredicates Predicates
preds (Request -> Request
noCheckStatus Request
req) Manager
manager
Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe PredicateFailure -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe PredicateFailure
v
case Result
r of
Success {} -> () -> Expectation
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
GaveUp { numTests :: Result -> Port
numTests = Port
n } -> HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Gave up after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Port -> String
forall a. Show a => a -> String
show Port
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests"
Failure { output :: Result -> String
output = String
m } -> HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
m
NoExpectedFailure {} -> HasCallStack => String -> Expectation
String -> Expectation
expectationFailure String
"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 :: Request -> Request
noCheckStatus = Request -> Request
forall a. a -> a
id
#else
noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
#endif
defManager :: C.Manager
defManager :: Manager
defManager = IO Manager -> Manager
forall a. IO a -> a
unsafePerformIO (IO Manager -> Manager) -> IO Manager -> Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
C.newManager ManagerSettings
C.defaultManagerSettings
{-# NOINLINE defManager #-}