From 64c845cb453dcb58c91c8d6b5485c7f0c0926c1d Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 30 Apr 2016 16:25:54 +0200 Subject: [PATCH] Slightly nicer RequestPredicate. Which still isn't beautiful. --- src/Servant/QuickCheck.hs | 6 ++ .../QuickCheck/Internal/Benchmarking.hs | 6 +- src/Servant/QuickCheck/Internal/Predicates.hs | 84 ++++++++++--------- 3 files changed, 53 insertions(+), 43 deletions(-) diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index 07daf64..d9df91f 100644 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -55,13 +55,19 @@ module Servant.QuickCheck -- | Helpers to setup and teardown @servant@ servers during tests. , withServantServer , withServantServerAndContext + , defaultArgs -- ** Re-exports , BaseUrl(..) , Scheme(..) + , Args(..) ) where import Servant.QuickCheck.Internal import Servant.Client (BaseUrl(..), Scheme(..)) +import Test.QuickCheck (Args(..), stdArgs) + +defaultArgs :: Args +defaultArgs = stdArgs { maxSuccess = 1000 } diff --git a/src/Servant/QuickCheck/Internal/Benchmarking.hs b/src/Servant/QuickCheck/Internal/Benchmarking.hs index 0c8abc3..38b8300 100644 --- a/src/Servant/QuickCheck/Internal/Benchmarking.hs +++ b/src/Servant/QuickCheck/Internal/Benchmarking.hs @@ -1,8 +1,4 @@ --- | This module contains benchmark-related logic. --- --- Currently it generates 'wrk' scripts rather than benchmarking directly with --- the @servant-client@ functions since the performance of 'wrk' is --- significantly better. +-- This is a WIP module that shouldn't be used. module Servant.QuickCheck.Internal.Benchmarking where import Data.ByteString (ByteString) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 38a5389..4a7c5b8 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -55,19 +55,35 @@ onlyJsonObjects Nothing -> False Just (_ :: Object) -> True) -{- --- | When creating a new resource, it is good practice to provide a @Location@ +-- | __Optional__ +-- +-- When creating a new resource, it is good practice to provide a @Location@ -- header with a link to the created resource. -- -- This function checks that every @201 Created@ response contains a @Location@ -- header, and that the link in it responds with a 2XX response code to @GET@ -- requests. -- --- References: -createContainsValidLocation :: ResponsePredicate Text Bool -createContainsValidLocation - = ResponsePredicate "createContainsValidLocation" (\resp -> +-- This is considered optional because other means of linking to the resource +-- (e.g. via the response body) are also acceptable; linking to the resource in +-- some way is considered best practice. +-- +-- __References__: +-- +-- * 201 Created: +-- * Location header: +{-createContainsValidLocation :: RequestPredicate Text Bool-} +{-createContainsValidLocation-} + {-= RequestPredicate-} + {-{ reqPredName = "createContainsValidLocation"-} + {-, reqResps = \req mg -> do-} + {-resp <- httpLbs mgr req-} + {-if responseStatus resp == status201-} + {-then case lookup "Location" $ responseHeaders resp of-} + {-Nothing -> return []-} + {-Just l -> if-} +{- getsHaveLastModifiedHeader :: ResponsePredicate Text Bool getsHaveLastModifiedHeader = ResponsePredicate "getsHaveLastModifiedHeader" (\resp -> @@ -91,19 +107,15 @@ getsHaveLastModifiedHeader notAllowedContainsAllowHeader :: RequestPredicate Text Bool notAllowedContainsAllowHeader = RequestPredicate - { reqPredName = name - , reqResps = \req mgr -> mapM (flip httpLbs mgr) - [ req { method = renderStdMethod m } - | m <- [minBound .. maxBound ] - , renderStdMethod m /= method req ] - , reqPred = pred' + { reqPredName = "notAllowedContainsAllowHeader" + , reqResps = \req mgr -> do + resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m } + | m <- [minBound .. maxBound ] + , renderStdMethod m /= method req ] + return (all pred' resp, resp) } where - name = "notAllowedContainsAllowHeader" - pred' = ResponsePredicate name (\resp -> - if responseStatus resp == status405 - then hasValidHeader "Allow" go resp - else True) + pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp where go x = all (\y -> isRight $ parseMethod $ SBSC.pack y) $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x) @@ -148,14 +160,14 @@ honoursAcceptHeader getsHaveCacheControlHeader :: RequestPredicate Text Bool getsHaveCacheControlHeader = RequestPredicate - { reqPredName = name + { reqPredName = "getsHaveCacheControlHeader" , reqResps = \req mgr -> if method req == methodGet - then return <$> httpLbs req mgr - else return [] - , reqPred = ResponsePredicate name $ \resp -> - isJust $ lookup "Cache-Control" $ responseHeaders resp + then do + resp <- httpLbs req mgr + let good = isJust $ lookup "Cache-Control" $ responseHeaders resp + return (good, [resp]) + else return (True, []) } - where name = "getsHaveCacheControlHeader" -- | [__Best Practice__] -- @@ -163,15 +175,14 @@ getsHaveCacheControlHeader headsHaveCacheControlHeader :: RequestPredicate Text Bool headsHaveCacheControlHeader = RequestPredicate - { reqPredName = name + { reqPredName = "headsHaveCacheControlHeader" , reqResps = \req mgr -> if method req == methodHead - then return <$> httpLbs req mgr - else return [] - , reqPred = ResponsePredicate name $ \resp -> - isJust $ lookup "Cache-Control" $ responseHeaders resp + then do + resp <- httpLbs req mgr + let good = isJust $ lookup "Cache-Control" $ responseHeaders resp + return (good, [resp]) + else return (True, []) } - where name = "headsHaveCacheControlHeader" - {- -- | -- @@ -264,21 +275,19 @@ instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where data RequestPredicate n r = RequestPredicate { reqPredName :: n - , reqResps :: Request -> Manager -> IO [Response LBS.ByteString] - , reqPred :: ResponsePredicate n r + , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString]) } deriving (Generic, Functor) instance Bifunctor RequestPredicate where - first f (RequestPredicate a b c) = RequestPredicate (f a) b (first f c) + first f (RequestPredicate a b) = RequestPredicate (f a) b second = fmap -- TODO: This isn't actually a monoid instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where - mempty = RequestPredicate mempty (\r m -> return <$> httpLbs r m) mempty + mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x])) a `mappend` b = RequestPredicate { reqPredName = reqPredName a <> reqPredName b , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m) - , reqPred = reqPred a <> reqPred b } data Predicates n r = Predicates @@ -316,9 +325,8 @@ infixr 6 <%> finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text] finishPredicates p req mgr = do - resps <- reqResps (reqPreds p) req mgr - let preds = reqPred (reqPreds p) <> respPreds p - return $ mconcat [respPred preds r | r <- resps ] + (soFar, resps) <- reqResps (reqPreds p) req mgr + return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps] -- * helpers