@@ -12,23 +12,33 @@ import Data.Maybe (fromJust)
1212import Network.HTTP.Client (path, queryString)
1313import Prelude.Compat
1414import Servant
15−import Servant.HTML.Blaze (HTML)
16−import qualified Text.Blaze.Html as Blaze
17−import qualified Text.Blaze.Html5 as Blaze5
1815import Test.Hspec (Spec, context, describe, it, shouldBe,
1916 shouldContain)
20−import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
21− defaultParams, safeEvaluateExample)
17+import Test.Hspec.Core.Spec (Arg, Example, Result (..),
18+ defaultParams)
2219import Test.QuickCheck.Gen (generate, unGen)
2320import Test.QuickCheck.Random (mkQCGen)
2421
2522
26−import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
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
29+
30+#if MIN_VERSION_hspec(2,4,0)
31+import Test.Hspec.Core.Spec (safeEvaluateExample)
32+#else
33+import Control.Exception (try)
34+import Test.Hspec.Core.Spec (evaluateExample)
35+#endif
2736
2837import Servant.QuickCheck
2938import Servant.QuickCheck.Internal (genRequest, runGenRequest,
3039 serverDoesntSatisfy)
3140
41+
3242spec :: Spec
3343spec = do
3444 serversEqualSpec
@@ -39,7 +49,6 @@ spec = do
3949 queryParamsSpec
4050 queryFlagsSpec
4151 deepPathSpec
42− htmlDocTypesSpec
4352 unbiasedGenerationSpec
4453
4554serversEqualSpec :: Spec
@@ -62,28 +71,22 @@ serversEqualSpec = describe "serversEqual" $ do
6271
6372 context "when JSON is equal but looks a bit different as a ByteString" $ do
6473
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
74+ it "considers equal JSON apis equal regardless of ordering or whitespace" $ do
7275 withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
7376 withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
7477 serversEqual jsonApi burl1 burl2 args jsonEquality
7578
76− it "sees when JSON apis are not equal because any value is different" $ do
77− FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
79+ it "sees when JSON apis are not equal regardless of ordering or whitespace" $ do
80+ Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
7881 withServantServer jsonApi jsonServer3 $ \burl2 -> do
79− evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
82+ safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
8083 show err `shouldContain` "Server equality failed"
8184 show err `shouldContain` "Path: /jsonComparison"
8285
8386 it "sees when JSON apis are not equal due to different keys but same values" $ do
84− FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
87+ Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
8588 withServantServer jsonApi jsonServer4 $ \burl2 -> do
86− evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
89+ safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
8790 show err `shouldContain` "Server equality failed"
8891 show err `shouldContain` "Path: /jsonComparison"
8992
@@ -128,10 +131,6 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
128131 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
129132 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
130133
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−
135134notLongerThanSpec :: Spec
136135notLongerThanSpec = describe "notLongerThan" $ do
137136
@@ -149,7 +148,7 @@ isComprehensiveSpec :: Spec
149148isComprehensiveSpec = describe "HasGenRequest" $ do
150149
151150 it "has instances for all 'servant' combinators" $ do
152− let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
151+ let _g = genRequest comprehensiveAPIWithoutRaw
153152 True `shouldBe` True -- This is a type-level check
154153
155154deepPathSpec :: Spec
@@ -185,25 +184,6 @@ queryFlagsSpec = describe "QueryFlags" $ do
185184 qs = C.unpack $ queryString req
186185 qs `shouldBe` "one&two"
187186
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−
207187makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
208188makeRandomRequest large burl = do
209189 req <- generate $ runGenRequest large
@@ -273,23 +253,7 @@ server2 = return $ return 1
273253server3 :: IO (Server API2)
274254server3 = return $ return 2
275255
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!"
287256
288−noDocTypeServer :: IO (Server HtmlDoctype)
289−noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
290−
291−
292−-- Api for unbiased generation of requests tests
293257largeApi :: Proxy LargeAPI
294258largeApi = Proxy
295259
@@ -344,14 +308,27 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
344308-- Utils
345309------------------------------------------------------------------------------
346310evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
311+#if MIN_VERSION_hspec(2,4,0)
347312evalExample e = do
348313 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"
314+ case r of
315+ Left err -> return $ AnException err
316+ Right Success -> return $ AllGood
317+ Right (Failure _ reason) -> return $ FailedWith $ show reason
318+ Right (Pending _) -> error "should not happen"
353319 where
354320 progCallback _ = return ()
321+#else
322+evalExample e = do
323+ r <- try $ evaluateExample e defaultParams ($ ()) progCallback
324+ case r of
325+ Left err -> return $ AnException err
326+ Right Success -> return $ AllGood
327+ Right (Fail _ reason) -> return $ FailedWith reason
328+ Right (Pending _) -> error "should not happen"
329+ where
330+ progCallback _ = return ()
331+#endif
355332
356333data EvalResult
357334 = AnException SomeException
@@ -369,3 +346,8 @@ noOfTestCases = 20000
369346#else
370347noOfTestCases = 1000
371348#endif
349+
350+#if !MIN_VERSION_servant(0,8,0)
351+comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
352+comprehensiveAPIWithoutRaw = comprehensiveAPI
353+#endif