wip

servant-quickcheck.cabal

@@ -57,6 +57,7 @@ library
                      , DeriveGeneric
                      , ScopedTypeVariables
                      , OverloadedStrings
+                     , FunctionalDependencies
   default-language:    Haskell2010
 
 test-suite spec

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(..)

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 ]

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"

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