@@ -12,33 +12,23 @@ 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
1518import Test.Hspec (Spec, context, describe, it, shouldBe,
1619 shouldContain)
17−import Test.Hspec.Core.Spec (Arg, Example, Result (..),
18− defaultParams)
20+import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
21+ defaultParams, safeEvaluateExample)
1922import Test.QuickCheck.Gen (generate, unGen)
2023import 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
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
26+import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
3627
3728import Servant.QuickCheck
3829import Servant.QuickCheck.Internal (genRequest, runGenRequest,
3930 serverDoesntSatisfy)
4031
41−
4232spec :: Spec
4333spec = do
4434 serversEqualSpec
@@ -49,6 +39,7 @@ spec = do
4939 queryParamsSpec
5040 queryFlagsSpec
5141 deepPathSpec
42+ htmlDocTypesSpec
5243 unbiasedGenerationSpec
5344
5445serversEqualSpec :: Spec
@@ -72,9 +63,9 @@ serversEqualSpec = describe "serversEqual" $ do
7263 context "when JSON is equal but looks a bit different as a ByteString" $ do
7364
7465 it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
75− Right (Failure _ err) <- withServantServer jsonApi jsonServer1 $ \burl1 ->
66+ FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
7667 withServantServer jsonApi jsonServer2 $ \burl2 -> do
77− safeEvalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
68+ evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
7869 show err `shouldContain` "Server equality failed"
7970
8071 it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
@@ -83,16 +74,16 @@ serversEqualSpec = describe "serversEqual" $ do
8374 serversEqual jsonApi burl1 burl2 args jsonEquality
8475
8576 it "sees when JSON apis are not equal because any value is different" $ do
86− Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
77+ FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
8778 withServantServer jsonApi jsonServer3 $ \burl2 -> do
88− safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
79+ evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
8980 show err `shouldContain` "Server equality failed"
9081 show err `shouldContain` "Path: /jsonComparison"
9182
9283 it "sees when JSON apis are not equal due to different keys but same values" $ do
93− Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
84+ FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
9485 withServantServer jsonApi jsonServer4 $ \burl2 -> do
95− safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
86+ evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
9687 show err `shouldContain` "Server equality failed"
9788 show err `shouldContain` "Path: /jsonComparison"
9889
@@ -137,6 +128,10 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
137128 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
138129 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
139130
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+
140135notLongerThanSpec :: Spec
141136notLongerThanSpec = describe "notLongerThan" $ do
142137
@@ -154,7 +149,7 @@ isComprehensiveSpec :: Spec
154149isComprehensiveSpec = describe "HasGenRequest" $ do
155150
156151 it "has instances for all 'servant' combinators" $ do
157− let _g = genRequest comprehensiveAPIWithoutRaw
152+ let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
158153 True `shouldBe` True -- This is a type-level check
159154
160155deepPathSpec :: Spec
@@ -190,6 +185,25 @@ queryFlagsSpec = describe "QueryFlags" $ do
190185 qs = C.unpack $ queryString req
191186 qs `shouldBe` "one&two"
192187
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+
193207makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
194208makeRandomRequest large burl = do
195209 req <- generate $ runGenRequest large
@@ -259,7 +273,23 @@ server2 = return $ return 1
259273server3 :: IO (Server API2)
260274server3 = return $ return 2
261275
276+serverFailing :: IO (Server API2)
277+serverFailing = return . throwError $ err405
262278
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
263293largeApi :: Proxy LargeAPI
264294largeApi = Proxy
265295
@@ -314,27 +344,14 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
314344-- Utils
315345------------------------------------------------------------------------------
316346evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
317−#if MIN_VERSION_hspec(2,4,0)
318347evalExample e = do
319348 r <- safeEvaluateExample e defaultParams ($ ()) progCallback
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"
349+ case resultStatus r of
350+ Success -> return $ AllGood
351+ Failure _ reason -> return $ FailedWith $ show reason
352+ Pending {} -> error "should not happen"
335353 where
336354 progCallback _ = return ()
337−#endif
338355
339356data EvalResult
340357 = AnException SomeException
@@ -352,8 +369,3 @@ noOfTestCases = 20000
352369#else
353370noOfTestCases = 1000
354371#endif
355−
356−#if !MIN_VERSION_servant(0,8,0)
357−comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
358−comprehensiveAPIWithoutRaw = comprehensiveAPI
359−#endif