From dbdb948934248ed4adb876a20e5104e3e9584611 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 23 Apr 2016 17:08:48 +0200 Subject: [PATCH] wip --- servant-quickcheck.cabal | 1 + src/Servant/QuickCheck.hs | 12 +++- src/Servant/QuickCheck/Internal/Predicates.hs | 60 ++++++++++++------- src/Servant/QuickCheck/Internal/QuickCheck.hs | 17 +++--- test/Servant/QuickCheck/InternalSpec.hs | 13 +++- 5 files changed, 69 insertions(+), 34 deletions(-) diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index d13072c..361ccb2 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -57,6 +57,7 @@ library , DeriveGeneric , ScopedTypeVariables , OverloadedStrings + , FunctionalDependencies default-language: Haskell2010 test-suite spec diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index 7fe22e6..1dadda1 100644 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -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(..) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index bcc0258..6869454 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -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 ] diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 476c467..ad45d56 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -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" diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 042a86b..bad7836 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -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