diff --git a/CHANGELOG.yaml b/CHANGELOG.yaml --- a/CHANGELOG.yaml +++ b/CHANGELOG.yaml @@ -1,6 +1,13 @@ upcoming: releases: + - version: "0.0.4" + changes: + + - description: Support for Servant 0.12 + issue: none + authors: phadej + date: 2017-11-07 - version: "0.0.3.1" changes: diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -1,5 +1,5 @@ name: servant-quickcheck -version: 0.0.3.1 +version: 0.0.4 synopsis: QuickCheck entire APIs description: This packages provides QuickCheck properties that are tested across an entire @@ -14,6 +14,10 @@ cabal-version: >=1.10 extra-source-files: CHANGELOG.yaml +tested-with: + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.1 source-repository head type: git @@ -31,7 +35,7 @@ , Servant.QuickCheck.Internal.QuickCheck , Servant.QuickCheck.Internal.Equality , Servant.QuickCheck.Internal.ErrorTypes - build-depends: base >=4.8 && <4.10 + build-depends: base >=4.8 && <4.11 , base-compat == 0.9.* , aeson > 0.8 && < 2 , bytestring == 0.10.* @@ -40,20 +44,20 @@ , data-default-class >= 0.0 && < 0.2 , hspec >= 2.2 && < 2.5 , http-client >= 0.4.30 && < 0.6 - , http-media == 0.6.* - , http-types > 0.8 && < 0.10 + , http-media >= 0.6 && <0.8 + , http-types > 0.8 && < 0.11 , mtl > 2.1 && < 2.3 , pretty == 1.1.* - , process >= 1.2 && < 1.5 + , process >= 1.2 && < 1.7 , QuickCheck > 2.7 && < 2.11 - , servant > 0.6 && < 0.12 - , servant-client > 0.6 && < 0.12 - , servant-server > 0.6 && < 0.12 + , servant > 0.6 && < 0.13 + , servant-client > 0.6 && < 0.13 + , servant-server > 0.6 && < 0.13 , split == 0.2.* , string-conversions > 0.3 && < 0.5 , temporary == 1.2.* , text == 1.* - , time >= 1.5 && < 1.7 + , time >= 1.5 && < 1.9 , warp >= 3.2.4 && < 3.3 hs-source-dirs: src @@ -82,6 +86,7 @@ hs-source-dirs: test main-is: Spec.hs other-modules: Servant.QuickCheck.InternalSpec + build-tool-depends: hspec-discover:hspec-discover build-depends: base == 4.* , base-compat , aeson @@ -90,10 +95,12 @@ , 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 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -34,6 +34,9 @@ , getsHaveCacheControlHeader , headsHaveCacheControlHeader , createContainsValidLocation + -- * Html Predicates + , htmlIncludesDoctype + -- *** Predicate utilities and types , (<%>) , Predicates diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -69,6 +69,14 @@ genRequest _ = (0, error "EmptyAPIs cannot be queried.") #endif +#if MIN_VERSION_servant(0,12,0) +instance HasGenRequest api => HasGenRequest (Summary d :> api) where + genRequest _ = genRequest (Proxy :: Proxy api) + +instance HasGenRequest api => HasGenRequest (Description d :> api) where + genRequest _ = genRequest (Proxy :: Proxy api) +#endif + instance (Arbitrary c, HasGenRequest b, ToHttpApiData c ) => HasGenRequest (Capture x c :> b) where genRequest _ = (oldf, do diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -7,11 +7,12 @@ 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 @@ -- /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 @@ 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 @@ 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,9 +337,31 @@ = 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 -- The idea with all this footwork is to not waste any requests. Rather than @@ -422,8 +445,8 @@ 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 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -12,6 +12,9 @@ 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 @@ queryParamsSpec queryFlagsSpec deepPathSpec + htmlDocTypesSpec unbiasedGenerationSpec serversEqualSpec :: Spec @@ -189,6 +193,25 @@ 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 @@ 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