From 76e3b8e7ec42c66c0488e19eaa45b353df7d05c9 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 23 Apr 2016 22:36:03 +0200 Subject: [PATCH] Documentation improvements --- src/Servant/QuickCheck.hs | 37 ++++++++++--------- src/Servant/QuickCheck/Internal/Equality.hs | 6 +-- src/Servant/QuickCheck/Internal/Predicates.hs | 7 +++- src/Servant/QuickCheck/Internal/QuickCheck.hs | 33 +++++++++++++---- 4 files changed, 53 insertions(+), 30 deletions(-) diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index ecb06e3..3293c35 100644 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -6,16 +6,6 @@ -- tested itself need not be implemented with @servant-server@ (or indeed, -- written in Haskell). -- --- /N.B./ The examples given here assume the following setup: --- --- > import Servant --- > import Servant.QuickCheck --- > import Test.Hspec --- > --- > type API = ReqBody '[JSON] Int :> Post '[JSON] String --- > --- > api :: Proxy API --- > api = Proxy module Servant.QuickCheck ( @@ -24,19 +14,32 @@ module Servant.QuickCheck -- | Helpers to setup and teardown @servant@ servers during tests. withServantServer - , serversEqual - , serverSatisfies - -- * Response equality + -- * 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 - , ResponseEquality(getResponseEquality) + -- ** Response equality type + , ResponseEquality(..) - -- * Predicates - , (<%>) - , Predicates + -- * Property testing + , serverSatisfies + -- ** Predicates + -- *** Useful predicates , not500 , onlyJsonObjects + , notAllowedContainsAllowHeader + -- *** Predicate utilities and types + , (<%>) + , Predicates + , ResponsePredicate(..) + , RequestPredicate(..) -- ** Re-exports , BaseUrl(..) diff --git a/src/Servant/QuickCheck/Internal/Equality.hs b/src/Servant/QuickCheck/Internal/Equality.hs index 25a60fe..f1b9e61 100644 --- a/src/Servant/QuickCheck/Internal/Equality.hs +++ b/src/Servant/QuickCheck/Internal/Equality.hs @@ -3,10 +3,6 @@ module Servant.QuickCheck.Internal.Equality where import Network.HTTP.Client import Data.Function (on) --- | 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 newtype ResponseEquality b = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool } @@ -15,8 +11,10 @@ instance Monoid (ResponseEquality b) where ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y -> a x y && b x y +-- | Use `Eq` instance for `Response` allEquality :: Eq b => ResponseEquality b allEquality = ResponseEquality (==) +-- | ByteString `Eq` instance over the response body. bodyEquality :: Eq b => ResponseEquality b bodyEquality = ResponseEquality ((==) `on` responseBody) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 45779e6..c34f83c 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -229,9 +229,14 @@ instance JoinPreds (ResponsePredicate Text Bool) where where go = let p' = first return p in fmap (\z -> if z then [] else respPredName p') p' -infixr 6 <%> + +-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to +-- the existing predicates. +-- +-- > not500 <%> onlyJsonObjects <%> empty (<%>) :: 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 diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index bba2552..062c66f 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -1,19 +1,20 @@ -- | This module contains wrappers around lower-level functionality. module Servant.QuickCheck.Internal.QuickCheck where +import qualified Data.ByteString.Lazy as LBS import Data.Proxy (Proxy) -import Network.HTTP.Client (Manager, defaultManagerSettings, - newManager, httpLbs, checkStatus, Request) +import Data.Text (Text) +import Network.HTTP.Client (Manager, Request, checkStatus, + defaultManagerSettings, httpLbs, + newManager) import Network.Wai.Handler.Warp (withApplication) import Servant (HasServer, Server, serve) -import Servant.Client (BaseUrl (..), Scheme (..) ) +import Servant.Client (BaseUrl (..), Scheme (..)) +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec (Expectation, expectationFailure) import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult) -import System.IO.Unsafe (unsafePerformIO) -import Test.QuickCheck.Monadic -import qualified Data.ByteString.Lazy as LBS -import Data.Text (Text) +import Test.QuickCheck.Monadic import Servant.QuickCheck.Internal.HasGenRequest import Servant.QuickCheck.Internal.Predicates @@ -54,13 +55,29 @@ serversEqual api burl1 burl2 args req = do 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) 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 - {-run $ print v-} assert $ null v case r of Success {} -> return ()