git.iko.soy/servant-quickcheck
on master help sign in
Start implementing better error messages.
70fed09Julian K. Arni
servant-quickcheck.cabal+5
compare with master
unifiedsplit
@@ -45,6 +45,7 @@ library
45 , case-insensitive == 1.2.*
45 , case-insensitive == 1.2.*
46 , hspec == 2.2.*
46 , hspec == 2.2.*
47 , text == 1.*
47 , text == 1.*
48+ , pretty == 1.1.*
48 if impl(ghc < 7.10)
49 if impl(ghc < 7.10)
49 build-depends: bifunctors == 5.*
50 build-depends: bifunctors == 5.*
50
51
@@ -77,6 +78,7 @@ test-suite spec
77 , base-compat
78 , base-compat
78 , servant-quickcheck
79 , servant-quickcheck
79 , hspec
80 , hspec
81+ , hspec-core
80 , http-client
82 , http-client
81 , warp
83 , warp
82 , servant-server
84 , servant-server
@@ -88,7 +90,10 @@ test-suite spec
88 default-extensions: TypeOperators
90 default-extensions: TypeOperators
89 , FlexibleInstances
91 , FlexibleInstances
90 , FlexibleContexts
92 , FlexibleContexts
93+ , GADTs
91 , DataKinds
94 , DataKinds
92 , NoImplicitPrelude
95 , NoImplicitPrelude
96+ , OverloadedStrings
97+ , ScopedTypeVariables
93 if flag(long-tests)
98 if flag(long-tests)
94 cpp-options: -DLONG_TESTS
99 cpp-options: -DLONG_TESTS
src/Servant/QuickCheck/Internal/ErrorTypes.hsnew file+37
@@ -0,0 +1,37 @@
1+module Servant.QuickCheck.Internal.ErrorTypes where
2+
3+import Text.PrettyPrint
4+
5+data Request = Request
6+ { requestBody :: String
7+ , requestHeaders :: [String]
8+ , requestUrl :: String
9+ } deriving (Eq, Show, Read, Generic)
10+
11+prettyReq :: Doc
12+prettyReq r =
13+ text "Request:" $ nest 5 $
14+ text "URL:" <+> text (nest 5 $ requestUrl r)
15+ $$ text "Headers:" <+>
16+ $$ text "Body:" <+> text (nest 5 $ requestBody r)
17+
18+instance IsString Request where
19+ fromString url = Request "" [] url
20+
21+data Response = Response
22+ { responseBody :: String
23+ , responseHeaders :: [String]
24+ } deriving (Eq, Show, Read, Generic)
25+
26+instance IsString Response where
27+ fromString body = Response body []
28+
29+-- The error that occurred.
30+data Failure
31+ = PredicateFailure String Request Response
32+ | ServerEqualityFailure Request Response Response
33+ deriving (Eq, Show, Read, Generic)
34+
35+instance Show Failure where
36+ show (PredicateFailure pred req resp)
37+ = "Predicate failed for " <> pred <> "
src/Servant/QuickCheck/Internal/QuickCheck.hs+11−10
@@ -2,10 +2,10 @@ module Servant.QuickCheck.Internal.QuickCheck where
2
2
3import qualified Data.ByteString.Lazy as LBS
3import qualified Data.ByteString.Lazy as LBS
4import Data.Proxy (Proxy)
4import Data.Proxy (Proxy)
5+import Data.String (IsString (..))
5import Data.Text (Text)
6import Data.Text (Text)
7+import GHC.Generics (Generic)
6−import Network.HTTP.Client (Manager, Request, checkStatus,
8+import qualified Network.HTTP.Client as C
7− defaultManagerSettings, httpLbs,
8− newManager)
9import Network.Wai.Handler.Warp (withApplication)
9import Network.Wai.Handler.Warp (withApplication)
10import Prelude.Compat
10import Prelude.Compat
11import Servant (Context (EmptyContext), HasServer,
11import Servant (Context (EmptyContext), HasServer,
@@ -17,9 +17,10 @@ import Test.QuickCheck (Args (..), Result (..),
17 quickCheckWithResult)
17 quickCheckWithResult)
18import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)
18import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)
19
19
20+import Servant.QuickCheck.Internal.Equality
20import Servant.QuickCheck.Internal.HasGenRequest
21import Servant.QuickCheck.Internal.HasGenRequest
21import Servant.QuickCheck.Internal.Predicates
22import Servant.QuickCheck.Internal.Predicates
22−import Servant.QuickCheck.Internal.Equality
23+import Servant.QuickCheck.Internal.ErrorTypes
23
24
24
25
25-- | Start a servant application on an open port, run the provided function,
26-- | Start a servant application on an open port, run the provided function,
@@ -58,8 +59,8 @@ serversEqual :: HasGenRequest a =>
58serversEqual api burl1 burl2 args req = do
59serversEqual api burl1 burl2 args req = do
59 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
60 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
60 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
61 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
61− resp1 <- run $ httpLbs (noCheckStatus req1) defManager
62+ resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
62− resp2 <- run $ httpLbs (noCheckStatus req2) defManager
63+ resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
63 assert $ getResponseEquality req resp1 resp2
64 assert $ getResponseEquality req resp1 resp2
64 case r of
65 case r of
65 Success {} -> return ()
66 Success {} -> return ()
@@ -116,9 +117,9 @@ serverDoesntSatisfy api burl args preds = do
116 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
117 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
117 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
118 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
118
119
119−noCheckStatus :: Request -> Request
120+noCheckStatus :: C.Request -> C.Request
120−noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
121+noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
121
122
122−defManager :: Manager
123+defManager :: C.Manager
123−defManager = unsafePerformIO $ newManager defaultManagerSettings
124+defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
124{-# NOINLINE defManager #-}
125{-# NOINLINE defManager #-}
test/Servant/QuickCheck/InternalSpec.hs+46−5
@@ -1,5 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3module Servant.QuickCheck.InternalSpec (spec) where
2module Servant.QuickCheck.InternalSpec (spec) where
4
3
5import Control.Concurrent.MVar (newMVar, readMVar,
4import Control.Concurrent.MVar (newMVar, readMVar,
@@ -8,11 +7,16 @@ import Control.Monad.IO.Class (liftIO)
8import Prelude.Compat
7import Prelude.Compat
9import Servant
8import Servant
10import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
9import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
11−import Test.Hspec (Spec, describe, it,
10+import Test.Hspec (Spec, context,
11+ describe, it,
12− shouldBe)
12+ pending, shouldBe)
13+import Test.Hspec.Core.Spec (Arg, Example,
14+ Result (..),
15+ defaultParams,
16+ evaluateExample)
13
17
14import Servant.QuickCheck
18import Servant.QuickCheck
15−import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
19+import Servant.QuickCheck.Internal (genRequest, Failure(..), serverDoesntSatisfy)
16
20
17spec :: Spec
21spec :: Spec
18spec = do
22spec = do
@@ -28,6 +32,23 @@ serversEqualSpec = describe "serversEqual" $ do
28 withServantServerAndContext api ctx server $ \burl2 -> do
32 withServantServerAndContext api ctx server $ \burl2 -> do
29 serversEqual api burl1 burl2 args bodyEquality
33 serversEqual api burl1 burl2 args bodyEquality
30
34
35+ context "when servers are not equal" $ do
36+
37+ it "provides the failing requests in the error message" $ do
38+ Fail _ err <- withServantServer api2 server2 $ \burl1 ->
39+ withServantServer api2 server3 $ \burl2 -> do
40+ evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
41+ let ServerEqualityFailure req _ _ = read err
42+ req `shouldBe` "failplz"
43+
44+ it "provides the failing responses in the error message" $ do
45+ Fail _ err <- withServantServer api2 server2 $ \burl1 ->
46+ withServantServer api2 server3 $ \burl2 -> do
47+ evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
48+ let ServerEqualityFailure _ r1 r2 = read err
49+ r1 `shouldBe` "1"
50+ r2 `shouldBe` "2"
51+
31
52
32serverSatisfiesSpec :: Spec
53serverSatisfiesSpec :: Spec
33serverSatisfiesSpec = describe "serverSatisfies" $ do
54serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -46,6 +67,9 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
46 <%> notAllowedContainsAllowHeader
67 <%> notAllowedContainsAllowHeader
47 <%> mempty)
68 <%> mempty)
48
69
70+ context "when predicates are false" $
71+ it "fails with informative error messages" $ pending
72+
49isComprehensiveSpec :: Spec
73isComprehensiveSpec :: Spec
50isComprehensiveSpec = describe "HasGenRequest" $ do
74isComprehensiveSpec = describe "HasGenRequest" $ do
51
75
@@ -72,12 +96,29 @@ server = do
72 :<|> (liftIO $ readMVar mvar >>= return . length)
96 :<|> (liftIO $ readMVar mvar >>= return . length)
73 :<|> (const $ return ())
97 :<|> (const $ return ())
74
98
99+
100+type API2 = "failplz" :> Get '[JSON] Int
101+
102+api2 :: Proxy API2
103+api2 = Proxy
104+
105+server2 :: IO (Server API2)
106+server2 = return $ return 1
107+
108+server3 :: IO (Server API2)
109+server3 = return $ return 2
110+
75ctx :: Context '[BasicAuthCheck ()]
111ctx :: Context '[BasicAuthCheck ()]
76ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
112ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
77------------------------------------------------------------------------------
113------------------------------------------------------------------------------
78-- Utils
114-- Utils
79------------------------------------------------------------------------------
115------------------------------------------------------------------------------
80
116
117+evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
118+evalExample e = evaluateExample e defaultParams ($ ()) progCallback
119+ where
120+ progCallback _ = return ()
121+
81args :: Args
122args :: Args
82args = defaultArgs { maxSuccess = noOfTestCases }
123args = defaultArgs { maxSuccess = noOfTestCases }
83
124