servant-quickcheck 0.0.3.1 → 0.0.4
raw patch · 6 files changed
+104/−20 lines, 6 filesdep +blaze-htmldep +servant-blazedep ~basedep ~http-mediadep ~http-typesnew-uploader
Dependencies added: blaze-html, servant-blaze
Dependency ranges changed: base, http-media, http-types, process, servant, servant-client, servant-server, time
Files
- CHANGELOG.yaml +7/−0
- servant-quickcheck.cabal +16/−9
- src/Servant/QuickCheck.hs +3/−0
- src/Servant/QuickCheck/Internal/HasGenRequest.hs +8/−0
- src/Servant/QuickCheck/Internal/Predicates.hs +34/−11
- test/Servant/QuickCheck/InternalSpec.hs +36/−0
CHANGELOG.yaml view
@@ -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:
servant-quickcheck.cabal view
@@ -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
src/Servant/QuickCheck.hs view
@@ -34,6 +34,9 @@ , getsHaveCacheControlHeader , headsHaveCacheControlHeader , createContainsValidLocation+ -- * Html Predicates+ , htmlIncludesDoctype+ -- *** Predicate utilities and types , (<%>) , Predicates
src/Servant/QuickCheck/Internal/HasGenRequest.hs view
@@ -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
src/Servant/QuickCheck/Internal/Predicates.hs view
@@ -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: <!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 -- 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
test/Servant/QuickCheck/InternalSpec.hs view
@@ -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