diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -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 diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -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. -- diff --git a/src/Servant/QuickCheck/Internal.hs b/src/Servant/QuickCheck/Internal.hs --- a/src/Servant/QuickCheck/Internal.hs +++ b/src/Servant/QuickCheck/Internal.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal/Equality.hs b/src/Servant/QuickCheck/Internal/Equality.hs --- a/src/Servant/QuickCheck/Internal/Equality.hs +++ b/src/Servant/QuickCheck/Internal/Equality.hs @@ -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 } diff --git a/src/Servant/QuickCheck/Internal/ErrorTypes.hs b/src/Servant/QuickCheck/Internal/ErrorTypes.hs new file mode 100644 --- /dev/null +++ b/src/Servant/QuickCheck/Internal/ErrorTypes.hs @@ -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 + diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -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: -- -- /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: -- -- /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: -- -- /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: -- -- /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: -- -- /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: -- -- /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 diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -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 #-} diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -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