d22576b · servant-quickcheck

git.iko.soy/servant-quickcheck

on master help sign in

fix serverSatisfies

d22576bJulian K. Arni11 years ago

src/Servant/QuickCheck/Internal/Predicates.hs+26−13

compare with master

unifiedsplit

@@ -3,9 +3,10 @@ module Servant.QuickCheck.Internal.Predicates where

3import Data.Monoid ((<>))

4import GHC.Generics (Generic)

5import Control.Monad

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

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

7import Network.HTTP.Types (status500)

8import qualified Data.ByteString.Lazy as LBS

9+import Data.Bifunctor (Bifunctor(..))

9import Data.Text (Text)

10import Data.Text (Text)

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

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

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

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

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

14--

15--

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

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

16−not500 :: ResponsePredicate Text [Text]

17+not500 :: ResponsePredicate Text Bool

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

18+not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)

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

20{-

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

@@ -158,6 +158,10 @@ data ResponsePredicate n r = ResponsePredicate

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

159 } deriving (Functor, Generic)

160

161+instance Bifunctor ResponsePredicate where

162+ first f (ResponsePredicate a b) = ResponsePredicate (f a) b

163+ second = fmap

164+

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

165instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where

162 mempty = ResponsePredicate mempty mempty

166 mempty = ResponsePredicate mempty mempty

163 a `mappend` b = ResponsePredicate

167 a `mappend` b = ResponsePredicate

@@ -167,15 +171,20 @@ instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where

167

171

168data RequestPredicate n r = RequestPredicate

172data RequestPredicate n r = RequestPredicate

169 { reqPredName :: n

173 { reqPredName :: n

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

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

171 , reqPred :: ResponsePredicate n r

175 , reqPred :: ResponsePredicate n r

172 } deriving (Generic, Functor)

176 } deriving (Generic, Functor)

173

177

178+instance Bifunctor RequestPredicate where

179+ first f (RequestPredicate a b c) = RequestPredicate (f a) b (first f c)

180+ second = fmap

181+

182+-- TODO: This isn't actually a monoid

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

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

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

184+ mempty = RequestPredicate mempty (\r m -> return <$> httpLbs r m) mempty

176 a `mappend` b = RequestPredicate

185 a `mappend` b = RequestPredicate

177 { reqPredName = reqPredName a <> reqPredName b

186 { reqPredName = reqPredName a <> reqPredName b

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

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

179 , reqPred = reqPred a <> reqPred b

188 , reqPred = reqPred a <> reqPred b

180 }

189 }

181

190

@@ -194,17 +203,21 @@ class JoinPreds a where

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

203 joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]

195

204

196instance JoinPreds (RequestPredicate Text Bool) where

205instance JoinPreds (RequestPredicate Text Bool) where

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

206+ joinPreds p (Predicates x y) = Predicates (go <> x) y

207+ where go = let p' = first return p

208+ in fmap (\z -> if z then [] else reqPredName p') p'

198

209

199instance JoinPreds (ResponsePredicate Text Bool) where

210instance JoinPreds (ResponsePredicate Text Bool) where

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

211+ joinPreds p (Predicates x y) = Predicates x (go <> y)

212+ where go = let p' = first return p

213+ in fmap (\z -> if z then [] else respPredName p') p'

201

214

202infixr 6 <%>

215infixr 6 <%>

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

216+(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]

204(<%>) = joinPreds

217(<%>) = joinPreds

205

218

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

219+finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]

207−finishPredicates p req = do

220+finishPredicates p req mgr = do

208− resps <- reqResps (reqPreds p) req

221+ resps <- reqResps (reqPreds p) req mgr

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

222 let preds = reqPred (reqPreds p) <> respPreds p

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

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

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

@@ -3,7 +3,7 @@ module Servant.QuickCheck.Internal.QuickCheck where

4import Data.Proxy (Proxy)

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

6− newManager, httpLbs)

6+ newManager, httpLbs, checkStatus, Request)

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

8import Servant (HasServer, Server, serve)

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

@@ -44,8 +44,8 @@ serversEqual :: HasGenRequest a =>

44serversEqual api burl1 burl2 args req = do

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

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

47− resp1 <- run $ httpLbs req1 defManager

47+ resp1 <- run $ httpLbs (noCheckStatus req1) defManager

48− resp2 <- run $ httpLbs req2 defManager

48+ resp2 <- run $ httpLbs (noCheckStatus req2) defManager

49 assert $ getResponseEquality req resp1 resp2

50 case r of

51 Success {} -> return ()

@@ -55,11 +55,12 @@ serversEqual api burl1 burl2 args req = do

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

57serverSatisfies :: (HasGenRequest a) =>

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

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

59serverSatisfies api burl args preds = do

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

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

62− v <- run $ finishPredicates preds req

62+ v <- run $ finishPredicates preds (noCheckStatus req) defManager

63+ {-run $ print v-}

63 assert $ null v

64 assert $ null v

64 case r of

65 case r of

65 Success {} -> return ()

66 Success {} -> return ()

@@ -69,6 +70,9 @@ serverSatisfies api burl args preds = do

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

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

73+noCheckStatus :: Request -> Request

74+noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}

75+

72defManager :: Manager

76defManager :: Manager

73defManager = unsafePerformIO $ newManager defaultManagerSettings

77defManager = unsafePerformIO $ newManager defaultManagerSettings

74{-# NOINLINE defManager #-}

78{-# NOINLINE defManager #-}