@@ -2,34 +2,32 @@
22module Servant.QuickCheck.InternalSpec (spec) where
33
44
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)
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)
1213import Prelude.Compat
1314import Servant
14−import Test.Hspec (Spec, context, describe, it, shouldBe,
15− shouldContain)
16−import Test.Hspec.Core.Spec (Arg, Example, Result (..),
17− defaultParams, safeEvaluateExample)
18−import Test.QuickCheck.Gen (unGen, generate)
19−import Test.QuickCheck.Random (mkQCGen)
20−import Network.HTTP.Client (queryString, path)
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)
2124
2225
23−#if MIN_VERSION_servant(0,8,0)
24−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
25−#else
26−import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
27− comprehensiveAPI)
28−#endif
26+import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
2927
3028import Servant.QuickCheck
31−import Servant.QuickCheck.Internal (genRequest, runGenRequest, serverDoesntSatisfy)
32−
29+import Servant.QuickCheck.Internal (genRequest, runGenRequest,
30+ serverDoesntSatisfy)
3331
3432spec :: Spec
3533spec = do
@@ -41,6 +39,7 @@ spec = do
4139 queryParamsSpec
4240 queryFlagsSpec
4341 deepPathSpec
42+ htmlDocTypesSpec
4443 unbiasedGenerationSpec
4544
4645serversEqualSpec :: Spec
@@ -53,14 +52,42 @@ serversEqualSpec = describe "serversEqual" $ do
5352
5453 context "when servers are not equal" $ do
5554 it "provides the failing responses in the error message" $ do
56− Right (Failure _ err) <- withServantServer api2 server2 $ \burl1 ->
55+ FailedWith err <- withServantServer api2 server2 $ \burl1 ->
5756 withServantServer api2 server3 $ \burl2 -> do
58− safeEvalExample $ serversEqual api2 burl1 burl2 args bodyEquality
57+ evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
5958 show err `shouldContain` "Server equality failed"
6059 show err `shouldContain` "Body: 1"
6160 show err `shouldContain` "Body: 2"
6261 show err `shouldContain` "Path: /failplz"
6362
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+
90+
6491serverSatisfiesSpec :: Spec
6592serverSatisfiesSpec = describe "serverSatisfies" $ do
6693
@@ -81,8 +108,8 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
81108 context "when predicates are false" $ do
82109
83110 it "fails with informative error messages" $ do
84− Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
85− safeEvalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
111+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
112+ evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
86113 show err `shouldContain` "notAllowedContainsAllowHeader"
87114 show err `shouldContain` "Headers"
88115 show err `shouldContain` "Body"
@@ -92,8 +119,8 @@ onlyJsonObjectSpec :: Spec
92119onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
93120
94121 it "fails correctly" $ do
95− Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
96− safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
122+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
123+ evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
97124 (onlyJsonObjects <%> mempty)
98125 show err `shouldContain` "onlyJsonObjects"
99126
@@ -101,12 +128,16 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
101128 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
102129 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
103130
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)
134+
104135notLongerThanSpec :: Spec
105136notLongerThanSpec = describe "notLongerThan" $ do
106137
107138 it "fails correctly" $ do
108− Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
109− safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
139+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
140+ evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
110141 (notLongerThan 1 <%> mempty)
111142 show err `shouldContain` "notLongerThan"
112143
@@ -118,7 +149,7 @@ isComprehensiveSpec :: Spec
118149isComprehensiveSpec = describe "HasGenRequest" $ do
119150
120151 it "has instances for all 'servant' combinators" $ do
121− let _g = genRequest comprehensiveAPIWithoutRaw
152+ let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
122153 True `shouldBe` True -- This is a type-level check
123154
124155deepPathSpec :: Spec
@@ -154,6 +185,25 @@ queryFlagsSpec = describe "QueryFlags" $ do
154185 qs = C.unpack $ queryString req
155186 qs `shouldBe` "one&two"
156187
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+
157207makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
158208makeRandomRequest large burl = do
159209 req <- generate $ runGenRequest large
@@ -223,7 +273,23 @@ server2 = return $ return 1
223273server3 :: IO (Server API2)
224274server3 = return $ return 2
225275
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!"
226287
288+noDocTypeServer :: IO (Server HtmlDoctype)
289+noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
290+
291+
292+-- Api for unbiased generation of requests tests
227293largeApi :: Proxy LargeAPI
228294largeApi = Proxy
229295
@@ -254,16 +320,45 @@ octetAPI = Proxy
254320serverOctetAPI :: IO (Server OctetAPI)
255321serverOctetAPI = return $ return "blah"
256322
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+
257341ctx :: Context '[BasicAuthCheck ()]
258342ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
259343------------------------------------------------------------------------------
260344-- Utils
261345------------------------------------------------------------------------------
262−safeEvalExample :: (Example e, Arg e ~ ()) => e -> IO (Either SomeException Result)
263−safeEvalExample e = safeEvaluateExample e defaultParams ($ ()) progCallback
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"
264353 where
265354 progCallback _ = return ()
266355
356+data EvalResult
357+ = AnException SomeException
358+ | AllGood
359+ | FailedWith String
360+ deriving (Show)
361+
267362
268363args :: Args
269364args = defaultArgs { maxSuccess = noOfTestCases }
@@ -274,8 +369,3 @@ noOfTestCases = 20000
274369#else
275370noOfTestCases = 1000
276371#endif
277−
278−#if !MIN_VERSION_servant(0,8,0)
279−comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
280−comprehensiveAPIWithoutRaw = comprehensiveAPI
281−#endif