From d62753b2c59765bbdd59e5f50ca2fbc68204ccff Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 23 Apr 2016 14:20:31 +0200 Subject: [PATCH] More predicates work --- servant-quickcheck.cabal | 1 + src/Servant/QuickCheck.hs | 6 ++ src/Servant/QuickCheck/Internal/Predicates.hs | 63 ++++++++++++++++--- src/Servant/QuickCheck/Internal/QuickCheck.hs | 30 +++++---- test/Servant/QuickCheck/InternalSpec.hs | 8 +-- 5 files changed, 80 insertions(+), 28 deletions(-) diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index da03b53..d13072c 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -42,6 +42,7 @@ library , process == 1.2.* , temporary == 1.2.* , hspec + , text == 1.* hs-source-dirs: src default-extensions: TypeOperators , FlexibleInstances diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index 8fe6749..7fe22e6 100644 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -24,10 +24,16 @@ module Servant.QuickCheck -- | Helpers to setup and teardown @servant@ servers during tests. , withServantServer + -- * Response equality + , bodyEquality + , allEquality + , ResponseEquality(getResponseEquality) + -- ** Re-exports , BaseUrl(..) , Scheme(..) + ) where import Servant.QuickCheck.Internal diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index f018545..bcc0258 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -3,18 +3,19 @@ module Servant.QuickCheck.Internal.Predicates where import Data.Monoid ((<>)) import GHC.Generics (Generic) import Control.Monad -import Network.HTTP.Client (Request, Response) +import Network.HTTP.Client (Request, Response, responseStatus) +import Network.HTTP.Types (status500) +import Data.Text (Text) -{- -- | @500 Internal Server Error@ should be avoided - it may represent some -- issue with the application code, and it moreover gives the client little -- indication of how to proceed or what went wrong. -- -- This function checks that the response code is not 500. -not500 :: Response b -> IO Bool -not500 - = ResponsePredicate "not500" _ +not500 :: ResponsePredicate Text b Bool +not500 = ResponsePredicate "not500" (\resp -> responseStatus resp == status500) +{- -- | Returning anything other than an object when returning JSON is considered -- bad practice, as: -- @@ -143,7 +144,51 @@ unauthorizedContainsWWWAuthenticate = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _ -} -data Predicate b r - = ResponsePredicate String (Response b -> IO r) - | RequestPredicate String (Request -> [Response b -> IO r] -> IO r) - deriving (Generic) +data ResponsePredicate n b r = ResponsePredicate + { respPredName :: n + , respPred :: Response b -> r + } deriving (Functor, Generic) + +instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n b 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 + { reqPredName :: n + , reqPred :: Request -> ResponsePredicate n b r -> IO r + } deriving (Generic) + +instance (Monoid n, Monoid r) => Monoid (RequestPredicate n b r) where + mempty = RequestPredicate mempty (\_ _ -> return mempty) + a `mappend` b = RequestPredicate + { reqPredName = reqPredName a <> reqPredName b + , reqPred = \x y -> liftM2 (<>) (reqPred a x y) (reqPred b x y) + } + +data Predicates n b r = Predicates + { reqPreds :: RequestPredicate n b r + , respPreds :: ResponsePredicate n b r + } deriving (Generic) + +instance (Monoid n, Monoid r) => Monoid (Predicates n b 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 + joinPreds p (Predicates x y) = Predicates (p <> x) y + +instance (Monoid n, Monoid r) => JoinPreds (ResponsePredicate n b r) n b r 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) diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index f550ba3..476c467 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -1,23 +1,13 @@ -- | This module contains wrappers around lower-level functionality. module Servant.QuickCheck.Internal.QuickCheck where -import Control.Concurrent (threadDelay) -import Control.Concurrent.MVar (modifyMVar_, readMVar) -import Control.Monad (replicateM_) import Data.Proxy (Proxy) -import Data.Void (Void) import Network.HTTP.Client (Manager, defaultManagerSettings, newManager, httpLbs) -import Network.HTTP.Client (managerModifyRequest, getUri) import Network.Wai.Handler.Warp (withApplication) import Servant (HasServer, Server, serve) -import Servant.Client (BaseUrl (..), Client, HasClient, - Scheme (..), ServantError, client) -import System.IO (hPutStrLn, hFlush) -import System.IO.Temp (withSystemTempFile) -import System.Mem (performGC) -import System.Process (callCommand) -import Test.Hspec (Expectation, expectationFailure, shouldBe) +import Servant.Client (BaseUrl (..), Scheme (..) ) +import Test.Hspec (Expectation, expectationFailure) import Test.QuickCheck (Args (..), Property, forAll, Result (..), Testable, property, ioProperty, quickCheckWithResult, stdArgs) @@ -65,7 +55,21 @@ 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 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 + 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" + + defManager :: Manager defManager = unsafePerformIO $ newManager defaultManagerSettings {-# NOINLINE defManager #-} - diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 5ec7ada..042a86b 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -4,16 +4,12 @@ module Servant.QuickCheck.InternalSpec (spec) where import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) import Control.Monad.IO.Class (liftIO) -import Control.Monad (void) -import Network.HTTP.Client (newManager, defaultManagerSettings) import Data.Proxy import Servant import Test.Hspec import Test.QuickCheck -import Test.QuickCheck.IO -import Test.QuickCheck.Monadic -import Servant.QuickCheck.Internal +import Servant.QuickCheck spec :: Spec spec = do @@ -25,7 +21,7 @@ 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 = 10000 } bodyEquality + serversEqual api burl1 burl2 stdArgs { maxSuccess = noOfTestCases } bodyEquality