More predicates work

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

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

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 Text b Bool
-not500
+not500 = ResponsePredicate "not500" (\resp -> responseStatus resp == status500)
-  = ResponsePredicate "not500" _
 
+{-
 -- | 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
+data ResponsePredicate n b r = ResponsePredicate
-  = ResponsePredicate String (Response b -> IO r)
+  { respPredName :: n
-  | RequestPredicate String (Request -> [Response b -> IO r] -> IO r)
+  , respPred :: Response b -> r
-  deriving (Generic)
+  } 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)

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,
+import           Servant.Client           (BaseUrl (..), Scheme (..) )
-                                           Scheme (..), ServantError, client)
+import           Test.Hspec               (Expectation, expectationFailure)
-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           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 #-}
-

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