mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-08-17 06:10:27 +03:00
Resolve merge conflicts with unbiasedGeneration merge
This commit is contained in:
commit
f3b4fcf7a9
@ -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)
|
||||
|
@ -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
|
||||
|
@ -1,20 +1,24 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Servant.QuickCheck.InternalSpec (spec) where
|
||||
|
||||
import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
|
||||
import Control.Exception
|
||||
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.Exception (SomeException)
|
||||
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, safeEvaluateExample)
|
||||
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, safeEvaluateExample)
|
||||
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)
|
||||
@ -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)
|
||||
show err `shouldContain` "getsHaveCacheControlHeader"
|
||||
safeEvalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
|
||||
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
|
||||
|
Loading…
Reference in New Issue
Block a user