ilyakooo0/servant-quickcheck
1
0
Fork 0
mirror of https://github.com/ilyakooo0/servant-quickcheck.git synced 2024-08-17 06:10:27 +03:00
Code Issues 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-core
, http-client
, blaze-html
, warp
, servant-server
, servant-client
, servant
, servant-blaze
, transformers
, QuickCheck
, quickcheck-io

3
src/Servant/QuickCheck.hs
View File

@ -34,6 +34,9 @@ module Servant.QuickCheck
, getsHaveCacheControlHeader
, headsHaveCacheControlHeader
, createContainsValidLocation
-- * Html Predicates
, htmlIncludesDoctype
-- *** Predicate utilities and types
, (<%>)
, 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.Char8 as SBSC
import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive (mk, foldedCase)
import Data.CaseInsensitive (foldCase, foldedCase, mk)
import Data.Either (isRight)
import Data.List.Split (wordsBy)
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
rfc822DateFormat)
import GHC.Generics (Generic)
@ -42,7 +43,7 @@ import Servant.QuickCheck.Internal.ErrorTypes
-- /Since 0.0.0.0/
not500 :: ResponsePredicate
not500 = ResponsePredicate $ \resp ->
when (responseStatus resp == status500) $ fail "not500"
when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
-- | [__Optional__]
--
@ -119,12 +120,12 @@ createContainsValidLocation
resp <- httpLbs req mgr
if responseStatus resp == status201
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
Nothing -> fail n
Nothing -> throw $ PredicateFailure n (Just req) resp
Just x -> do
resp2 <- httpLbs x mgr
status2XX resp2 n
status2XX (Just req) resp2 n
return [resp, resp2]
else return [resp]
@ -225,7 +226,7 @@ honoursAcceptHeader
sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
if status100 < scode && scode < status300
then if isJust $ sctype >>= \x -> matchAccept [x] sacc
then fail "honoursAcceptHeader"
then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
else return [resp]
else return [resp]
@ -336,7 +337,29 @@ unauthorizedContainsWWWAuthenticate
= ResponsePredicate $ \resp ->
if responseStatus resp == status401
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 ()
-- * Predicate logic
@ -422,8 +445,8 @@ isRFC822Date s
Nothing -> False
Just (_ :: UTCTime) -> True
status2XX :: Monad m => Response b -> String -> m ()
status2XX r t
| status200 <= responseStatus r && responseStatus r < status300
status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
status2XX mreq resp t
| status200 <= responseStatus resp && responseStatus resp < status300
= 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 Prelude.Compat
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,
shouldContain)
import Test.Hspec.Core.Spec (Arg, Example, Result (..),
@ -48,6 +51,7 @@ spec = do
queryParamsSpec
queryFlagsSpec
deepPathSpec
htmlDocTypesSpec
unbiasedGenerationSpec
serversEqualSpec :: Spec
@ -189,6 +193,25 @@ queryFlagsSpec = describe "QueryFlags" $ do
qs = C.unpack $ queryString req
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 large burl = do
req <- generate $ runGenRequest large
@ -258,7 +281,20 @@ server2 = return $ return 1
server3 :: IO (Server API2)
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