mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-08-16 22:00:32 +03:00
wip
This commit is contained in:
parent
d62753b2c5
commit
dbdb948934
@ -57,6 +57,7 @@ library
|
||||
, DeriveGeneric
|
||||
, ScopedTypeVariables
|
||||
, OverloadedStrings
|
||||
, FunctionalDependencies
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite spec
|
||||
|
@ -19,16 +19,24 @@
|
||||
module Servant.QuickCheck
|
||||
(
|
||||
|
||||
serversEqual
|
||||
|
||||
-- * Test setup helpers
|
||||
-- | Helpers to setup and teardown @servant@ servers during tests.
|
||||
, withServantServer
|
||||
withServantServer
|
||||
|
||||
, serversEqual
|
||||
, serverSatisfies
|
||||
|
||||
-- * Response equality
|
||||
, bodyEquality
|
||||
, allEquality
|
||||
, ResponseEquality(getResponseEquality)
|
||||
|
||||
-- * Predicates
|
||||
, (<%>)
|
||||
, Predicates
|
||||
, not500
|
||||
|
||||
-- ** Re-exports
|
||||
, BaseUrl(..)
|
||||
, Scheme(..)
|
||||
|
@ -5,6 +5,7 @@ import GHC.Generics (Generic)
|
||||
import Control.Monad
|
||||
import Network.HTTP.Client (Request, Response, responseStatus)
|
||||
import Network.HTTP.Types (status500)
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Text (Text)
|
||||
|
||||
-- | @500 Internal Server Error@ should be avoided - it may represent some
|
||||
@ -12,8 +13,9 @@ import Data.Text (Text)
|
||||
-- indication of how to proceed or what went wrong.
|
||||
--
|
||||
-- This function checks that the response code is not 500.
|
||||
not500 :: ResponsePredicate Text b Bool
|
||||
not500 = ResponsePredicate "not500" (\resp -> responseStatus resp == status500)
|
||||
not500 :: ResponsePredicate Text [Text]
|
||||
not500 = ResponsePredicate "not500" (\resp ->
|
||||
if responseStatus resp == status500 then ["not500"] else [])
|
||||
|
||||
{-
|
||||
-- | Returning anything other than an object when returning JSON is considered
|
||||
@ -143,52 +145,66 @@ unauthorizedContainsWWWAuthenticate :: Predicate b Bool
|
||||
unauthorizedContainsWWWAuthenticate
|
||||
= ResponsePredicate "unauthorizedContainsWWWAuthenticate" _
|
||||
-}
|
||||
-- * Predicate logic
|
||||
|
||||
data ResponsePredicate n b r = ResponsePredicate
|
||||
-- The idea with all this footwork is to not waste any requests. Rather than
|
||||
-- generating new requests and only applying one predicate to the response, we
|
||||
-- apply as many predicates as possible.
|
||||
--
|
||||
-- Still, this is all kind of ugly.
|
||||
|
||||
data ResponsePredicate n r = ResponsePredicate
|
||||
{ respPredName :: n
|
||||
, respPred :: Response b -> r
|
||||
, respPred :: Response LBS.ByteString -> r
|
||||
} deriving (Functor, Generic)
|
||||
|
||||
instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n b r) where
|
||||
instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
|
||||
mempty = ResponsePredicate mempty mempty
|
||||
a `mappend` b = ResponsePredicate
|
||||
{ respPredName = respPredName a <> respPredName b
|
||||
, respPred = respPred a <> respPred b
|
||||
}
|
||||
|
||||
data RequestPredicate n b r = RequestPredicate
|
||||
data RequestPredicate n r = RequestPredicate
|
||||
{ reqPredName :: n
|
||||
, reqPred :: Request -> ResponsePredicate n b r -> IO r
|
||||
} deriving (Generic)
|
||||
, reqResps :: Request -> IO [Response LBS.ByteString]
|
||||
, reqPred :: ResponsePredicate n r
|
||||
} deriving (Generic, Functor)
|
||||
|
||||
instance (Monoid n, Monoid r) => Monoid (RequestPredicate n b r) where
|
||||
mempty = RequestPredicate mempty (\_ _ -> return mempty)
|
||||
instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
|
||||
mempty = RequestPredicate mempty (\_ -> return mempty) mempty
|
||||
a `mappend` b = RequestPredicate
|
||||
{ reqPredName = reqPredName a <> reqPredName b
|
||||
, reqPred = \x y -> liftM2 (<>) (reqPred a x y) (reqPred b x y)
|
||||
, reqResps = \x -> liftM2 (<>) (reqResps a x) (reqResps b x)
|
||||
, reqPred = reqPred a <> reqPred b
|
||||
}
|
||||
|
||||
data Predicates n b r = Predicates
|
||||
{ reqPreds :: RequestPredicate n b r
|
||||
, respPreds :: ResponsePredicate n b r
|
||||
} deriving (Generic)
|
||||
data Predicates n r = Predicates
|
||||
{ reqPreds :: RequestPredicate n r
|
||||
, respPreds :: ResponsePredicate n r
|
||||
} deriving (Generic, Functor)
|
||||
|
||||
instance (Monoid n, Monoid r) => Monoid (Predicates n b r) where
|
||||
instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
|
||||
mempty = Predicates mempty mempty
|
||||
a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
|
||||
|
||||
class JoinPreds a n b r where
|
||||
joinPreds :: a -> Predicates n b r -> Predicates n b r
|
||||
|
||||
instance (Monoid n, Monoid r) => JoinPreds (RequestPredicate n b r) n b r where
|
||||
|
||||
class JoinPreds a where
|
||||
joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
|
||||
|
||||
instance JoinPreds (RequestPredicate Text Bool) where
|
||||
joinPreds p (Predicates x y) = Predicates (p <> x) y
|
||||
|
||||
instance (Monoid n, Monoid r) => JoinPreds (ResponsePredicate n b r) n b r where
|
||||
instance JoinPreds (ResponsePredicate Text Bool) where
|
||||
joinPreds p (Predicates x y) = Predicates x (p <> y)
|
||||
|
||||
infixr 6 <%>
|
||||
(<%>) :: JoinPreds a n b r => a -> Predicates n b r -> Predicates n b r
|
||||
(<%>) = joinPreds
|
||||
|
||||
finishPredicates :: (Monoid r) => Predicates n b r -> Request -> IO r
|
||||
finishPredicates p req = (reqPred $ reqPreds p) req (respPreds p)
|
||||
finishPredicates :: Predicates [Text] [Text] -> Request -> IO [Text]
|
||||
finishPredicates p req = do
|
||||
resps <- reqResps (reqPreds p) req
|
||||
let preds = reqPred (reqPreds p) <> respPreds p
|
||||
return $ mconcat [respPred preds r | r <- resps ]
|
||||
|
@ -8,16 +8,15 @@ import Network.Wai.Handler.Warp (withApplication)
|
||||
import Servant (HasServer, Server, serve)
|
||||
import Servant.Client (BaseUrl (..), Scheme (..) )
|
||||
import Test.Hspec (Expectation, expectationFailure)
|
||||
import Test.QuickCheck (Args (..), Property, forAll, Result (..),
|
||||
Testable, property, ioProperty,
|
||||
quickCheckWithResult, stdArgs)
|
||||
import Test.QuickCheck (Args (..), Result (..),
|
||||
quickCheckWithResult)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.QuickCheck.Monadic
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Text (Text)
|
||||
|
||||
import Servant.QuickCheck.Internal.HasGenRequest
|
||||
import Servant.QuickCheck.Internal.Predicates
|
||||
import Servant.QuickCheck.Internal.Benchmarking
|
||||
import Servant.QuickCheck.Internal.Equality
|
||||
|
||||
|
||||
@ -41,7 +40,7 @@ withServantServer api server t
|
||||
-- Evidently, if the behaviour of the server is expected to be
|
||||
-- non-deterministic, this function may produce spurious failures
|
||||
serversEqual :: HasGenRequest a =>
|
||||
Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality BSL.ByteString -> Expectation
|
||||
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
|
||||
@ -55,13 +54,13 @@ serversEqual api burl1 burl2 args req = do
|
||||
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
||||
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
|
||||
|
||||
serverSatisfies :: HasGenRequest a =>
|
||||
Proxy a -> BaseUrl -> Args -> Predicates n b Bool -> Expectation
|
||||
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 req
|
||||
assert v
|
||||
assert $ null v
|
||||
case r of
|
||||
Success {} -> return ()
|
||||
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
||||
|
@ -14,6 +14,7 @@ import Servant.QuickCheck
|
||||
spec :: Spec
|
||||
spec = do
|
||||
serversEqualSpec
|
||||
serverSatisfiesSpec
|
||||
|
||||
serversEqualSpec :: Spec
|
||||
serversEqualSpec = describe "serversEqual" $ do
|
||||
@ -21,9 +22,16 @@ serversEqualSpec = describe "serversEqual" $ do
|
||||
it "considers equal servers equal" $ do
|
||||
withServantServer api server $ \burl1 ->
|
||||
withServantServer api server $ \burl2 -> do
|
||||
serversEqual api burl1 burl2 stdArgs { maxSuccess = noOfTestCases } bodyEquality
|
||||
serversEqual api burl1 burl2 args bodyEquality
|
||||
|
||||
|
||||
serverSatisfiesSpec :: Spec
|
||||
serverSatisfiesSpec = describe "serverSatisfies" $ do
|
||||
|
||||
it "succeeds for true predicates" $ do
|
||||
withServantServer api server $ \burl ->
|
||||
serverSatisfies api burl args (not500 <%> mempty)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- APIs
|
||||
@ -46,6 +54,9 @@ server = do
|
||||
-- Utils
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
args :: Args
|
||||
args = stdArgs { maxSuccess = noOfTestCases }
|
||||
|
||||
noOfTestCases :: Int
|
||||
#if LONG_TESTS
|
||||
noOfTestCases = 20000
|
||||
|
Loading…
Reference in New Issue
Block a user