@@ -14,106 +14,130 @@ import Prelude.Compat
1414import Servant
1515import Servant.API.ContentTypes (AllMimeRender (..))
1616import Servant.Client (BaseUrl (..), Scheme (..))
17−import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)
17+import Test.QuickCheck (Arbitrary (..), Gen, elements, frequency)
1818
1919import qualified Data.ByteString as BS
2020import qualified Data.ByteString.Internal as BS (c2w)
2121
2222
23+-- -----------------------------------------------------------------------------
24+-- runGenRequest
25+
26+-- | This function returns a QuickCheck `Gen a` when passed a servant API value,
27+-- typically a `Proxy API`. The generator returned is a function
28+-- that accepts a `BaseUrl` and returns a `Request`, which can then be used
29+-- to issue network requests. This `Gen` type makes it easier to compare distinct
30+-- APIs across different `BaseUrl`s.
31+runGenRequest :: HasGenRequest a => Proxy a -> Gen (BaseUrl -> Request)
32+runGenRequest = snd . genRequest
33+
34+
35+-- -----------------------------------------------------------------------------
36+-- HasGenRequest
37+
38+-- | This is the core Servant-Quickcheck generator, which, when given a `Proxy API`
39+-- will return a pair of `Int` and `Gen a`, where `a` is a function from
40+-- `BaseUrl` to a `Network.Http.Client.Request`. The `Int` is a weight for the
41+-- QuickCheck `frequency` function which ensures a random distribution across
42+-- all endpoints in an API.
2343class HasGenRequest a where
24− genRequest :: Proxy a -> Gen (BaseUrl -> Request)
44+ genRequest :: Proxy a -> (Int, Gen (BaseUrl -> Request))
45+
2546
2647instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
2748 genRequest _
28− = oneof [ genRequest (Proxy :: Proxy a)
29− , genRequest (Proxy :: Proxy b)
30− ]
49+ = (lf + rf, frequency [l, r])
50+ where
51+ l@(lf, _) = genRequest (Proxy :: Proxy a)
52+ r@(rf, _) = genRequest (Proxy :: Proxy b)
53+
3154
3255instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
33− genRequest _ = do
56+ genRequest _ = (oldf, do
3457 old' <- old
3558 return $ \burl -> let r = old' burl
3659 oldPath = path r
3760 oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
3861 paths = filter (not . BS.null) [new, oldPath']
39− in r { path = "/" <> BS.intercalate "/" paths }
62+ in r { path = "/" <> BS.intercalate "/" paths })
4063 where
41− old = genRequest (Proxy :: Proxy b)
64+ (oldf, old) = genRequest (Proxy :: Proxy b)
4265 new = cs $ symbolVal (Proxy :: Proxy path)
4366
67+
4468instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
4569 => HasGenRequest (Capture x c :> b) where
46− genRequest _ = do
70+ genRequest _ = (oldf, do
4771 old' <- old
4872 new' <- toUrlPiece <$> new
49− return $ \burl -> let r = old' burl in r { path = cs new' <> path r }
73+ return $ \burl -> let r = old' burl in r { path = cs new' <> path r })
5074 where
51− old = genRequest (Proxy :: Proxy b)
75+ (oldf, old) = genRequest (Proxy :: Proxy b)
5276 new = arbitrary :: Gen c
5377
5478#if MIN_VERSION_servant(0,8,0)
5579instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
5680 => HasGenRequest (CaptureAll x c :> b) where
57− genRequest _ = do
81+ genRequest _ = (oldf, do
5882 old' <- old
5983 new' <- fmap (cs . toUrlPiece) <$> new
6084 let new'' = BS.intercalate "/" new'
61− return $ \burl -> let r = old' burl in r { path = new'' <> path r }
85+ return $ \burl -> let r = old' burl in r { path = new'' <> path r })
6286 where
63− old = genRequest (Proxy :: Proxy b)
87+ (oldf, old) = genRequest (Proxy :: Proxy b)
6488 new = arbitrary :: Gen [c]
6589#endif
6690
6791instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
6892 => HasGenRequest (Header h c :> b) where
69− genRequest _ = do
93+ genRequest _ = (oldf, do
7094 old' <- old
7195 new' <- toUrlPiece <$> new
7296 return $ \burl -> let r = old' burl in r {
73− requestHeaders = (hdr, cs new') : requestHeaders r }
97+ requestHeaders = (hdr, cs new') : requestHeaders r })
7498 where
75− old = genRequest (Proxy :: Proxy b)
99+ (oldf, old) = genRequest (Proxy :: Proxy b)
76100 hdr = fromString $ symbolVal (Proxy :: Proxy h)
77101 new = arbitrary :: Gen c
78102
79103instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
80104 => HasGenRequest (ReqBody x c :> b) where
81− genRequest _ = do
105+ genRequest _ = (oldf, do
82106 old' <- old
83107 new' <- new
84108 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
85109 return $ \burl -> let r = old' burl in r {
86110 requestBody = RequestBodyLBS bd
87111 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
88− }
112+ })
89113 where
90− old = genRequest (Proxy :: Proxy b)
114+ (oldf, old) = genRequest (Proxy :: Proxy b)
91115 new = arbitrary :: Gen c
92116
93117instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
94118 => HasGenRequest (QueryParam x c :> b) where
95− genRequest _ = do
119+ genRequest _ = (oldf, do
96120 new' <- new
97121 old' <- old
98122 return $ \burl -> let r = old' burl
99123 newExpr = param <> "=" <> cs (toQueryParam new')
100124 qs = queryString r in r {
101− queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs }
125+ queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
102126 where
103− old = genRequest (Proxy :: Proxy b)
127+ (oldf, old) = genRequest (Proxy :: Proxy b)
104128 param = cs $ symbolVal (Proxy :: Proxy x)
105129 new = arbitrary :: Gen c
106130
107131instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
108132 => HasGenRequest (QueryParams x c :> b) where
109− genRequest _ = do
133+ genRequest _ = (oldf, do
110134 new' <- new
111135 old' <- old
112136 return $ \burl -> let r = old' burl in r {
113137 queryString = queryString r
114− <> if length new' > 0 then fold (toParam <$> new') else ""}
138+ <> if length new' > 0 then fold (toParam <$> new') else ""})
115139 where
116− old = genRequest (Proxy :: Proxy b)
140+ (oldf, old) = genRequest (Proxy :: Proxy b)
117141 param = cs $ symbolVal (Proxy :: Proxy x)
118142 new = arbitrary :: Gen [c]
119143 toParam c = param <> "[]=" <> cs (toQueryParam c)
@@ -121,23 +145,23 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
121145
122146instance (KnownSymbol x, HasGenRequest b)
123147 => HasGenRequest (QueryFlag x :> b) where
124− genRequest _ = do
148+ genRequest _ = (oldf, do
125149 old' <- old
126150 return $ \burl -> let r = old' burl
127151 qs = queryString r in r {
128− queryString = if BS.null qs then param else param <> "&" <> qs }
152+ queryString = if BS.null qs then param else param <> "&" <> qs })
129153 where
130− old = genRequest (Proxy :: Proxy b)
154+ (oldf, old) = genRequest (Proxy :: Proxy b)
131155 param = cs $ symbolVal (Proxy :: Proxy x)
132156
133157instance (ReflectMethod method)
134158 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
135− genRequest _ = return $ \burl -> defaultRequest
159+ genRequest _ = (1, return $ \burl -> defaultRequest
136160 { host = cs $ baseUrlHost burl
137161 , port = baseUrlPort burl
138162 , secure = baseUrlScheme burl == Https
139163 , method = reflectMethod (Proxy :: Proxy method)
140− }
164+ })
141165
142166instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
143167 genRequest _ = genRequest (Proxy :: Proxy a)