d65abc8 · servant-quickcheck

git.iko.soy/servant-quickcheck

on master help sign in

[READY] Fixes #7: Add HTML missing Doctype predicate with tests (#33)

d65abc8Erik9 years ago

servant-quickcheck.cabal+2

compare with master

unifiedsplit

@@ -90,10 +90,12 @@ test-suite spec

90 , hspec

91 , hspec-core

92 , http-client

93+ , blaze-html

93 , warp

94 , warp

94 , servant-server

95 , servant-server

95 , servant-client

96 , servant-client

96 , servant

97 , servant

98+ , servant-blaze

97 , transformers

99 , transformers

98 , QuickCheck

100 , QuickCheck

99 , quickcheck-io

101 , quickcheck-io

src/Servant/QuickCheck.hs+3

@@ -34,6 +34,9 @@ module Servant.QuickCheck

34 , getsHaveCacheControlHeader

35 , headsHaveCacheControlHeader

36 , createContainsValidLocation

37+ -- * Html Predicates

38+ , htmlIncludesDoctype

39+

37 -- *** Predicate utilities and types

40 -- *** Predicate utilities and types

38 , (<%>)

41 , (<%>)

39 , Predicates

42 , Predicates

src/Servant/QuickCheck/Internal/Predicates.hs+34−11

@@ -7,11 +7,12 @@ import Data.Bifunctor (first)

7import qualified Data.ByteString as SBS

8import qualified Data.ByteString.Char8 as SBSC

9import qualified Data.ByteString.Lazy as LBS

10−import Data.CaseInsensitive (mk, foldedCase)

10+import Data.CaseInsensitive (foldCase, foldedCase, mk)

11import Data.Either (isRight)

12import Data.List.Split (wordsBy)

13import Data.Maybe (fromMaybe, isJust)

14import Data.Monoid ((<>))

15+import qualified Data.Text as T

15import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,

16import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,

16 rfc822DateFormat)

17 rfc822DateFormat)

17import GHC.Generics (Generic)

18import GHC.Generics (Generic)

@@ -42,7 +43,7 @@ import Servant.QuickCheck.Internal.ErrorTypes

42-- /Since 0.0.0.0/

43-- /Since 0.0.0.0/

43not500 :: ResponsePredicate

44not500 :: ResponsePredicate

44not500 = ResponsePredicate $ \resp ->

45not500 = ResponsePredicate $ \resp ->

45− when (responseStatus resp == status500) $ fail "not500"

46+ when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp

47-- | [__Optional__]

48-- | [__Optional__]

48--

49--

@@ -119,12 +120,12 @@ createContainsValidLocation

119 resp <- httpLbs req mgr

120 resp <- httpLbs req mgr

120 if responseStatus resp == status201

121 if responseStatus resp == status201

121 then case lookup "Location" $ responseHeaders resp of

122 then case lookup "Location" $ responseHeaders resp of

122− Nothing -> fail n

123+ Nothing -> throw $ PredicateFailure n (Just req) resp

123 Just l -> case parseRequest $ SBSC.unpack l of

124 Just l -> case parseRequest $ SBSC.unpack l of

124− Nothing -> fail n

125+ Nothing -> throw $ PredicateFailure n (Just req) resp

125 Just x -> do

126 Just x -> do

126 resp2 <- httpLbs x mgr

127 resp2 <- httpLbs x mgr

127− status2XX resp2 n

128+ status2XX (Just req) resp2 n

128 return [resp, resp2]

129 return [resp, resp2]

129 else return [resp]

130 else return [resp]

130

131

@@ -225,7 +226,7 @@ honoursAcceptHeader

225 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)

226 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)

226 if status100 < scode && scode < status300

227 if status100 < scode && scode < status300

227 then if isJust $ sctype >>= \x -> matchAccept [x] sacc

228 then if isJust $ sctype >>= \x -> matchAccept [x] sacc

228− then fail "honoursAcceptHeader"

229+ then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp

229 else return [resp]

230 else return [resp]

231 else return [resp]

231

232

@@ -336,7 +337,29 @@ unauthorizedContainsWWWAuthenticate

336 = ResponsePredicate $ \resp ->

337 = ResponsePredicate $ \resp ->

337 if responseStatus resp == status401

338 if responseStatus resp == status401

338 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $

339 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

340 else return ()

363 else return ()

341

364

342-- * Predicate logic

365-- * Predicate logic

@@ -422,8 +445,8 @@ isRFC822Date s

422 Nothing -> False

445 Nothing -> False

423 Just (_ :: UTCTime) -> True

446 Just (_ :: UTCTime) -> True

424

447

425−status2XX :: Monad m => Response b -> String -> m ()

448+status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()

426−status2XX r t

449+status2XX mreq resp t

427− | status200 <= responseStatus r && responseStatus r < status300

450+ | status200 <= responseStatus resp && responseStatus resp < status300

428 = return ()

451 = 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)

12import Network.HTTP.Client (path, queryString)

13import Prelude.Compat

14import Servant

15+import Servant.HTML.Blaze (HTML)

16+import qualified Text.Blaze.Html as Blaze

17+import qualified Text.Blaze.Html5 as Blaze5

15import Test.Hspec (Spec, context, describe, it, shouldBe,

18import Test.Hspec (Spec, context, describe, it, shouldBe,

16 shouldContain)

19 shouldContain)

17import Test.Hspec.Core.Spec (Arg, Example, Result (..),

20import Test.Hspec.Core.Spec (Arg, Example, Result (..),

@@ -48,6 +51,7 @@ spec = do

48 queryParamsSpec

51 queryParamsSpec

49 queryFlagsSpec

52 queryFlagsSpec

50 deepPathSpec

53 deepPathSpec

54+ htmlDocTypesSpec

51 unbiasedGenerationSpec

55 unbiasedGenerationSpec

53serversEqualSpec :: Spec

57serversEqualSpec :: Spec

@@ -189,6 +193,25 @@ queryFlagsSpec = describe "QueryFlags" $ do

189 qs = C.unpack $ queryString req

193 qs = C.unpack $ queryString req

190 qs `shouldBe` "one&two"

194 qs `shouldBe` "one&two"

191

195

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+

192makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer

215makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer

193makeRandomRequest large burl = do

216makeRandomRequest large burl = do

194 req <- generate $ runGenRequest large

217 req <- generate $ runGenRequest large

@@ -258,7 +281,20 @@ server2 = return $ return 1

258server3 :: IO (Server API2)

281server3 :: IO (Server API2)

259server3 = return $ return 2

282server3 = return $ return 2

260

283

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+

261

296

297+-- Api for unbiased generation of requests tests

262largeApi :: Proxy LargeAPI

298largeApi :: Proxy LargeAPI

263largeApi = Proxy

299largeApi = Proxy

264

300