@@ -1,33 +1,19 @@
11{-# LANGUAGE CPP #-}
22module Servant.QuickCheck.InternalSpec (spec) where
33
4−
5−import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
6−import Control.Exception (SomeException)
7−import Control.Monad (replicateM)
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)
13−import Prelude.Compat
14−import Servant
15−import Servant.HTML.Blaze (HTML)
16−import qualified Text.Blaze.Html as Blaze
17−import qualified Text.Blaze.Html5 as Blaze5
18−import Test.Hspec (Spec, context, describe, it, shouldBe,
19− shouldContain)
20−import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
21− defaultParams, safeEvaluateExample)
22−import Test.QuickCheck.Gen (generate, unGen)
23−import Test.QuickCheck.Random (mkQCGen)
24−
25−
26−import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
4+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
5+import Control.Monad.IO.Class (liftIO)
6+import Prelude.Compat
7+import Servant
8+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
9+import Test.Hspec (Spec, context, describe, it,
10+ shouldBe, shouldContain)
11+import Test.Hspec.Core.Spec (Arg, Example, Result (..),
12+ defaultParams,
13+ evaluateExample)
2714
2815import Servant.QuickCheck
29−import Servant.QuickCheck.Internal (genRequest, runGenRequest,
30− serverDoesntSatisfy)
16+import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
3117
3218spec :: Spec
3319spec = do
@@ -35,12 +21,6 @@ spec = do
3521 serverSatisfiesSpec
3622 isComprehensiveSpec
3723 onlyJsonObjectSpec
38− notLongerThanSpec
39− queryParamsSpec
40− queryFlagsSpec
41− deepPathSpec
42− htmlDocTypesSpec
43− unbiasedGenerationSpec
4424
4525serversEqualSpec :: Spec
4626serversEqualSpec = describe "serversEqual" $ do
@@ -51,42 +31,15 @@ serversEqualSpec = describe "serversEqual" $ do
5131 serversEqual api burl1 burl2 args bodyEquality
5232
5333 context "when servers are not equal" $ do
34+
35+
5436 it "provides the failing responses in the error message" $ do
55− FailedWith err <- withServantServer api2 server2 $ \burl1 ->
37+ Fail _ err <- withServantServer api2 server2 $ \burl1 ->
5638 withServantServer api2 server3 $ \burl2 -> do
5739 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
58− show err `shouldContain` "Server equality failed"
5940 show err `shouldContain` "Body: 1"
6041 show err `shouldContain` "Body: 2"
61− show err `shouldContain` "Path: /failplz"
62−
63− context "when JSON is equal but looks a bit different as a ByteString" $ do
64−
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"
70−
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
75−
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"
82−
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"
89−
42+ show err `shouldContain` "Path: failplz/"
9043
9144serverSatisfiesSpec :: Spec
9245serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -108,123 +61,29 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
10861 context "when predicates are false" $ do
10962
11063 it "fails with informative error messages" $ do
111− FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
112− evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
113− show err `shouldContain` "notAllowedContainsAllowHeader"
114− show err `shouldContain` "Headers"
115− show err `shouldContain` "Body"
116−
64+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
65+ evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
66+ err `shouldContain` "getsHaveCacheControlHeader"
67+ err `shouldContain` "Headers"
68+ err `shouldContain` "Body"
11769
11870onlyJsonObjectSpec :: Spec
11971onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
12072
12173 it "fails correctly" $ do
122− FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
74+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
12375 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
12476 (onlyJsonObjects <%> mempty)
125− show err `shouldContain` "onlyJsonObjects"
126−
127− it "accepts non-JSON endpoints" $ do
128− withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
129− serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
130−
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)
77+ err `shouldContain` "onlyJsonObjects"
13478
135−notLongerThanSpec :: Spec
136−notLongerThanSpec = describe "notLongerThan" $ do
137−
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"
143−
144− it "succeeds correctly" $ do
145− withServantServerAndContext api ctx server $ \burl ->
146− serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)
14779
14880isComprehensiveSpec :: Spec
14981isComprehensiveSpec = describe "HasGenRequest" $ do
15082
15183 it "has instances for all 'servant' combinators" $ do
152− let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
84+ let _g = genRequest comprehensiveAPIWithoutRaw
15385 True `shouldBe` True -- This is a type-level check
15486
155−deepPathSpec :: Spec
156−deepPathSpec = describe "Path components" $ do
157−
158− it "are separated by slashes, without a trailing slash" $ do
159− let rng = mkQCGen 0
160− burl = BaseUrl Http "localhost" 80 ""
161− gen = runGenRequest deepAPI
162− req = (unGen gen rng 0) burl
163− path req `shouldBe` ("/one/two/three")
164−
165−
166−queryParamsSpec :: Spec
167−queryParamsSpec = describe "QueryParams" $ do
168−
169− it "reduce to an HTTP query string correctly" $ do
170− let rng = mkQCGen 0
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=_"
176−
177−queryFlagsSpec :: Spec
178−queryFlagsSpec = describe "QueryFlags" $ do
179−
180− it "reduce to an HTTP query string correctly" $ do
181− let rng = mkQCGen 0
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"
187−
188−htmlDocTypesSpec :: Spec
189−htmlDocTypesSpec = describe "HtmlDocTypes" $ do
190−
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"
196−
197− it "passes HTML with a doctype at start" $ do
198− withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
199− serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
200−
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)
205−
206−
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
211−
212−
213−unbiasedGenerationSpec :: Spec
214−unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
215−
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
22887
22988------------------------------------------------------------------------------
23089-- APIs
@@ -237,17 +96,6 @@ type API = ReqBody '[JSON] String :> Post '[JSON] String
23796api :: Proxy API
23897api = Proxy
23998
240−type ParamsAPI = QueryParam "one" () :> QueryParam "two" () :> Get '[JSON] ()
241−
242−paramsAPI :: Proxy ParamsAPI
243−paramsAPI = Proxy
244−
245−type FlagsAPI = QueryFlag "one" :> QueryFlag "two" :> Get '[JSON] ()
246−
247−flagsAPI :: Proxy FlagsAPI
248−flagsAPI = Proxy
249−
250−
25199server :: IO (Server API)
252100server = do
253101 mvar <- newMVar ""
@@ -261,105 +109,23 @@ type API2 = "failplz" :> Get '[JSON] Int
261109api2 :: Proxy API2
262110api2 = Proxy
263111
264−type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
265−
266−deepAPI :: Proxy DeepAPI
267−deepAPI = Proxy
268−
269−
270112server2 :: IO (Server API2)
271113server2 = return $ return 1
272114
273115server3 :: IO (Server API2)
274116server3 = return $ return 2
275117
276−serverFailing :: IO (Server API2)
277−serverFailing = return . throwError $ err405
278−
279−-- With Doctypes
280−type HtmlDoctype = Get '[HTML] Blaze.Html
281−
282−docTypeApi :: Proxy HtmlDoctype
283−docTypeApi = Proxy
284−
285−docTypeServer :: IO (Server HtmlDoctype)
286−docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
287−
288−noDocTypeServer :: IO (Server HtmlDoctype)
289−noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
290−
291−
292−-- Api for unbiased generation of requests tests
293−largeApi :: Proxy LargeAPI
294−largeApi = Proxy
295−
296−type 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
313−
314−
315−type OctetAPI = Get '[OctetStream] BS.ByteString
316−
317−octetAPI :: Proxy OctetAPI
318−octetAPI = Proxy
319−
320−serverOctetAPI :: IO (Server OctetAPI)
321−serverOctetAPI = return $ return "blah"
322−
323−type JsonApi = "jsonComparison" :> Get '[OctetStream] BS.ByteString
324−
325−jsonApi :: Proxy JsonApi
326−jsonApi = Proxy
327−
328−jsonServer1 :: IO (Server JsonApi)
329−jsonServer1 = return $ return "{ \"b\": [\"b\"], \"a\": 1 }" -- whitespace, ordering different
330−
331−jsonServer2 :: IO (Server JsonApi)
332−jsonServer2 = return $ return "{\"a\": 1,\"b\":[\"b\"]}"
333−
334−jsonServer3 :: IO (Server JsonApi)
335−jsonServer3 = return $ return "{\"a\": 2, \"b\": [\"b\"]}"
336−
337−jsonServer4 :: IO (Server JsonApi)
338−jsonServer4 = return $ return "{\"c\": 1, \"d\": [\"b\"]}"
339−
340−
341118ctx :: Context '[BasicAuthCheck ()]
342119ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
343120------------------------------------------------------------------------------
344121-- Utils
345122------------------------------------------------------------------------------
346−evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
347−evalExample e = do
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"
123+
124+evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
125+evalExample e = evaluateExample e defaultParams ($ ()) progCallback
353126 where
354127 progCallback _ = return ()
355128
356−data EvalResult
357− = AnException SomeException
358− | AllGood
359− | FailedWith String
360− deriving (Show)
361−
362−
363129args :: Args
364130args = defaultArgs { maxSuccess = noOfTestCases }
365131