diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 08bb995..835578f 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -24,6 +24,7 @@ library , Servant.QuickCheck.Internal.HasGenRequest , Servant.QuickCheck.Internal.QuickCheck , Servant.QuickCheck.Internal.Equality + , Servant.QuickCheck.Internal.ErrorTypes build-depends: base >=4.7 && <4.9 , base-compat == 0.9.* , QuickCheck == 2.8.* diff --git a/src/Servant/QuickCheck/Internal.hs b/src/Servant/QuickCheck/Internal.hs index 8e52dd4..5f36e14 100644 --- a/src/Servant/QuickCheck/Internal.hs +++ b/src/Servant/QuickCheck/Internal.hs @@ -4,3 +4,4 @@ import Servant.QuickCheck.Internal.HasGenRequest as X import Servant.QuickCheck.Internal.Predicates as X import Servant.QuickCheck.Internal.QuickCheck as X import Servant.QuickCheck.Internal.Equality as X +import Servant.QuickCheck.Internal.ErrorTypes as X diff --git a/src/Servant/QuickCheck/Internal/ErrorTypes.hs b/src/Servant/QuickCheck/Internal/ErrorTypes.hs index 60e91d9..7cbf33d 100644 --- a/src/Servant/QuickCheck/Internal/ErrorTypes.hs +++ b/src/Servant/QuickCheck/Internal/ErrorTypes.hs @@ -1,6 +1,9 @@ module Servant.QuickCheck.Internal.ErrorTypes where import Text.PrettyPrint +import Prelude.Compat +import Data.String (IsString(fromString)) +import GHC.Generics (Generic) data Request = Request { requestBody :: String @@ -8,12 +11,12 @@ data Request = Request , requestUrl :: String } deriving (Eq, Show, Read, Generic) -prettyReq :: Doc +prettyReq :: Request -> Doc prettyReq r = - text "Request:" $ nest 5 $ - text "URL:" <+> text (nest 5 $ requestUrl r) - $$ text "Headers:" <+> - $$ text "Body:" <+> text (nest 5 $ requestBody r) + text "Request:" $$ (nest 5 $ + text "URL:" <+> (nest 5 $ text $ requestUrl r) + $$ text "Headers:" <+> (nest 5 $ hsep $ text <$> requestHeaders r) + $$ text "Body:" <+> (nest 5 $ text $ requestBody r)) instance IsString Request where fromString url = Request "" [] url @@ -30,8 +33,8 @@ instance IsString Response where data Failure = PredicateFailure String Request Response | ServerEqualityFailure Request Response Response - deriving (Eq, Show, Read, Generic) + deriving (Eq, Read, Generic) instance Show Failure where show (PredicateFailure pred req resp) - = "Predicate failed for " <> pred <> " + = "Predicate failed for " ++ pred diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs index 84e466e..3d2f58c 100644 --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -29,7 +29,7 @@ instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where genRequest _ = do old' <- old - return $ \burl -> let r = old' burl in r { path = new <> "/" <> path r } + return $ \burl -> let r = old' burl in r { path = new <> path r } where old = genRequest (Proxy :: Proxy b) new = cs $ symbolVal (Proxy :: Proxy path) @@ -39,7 +39,7 @@ instance (Arbitrary c, HasGenRequest b, ToHttpApiData c ) genRequest _ = do old' <- old new' <- toUrlPiece <$> new - return $ \burl -> let r = old' burl in r { path = cs new' <> "/" <> path r } + return $ \burl -> let r = old' burl in r { path = cs new' <> path r } where old = genRequest (Proxy :: Proxy b) new = arbitrary :: Gen c diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 75cad3f..72747a7 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -15,7 +15,9 @@ import System.IO.Unsafe (unsafePerformIO) import Test.Hspec (Expectation, expectationFailure) import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult) -import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run) +import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run, monitor) +import Test.QuickCheck.Property (counterexample) +import Control.Monad (unless) import Servant.QuickCheck.Internal.Equality import Servant.QuickCheck.Internal.HasGenRequest @@ -61,7 +63,10 @@ serversEqual api burl1 burl2 args req = do r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager - assert $ getResponseEquality req resp1 resp2 + unless (getResponseEquality req resp1 resp2) $ do + monitor (counterexample "hi" ) + assert False + case r of Success {} -> return () GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests" diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 21fe511..1e65bc2 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -34,20 +34,27 @@ 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 Fail _ err <- withServantServer api2 server2 $ \burl1 -> withServantServer api2 server3 $ \burl2 -> do evalExample $ serversEqual api2 burl1 burl2 args bodyEquality + print err 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" + {-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