From 205048705857991b5328a21851451845cb939f64 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 23 Apr 2016 01:21:36 +0200 Subject: [PATCH] Rewrite. Being lazy without a new full intepretation isn't paying off. --- servant-quickcheck.cabal | 9 +- src/Servant/QuickCheck.hs | 67 +---- src/Servant/QuickCheck/Internal.hs | 2 +- .../QuickCheck/Internal/HasGenRequest.hs | 93 ++++++ src/Servant/QuickCheck/Internal/Predicates.hs | 265 ++++++++++-------- src/Servant/QuickCheck/Internal/QuickCheck.hs | 136 +-------- src/Servant/QuickCheck/Internal/Testable.hs | 111 -------- test/Servant/QuickCheck/InternalSpec.hs | 144 ++-------- test/Spec.hs | 2 +- 9 files changed, 275 insertions(+), 554 deletions(-) create mode 100644 src/Servant/QuickCheck/Internal/HasGenRequest.hs delete mode 100644 src/Servant/QuickCheck/Internal/Testable.hs diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 6cf775d..05f1d03 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -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 diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index 01cf0ec..8fe6749 100644 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -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(..) diff --git a/src/Servant/QuickCheck/Internal.hs b/src/Servant/QuickCheck/Internal.hs index 7178e62..feee693 100644 --- a/src/Servant/QuickCheck/Internal.hs +++ b/src/Servant/QuickCheck/Internal.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs new file mode 100644 index 0000000..27a5f0d --- /dev/null +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -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) + } + diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index f50aedc..f018545 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -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: +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) diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 02cbf40..475e2ca 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -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, "") diff --git a/src/Servant/QuickCheck/Internal/Testable.hs b/src/Servant/QuickCheck/Internal/Testable.hs deleted file mode 100644 index 020c3bb..0000000 --- a/src/Servant/QuickCheck/Internal/Testable.hs +++ /dev/null @@ -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" diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 7443fbe..ef28bb5 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs index a824f8c..5416ef6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1 +1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}