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-core
, http-client
, blaze-html
, warp
, servant-server
, servant-client
, servant
, servant-blaze
, transformers
, QuickCheck
, quickcheck-io

3
src/Servant/QuickCheck.hs
View File

@ -34,6 +34,9 @@ module Servant.QuickCheck
, getsHaveCacheControlHeader
, headsHaveCacheControlHeader
, createContainsValidLocation
-- * Html Predicates
, htmlIncludesDoctype
-- *** Predicate utilities and types
, (<%>)
, 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.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: <!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
-- 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

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

@ -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