From 9743ac5ec44015851fdcf77b982f3fc1b636a817 Mon Sep 17 00:00:00 2001 From: Joachim Desroches Date: Fri, 24 Aug 2018 17:31:46 +0200 Subject: [PATCH] Fix a bug in onlyJsonObjects that made it fail if there was no content-type. --- src/Servant/QuickCheck/Internal/Predicates.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 4c2726f..b44d0b0 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -84,15 +84,13 @@ notLongerThan maxAllowed -- /Since 0.0.0.0/ onlyJsonObjects :: ResponsePredicate onlyJsonObjects - = ResponsePredicate (\resp -> case go resp of - Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp - Just () -> return ()) - where - go r = do - ctyp <- lookup "content-type" (first foldedCase <$> responseHeaders r) - when ("application/json" `SBS.isPrefixOf` ctyp) $ do - (_ :: Object) <- decode (responseBody r) - return () + = ResponsePredicate (\resp -> do + case lookup "content-type" (first foldedCase <$> responseHeaders resp) of + Nothing -> return () + Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do + case (decode (responseBody resp) :: Maybe Object) of + Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp + Just _ -> return ()) -- | __Optional__ --