From 8673a776dd605eb3d2d34d6c46eb39fc85424a61 Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Sat, 21 Oct 2017 09:57:17 -0700 Subject: [PATCH] Rework ResponsePredicate to include request and PredicateFailure without Maybe request --- src/Servant/QuickCheck/Internal/ErrorTypes.hs | 9 +---- src/Servant/QuickCheck/Internal/Predicates.hs | 40 ++++++++++--------- 2 files changed, 23 insertions(+), 26 deletions(-) diff --git a/src/Servant/QuickCheck/Internal/ErrorTypes.hs b/src/Servant/QuickCheck/Internal/ErrorTypes.hs index 1d9cb9e..8aebf0b 100644 --- a/src/Servant/QuickCheck/Internal/ErrorTypes.hs +++ b/src/Servant/QuickCheck/Internal/ErrorTypes.hs @@ -12,7 +12,7 @@ import Prelude.Compat import Text.PrettyPrint data PredicateFailure - = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString) + = PredicateFailure T.Text (C.Request) (C.Response LBS.ByteString) deriving (Typeable, Generic) instance Exception ServerEqualityFailure where @@ -71,10 +71,5 @@ prettyPredicateFailure :: PredicateFailure -> Doc prettyPredicateFailure (PredicateFailure predicate req resp) = text "Predicate failed" $$ (nest 5 $ text "Predicate:" <+> (text $ T.unpack predicate) - $$ r + $$ prettyReq req $$ prettyResp resp) - where - r = case req of - Nothing -> text "" - Just v -> prettyReq v - diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 6253d86..3e3b282 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -41,8 +41,9 @@ import Servant.QuickCheck.Internal.ErrorTypes -- -- /Since 0.0.0.0/ not500 :: ResponsePredicate -not500 = ResponsePredicate $ \resp -> - when (responseStatus resp == status500) $ fail "not500" +not500 = ResponsePredicate $ \req resp -> + when (responseStatus resp == status500) $ + throw $ PredicateFailure "not500" req resp -- | [__Optional__] -- @@ -57,7 +58,7 @@ notLongerThan maxAllowed resp <- httpLbs req mgr end <- getTime Monotonic when (toNanoSecs (end `diffTimeSpec` start) > maxAllowed) $ - throw $ PredicateFailure "notLongerThan" (Just req) resp + throw $ PredicateFailure "notLongerThan" req resp return [] -- | [__Best Practice__] @@ -83,8 +84,8 @@ notLongerThan maxAllowed -- /Since 0.0.0.0/ onlyJsonObjects :: ResponsePredicate onlyJsonObjects - = ResponsePredicate (\resp -> case go resp of - Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp + = ResponsePredicate (\req resp -> case go resp of + Nothing -> throw $ PredicateFailure "onlyJsonObjects" req resp Just () -> return ()) where go r = do @@ -119,9 +120,9 @@ createContainsValidLocation resp <- httpLbs req mgr if responseStatus resp == status201 then case lookup "Location" $ responseHeaders resp of - Nothing -> fail n + Nothing -> throw $ PredicateFailure "createContainsValidLocation" req resp Just l -> case parseRequest $ SBSC.unpack l of - Nothing -> fail n + Nothing -> throw $ PredicateFailure "createContainsValidLocation" req resp Just x -> do resp2 <- httpLbs x mgr status2XX resp2 n @@ -159,8 +160,8 @@ getsHaveLastModifiedHeader if (method req == methodGet) then do resp <- httpLbs req mgr - unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do - throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp + unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ + throw $ PredicateFailure "getsHaveLastModifiedHeader" req resp return [resp] else return [] @@ -192,7 +193,7 @@ notAllowedContainsAllowHeader | m <- [minBound .. maxBound ] , renderStdMethod m /= method req ] case filter pred' resp of - (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x + (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" req x [] -> return resp where pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp) @@ -250,8 +251,8 @@ getsHaveCacheControlHeader if (method req == methodGet) then do resp <- httpLbs req mgr - unless (hasValidHeader "Cache-Control" (const True) resp) $ do - throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp + unless (hasValidHeader "Cache-Control" (const True) resp) $ + throw $ PredicateFailure "getsHaveCacheControlHeader" req resp return [resp] else return [] @@ -267,7 +268,7 @@ headsHaveCacheControlHeader then do resp <- httpLbs req mgr unless (hasValidHeader "Cache-Control" (const True) resp) $ - throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp + throw $ PredicateFailure "headsHaveCacheControlHeader" req resp return [resp] else return [] {- @@ -333,10 +334,10 @@ linkHeadersAreValid -- /Since 0.0.0.0/ unauthorizedContainsWWWAuthenticate :: ResponsePredicate unauthorizedContainsWWWAuthenticate - = ResponsePredicate $ \resp -> + = ResponsePredicate $ \req resp -> if responseStatus resp == status401 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $ - fail "unauthorizedContainsWWWAuthenticate" + throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" req resp else return () -- * Predicate logic @@ -351,12 +352,12 @@ unauthorizedContainsWWWAuthenticate -- -- /Since 0.0.0.0/ newtype ResponsePredicate = ResponsePredicate - { getResponsePredicate :: Response LBS.ByteString -> IO () + { getResponsePredicate :: Request -> Response LBS.ByteString -> IO () } deriving (Generic) instance Monoid ResponsePredicate where - mempty = ResponsePredicate $ const $ return () - ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x + mempty = ResponsePredicate (\req resp -> return ()) + ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x y -> a x y >> b x y -- | A predicate that depends on both the request and the response. -- @@ -406,7 +407,8 @@ finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Jus where go = do resps <- getRequestPredicate (requestPredicates p) req mgr - mapM_ (getResponsePredicate $ responsePredicates p) resps + let responder = getResponsePredicate (responsePredicates p) req + mapM_ responder resps return Nothing -- * helpers