@@ -1,5 +1,4 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
1+{-# LANGUAGE CPP #-}
32module Servant.QuickCheck.InternalSpec (spec) where
43
54import Control.Concurrent.MVar (newMVar, readMVar,
@@ -8,11 +7,16 @@ import Control.Monad.IO.Class (liftIO)
87import Prelude.Compat
98import Servant
109import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
11−import Test.Hspec (Spec, describe, it,
12− shouldBe)
10+import Test.Hspec (Spec, context,
11+ describe, it,
12+ pending, shouldBe)
13+import Test.Hspec.Core.Spec (Arg, Example,
14+ Result (..),
15+ defaultParams,
16+ evaluateExample)
1317
1418import Servant.QuickCheck
15−import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
19+import Servant.QuickCheck.Internal (genRequest, Failure(..), serverDoesntSatisfy)
1620
1721spec :: Spec
1822spec = do
@@ -28,6 +32,23 @@ serversEqualSpec = describe "serversEqual" $ do
2832 withServantServerAndContext api ctx server $ \burl2 -> do
2933 serversEqual api burl1 burl2 args bodyEquality
3034
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+
3152
3253serverSatisfiesSpec :: Spec
3354serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -46,6 +67,9 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
4667 <%> notAllowedContainsAllowHeader
4768 <%> mempty)
4869
70+ context "when predicates are false" $
71+ it "fails with informative error messages" $ pending
72+
4973isComprehensiveSpec :: Spec
5074isComprehensiveSpec = describe "HasGenRequest" $ do
5175
@@ -72,12 +96,29 @@ server = do
7296 :<|> (liftIO $ readMVar mvar >>= return . length)
7397 :<|> (const $ return ())
7498
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+
75111ctx :: Context '[BasicAuthCheck ()]
76112ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
77113------------------------------------------------------------------------------
78114-- Utils
79115------------------------------------------------------------------------------
80116
117+evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
118+evalExample e = evaluateExample e defaultParams ($ ()) progCallback
119+ where
120+ progCallback _ = return ()
121+
81122args :: Args
82123args = defaultArgs { maxSuccess = noOfTestCases }
83124