Much better errors

src/Servant/QuickCheck/Internal/ErrorTypes.hs

@@ -1,40 +1,72 @@
 module Servant.QuickCheck.Internal.ErrorTypes where
 
-import Text.PrettyPrint
+import           Control.Exception       (Exception (..))
-import Prelude.Compat
+import qualified Data.ByteString.Lazy    as LBS
-import Data.String (IsString(fromString))
+import           Data.String.Conversions (cs)
-import GHC.Generics (Generic)
+import qualified Data.Text               as T
+import           GHC.Generics            (Generic)
+import qualified Network.HTTP.Client     as C
+import           Network.HTTP.Types      (Header, statusCode)
+import           Prelude.Compat
+import           Text.PrettyPrint
 
-data Request = Request
+prettyHeaders :: [Header] -> Doc
-  { requestBody    :: String
+prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs
-  , requestHeaders :: [String]
+  where
-  , requestUrl     :: String
+    prettyHdr (hn, h) = text (show hn) <> colon <+>  text (show h)
-  } deriving (Eq, Show, Read, Generic)
 
-prettyReq :: Request -> Doc
+prettyReq :: C.Request -> Doc
 prettyReq r =
   text "Request:" $$ (nest 5 $
-     text "URL:"      <+> (nest 5 $ text $ requestUrl r)
+     text "Method:"   <+> (nest 5 $ text . show $ C.method r)
-  $$ text "Headers:"  <+> (nest 5 $ hsep $ text <$> requestHeaders r)
+  $$ text "Path:"     <+> (nest 5 $ text . cs $ C.path r)
-  $$ text "Body:"     <+> (nest 5 $ text $ requestBody r))
+  $$ text "Headers:"  <+> (nest 5 $ prettyHeaders $ C.requestHeaders r)
+  $$ text "Body:"     <+> (nest 5 $ text . getReqBody $ C.requestBody r))
+  where
+    getReqBody (C.RequestBodyLBS lbs ) = cs lbs
+    getReqBody (C.RequestBodyBS bs ) = cs bs
+    getReqBody _ = error "expected bytestring body"
 
-instance IsString Request where
+prettyResp :: C.Response LBS.ByteString -> Doc
-  fromString url = Request "" [] url
+prettyResp r =
+  text "Response:" $$ (nest 5 $
+     text "Status code:" <+> (nest 5 $ text . show . statusCode $ C.responseStatus r)
+  $$ text "Headers:"  $$ (nest 10 $ prettyHeaders $ C.responseHeaders r)
+  $$ text "Body:"     <+> (nest 5 $ text . cs $ C.responseBody r))
 
-data Response = Response
-  { responseBody    :: String
-  , responseHeaders :: [String]
-  } deriving (Eq, Show, Read, Generic)
-
-instance IsString Response where
-  fromString body = Response body []
 
 -- The error that occurred.
-data Failure
+data PredicateFailure = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
-  = PredicateFailure String Request Response
+  deriving (Generic)
-  | ServerEqualityFailure Request Response Response
-  deriving (Eq, Read, Generic)
 
-instance Show Failure where
+data ServerEqualityFailure = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)
-  show (PredicateFailure pred req resp)
+  deriving (Generic)
-    = "Predicate failed for " ++ pred
+
+prettyServerEqualityFailure :: ServerEqualityFailure -> Doc
+prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =
+  text "Server equality failed" $$ (nest 5 $
+     prettyReq req
+  $$ prettyResp resp1
+  $$ prettyResp resp2)
+
+
+prettyPredicateFailure :: PredicateFailure -> Doc
+prettyPredicateFailure (PredicateFailure predicate req resp) =
+  text "Predicate failed" $$ (nest 5 $
+     text "Predicate:" <+> (text $ T.unpack predicate)
+  $$ r
+  $$ prettyResp resp)
+  where
+    r = case req of
+      Nothing -> text ""
+      Just v  -> prettyReq v
+
+instance Show ServerEqualityFailure where
+  show = render . prettyServerEqualityFailure
+
+instance Exception ServerEqualityFailure where
+
+instance Show PredicateFailure where
+  show = render . prettyPredicateFailure
+
+instance Exception PredicateFailure where

src/Servant/QuickCheck/Internal/Predicates.hs

@@ -1,6 +1,8 @@
 module Servant.QuickCheck.Internal.Predicates where
 
-import           Control.Monad         (liftM2)
+import Control.Exception (catch, SomeException, throw)
+import           Control.Monad         (liftM2, guard, ap)
+import           Control.Monad.Reader
 import           Data.Aeson            (Object, decode)
 import           Data.Bifunctor        (Bifunctor (..))
 import           Prelude.Compat
@@ -24,6 +26,9 @@ import           Network.HTTP.Types    (methodGet, methodHead, parseMethod,
                                         status300, status401, status405,
                                         status500, status100)
 
+import Servant.QuickCheck.Internal.ErrorTypes
+
+
 -- | [__Best Practice__]
 --
 -- @500 Internal Server Error@ should be avoided - it may represent some
@@ -33,8 +38,9 @@ import           Network.HTTP.Types    (methodGet, methodHead, parseMethod,
 -- This function checks that the response code is not 500.
 --
 -- /Since 0.0.0.0/
-not500 :: ResponsePredicate Text Bool
+not500 :: ResponsePredicate
-not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
+not500 = ResponsePredicate $ \resp ->
+  when (responseStatus resp == status500) $ fail "not500"
 
 -- | [__Best Practice__]
 --
@@ -57,11 +63,11 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu
 --   * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
 --
 -- /Since 0.0.0.0/
-onlyJsonObjects :: ResponsePredicate Text Bool
+onlyJsonObjects :: ResponsePredicate
 onlyJsonObjects
-  = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
+  = ResponsePredicate (\resp -> case decode (responseBody resp) of
-      Nothing -> False
+      Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
-      Just (_ :: Object) -> True)
+      Just (_ :: Object) -> return ())
 
 -- | __Optional__
 --
@@ -82,25 +88,24 @@ onlyJsonObjects
 --   * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
 --
 -- /Since 0.0.0.0/
-createContainsValidLocation :: RequestPredicate Text Bool
+createContainsValidLocation :: RequestPredicate
 createContainsValidLocation
-  = RequestPredicate
+  = RequestPredicate $ \req mgr -> do
-    { reqPredName = "createContainsValidLocation"
+     let n = "createContainsValidLocation"
-    , reqResps = \req mgr -> do
+     resp <- httpLbs req mgr
-        resp <- httpLbs req mgr
+     if responseStatus resp == status201
-        if responseStatus resp == status201
+         then case lookup "Location" $ responseHeaders resp of
-            then case lookup "Location" $ responseHeaders resp of
+             Nothing -> fail n
-                Nothing -> return (False, [resp])
+             Just l  -> case parseUrl $ SBSC.unpack l of
-                Just l  -> case parseUrl $ SBSC.unpack l of
+               Nothing -> fail n
-                  Nothing -> return (False, [resp])
+               Just x  -> do
-                  Just x  -> do
+                 resp2 <- httpLbs x mgr
-                    resp2 <- httpLbs x mgr
+                 status2XX resp2 n
-                    return (status2XX resp2, [resp, resp2])
+                 return [resp, resp2]
-            else return (True, [resp])
+         else return [resp]
-    }
 
 {-
-getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
+getsHaveLastModifiedHeader :: ResponsePredicate
 getsHaveLastModifiedHeader
   = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
 
@@ -122,18 +127,17 @@ getsHaveLastModifiedHeader
 --   * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
 --
 -- /Since 0.0.0.0/
-notAllowedContainsAllowHeader :: RequestPredicate Text Bool
+notAllowedContainsAllowHeader :: RequestPredicate
 notAllowedContainsAllowHeader
-  = RequestPredicate
+  = RequestPredicate $ \req mgr -> do
-    { reqPredName = "notAllowedContainsAllowHeader"
+      resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
-    , reqResps = \req mgr -> do
+                                        | m <- [minBound .. maxBound ]
-        resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
+                                        , renderStdMethod m /= method req ]
-                                          | m <- [minBound .. maxBound ]
+      case filter pred' resp of
-                                          , renderStdMethod m /= method req ]
+        (x:xs) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x
-        return (all pred' resp, resp)
+        []     -> return resp
-    }
     where
-      pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp
+      pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
         where
           go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
                $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -154,19 +158,19 @@ notAllowedContainsAllowHeader
 --   * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
 --
 -- /Since 0.0.0.0/
-honoursAcceptHeader :: RequestPredicate Text Bool
+honoursAcceptHeader :: RequestPredicate
 honoursAcceptHeader
-  = RequestPredicate
+  = RequestPredicate $ \req mgr -> do
-    { reqPredName = "honoursAcceptHeader"
+      resp <- httpLbs req mgr
-    , reqResps = \req mgr -> do
+      let scode = responseStatus resp
-        resp <- httpLbs req mgr
+          sctype = lookup "Content-Type" $ responseHeaders resp
-        let scode = responseStatus resp
+          sacc  = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
-            sctype = lookup "Content-Type" $ responseHeaders resp
+      if status100 < scode && scode < status300
-            sacc  = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
+        then if isJust $ sctype >>= \x -> matchAccept [x] sacc
-        if status100 < scode && scode < status300
+          then fail "honoursAcceptHeader"
-          then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])
+          else return [resp]
-          else return (True, [resp])
+        else return [resp]
-    }
+
 
 -- | [__Best Practice__]
 --
@@ -182,34 +186,32 @@ honoursAcceptHeader
 --   * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
 --
 -- /Since 0.0.0.0/
-getsHaveCacheControlHeader :: RequestPredicate Text Bool
+getsHaveCacheControlHeader :: RequestPredicate
 getsHaveCacheControlHeader
-  = RequestPredicate
+  = RequestPredicate $ \req mgr ->
-     { reqPredName = "getsHaveCacheControlHeader"
+     if (method req == methodGet)
-     , reqResps = \req mgr -> if method req == methodGet
+      then do
-        then do
+        resp <- httpLbs req mgr
-          resp <- httpLbs req mgr
+        unless (hasValidHeader "Cache-Control" (const True) resp) $ do
-          let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
+          throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp
-          return (good, [resp])
+        return [resp]
-        else return (True, [])
+      else return []
-     }
 
 -- | [__Best Practice__]
 --
 -- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
 --
 -- /Since 0.0.0.0/
-headsHaveCacheControlHeader :: RequestPredicate Text Bool
+headsHaveCacheControlHeader :: RequestPredicate
 headsHaveCacheControlHeader
-  = RequestPredicate
+  = RequestPredicate $ \req mgr ->
-     { reqPredName = "headsHaveCacheControlHeader"
+     if (method req == methodHead)
-     , reqResps = \req mgr -> if method req == methodHead
+       then do
-        then do
+         resp <- httpLbs req mgr
-          resp <- httpLbs req mgr
+         unless (hasValidHeader "Cache-Control" (const True) resp) $
-          let good = hasValidHeader "Cache-Control" (const True) resp
+           throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp
-          return (good, [resp])
+         return [resp]
-        else return (True, [])
+       else return []
-     }
 {-
 -- |
 --
@@ -271,12 +273,13 @@ linkHeadersAreValid
 --   * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
 --
 -- /Since 0.0.0.0/
-unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool
+unauthorizedContainsWWWAuthenticate :: ResponsePredicate
 unauthorizedContainsWWWAuthenticate
-  = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->
+  = ResponsePredicate $ \resp ->
       if responseStatus resp == status401
-        then hasValidHeader "WWW-Authenticate" (const True) resp
+        then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
-        else True)
+          fail "unauthorizedContainsWWWAuthenticate"
+        else return ()
 
 -- * Predicate logic
 
@@ -289,67 +292,46 @@ unauthorizedContainsWWWAuthenticate
 -- | A predicate that depends only on the response.
 --
 -- /Since 0.0.0.0/
-data ResponsePredicate n r = ResponsePredicate
+data ResponsePredicate = ResponsePredicate
-  { respPredName :: n
+  { getResponsePredicate :: Response LBS.ByteString -> IO ()
-  , respPred :: Response LBS.ByteString -> r
+  } deriving (Generic)
-  } deriving (Functor, Generic)
 
-instance Bifunctor ResponsePredicate where
+instance Monoid ResponsePredicate where
-  first f (ResponsePredicate a b) = ResponsePredicate (f a) b
+  mempty = ResponsePredicate $ const $ return ()
-  second = fmap
+  ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
-
-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
-    }
 
 -- | A predicate that depends on both the request and the response.
 --
 -- /Since 0.0.0.0/
-data RequestPredicate n r = RequestPredicate
+data RequestPredicate = RequestPredicate
-  { reqPredName :: n
+  { getRequestPredicate    :: Request -> Manager -> IO [Response LBS.ByteString]
-  , reqResps    :: Request -> Manager -> IO (r, [Response LBS.ByteString])
+  } deriving (Generic)
-  } deriving (Generic, Functor)
-
-instance Bifunctor RequestPredicate where
-  first f (RequestPredicate a b) = RequestPredicate (f a) b
-  second = fmap
 
 -- TODO: This isn't actually a monoid
-instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
+instance Monoid RequestPredicate where
-  mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))
+  mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
-  a `mappend` b = RequestPredicate
+  RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->
-    { reqPredName = reqPredName a <> reqPredName b
+    liftM2 (<>) (a r mgr) (b r mgr)
-    , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
-    }
 
 -- | A set of predicates. Construct one with 'mempty' and '<%>'.
-data Predicates n r = Predicates
+data Predicates = Predicates
-  { reqPreds :: RequestPredicate n r
+  { requestPredicates :: RequestPredicate
-  , respPreds :: ResponsePredicate n r
+  , responsePredicates :: ResponsePredicate
-  } deriving (Generic, Functor)
+  } deriving (Generic)
 
-instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
+instance Monoid Predicates where
   mempty = Predicates mempty mempty
-  a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
+  a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
-
+                             (responsePredicates a <> responsePredicates b)
-
 
 class JoinPreds a where
-  joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
+  joinPreds :: a -> Predicates -> Predicates
 
-instance JoinPreds (RequestPredicate Text Bool) where
+instance JoinPreds (RequestPredicate ) where
-  joinPreds p (Predicates x y) = Predicates (go <> x) y
+  joinPreds p (Predicates x y) = Predicates (p <> x) y
-    where go = let p' = first return p
-               in fmap (\z -> if z then [] else reqPredName p') p'
-
-instance JoinPreds (ResponsePredicate Text Bool) where
-  joinPreds p (Predicates x y) = Predicates x (go <> y)
-    where go = let p' = first return p
-               in fmap (\z -> if z then [] else respPredName p') p'
 
+instance JoinPreds (ResponsePredicate ) where
+  joinPreds p (Predicates x y) = Predicates x (p <> y)
 
 -- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
 -- the existing predicates.
@@ -357,14 +339,17 @@ instance JoinPreds (ResponsePredicate Text Bool) where
 -- > not500 <%> onlyJsonObjects <%> empty
 --
 -- /Since 0.0.0.0/
-(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
+(<%>) :: JoinPreds a => a -> Predicates -> Predicates
 (<%>) = joinPreds
 infixr 6 <%>
 
-finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
+finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
-finishPredicates p req mgr = do
+finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
-  (soFar, resps) <- reqResps (reqPreds p) req mgr
+  where
-  return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]
+    go = do
+     resps <- getRequestPredicate (requestPredicates p) req mgr
+     mapM_  (getResponsePredicate $ responsePredicates p) resps
+     return Nothing
 
 -- * helpers
 
@@ -373,5 +358,8 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
   Nothing -> False
   Just v  -> p v
 
-status2XX :: Response b -> Bool
+status2XX :: Monad m => Response b -> String -> m ()
-status2XX r = status200 <= responseStatus r && responseStatus r < status300
+status2XX r t
+  | status200 <= responseStatus r && responseStatus r < status300
+  = return ()
+  | otherwise = fail t

src/Servant/QuickCheck/Internal/QuickCheck.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
 module Servant.QuickCheck.Internal.QuickCheck where
 
 import qualified Data.ByteString.Lazy     as LBS
@@ -18,6 +19,7 @@ import           Test.QuickCheck          (Args (..), Result (..),
 import           Test.QuickCheck.Monadic  (assert, forAllM, monadicIO, run, monitor)
 import           Test.QuickCheck.Property (counterexample)
 import Control.Monad (unless)
+import Control.Concurrent (newMVar, modifyMVar_, readMVar)
 
 import Servant.QuickCheck.Internal.Equality
 import Servant.QuickCheck.Internal.HasGenRequest
@@ -60,17 +62,22 @@ serversEqual :: HasGenRequest a =>
   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
+  -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
+  -- return results when a test fails, since an exception is throw.
+  deetsMVar <- newMVar $ error "should not be called"
+  r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
     resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
     resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
     unless (getResponseEquality req resp1 resp2) $ do
       monitor (counterexample "hi" )
+      run $ modifyMVar_ deetsMVar $ const $ return $
+        ServerEqualityFailure req1 resp1 resp2
       assert False
-
   case r of
     Success {} -> return ()
+    f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
+      "Failed:\n" ++ show x
     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"
 
@@ -94,22 +101,27 @@ serversEqual api burl1 burl2 args req = do
 --
 -- /Since 0.0.0.0/
 serverSatisfies :: (HasGenRequest a) =>
-  Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
+  Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
 serverSatisfies api burl args preds = do
   let reqs = ($ burl) <$> genRequest api
-  r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
+  deetsMVar <- newMVar $ error "should not be called"
+  r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
      v <- run $ finishPredicates preds (noCheckStatus req) defManager
-     assert $ null v
+     run $ modifyMVar_ deetsMVar $ const $ return v
+     case v of
+       Just x -> assert False
+       _ -> return ()
   case r of
     Success {} -> return ()
+    f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
+      "Failed:\n" ++ show x
     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"
 
 
 serverDoesntSatisfy :: (HasGenRequest a) =>
-  Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
+  Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
 serverDoesntSatisfy api burl args preds = do
   let reqs = ($ burl) <$> genRequest api
   r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do

test/Servant/QuickCheck/InternalSpec.hs

@@ -1,28 +1,27 @@
 {-# LANGUAGE CPP #-}
 module Servant.QuickCheck.InternalSpec (spec) where
 
-import           Control.Concurrent.MVar                    (newMVar, readMVar,
+import Control.Concurrent.MVar                    (newMVar, readMVar, swapMVar)
-                                                             swapMVar)
+import Control.Monad.IO.Class                     (liftIO)
-import           Control.Monad.IO.Class                     (liftIO)
+import Prelude.Compat
-import           Prelude.Compat
+import Servant
-import           Servant
+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
-import           Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
+import Test.Hspec                                 (Spec, context, describe, it,
-import           Test.Hspec                                 (Spec, context,
+                                                   pending, shouldBe,
-                                                             describe, it,
+                                                   shouldContain)
-                                                             pending, shouldBe)
+import Test.Hspec.Core.Spec                       (Arg, Example, Result (..),
-import           Test.Hspec.Core.Spec                       (Arg, Example,
+                                                   defaultParams,
-                                                             Result (..),
+                                                   evaluateExample)
-                                                             defaultParams,
-                                                             evaluateExample)
 
-import           Servant.QuickCheck
+import Servant.QuickCheck
-import           Servant.QuickCheck.Internal                (genRequest, Failure(..), serverDoesntSatisfy)
+import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
 
 spec :: Spec
 spec = do
   serversEqualSpec
   serverSatisfiesSpec
   isComprehensiveSpec
+  onlyJsonObjectSpec
 
 serversEqualSpec :: Spec
 serversEqualSpec = describe "serversEqual" $ do
@@ -34,28 +33,14 @@ serversEqualSpec = describe "serversEqual" $ do
 
   context "when servers are not equal" $ do
 
-    it "provides the failing requests in the error message" $ do
-      e <- withServantServer api2 server2 $ \burl1 ->
-        withServantServer api2 server3 $ \burl2 -> do
-          evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
-      e `shouldBe` e
 
-    it "provides the failing requests in the error message" $ do
+    it "provides the failing responses in the error message" $ do
       Fail _ err <- withServantServer api2 server2 $ \burl1 ->
         withServantServer api2 server3 $ \burl2 -> do
           evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
-      print err
+      show err `shouldContain` "Body: 1"
-      let ServerEqualityFailure req _ _ = read err
+      show err `shouldContain` "Body: 2"
-      req `shouldBe` "failplz"
+      show err `shouldContain` "Path: failplz/"
-
-    {-it "provides the failing responses in the error message" $ do-}
-      {-Fail _ err <- withServantServer api2 server2 $ \burl1 ->-}
-        {-withServantServer api2 server3 $ \burl2 -> do-}
-          {-evalExample $ serversEqual api2 burl1 burl2 args bodyEquality-}
-      {-let ServerEqualityFailure _ r1 r2 = read err-}
-      {-r1 `shouldBe` "1"-}
-      {-r2 `shouldBe` "2"-}
-
 
 serverSatisfiesSpec :: Spec
 serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -74,8 +59,24 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
                                      <%> notAllowedContainsAllowHeader
                                      <%> mempty)
 
-  context "when predicates are false" $
+  context "when predicates are false" $ do
-    it "fails with informative error messages" $ pending
+
+    it "fails with informative error messages" $ do
+      Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
+        evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
+      err `shouldContain` "getsHaveCacheControlHeader"
+      err `shouldContain` "Headers"
+      err `shouldContain` "Body"
+
+onlyJsonObjectSpec :: Spec
+onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
+
+  it "fails correctly" $ do
+    Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
+      evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
+        (onlyJsonObjects <%> mempty)
+    err `shouldContain` "onlyJsonObjects"
+
 
 isComprehensiveSpec :: Spec
 isComprehensiveSpec = describe "HasGenRequest" $ do
@@ -133,5 +134,5 @@ noOfTestCases :: Int
 #if LONG_TESTS
 noOfTestCases = 20000
 #else
-noOfTestCases = 500
+noOfTestCases = 1000
 #endif