Use new client with per-client BaseUrl and Manager.

This may be a step back, and the instances aren't as nice.

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

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

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