From 89c9170bdfce4b5975ce677ec9a22490ae8a5757 Mon Sep 17 00:00:00 2001 From: Joachim Desroches Date: Mon, 27 Aug 2018 18:12:22 +0200 Subject: [PATCH] Fix #56 A bug where the request printed alongside a failure in notAllowedContainsAllowHeader was not the request causing the failure. --- src/Servant/QuickCheck/Internal/Predicates.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 4c2726f..cfeccec 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -189,14 +189,15 @@ getsHaveLastModifiedHeader notAllowedContainsAllowHeader :: RequestPredicate notAllowedContainsAllowHeader = 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:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x + let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound] + , renderStdMethod m /= method req ] + resp <- mapM (flip httpLbs mgr) reqs + + case filter pred' (zip reqs resp) of + (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x) [] -> return resp where - pred' resp = responseStatus resp == status405 && not (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)