dbdb948 · servant-quickcheck

git.iko.soy/servant-quickcheck

on master help sign in

wip

dbdb948Julian K. Arni11 years ago

servant-quickcheck.cabal+1

compare with master

unifiedsplit

@@ -57,6 +57,7 @@ library

57 , DeriveGeneric

58 , ScopedTypeVariables

59 , OverloadedStrings

60+ , FunctionalDependencies

60 default-language: Haskell2010

61 default-language: Haskell2010

62test-suite spec

63test-suite spec

src/Servant/QuickCheck.hs+10−2

@@ -19,16 +19,24 @@

19module Servant.QuickCheck

20 (

22− serversEqual

22+

23 -- * Test setup helpers

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

25− , withServantServer

25+ withServantServer

26+

27+ , serversEqual

28+ , serverSatisfies

27 -- * Response equality

30 -- * Response equality

28 , bodyEquality

31 , bodyEquality

29 , allEquality

32 , allEquality

30 , ResponseEquality(getResponseEquality)

33 , ResponseEquality(getResponseEquality)

35+ -- * Predicates

36+ , (<%>)

37+ , Predicates

38+ , not500

39+

32 -- ** Re-exports

40 -- ** Re-exports

33 , BaseUrl(..)

41 , BaseUrl(..)

34 , Scheme(..)

42 , Scheme(..)

src/Servant/QuickCheck/Internal/Predicates.hs+38−22

@@ -5,6 +5,7 @@ import GHC.Generics (Generic)

5import Control.Monad

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

7import Network.HTTP.Types (status500)

8+import qualified Data.ByteString.Lazy as LBS

8import Data.Text (Text)

9import Data.Text (Text)

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

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

@@ -12,8 +13,9 @@ import Data.Text (Text)

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

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

13--

14--

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

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

15−not500 :: ResponsePredicate Text b Bool

16+not500 :: ResponsePredicate Text [Text]

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

17+not500 = ResponsePredicate "not500" (\resp ->

18+ if responseStatus resp == status500 then ["not500"] else [])

18{-

20{-

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

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

@@ -143,52 +145,66 @@ unauthorizedContainsWWWAuthenticate :: Predicate b Bool

143unauthorizedContainsWWWAuthenticate

145unauthorizedContainsWWWAuthenticate

144 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _

146 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _

145-}

147-}

148+-- * Predicate logic

146

149

150+-- The idea with all this footwork is to not waste any requests. Rather than

151+-- generating new requests and only applying one predicate to the response, we

152+-- apply as many predicates as possible.

153+--

154+-- Still, this is all kind of ugly.

155+

147−data ResponsePredicate n b r = ResponsePredicate

156+data ResponsePredicate n r = ResponsePredicate

148 { respPredName :: n

157 { respPredName :: n

149− , respPred :: Response b -> r

158+ , respPred :: Response LBS.ByteString -> r

150 } deriving (Functor, Generic)

159 } deriving (Functor, Generic)

151

160

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

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

153 mempty = ResponsePredicate mempty mempty

162 mempty = ResponsePredicate mempty mempty

154 a `mappend` b = ResponsePredicate

163 a `mappend` b = ResponsePredicate

155 { respPredName = respPredName a <> respPredName b

164 { respPredName = respPredName a <> respPredName b

156 , respPred = respPred a <> respPred b

165 , respPred = respPred a <> respPred b

157 }

166 }

158

167

159−data RequestPredicate n b r = RequestPredicate

168+data RequestPredicate n r = RequestPredicate

160 { reqPredName :: n

169 { reqPredName :: n

170+ , reqResps :: Request -> IO [Response LBS.ByteString]

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

171+ , reqPred :: ResponsePredicate n r

162− } deriving (Generic)

172+ } deriving (Generic, Functor)

163

173

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

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

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

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

166 a `mappend` b = RequestPredicate

176 a `mappend` b = RequestPredicate

167 { reqPredName = reqPredName a <> reqPredName b

177 { reqPredName = reqPredName a <> reqPredName b

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

178+ , reqResps = \x -> liftM2 (<>) (reqResps a x) (reqResps b x)

179+ , reqPred = reqPred a <> reqPred b

169 }

180 }

170

181

171−data Predicates n b r = Predicates

182+data Predicates n r = Predicates

172− { reqPreds :: RequestPredicate n b r

183+ { reqPreds :: RequestPredicate n r

173− , respPreds :: ResponsePredicate n b r

184+ , respPreds :: ResponsePredicate n r

174− } deriving (Generic)

185+ } deriving (Generic, Functor)

175

186

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

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

177 mempty = Predicates mempty mempty

188 mempty = Predicates mempty mempty

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

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

179

190

180−class JoinPreds a n b r where

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

182

191

192+

193+class JoinPreds a where

194+ joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]

195+

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

196+instance JoinPreds (RequestPredicate Text Bool) where

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

197 joinPreds p (Predicates x y) = Predicates (p <> x) y

185

198

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

199+instance JoinPreds (ResponsePredicate Text Bool) where

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

200 joinPreds p (Predicates x y) = Predicates x (p <> y)

188

201

189infixr 6 <%>

202infixr 6 <%>

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

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

191(<%>) = joinPreds

204(<%>) = joinPreds

192

205

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

206+finishPredicates :: Predicates [Text] [Text] -> Request -> IO [Text]

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

207+finishPredicates p req = do

208+ resps <- reqResps (reqPreds p) req

209+ let preds = reqPred (reqPreds p) <> respPreds p

210+ return $ mconcat [respPred preds r | r <- resps ]

src/Servant/QuickCheck/Internal/QuickCheck.hs+8−9

@@ -8,16 +8,15 @@ import Network.Wai.Handler.Warp (withApplication)

8import Servant (HasServer, Server, serve)

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

10import Test.Hspec (Expectation, expectationFailure)

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

11+import Test.QuickCheck (Args (..), Result (..),

12− Testable, property, ioProperty,

13− quickCheckWithResult, stdArgs)

12+ quickCheckWithResult)

14import System.IO.Unsafe (unsafePerformIO)

13import System.IO.Unsafe (unsafePerformIO)

15import Test.QuickCheck.Monadic

14import Test.QuickCheck.Monadic

16−import qualified Data.ByteString.Lazy as BSL

15+import qualified Data.ByteString.Lazy as LBS

16+import Data.Text (Text)

18import Servant.QuickCheck.Internal.HasGenRequest

19import Servant.QuickCheck.Internal.Predicates

20−import Servant.QuickCheck.Internal.Benchmarking

21import Servant.QuickCheck.Internal.Equality

20import Servant.QuickCheck.Internal.Equality

@@ -41,7 +40,7 @@ withServantServer api server t

41-- Evidently, if the behaviour of the server is expected to be

40-- Evidently, if the behaviour of the server is expected to be

42-- non-deterministic, this function may produce spurious failures

41-- non-deterministic, this function may produce spurious failures

43serversEqual :: HasGenRequest a =>

42serversEqual :: HasGenRequest a =>

44− Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality BSL.ByteString -> Expectation

43+ Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation

45serversEqual api burl1 burl2 args req = do

44serversEqual api burl1 burl2 args req = do

46 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api

45 let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api

47 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do

46 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do

@@ -55,13 +54,13 @@ serversEqual api burl1 burl2 args req = do

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

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

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

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

58−serverSatisfies :: HasGenRequest a =>

57+serverSatisfies :: (HasGenRequest a) =>

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

58+ Proxy a -> BaseUrl -> Args -> Predicates Text [Text] -> Expectation

60serverSatisfies api burl args preds = do

59serverSatisfies api burl args preds = do

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

60 let reqs = ($ burl) <$> genRequest api

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

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

63 v <- run $ finishPredicates preds req

62 v <- run $ finishPredicates preds req

64− assert v

63+ assert $ null v

65 case r of

64 case r of

66 Success {} -> return ()

65 Success {} -> return ()

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

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

test/Servant/QuickCheck/InternalSpec.hs+12−1

@@ -14,6 +14,7 @@ import Servant.QuickCheck

14spec :: Spec

15spec = do

16 serversEqualSpec

17+ serverSatisfiesSpec

18serversEqualSpec :: Spec

19serversEqualSpec :: Spec

19serversEqualSpec = describe "serversEqual" $ do

20serversEqualSpec = describe "serversEqual" $ do

@@ -21,9 +22,16 @@ serversEqualSpec = describe "serversEqual" $ do

21 it "considers equal servers equal" $ do

22 it "considers equal servers equal" $ do

22 withServantServer api server $ \burl1 ->

23 withServantServer api server $ \burl1 ->

23 withServantServer api server $ \burl2 -> do

24 withServantServer api server $ \burl2 -> do

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

25+ serversEqual api burl1 burl2 args bodyEquality

28+serverSatisfiesSpec :: Spec

29+serverSatisfiesSpec = describe "serverSatisfies" $ do

30+

31+ it "succeeds for true predicates" $ do

32+ withServantServer api server $ \burl ->

33+ serverSatisfies api burl args (not500 <%> mempty)

34+

28------------------------------------------------------------------------------

36------------------------------------------------------------------------------

29-- APIs

37-- APIs

@@ -46,6 +54,9 @@ server = do

46-- Utils

54-- Utils

47------------------------------------------------------------------------------

55------------------------------------------------------------------------------

57+args :: Args

58+args = stdArgs { maxSuccess = noOfTestCases }

59+

49noOfTestCases :: Int

60noOfTestCases :: Int

50#if LONG_TESTS

61#if LONG_TESTS

51noOfTestCases = 20000

62noOfTestCases = 20000