@@ -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
@@ -63,9 +72,9 @@ serversEqualSpec = describe "serversEqual" $ do
6372 context "when JSON is equal but looks a bit different as a ByteString" $ do
6473
6574 it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
66− FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
75+ Right (Failure _ err) <- withServantServer jsonApi jsonServer1 $ \burl1 ->
6776 withServantServer jsonApi jsonServer2 $ \burl2 -> do
68− evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
77+ safeEvalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
6978 show err `shouldContain` "Server equality failed"
7079
7180 it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
@@ -74,16 +83,16 @@ serversEqualSpec = describe "serversEqual" $ do
7483 serversEqual jsonApi burl1 burl2 args jsonEquality
7584
7685 it "sees when JSON apis are not equal because any value is different" $ do
77− FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
86+ Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
7887 withServantServer jsonApi jsonServer3 $ \burl2 -> do
79− evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
88+ safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
8089 show err `shouldContain` "Server equality failed"
8190 show err `shouldContain` "Path: /jsonComparison"
8291
8392 it "sees when JSON apis are not equal due to different keys but same values" $ do
84− FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
93+ Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
8594 withServantServer jsonApi jsonServer4 $ \burl2 -> do
86− evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
95+ safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
8796 show err `shouldContain` "Server equality failed"
8897 show err `shouldContain` "Path: /jsonComparison"
8998
@@ -128,10 +137,6 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
128137 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
129138 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
130139
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−
135140notLongerThanSpec :: Spec
136141notLongerThanSpec = describe "notLongerThan" $ do
137142
@@ -149,7 +154,7 @@ isComprehensiveSpec :: Spec
149154isComprehensiveSpec = describe "HasGenRequest" $ do
150155
151156 it "has instances for all 'servant' combinators" $ do
152− let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
157+ let _g = genRequest comprehensiveAPIWithoutRaw
153158 True `shouldBe` True -- This is a type-level check
154159
155160deepPathSpec :: Spec
@@ -185,25 +190,6 @@ queryFlagsSpec = describe "QueryFlags" $ do
185190 qs = C.unpack $ queryString req
186191 qs `shouldBe` "one&two"
187192
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−
207193makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
208194makeRandomRequest large burl = do
209195 req <- generate $ runGenRequest large
@@ -273,23 +259,7 @@ server2 = return $ return 1
273259server3 :: IO (Server API2)
274260server3 = return $ return 2
275261
276−serverFailing :: IO (Server API2)
277−serverFailing = return . throwError $ err405
278262
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
293263largeApi :: Proxy LargeAPI
294264largeApi = Proxy
295265
@@ -344,14 +314,27 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
344314-- Utils
345315------------------------------------------------------------------------------
346316evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
317+#if MIN_VERSION_hspec(2,4,0)
347318evalExample e = do
348319 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"
320+ case r of
321+ Left err -> return $ AnException err
322+ Right Success -> return $ AllGood
323+ Right (Failure _ reason) -> return $ FailedWith $ show reason
324+ Right (Pending _) -> error "should not happen"
325+ where
326+ progCallback _ = return ()
327+#else
328+evalExample e = do
329+ r <- try $ evaluateExample e defaultParams ($ ()) progCallback
330+ case r of
331+ Left err -> return $ AnException err
332+ Right Success -> return $ AllGood
333+ Right (Fail _ reason) -> return $ FailedWith reason
334+ Right (Pending _) -> error "should not happen"
353335 where
354336 progCallback _ = return ()
337+#endif
355338
356339data EvalResult
357340 = AnException SomeException
@@ -369,3 +352,8 @@ noOfTestCases = 20000
369352#else
370353noOfTestCases = 1000
371354#endif
355+
356+#if !MIN_VERSION_servant(0,8,0)
357+comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
358+comprehensiveAPIWithoutRaw = comprehensiveAPI
359+#endif