diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal new file mode 100644 --- /dev/null +++ b/servant-quickcheck.cabal @@ -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 diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Servant/QuickCheck.hs @@ -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 } diff --git a/src/Servant/QuickCheck/Internal.hs b/src/Servant/QuickCheck/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/QuickCheck/Internal.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal/Equality.hs b/src/Servant/QuickCheck/Internal/Equality.hs new file mode 100644 --- /dev/null +++ b/src/Servant/QuickCheck/Internal/Equality.hs @@ -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) diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -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) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs new file mode 100644 --- /dev/null +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -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: +-- * JSON Grammar: +-- +-- /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: +-- * Location header: +-- +-- /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: +-- * Status 405: +-- +-- /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: +-- +-- /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: +-- +-- /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__: +-- +-- * +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: +-- +-- /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 diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -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 #-} diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}