d62753b · servant-quickcheck

git.iko.soy/servant-quickcheck

on master help sign in

More predicates work

d62753bJulian K. Arni11 years ago

servant-quickcheck.cabal+1

compare with master

unifiedsplit

@@ -42,6 +42,7 @@ library

42 , process == 1.2.*

43 , temporary == 1.2.*

44 , hspec

45+ , text == 1.*

45 hs-source-dirs: src

46 hs-source-dirs: src

46 default-extensions: TypeOperators

47 default-extensions: TypeOperators

47 , FlexibleInstances

48 , FlexibleInstances

src/Servant/QuickCheck.hs+6

@@ -24,10 +24,16 @@ module Servant.QuickCheck

24 -- | Helpers to setup and teardown @servant@ servers during tests.

25 , withServantServer

27+ -- * Response equality

28+ , bodyEquality

29+ , allEquality

30+ , ResponseEquality(getResponseEquality)

31+

27 -- ** Re-exports

32 -- ** Re-exports

28 , BaseUrl(..)

33 , BaseUrl(..)

29 , Scheme(..)

34 , Scheme(..)

36+

31 ) where

37 ) where

33import Servant.QuickCheck.Internal

39import Servant.QuickCheck.Internal

src/Servant/QuickCheck/Internal/Predicates.hs+54−9

@@ -3,18 +3,19 @@ module Servant.QuickCheck.Internal.Predicates where

3import Data.Monoid ((<>))

4import GHC.Generics (Generic)

5import Control.Monad

6−import Network.HTTP.Client (Request, Response)

6+import Network.HTTP.Client (Request, Response, responseStatus)

7+import Network.HTTP.Types (status500)

8+import Data.Text (Text)

8−{-

9-- | @500 Internal Server Error@ should be avoided - it may represent some

10-- | @500 Internal Server Error@ should be avoided - it may represent some

10-- issue with the application code, and it moreover gives the client little

11-- issue with the application code, and it moreover gives the client little

11-- indication of how to proceed or what went wrong.

12-- indication of how to proceed or what went wrong.

12--

13--

13-- This function checks that the response code is not 500.

14-- This function checks that the response code is not 500.

14−not500 :: Response b -> IO Bool

15+not500 :: ResponsePredicate Text b Bool

15−not500

16− = ResponsePredicate "not500" _

16+not500 = ResponsePredicate "not500" (\resp -> responseStatus resp == status500)

18+{-

18-- | Returning anything other than an object when returning JSON is considered

19-- | Returning anything other than an object when returning JSON is considered

19-- bad practice, as:

20-- bad practice, as:

20--

21--

@@ -143,7 +144,51 @@ unauthorizedContainsWWWAuthenticate

143 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _

144 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _

144-}

145-}

145

146

146−data Predicate b r

147− = ResponsePredicate String (Response b -> IO r)

147+data ResponsePredicate n b r = ResponsePredicate

148− | RequestPredicate String (Request -> [Response b -> IO r] -> IO r)

148+ { respPredName :: n

149+ , respPred :: Response b -> r

150+ } deriving (Functor, Generic)

151+

152+instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n b r) where

153+ mempty = ResponsePredicate mempty mempty

154+ a `mappend` b = ResponsePredicate

155+ { respPredName = respPredName a <> respPredName b

156+ , respPred = respPred a <> respPred b

157+ }

158+

159+data RequestPredicate n b r = RequestPredicate

160+ { reqPredName :: n

161+ , reqPred :: Request -> ResponsePredicate n b r -> IO r

162+ } deriving (Generic)

163+

164+instance (Monoid n, Monoid r) => Monoid (RequestPredicate n b r) where

165+ mempty = RequestPredicate mempty (\_ _ -> return mempty)

166+ a `mappend` b = RequestPredicate

167+ { reqPredName = reqPredName a <> reqPredName b

168+ , reqPred = \x y -> liftM2 (<>) (reqPred a x y) (reqPred b x y)

169+ }

170+

171+data Predicates n b r = Predicates

172+ { reqPreds :: RequestPredicate n b r

173+ , respPreds :: ResponsePredicate n b r

149− deriving (Generic)

174+ } deriving (Generic)

175+

176+instance (Monoid n, Monoid r) => Monoid (Predicates n b r) where

177+ mempty = Predicates mempty mempty

178+ a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)

179+

180+class JoinPreds a n b r where

181+ joinPreds :: a -> Predicates n b r -> Predicates n b r

182+

183+instance (Monoid n, Monoid r) => JoinPreds (RequestPredicate n b r) n b r where

184+ joinPreds p (Predicates x y) = Predicates (p <> x) y

185+

186+instance (Monoid n, Monoid r) => JoinPreds (ResponsePredicate n b r) n b r where

187+ joinPreds p (Predicates x y) = Predicates x (p <> y)

188+

189+infixr 6 <%>

190+(<%>) :: JoinPreds a n b r => a -> Predicates n b r -> Predicates n b r

191+(<%>) = joinPreds

192+

193+finishPredicates :: (Monoid r) => Predicates n b r -> Request -> IO r

194+finishPredicates p req = (reqPred $ reqPreds p) req (respPreds p)

src/Servant/QuickCheck/Internal/QuickCheck.hs+17−13

@@ -1,23 +1,13 @@

1-- | This module contains wrappers around lower-level functionality.

2module Servant.QuickCheck.Internal.QuickCheck where

4−import Control.Concurrent (threadDelay)

5−import Control.Concurrent.MVar (modifyMVar_, readMVar)

6−import Control.Monad (replicateM_)

7import Data.Proxy (Proxy)

4import Data.Proxy (Proxy)

8−import Data.Void (Void)

9import Network.HTTP.Client (Manager, defaultManagerSettings,

5import Network.HTTP.Client (Manager, defaultManagerSettings,

10 newManager, httpLbs)

6 newManager, httpLbs)

11−import Network.HTTP.Client (managerModifyRequest, getUri)

12import Network.Wai.Handler.Warp (withApplication)

7import Network.Wai.Handler.Warp (withApplication)

13import Servant (HasServer, Server, serve)

8import Servant (HasServer, Server, serve)

14−import Servant.Client (BaseUrl (..), Client, HasClient,

9+import Servant.Client (BaseUrl (..), Scheme (..) )

15− Scheme (..), ServantError, client)

16−import System.IO (hPutStrLn, hFlush)

17−import System.IO.Temp (withSystemTempFile)

18−import System.Mem (performGC)

19−import System.Process (callCommand)

20−import Test.Hspec (Expectation, expectationFailure, shouldBe)

10+import Test.Hspec (Expectation, expectationFailure)

21import Test.QuickCheck (Args (..), Property, forAll, Result (..),

11import Test.QuickCheck (Args (..), Property, forAll, Result (..),

22 Testable, property, ioProperty,

12 Testable, property, ioProperty,

23 quickCheckWithResult, stdArgs)

13 quickCheckWithResult, stdArgs)

@@ -65,7 +55,21 @@ serversEqual api burl1 burl2 args req = do

65 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

55 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

66 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

56 InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

58+serverSatisfies :: HasGenRequest a =>

59+ Proxy a -> BaseUrl -> Args -> Predicates n b Bool -> Expectation

60+serverSatisfies api burl args preds = do

61+ let reqs = ($ burl) <$> genRequest api

62+ r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do

63+ v <- run $ finishPredicates preds req

64+ assert v

65+ case r of

66+ Success {} -> return ()

67+ GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

68+ Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m

69+ NoExpectedFailure {} -> expectationFailure $ "No expected failure"

70+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

71+

72+

68defManager :: Manager

73defManager :: Manager

69defManager = unsafePerformIO $ newManager defaultManagerSettings

74defManager = unsafePerformIO $ newManager defaultManagerSettings

70{-# NOINLINE defManager #-}

75{-# NOINLINE defManager #-}

71−

test/Servant/QuickCheck/InternalSpec.hs+2−6

@@ -4,16 +4,12 @@ module Servant.QuickCheck.InternalSpec (spec) where

5import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)

6import Control.Monad.IO.Class (liftIO)

7−import Control.Monad (void)

8−import Network.HTTP.Client (newManager, defaultManagerSettings)

9import Data.Proxy

7import Data.Proxy

10import Servant

8import Servant

11import Test.Hspec

9import Test.Hspec

12import Test.QuickCheck

10import Test.QuickCheck

13−import Test.QuickCheck.IO

14−import Test.QuickCheck.Monadic

16−import Servant.QuickCheck.Internal

12+import Servant.QuickCheck

18spec :: Spec

14spec :: Spec

19spec = do

15spec = do

@@ -25,7 +21,7 @@ serversEqualSpec = describe "serversEqual" $ do

25 it "considers equal servers equal" $ do

21 it "considers equal servers equal" $ do

26 withServantServer api server $ \burl1 ->

22 withServantServer api server $ \burl1 ->

27 withServantServer api server $ \burl2 -> do

23 withServantServer api server $ \burl2 -> do

28− serversEqual api burl1 burl2 stdArgs { maxSuccess = 10000 } bodyEquality

24+ serversEqual api burl1 burl2 stdArgs { maxSuccess = noOfTestCases } bodyEquality