From d22576bc26fbdd8083935cedbb7a5294fb526f96 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 23 Apr 2016 19:24:49 +0200 Subject: [PATCH] fix serverSatisfies --- src/Servant/QuickCheck/Internal/Predicates.hs | 39 ++++++++++++------- src/Servant/QuickCheck/Internal/QuickCheck.hs | 14 ++++--- 2 files changed, 35 insertions(+), 18 deletions(-) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 6869454..eca2740 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -3,9 +3,10 @@ module Servant.QuickCheck.Internal.Predicates where import Data.Monoid ((<>)) import GHC.Generics (Generic) import Control.Monad -import Network.HTTP.Client (Request, Response, responseStatus) +import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs) import Network.HTTP.Types (status500) import qualified Data.ByteString.Lazy as LBS +import Data.Bifunctor (Bifunctor(..)) import Data.Text (Text) -- | @500 Internal Server Error@ should be avoided - it may represent some @@ -13,9 +14,8 @@ import Data.Text (Text) -- indication of how to proceed or what went wrong. -- -- This function checks that the response code is not 500. -not500 :: ResponsePredicate Text [Text] -not500 = ResponsePredicate "not500" (\resp -> - if responseStatus resp == status500 then ["not500"] else []) +not500 :: ResponsePredicate Text Bool +not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500) {- -- | Returning anything other than an object when returning JSON is considered @@ -158,6 +158,10 @@ data ResponsePredicate n r = ResponsePredicate , respPred :: Response LBS.ByteString -> r } deriving (Functor, Generic) +instance Bifunctor ResponsePredicate where + first f (ResponsePredicate a b) = ResponsePredicate (f a) b + second = fmap + instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where mempty = ResponsePredicate mempty mempty a `mappend` b = ResponsePredicate @@ -167,15 +171,20 @@ instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where data RequestPredicate n r = RequestPredicate { reqPredName :: n - , reqResps :: Request -> IO [Response LBS.ByteString] + , reqResps :: Request -> Manager -> IO [Response LBS.ByteString] , reqPred :: ResponsePredicate n r } deriving (Generic, Functor) +instance Bifunctor RequestPredicate where + first f (RequestPredicate a b c) = RequestPredicate (f a) b (first f c) + second = fmap + +-- TODO: This isn't actually a monoid instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where - mempty = RequestPredicate mempty (\_ -> return mempty) mempty + mempty = RequestPredicate mempty (\r m -> return <$> httpLbs r m) mempty a `mappend` b = RequestPredicate { reqPredName = reqPredName a <> reqPredName b - , reqResps = \x -> liftM2 (<>) (reqResps a x) (reqResps b x) + , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m) , reqPred = reqPred a <> reqPred b } @@ -194,17 +203,21 @@ class JoinPreds a where joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text] instance JoinPreds (RequestPredicate Text Bool) where - joinPreds p (Predicates x y) = Predicates (p <> x) y + joinPreds p (Predicates x y) = Predicates (go <> x) y + where go = let p' = first return p + in fmap (\z -> if z then [] else reqPredName p') p' instance JoinPreds (ResponsePredicate Text Bool) where - joinPreds p (Predicates x y) = Predicates x (p <> y) + joinPreds p (Predicates x y) = Predicates x (go <> y) + where go = let p' = first return p + in fmap (\z -> if z then [] else respPredName p') p' infixr 6 <%> -(<%>) :: JoinPreds a n b r => a -> Predicates n b r -> Predicates n b r +(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text] (<%>) = joinPreds -finishPredicates :: Predicates [Text] [Text] -> Request -> IO [Text] -finishPredicates p req = do - resps <- reqResps (reqPreds p) req +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 ] diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index ad45d56..bba2552 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -3,7 +3,7 @@ module Servant.QuickCheck.Internal.QuickCheck where import Data.Proxy (Proxy) import Network.HTTP.Client (Manager, defaultManagerSettings, - newManager, httpLbs) + newManager, httpLbs, checkStatus, Request) import Network.Wai.Handler.Warp (withApplication) import Servant (HasServer, Server, serve) import Servant.Client (BaseUrl (..), Scheme (..) ) @@ -44,8 +44,8 @@ serversEqual :: HasGenRequest a => serversEqual api burl1 burl2 args req = do let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do - resp1 <- run $ httpLbs req1 defManager - resp2 <- run $ httpLbs req2 defManager + resp1 <- run $ httpLbs (noCheckStatus req1) defManager + resp2 <- run $ httpLbs (noCheckStatus req2) defManager assert $ getResponseEquality req resp1 resp2 case r of Success {} -> return () @@ -55,11 +55,12 @@ serversEqual api burl1 burl2 args req = do InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" serverSatisfies :: (HasGenRequest a) => - Proxy a -> BaseUrl -> Args -> Predicates Text [Text] -> Expectation + Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation serverSatisfies api burl args preds = do let reqs = ($ burl) <$> genRequest api r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do - v <- run $ finishPredicates preds req + v <- run $ finishPredicates preds (noCheckStatus req) defManager + {-run $ print v-} assert $ null v case r of Success {} -> return () @@ -69,6 +70,9 @@ serverSatisfies api burl args preds = do InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" +noCheckStatus :: Request -> Request +noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing} + defManager :: Manager defManager = unsafePerformIO $ newManager defaultManagerSettings {-# NOINLINE defManager #-}