haskell/servant-quickcheck
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix merge conflicts with master

Browse Source
This commit is contained in:
Erik Aker 2017-10-21 15:29:29 -07:00
commit d4f6aa5272
4 changed files with 73 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
, hspec-core , hspec-core
, http-client , http-client
, blaze-html
, warp , warp
, servant-server , servant-server
, servant-client , servant-client
, servant , servant
, servant-blaze
, transformers , transformers
, QuickCheck , QuickCheck
, quickcheck-io , quickcheck-io

3
src/Servant/QuickCheck.hs
View File

@ -34,6 +34,9 @@ module Servant.QuickCheck
, getsHaveCacheControlHeader , getsHaveCacheControlHeader
, headsHaveCacheControlHeader , headsHaveCacheControlHeader
, createContainsValidLocation , createContainsValidLocation
-- * Html Predicates
, htmlIncludesDoctype
-- *** Predicate utilities and types -- *** Predicate utilities and types
, (<%>) , (<%>)
, Predicates , Predicates

41
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 as SBS
import qualified Data.ByteString.Char8 as SBSC import qualified Data.ByteString.Char8 as SBSC
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive (mk, foldedCase) import Data.CaseInsensitive (foldCase, foldedCase, mk)
import Data.Either (isRight) import Data.Either (isRight)
import Data.List.Split (wordsBy) import Data.List.Split (wordsBy)
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe, isJust)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Time (UTCTime, defaultTimeLocale, parseTimeM, import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
rfc822DateFormat) rfc822DateFormat)
import GHC.Generics (Generic) import GHC.Generics (Generic)
@ -120,12 +121,12 @@ createContainsValidLocation
resp <- httpLbs req mgr resp <- httpLbs req mgr
if responseStatus resp == status201 if responseStatus resp == status201
then case lookup "Location" $ responseHeaders resp of 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 Just l -> case parseRequest $ SBSC.unpack l of
Nothing -> throw $ PredicateFailure "createContainsValidLocation" req resp Nothing -> throw $ PredicateFailure n req resp
Just x -> do Just x -> do
resp2 <- httpLbs x mgr resp2 <- httpLbs x mgr
status2XX resp2 n status2XX req resp2 n
return [resp, resp2] return [resp, resp2]
else return [resp] else return [resp]
@ -226,7 +227,7 @@ honoursAcceptHeader
sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req) sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
if status100 < scode && scode < status300 if status100 < scode && scode < status300
then if isJust $ sctype >>= \x -> matchAccept [x] sacc then if isJust $ sctype >>= \x -> matchAccept [x] sacc
then fail "honoursAcceptHeader" then throw $ PredicateFailure "honoursAcceptHeader" req resp
else return [resp] else return [resp]
else return [resp] else return [resp]
@ -340,6 +341,28 @@ unauthorizedContainsWWWAuthenticate
throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" req resp throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" req resp
else return () 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 $ \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 "<!doctype html>") htmlContent) $
throw $ PredicateFailure "htmlIncludesDoctype" req resp
else return ()
-- * Predicate logic -- * Predicate logic
-- The idea with all this footwork is to not waste any requests. Rather than -- The idea with all this footwork is to not waste any requests. Rather than
@ -424,8 +447,8 @@ isRFC822Date s
Nothing -> False Nothing -> False
Just (_ :: UTCTime) -> True Just (_ :: UTCTime) -> True
status2XX :: Monad m => Response b -> String -> m () status2XX :: Monad m => Request -> Response LBS.ByteString -> T.Text -> m ()
status2XX r t status2XX req resp t
| status200 <= responseStatus r && responseStatus r < status300 | status200 <= responseStatus resp && responseStatus resp < status300
= return () = return ()
| otherwise = fail t | otherwise = throw $ PredicateFailure t req resp

38
test/Servant/QuickCheck/InternalSpec.hs
View File

@ -12,6 +12,9 @@ import Data.Maybe (fromJust)
import Network.HTTP.Client (path, queryString) import Network.HTTP.Client (path, queryString)
import Prelude.Compat import Prelude.Compat
import Servant 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, import Test.Hspec (Spec, context, describe, it, shouldBe,
shouldContain) shouldContain)
import Test.Hspec.Core.Spec (Arg, Example, Result (..), import Test.Hspec.Core.Spec (Arg, Example, Result (..),
@ -50,6 +53,7 @@ spec = do
queryFlagsSpec queryFlagsSpec
deepPathSpec deepPathSpec
authServerCheck authServerCheck
htmlDocTypesSpec
unbiasedGenerationSpec unbiasedGenerationSpec
serversEqualSpec :: Spec serversEqualSpec :: Spec
@ -200,7 +204,6 @@ queryFlagsSpec = describe "QueryFlags" $ do
qs = C.unpack $ queryString req qs = C.unpack $ queryString req
qs `shouldBe` "one&two" qs `shouldBe` "one&two"
authServerCheck :: Spec authServerCheck :: Spec
authServerCheck = describe "authenticate endpoints" $ do authServerCheck = describe "authenticate endpoints" $ do
@ -212,6 +215,25 @@ authServerCheck = describe "authenticate endpoints" $ do
-- Large API Randomness Testing Helper -- 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 :: Proxy LargeAPI -> BaseUrl -> IO Integer
makeRandomRequest large burl = do makeRandomRequest large burl = do
req <- generate $ runGenRequest large req <- generate $ runGenRequest large
@ -285,7 +307,19 @@ server500fail = return $ throwError $ err500 { errBody = "BOOM!" }
authFailServer :: IO (Server API2) authFailServer :: IO (Server API2)
authFailServer = return $ throwError $ err401 { errBody = "Login failure but missing header"} 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 LargeAPI
largeApi = Proxy largeApi = Proxy