servant-quickcheck 0.0.0.0 → 0.0.1.0
raw patch · 10 files changed
+343/−184 lines, 10 filesdep +hspec-coredep +pretty
Dependencies added: hspec-core, pretty
Files
- CHANGELOG.md +5/−0
- servant-quickcheck.cabal +9/−1
- src/Servant/QuickCheck.hs +3/−3
- src/Servant/QuickCheck/Internal.hs +4/−3
- src/Servant/QuickCheck/Internal/Equality.hs +3/−3
- src/Servant/QuickCheck/Internal/ErrorTypes.hs +79/−0
- src/Servant/QuickCheck/Internal/HasGenRequest.hs +16/−16
- src/Servant/QuickCheck/Internal/Predicates.hs +114/−126
- src/Servant/QuickCheck/Internal/QuickCheck.hs +49/−19
- test/Servant/QuickCheck/InternalSpec.hs +61/−13
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# 0.0.1.0++- Better error messages. Error messages now contain failing predicate, failing+response and (except for response predicates), failing requests.+- Significant changes to RequestPredicate and ResponsePredicate types.
servant-quickcheck.cabal view
@@ -1,5 +1,5 @@ name: servant-quickcheck-version: 0.0.0.0+version: 0.0.1.0 synopsis: QuickCheck entire APIs description: This packages provides QuickCheck properties that are tested across an entire@@ -12,6 +12,8 @@ category: Web build-type: Simple cabal-version: >=1.10+extra-source-files:+ CHANGELOG.md flag long-tests description: Run more QuickCheck tests@@ -24,6 +26,7 @@ , Servant.QuickCheck.Internal.HasGenRequest , Servant.QuickCheck.Internal.QuickCheck , Servant.QuickCheck.Internal.Equality+ , Servant.QuickCheck.Internal.ErrorTypes build-depends: base >=4.7 && <4.9 , base-compat == 0.9.* , QuickCheck == 2.8.*@@ -45,6 +48,7 @@ , case-insensitive == 1.2.* , hspec == 2.2.* , text == 1.*+ , pretty == 1.1.* if impl(ghc < 7.10) build-depends: bifunctors == 5.* @@ -77,6 +81,7 @@ , base-compat , servant-quickcheck , hspec+ , hspec-core , http-client , warp , servant-server@@ -88,7 +93,10 @@ default-extensions: TypeOperators , FlexibleInstances , FlexibleContexts+ , GADTs , DataKinds , NoImplicitPrelude+ , OverloadedStrings+ , ScopedTypeVariables if flag(long-tests) cpp-options: -DLONG_TESTS
src/Servant/QuickCheck.hs view
@@ -69,10 +69,10 @@ ) where +import Data.Proxy (Proxy (..))+import Servant.Client (BaseUrl (..), Scheme (..)) import Servant.QuickCheck.Internal-import Servant.Client (BaseUrl(..), Scheme(..))-import Test.QuickCheck (Args(..), stdArgs)-import Data.Proxy (Proxy(..))+import Test.QuickCheck (Args (..), stdArgs) -- | QuickCheck @Args@ with 1000 rather than 100 test cases. --
src/Servant/QuickCheck/Internal.hs view
@@ -1,6 +1,7 @@ module Servant.QuickCheck.Internal (module X) where +import Servant.QuickCheck.Internal.Equality as X+import Servant.QuickCheck.Internal.ErrorTypes 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.Equality as X+import Servant.QuickCheck.Internal.Predicates as X+import Servant.QuickCheck.Internal.QuickCheck as X
src/Servant/QuickCheck/Internal/Equality.hs view
@@ -1,8 +1,8 @@ module Servant.QuickCheck.Internal.Equality where -import Data.Function (on)-import Network.HTTP.Client (Response, responseBody)-import Prelude.Compat+import Data.Function (on)+import Network.HTTP.Client (Response, responseBody)+import Prelude.Compat newtype ResponseEquality b = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
+ src/Servant/QuickCheck/Internal/ErrorTypes.hs view
@@ -0,0 +1,79 @@+module Servant.QuickCheck.Internal.ErrorTypes where++import Control.Exception (Exception (..))+import qualified Data.ByteString.Lazy as LBS+import Data.String.Conversions (cs)+import qualified Data.Text as T+import GHC.Generics (Generic)+import qualified Network.HTTP.Client as C+import Network.HTTP.Types (Header, statusCode)+import Prelude.Compat+import Text.PrettyPrint++data PredicateFailure+ = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)+ deriving (Generic)++instance Exception ServerEqualityFailure where++instance Show PredicateFailure where+ show = render . prettyPredicateFailure+++data ServerEqualityFailure+ = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)+ deriving (Generic)++instance Show ServerEqualityFailure where+ show = render . prettyServerEqualityFailure+++instance Exception PredicateFailure where++-- * Pretty printing++prettyHeaders :: [Header] -> Doc+prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs+ where+ prettyHdr (hn, h) = text (show hn) <> colon <+> text (show h)++prettyReq :: C.Request -> Doc+prettyReq r =+ text "Request:" $$ (nest 5 $+ text "Method:" <+> (nest 5 $ text . show $ C.method r)+ $$ text "Path:" <+> (nest 5 $ text . cs $ C.path r)+ $$ text "Headers:" <+> (nest 5 $ prettyHeaders $ C.requestHeaders r)+ $$ text "Body:" <+> (nest 5 $ text . getReqBody $ C.requestBody r))+ where+ getReqBody (C.RequestBodyLBS lbs ) = cs lbs+ getReqBody (C.RequestBodyBS bs ) = cs bs+ getReqBody _ = error "expected bytestring body"++prettyResp :: C.Response LBS.ByteString -> Doc+prettyResp r =+ text "Response:" $$ (nest 5 $+ text "Status code:" <+> (nest 5 $ text . show . statusCode $ C.responseStatus r)+ $$ text "Headers:" $$ (nest 10 $ prettyHeaders $ C.responseHeaders r)+ $$ text "Body:" <+> (nest 5 $ text . cs $ C.responseBody r))++++prettyServerEqualityFailure :: ServerEqualityFailure -> Doc+prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =+ text "Server equality failed" $$ (nest 5 $+ prettyReq req+ $$ prettyResp resp1+ $$ prettyResp resp2)+++prettyPredicateFailure :: PredicateFailure -> Doc+prettyPredicateFailure (PredicateFailure predicate req resp) =+ text "Predicate failed" $$ (nest 5 $+ text "Predicate:" <+> (text $ T.unpack predicate)+ $$ r+ $$ prettyResp resp)+ where+ r = case req of+ Nothing -> text ""+ Just v -> prettyReq v+
src/Servant/QuickCheck/Internal/HasGenRequest.hs view
@@ -1,20 +1,20 @@ {-# 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)+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@@ -29,7 +29,7 @@ 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 }+ return $ \burl -> let r = old' burl in r { path = new <> path r } where old = genRequest (Proxy :: Proxy b) new = cs $ symbolVal (Proxy :: Proxy path)@@ -39,7 +39,7 @@ genRequest _ = do old' <- old new' <- toUrlPiece <$> new- return $ \burl -> let r = old' burl in r { path = cs new' <> "/" <> path r }+ return $ \burl -> let r = old' burl in r { path = cs new' <> path r } where old = genRequest (Proxy :: Proxy b) new = arbitrary :: Gen c
src/Servant/QuickCheck/Internal/Predicates.hs view
@@ -1,9 +1,10 @@ module Servant.QuickCheck.Internal.Predicates where -import Control.Monad (liftM2)+import Control.Exception (SomeException, catch, throw)+import Control.Monad (ap, guard, liftM2)+import Control.Monad.Reader 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@@ -20,10 +21,14 @@ responseStatus) import Network.HTTP.Media (matchAccept) import Network.HTTP.Types (methodGet, methodHead, parseMethod,- renderStdMethod, status200, status201,- status300, status401, status405,- status500, status100)+ renderStdMethod, status100, status200,+ status201, status300, status401,+ status405, status500)+import Prelude.Compat +import Servant.QuickCheck.Internal.ErrorTypes++ -- | [__Best Practice__] -- -- @500 Internal Server Error@ should be avoided - it may represent some@@ -33,8 +38,9 @@ -- 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)+not500 :: ResponsePredicate+not500 = ResponsePredicate $ \resp ->+ when (responseStatus resp == status500) $ fail "not500" -- | [__Best Practice__] --@@ -57,11 +63,11 @@ -- * 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- = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of- Nothing -> False- Just (_ :: Object) -> True)+ = ResponsePredicate (\resp -> case decode (responseBody resp) of+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp+ Just (_ :: Object) -> return ()) -- | __Optional__ --@@ -82,25 +88,24 @@ -- * 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 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])- }+ = RequestPredicate $ \req mgr -> do+ let n = "createContainsValidLocation"+ resp <- httpLbs req mgr+ if responseStatus resp == status201+ then case lookup "Location" $ responseHeaders resp of+ Nothing -> fail n+ Just l -> case parseUrl $ SBSC.unpack l of+ Nothing -> fail n+ Just x -> do+ resp2 <- httpLbs x mgr+ status2XX resp2 n+ return [resp, resp2]+ else return [resp] {--getsHaveLastModifiedHeader :: ResponsePredicate Text Bool+getsHaveLastModifiedHeader :: ResponsePredicate getsHaveLastModifiedHeader = ResponsePredicate "getsHaveLastModifiedHeader" (\resp -> @@ -122,18 +127,17 @@ -- * 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 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)- }+ = RequestPredicate $ \req mgr -> do+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }+ | m <- [minBound .. maxBound ]+ , renderStdMethod m /= method req ]+ case filter pred' resp of+ (x:xs) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x+ [] -> return resp where- pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp+ pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp) where go x = all (\y -> isRight $ parseMethod $ SBSC.pack y) $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)@@ -154,20 +158,20 @@ -- * @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 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])- }+ = RequestPredicate $ \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 if isJust $ sctype >>= \x -> matchAccept [x] sacc+ then fail "honoursAcceptHeader"+ else return [resp]+ else return [resp] + -- | [__Best Practice__] -- -- Whether or not a representation should be cached, it is good practice to@@ -182,34 +186,32 @@ -- * @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 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, [])- }+ = RequestPredicate $ \req mgr ->+ if (method req == methodGet)+ then do+ resp <- httpLbs req mgr+ unless (hasValidHeader "Cache-Control" (const True) resp) $ do+ throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp+ return [resp]+ else return [] -- | [__Best Practice__] -- -- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests. -- -- /Since 0.0.0.0/-headsHaveCacheControlHeader :: RequestPredicate Text Bool+headsHaveCacheControlHeader :: RequestPredicate 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, [])- }+ = RequestPredicate $ \req mgr ->+ if (method req == methodHead)+ then do+ resp <- httpLbs req mgr+ unless (hasValidHeader "Cache-Control" (const True) resp) $+ throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp+ return [resp]+ else return [] {- -- | --@@ -271,12 +273,13 @@ -- * @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- = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->+ = ResponsePredicate $ \resp -> if responseStatus resp == status401- then hasValidHeader "WWW-Authenticate" (const True) resp- else True)+ then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $+ fail "unauthorizedContainsWWWAuthenticate"+ else return () -- * Predicate logic @@ -289,67 +292,46 @@ -- | 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+data ResponsePredicate = ResponsePredicate+ { getResponsePredicate :: Response LBS.ByteString -> IO ()+ } deriving (Generic) -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- }+instance Monoid ResponsePredicate where+ mempty = ResponsePredicate $ const $ return ()+ ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x -- | 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+data RequestPredicate = RequestPredicate+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]+ } deriving (Generic) -- 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)- }+instance Monoid RequestPredicate where+ mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))+ RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->+ liftM2 (<>) (a r mgr) (b r mgr) -- | 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)+data Predicates = Predicates+ { requestPredicates :: RequestPredicate+ , responsePredicates :: ResponsePredicate+ } deriving (Generic) -instance (Monoid n, Monoid r) => Monoid (Predicates n r) where+instance Monoid Predicates where mempty = Predicates mempty mempty- a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)--+ a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)+ (responsePredicates a <> responsePredicates 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'+ joinPreds :: a -> Predicates -> Predicates -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'+instance JoinPreds (RequestPredicate ) where+ joinPreds p (Predicates x y) = Predicates (p <> x) y +instance JoinPreds (ResponsePredicate ) where+ joinPreds p (Predicates x y) = Predicates x (p <> y) -- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to -- the existing predicates.@@ -357,14 +339,17 @@ -- > not500 <%> onlyJsonObjects <%> empty -- -- /Since 0.0.0.0/-(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]+(<%>) :: JoinPreds a => a -> Predicates -> Predicates (<%>) = 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]+finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)+finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e+ where+ go = do+ resps <- getRequestPredicate (requestPredicates p) req mgr+ mapM_ (getResponsePredicate $ responsePredicates p) resps+ return Nothing -- * helpers @@ -373,5 +358,8 @@ Nothing -> False Just v -> p v -status2XX :: Response b -> Bool-status2XX r = status200 <= responseStatus r && responseStatus r < status300+status2XX :: Monad m => Response b -> String -> m ()+status2XX r t+ | status200 <= responseStatus r && responseStatus r < status300+ = return ()+ | otherwise = fail t
src/Servant/QuickCheck/Internal/QuickCheck.hs view
@@ -1,11 +1,14 @@+{-# LANGUAGE RecordWildCards #-} module Servant.QuickCheck.Internal.QuickCheck where +import Control.Concurrent (modifyMVar_, newMVar, readMVar)+import Control.Monad (unless) import qualified Data.ByteString.Lazy as LBS import Data.Proxy (Proxy)+import Data.String (IsString (..)) import Data.Text (Text)-import Network.HTTP.Client (Manager, Request, checkStatus,- defaultManagerSettings, httpLbs,- newManager)+import GHC.Generics (Generic)+import qualified Network.HTTP.Client as C import Network.Wai.Handler.Warp (withApplication) import Prelude.Compat import Servant (Context (EmptyContext), HasServer,@@ -15,11 +18,14 @@ import Test.Hspec (Expectation, expectationFailure) import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult)-import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)+import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,+ run)+import Test.QuickCheck.Property (counterexample) +import Servant.QuickCheck.Internal.Equality+import Servant.QuickCheck.Internal.ErrorTypes 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,@@ -52,19 +58,38 @@ -- Evidently, if the behaviour of the server is expected to be -- non-deterministic, this function may produce spurious failures --+-- Note that only valid requests are generated and tested. As an example of why+-- this matters, let's say your API specifies that a particular endpoint can+-- only generate @JSON@. @serversEqual@ will then not generate any requests+-- with an @Accept@ header _other_ than @application/json@. It may therefore+-- fail to notice that one application, when the request has @Accept:+-- text/html@, returns a @406 Not Acceptable@ HTTP response, and another+-- returns a @200 Success@, but with @application/json@ as the content-type.+--+-- The fact that only valid requests are tested also means that no endpoints+-- not listed in the API type are tested.+-- -- /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+ -- This MVar stuff is clunky! But there doesn't seem to be an easy way to+ -- return results when a test fails, since an exception is throw.+ deetsMVar <- newMVar $ error "should not be called"+ r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do+ resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager+ resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager+ unless (getResponseEquality req resp1 resp2) $ do+ monitor (counterexample "hi" )+ run $ modifyMVar_ deetsMVar $ const $ return $+ ServerEqualityFailure req1 resp1 resp2+ assert False case r of Success {} -> return ()+ f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $+ "Failed:\n" ++ show x 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" @@ -88,22 +113,27 @@ -- -- /Since 0.0.0.0/ serverSatisfies :: (HasGenRequest a) =>- Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation+ Proxy a -> BaseUrl -> Args -> Predicates -> Expectation serverSatisfies api burl args preds = do let reqs = ($ burl) <$> genRequest api- r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do+ deetsMVar <- newMVar $ error "should not be called"+ r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do v <- run $ finishPredicates preds (noCheckStatus req) defManager- assert $ null v+ run $ modifyMVar_ deetsMVar $ const $ return v+ case v of+ Just x -> assert False+ _ -> return () case r of Success {} -> return ()+ f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $+ "Failed:\n" ++ show x 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+ Proxy a -> BaseUrl -> Args -> Predicates -> Expectation serverDoesntSatisfy api burl args preds = do let reqs = ($ burl) <$> genRequest api r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do@@ -116,9 +146,9 @@ NoExpectedFailure {} -> expectationFailure $ "No expected failure" InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" -noCheckStatus :: Request -> Request-noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}+noCheckStatus :: C.Request -> C.Request+noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing} -defManager :: Manager-defManager = unsafePerformIO $ newManager defaultManagerSettings+defManager :: C.Manager+defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings {-# NOINLINE defManager #-}
test/Servant/QuickCheck/InternalSpec.hs view
@@ -1,24 +1,26 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} 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 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, context, describe, it,+ shouldBe, shouldContain)+import Test.Hspec.Core.Spec (Arg, Example, Result (..),+ defaultParams,+ evaluateExample) -import Servant.QuickCheck-import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)+import Servant.QuickCheck+import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy) spec :: Spec spec = do serversEqualSpec serverSatisfiesSpec isComprehensiveSpec+ onlyJsonObjectSpec serversEqualSpec :: Spec serversEqualSpec = describe "serversEqual" $ do@@ -28,7 +30,17 @@ withServantServerAndContext api ctx server $ \burl2 -> do serversEqual api burl1 burl2 args bodyEquality + context "when servers are not equal" $ do ++ it "provides the failing responses in the error message" $ do+ Fail _ err <- withServantServer api2 server2 $ \burl1 ->+ withServantServer api2 server3 $ \burl2 -> do+ evalExample $ serversEqual api2 burl1 burl2 args bodyEquality+ show err `shouldContain` "Body: 1"+ show err `shouldContain` "Body: 2"+ show err `shouldContain` "Path: failplz/"+ serverSatisfiesSpec :: Spec serverSatisfiesSpec = describe "serverSatisfies" $ do @@ -46,6 +58,25 @@ <%> notAllowedContainsAllowHeader <%> mempty) + context "when predicates are false" $ do++ it "fails with informative error messages" $ do+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do+ evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)+ err `shouldContain` "getsHaveCacheControlHeader"+ err `shouldContain` "Headers"+ err `shouldContain` "Body"++onlyJsonObjectSpec :: Spec+onlyJsonObjectSpec = describe "onlyJsonObjects" $ do++ it "fails correctly" $ do+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do+ evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args+ (onlyJsonObjects <%> mempty)+ err `shouldContain` "onlyJsonObjects"++ isComprehensiveSpec :: Spec isComprehensiveSpec = describe "HasGenRequest" $ do @@ -72,12 +103,29 @@ :<|> (liftIO $ readMVar mvar >>= return . length) :<|> (const $ return ()) ++type API2 = "failplz" :> Get '[JSON] Int++api2 :: Proxy API2+api2 = Proxy++server2 :: IO (Server API2)+server2 = return $ return 1++server3 :: IO (Server API2)+server3 = return $ return 2+ ctx :: Context '[BasicAuthCheck ()] ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext ------------------------------------------------------------------------------ -- Utils ------------------------------------------------------------------------------ +evalExample :: (Example e, Arg e ~ ()) => e -> IO Result+evalExample e = evaluateExample e defaultParams ($ ()) progCallback+ where+ progCallback _ = return ()+ args :: Args args = defaultArgs { maxSuccess = noOfTestCases } @@ -85,5 +133,5 @@ #if LONG_TESTS noOfTestCases = 20000 #else-noOfTestCases = 500+noOfTestCases = 1000 #endif