Start implementing better error messages.

servant-quickcheck.cabal

@@ -45,6 +45,7 @@ library
                      , case-insensitive == 1.2.*
                      , hspec == 2.2.*
                      , text == 1.*
+                     , pretty == 1.1.*
   if impl(ghc < 7.10)
     build-depends:     bifunctors == 5.*
 
@@ -77,6 +78,7 @@ test-suite spec
                      , base-compat
                      , servant-quickcheck
                      , hspec
+                     , hspec-core
                      , http-client
                      , warp
                      , servant-server
@@ -88,7 +90,10 @@ test-suite spec
   default-extensions:  TypeOperators
                      , FlexibleInstances
                      , FlexibleContexts
+                     , GADTs
                      , DataKinds
                      , NoImplicitPrelude
+                     , OverloadedStrings
+                     , ScopedTypeVariables
   if flag(long-tests)
       cpp-options: -DLONG_TESTS

src/Servant/QuickCheck/Internal/ErrorTypes.hs

@@ -0,0 +1,37 @@
+module Servant.QuickCheck.Internal.ErrorTypes where
+
+import Text.PrettyPrint
+
+data Request = Request
+  { requestBody    :: String
+  , requestHeaders :: [String]
+  , requestUrl     :: String
+  } deriving (Eq, Show, Read, Generic)
+
+prettyReq :: Doc
+prettyReq r =
+  text "Request:" $ nest 5 $
+     text "URL:"      <+> text (nest 5 $ requestUrl r)
+  $$ text "Headers:"  <+>
+  $$ text "Body:"     <+> text (nest 5 $ requestBody r)
+
+instance IsString Request where
+  fromString url = Request "" [] url
+
+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
+  = PredicateFailure String Request Response
+  | ServerEqualityFailure Request Response Response
+  deriving (Eq, Show, Read, Generic)
+
+instance Show Failure where
+  show (PredicateFailure pred req resp)
+    = "Predicate failed for " <> pred <> "

src/Servant/QuickCheck/Internal/QuickCheck.hs

@@ -2,10 +2,10 @@ module Servant.QuickCheck.Internal.QuickCheck where
 
 import qualified Data.ByteString.Lazy     as LBS
 import           Data.Proxy               (Proxy)
+import           Data.String              (IsString (..))
 import           Data.Text                (Text)
-import           Network.HTTP.Client      (Manager, Request, checkStatus,
+import           GHC.Generics             (Generic)
-                                           defaultManagerSettings, httpLbs,
+import qualified Network.HTTP.Client      as C
-                                           newManager)
 import           Network.Wai.Handler.Warp (withApplication)
 import           Prelude.Compat
 import           Servant                  (Context (EmptyContext), HasServer,
@@ -17,9 +17,10 @@ import           Test.QuickCheck          (Args (..), Result (..),
                                            quickCheckWithResult)
 import           Test.QuickCheck.Monadic  (assert, forAllM, monadicIO, run)
 
+import Servant.QuickCheck.Internal.Equality
 import Servant.QuickCheck.Internal.HasGenRequest
 import Servant.QuickCheck.Internal.Predicates
-import Servant.QuickCheck.Internal.Equality
+import Servant.QuickCheck.Internal.ErrorTypes
 
 
 -- | Start a servant application on an open port, run the provided function,
@@ -58,8 +59,8 @@ serversEqual :: HasGenRequest a =>
 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
-    resp1 <- run $ httpLbs (noCheckStatus req1) defManager
+    resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
-    resp2 <- run $ httpLbs (noCheckStatus req2) defManager
+    resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
     assert $ getResponseEquality req resp1 resp2
   case r of
     Success {} -> return ()
@@ -116,9 +117,9 @@ serverDoesntSatisfy api burl args preds = do
     NoExpectedFailure {} -> expectationFailure $ "No expected failure"
     InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
 
-noCheckStatus :: Request -> Request
+noCheckStatus :: C.Request -> C.Request
-noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
+noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
 
-defManager :: Manager
+defManager :: C.Manager
-defManager = unsafePerformIO $ newManager defaultManagerSettings
+defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
 {-# NOINLINE defManager #-}

test/Servant/QuickCheck/InternalSpec.hs

@@ -1,5 +1,4 @@
-{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE CPP #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Servant.QuickCheck.InternalSpec (spec) where
 
 import           Control.Concurrent.MVar                    (newMVar, readMVar,
@@ -8,11 +7,16 @@ import           Control.Monad.IO.Class                     (liftIO)
 import           Prelude.Compat
 import           Servant
 import           Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
-import           Test.Hspec                                 (Spec, describe, it,
+import           Test.Hspec                                 (Spec, context,
-                                                             shouldBe)
+                                                             describe, it,
+                                                             pending, shouldBe)
+import           Test.Hspec.Core.Spec                       (Arg, Example,
+                                                             Result (..),
+                                                             defaultParams,
+                                                             evaluateExample)
 
 import           Servant.QuickCheck
-import           Servant.QuickCheck.Internal                (genRequest, serverDoesntSatisfy)
+import           Servant.QuickCheck.Internal                (genRequest, Failure(..), serverDoesntSatisfy)
 
 spec :: Spec
 spec = do
@@ -28,6 +32,23 @@ serversEqualSpec = describe "serversEqual" $ do
       withServantServerAndContext api ctx server $ \burl2 -> do
         serversEqual api burl1 burl2 args bodyEquality
 
+  context "when servers are not equal" $ do
+
+    it "provides the failing requests 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 req _ _ = read err
+      req `shouldBe` "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
@@ -46,6 +67,9 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
                                      <%> notAllowedContainsAllowHeader
                                      <%> mempty)
 
+  context "when predicates are false" $
+    it "fails with informative error messages" $ pending
+
 isComprehensiveSpec :: Spec
 isComprehensiveSpec = describe "HasGenRequest" $ do
 
@@ -72,12 +96,29 @@ server = do
         :<|> (liftIO $ readMVar mvar >>= return . length)
         :<|> (const $ return ())
 
+
+type API2 = "failplz" :> Get '[JSON] Int
+
+api2 :: Proxy API2
+api2 = Proxy
+
+server2 :: IO (Server API2)
+server2 = return $ return 1
+
+server3 :: IO (Server API2)
+server3 = return $ return 2
+
 ctx :: Context '[BasicAuthCheck ()]
 ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
 ------------------------------------------------------------------------------
 -- Utils
 ------------------------------------------------------------------------------
 
+evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
+evalExample e = evaluateExample e defaultParams ($ ()) progCallback
+  where
+    progCallback _ = return ()
+
 args :: Args
 args = defaultArgs { maxSuccess = noOfTestCases }