diff --git a/src/Servant/QuickCheck/Internal/ErrorTypes.hs b/src/Servant/QuickCheck/Internal/ErrorTypes.hs index 7cbf33d..e43b46e 100644 --- a/src/Servant/QuickCheck/Internal/ErrorTypes.hs +++ b/src/Servant/QuickCheck/Internal/ErrorTypes.hs @@ -1,40 +1,72 @@ module Servant.QuickCheck.Internal.ErrorTypes where -import Text.PrettyPrint -import Prelude.Compat -import Data.String (IsString(fromString)) -import GHC.Generics (Generic) +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 Request = Request - { requestBody :: String - , requestHeaders :: [String] - , requestUrl :: String - } deriving (Eq, Show, Read, Generic) +prettyHeaders :: [Header] -> Doc +prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs + where + prettyHdr (hn, h) = text (show hn) <> colon <+> text (show h) -prettyReq :: Request -> Doc +prettyReq :: C.Request -> Doc prettyReq r = text "Request:" $$ (nest 5 $ - text "URL:" <+> (nest 5 $ text $ requestUrl r) - $$ text "Headers:" <+> (nest 5 $ hsep $ text <$> requestHeaders r) - $$ text "Body:" <+> (nest 5 $ text $ requestBody r)) + 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" -instance IsString Request where - fromString url = Request "" [] url +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)) -data Response = Response - { responseBody :: String - , responseHeaders :: [String] - } deriving (Eq, Show, Read, Generic) - -instance IsString Response where - fromString body = Response body [] -- The error that occurred. -data Failure - = PredicateFailure String Request Response - | ServerEqualityFailure Request Response Response - deriving (Eq, Read, Generic) +data PredicateFailure = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString) + deriving (Generic) -instance Show Failure where - show (PredicateFailure pred req resp) - = "Predicate failed for " ++ pred +data ServerEqualityFailure = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString) + deriving (Generic) + +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 + +instance Show ServerEqualityFailure where + show = render . prettyServerEqualityFailure + +instance Exception ServerEqualityFailure where + +instance Show PredicateFailure where + show = render . prettyPredicateFailure + +instance Exception PredicateFailure where diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 7716637..e896889 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -1,6 +1,8 @@ module Servant.QuickCheck.Internal.Predicates where -import Control.Monad (liftM2) +import Control.Exception (catch, SomeException, throw) +import Control.Monad (liftM2, guard, ap) +import Control.Monad.Reader import Data.Aeson (Object, decode) import Data.Bifunctor (Bifunctor (..)) import Prelude.Compat @@ -24,6 +26,9 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod, status300, status401, status405, status500, status100) +import Servant.QuickCheck.Internal.ErrorTypes + + -- | [__Best Practice__] -- -- @500 Internal Server Error@ should be avoided - it may represent some @@ -33,8 +38,9 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod, -- 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 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu -- * 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 @@ onlyJsonObjects -- * 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 @@ getsHaveLastModifiedHeader -- * 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,19 +158,19 @@ notAllowedContainsAllowHeader -- * @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__] -- @@ -182,34 +186,32 @@ honoursAcceptHeader -- * @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 @@ linkHeadersAreValid -- * @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 @@ unauthorizedContainsWWWAuthenticate -- | 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) +data ResponsePredicate = ResponsePredicate + { getResponsePredicate :: Response LBS.ByteString -> IO () + } deriving (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 - } +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] + joinPreds :: a -> Predicates -> Predicates -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' +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 @@ instance JoinPreds (ResponsePredicate Text Bool) where -- > 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 @@ 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 +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 index 72747a7..85d6789 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} module Servant.QuickCheck.Internal.QuickCheck where import qualified Data.ByteString.Lazy as LBS @@ -18,6 +19,7 @@ import Test.QuickCheck (Args (..), Result (..), import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run, monitor) import Test.QuickCheck.Property (counterexample) import Control.Monad (unless) +import Control.Concurrent (newMVar, modifyMVar_, readMVar) import Servant.QuickCheck.Internal.Equality import Servant.QuickCheck.Internal.HasGenRequest @@ -60,17 +62,22 @@ 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 + -- 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" @@ -94,22 +101,27 @@ serversEqual api burl1 burl2 args req = do -- -- /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 diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 1e65bc2..865d7ba 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -1,28 +1,27 @@ {-# 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, context, - describe, it, - pending, shouldBe) -import Test.Hspec.Core.Spec (Arg, Example, - Result (..), - defaultParams, - evaluateExample) +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, + pending, shouldBe, + shouldContain) +import Test.Hspec.Core.Spec (Arg, Example, Result (..), + defaultParams, + evaluateExample) -import Servant.QuickCheck -import Servant.QuickCheck.Internal (genRequest, Failure(..), serverDoesntSatisfy) +import Servant.QuickCheck +import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy) spec :: Spec spec = do serversEqualSpec serverSatisfiesSpec isComprehensiveSpec + onlyJsonObjectSpec serversEqualSpec :: Spec serversEqualSpec = describe "serversEqual" $ do @@ -34,28 +33,14 @@ serversEqualSpec = describe "serversEqual" $ do context "when servers are not equal" $ do - it "provides the failing requests in the error message" $ do - e <- withServantServer api2 server2 $ \burl1 -> - withServantServer api2 server3 $ \burl2 -> do - evalExample $ serversEqual api2 burl1 burl2 args bodyEquality - e `shouldBe` e - it "provides the failing requests in the error message" $ 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 - print err - let ServerEqualityFailure req _ _ = read err - req `shouldBe` "failplz" - - {-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-} - {-let ServerEqualityFailure _ r1 r2 = read err-} - {-r1 `shouldBe` "1"-} - {-r2 `shouldBe` "2"-} - + show err `shouldContain` "Body: 1" + show err `shouldContain` "Body: 2" + show err `shouldContain` "Path: failplz/" serverSatisfiesSpec :: Spec serverSatisfiesSpec = describe "serverSatisfies" $ do @@ -74,8 +59,24 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do <%> notAllowedContainsAllowHeader <%> mempty) - context "when predicates are false" $ - it "fails with informative error messages" $ pending + 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 @@ -133,5 +134,5 @@ noOfTestCases :: Int #if LONG_TESTS noOfTestCases = 20000 #else -noOfTestCases = 500 +noOfTestCases = 1000 #endif