git.iko.soy/servant-quickcheck
on master help sign in
[READY] Fixes #7: Add HTML missing Doctype predicate with tests (#33)

* Add HTML missing Doctype predicate with tests * Don't use 'fail' in predicates * Add RFC reference and description for HTML doctype * Only take enough of respBody to compare to doctype string

commitd65abc856f6708558d96fa8aa1973d578bc85dbe authorErik <eraker@gmail.com> dateSat 21 Oct 2017, 15:20 (9 years ago) parent54a05a5
4 files changed+75−11
compare with master
unifiedsplit
servant-quickcheck.cabal+2 src/Servant/QuickCheck.hs+3 src/Servant/QuickCheck/Internal/Predicates.hs+34−11 test/Servant/QuickCheck/InternalSpec.hs+36
servant-quickcheck.cabal+2
@@ -90,10 +90,12 @@ test-suite spec
9090 , hspec
9191 , hspec-core
9292 , http-client
93+ , blaze-html
9394 , warp
9495 , servant-server
9596 , servant-client
9697 , servant
98+ , servant-blaze
9799 , transformers
98100 , QuickCheck
99101 , quickcheck-io
src/Servant/QuickCheck.hs+3
@@ -34,6 +34,9 @@ module Servant.QuickCheck
3434 , getsHaveCacheControlHeader
3535 , headsHaveCacheControlHeader
3636 , createContainsValidLocation
37+ -- * Html Predicates
38+ , htmlIncludesDoctype
39+
3740 -- *** Predicate utilities and types
3841 , (<%>)
3942 , Predicates
src/Servant/QuickCheck/Internal/Predicates.hs+34−11
@@ -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)
1414import Data.Monoid ((<>))
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--
@@ -119,12 +120,12 @@ createContainsValidLocation
119120 resp <- httpLbs req mgr
120121 if responseStatus resp == status201
121122 then case lookup "Location" $ responseHeaders resp of
122− Nothing -> fail n
123+ Nothing -> throw $ PredicateFailure n (Just req) resp
123124 Just l -> case parseRequest $ SBSC.unpack l of
124− Nothing -> fail n
125+ Nothing -> throw $ PredicateFailure n (Just req) resp
125126 Just x -> do
126127 resp2 <- httpLbs x mgr
127− status2XX resp2 n
128+ status2XX (Just req) resp2 n
128129 return [resp, resp2]
129130 else return [resp]
130131
@@ -225,7 +226,7 @@ honoursAcceptHeader
225226 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
226227 if status100 < scode && scode < status300
227228 then if isJust $ sctype >>= \x -> matchAccept [x] sacc
228− then fail "honoursAcceptHeader"
229+ then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
229230 else return [resp]
230231 else return [resp]
231232
@@ -336,7 +337,29 @@ unauthorizedContainsWWWAuthenticate
336337 = ResponsePredicate $ \resp ->
337338 if responseStatus resp == status401
338339 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339− fail "unauthorizedContainsWWWAuthenticate"
340+ throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
341+ else return ()
342+
343+
344+-- | [__RFC Compliance__]
345+--
346+-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
347+--
348+-- This function checks that HTML documents (those with `Content-Type: text/html...`)
349+-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
350+--
351+-- __References__:
352+--
353+-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
354+-- /Since 0.3.0.0/
355+htmlIncludesDoctype :: ResponsePredicate
356+htmlIncludesDoctype
357+ = ResponsePredicate $ \resp ->
358+ if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
359+ then do
360+ let htmlContent = foldCase . LBS.take 20 $ responseBody resp
361+ unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
362+ throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
340363 else return ()
341364
342365-- * Predicate logic
@@ -422,8 +445,8 @@ isRFC822Date s
422445 Nothing -> False
423446 Just (_ :: UTCTime) -> True
424447
425−status2XX :: Monad m => Response b -> String -> m ()
426−status2XX r t
427− | status200 <= responseStatus r && responseStatus r < status300
448+status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
449+status2XX mreq resp t
450+ | status200 <= responseStatus resp && responseStatus resp < status300
428451 = return ()
429− | otherwise = fail t
452+ | otherwise = throw $ PredicateFailure t mreq resp
test/Servant/QuickCheck/InternalSpec.hs+36
@@ -12,6 +12,9 @@ import Data.Maybe (fromJust)
1212import Network.HTTP.Client (path, queryString)
1313import Prelude.Compat
1414import Servant
15+import Servant.HTML.Blaze (HTML)
16+import qualified Text.Blaze.Html as Blaze
17+import qualified Text.Blaze.Html5 as Blaze5
1518import Test.Hspec (Spec, context, describe, it, shouldBe,
1619 shouldContain)
1720import Test.Hspec.Core.Spec (Arg, Example, Result (..),
@@ -48,6 +51,7 @@ spec = do
4851 queryParamsSpec
4952 queryFlagsSpec
5053 deepPathSpec
54+ htmlDocTypesSpec
5155 unbiasedGenerationSpec
5256
5357serversEqualSpec :: Spec
@@ -189,6 +193,25 @@ queryFlagsSpec = describe "QueryFlags" $ do
189193 qs = C.unpack $ queryString req
190194 qs `shouldBe` "one&two"
191195
196+htmlDocTypesSpec :: Spec
197+htmlDocTypesSpec = describe "HtmlDocTypes" $ do
198+
199+ it "fails HTML without doctype correctly" $ do
200+ err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
201+ evalExample $ serverSatisfies docTypeApi burl args
202+ (htmlIncludesDoctype <%> mempty)
203+ show err `shouldContain` "htmlIncludesDoctype"
204+
205+ it "passes HTML with a doctype at start" $ do
206+ withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
207+ serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
208+
209+ it "accepts json endpoints and passes over them in silence" $ do
210+ withServantServerAndContext api ctx server $ \burl -> do
211+ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
212+ (htmlIncludesDoctype <%> mempty)
213+
214+
192215makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
193216makeRandomRequest large burl = do
194217 req <- generate $ runGenRequest large
@@ -258,7 +281,20 @@ server2 = return $ return 1
258281server3 :: IO (Server API2)
259282server3 = return $ return 2
260283
284+-- With Doctypes
285+type HtmlDoctype = Get '[HTML] Blaze.Html
286+
287+docTypeApi :: Proxy HtmlDoctype
288+docTypeApi = Proxy
289+
290+docTypeServer :: IO (Server HtmlDoctype)
291+docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
292+
293+noDocTypeServer :: IO (Server HtmlDoctype)
294+noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
295+
261296
297+-- Api for unbiased generation of requests tests
262298largeApi :: Proxy LargeAPI
263299largeApi = Proxy
264300