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 6253d86..cc0f724 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) @@ -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: +-- +-- 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 $ \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" 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 diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 8c2197b..5da6667 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 (..), @@ -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