@@ -2,12 +2,12 @@
22module Servant.QuickCheck.Internal.Testable where
33
44import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
5−import Control.Monad.Except (runExceptT)
5+import Control.Monad.Except (runExceptT, ExceptT)
66import GHC.Generics (Generic)
77import Network.HTTP.Client (Request, RequestBody (..),
8− requestBody)
8+ requestBody, Manager)
99import Servant.API ((:<|>)(..))
10−import Servant.Client (ServantError (..), ClientM)
10+import Servant.Client (ServantError (..), BaseUrl)
1111import System.IO.Unsafe (unsafePerformIO)
1212import Test.QuickCheck (Arbitrary (..), discard)
1313import Test.QuickCheck.Property (Testable (..), forAllShrink,
@@ -16,16 +16,22 @@ import Test.QuickCheck.Property (Testable (..), forAllShrink,
1616import Servant.QuickCheck.Internal.Predicates
1717
1818
19+type FinalClient a = Manager -> BaseUrl -> ExceptT ServantError IO a
20+
1921-- * ShouldMatch
2022
2123-- | Two corresponding client functions. Used for checking that APIs match.
22−data ShouldMatch a = ShouldMatch a a
23− deriving (Eq, Show, Read, Generic)
24−
25−instance (Show a, Eq a) => Testable (ShouldMatch (ClientM a)) where
26− property (ShouldMatch e1 e2) = ioProperty $ do
27− e1' <- runExceptT e1
28− e2' <- runExceptT e2
24+data ShouldMatch a = ShouldMatch
25+ { smClient :: a
26+ , smManager :: Manager
27+ , smBaseUrls :: (BaseUrl, BaseUrl)
28+ } deriving (Functor, Generic)
29+
30+instance (Show a, Eq a) => Testable (ShouldMatch (FinalClient a)) where
31+ property sm = ioProperty $ do
32+ let (burl1, burl2) = smBaseUrls sm
33+ e1' <- runExceptT $ smClient sm (smManager sm) burl1
34+ e2' <- runExceptT $ smClient sm (smManager sm) burl2
2935 modifyMVar_ currentReq $ \x -> case x of
3036 Nothing -> error "impossible"
3137 Just (x', _) -> return $ Just (x', "LHS:\n" ++ show e1'
@@ -40,13 +46,12 @@ instance (Show a, Eq a) => Testable (ShouldMatch (ClientM a)) where
4046
4147instance (Arbitrary a, Show a, Testable (ShouldMatch b))
4248 => Testable (ShouldMatch (a -> b)) where
43− property (ShouldMatch f1 f2) = forAllShrink arbitrary shrink go
44− where go x = ShouldMatch (f1 x) (f2 x)
49+ property sm = forAllShrink arbitrary shrink go
50+ where go x = ($ x) <$> sm
4551
4652instance (Testable (ShouldMatch a), Testable (ShouldMatch b))
4753 => Testable (ShouldMatch (a :<|> b)) where
48− property (ShouldMatch (a1 :<|> b1) (a2 :<|> b2))
49− = property (ShouldMatch a1 a2) .&. property (ShouldMatch b1 b2)
54+ property sm = property (fstAlt <$> sm) .&. property (sndAlt <$> sm)
5055
5156-- * ShouldSatisfy
5257
@@ -54,32 +59,39 @@ data ShouldSatisfy filter expect a = ShouldSatisfy
5459 { ssVal :: a
5560 , ssFilter :: Predicates filter
5661 , ssExpect :: Predicates expect
62+ , ssManager :: Manager
63+ , ssBaseUrl :: BaseUrl
5764 } deriving (Functor)
5865
5966instance (Show a, Eq a, HasPredicate expect (Either ServantError a))
60− => Testable (ShouldSatisfy filter expect (ClientM a)) where
61− property (ShouldSatisfy a _ e) = ioProperty $ do
62− a' <- runExceptT a
67+ => Testable (ShouldSatisfy filter expect (FinalClient a)) where
68+ property ss = ioProperty $ do
69+ a' <- runExceptT $ ssVal ss (ssManager ss) (ssBaseUrl ss)
6370 modifyMVar_ currentReq $ \x -> case x of
6471 Nothing -> error "impossible"
6572 Just (x', _) -> return $ Just (x', show a')
66− return $ getPredicate e a'
73+ return $ getPredicate (ssExpect ss) a'
6774
6875instance ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
6976 , HasPredicate filter a)
7077 => Testable (ShouldSatisfy filter expect (a -> b)) where
71− property (ShouldSatisfy g f e) = forAllShrink arbitrary shrink go
72− where go x | getPredicate f x = ShouldSatisfy (g x) f e
73− | otherwise = discard
78+ property ss = forAllShrink arbitrary shrink go
79+ where go x | getPredicate (ssFilter ss) x = ($ x) <$> ss
80+ | otherwise = discard
7481
7582instance ( Testable (ShouldSatisfy filter expect a)
7683 , Testable (ShouldSatisfy filter expect b))
7784 => Testable (ShouldSatisfy filter expect (a :<|> b)) where
78− property (ShouldSatisfy (a :<|> b) f e)
79− = property (ShouldSatisfy a f e) .&. property (ShouldSatisfy b f e)
85+ property ss = property (fstAlt <$> ss) .&. property (sndAlt <$> ss)
8086
8187-- * Utils
8288
89+fstAlt :: (a :<|> b) -> a
90+fstAlt (a :<|> _) = a
91+
92+sndAlt :: (a :<|> b) -> b
93+sndAlt (_ :<|> b) = b
94+
8395-- Used to store the current request and response so that in case of failure we
8496-- have the failing test in a user-friendly form.
8597currentReq :: MVar (Maybe (Request, String))