ilyakooo0/servant-quickcheck
1
0
Fork 0
mirror of https://github.com/ilyakooo0/servant-quickcheck.git synced 2024-11-22 05:42:11 +03:00
Code Issues Packages Projects Releases Wiki Activity

Fix #56

Browse Source 
A bug where the request printed alongside a failure in
notAllowedContainsAllowHeader was not the request causing the failure.
This commit is contained in:
Joachim Desroches 2018-08-27 18:12:22 +02:00
parent 35c98622fc
commit 89c9170bdf
No known key found for this signature in database
GPG Key ID: 9470B2186573EC6E
1 changed files with 7 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Servant/QuickCheck/Internal/Predicates.hs
View File

@ -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)