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

Merge pull request #57 from Phenitei/notAllowedBug

Browse Source 
Fix #56: a notAllowedContainsAllowHeader bug
This commit is contained in:
Alp Mestanogullari 2018-08-29 12:01:14 +02:00 committed by GitHub
commit 7d6a97af5a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
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

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