diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 747de0c..a752d29 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -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 diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index 7e8379b..738d7b7 100644 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -34,6 +34,9 @@ module Servant.QuickCheck , getsHaveCacheControlHeader , headsHaveCacheControlHeader , createContainsValidLocation + -- * Html Predicates + , htmlIncludesDoctype + -- *** Predicate utilities and types , (<%>) , Predicates diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 3e3b282..6138162 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -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) @@ -120,12 +121,12 @@ createContainsValidLocation resp <- httpLbs req mgr if responseStatus resp == status201 then case lookup "Location" $ responseHeaders resp of - Nothing -> throw $ PredicateFailure "createContainsValidLocation" req resp + Nothing -> throw $ PredicateFailure n req resp Just l -> case parseRequest $ SBSC.unpack l of - Nothing -> throw $ PredicateFailure "createContainsValidLocation" req resp + Nothing -> throw $ PredicateFailure n req resp Just x -> do resp2 <- httpLbs x mgr - status2XX resp2 n + status2XX req resp2 n return [resp, resp2] else return [resp] @@ -226,7 +227,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" req resp else return [resp] else return [resp] @@ -340,6 +341,28 @@ unauthorizedContainsWWWAuthenticate throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" req resp else return () + +-- | [__RFC Compliance__] +-- +-- [An HTML] document will start with exactly this string: +-- +-- 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: +-- /Since 0.3.0.0/ +htmlIncludesDoctype :: ResponsePredicate +htmlIncludesDoctype + = ResponsePredicate $ \req 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 "") htmlContent) $ + throw $ PredicateFailure "htmlIncludesDoctype" req resp + else return () + -- * Predicate logic -- The idea with all this footwork is to not waste any requests. Rather than @@ -424,8 +447,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 => Request -> Response LBS.ByteString -> T.Text -> m () +status2XX req resp t + | status200 <= responseStatus resp && responseStatus resp < status300 = return () - | otherwise = fail t + | otherwise = throw $ PredicateFailure t req resp diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 19daeb9..02ffd70 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -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 (..), @@ -50,6 +53,7 @@ spec = do queryFlagsSpec deepPathSpec authServerCheck + htmlDocTypesSpec unbiasedGenerationSpec serversEqualSpec :: Spec @@ -200,7 +204,6 @@ queryFlagsSpec = describe "QueryFlags" $ do qs = C.unpack $ queryString req qs `shouldBe` "one&two" - authServerCheck :: Spec authServerCheck = describe "authenticate endpoints" $ do @@ -212,6 +215,25 @@ authServerCheck = describe "authenticate endpoints" $ do -- Large API Randomness Testing Helper +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 @@ -285,7 +307,19 @@ server500fail = return $ throwError $ err500 { errBody = "BOOM!" } authFailServer :: IO (Server API2) authFailServer = return $ throwError $ err401 { errBody = "Login failure but missing header"} --- Large API for testing the random generator's randomness +-- 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