@@ -2,32 +2,34 @@
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)
12−import Network.HTTP.Client (path, queryString)
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)
1312import Prelude.Compat
1413import Servant
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)
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)
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
2729
2830import Servant.QuickCheck
29−import Servant.QuickCheck.Internal (genRequest, runGenRequest,
30− serverDoesntSatisfy)
31+import Servant.QuickCheck.Internal (genRequest, runGenRequest, serverDoesntSatisfy)
32+
3133
3234spec :: Spec
3335spec = do
@@ -39,7 +41,6 @@ spec = do
3941 queryParamsSpec
4042 queryFlagsSpec
4143 deepPathSpec
42− htmlDocTypesSpec
4344 unbiasedGenerationSpec
4445
4546serversEqualSpec :: Spec
@@ -52,42 +53,14 @@ serversEqualSpec = describe "serversEqual" $ do
5253
5354 context "when servers are not equal" $ do
5455 it "provides the failing responses in the error message" $ do
55− FailedWith err <- withServantServer api2 server2 $ \burl1 ->
56+ Right (Failure _ err) <- withServantServer api2 server2 $ \burl1 ->
5657 withServantServer api2 server3 $ \burl2 -> do
57− evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
58+ safeEvalExample $ serversEqual api2 burl1 burl2 args bodyEquality
5859 show err `shouldContain` "Server equality failed"
5960 show err `shouldContain` "Body: 1"
6061 show err `shouldContain` "Body: 2"
6162 show err `shouldContain` "Path: /failplz"
6263
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−
9164serverSatisfiesSpec :: Spec
9265serverSatisfiesSpec = describe "serverSatisfies" $ do
9366
@@ -108,8 +81,8 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
10881 context "when predicates are false" $ do
10982
11083 it "fails with informative error messages" $ do
111− FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
112− evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
84+ Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
85+ safeEvalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
11386 show err `shouldContain` "notAllowedContainsAllowHeader"
11487 show err `shouldContain` "Headers"
11588 show err `shouldContain` "Body"
@@ -119,8 +92,8 @@ onlyJsonObjectSpec :: Spec
11992onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
12093
12194 it "fails correctly" $ do
122− FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
123− evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
95+ Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
96+ safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
12497 (onlyJsonObjects <%> mempty)
12598 show err `shouldContain` "onlyJsonObjects"
12699
@@ -128,16 +101,12 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
128101 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
129102 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
130103
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−
135104notLongerThanSpec :: Spec
136105notLongerThanSpec = describe "notLongerThan" $ do
137106
138107 it "fails correctly" $ do
139− FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
140− evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
108+ Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
109+ safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
141110 (notLongerThan 1 <%> mempty)
142111 show err `shouldContain` "notLongerThan"
143112
@@ -149,7 +118,7 @@ isComprehensiveSpec :: Spec
149118isComprehensiveSpec = describe "HasGenRequest" $ do
150119
151120 it "has instances for all 'servant' combinators" $ do
152− let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
121+ let _g = genRequest comprehensiveAPIWithoutRaw
153122 True `shouldBe` True -- This is a type-level check
154123
155124deepPathSpec :: Spec
@@ -185,25 +154,6 @@ queryFlagsSpec = describe "QueryFlags" $ do
185154 qs = C.unpack $ queryString req
186155 qs `shouldBe` "one&two"
187156
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−
207157makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
208158makeRandomRequest large burl = do
209159 req <- generate $ runGenRequest large
@@ -273,23 +223,7 @@ server2 = return $ return 1
273223server3 :: IO (Server API2)
274224server3 = return $ return 2
275225
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!"
287226
288−noDocTypeServer :: IO (Server HtmlDoctype)
289−noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
290−
291−
292−-- Api for unbiased generation of requests tests
293227largeApi :: Proxy LargeAPI
294228largeApi = Proxy
295229
@@ -320,45 +254,16 @@ octetAPI = Proxy
320254serverOctetAPI :: IO (Server OctetAPI)
321255serverOctetAPI = return $ return "blah"
322256
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−
341257ctx :: Context '[BasicAuthCheck ()]
342258ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
343259------------------------------------------------------------------------------
344260-- Utils
345261------------------------------------------------------------------------------
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"
262+safeEvalExample :: (Example e, Arg e ~ ()) => e -> IO (Either SomeException Result)
263+safeEvalExample e = safeEvaluateExample e defaultParams ($ ()) progCallback
353264 where
354265 progCallback _ = return ()
355266
356−data EvalResult
357− = AnException SomeException
358− | AllGood
359− | FailedWith String
360− deriving (Show)
361−
362267
363268args :: Args
364269args = defaultArgs { maxSuccess = noOfTestCases }
@@ -369,3 +274,8 @@ noOfTestCases = 20000
369274#else
370275noOfTestCases = 1000
371276#endif
277+
278+#if !MIN_VERSION_servant(0,8,0)
279+comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
280+comprehensiveAPIWithoutRaw = comprehensiveAPI
281+#endif