servant-quickcheck (empty) → 0.0.0.0
raw patch · 11 files changed
+966/−0 lines, 11 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, base-compat, bifunctors, bytestring, case-insensitive, data-default-class, hspec, http-client, http-media, http-types, mtl, process, quickcheck-io, servant, servant-client, servant-quickcheck, servant-server, split, string-conversions, temporary, text, transformers, warp
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- servant-quickcheck.cabal +94/−0
- src/Servant/QuickCheck.hs +81/−0
- src/Servant/QuickCheck/Internal.hs +6/−0
- src/Servant/QuickCheck/Internal/Equality.hs +25/−0
- src/Servant/QuickCheck/Internal/HasGenRequest.hs +137/−0
- src/Servant/QuickCheck/Internal/Predicates.hs +377/−0
- src/Servant/QuickCheck/Internal/QuickCheck.hs +124/−0
- test/Servant/QuickCheck/InternalSpec.hs +89/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Julian K. Arni++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Julian K. Arni nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-quickcheck.cabal view
@@ -0,0 +1,94 @@+name: servant-quickcheck+version: 0.0.0.0+synopsis: QuickCheck entire APIs+description:+ This packages provides QuickCheck properties that are tested across an entire+ API.++license: BSD3+license-file: LICENSE+author: Julian K. Arni+maintainer: jkarni@gmail.com+category: Web+build-type: Simple+cabal-version: >=1.10++flag long-tests+ description: Run more QuickCheck tests+ default: False++library+ exposed-modules: Servant.QuickCheck+ , Servant.QuickCheck.Internal+ , Servant.QuickCheck.Internal.Predicates+ , Servant.QuickCheck.Internal.HasGenRequest+ , Servant.QuickCheck.Internal.QuickCheck+ , Servant.QuickCheck.Internal.Equality+ build-depends: base >=4.7 && <4.9+ , base-compat == 0.9.*+ , QuickCheck == 2.8.*+ , bytestring == 0.10.*+ , aeson > 0.10 && < 0.12+ , mtl == 2.2.*+ , http-client == 0.4.*+ , http-types == 0.9.*+ , http-media == 0.6.*+ , 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.*+ , temporary == 1.2.*+ , split == 0.2.*+ , case-insensitive == 1.2.*+ , hspec == 2.2.*+ , text == 1.*+ if impl(ghc < 7.10)+ build-depends: bifunctors == 5.*++ hs-source-dirs: src+ default-extensions: TypeOperators+ , FlexibleInstances+ , FlexibleContexts+ , DataKinds+ , GADTs+ , MultiParamTypeClasses+ , DeriveFunctor+ , KindSignatures+ , RankNTypes+ , ConstraintKinds+ , DeriveGeneric+ , ScopedTypeVariables+ , OverloadedStrings+ , FunctionalDependencies+ , NoImplicitPrelude+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ ghc-options: -Wall -threaded+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Servant.QuickCheck.InternalSpec+ build-depends: base == 4.*+ , base-compat+ , servant-quickcheck+ , hspec+ , http-client+ , warp+ , servant-server+ , servant-client+ , servant+ , transformers+ , QuickCheck+ , quickcheck-io+ default-extensions: TypeOperators+ , FlexibleInstances+ , FlexibleContexts+ , DataKinds+ , NoImplicitPrelude+ if flag(long-tests)+ cpp-options: -DLONG_TESTS
+ src/Servant/QuickCheck.hs view
@@ -0,0 +1,81 @@+-- | @Servant.QuickCheck@ provides utilities related to using QuickCheck over an API.+-- Rather than specifying properties that individual handlers must satisfy,+-- you can state properties that ought to hold true of the entire API.+--+-- While the API must be described with @servant@ types, the server being+-- tested itself need not be implemented with @servant-server@ (or indeed,+-- written in Haskell).+--+-- The documentation of the <#useful-preds Useful predicates> sections is+-- meant to serve as a set of helpful pointers for learning more about best+-- practices concerning REST APIs.+module Servant.QuickCheck+ (++ -- * Property testing+ serverSatisfies+ -- ** Predicates+ -- *** #useful-preds# Useful predicates+ -- | The predicates below are often useful. Some check RFC compliance; some are+ -- best practice, and some are useful to check that APIs follow in-house+ -- best-practices. Included in the documentation for each is a list of+ -- references to any relevant RFCs and other links, as well as what type of+ -- predicate it is (__RFC Compliance__, __Best Practice__, __Optional__).+ --+ -- RFCs distinguish between the force of requirements (e.g. __MUST__ vs.+ -- __SHOULD__). __RFC Compliance__ includes any absolute requirements present+ -- in RFCs. The __Best Practices__ includes, in addition to RFC+ -- recommendations, recommendations found elsewhere or generally accepted.+ , not500+ , onlyJsonObjects+ , notAllowedContainsAllowHeader+ , unauthorizedContainsWWWAuthenticate+ , getsHaveCacheControlHeader+ , headsHaveCacheControlHeader+ , createContainsValidLocation+ -- *** Predicate utilities and types+ , (<%>)+ , Predicates+ , ResponsePredicate(..)+ , RequestPredicate(..)++ -- * Equality testing+ , serversEqual+ -- ** Response equality+ -- | Often the normal equality of responses is not what we want. For example,+ -- if responses contain a @Date@ header with the time of the response,+ -- responses will fail to be equal even though they morally are. This datatype+ -- represents other means of checking equality+ -- *** Useful @ResponseEquality@s+ , bodyEquality+ , allEquality+ -- ** Response equality type+ , ResponseEquality(..)++ -- * Test setup helpers+ -- | Helpers to setup and teardown @servant@ servers during tests.+ , withServantServer+ , withServantServerAndContext+ , defaultArgs++ -- ** Re-exports+ -- | Types and constructors from other packages that are generally needed for+ -- using @servant-quickcheck@.+ , BaseUrl(..)+ , Scheme(..)+ , Args(..)+ , Proxy(..)+++ ) where++import Servant.QuickCheck.Internal+import Servant.Client (BaseUrl(..), Scheme(..))+import Test.QuickCheck (Args(..), stdArgs)+import Data.Proxy (Proxy(..))++-- | QuickCheck @Args@ with 1000 rather than 100 test cases.+--+-- /Since 0.0.0.0/+defaultArgs :: Args+defaultArgs = stdArgs { maxSuccess = 1000 }
+ src/Servant/QuickCheck/Internal.hs view
@@ -0,0 +1,6 @@+module Servant.QuickCheck.Internal (module X) where++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.Equality as X
+ src/Servant/QuickCheck/Internal/Equality.hs view
@@ -0,0 +1,25 @@+module Servant.QuickCheck.Internal.Equality where++import Data.Function (on)+import Network.HTTP.Client (Response, responseBody)+import Prelude.Compat++newtype ResponseEquality b+ = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }++instance Monoid (ResponseEquality b) where+ mempty = ResponseEquality $ \_ _ -> True+ ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->+ a x y && b x y++-- | Use `Eq` instance for `Response`+--+-- /Since 0.0.0.0/+allEquality :: Eq b => ResponseEquality b+allEquality = ResponseEquality (==)++-- | ByteString `Eq` instance over the response body.+--+-- /Since 0.0.0.0/+bodyEquality :: Eq b => ResponseEquality b+bodyEquality = ResponseEquality ((==) `on` responseBody)
+ src/Servant/QuickCheck/Internal/HasGenRequest.hs view
@@ -0,0 +1,137 @@+{-# 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 (KnownSymbol, Nat, symbolVal)+import Network.HTTP.Client (Request, RequestBody (..), host,+ method, path, port, queryString,+ requestBody, requestHeaders, secure)+import Network.HTTP.Media (renderHeader)+import Prelude.Compat+import Servant+import Servant.API.ContentTypes (AllMimeRender (..))+import Servant.Client (BaseUrl (..), Scheme (..))+import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)+++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 (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)+ => HasGenRequest (QueryParams x c :> b) where+ genRequest _ = 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 ""}+ where+ old = genRequest (Proxy :: Proxy b)+ param = cs $ symbolVal (Proxy :: Proxy x)+ new = arbitrary :: Gen [c]+ toParam c = param <> "[]=" <> cs (toQueryParam c)+ fold = foldr1 (\a b -> a <> "&" <> b)++instance (KnownSymbol x, HasGenRequest b)+ => HasGenRequest (QueryFlag x :> b) where+ genRequest _ = do+ old' <- old+ return $ \burl -> let r = old' burl in r {+ queryString = queryString r <> param <> "=" }+ where+ 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 -> def+ { 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)++instance (HasGenRequest a) => HasGenRequest (IsSecure :> a) where+ genRequest _ = genRequest (Proxy :: Proxy a)++instance (HasGenRequest a) => HasGenRequest (HttpVersion :> a) where+ genRequest _ = genRequest (Proxy :: Proxy a)++instance (HasGenRequest a) => HasGenRequest (Vault :> a) where+ genRequest _ = genRequest (Proxy :: Proxy a)++instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where+ genRequest _ = genRequest (Proxy :: Proxy a)++-- TODO: Try logging in+instance (HasGenRequest a) => HasGenRequest (BasicAuth x y :> a) where+ genRequest _ = genRequest (Proxy :: Proxy a)
+ src/Servant/QuickCheck/Internal/Predicates.hs view
@@ -0,0 +1,377 @@+module Servant.QuickCheck.Internal.Predicates where++import Control.Monad (liftM2)+import Data.Aeson (Object, decode)+import Data.Bifunctor (Bifunctor (..))+import Prelude.Compat+import qualified Data.ByteString as SBS+import qualified Data.ByteString.Char8 as SBSC+import qualified Data.ByteString.Lazy as LBS+import Data.CaseInsensitive (mk)+import Data.Either (isRight)+import Data.List.Split (wordsBy)+import Data.Maybe (fromMaybe, isJust)+import Data.Monoid ((<>))+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.HTTP.Client (Manager, Request, Response, httpLbs,+ method, parseUrl, requestHeaders,+ responseBody, responseHeaders,+ responseStatus)+import Network.HTTP.Media (matchAccept)+import Network.HTTP.Types (methodGet, methodHead, parseMethod,+ renderStdMethod, status200, status201,+ status300, status401, status405,+ status500, status100)++-- | [__Best Practice__]+--+-- @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.+--+-- This function checks that the response code is not 500.+--+-- /Since 0.0.0.0/+not500 :: ResponsePredicate Text Bool+not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)++-- | [__Best Practice__]+--+-- 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+-- (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+--+-- This function checks that any @application/json@ responses only return JSON+-- objects (and not arrays, strings, numbers, or booleans) at the top level.+--+-- __References__:+--+-- * JSON Grammar: <https://tools.ietf.org/html/rfc7159#section-2 RFC 7159 Section 2>+-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>+--+-- /Since 0.0.0.0/+onlyJsonObjects :: ResponsePredicate Text Bool+onlyJsonObjects+ = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of+ Nothing -> False+ Just (_ :: Object) -> True)++-- | __Optional__+--+-- 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.+--+-- This is considered optional because other means of linking to the resource+-- (e.g. via the response body) are also acceptable; linking to the resource in+-- some way is considered best practice.+--+-- __References__:+--+-- * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2>+-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>+--+-- /Since 0.0.0.0/+createContainsValidLocation :: RequestPredicate Text Bool+createContainsValidLocation+ = RequestPredicate+ { reqPredName = "createContainsValidLocation"+ , reqResps = \req mgr -> do+ resp <- httpLbs req mgr+ if responseStatus resp == status201+ then case lookup "Location" $ responseHeaders resp of+ Nothing -> return (False, [resp])+ Just l -> case parseUrl $ SBSC.unpack l of+ Nothing -> return (False, [resp])+ Just x -> do+ resp2 <- httpLbs x mgr+ return (status2XX resp2, [resp, resp2])+ else return (True, [resp])+ }++{-+getsHaveLastModifiedHeader :: ResponsePredicate Text Bool+getsHaveLastModifiedHeader+ = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->++-}++-- | [__RFC Compliance__]+--+-- 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.+--+-- __References__:+--+-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>+-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>+--+-- /Since 0.0.0.0/+notAllowedContainsAllowHeader :: RequestPredicate Text Bool+notAllowedContainsAllowHeader+ = RequestPredicate+ { reqPredName = "notAllowedContainsAllowHeader"+ , reqResps = \req mgr -> do+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }+ | m <- [minBound .. maxBound ]+ , renderStdMethod m /= method req ]+ return (all pred' resp, resp)+ }+ where+ pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp+ where+ go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)+ $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)+++-- | [__RFC Compliance__]+--+-- 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. It does *not* check that the server+-- matches the quality descriptions of the @Accept@ header correctly.+--+-- __References__:+--+-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>+--+-- /Since 0.0.0.0/+honoursAcceptHeader :: RequestPredicate Text Bool+honoursAcceptHeader+ = RequestPredicate+ { reqPredName = "honoursAcceptHeader"+ , reqResps = \req mgr -> do+ resp <- httpLbs req mgr+ let scode = responseStatus resp+ sctype = lookup "Content-Type" $ responseHeaders resp+ sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)+ if status100 < scode && scode < status300+ then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])+ else return (True, [resp])+ }++-- | [__Best Practice__]+--+-- 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 @Cache-Control@ header.+-- It does NOT currently check that the header is valid.+--+-- __References__:+--+-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>+--+-- /Since 0.0.0.0/+getsHaveCacheControlHeader :: RequestPredicate Text Bool+getsHaveCacheControlHeader+ = RequestPredicate+ { reqPredName = "getsHaveCacheControlHeader"+ , reqResps = \req mgr -> if method req == methodGet+ then do+ resp <- httpLbs req mgr+ let good = isJust $ lookup "Cache-Control" $ responseHeaders resp+ return (good, [resp])+ else return (True, [])+ }++-- | [__Best Practice__]+--+-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.+--+-- /Since 0.0.0.0/+headsHaveCacheControlHeader :: RequestPredicate Text Bool+headsHaveCacheControlHeader+ = RequestPredicate+ { reqPredName = "headsHaveCacheControlHeader"+ , reqResps = \req mgr -> if method req == methodHead+ then do+ resp <- httpLbs req mgr+ let good = hasValidHeader "Cache-Control" (const True) resp+ return (good, [resp])+ else return (True, [])+ }+{-+-- |+--+-- 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__:+--+-- * <https://tools.ietf.org/html/rfc5988 RFC 5988 Section 5>+linkHeadersAreValid :: Predicate b Bool+linkHeadersAreValid+ = ResponsePredicate "linkHeadersAreValid" _++-}+-- | [__RFC Compliance__]+--+-- 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__:+--+-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>+--+-- /Since 0.0.0.0/+unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool+unauthorizedContainsWWWAuthenticate+ = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->+ if responseStatus resp == status401+ then hasValidHeader "WWW-Authenticate" (const True) resp+ else True)++-- * Predicate logic++-- The idea with all this footwork is to not waste any requests. Rather than+-- generating new requests and only applying one predicate to the response, we+-- apply as many predicates as possible.+--+-- Still, this is all kind of ugly.++-- | A predicate that depends only on the response.+--+-- /Since 0.0.0.0/+data ResponsePredicate n r = ResponsePredicate+ { respPredName :: n+ , respPred :: Response LBS.ByteString -> r+ } deriving (Functor, Generic)++instance Bifunctor ResponsePredicate where+ first f (ResponsePredicate a b) = ResponsePredicate (f a) b+ second = fmap++instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where+ mempty = ResponsePredicate mempty mempty+ a `mappend` b = ResponsePredicate+ { respPredName = respPredName a <> respPredName b+ , respPred = respPred a <> respPred b+ }++-- | A predicate that depends on both the request and the response.+--+-- /Since 0.0.0.0/+data RequestPredicate n r = RequestPredicate+ { reqPredName :: n+ , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])+ } deriving (Generic, Functor)++instance Bifunctor RequestPredicate where+ first f (RequestPredicate a b) = RequestPredicate (f a) b+ second = fmap++-- TODO: This isn't actually a monoid+instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where+ mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))+ a `mappend` b = RequestPredicate+ { reqPredName = reqPredName a <> reqPredName b+ , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)+ }++-- | A set of predicates. Construct one with 'mempty' and '<%>'.+data Predicates n r = Predicates+ { reqPreds :: RequestPredicate n r+ , respPreds :: ResponsePredicate n r+ } deriving (Generic, Functor)++instance (Monoid n, Monoid r) => Monoid (Predicates n r) where+ mempty = Predicates mempty mempty+ a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)++++class JoinPreds a where+ joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]++instance JoinPreds (RequestPredicate Text Bool) where+ joinPreds p (Predicates x y) = Predicates (go <> x) y+ where go = let p' = first return p+ in fmap (\z -> if z then [] else reqPredName p') p'++instance JoinPreds (ResponsePredicate Text Bool) where+ joinPreds p (Predicates x y) = Predicates x (go <> y)+ where go = let p' = first return p+ in fmap (\z -> if z then [] else respPredName p') p'+++-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to+-- the existing predicates.+--+-- > not500 <%> onlyJsonObjects <%> empty+--+-- /Since 0.0.0.0/+(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]+(<%>) = joinPreds+infixr 6 <%>++finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]+finishPredicates p req mgr = do+ (soFar, resps) <- reqResps (reqPreds p) req mgr+ return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]++-- * helpers++hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bool+hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of+ Nothing -> False+ Just v -> p v++status2XX :: Response b -> Bool+status2XX r = status200 <= responseStatus r && responseStatus r < status300
+ src/Servant/QuickCheck/Internal/QuickCheck.hs view
@@ -0,0 +1,124 @@+module Servant.QuickCheck.Internal.QuickCheck where++import qualified Data.ByteString.Lazy as LBS+import Data.Proxy (Proxy)+import Data.Text (Text)+import Network.HTTP.Client (Manager, Request, checkStatus,+ defaultManagerSettings, httpLbs,+ newManager)+import Network.Wai.Handler.Warp (withApplication)+import Prelude.Compat+import Servant (Context (EmptyContext), HasServer,+ Server, serveWithContext)+import Servant.Client (BaseUrl (..), Scheme (..))+import System.IO.Unsafe (unsafePerformIO)+import Test.Hspec (Expectation, expectationFailure)+import Test.QuickCheck (Args (..), Result (..),+ quickCheckWithResult)+import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)++import Servant.QuickCheck.Internal.HasGenRequest+import Servant.QuickCheck.Internal.Predicates+import Servant.QuickCheck.Internal.Equality+++-- | Start a servant application on an open port, run the provided function,+-- then stop the application.+--+-- /Since 0.0.0.0/+withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)+ -> (BaseUrl -> IO r) -> IO r+withServantServer api = withServantServerAndContext api EmptyContext++-- | Like 'withServantServer', but allows passing in a 'Context' to the+-- application.+--+-- /Since 0.0.0.0/+withServantServerAndContext :: HasServer a ctx+ => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r+withServantServerAndContext api ctx server t+ = withApplication (return . serveWithContext api ctx =<< server) $ \port ->+ t (BaseUrl Http "localhost" port "")++-- | 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+-- response is not the same (according to the definition of @==@ for the return+-- datatype), the 'Expectation' fails, printing the counterexample.+--+-- The @Int@ argument specifies maximum number of test cases to generate and+-- run.+--+-- Evidently, if the behaviour of the server is expected to be+-- non-deterministic, this function may produce spurious failures+--+-- /Since 0.0.0.0/+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+ r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do+ resp1 <- run $ httpLbs (noCheckStatus req1) defManager+ resp2 <- run $ httpLbs (noCheckStatus req2) defManager+ assert $ getResponseEquality req resp1 resp2+ case r of+ Success {} -> return ()+ GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"+ Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m+ NoExpectedFailure {} -> expectationFailure $ "No expected failure"+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"++-- | Check that a server satisfies the set of properties specified.+--+-- Note that, rather than having separate tests for each property you'd like to+-- test, you should generally prefer to combine all properties into a single+-- test. This enables a more parsimonious generation of requests and responses+-- with the same testing depth.+--+-- Example usage:+--+-- > goodAPISpec = describe "my server" $ do+-- >+-- > it "follows best practices" $ do+-- > withServantServer api server $ \burl ->+-- > serverSatisfies api burl stdArgs (not500+-- > <%> onlyJsonObjects+-- > <%> notAllowedContainsAllowHeader+-- > <%> mempty)+--+-- /Since 0.0.0.0/+serverSatisfies :: (HasGenRequest a) =>+ Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation+serverSatisfies api burl args preds = do+ let reqs = ($ burl) <$> genRequest api+ r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do+ v <- run $ finishPredicates preds (noCheckStatus req) defManager+ assert $ null v+ case r of+ Success {} -> return ()+ GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"+ Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m+ NoExpectedFailure {} -> expectationFailure $ "No expected failure"+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"+++serverDoesntSatisfy :: (HasGenRequest a) =>+ Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation+serverDoesntSatisfy api burl args preds = do+ let reqs = ($ burl) <$> genRequest api+ r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do+ v <- run $ finishPredicates preds (noCheckStatus req) defManager+ assert $ not $ null v+ case r of+ Success {} -> return ()+ GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"+ Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m+ NoExpectedFailure {} -> expectationFailure $ "No expected failure"+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"++noCheckStatus :: Request -> Request+noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}++defManager :: Manager+defManager = unsafePerformIO $ newManager defaultManagerSettings+{-# NOINLINE defManager #-}
+ test/Servant/QuickCheck/InternalSpec.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Servant.QuickCheck.InternalSpec (spec) where++import Control.Concurrent.MVar (newMVar, readMVar,+ swapMVar)+import Control.Monad.IO.Class (liftIO)+import Prelude.Compat+import Servant+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)+import Test.Hspec (Spec, describe, it,+ shouldBe)++import Servant.QuickCheck+import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)++spec :: Spec+spec = do+ serversEqualSpec+ serverSatisfiesSpec+ isComprehensiveSpec++serversEqualSpec :: Spec+serversEqualSpec = describe "serversEqual" $ do++ it "considers equal servers equal" $ do+ withServantServerAndContext api ctx server $ \burl1 ->+ withServantServerAndContext api ctx server $ \burl2 -> do+ serversEqual api burl1 burl2 args bodyEquality+++serverSatisfiesSpec :: Spec+serverSatisfiesSpec = describe "serverSatisfies" $ do++ it "succeeds for true predicates" $ do+ withServantServerAndContext api ctx server $ \burl ->+ serverSatisfies api burl args (unauthorizedContainsWWWAuthenticate+ <%> not500+ <%> mempty)++ it "fails for false predicates" $ do+ withServantServerAndContext api ctx server $ \burl -> do+ serverDoesntSatisfy api burl args (onlyJsonObjects+ <%> getsHaveCacheControlHeader+ <%> headsHaveCacheControlHeader+ <%> notAllowedContainsAllowHeader+ <%> mempty)++isComprehensiveSpec :: Spec+isComprehensiveSpec = describe "HasGenRequest" $ do++ it "has instances for all 'servant' combinators" $ do+ let _g = genRequest comprehensiveAPI+ True `shouldBe` True -- This is a type-level check+++------------------------------------------------------------------------------+-- APIs+------------------------------------------------------------------------------++type API = ReqBody '[JSON] String :> Post '[JSON] String+ :<|> Get '[JSON] Int+ :<|> BasicAuth "some-realm" () :> Get '[JSON] ()++api :: Proxy API+api = Proxy++server :: IO (Server API)+server = do+ mvar <- newMVar ""+ return $ (\x -> liftIO $ swapMVar mvar x)+ :<|> (liftIO $ readMVar mvar >>= return . length)+ :<|> (const $ return ())++ctx :: Context '[BasicAuthCheck ()]+ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext+------------------------------------------------------------------------------+-- Utils+------------------------------------------------------------------------------++args :: Args+args = defaultArgs { maxSuccess = noOfTestCases }++noOfTestCases :: Int+#if LONG_TESTS+noOfTestCases = 20000+#else+noOfTestCases = 500+#endif
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}