@@ -7,11 +7,12 @@ 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 (mk, foldedCase)
10+import Data.CaseInsensitive (foldCase, foldedCase, mk)
1111import Data.Either (isRight)
1212import Data.List.Split (wordsBy)
1313import Data.Maybe (fromMaybe, isJust)
14−import Data.Monoid ((<>))
14+import Data.Semigroup (Semigroup (..))
15+import qualified Data.Text as T
1516import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
1617 rfc822DateFormat)
1718import GHC.Generics (Generic)
@@ -42,7 +43,7 @@ import Servant.QuickCheck.Internal.ErrorTypes
4243-- /Since 0.0.0.0/
4344not500 :: ResponsePredicate
4445not500 = ResponsePredicate $ \resp ->
45− when (responseStatus resp == status500) $ fail "not500"
46+ when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
4647
4748-- | [__Optional__]
4849--
@@ -83,15 +84,13 @@ notLongerThan maxAllowed
8384-- /Since 0.0.0.0/
8485onlyJsonObjects :: ResponsePredicate
8586onlyJsonObjects
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 ()
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 ())
9594
9695-- | __Optional__
9796--
@@ -119,12 +118,12 @@ createContainsValidLocation
119118 resp <- httpLbs req mgr
120119 if responseStatus resp == status201
121120 then case lookup "Location" $ responseHeaders resp of
122− Nothing -> fail n
121+ Nothing -> throw $ PredicateFailure n (Just req) resp
123122 Just l -> case parseRequest $ SBSC.unpack l of
124− Nothing -> fail n
123+ Nothing -> throw $ PredicateFailure n (Just req) resp
125124 Just x -> do
126125 resp2 <- httpLbs x mgr
127− status2XX resp2 n
126+ status2XX (Just req) resp2 n
128127 return [resp, resp2]
129128 else return [resp]
130129
@@ -188,14 +187,15 @@ getsHaveLastModifiedHeader
188187notAllowedContainsAllowHeader :: RequestPredicate
189188notAllowedContainsAllowHeader
190189 = RequestPredicate $ \req mgr -> do
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
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)
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 fail "honoursAcceptHeader"
228+ then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
229229 else return [resp]
230230 else return [resp]
231231
@@ -336,7 +336,29 @@ unauthorizedContainsWWWAuthenticate
336336 = ResponsePredicate $ \resp ->
337337 if responseStatus resp == status401
338338 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339− fail "unauthorizedContainsWWWAuthenticate"
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
340362 else return ()
341363
342364-- * Predicate logic
@@ -354,9 +376,12 @@ newtype ResponsePredicate = ResponsePredicate
354376 { getResponsePredicate :: Response LBS.ByteString -> IO ()
355377 } deriving (Generic)
356378
379+instance Semigroup ResponsePredicate where
380+ ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
381+
357382instance Monoid ResponsePredicate where
358383 mempty = ResponsePredicate $ const $ return ()
359− ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
384+ mappend = (<>)
360385
361386-- | A predicate that depends on both the request and the response.
362387--
@@ -368,7 +393,11 @@ newtype RequestPredicate = RequestPredicate
368393-- TODO: This isn't actually a monoid
369394instance Monoid RequestPredicate where
370395 mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
371− RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->
396+ mappend = (<>)
397+
398+-- TODO: This isn't actually a monoid
399+instance Semigroup RequestPredicate where
400+ RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
372401 liftM2 (<>) (a r mgr) (b r mgr)
373402
374403-- | A set of predicates. Construct one with 'mempty' and '<%>'.
@@ -377,10 +406,13 @@ data Predicates = Predicates
377406 , responsePredicates :: ResponsePredicate
378407 } deriving (Generic)
379408
409+instance Semigroup Predicates where
410+ a <> b = Predicates (requestPredicates a <> requestPredicates b)
411+ (responsePredicates a <> responsePredicates b)
412+
380413instance Monoid Predicates where
381414 mempty = Predicates mempty mempty
382− a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
383− (responsePredicates a <> responsePredicates b)
415+ mappend = (<>)
384416
385417class JoinPreds a where
386418 joinPreds :: a -> Predicates -> Predicates
@@ -422,8 +454,8 @@ isRFC822Date s
422454 Nothing -> False
423455 Just (_ :: UTCTime) -> True
424456
425−status2XX :: Monad m => Response b -> String -> m ()
426−status2XX r t
427− | status200 <= responseStatus r && responseStatus r < status300
457+status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
458+status2XX mreq resp t
459+ | status200 <= responseStatus resp && responseStatus resp < status300
428460 = return ()
429− | otherwise = fail t
461+ | otherwise = throw $ PredicateFailure t mreq resp