mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-09-11 10:26:36 +03:00
Use new client with per-client BaseUrl and Manager.
This may be a step back, and the instances aren't as nice.
This commit is contained in:
parent
72abea9b0f
commit
0d455a9851
@ -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)))
|
||||
|
@ -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))
|
||||
|
@ -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
|
Loading…
Reference in New Issue
Block a user