haskell/servant-quickcheck
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
* 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
This commit is contained in:
Erik 2017-10-21 15:20:56 -07:00 committed by GitHub
parent 54a05a53a9
commit d65abc856f
4 changed files with 75 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
servant-quickcheck.cabal
View File

@ -90,10 +90,12 @@ test-suite spec
, hspec , hspec
, hspec-core , hspec-core
, http-client , http-client
, blaze-html
, warp , warp
, servant-server , servant-server
, servant-client , servant-client
, servant , servant
, servant-blaze
, transformers , transformers
, QuickCheck , QuickCheck
, quickcheck-io , quickcheck-io

3
src/Servant/QuickCheck.hs
View File

@ -34,6 +34,9 @@ module Servant.QuickCheck
, getsHaveCacheControlHeader , getsHaveCacheControlHeader
, headsHaveCacheControlHeader , headsHaveCacheControlHeader
, createContainsValidLocation , createContainsValidLocation
-- * Html Predicates
, htmlIncludesDoctype
-- *** Predicate utilities and types -- *** Predicate utilities and types
, (<%>) , (<%>)
, Predicates , Predicates

45
src/Servant/QuickCheck/Internal/Predicates.hs
View File

@ -7,11 +7,12 @@ import Data.Bifunctor (first)
import qualified Data.ByteString as SBS import qualified Data.ByteString as SBS
import qualified Data.ByteString.Char8 as SBSC import qualified Data.ByteString.Char8 as SBSC
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive (mk, foldedCase) import Data.CaseInsensitive (foldCase, foldedCase, mk)
import Data.Either (isRight) import Data.Either (isRight)
import Data.List.Split (wordsBy) import Data.List.Split (wordsBy)
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe, isJust)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Time (UTCTime, defaultTimeLocale, parseTimeM, import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
rfc822DateFormat) rfc822DateFormat)
import GHC.Generics (Generic) import GHC.Generics (Generic)
@ -42,7 +43,7 @@ import Servant.QuickCheck.Internal.ErrorTypes
-- /Since 0.0.0.0/ -- /Since 0.0.0.0/
not500 :: ResponsePredicate not500 :: ResponsePredicate
not500 = ResponsePredicate $ \resp -> not500 = ResponsePredicate $ \resp ->
when (responseStatus resp == status500) $ fail "not500" when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
-- | [__Optional__] -- | [__Optional__]
-- --
@ -119,12 +120,12 @@ createContainsValidLocation
resp <- httpLbs req mgr resp <- httpLbs req mgr
if responseStatus resp == status201 if responseStatus resp == status201
then case lookup "Location" $ responseHeaders resp of then case lookup "Location" $ responseHeaders resp of
Nothing -> fail n Nothing -> throw $ PredicateFailure n (Just req) resp
Just l -> case parseRequest $ SBSC.unpack l of Just l -> case parseRequest $ SBSC.unpack l of
Nothing -> fail n Nothing -> throw $ PredicateFailure n (Just req) resp
Just x -> do Just x -> do
resp2 <- httpLbs x mgr resp2 <- httpLbs x mgr
status2XX resp2 n status2XX (Just req) resp2 n
return [resp, resp2] return [resp, resp2]
else return [resp] else return [resp]
@ -225,7 +226,7 @@ honoursAcceptHeader
sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req) sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
if status100 < scode && scode < status300 if status100 < scode && scode < status300
then if isJust $ sctype >>= \x -> matchAccept [x] sacc then if isJust $ sctype >>= \x -> matchAccept [x] sacc
then fail "honoursAcceptHeader" then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
else return [resp] else return [resp]
else return [resp] else return [resp]
@ -336,7 +337,29 @@ unauthorizedContainsWWWAuthenticate
= ResponsePredicate $ \resp -> = ResponsePredicate $ \resp ->
if responseStatus resp == status401 if responseStatus resp == status401
then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $ then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
fail "unauthorizedContainsWWWAuthenticate" throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
else return ()
-- | [__RFC Compliance__]
--
-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
--
-- This function checks that HTML documents (those with `Content-Type: text/html...`)
-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
--
-- __References__:
--
-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
-- /Since 0.3.0.0/
htmlIncludesDoctype :: ResponsePredicate
htmlIncludesDoctype
= ResponsePredicate $ \resp ->
if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
then do
let htmlContent = foldCase . LBS.take 20 $ responseBody resp
unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
else return () else return ()
-- * Predicate logic -- * Predicate logic
@ -422,8 +445,8 @@ isRFC822Date s
Nothing -> False Nothing -> False
Just (_ :: UTCTime) -> True Just (_ :: UTCTime) -> True
status2XX :: Monad m => Response b -> String -> m () status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
status2XX r t status2XX mreq resp t
| status200 <= responseStatus r && responseStatus r < status300 | status200 <= responseStatus resp && responseStatus resp < status300
= return () = return ()
| otherwise = fail t | otherwise = throw $ PredicateFailure t mreq resp

36
test/Servant/QuickCheck/InternalSpec.hs
View File

@ -12,6 +12,9 @@ import Data.Maybe (fromJust)
import Network.HTTP.Client (path, queryString) import Network.HTTP.Client (path, queryString)
import Prelude.Compat import Prelude.Compat
import Servant import Servant
import Servant.HTML.Blaze (HTML)
import qualified Text.Blaze.Html as Blaze
import qualified Text.Blaze.Html5 as Blaze5
import Test.Hspec (Spec, context, describe, it, shouldBe, import Test.Hspec (Spec, context, describe, it, shouldBe,
shouldContain) shouldContain)
import Test.Hspec.Core.Spec (Arg, Example, Result (..), import Test.Hspec.Core.Spec (Arg, Example, Result (..),
@ -48,6 +51,7 @@ spec = do
queryParamsSpec queryParamsSpec
queryFlagsSpec queryFlagsSpec
deepPathSpec deepPathSpec
htmlDocTypesSpec
unbiasedGenerationSpec unbiasedGenerationSpec
serversEqualSpec :: Spec serversEqualSpec :: Spec
@ -189,6 +193,25 @@ queryFlagsSpec = describe "QueryFlags" $ do
qs = C.unpack $ queryString req qs = C.unpack $ queryString req
qs `shouldBe` "one&two" qs `shouldBe` "one&two"
htmlDocTypesSpec :: Spec
htmlDocTypesSpec = describe "HtmlDocTypes" $ do
it "fails HTML without doctype correctly" $ do
err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
evalExample $ serverSatisfies docTypeApi burl args
(htmlIncludesDoctype <%> mempty)
show err `shouldContain` "htmlIncludesDoctype"
it "passes HTML with a doctype at start" $ do
withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
it "accepts json endpoints and passes over them in silence" $ do
withServantServerAndContext api ctx server $ \burl -> do
serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
(htmlIncludesDoctype <%> mempty)
makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
makeRandomRequest large burl = do makeRandomRequest large burl = do
req <- generate $ runGenRequest large req <- generate $ runGenRequest large
@ -258,7 +281,20 @@ server2 = return $ return 1
server3 :: IO (Server API2) server3 :: IO (Server API2)
server3 = return $ return 2 server3 = return $ return 2
-- With Doctypes
type HtmlDoctype = Get '[HTML] Blaze.Html
docTypeApi :: Proxy HtmlDoctype
docTypeApi = Proxy
docTypeServer :: IO (Server HtmlDoctype)
docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
noDocTypeServer :: IO (Server HtmlDoctype)
noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
-- Api for unbiased generation of requests tests
largeApi :: Proxy LargeAPI largeApi :: Proxy LargeAPI
largeApi = Proxy largeApi = Proxy