mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-11-22 23:27:08 +03:00
Much better errors
This commit is contained in:
Julian K. Arni
parent
b7df33fbe8
commit
2c1152a8c0
@ -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
|
||||
|
||||
@ -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: <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 @@ onlyJsonObjects
|
||||
-- * 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 @@ getsHaveLastModifiedHeader
|
||||
-- * 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,19 +158,19 @@ notAllowedContainsAllowHeader
|
||||
-- * @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__]
|
||||
--
|
||||
@ -182,34 +186,32 @@ honoursAcceptHeader
|
||||
-- * @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 @@ linkHeadersAreValid
|
||||
-- * @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 @@ 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user