Resolve merge conflicts with unbiasedGeneration merge

src/Servant/QuickCheck/Internal/HasGenRequest.hs

@@ -14,106 +14,130 @@ import Prelude.Compat
 import Servant
 import Servant.API.ContentTypes (AllMimeRender (..))
 import Servant.Client           (BaseUrl (..), Scheme (..))
-import Test.QuickCheck          (Arbitrary (..), Gen, elements, oneof)
+import Test.QuickCheck          (Arbitrary (..), Gen, elements, frequency)
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Internal as BS (c2w)
 
 
+-- -----------------------------------------------------------------------------
+-- runGenRequest
+
+-- | This function returns a QuickCheck `Gen a` when passed a servant API value,
+-- typically a `Proxy API`. The generator returned is a function
+-- that accepts a `BaseUrl` and returns a `Request`, which can then be used
+-- to issue network requests. This `Gen` type makes it easier to compare distinct
+-- APIs across different `BaseUrl`s.
+runGenRequest :: HasGenRequest a => Proxy a -> Gen (BaseUrl -> Request)
+runGenRequest = snd . genRequest
+
+
+-- -----------------------------------------------------------------------------
+-- HasGenRequest
+
+-- | This is the core Servant-Quickcheck generator, which, when given a `Proxy API`
+-- will return a pair of `Int` and `Gen a`, where `a` is a function from
+-- `BaseUrl` to a `Network.Http.Client.Request`. The `Int` is a weight for the
+-- QuickCheck `frequency` function which ensures a random distribution across
+-- all endpoints in an API.
 class HasGenRequest a where
-    genRequest :: Proxy a -> Gen (BaseUrl -> Request)
+    genRequest :: Proxy a -> (Int, Gen (BaseUrl -> Request))
+
 
 instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
     genRequest _
-      = oneof [ genRequest (Proxy :: Proxy a)
+      = (lf + rf, frequency [l, r])
-              , genRequest (Proxy :: Proxy b)
+      where
-              ]
+        l@(lf, _) = genRequest (Proxy :: Proxy a)
+        r@(rf, _) = genRequest (Proxy :: Proxy b)
+
 
 instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       old' <- old
       return $ \burl -> let r = old' burl
                             oldPath = path r
                             oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
                             paths = filter (not . BS.null) [new, oldPath']
-                            in r { path = "/" <> BS.intercalate "/" paths }
+                            in r { path = "/" <> BS.intercalate "/" paths })
       where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
         new = cs $ symbolVal (Proxy :: Proxy path)
 
+
 instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
     => HasGenRequest (Capture x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       old' <- old
       new' <- toUrlPiece <$> new
-      return $ \burl -> let r = old' burl in r { path = cs new' <> path r }
+      return $ \burl -> let r = old' burl in r { path = cs new' <> path r })
       where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
         new = arbitrary :: Gen c
 
 #if MIN_VERSION_servant(0,8,0)
 instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
     => HasGenRequest (CaptureAll x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       old' <- old
       new' <- fmap (cs . toUrlPiece) <$> new
       let new'' = BS.intercalate "/" new'
-      return $ \burl -> let r = old' burl in r { path = new'' <> path r }
+      return $ \burl -> let r = old' burl in r { path = new'' <> path r })
       where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
         new = arbitrary :: Gen [c]
 #endif
 
 instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
     => HasGenRequest (Header h c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       old' <- old
       new' <- toUrlPiece <$> new
       return $ \burl -> let r = old' burl in r {
-          requestHeaders = (hdr, cs new') : requestHeaders r }
+          requestHeaders = (hdr, cs new') : requestHeaders r })
       where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
         hdr = fromString $ symbolVal (Proxy :: Proxy h)
         new = arbitrary :: Gen c
 
 instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
     => HasGenRequest (ReqBody x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       old' <- old
       new' <- new
       (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
       return $ \burl -> let r = old' burl in r {
           requestBody = RequestBodyLBS bd
         , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
-        }
+        })
       where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
         new = arbitrary :: Gen c
 
 instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
     => HasGenRequest (QueryParam x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       new' <- new
       old' <- old
       return $ \burl -> let r = old' burl
                             newExpr = param <> "=" <> cs (toQueryParam new')
                             qs = queryString r in r {
-          queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs }
+          queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
       where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
         param = cs $ symbolVal (Proxy :: Proxy x)
         new = arbitrary :: Gen c
 
 instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
     => HasGenRequest (QueryParams x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       new' <- new
       old' <- old
       return $ \burl -> let r = old' burl in r {
           queryString = queryString r
-                     <> if length new' > 0 then fold (toParam <$> new') else ""}
+                     <> if length new' > 0 then fold (toParam <$> new') else ""})
       where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
         param = cs $ symbolVal (Proxy :: Proxy x)
         new = arbitrary :: Gen [c]
         toParam c = param <> "[]=" <> cs (toQueryParam c)
@@ -121,23 +145,23 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
 
 instance (KnownSymbol x, HasGenRequest b)
     => HasGenRequest (QueryFlag x :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       old' <- old
       return $ \burl -> let r = old' burl
                             qs = queryString r in r {
-          queryString = if BS.null qs then param else param <> "&" <> qs }
+          queryString = if BS.null qs then param else param <> "&" <> qs })
       where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
         param = cs $ symbolVal (Proxy :: Proxy x)
 
 instance (ReflectMethod method)
     => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
-    genRequest _ = return $ \burl -> defaultRequest
+    genRequest _ = (1, return $ \burl -> defaultRequest
        { host = cs $ baseUrlHost burl
        , port = baseUrlPort burl
        , secure = baseUrlScheme burl == Https
        , method = reflectMethod (Proxy :: Proxy method)
-       }
+       })
 
 instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
     genRequest _ = genRequest (Proxy :: Proxy a)

src/Servant/QuickCheck/Internal/QuickCheck.hs

@@ -70,7 +70,7 @@ withServantServerAndContext api ctx server t
 serversEqual :: HasGenRequest a =>
   Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
 serversEqual api burl1 burl2 args req = do
-  let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
+  let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
   -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
   -- return results when a test fails, since an exception is throw.
   deetsMVar <- newMVar $ error "should not be called"
@@ -111,7 +111,7 @@ serversEqual api burl1 burl2 args req = do
 serverSatisfies :: (HasGenRequest a) =>
   Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
 serverSatisfies api burl args preds = do
-  let reqs = ($ burl) <$> genRequest api
+  let reqs = ($ burl) <$> runGenRequest api
   deetsMVar <- newMVar $ error "should not be called"
   r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
      v <- run $ finishPredicates preds (noCheckStatus req) defManager
@@ -131,7 +131,7 @@ serverSatisfies api burl args preds = do
 serverDoesntSatisfy :: (HasGenRequest a) =>
   Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
 serverDoesntSatisfy api burl args preds = do
-  let reqs = ($ burl) <$> genRequest api
+  let reqs = ($ burl) <$> runGenRequest api
   r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
      v <- run $ finishPredicates preds (noCheckStatus req) defManager
      assert $ not $ null v

test/Servant/QuickCheck/InternalSpec.hs

@@ -1,20 +1,24 @@
 {-# LANGUAGE CPP #-}
 module Servant.QuickCheck.InternalSpec (spec) where
 
-import           Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
+
-import           Control.Exception
+import           Control.Concurrent.MVar      (newMVar, readMVar, swapMVar)
-import           Control.Monad.IO.Class  (liftIO)
+import           Control.Exception            (SomeException)
-import qualified Data.ByteString         as BS
+import           Control.Monad                (replicateM)
-import qualified Data.ByteString.Char8   as C
+import           Control.Monad.IO.Class       (liftIO)
+import qualified Data.ByteString              as BS
+import qualified Data.ByteString.Char8        as C
+import           Data.Maybe                   (fromJust)
 import           Prelude.Compat
 import           Servant
-import           Test.Hspec              (Spec, context, describe, it, shouldBe,
+import           Test.Hspec                   (Spec, context, describe, it, shouldBe,
-                                          shouldContain)
+                                               shouldContain)
-import           Test.Hspec.Core.Spec    (Arg, Example, Result (..),
+import           Test.Hspec.Core.Spec         (Arg, Example, Result (..),
-                                          defaultParams, safeEvaluateExample)
+                                               defaultParams, safeEvaluateExample)
-import           Test.QuickCheck.Gen     (unGen)
+import           Test.QuickCheck.Gen          (unGen, generate)
-import           Test.QuickCheck.Random  (mkQCGen)
+import           Test.QuickCheck.Random       (mkQCGen)
-import           Network.HTTP.Client     (queryString, path)
+import           Network.HTTP.Client          (queryString, path)
+
 
 #if MIN_VERSION_servant(0,8,0)
 import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
@@ -24,7 +28,8 @@ import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
 #endif
 
 import Servant.QuickCheck
-import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
+import Servant.QuickCheck.Internal (genRequest, runGenRequest, serverDoesntSatisfy)
+
 
 spec :: Spec
 spec = do
@@ -36,6 +41,7 @@ spec = do
   queryParamsSpec
   queryFlagsSpec
   deepPathSpec
+  unbiasedGenerationSpec
 
 serversEqualSpec :: Spec
 serversEqualSpec = describe "serversEqual" $ do
@@ -46,7 +52,6 @@ serversEqualSpec = describe "serversEqual" $ do
         serversEqual api burl1 burl2 args bodyEquality
 
   context "when servers are not equal" $ do
-
     it "provides the failing responses in the error message" $ do
       Right (Failure _ err) <- withServantServer api2 server2 $ \burl1 ->
         withServantServer api2 server3 $ \burl2 -> do
@@ -77,11 +82,12 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
 
     it "fails with informative error messages" $ do
       Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
-        safeEvalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
+        safeEvalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
-      show err `shouldContain` "getsHaveCacheControlHeader"
+      show err `shouldContain` "notAllowedContainsAllowHeader"
       show err `shouldContain` "Headers"
       show err `shouldContain` "Body"
 
+
 onlyJsonObjectSpec :: Spec
 onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
 
@@ -121,7 +127,7 @@ deepPathSpec = describe "Path components" $ do
   it "are separated by slashes, without a trailing slash" $ do
     let rng = mkQCGen 0
         burl = BaseUrl Http "localhost" 80 ""
-        gen = genRequest deepAPI
+        gen = runGenRequest deepAPI
         req = (unGen gen rng 0) burl
     path req `shouldBe` ("/one/two/three")
 
@@ -132,7 +138,7 @@ queryParamsSpec = describe "QueryParams" $ do
   it "reduce to an HTTP query string correctly" $ do
     let rng = mkQCGen 0
         burl = BaseUrl Http "localhost" 80 ""
-        gen = genRequest paramsAPI
+        gen = runGenRequest paramsAPI
         req = (unGen gen rng 0) burl
         qs = C.unpack $ queryString req
     qs `shouldBe` "one=_&two=_"
@@ -143,11 +149,33 @@ queryFlagsSpec = describe "QueryFlags" $ do
   it "reduce to an HTTP query string correctly" $ do
     let rng = mkQCGen 0
         burl = BaseUrl Http "localhost" 80 ""
-        gen = genRequest flagsAPI
+        gen = runGenRequest flagsAPI
         req = (unGen gen rng 0) burl
         qs = C.unpack $ queryString req
     qs `shouldBe` "one&two"
 
+makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
+makeRandomRequest large burl = do
+  req <- generate $ runGenRequest large
+  pure $ fst . fromJust . C.readInteger . C.drop 1 . path $ req burl
+
+
+unbiasedGenerationSpec :: Spec
+unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
+
+  it "frequency paired with generated endpoint should be more randomly distributed" $ do
+    let burl = BaseUrl Http "localhost" 80 ""
+    let runs = 10000 :: Double
+    someRequests <- replicateM 10000 (makeRandomRequest largeApi burl)
+    let mean = (sum $ map fromIntegral someRequests) / runs
+    let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
+    let variance = (sum $ map variancer someRequests) / runs - 1
+    -- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
+    mean > 8 `shouldBe` True
+    mean < 9 `shouldBe` True
+    -- Std dev is likely around 4. Variance is probably greater than 20.
+    variance > 19.5 `shouldBe` True
+
 ------------------------------------------------------------------------------
 -- APIs
 ------------------------------------------------------------------------------
@@ -195,6 +223,29 @@ server2 = return $ return 1
 server3 :: IO (Server API2)
 server3 = return $ return 2
 
+
+largeApi :: Proxy LargeAPI
+largeApi = Proxy
+
+type LargeAPI
+  =    "1" :> Get '[JSON] Int
+  :<|> "2" :> Get '[JSON] Int
+  :<|> "3" :> Get '[JSON] Int
+  :<|> "4" :> Get '[JSON] Int
+  :<|> "5" :> Get '[JSON] Int
+  :<|> "6" :> Get '[JSON] Int
+  :<|> "7" :> Get '[JSON] Int
+  :<|> "8" :> Get '[JSON] Int
+  :<|> "9" :> Get '[JSON] Int
+  :<|> "10" :> Get '[JSON] Int
+  :<|> "11" :> Get '[JSON] Int
+  :<|> "12" :> Get '[JSON] Int
+  :<|> "13" :> Get '[JSON] Int
+  :<|> "14" :> Get '[JSON] Int
+  :<|> "15" :> Get '[JSON] Int
+  :<|> "16" :> Get '[JSON] Int
+
+
 type OctetAPI = Get '[OctetStream] BS.ByteString
 
 octetAPI :: Proxy OctetAPI