@@ -2,12 +2,12 @@
2module Servant.QuickCheck.Internal.Testable where
2module Servant.QuickCheck.Internal.Testable where
4import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
4import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
5−import Control.Monad.Except (runExceptT)
5+import Control.Monad.Except (runExceptT, ExceptT)
6import GHC.Generics (Generic)
6import GHC.Generics (Generic)
7import Network.HTTP.Client (Request, RequestBody (..),
7import Network.HTTP.Client (Request, RequestBody (..),
8− requestBody)
8+ requestBody, Manager)
9import Servant.API ((:<|>)(..))
9import Servant.API ((:<|>)(..))
10−import Servant.Client (ServantError (..), ClientM)
10+import Servant.Client (ServantError (..), BaseUrl)
11import System.IO.Unsafe (unsafePerformIO)
11import System.IO.Unsafe (unsafePerformIO)
12import Test.QuickCheck (Arbitrary (..), discard)
12import Test.QuickCheck (Arbitrary (..), discard)
13import Test.QuickCheck.Property (Testable (..), forAllShrink,
13import Test.QuickCheck.Property (Testable (..), forAllShrink,
@@ -16,16 +16,22 @@ import Test.QuickCheck.Property (Testable (..), forAllShrink,
16import Servant.QuickCheck.Internal.Predicates
16import Servant.QuickCheck.Internal.Predicates
19+type FinalClient a = Manager -> BaseUrl -> ExceptT ServantError IO a
19-- * ShouldMatch
21-- * ShouldMatch
21-- | Two corresponding client functions. Used for checking that APIs match.
23-- | Two corresponding client functions. Used for checking that APIs match.
22−data ShouldMatch a = ShouldMatch a a
24+data ShouldMatch a = ShouldMatch
26+ , smManager :: Manager
27+ , smBaseUrls :: (BaseUrl, BaseUrl)
23− deriving (Eq, Show, Read, Generic)
28+ } deriving (Functor, Generic)
25−instance (Show a, Eq a) => Testable (ShouldMatch (ClientM a)) where
30+instance (Show a, Eq a) => Testable (ShouldMatch (FinalClient a)) where
26− property (ShouldMatch e1 e2) = ioProperty $ do
31+ property sm = ioProperty $ do
32+ let (burl1, burl2) = smBaseUrls sm
27− e1' <- runExceptT e1
33+ e1' <- runExceptT $ smClient sm (smManager sm) burl1
28− e2' <- runExceptT e2
34+ e2' <- runExceptT $ smClient sm (smManager sm) burl2
29 modifyMVar_ currentReq $ \x -> case x of
35 modifyMVar_ currentReq $ \x -> case x of
30 Nothing -> error "impossible"
36 Nothing -> error "impossible"
31 Just (x', _) -> return $ Just (x', "LHS:\n" ++ show e1'
37 Just (x', _) -> return $ Just (x', "LHS:\n" ++ show e1'
@@ -40,13 +46,12 @@ instance (Show a, Eq a) => Testable (ShouldMatch (ClientM a)) where
41instance (Arbitrary a, Show a, Testable (ShouldMatch b))
47instance (Arbitrary a, Show a, Testable (ShouldMatch b))
42 => Testable (ShouldMatch (a -> b)) where
48 => Testable (ShouldMatch (a -> b)) where
43− property (ShouldMatch f1 f2) = forAllShrink arbitrary shrink go
49+ property sm = forAllShrink arbitrary shrink go
44− where go x = ShouldMatch (f1 x) (f2 x)
50+ where go x = ($ x) <$> sm
46instance (Testable (ShouldMatch a), Testable (ShouldMatch b))
52instance (Testable (ShouldMatch a), Testable (ShouldMatch b))
47 => Testable (ShouldMatch (a :<|> b)) where
53 => Testable (ShouldMatch (a :<|> b)) where
48− property (ShouldMatch (a1 :<|> b1) (a2 :<|> b2))
54+ property sm = property (fstAlt <$> sm) .&. property (sndAlt <$> sm)
49− = property (ShouldMatch a1 a2) .&. property (ShouldMatch b1 b2)
51-- * ShouldSatisfy
56-- * ShouldSatisfy
@@ -54,32 +59,39 @@ data ShouldSatisfy filter expect a = ShouldSatisfy
54 { ssVal :: a
59 { ssVal :: a
55 , ssFilter :: Predicates filter
60 , ssFilter :: Predicates filter
56 , ssExpect :: Predicates expect
61 , ssExpect :: Predicates expect
62+ , ssManager :: Manager
63+ , ssBaseUrl :: BaseUrl
57 } deriving (Functor)
64 } deriving (Functor)
59instance (Show a, Eq a, HasPredicate expect (Either ServantError a))
66instance (Show a, Eq a, HasPredicate expect (Either ServantError a))
60− => Testable (ShouldSatisfy filter expect (ClientM a)) where
67+ => Testable (ShouldSatisfy filter expect (FinalClient a)) where
61− property (ShouldSatisfy a _ e) = ioProperty $ do
68+ property ss = ioProperty $ do
62− a' <- runExceptT a
69+ a' <- runExceptT $ ssVal ss (ssManager ss) (ssBaseUrl ss)
63 modifyMVar_ currentReq $ \x -> case x of
70 modifyMVar_ currentReq $ \x -> case x of
64 Nothing -> error "impossible"
71 Nothing -> error "impossible"
65 Just (x', _) -> return $ Just (x', show a')
72 Just (x', _) -> return $ Just (x', show a')
66− return $ getPredicate e a'
73+ return $ getPredicate (ssExpect ss) a'
68instance ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
75instance ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
69 , HasPredicate filter a)
76 , HasPredicate filter a)
70 => Testable (ShouldSatisfy filter expect (a -> b)) where
77 => Testable (ShouldSatisfy filter expect (a -> b)) where
71− property (ShouldSatisfy g f e) = forAllShrink arbitrary shrink go
78+ property ss = forAllShrink arbitrary shrink go
72− where go x | getPredicate f x = ShouldSatisfy (g x) f e
79+ where go x | getPredicate (ssFilter ss) x = ($ x) <$> ss
73− | otherwise = discard
80+ | otherwise = discard
75instance ( Testable (ShouldSatisfy filter expect a)
82instance ( Testable (ShouldSatisfy filter expect a)
76 , Testable (ShouldSatisfy filter expect b))
83 , Testable (ShouldSatisfy filter expect b))
77 => Testable (ShouldSatisfy filter expect (a :<|> b)) where
84 => Testable (ShouldSatisfy filter expect (a :<|> b)) where
78− property (ShouldSatisfy (a :<|> b) f e)
85+ property ss = property (fstAlt <$> ss) .&. property (sndAlt <$> ss)
79− = property (ShouldSatisfy a f e) .&. property (ShouldSatisfy b f e)
89+fstAlt :: (a :<|> b) -> a
92+sndAlt :: (a :<|> b) -> b
83-- Used to store the current request and response so that in case of failure we
95-- Used to store the current request and response so that in case of failure we
84-- have the failing test in a user-friendly form.
96-- have the failing test in a user-friendly form.
85currentReq :: MVar (Maybe (Request, String))
97currentReq :: MVar (Maybe (Request, String))