mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-08-16 22:00:32 +03:00
Rewrite.
Being lazy without a new full intepretation isn't paying off.
This commit is contained in:
Julian K. Arni
parent
bf4efbcb8c
commit
2050487058
@ -22,7 +22,7 @@ library
|
||||
, Servant.QuickCheck.Internal
|
||||
, Servant.QuickCheck.Internal.Benchmarking
|
||||
, Servant.QuickCheck.Internal.Predicates
|
||||
, Servant.QuickCheck.Internal.Testable
|
||||
, Servant.QuickCheck.Internal.HasGenRequest
|
||||
, Servant.QuickCheck.Internal.QuickCheck
|
||||
build-depends: base >=4.8 && <4.9
|
||||
, QuickCheck == 2.8.*
|
||||
@ -31,8 +31,11 @@ library
|
||||
, mtl == 2.2.*
|
||||
, http-client == 0.4.*
|
||||
, http-types == 0.9.*
|
||||
, http-media
|
||||
, servant-client == 0.7.*
|
||||
, servant-server == 0.7.*
|
||||
, string-conversions == 0.4.*
|
||||
, data-default-class == 0.0.*
|
||||
, servant == 0.7.*
|
||||
, warp >= 3.2.4 && < 3.3
|
||||
, process == 1.2.*
|
||||
@ -46,9 +49,12 @@ library
|
||||
, GADTs
|
||||
, MultiParamTypeClasses
|
||||
, DeriveFunctor
|
||||
, KindSignatures
|
||||
, RankNTypes
|
||||
, ConstraintKinds
|
||||
, DeriveGeneric
|
||||
, ScopedTypeVariables
|
||||
, OverloadedStrings
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite spec
|
||||
@ -67,6 +73,7 @@ test-suite spec
|
||||
, servant-client
|
||||
, transformers
|
||||
, QuickCheck
|
||||
, quickcheck-io
|
||||
default-extensions: TypeOperators
|
||||
, FlexibleInstances
|
||||
, FlexibleContexts
|
||||
|
||||
@ -19,76 +19,11 @@
|
||||
module Servant.QuickCheck
|
||||
(
|
||||
|
||||
-- * Server properties
|
||||
-- | Functions to verify that a server meets certain properties.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > server :: Server API
|
||||
-- > server = return . show
|
||||
-- >
|
||||
-- >
|
||||
-- > test :: Spec
|
||||
-- > test = describe "my server" $ do
|
||||
-- >
|
||||
-- > it "never throws a 500 on valid input" $ do
|
||||
-- > withServantServer api server $ \url ->
|
||||
-- > serverSatisfiers api url emptyPredicates never500s 100
|
||||
serverSatisfies
|
||||
|
||||
-- * Server equality
|
||||
-- | Functions to verify that two servers behave identically.
|
||||
--
|
||||
-- This can be useful when for example rewriting or refactoring an
|
||||
-- application.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > server :: Server API
|
||||
-- > server = return . show
|
||||
-- >
|
||||
-- > server2 :: Server API
|
||||
-- > server2 = const $ return "hi"
|
||||
-- >
|
||||
-- > test :: Spec
|
||||
-- > test = describe "my new server" $ do
|
||||
-- >
|
||||
-- > it "behaves like the old one" $ do
|
||||
-- > withServantServer api server $ \url1 ->
|
||||
-- > withServantServer api server2 $ \url2 ->
|
||||
-- > serversEqual api url1 url2 100
|
||||
--
|
||||
, serversEqual
|
||||
|
||||
-- * Server benchmarking
|
||||
-- | Functions that randomly generate and run benchmarking scripts
|
||||
, serverBenchmark
|
||||
, BenchOptions(..)
|
||||
, defaultBenchOptions
|
||||
|
||||
|
||||
serversEqual
|
||||
-- * Test setup helpers
|
||||
-- | Helpers to setup and teardown @servant@ servers during tests.
|
||||
, withServantServer
|
||||
|
||||
-- * Predicates
|
||||
-- | Predicates (functions with signatures @a -> Bool@) are used to filter
|
||||
-- out QuickCheck-generated values (so as to specify that requests must
|
||||
-- possess certain properties) and to check that the response specifies the
|
||||
-- expected properties.
|
||||
, Predicates
|
||||
, emptyPredicates
|
||||
, addPredicate
|
||||
, addPolyPredicate
|
||||
|
||||
-- ** Predicate convenience functions
|
||||
, addRightPredicate
|
||||
, addLeftPredicate
|
||||
|
||||
-- ** Useful predicates
|
||||
, never500s
|
||||
, onlyJsonObjects
|
||||
|
||||
-- ** Re-exports
|
||||
, BaseUrl(..)
|
||||
, Scheme(..)
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Servant.QuickCheck.Internal (module X) where
|
||||
|
||||
import Servant.QuickCheck.Internal.Testable as X
|
||||
import Servant.QuickCheck.Internal.HasGenRequest as X
|
||||
import Servant.QuickCheck.Internal.Predicates as X
|
||||
import Servant.QuickCheck.Internal.QuickCheck as X
|
||||
import Servant.QuickCheck.Internal.Benchmarking as X
|
||||
|
||||
93
src/Servant/QuickCheck/Internal/HasGenRequest.hs
Normal file
93
src/Servant/QuickCheck/Internal/HasGenRequest.hs
Normal file
@ -0,0 +1,93 @@
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
module Servant.QuickCheck.Internal.HasGenRequest where
|
||||
|
||||
import Data.Default.Class (def)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import GHC.TypeLits
|
||||
import Network.HTTP.Client (Request, RequestBody (..), host,
|
||||
method, path, port, requestBody,
|
||||
requestHeaders, secure, queryString)
|
||||
import Network.HTTP.Media (renderHeader)
|
||||
import Servant
|
||||
import Servant.API.ContentTypes
|
||||
import Servant.Client (BaseUrl (..), Scheme (..))
|
||||
import Test.QuickCheck
|
||||
|
||||
|
||||
class HasGenRequest a where
|
||||
genRequest :: Proxy a -> Gen (BaseUrl -> Request)
|
||||
|
||||
instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
|
||||
genRequest _
|
||||
= oneof [ genRequest (Proxy :: Proxy a)
|
||||
, genRequest (Proxy :: Proxy b)
|
||||
]
|
||||
|
||||
instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
|
||||
genRequest _ = do
|
||||
old' <- old
|
||||
return $ \burl -> let r = old' burl in r { path = new <> "/" <> path r }
|
||||
where
|
||||
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
|
||||
old' <- old
|
||||
new' <- toUrlPiece <$> new
|
||||
return $ \burl -> let r = old' burl in r { path = cs new' <> "/" <> path r }
|
||||
where
|
||||
old = genRequest (Proxy :: Proxy b)
|
||||
new = arbitrary :: Gen c
|
||||
|
||||
instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
|
||||
=> HasGenRequest (Header h c :> b) where
|
||||
genRequest _ = do
|
||||
old' <- old
|
||||
new' <- toUrlPiece <$> new
|
||||
return $ \burl -> let r = old' burl in r {
|
||||
requestHeaders = (hdr, cs new') : requestHeaders r }
|
||||
where
|
||||
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
|
||||
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)
|
||||
new = arbitrary :: Gen c
|
||||
|
||||
instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
||||
=> HasGenRequest (QueryParam x c :> b) where
|
||||
genRequest _ = do
|
||||
new' <- new
|
||||
old' <- old
|
||||
return $ \burl -> let r = old' burl in r {
|
||||
queryString = queryString r
|
||||
<> param <> "=" <> cs (toQueryParam new') }
|
||||
where
|
||||
old = genRequest (Proxy :: Proxy b)
|
||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
||||
new = arbitrary :: Gen c
|
||||
|
||||
instance (ReflectMethod method)
|
||||
=> HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
|
||||
genRequest _ = return $ \burl -> def
|
||||
{ host = cs $ baseUrlHost burl
|
||||
, port = baseUrlPort burl
|
||||
, secure = baseUrlScheme burl == Https
|
||||
, method = reflectMethod (Proxy :: Proxy method)
|
||||
}
|
||||
|
||||
@ -1,132 +1,149 @@
|
||||
-- | This module contains all logic related to constructing or using
|
||||
-- @Predicates@.
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.QuickCheck.Internal.Predicates where
|
||||
|
||||
import Data.Aeson (ToJSON (toJSON), Value (..))
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.Void
|
||||
import Network.HTTP.Types (statusCode)
|
||||
import Servant.Common.Req (ServantError (..))
|
||||
import Test.QuickCheck
|
||||
import Data.Monoid ((<>))
|
||||
import GHC.Generics (Generic)
|
||||
import Control.Monad
|
||||
import Network.HTTP.Client (Request, Response)
|
||||
|
||||
|
||||
-- | An HList containing predicates (functions of type @a -> Bool@). This
|
||||
-- datatype is used to represent both filters (what values to discard when
|
||||
-- generating arguments to test an API) and tests results (what to consider a
|
||||
-- failing response).
|
||||
{-
|
||||
-- | @500 Internal Server Error@ should be avoided - it may represent some
|
||||
-- issue with the application code, and it moreover gives the client little
|
||||
-- indication of how to proceed or what went wrong.
|
||||
--
|
||||
-- For both filters and test results, only the *first* predicate of the
|
||||
-- appropriate type is used.
|
||||
--
|
||||
-- Use 'emptyPredicates', 'addPredicate', 'addLeftPredicate' and
|
||||
-- 'addRightPredicate' to construct a @Predicates@.
|
||||
data Predicates a where
|
||||
HNil :: Predicates '[]
|
||||
HCons :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
|
||||
HConsC :: Constraint a -> Predicates b -> Predicates (Constraint a ': b)
|
||||
-- This function checks that the response code is not 500.
|
||||
not500 :: Response b -> IO Bool
|
||||
not500
|
||||
= ResponsePredicate "not500" _
|
||||
|
||||
class HasPredicate a b where
|
||||
getPredicate :: Predicates a -> b -> Bool
|
||||
|
||||
instance {-# OVERLAPPING #-} HasPredicate '[] a where
|
||||
getPredicate _ = const True
|
||||
|
||||
-- TODO: Find some better way of distinguishing how the predicate is being used
|
||||
instance {-# OVERLAPPING #-} HasPredicate '[] (Either ServantError a) where
|
||||
getPredicate _ = discard
|
||||
|
||||
instance {-# OVERLAPPING #-} HasPredicate (a ': xs) a where
|
||||
getPredicate (HCons a _) = a
|
||||
getPredicate (HConsC _ _) = error "not impossible, but non-sensical"
|
||||
|
||||
data Constraint ctx = Constraint
|
||||
{ getConstraint :: forall a . (ctx a) => a -> Bool }
|
||||
|
||||
-- This is a little bit of a hack. Ideally instances would match when the
|
||||
-- predicate is polymorphic, but that doesn't work since the polymorphic type
|
||||
-- may have to unify with multiple distict values.
|
||||
--
|
||||
-- It may however be possible to define a MPTC from monomorphic to polymorphic
|
||||
-- datatypes to avoid this issue.
|
||||
instance {-# OVERLAPPING #-}
|
||||
HasPredicate (Either ServantError Void ': xs) (Either ServantError a) where
|
||||
getPredicate (HCons f _) x = case x of
|
||||
Left e -> f (Left e)
|
||||
Right _ -> True
|
||||
|
||||
instance {-# OVERLAPPING #-} (ctx a)
|
||||
=> HasPredicate (Constraint ctx ': xs) (Either ServantError a) where
|
||||
getPredicate (HConsC f _) x = case x of
|
||||
Left _ -> discard -- Not clear whether checking for FailureResponse is better
|
||||
Right v -> getConstraint f v
|
||||
getPredicate (HCons _ _) _ = error "not impossible, but non-sensical"
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (ls ~ (b ': xs), HasPredicate xs a)
|
||||
=> HasPredicate ls a where
|
||||
getPredicate (HCons _ xs) = getPredicate xs
|
||||
getPredicate _ = error "impossible"
|
||||
|
||||
-- | Add a predicate to a list of predicates. Note that the predicate may not
|
||||
-- be polymorphic.
|
||||
addPredicate :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
|
||||
addPredicate = HCons
|
||||
|
||||
-- | Add a predicate with a class constraint.
|
||||
--
|
||||
-- Note that every possible argument must be an instance of that class for this
|
||||
-- to typecheck. In other words, if the @Predicates@ is being used for return
|
||||
-- types, every return type in the API must be an instance of the class. If
|
||||
-- it's being used for filtering, every capture, header, body, etc. type must
|
||||
-- be an instance of that class.
|
||||
--
|
||||
-- This can be used to for example test that returned JSON has certain
|
||||
-- properties, or (via generics) that if any datatype contains a (possibly
|
||||
-- nested) field of a particular type, it always meets certain properties.
|
||||
addPolyPredicate :: proxy ctx -> (forall a. ctx a => a -> Bool) -> Predicates b
|
||||
-> Predicates (Constraint ctx ': b)
|
||||
addPolyPredicate _ p = HConsC (Constraint p)
|
||||
|
||||
-- | Given a predicate over an @p :: a -> Bool@, add a predicate to the @Predicates@
|
||||
-- list that succeeds on an @val :: Either ServantError a@ if @val@ is a
|
||||
-- @Left@, or a @Right v@ such that @p a == True@.
|
||||
addRightPredicate :: (a -> Bool) -> Predicates b -> Predicates (Either ServantError a ': b)
|
||||
addRightPredicate p = addPredicate $ either (const True) p
|
||||
|
||||
-- | The @Left@ analog of 'addRightPredicate'.
|
||||
addLeftPredicate :: (ServantError -> Bool) -> Predicates b
|
||||
-> Predicates (Either ServantError Void ': b)
|
||||
addLeftPredicate p = addPredicate $ either p (error "impossible")
|
||||
|
||||
-- | An empty list of predicates. This doesn't discard any values when used as
|
||||
-- a filter, and doesn't fail any value when used as a condition to satisfy.
|
||||
emptyPredicates :: Predicates '[]
|
||||
emptyPredicates = HNil
|
||||
|
||||
-- * Useful predicates
|
||||
|
||||
-- | A @Predicates@ list that fails a test if the response is an HTTP 500 error.
|
||||
never500s :: Predicates '[Either ServantError Void]
|
||||
never500s = addLeftPredicate go emptyPredicates
|
||||
where
|
||||
go (FailureResponse x _ _) = statusCode x /= 500
|
||||
go _ = True
|
||||
|
||||
-- | A @Predicates@ list that fails a test if the response is anything but a
|
||||
-- top-level object (e.g., if it is an array or literal).
|
||||
--
|
||||
-- Returning anything other than object is considered bad practice, as
|
||||
-- | Returning anything other than an object when returning JSON is considered
|
||||
-- bad practice, as:
|
||||
--
|
||||
-- (1) it is hard to modify the returned value while maintaining backwards
|
||||
-- compatibility;
|
||||
-- (2) many older tools do not support top-level arrays;
|
||||
-- compatibility
|
||||
-- (2) many older tools do not support top-level arrays
|
||||
-- (3) whether top-level numbers, booleans, or strings are valid JSON depends
|
||||
-- on what RFC you're going by;
|
||||
-- (4) there are security issues with top-level arrays.
|
||||
onlyJsonObjects :: Predicates '[Constraint ToJSON]
|
||||
onlyJsonObjects = addPolyPredicate (Proxy :: Proxy ToJSON) go emptyPredicates
|
||||
where
|
||||
go x = case toJSON x of
|
||||
Object _ -> True
|
||||
_ -> False
|
||||
-- on what RFC you're going by
|
||||
-- (4) there are security issues with top-level arrays
|
||||
--
|
||||
-- This function checks that any @application/json@ responses only return JSON
|
||||
-- objects (and not arrays, strings, numbers, or booleans) at the top level.
|
||||
onlyJsonObjects :: Response b -> IO Bool
|
||||
onlyJsonObjects
|
||||
= ResponsePredicate "onlyJsonObjects" _
|
||||
|
||||
-- | When creating a new resource, it is good practice to provide a @Location@
|
||||
-- header with a link to the created resource.
|
||||
--
|
||||
-- This function checks that every @201 Created@ response contains a @Location@
|
||||
-- header, and that the link in it responds with a 2XX response code to @GET@
|
||||
-- requests.
|
||||
--
|
||||
-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
|
||||
createContainsValidLocation :: Response b -> IO Bool
|
||||
createContainsValidLocation
|
||||
= ResponsePredicate "createContainsValidLocation" _
|
||||
|
||||
getsHaveLastModifiedHeader :: Response b -> IO Bool
|
||||
getsHaveLastModifiedHeader
|
||||
= ResponsePredicate "getsHaveLastModifiedHeader" _
|
||||
|
||||
-- | When an HTTP request has a method that is not allowed, a 405 response
|
||||
-- should be returned. Additionally, it is good practice to return an @Allow@
|
||||
-- header with the list of allowed methods.
|
||||
--
|
||||
-- This function checks that every @405 Method Not Allowed@ response contains
|
||||
-- an @Allow@ header with a list of standard HTTP methods.
|
||||
notAllowedContainsAllowHeader :: Response b -> IO Bool
|
||||
notAllowedContainsAllowHeader
|
||||
= ResponsePredicate "notAllowedContainsAllowHeader" _
|
||||
|
||||
-- | When a request contains an @Accept@ header, the server must either return
|
||||
-- content in one of the requested representations, or respond with @406 Not
|
||||
-- Acceptable@.
|
||||
--
|
||||
-- This function checks that every *successful* response has a @Content-Type@
|
||||
-- header that matches the @Accept@ header.
|
||||
honoursAcceptHeader :: Predicate b Bool
|
||||
honoursAcceptHeader
|
||||
= RequestPredicate "honoursAcceptHeader" _
|
||||
|
||||
-- | Whether or not a representation should be cached, it is good practice to
|
||||
-- have a @Cache-Control@ header for @GET@ requests. If the representation
|
||||
-- should not be cached, used @Cache-Control: no-cache@.
|
||||
--
|
||||
-- This function checks that @GET@ responses have a valid @Cache-Control@
|
||||
-- header.
|
||||
--
|
||||
-- References: RFC 7234 Section 5.2
|
||||
-- https://tools.ietf.org/html/rfc7234#section-5.2
|
||||
getsHaveCacheControlHeader :: Predicate b Bool
|
||||
getsHaveCacheControlHeader
|
||||
= ResponsePredicate "getsHaveCacheControlHeader" _
|
||||
|
||||
-- | Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
|
||||
headsHaveCacheControlHeader :: Predicate b Bool
|
||||
headsHaveCacheControlHeader
|
||||
= ResponsePredicate "headsHaveCacheControlHeader" _
|
||||
|
||||
-- |
|
||||
--
|
||||
-- If the original request modifies the resource, this function makes two
|
||||
-- requests:
|
||||
--
|
||||
-- (1) Once, with the original request and a future date as the
|
||||
-- @If-Unmodified-Since@, which is expected to succeed.
|
||||
-- (2) Then with the original request again, with a @If-Unmodified-Since@
|
||||
-- safely in the past. Since presumably the representation has been changed
|
||||
-- recently (by the first request), this is expected to fail with @412
|
||||
-- Precondition Failure@.
|
||||
--
|
||||
-- Note that the heuristic used to guess whether the original request modifies
|
||||
-- a resource is simply whether the method is @PUT@ or @PATCH@, which may be
|
||||
-- incorrect in certain circumstances.
|
||||
supportsIfUnmodifiedSince :: Predicate b Bool
|
||||
supportsIfUnmodifiedSince
|
||||
= ResponsePredicate "supportsIfUnmodifiedSince" _
|
||||
|
||||
-- | @OPTIONS@ responses should contain an @Allow@ header with the list of
|
||||
-- allowed methods.
|
||||
--
|
||||
-- If a request is an @OPTIONS@ request, and if the response is a successful
|
||||
-- one, this function checks the response for an @Allow@ header. It fails if:
|
||||
--
|
||||
-- (1) There is no @Allow@ header
|
||||
-- (2) The @Allow@ header does not have standard HTTP methods in the correct
|
||||
-- format
|
||||
-- (3) Making a request to the same URL with one of those methods results in
|
||||
-- a 404 or 405.
|
||||
optionsContainsValidAllow :: Predicate b Bool
|
||||
optionsContainsValidAllow
|
||||
= ResponsePredicate "optionsContainsValidAllow" _
|
||||
|
||||
-- | Link headers are a standardized way of presenting links that may be
|
||||
-- relevant to a client.
|
||||
--
|
||||
-- This function checks that any @Link@ headers have values in the correct
|
||||
-- format.
|
||||
--
|
||||
-- References: RFC 5988 Section 5
|
||||
-- https://tools.ietf.org/html/rfc5988
|
||||
linkHeadersAreValid :: Predicate b Bool
|
||||
linkHeadersAreValid
|
||||
= ResponsePredicate "linkHeadersAreValid" _
|
||||
|
||||
-- | Any @401 Unauthorized@ response must include a @WWW-Authenticate@ header.
|
||||
--
|
||||
-- This function checks that, if a response has status code 401, it contains a
|
||||
-- @WWW-Authenticate@ header.
|
||||
--
|
||||
-- References: RFC 7235 Section 4.1
|
||||
-- https://tools.ietf.org/html/rfc7235#section-4.1
|
||||
unauthorizedContainsWWWAuthenticate :: Predicate b Bool
|
||||
unauthorizedContainsWWWAuthenticate
|
||||
= ResponsePredicate "unauthorizedContainsWWWAuthenticate" _
|
||||
-}
|
||||
|
||||
data Predicate b r
|
||||
= ResponsePredicate String (Response b -> IO r)
|
||||
| RequestPredicate String (Request -> [Response b -> IO r] -> IO r)
|
||||
deriving (Generic)
|
||||
|
||||
@ -7,7 +7,7 @@ import Control.Monad (replicateM_)
|
||||
import Data.Proxy (Proxy)
|
||||
import Data.Void (Void)
|
||||
import Network.HTTP.Client (Manager, defaultManagerSettings,
|
||||
newManager)
|
||||
newManager, httpLbs)
|
||||
import Network.HTTP.Client (managerModifyRequest, getUri)
|
||||
import Network.Wai.Handler.Warp (withApplication)
|
||||
import Servant (HasServer, Server, serve)
|
||||
@ -18,11 +18,11 @@ import System.IO.Temp (withSystemTempFile)
|
||||
import System.Mem (performGC)
|
||||
import System.Process (callCommand)
|
||||
import Test.Hspec (Expectation, expectationFailure)
|
||||
import Test.QuickCheck (Args (..), Property, Result (..),
|
||||
Testable, property,
|
||||
import Test.QuickCheck (Args (..), Property, forAll, Result (..),
|
||||
Testable, property, ioProperty,
|
||||
quickCheckWithResult, stdArgs)
|
||||
|
||||
import Servant.QuickCheck.Internal.Testable
|
||||
import Servant.QuickCheck.Internal.HasGenRequest
|
||||
import Servant.QuickCheck.Internal.Predicates
|
||||
import Servant.QuickCheck.Internal.Benchmarking
|
||||
|
||||
@ -35,27 +35,6 @@ withServantServer api server t
|
||||
= withApplication (return . serve api =<< server) $ \port ->
|
||||
t (BaseUrl Http "localhost" port "")
|
||||
|
||||
-- | A QuickCheck 'Property' that randomly generates arguments (captures, query
|
||||
-- params, request bodies, headers, etc.) expected by endpoints of a server,
|
||||
-- and makes requests to the servers running in the two provided URLs in the
|
||||
-- same order, failing if they do not return the same response.
|
||||
--
|
||||
-- Evidently, if the behaviour of the server is expected to be
|
||||
-- non-deterministic, this function may produce spurious failures.
|
||||
--
|
||||
-- Note that this QuickCheck 'Property' does IO; interleaving it with other IO
|
||||
-- actions will not work. It is provided so that it can be used with QuickCheck
|
||||
-- functions such as 'quickCheckWith'. For most use cases, you should use
|
||||
-- @serversEqual@ or @servantServersEqual@.
|
||||
serversEqualProperty :: (HasClient a, Testable (ShouldMatch (Client a)))
|
||||
=> Proxy a -> Manager -> BaseUrl -> BaseUrl -> Property
|
||||
serversEqualProperty api mgr burl1 burl2
|
||||
= property $ ShouldMatch
|
||||
{ smClient = client api
|
||||
, smManager = mgr
|
||||
, smBaseUrls = (burl1, burl2)
|
||||
}
|
||||
|
||||
-- | Check that the two servers running under the provided @BaseUrl@s behave
|
||||
-- identically by randomly generating arguments (captures, query params, request bodies,
|
||||
-- headers, etc.) expected by the server. If, given the same request, the
|
||||
@ -66,103 +45,14 @@ serversEqualProperty api mgr burl1 burl2
|
||||
-- run.
|
||||
--
|
||||
-- Evidently, if the behaviour of the server is expected to be
|
||||
-- non-deterministic, this function may produce spurious failures.
|
||||
serversEqual :: (HasClient a, Testable (ShouldMatch (Client a)))
|
||||
=> Proxy a -> BaseUrl -> BaseUrl -> Int -> Expectation
|
||||
serversEqual api burl1 burl2 tries = do
|
||||
mgr <- managerWithStoredReq
|
||||
let args = stdArgs { chatty = False, maxSuccess = tries }
|
||||
res <- quickCheckWithResult args $ serversEqualProperty api mgr burl1 burl2
|
||||
case res of
|
||||
Success _ _ _ -> return ()
|
||||
_ -> prettyErr >>= expectationFailure
|
||||
-- non-deterministic, this function may produce spurious failures
|
||||
serversEqual :: HasGenRequest a =>
|
||||
Proxy a -> BaseUrl -> BaseUrl -> Manager -> Property
|
||||
serversEqual api burl1 burl2 mgr =
|
||||
let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
|
||||
in forAll reqs $ \(req1, req2) -> ioProperty $ do
|
||||
resp1 <- httpLbs req1 mgr
|
||||
resp2 <- httpLbs req2 mgr
|
||||
return $ resp1 == resp2
|
||||
|
||||
|
||||
serverSatisfiesProperty :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
|
||||
=> Proxy a -> Manager -> BaseUrl -> Predicates filt -> Predicates exp -> Property
|
||||
serverSatisfiesProperty api mgr burl filters expect = do
|
||||
property $ ShouldSatisfy
|
||||
{ ssVal = client api
|
||||
, ssFilter = filters
|
||||
, ssExpect = expect
|
||||
, ssManager = mgr
|
||||
, ssBaseUrl = burl
|
||||
}
|
||||
|
||||
-- | Check that a server's responses satisfies certain properties.
|
||||
serverSatisfies :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
|
||||
=> Proxy a -> BaseUrl -> Predicates filt -> Predicates exp
|
||||
-> Int -> Expectation
|
||||
serverSatisfies api burl filters expect tries = do
|
||||
mgr <- managerWithStoredReq
|
||||
let args = stdArgs { chatty = False, maxSuccess = tries }
|
||||
res <- quickCheckWithResult args $ serverSatisfiesProperty api mgr burl filters expect
|
||||
case res of
|
||||
Success _ _ _ -> return ()
|
||||
GaveUp n _ _ -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
||||
_ -> prettyErr >>= expectationFailure
|
||||
|
||||
-- | Check that the two servers running under the provided @BaseUrl@s do not
|
||||
-- behave identically.
|
||||
--
|
||||
-- As with @serversEqualProperty@, non-determinism in the servers will likely
|
||||
-- result in failures that may not be significant.
|
||||
serversUnequal :: (HasClient a, Testable (ShouldMatch (Client a)))
|
||||
=> Proxy a -> BaseUrl -> BaseUrl -> Int -> Expectation
|
||||
serversUnequal api burl1 burl2 tries = do
|
||||
mgr <- managerWithStoredReq
|
||||
let args = stdArgs { chatty = False, maxSuccess = tries }
|
||||
res <- quickCheckWithResult args $ serversEqualProperty api mgr burl1 burl2
|
||||
case res of
|
||||
Success _ _ _ -> prettyErr >>= expectationFailure
|
||||
_ -> return ()
|
||||
|
||||
serverDoesntSatisfy :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
|
||||
=> Proxy a -> BaseUrl -> Predicates filt -> Predicates exp
|
||||
-> Int -> Expectation
|
||||
serverDoesntSatisfy api burl filters expect tries = do
|
||||
mgr <- managerWithStoredReq
|
||||
let args = stdArgs { chatty = False, maxSuccess = tries }
|
||||
res <- quickCheckWithResult args $ serverSatisfiesProperty api mgr burl filters expect
|
||||
case res of
|
||||
Success _ _ _ -> prettyErr >>= expectationFailure
|
||||
_ -> return ()
|
||||
|
||||
-- | Benchmarks a server with arbitrary requests using 'wrk'.
|
||||
--
|
||||
-- When using this, you should compile your program with '-threaded'.
|
||||
-- Moreover, 'wrk' must be in the @$PATH@.
|
||||
--
|
||||
-- Note that this function is still very experimental, and it's behaviour will
|
||||
-- likely change.
|
||||
serverBenchmark ::
|
||||
(HasClient a , Testable (ShouldSatisfy '[] '[Either ServantError Void] (Client a)))
|
||||
=> Proxy a -> BaseUrl -> BenchOptions -> IO ()
|
||||
serverBenchmark api burl opts = replicateM_ (noOfTests opts) go
|
||||
where
|
||||
go = do
|
||||
let alwaysTrue = addLeftPredicate (const True) emptyPredicates
|
||||
serverSatisfies api burl emptyPredicates alwaysTrue 1
|
||||
Just (r, _) <- readMVar currentReq
|
||||
withSystemTempFile "wrkscript.lua" $ \f h -> do
|
||||
let url = show $ getUri r
|
||||
s = mkScript $ reqToWrk r
|
||||
c = "wrk -c" ++ show (connections opts)
|
||||
++ " -d" ++ show (duration opts) ++ "s "
|
||||
++ " -t" ++ show (threads opts)
|
||||
++ " -s \"" ++ f ++ "\" "
|
||||
++ " --latency "
|
||||
++ url
|
||||
hPutStrLn h s
|
||||
hFlush h
|
||||
callCommand c
|
||||
-- While running wrk and the server on the same machine make the
|
||||
-- results much less meaningful, this ameliorates the situation
|
||||
-- somewhat.
|
||||
performGC
|
||||
threadDelay 1000
|
||||
|
||||
managerWithStoredReq :: IO Manager
|
||||
managerWithStoredReq = newManager defaultManagerSettings { managerModifyRequest = go }
|
||||
where go req = modifyMVar_ currentReq (addReq req) >> return req
|
||||
addReq req _ = return $ Just (req, "")
|
||||
|
||||
@ -1,111 +0,0 @@
|
||||
-- | This module contains QuickCheck-related logic.
|
||||
module Servant.QuickCheck.Internal.Testable where
|
||||
|
||||
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
|
||||
import Control.Monad.Except (runExceptT, ExceptT)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Client (Request, RequestBody (..),
|
||||
requestBody, Manager)
|
||||
import Servant.API ((:<|>)(..))
|
||||
import Servant.Client (ServantError (..), BaseUrl)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.QuickCheck (Arbitrary (..), discard)
|
||||
import Test.QuickCheck.Property (Testable (..), forAllShrink,
|
||||
ioProperty, (.&.))
|
||||
|
||||
import Servant.QuickCheck.Internal.Predicates
|
||||
|
||||
|
||||
type FinalClient a = Manager -> BaseUrl -> ExceptT ServantError IO a
|
||||
|
||||
-- * ShouldMatch
|
||||
|
||||
-- | Two corresponding client functions. Used for checking that APIs match.
|
||||
data ShouldMatch a = ShouldMatch
|
||||
{ smClient :: a
|
||||
, smManager :: Manager
|
||||
, smBaseUrls :: (BaseUrl, BaseUrl)
|
||||
} deriving (Functor, Generic)
|
||||
|
||||
instance {-# OVERLAPPING #-} (Show a, Eq a)
|
||||
=> Testable (ShouldMatch (FinalClient a)) where
|
||||
property sm = ioProperty $ do
|
||||
let (burl1, burl2) = smBaseUrls sm
|
||||
e1' <- runExceptT $ smClient sm (smManager sm) burl1
|
||||
e2' <- runExceptT $ smClient sm (smManager sm) burl2
|
||||
modifyMVar_ currentReq $ \x -> case x of
|
||||
Nothing -> error "impossible"
|
||||
Just (x', _) -> return $ Just (x', "LHS:\n" ++ show e1'
|
||||
++ "\nRHS:\n" ++ show e2')
|
||||
case (e1', e2') of
|
||||
(Right v1, Right v2) -> return $ v1 == v2
|
||||
(Left (FailureResponse a1 b1 c1), Left (FailureResponse a2 b2 c2)) ->
|
||||
return $ a1 == a2 && b1 == b2 && c1 == c2
|
||||
(err1, err2) -> error $ "Exception response:"
|
||||
++ "\nLHS:\n" ++ show err1
|
||||
++ "\nRHS:\n" ++ show err2
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (Arbitrary a, Show a, Testable (ShouldMatch b))
|
||||
=> Testable (ShouldMatch (a -> b)) where
|
||||
property sm = forAllShrink arbitrary shrink go
|
||||
where go x = ($ x) <$> sm
|
||||
|
||||
instance (Testable (ShouldMatch a), Testable (ShouldMatch b))
|
||||
=> Testable (ShouldMatch (a :<|> b)) where
|
||||
property sm = property (fstAlt <$> sm) .&. property (sndAlt <$> sm)
|
||||
|
||||
-- * ShouldSatisfy
|
||||
|
||||
data ShouldSatisfy filter expect a = ShouldSatisfy
|
||||
{ ssVal :: a
|
||||
, ssFilter :: Predicates filter
|
||||
, ssExpect :: Predicates expect
|
||||
, ssManager :: Manager
|
||||
, ssBaseUrl :: BaseUrl
|
||||
} deriving (Functor)
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
(Show a, Eq a, HasPredicate expect (Either ServantError a))
|
||||
=> Testable (ShouldSatisfy filter expect (FinalClient a)) where
|
||||
property ss = ioProperty $ do
|
||||
a' <- runExceptT $ ssVal ss (ssManager ss) (ssBaseUrl ss)
|
||||
modifyMVar_ currentReq $ \x -> case x of
|
||||
Nothing -> error "impossible"
|
||||
Just (x', _) -> return $ Just (x', show a')
|
||||
return $ getPredicate (ssExpect ss) a'
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
|
||||
, HasPredicate filter a)
|
||||
=> Testable (ShouldSatisfy filter expect (a -> b)) where
|
||||
property ss = forAllShrink arbitrary shrink go
|
||||
where go x | getPredicate (ssFilter ss) x = ($ x) <$> ss
|
||||
| otherwise = discard
|
||||
|
||||
instance ( Testable (ShouldSatisfy filter expect a)
|
||||
, Testable (ShouldSatisfy filter expect b))
|
||||
=> Testable (ShouldSatisfy filter expect (a :<|> b)) where
|
||||
property ss = property (fstAlt <$> ss) .&. property (sndAlt <$> ss)
|
||||
|
||||
-- * Utils
|
||||
|
||||
fstAlt :: (a :<|> b) -> a
|
||||
fstAlt (a :<|> _) = a
|
||||
|
||||
sndAlt :: (a :<|> b) -> b
|
||||
sndAlt (_ :<|> b) = b
|
||||
|
||||
-- Used to store the current request and response so that in case of failure we
|
||||
-- have the failing test in a user-friendly form.
|
||||
currentReq :: MVar (Maybe (Request, String))
|
||||
currentReq = unsafePerformIO $ newMVar Nothing
|
||||
{-# NOINLINE currentReq #-}
|
||||
|
||||
prettyErr :: IO String
|
||||
prettyErr = do
|
||||
Just (req, resp) <- readMVar currentReq
|
||||
return $ show req ++ "Body:\n" ++ showReqBody (requestBody req)
|
||||
++ "\n\nResponse:\n" ++ resp
|
||||
where
|
||||
showReqBody (RequestBodyLBS x) = show x
|
||||
showReqBody _ = error "expecting RequestBodyLBS"
|
||||
@ -4,157 +4,47 @@ module Servant.QuickCheck.InternalSpec (spec) where
|
||||
|
||||
import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad (void)
|
||||
import Network.HTTP.Client (newManager, defaultManagerSettings)
|
||||
import Data.Proxy
|
||||
import Servant
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.IO
|
||||
import Test.QuickCheck.Monadic
|
||||
|
||||
import Servant.QuickCheck.Internal
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
serversEqualSpec
|
||||
serverSatisfiesSpec
|
||||
serverBenchmarkSpec
|
||||
|
||||
|
||||
serversEqualSpec :: Spec
|
||||
serversEqualSpec = describe "serversEqual" $ do
|
||||
|
||||
context "servers without function types" $ do
|
||||
|
||||
it "considers equal servers equal" $ do
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
|
||||
serversEqual onlyReturnAPI burl burl noOfTestCases
|
||||
|
||||
it "considers unequal servers unequal" $ do
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl1 ->
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer' $ \burl2 ->
|
||||
serversUnequal onlyReturnAPI burl1 burl2 noOfTestCases
|
||||
it "considers equal servers equal" $ do
|
||||
mgr <- newManager defaultManagerSettings
|
||||
withServantServer api server $ \burl1 ->
|
||||
withServantServer api server $ \burl2 -> do
|
||||
return $ serversEqual api burl1 burl2 mgr
|
||||
|
||||
|
||||
context "servers with function types" $ do
|
||||
|
||||
it "considers equal servers equal" $ do
|
||||
withServantServer functionAPI functionAPIServer $ \burl ->
|
||||
serversEqual functionAPI burl burl noOfTestCases
|
||||
|
||||
it "considers unequal servers unequal" $ do
|
||||
withServantServer functionAPI functionAPIServer $ \burl1 ->
|
||||
withServantServer functionAPI functionAPIServer' $ \burl2 ->
|
||||
serversUnequal functionAPI burl1 burl2 noOfTestCases
|
||||
|
||||
|
||||
context "stateful servers" $ do
|
||||
|
||||
it "considers equal servers equal" $ do
|
||||
withServantServer statefulAPI statefulAPIServer $ \burl1 ->
|
||||
withServantServer statefulAPI statefulAPIServer $ \burl2 ->
|
||||
serversEqual statefulAPI burl1 burl2 noOfTestCases
|
||||
|
||||
|
||||
serverSatisfiesSpec :: Spec
|
||||
serverSatisfiesSpec = describe "serverSatisfies" $ do
|
||||
|
||||
it "passes true predicates" $ do
|
||||
let e = addRightPredicate (== (5 :: Int)) emptyPredicates
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
|
||||
serverSatisfies onlyReturnAPI burl emptyPredicates e noOfTestCases
|
||||
|
||||
it "fails false predicates" $ do
|
||||
let e = addRightPredicate (== (4 :: Int)) emptyPredicates
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
|
||||
serverDoesntSatisfy onlyReturnAPI burl emptyPredicates e noOfTestCases
|
||||
|
||||
it "allows filtering" $ do
|
||||
let f = addPredicate (\(x :: String) -> length x > 2) emptyPredicates
|
||||
e = addRightPredicate (\(x :: Int) -> x > 2) emptyPredicates
|
||||
e' = addRightPredicate (\(x :: Int) -> x < 2) emptyPredicates
|
||||
withServantServer functionAPI functionAPIServer $ \burl -> do
|
||||
serverSatisfies functionAPI burl f e noOfTestCases
|
||||
serverDoesntSatisfy functionAPI burl f e' noOfTestCases
|
||||
|
||||
it "allows polymorphic predicates" $ do
|
||||
let p1 x = length (show x) < 100000
|
||||
p2 x = length (show x) < 1
|
||||
e1 = addPolyPredicate (Proxy :: Proxy Show) p1 emptyPredicates
|
||||
e2 = addPolyPredicate (Proxy :: Proxy Show) p2 emptyPredicates
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl -> do
|
||||
serverSatisfies onlyReturnAPI burl emptyPredicates e1 noOfTestCases
|
||||
serverDoesntSatisfy onlyReturnAPI burl emptyPredicates e2 noOfTestCases
|
||||
|
||||
|
||||
context "never500s" $ do
|
||||
|
||||
it "is true for servers that don't return 500s" $ do
|
||||
withServantServer functionAPI functionAPIServer $ \burl ->
|
||||
serverSatisfies functionAPI burl emptyPredicates never500s noOfTestCases
|
||||
|
||||
it "is false for servers that return 500s" $ do
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer'' $ \burl ->
|
||||
serverDoesntSatisfy onlyReturnAPI burl emptyPredicates never500s noOfTestCases
|
||||
|
||||
context "onlyJsonObjects" $ do
|
||||
|
||||
it "is false for servers that return top-level literals" $ do
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
|
||||
serverDoesntSatisfy onlyReturnAPI burl emptyPredicates onlyJsonObjects noOfTestCases
|
||||
|
||||
|
||||
serverBenchmarkSpec :: Spec
|
||||
serverBenchmarkSpec = describe "serverBenchmark" $ do
|
||||
|
||||
it "works" $ do
|
||||
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
|
||||
serverBenchmark onlyReturnAPI burl defaultBenchOptions
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- APIs
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- * OnlyReturn
|
||||
type API = ReqBody '[JSON] String :> Post '[JSON] String
|
||||
:<|> Get '[JSON] Int
|
||||
|
||||
type OnlyReturnAPI = Get '[JSON] Int
|
||||
:<|> Post '[JSON] String
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
onlyReturnAPI :: Proxy OnlyReturnAPI
|
||||
onlyReturnAPI = Proxy
|
||||
|
||||
onlyReturnAPIServer :: IO (Server OnlyReturnAPI)
|
||||
onlyReturnAPIServer = return $ return 5 :<|> return "hi"
|
||||
|
||||
onlyReturnAPIServer' :: IO (Server OnlyReturnAPI)
|
||||
onlyReturnAPIServer' = return $ return 5 :<|> return "hia"
|
||||
|
||||
onlyReturnAPIServer'' :: IO (Server OnlyReturnAPI)
|
||||
onlyReturnAPIServer'' = return $ error "err" :<|> return "hia"
|
||||
|
||||
-- * Function
|
||||
|
||||
type FunctionAPI = ReqBody '[JSON] String :> Post '[JSON] Int
|
||||
:<|> Header "X-abool" Bool :> Get '[JSON] (Maybe Bool)
|
||||
|
||||
functionAPI :: Proxy FunctionAPI
|
||||
functionAPI = Proxy
|
||||
|
||||
functionAPIServer :: IO (Server FunctionAPI)
|
||||
functionAPIServer = return $ return . length :<|> return
|
||||
|
||||
functionAPIServer' :: IO (Server FunctionAPI)
|
||||
functionAPIServer'
|
||||
= return $ (\x -> return $ length x - 1) :<|> \x -> return (not <$> x)
|
||||
|
||||
-- * Stateful
|
||||
|
||||
type StatefulAPI = ReqBody '[JSON] String :> Post '[JSON] String
|
||||
:<|> Get '[JSON] Int
|
||||
|
||||
statefulAPI :: Proxy StatefulAPI
|
||||
statefulAPI = Proxy
|
||||
|
||||
statefulAPIServer :: IO (Server StatefulAPI)
|
||||
statefulAPIServer = do
|
||||
server :: IO (Server API)
|
||||
server = do
|
||||
mvar <- newMVar ""
|
||||
return $ (\x -> liftIO $ swapMVar mvar x)
|
||||
return $ (\x -> liftIO $ print 'a' >> swapMVar mvar x)
|
||||
:<|> (liftIO $ readMVar mvar >>= return . length)
|
||||
|
||||
|
||||
|
||||
@ -1 +1 @@
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user