mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-09-11 18:37:09 +03:00
Merge pull request #57 from Phenitei/notAllowedBug
Fix #56: a notAllowedContainsAllowHeader bug
This commit is contained in:
commit
7d6a97af5a
@ -187,14 +187,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)
|
||||
|
Loading…
Reference in New Issue
Block a user