diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 68d28c4..02cbf40 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -49,9 +49,12 @@ withServantServer api server t -- @serversEqual@ or @servantServersEqual@. serversEqualProperty :: (HasClient a, Testable (ShouldMatch (Client a))) => Proxy a -> Manager -> BaseUrl -> BaseUrl -> Property -serversEqualProperty api mgr burl1 burl2 = property $ ShouldMatch c1 c2 - where c1 = client api burl1 mgr - c2 = client api burl2 mgr +serversEqualProperty api mgr burl1 burl2 + = property $ ShouldMatch + { smClient = client api + , smManager = mgr + , smBaseUrls = (burl1, burl2) + } -- | Check that the two servers running under the provided @BaseUrl@s behave -- identically by randomly generating arguments (captures, query params, request bodies, @@ -78,7 +81,13 @@ serversEqual api burl1 burl2 tries = do serverSatisfiesProperty :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a))) => Proxy a -> Manager -> BaseUrl -> Predicates filt -> Predicates exp -> Property serverSatisfiesProperty api mgr burl filters expect = do - property $ ShouldSatisfy (client api burl mgr) filters expect + property $ ShouldSatisfy + { ssVal = client api + , ssFilter = filters + , ssExpect = expect + , ssManager = mgr + , ssBaseUrl = burl + } -- | Check that a server's responses satisfies certain properties. serverSatisfies :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a))) diff --git a/src/Servant/QuickCheck/Internal/Testable.hs b/src/Servant/QuickCheck/Internal/Testable.hs index ee0aad1..7da287d 100644 --- a/src/Servant/QuickCheck/Internal/Testable.hs +++ b/src/Servant/QuickCheck/Internal/Testable.hs @@ -2,12 +2,12 @@ module Servant.QuickCheck.Internal.Testable where import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar) -import Control.Monad.Except (runExceptT) +import Control.Monad.Except (runExceptT, ExceptT) import GHC.Generics (Generic) import Network.HTTP.Client (Request, RequestBody (..), - requestBody) + requestBody, Manager) import Servant.API ((:<|>)(..)) -import Servant.Client (ServantError (..), ClientM) +import Servant.Client (ServantError (..), BaseUrl) import System.IO.Unsafe (unsafePerformIO) import Test.QuickCheck (Arbitrary (..), discard) import Test.QuickCheck.Property (Testable (..), forAllShrink, @@ -16,16 +16,22 @@ import Test.QuickCheck.Property (Testable (..), forAllShrink, import Servant.QuickCheck.Internal.Predicates +type FinalClient a = Manager -> BaseUrl -> ExceptT ServantError IO a + -- * ShouldMatch -- | Two corresponding client functions. Used for checking that APIs match. -data ShouldMatch a = ShouldMatch a a - deriving (Eq, Show, Read, Generic) +data ShouldMatch a = ShouldMatch + { smClient :: a + , smManager :: Manager + , smBaseUrls :: (BaseUrl, BaseUrl) + } deriving (Functor, Generic) -instance (Show a, Eq a) => Testable (ShouldMatch (ClientM a)) where - property (ShouldMatch e1 e2) = ioProperty $ do - e1' <- runExceptT e1 - e2' <- runExceptT e2 +instance (Show a, Eq a) => Testable (ShouldMatch (FinalClient a)) where + property sm = ioProperty $ do + let (burl1, burl2) = smBaseUrls sm + e1' <- runExceptT $ smClient sm (smManager sm) burl1 + e2' <- runExceptT $ smClient sm (smManager sm) burl2 modifyMVar_ currentReq $ \x -> case x of Nothing -> error "impossible" Just (x', _) -> return $ Just (x', "LHS:\n" ++ show e1' @@ -40,13 +46,12 @@ instance (Show a, Eq a) => Testable (ShouldMatch (ClientM a)) where instance (Arbitrary a, Show a, Testable (ShouldMatch b)) => Testable (ShouldMatch (a -> b)) where - property (ShouldMatch f1 f2) = forAllShrink arbitrary shrink go - where go x = ShouldMatch (f1 x) (f2 x) + property sm = forAllShrink arbitrary shrink go + where go x = ($ x) <$> sm instance (Testable (ShouldMatch a), Testable (ShouldMatch b)) => Testable (ShouldMatch (a :<|> b)) where - property (ShouldMatch (a1 :<|> b1) (a2 :<|> b2)) - = property (ShouldMatch a1 a2) .&. property (ShouldMatch b1 b2) + property sm = property (fstAlt <$> sm) .&. property (sndAlt <$> sm) -- * ShouldSatisfy @@ -54,32 +59,39 @@ data ShouldSatisfy filter expect a = ShouldSatisfy { ssVal :: a , ssFilter :: Predicates filter , ssExpect :: Predicates expect + , ssManager :: Manager + , ssBaseUrl :: BaseUrl } deriving (Functor) instance (Show a, Eq a, HasPredicate expect (Either ServantError a)) - => Testable (ShouldSatisfy filter expect (ClientM a)) where - property (ShouldSatisfy a _ e) = ioProperty $ do - a' <- runExceptT a + => Testable (ShouldSatisfy filter expect (FinalClient a)) where + property ss = ioProperty $ do + a' <- runExceptT $ ssVal ss (ssManager ss) (ssBaseUrl ss) modifyMVar_ currentReq $ \x -> case x of Nothing -> error "impossible" Just (x', _) -> return $ Just (x', show a') - return $ getPredicate e a' + return $ getPredicate (ssExpect ss) a' instance ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b) , HasPredicate filter a) => Testable (ShouldSatisfy filter expect (a -> b)) where - property (ShouldSatisfy g f e) = forAllShrink arbitrary shrink go - where go x | getPredicate f x = ShouldSatisfy (g x) f e - | otherwise = discard + property ss = forAllShrink arbitrary shrink go + where go x | getPredicate (ssFilter ss) x = ($ x) <$> ss + | otherwise = discard instance ( Testable (ShouldSatisfy filter expect a) , Testable (ShouldSatisfy filter expect b)) => Testable (ShouldSatisfy filter expect (a :<|> b)) where - property (ShouldSatisfy (a :<|> b) f e) - = property (ShouldSatisfy a f e) .&. property (ShouldSatisfy b f e) + property ss = property (fstAlt <$> ss) .&. property (sndAlt <$> ss) -- * Utils +fstAlt :: (a :<|> b) -> a +fstAlt (a :<|> _) = a + +sndAlt :: (a :<|> b) -> b +sndAlt (_ :<|> b) = b + -- Used to store the current request and response so that in case of failure we -- have the failing test in a user-friendly form. currentReq :: MVar (Maybe (Request, String)) diff --git a/test/Servant/CoMock/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs similarity index 98% rename from test/Servant/CoMock/InternalSpec.hs rename to test/Servant/QuickCheck/InternalSpec.hs index 34b09d4..7443fbe 100644 --- a/test/Servant/CoMock/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -module Servant.CoMock.InternalSpec (spec) where +module Servant.QuickCheck.InternalSpec (spec) where import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) import Control.Monad.IO.Class (liftIO) @@ -8,7 +8,7 @@ import Data.Proxy import Servant import Test.Hspec -import Servant.CoMock.Internal +import Servant.QuickCheck.Internal spec :: Spec spec = do