ilyakooo0/servant-quickcheck
1
0
Fork 0
mirror of https://github.com/ilyakooo0/servant-quickcheck.git synced 2024-08-17 06:10:27 +03:00
Code Issues Packages Projects Releases Wiki Activity

Unbias generation of requests. (#19)

Browse Source 
* 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.
This commit is contained in:
Julian Arni 2017-10-14 07:53:04 -07:00 committed by Erik
parent e1a9db4924
commit 66ce50993f
3 changed files with 125 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
src/Servant/QuickCheck/Internal/HasGenRequest.hs
View File

@ -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)

6
src/Servant/QuickCheck/Internal/QuickCheck.hs
View File

@ -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

86
test/Servant/QuickCheck/InternalSpec.hs
View File

@ -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