From 66ce50993f45d5fa813b8108adc8263a8f6d13c6 Mon Sep 17 00:00:00 2001 From: Julian Arni Date: Sat, 14 Oct 2017 07:53:04 -0700 Subject: [PATCH] Unbias generation of requests. (#19) * Unbias generation of requests: ...so that each endpoint is picked with the same frequency. Also, include a test for unbiased generation that measures mean and variance of results. --- .../QuickCheck/Internal/HasGenRequest.hs | 86 ++++++++++++------- src/Servant/QuickCheck/Internal/QuickCheck.hs | 6 +- test/Servant/QuickCheck/InternalSpec.hs | 86 +++++++++++++++---- 3 files changed, 125 insertions(+), 53 deletions(-) diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs index 9ba7452..192a694 100644 --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/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) - , genRequest (Proxy :: Proxy b) - ] + = (lf + rf, frequency [l, r]) + 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) diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index fe30188..c68cd42 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -71,7 +71,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" @@ -113,7 +113,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 @@ -133,7 +133,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 diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 3cf9716..7dc9db3 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -1,19 +1,21 @@ {-# LANGUAGE CPP #-} module Servant.QuickCheck.InternalSpec (spec) where -import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) -import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C +import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) +import Control.Monad (replicateM) +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, - shouldContain) -import Test.Hspec.Core.Spec (Arg, Example, Result (..), - defaultParams, evaluateExample) -import Test.QuickCheck.Gen (unGen) -import Test.QuickCheck.Random (mkQCGen) -import Network.HTTP.Client (queryString, path) +import Test.Hspec (Spec, context, describe, it, shouldBe, + shouldContain) +import Test.Hspec.Core.Spec (Arg, Example, Result (..), + defaultParams, evaluateExample) +import Test.QuickCheck.Gen (unGen, generate) +import Test.QuickCheck.Random (mkQCGen) +import Network.HTTP.Client (queryString, path) #if MIN_VERSION_servant(0,8,0) import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw) @@ -23,7 +25,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 @@ -35,6 +38,7 @@ spec = do queryParamsSpec queryFlagsSpec deepPathSpec + unbiasedGenerationSpec serversEqualSpec :: Spec serversEqualSpec = describe "serversEqual" $ do @@ -45,8 +49,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 Fail _ err <- withServantServer api2 server2 $ \burl1 -> withServantServer api2 server3 $ \burl2 -> do @@ -76,11 +78,12 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do it "fails with informative error messages" $ do Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do - evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty) - err `shouldContain` "getsHaveCacheControlHeader" + evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty) + err `shouldContain` "notAllowedContainsAllowHeader" err `shouldContain` "Headers" err `shouldContain` "Body" + onlyJsonObjectSpec :: Spec onlyJsonObjectSpec = describe "onlyJsonObjects" $ do @@ -120,7 +123,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") @@ -131,7 +134,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=_" @@ -142,11 +145,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 + mean > 7 `shouldBe` True + mean < 9 `shouldBe` True + -- Std dev is likely around 4. Variance is probably greater than 20. + variance > 19.5 `shouldBe` True + ------------------------------------------------------------------------------ -- APIs ------------------------------------------------------------------------------ @@ -194,6 +219,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