@@ -7,12 +7,11 @@ import Data.Bifunctor (first)
77import qualified Data.ByteString as SBS
88import qualified Data.ByteString.Char8 as SBSC
99import qualified Data.ByteString.Lazy as LBS
10−import Data.CaseInsensitive (foldCase, foldedCase, mk)
10+import Data.CaseInsensitive (mk, foldedCase)
1111import Data.Either (isRight)
1212import Data.List.Split (wordsBy)
1313import Data.Maybe (fromMaybe, isJust)
14−import Data.Semigroup (Semigroup (..))
15−import qualified Data.Text as T
14+import Data.Monoid ((<>))
1615import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
1716 rfc822DateFormat)
1817import GHC.Generics (Generic)
@@ -43,7 +42,7 @@ import Servant.QuickCheck.Internal.ErrorTypes
4342-- /Since 0.0.0.0/
4443not500 :: ResponsePredicate
4544not500 = ResponsePredicate $ \resp ->
46− when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
45+ when (responseStatus resp == status500) $ fail "not500"
4746
4847-- | [__Optional__]
4948--
@@ -84,13 +83,15 @@ notLongerThan maxAllowed
8483-- /Since 0.0.0.0/
8584onlyJsonObjects :: ResponsePredicate
8685onlyJsonObjects
87− = ResponsePredicate (\resp -> do
88− case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
89− Nothing -> return ()
90− Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do
91− case (decode (responseBody resp) :: Maybe Object) of
92− Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
93− Just _ -> return ())
86+ = ResponsePredicate (\resp -> case go resp of
87+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
88+ Just () -> return ())
89+ where
90+ go r = do
91+ ctyp <- lookup "content-type" (first foldedCase <$> responseHeaders r)
92+ when ("application/json" `SBS.isPrefixOf` ctyp) $ do
93+ (_ :: Object) <- decode (responseBody r)
94+ return ()
9495
9596-- | __Optional__
9697--
@@ -118,12 +119,12 @@ createContainsValidLocation
118119 resp <- httpLbs req mgr
119120 if responseStatus resp == status201
120121 then case lookup "Location" $ responseHeaders resp of
121− Nothing -> throw $ PredicateFailure n (Just req) resp
122+ Nothing -> fail n
122123 Just l -> case parseRequest $ SBSC.unpack l of
123− Nothing -> throw $ PredicateFailure n (Just req) resp
124+ Nothing -> fail n
124125 Just x -> do
125126 resp2 <- httpLbs x mgr
126− status2XX (Just req) resp2 n
127+ status2XX resp2 n
127128 return [resp, resp2]
128129 else return [resp]
129130
@@ -187,15 +188,14 @@ getsHaveLastModifiedHeader
187188notAllowedContainsAllowHeader :: RequestPredicate
188189notAllowedContainsAllowHeader
189190 = RequestPredicate $ \req mgr -> do
190− let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
191− , renderStdMethod m /= method req ]
192− resp <- mapM (flip httpLbs mgr) reqs
193−
194− case filter pred' (zip reqs resp) of
195− (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
191+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
192+ | m <- [minBound .. maxBound ]
193+ , renderStdMethod m /= method req ]
194+ case filter pred' resp of
195+ (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x
196196 [] -> return resp
197197 where
198− pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
198+ pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
199199 where
200200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
201201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -225,7 +225,7 @@ honoursAcceptHeader
225225 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
226226 if status100 < scode && scode < status300
227227 then if isJust $ sctype >>= \x -> matchAccept [x] sacc
228− then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
228+ then fail "honoursAcceptHeader"
229229 else return [resp]
230230 else return [resp]
231231
@@ -336,29 +336,7 @@ unauthorizedContainsWWWAuthenticate
336336 = ResponsePredicate $ \resp ->
337337 if responseStatus resp == status401
338338 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339− throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
340− else return ()
341−
342−
343−-- | [__RFC Compliance__]
344−--
345−-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
346−--
347−-- This function checks that HTML documents (those with `Content-Type: text/html...`)
348−-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
349−--
350−-- __References__:
351−--
352−-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
353−-- /Since 0.3.0.0/
354−htmlIncludesDoctype :: ResponsePredicate
355−htmlIncludesDoctype
356− = ResponsePredicate $ \resp ->
357− if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
358− then do
359− let htmlContent = foldCase . LBS.take 20 $ responseBody resp
360− unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
361− throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
339+ fail "unauthorizedContainsWWWAuthenticate"
362340 else return ()
363341
364342-- * Predicate logic
@@ -376,12 +354,9 @@ newtype ResponsePredicate = ResponsePredicate
376354 { getResponsePredicate :: Response LBS.ByteString -> IO ()
377355 } deriving (Generic)
378356
379−instance Semigroup ResponsePredicate where
380− ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
381−
382357instance Monoid ResponsePredicate where
383358 mempty = ResponsePredicate $ const $ return ()
384− mappend = (<>)
359+ ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
385360
386361-- | A predicate that depends on both the request and the response.
387362--
@@ -393,11 +368,7 @@ newtype RequestPredicate = RequestPredicate
393368-- TODO: This isn't actually a monoid
394369instance Monoid RequestPredicate where
395370 mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
396− mappend = (<>)
397−
398−-- TODO: This isn't actually a monoid
399−instance Semigroup RequestPredicate where
400− RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
371+ RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->
401372 liftM2 (<>) (a r mgr) (b r mgr)
402373
403374-- | A set of predicates. Construct one with 'mempty' and '<%>'.
@@ -406,13 +377,10 @@ data Predicates = Predicates
406377 , responsePredicates :: ResponsePredicate
407378 } deriving (Generic)
408379
409−instance Semigroup Predicates where
410− a <> b = Predicates (requestPredicates a <> requestPredicates b)
411− (responsePredicates a <> responsePredicates b)
412−
413380instance Monoid Predicates where
414381 mempty = Predicates mempty mempty
415− mappend = (<>)
382+ a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
383+ (responsePredicates a <> responsePredicates b)
416384
417385class JoinPreds a where
418386 joinPreds :: a -> Predicates -> Predicates
@@ -454,8 +422,8 @@ isRFC822Date s
454422 Nothing -> False
455423 Just (_ :: UTCTime) -> True
456424
457−status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
458−status2XX mreq resp t
459− | status200 <= responseStatus resp && responseStatus resp < status300
425+status2XX :: Monad m => Response b -> String -> m ()
426+status2XX r t
427+ | status200 <= responseStatus r && responseStatus r < status300
460428 = return ()
461− | otherwise = throw $ PredicateFailure t mreq resp
429+ | otherwise = fail t