From 70fed09866b17a141aff154b5084f9dedb2be16b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 1 Aug 2016 11:58:10 -0300 Subject: [PATCH] Start implementing better error messages. --- servant-quickcheck.cabal | 5 ++ src/Servant/QuickCheck/Internal/ErrorTypes.hs | 37 ++++++++++++++ src/Servant/QuickCheck/Internal/QuickCheck.hs | 21 ++++---- test/Servant/QuickCheck/InternalSpec.hs | 51 +++++++++++++++++-- 4 files changed, 99 insertions(+), 15 deletions(-) create mode 100644 src/Servant/QuickCheck/Internal/ErrorTypes.hs diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index d5f29ab..08bb995 100644 --- a/servant-quickcheck.cabal +++ b/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 diff --git a/src/Servant/QuickCheck/Internal/ErrorTypes.hs b/src/Servant/QuickCheck/Internal/ErrorTypes.hs new file mode 100644 index 0000000..60e91d9 --- /dev/null +++ b/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 <> " diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 95081d4..75cad3f 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/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, - defaultManagerSettings, httpLbs, - newManager) +import GHC.Generics (Generic) +import qualified Network.HTTP.Client as C 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 - resp2 <- run $ httpLbs (noCheckStatus req2) defManager + resp1 <- run $ C.httpLbs (noCheckStatus req1) 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 r = r { checkStatus = \_ _ _ -> Nothing} +noCheckStatus :: C.Request -> C.Request +noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing} -defManager :: Manager -defManager = unsafePerformIO $ newManager defaultManagerSettings +defManager :: C.Manager +defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings {-# NOINLINE defManager #-} diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index c9bc333..21fe511 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} 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, - shouldBe) +import Test.Hspec (Spec, context, + 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 }