@@ -1,19 +1,33 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2module Servant.QuickCheck.InternalSpec (spec) where
2module Servant.QuickCheck.InternalSpec (spec) where
4−import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
5+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
6+import Control.Exception (SomeException)
7+import Control.Monad (replicateM)
5−import Control.Monad.IO.Class (liftIO)
8+import Control.Monad.IO.Class (liftIO)
9+import qualified Data.ByteString as BS
10+import qualified Data.ByteString.Char8 as C
11+import Data.Maybe (fromJust)
12+import Network.HTTP.Client (path, queryString)
6−import Prelude.Compat
13+import Prelude.Compat
7−import Servant
14+import Servant
8−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
15+import Servant.HTML.Blaze (HTML)
16+import qualified Text.Blaze.Html as Blaze
17+import qualified Text.Blaze.Html5 as Blaze5
9−import Test.Hspec (Spec, context, describe, it,
18+import Test.Hspec (Spec, context, describe, it, shouldBe,
10− shouldBe, shouldContain)
19+ shouldContain)
11−import Test.Hspec.Core.Spec (Arg, Example, Result (..),
20+import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
12− defaultParams,
21+ defaultParams, safeEvaluateExample)
13− evaluateExample)
22+import Test.QuickCheck.Gen (generate, unGen)
23+import Test.QuickCheck.Random (mkQCGen)
26+import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
15import Servant.QuickCheck
28import Servant.QuickCheck
16−import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
29+import Servant.QuickCheck.Internal (genRequest, runGenRequest,
18spec :: Spec
32spec :: Spec
@@ -21,6 +35,12 @@ spec = do
21 serverSatisfiesSpec
35 serverSatisfiesSpec
22 isComprehensiveSpec
36 isComprehensiveSpec
23 onlyJsonObjectSpec
37 onlyJsonObjectSpec
43+ unbiasedGenerationSpec
25serversEqualSpec :: Spec
45serversEqualSpec :: Spec
26serversEqualSpec = describe "serversEqual" $ do
46serversEqualSpec = describe "serversEqual" $ do
@@ -31,15 +51,42 @@ serversEqualSpec = describe "serversEqual" $ do
31 serversEqual api burl1 burl2 args bodyEquality
51 serversEqual api burl1 burl2 args bodyEquality
33 context "when servers are not equal" $ do
53 context "when servers are not equal" $ do
36 it "provides the failing responses in the error message" $ do
54 it "provides the failing responses in the error message" $ do
37− Fail _ err <- withServantServer api2 server2 $ \burl1 ->
55+ FailedWith err <- withServantServer api2 server2 $ \burl1 ->
38 withServantServer api2 server3 $ \burl2 -> do
56 withServantServer api2 server3 $ \burl2 -> do
39 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
57 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
58+ show err `shouldContain` "Server equality failed"
40 show err `shouldContain` "Body: 1"
59 show err `shouldContain` "Body: 1"
41 show err `shouldContain` "Body: 2"
60 show err `shouldContain` "Body: 2"
42− show err `shouldContain` "Path: failplz/"
61+ show err `shouldContain` "Path: /failplz"
63+ context "when JSON is equal but looks a bit different as a ByteString" $ do
65+ it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
66+ FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
67+ withServantServer jsonApi jsonServer2 $ \burl2 -> do
68+ evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
69+ show err `shouldContain` "Server equality failed"
71+ it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
72+ withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
73+ withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
74+ serversEqual jsonApi burl1 burl2 args jsonEquality
76+ it "sees when JSON apis are not equal because any value is different" $ do
77+ FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
78+ withServantServer jsonApi jsonServer3 $ \burl2 -> do
79+ evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
80+ show err `shouldContain` "Server equality failed"
81+ show err `shouldContain` "Path: /jsonComparison"
83+ it "sees when JSON apis are not equal due to different keys but same values" $ do
84+ FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
85+ withServantServer jsonApi jsonServer4 $ \burl2 -> do
86+ evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
87+ show err `shouldContain` "Server equality failed"
88+ show err `shouldContain` "Path: /jsonComparison"
44serverSatisfiesSpec :: Spec
91serverSatisfiesSpec :: Spec
45serverSatisfiesSpec = describe "serverSatisfies" $ do
92serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -61,29 +108,123 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
61 context "when predicates are false" $ do
108 context "when predicates are false" $ do
63 it "fails with informative error messages" $ do
110 it "fails with informative error messages" $ do
64− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
111+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
65− evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
112+ evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
66− err `shouldContain` "getsHaveCacheControlHeader"
113+ show err `shouldContain` "notAllowedContainsAllowHeader"
67− err `shouldContain` "Headers"
114+ show err `shouldContain` "Headers"
68− err `shouldContain` "Body"
115+ show err `shouldContain` "Body"
70onlyJsonObjectSpec :: Spec
118onlyJsonObjectSpec :: Spec
71onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
119onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
73 it "fails correctly" $ do
121 it "fails correctly" $ do
74− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
122+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
75 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
123 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
76 (onlyJsonObjects <%> mempty)
124 (onlyJsonObjects <%> mempty)
77− err `shouldContain` "onlyJsonObjects"
125+ show err `shouldContain` "onlyJsonObjects"
127+ it "accepts non-JSON endpoints" $ do
128+ withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
129+ serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
131+ it "does not fail when there is no content-type" $ do
132+ withServantServerAndContext api2 ctx serverFailing $ \burl ->
133+ serverSatisfies api2 burl args (onlyJsonObjects <%> mempty)
135+notLongerThanSpec :: Spec
136+notLongerThanSpec = describe "notLongerThan" $ do
138+ it "fails correctly" $ do
139+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
140+ evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
141+ (notLongerThan 1 <%> mempty)
142+ show err `shouldContain` "notLongerThan"
144+ it "succeeds correctly" $ do
145+ withServantServerAndContext api ctx server $ \burl ->
146+ serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)
80isComprehensiveSpec :: Spec
148isComprehensiveSpec :: Spec
81isComprehensiveSpec = describe "HasGenRequest" $ do
149isComprehensiveSpec = describe "HasGenRequest" $ do
83 it "has instances for all 'servant' combinators" $ do
151 it "has instances for all 'servant' combinators" $ do
84− let _g = genRequest comprehensiveAPIWithoutRaw
152+ let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
85 True `shouldBe` True -- This is a type-level check
153 True `shouldBe` True -- This is a type-level check
156+deepPathSpec = describe "Path components" $ do
158+ it "are separated by slashes, without a trailing slash" $ do
160+ burl = BaseUrl Http "localhost" 80 ""
161+ gen = runGenRequest deepAPI
162+ req = (unGen gen rng 0) burl
163+ path req `shouldBe` ("/one/two/three")
166+queryParamsSpec :: Spec
167+queryParamsSpec = describe "QueryParams" $ do
169+ it "reduce to an HTTP query string correctly" $ do
171+ burl = BaseUrl Http "localhost" 80 ""
172+ gen = runGenRequest paramsAPI
173+ req = (unGen gen rng 0) burl
174+ qs = C.unpack $ queryString req
175+ qs `shouldBe` "one=_&two=_"
177+queryFlagsSpec :: Spec
178+queryFlagsSpec = describe "QueryFlags" $ do
180+ it "reduce to an HTTP query string correctly" $ do
182+ burl = BaseUrl Http "localhost" 80 ""
183+ gen = runGenRequest flagsAPI
184+ req = (unGen gen rng 0) burl
185+ qs = C.unpack $ queryString req
186+ qs `shouldBe` "one&two"
188+htmlDocTypesSpec :: Spec
189+htmlDocTypesSpec = describe "HtmlDocTypes" $ do
191+ it "fails HTML without doctype correctly" $ do
192+ err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
193+ evalExample $ serverSatisfies docTypeApi burl args
194+ (htmlIncludesDoctype <%> mempty)
195+ show err `shouldContain` "htmlIncludesDoctype"
197+ it "passes HTML with a doctype at start" $ do
198+ withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
199+ serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
201+ it "accepts json endpoints and passes over them in silence" $ do
202+ withServantServerAndContext api ctx server $ \burl -> do
203+ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
204+ (htmlIncludesDoctype <%> mempty)
207+makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
208+makeRandomRequest large burl = do
209+ req <- generate $ runGenRequest large
210+ pure $ fst . fromJust . C.readInteger . C.drop 1 . path $ req burl
213+unbiasedGenerationSpec :: Spec
214+unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
216+ it "frequency paired with generated endpoint should be more randomly distributed" $ do
217+ let burl = BaseUrl Http "localhost" 80 ""
218+ let runs = 10000 :: Double
219+ someRequests <- replicateM 10000 (makeRandomRequest largeApi burl)
220+ let mean = (sum $ map fromIntegral someRequests) / runs
221+ let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
222+ let variance = (sum $ map variancer someRequests) / runs - 1
223+ -- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
224+ mean > 8 `shouldBe` True
225+ mean < 9 `shouldBe` True
226+ -- Std dev is likely around 4. Variance is probably greater than 20.
227+ variance > 19.5 `shouldBe` True
88------------------------------------------------------------------------------
229------------------------------------------------------------------------------
@@ -96,6 +237,17 @@ type API = ReqBody '[JSON] String :> Post '[JSON] String
96api :: Proxy API
237api :: Proxy API
97api = Proxy
238api = Proxy
240+type ParamsAPI = QueryParam "one" () :> QueryParam "two" () :> Get '[JSON] ()
242+paramsAPI :: Proxy ParamsAPI
245+type FlagsAPI = QueryFlag "one" :> QueryFlag "two" :> Get '[JSON] ()
247+flagsAPI :: Proxy FlagsAPI
99server :: IO (Server API)
251server :: IO (Server API)
100server = do
252server = do
101 mvar <- newMVar ""
253 mvar <- newMVar ""
@@ -109,23 +261,105 @@ type API2 = "failplz" :> Get '[JSON] Int
109api2 :: Proxy API2
261api2 :: Proxy API2
110api2 = Proxy
262api2 = Proxy
264+type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
266+deepAPI :: Proxy DeepAPI
112server2 :: IO (Server API2)
270server2 :: IO (Server API2)
113server2 = return $ return 1
271server2 = return $ return 1
115server3 :: IO (Server API2)
273server3 :: IO (Server API2)
116server3 = return $ return 2
274server3 = return $ return 2
276+serverFailing :: IO (Server API2)
277+serverFailing = return . throwError $ err405
280+type HtmlDoctype = Get '[HTML] Blaze.Html
282+docTypeApi :: Proxy HtmlDoctype
285+docTypeServer :: IO (Server HtmlDoctype)
286+docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
288+noDocTypeServer :: IO (Server HtmlDoctype)
289+noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
292+-- Api for unbiased generation of requests tests
293+largeApi :: Proxy LargeAPI
297+ = "1" :> Get '[JSON] Int
298+ :<|> "2" :> Get '[JSON] Int
299+ :<|> "3" :> Get '[JSON] Int
300+ :<|> "4" :> Get '[JSON] Int
301+ :<|> "5" :> Get '[JSON] Int
302+ :<|> "6" :> Get '[JSON] Int
303+ :<|> "7" :> Get '[JSON] Int
304+ :<|> "8" :> Get '[JSON] Int
305+ :<|> "9" :> Get '[JSON] Int
306+ :<|> "10" :> Get '[JSON] Int
307+ :<|> "11" :> Get '[JSON] Int
308+ :<|> "12" :> Get '[JSON] Int
309+ :<|> "13" :> Get '[JSON] Int
310+ :<|> "14" :> Get '[JSON] Int
311+ :<|> "15" :> Get '[JSON] Int
312+ :<|> "16" :> Get '[JSON] Int
315+type OctetAPI = Get '[OctetStream] BS.ByteString
317+octetAPI :: Proxy OctetAPI
320+serverOctetAPI :: IO (Server OctetAPI)
321+serverOctetAPI = return $ return "blah"
323+type JsonApi = "jsonComparison" :> Get '[OctetStream] BS.ByteString
325+jsonApi :: Proxy JsonApi
328+jsonServer1 :: IO (Server JsonApi)
329+jsonServer1 = return $ return "{ \"b\": [\"b\"], \"a\": 1 }" -- whitespace, ordering different
331+jsonServer2 :: IO (Server JsonApi)
332+jsonServer2 = return $ return "{\"a\": 1,\"b\":[\"b\"]}"
334+jsonServer3 :: IO (Server JsonApi)
335+jsonServer3 = return $ return "{\"a\": 2, \"b\": [\"b\"]}"
337+jsonServer4 :: IO (Server JsonApi)
338+jsonServer4 = return $ return "{\"c\": 1, \"d\": [\"b\"]}"
118ctx :: Context '[BasicAuthCheck ()]
341ctx :: Context '[BasicAuthCheck ()]
119ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
342ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
120------------------------------------------------------------------------------
343------------------------------------------------------------------------------
122------------------------------------------------------------------------------
345------------------------------------------------------------------------------
124−evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
346+evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
125−evalExample e = evaluateExample e defaultParams ($ ()) progCallback
348+ r <- safeEvaluateExample e defaultParams ($ ()) progCallback
349+ case resultStatus r of
350+ Success -> return $ AllGood
351+ Failure _ reason -> return $ FailedWith $ show reason
352+ Pending {} -> error "should not happen"
127 progCallback _ = return ()
354 progCallback _ = return ()
357+ = AnException SomeException
129args :: Args
363args :: Args
130args = defaultArgs { maxSuccess = noOfTestCases }
364args = defaultArgs { maxSuccess = noOfTestCases }