@@ -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
@@ -71,22 +62,28 @@ serversEqualSpec = describe "serversEqual" $ do
7162
7263 context "when JSON is equal but looks a bit different as a ByteString" $ do
7364
74− it "considers equal JSON apis equal regardless of ordering or whitespace" $ do
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
7572 withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
7673 withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
7774 serversEqual jsonApi burl1 burl2 args jsonEquality
7875
79− it "sees when JSON apis are not equal regardless of ordering or whitespace" $ do
80− Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
76+ it "sees when JSON apis are not equal because any value is different" $ do
77+ FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
8178 withServantServer jsonApi jsonServer3 $ \burl2 -> do
82− safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
79+ evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
8380 show err `shouldContain` "Server equality failed"
8481 show err `shouldContain` "Path: /jsonComparison"
8582
8683 it "sees when JSON apis are not equal due to different keys but same values" $ do
87− Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
84+ FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
8885 withServantServer jsonApi jsonServer4 $ \burl2 -> do
89− safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
86+ evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
9087 show err `shouldContain` "Server equality failed"
9188 show err `shouldContain` "Path: /jsonComparison"
9289
@@ -131,6 +128,10 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
131128 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
132129 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
133130
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+
134135notLongerThanSpec :: Spec
135136notLongerThanSpec = describe "notLongerThan" $ do
136137
@@ -148,7 +149,7 @@ isComprehensiveSpec :: Spec
148149isComprehensiveSpec = describe "HasGenRequest" $ do
149150
150151 it "has instances for all 'servant' combinators" $ do
151− let _g = genRequest comprehensiveAPIWithoutRaw
152+ let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
152153 True `shouldBe` True -- This is a type-level check
153154
154155deepPathSpec :: Spec
@@ -184,6 +185,25 @@ queryFlagsSpec = describe "QueryFlags" $ do
184185 qs = C.unpack $ queryString req
185186 qs `shouldBe` "one&two"
186187
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+
187207makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
188208makeRandomRequest large burl = do
189209 req <- generate $ runGenRequest large
@@ -253,7 +273,23 @@ server2 = return $ return 1
253273server3 :: IO (Server API2)
254274server3 = return $ return 2
255275
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!"
256287
288+noDocTypeServer :: IO (Server HtmlDoctype)
289+noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
290+
291+
292+-- Api for unbiased generation of requests tests
257293largeApi :: Proxy LargeAPI
258294largeApi = Proxy
259295
@@ -308,27 +344,14 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
308344-- Utils
309345------------------------------------------------------------------------------
310346evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
311−#if MIN_VERSION_hspec(2,4,0)
312347evalExample e = do
313348 r <- safeEvaluateExample e defaultParams ($ ()) progCallback
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"
349+ case resultStatus r of
350+ Success -> return $ AllGood
351+ Failure _ reason -> return $ FailedWith $ show reason
352+ Pending {} -> error "should not happen"
319353 where
320354 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
332355
333356data EvalResult
334357 = AnException SomeException
@@ -346,8 +369,3 @@ noOfTestCases = 20000
346369#else
347370noOfTestCases = 1000
348371#endif
349−
350−#if !MIN_VERSION_servant(0,8,0)
351−comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
352−comprehensiveAPIWithoutRaw = comprehensiveAPI
353−#endif