64c845c · servant-quickcheck

git.iko.soy/servant-quickcheck

on master help sign in

Slightly nicer RequestPredicate.

64c845cJulian K. Arni10 years ago

src/Servant/QuickCheck.hs+6

compare with master

unifiedsplit

@@ -55,13 +55,19 @@ module Servant.QuickCheck

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

56 , withServantServer

57 , withServantServerAndContext

58+ , defaultArgs

59 -- ** Re-exports

60 -- ** Re-exports

60 , BaseUrl(..)

61 , BaseUrl(..)

61 , Scheme(..)

62 , Scheme(..)

63+ , Args(..)

64 ) where

66 ) where

66import Servant.QuickCheck.Internal

68import Servant.QuickCheck.Internal

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

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

70+import Test.QuickCheck (Args(..), stdArgs)

71+

72+defaultArgs :: Args

73+defaultArgs = stdArgs { maxSuccess = 1000 }

src/Servant/QuickCheck/Internal/Benchmarking.hs+1−5

@@ -1,8 +1,4 @@

1−-- | This module contains benchmark-related logic.

1+-- This is a WIP module that shouldn't be used.

2−--

3−-- Currently it generates 'wrk' scripts rather than benchmarking directly with

4−-- the @servant-client@ functions since the performance of 'wrk' is

5−-- significantly better.

6module Servant.QuickCheck.Internal.Benchmarking where

2module Servant.QuickCheck.Internal.Benchmarking where

8import Data.ByteString (ByteString)

4import Data.ByteString (ByteString)

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

@@ -55,19 +55,35 @@ onlyJsonObjects

55 Nothing -> False

56 Just (_ :: Object) -> True)

58−{-

58+-- | __Optional__

59+--

59−-- | When creating a new resource, it is good practice to provide a @Location@

60+-- When creating a new resource, it is good practice to provide a @Location@

60-- header with a link to the created resource.

61-- header with a link to the created resource.

61--

62--

62-- This function checks that every @201 Created@ response contains a @Location@

63-- This function checks that every @201 Created@ response contains a @Location@

63-- header, and that the link in it responds with a 2XX response code to @GET@

64-- header, and that the link in it responds with a 2XX response code to @GET@

64-- requests.

65-- requests.

65--

66--

67+-- This is considered optional because other means of linking to the resource

68+-- (e.g. via the response body) are also acceptable; linking to the resource in

69+-- some way is considered best practice.

70+--

71+-- __References__:

72+--

73+-- * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2>

66−-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>

74+-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>

67−createContainsValidLocation :: ResponsePredicate Text Bool

75+{-createContainsValidLocation :: RequestPredicate Text Bool-}

68−createContainsValidLocation

76+{-createContainsValidLocation-}

77+ {-= RequestPredicate-}

69− = ResponsePredicate "createContainsValidLocation" (\resp ->

78+ {-{ reqPredName = "createContainsValidLocation"-}

79+ {-, reqResps = \req mg -> do-}

80+ {-resp <- httpLbs mgr req-}

81+ {-if responseStatus resp == status201-}

82+ {-then case lookup "Location" $ responseHeaders resp of-}

83+ {-Nothing -> return []-}

84+ {-Just l -> if-}

86+{-

71getsHaveLastModifiedHeader :: ResponsePredicate Text Bool

87getsHaveLastModifiedHeader :: ResponsePredicate Text Bool

72getsHaveLastModifiedHeader

88getsHaveLastModifiedHeader

73 = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->

89 = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->

@@ -91,19 +107,15 @@ getsHaveLastModifiedHeader

91notAllowedContainsAllowHeader :: RequestPredicate Text Bool

107notAllowedContainsAllowHeader :: RequestPredicate Text Bool

92notAllowedContainsAllowHeader

108notAllowedContainsAllowHeader

93 = RequestPredicate

109 = RequestPredicate

94− { reqPredName = name

110+ { reqPredName = "notAllowedContainsAllowHeader"

95− , reqResps = \req mgr -> mapM (flip httpLbs mgr)

111+ , reqResps = \req mgr -> do

96− [ req { method = renderStdMethod m }

112+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }

97− | m <- [minBound .. maxBound ]

113+ | m <- [minBound .. maxBound ]

98− , renderStdMethod m /= method req ]

114+ , renderStdMethod m /= method req ]

99− , reqPred = pred'

115+ return (all pred' resp, resp)

100 }

116 }

101 where

117 where

102− name = "notAllowedContainsAllowHeader"

103− pred' = ResponsePredicate name (\resp ->

104− if responseStatus resp == status405

118+ pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp

105− then hasValidHeader "Allow" go resp

106− else True)

107 where

119 where

108 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)

120 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)

109 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)

121 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)

@@ -148,14 +160,14 @@ honoursAcceptHeader

148getsHaveCacheControlHeader :: RequestPredicate Text Bool

160getsHaveCacheControlHeader :: RequestPredicate Text Bool

149getsHaveCacheControlHeader

161getsHaveCacheControlHeader

150 = RequestPredicate

162 = RequestPredicate

151− { reqPredName = name

163+ { reqPredName = "getsHaveCacheControlHeader"

152 , reqResps = \req mgr -> if method req == methodGet

164 , reqResps = \req mgr -> if method req == methodGet

165+ then do

153− then return <$> httpLbs req mgr

166+ resp <- httpLbs req mgr

154− else return []

155− , reqPred = ResponsePredicate name $ \resp ->

156− isJust $ lookup "Cache-Control" $ responseHeaders resp

167+ let good = isJust $ lookup "Cache-Control" $ responseHeaders resp

168+ return (good, [resp])

169+ else return (True, [])

157 }

170 }

158− where name = "getsHaveCacheControlHeader"

159

171

160-- | [__Best Practice__]

172-- | [__Best Practice__]

161--

173--

@@ -163,15 +175,14 @@ getsHaveCacheControlHeader

163headsHaveCacheControlHeader :: RequestPredicate Text Bool

175headsHaveCacheControlHeader :: RequestPredicate Text Bool

164headsHaveCacheControlHeader

176headsHaveCacheControlHeader

165 = RequestPredicate

177 = RequestPredicate

166− { reqPredName = name

178+ { reqPredName = "headsHaveCacheControlHeader"

167 , reqResps = \req mgr -> if method req == methodHead

179 , reqResps = \req mgr -> if method req == methodHead

180+ then do

168− then return <$> httpLbs req mgr

181+ resp <- httpLbs req mgr

169− else return []

170− , reqPred = ResponsePredicate name $ \resp ->

171− isJust $ lookup "Cache-Control" $ responseHeaders resp

182+ let good = isJust $ lookup "Cache-Control" $ responseHeaders resp

183+ return (good, [resp])

184+ else return (True, [])

172 }

185 }

173− where name = "headsHaveCacheControlHeader"

174−

175{-

186{-

176-- |

187-- |

177--

188--

@@ -264,21 +275,19 @@ instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where

264

275

265data RequestPredicate n r = RequestPredicate

276data RequestPredicate n r = RequestPredicate

266 { reqPredName :: n

277 { reqPredName :: n

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

278+ , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])

268− , reqPred :: ResponsePredicate n r

269 } deriving (Generic, Functor)

279 } deriving (Generic, Functor)

270

280

271instance Bifunctor RequestPredicate where

281instance Bifunctor RequestPredicate where

272− first f (RequestPredicate a b c) = RequestPredicate (f a) b (first f c)

282+ first f (RequestPredicate a b) = RequestPredicate (f a) b

273 second = fmap

283 second = fmap

274

284

275-- TODO: This isn't actually a monoid

285-- TODO: This isn't actually a monoid

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

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

277− mempty = RequestPredicate mempty (\r m -> return <$> httpLbs r m) mempty

287+ mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))

278 a `mappend` b = RequestPredicate

288 a `mappend` b = RequestPredicate

279 { reqPredName = reqPredName a <> reqPredName b

289 { reqPredName = reqPredName a <> reqPredName b

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

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

281− , reqPred = reqPred a <> reqPred b

282 }

291 }

283

292

284data Predicates n r = Predicates

293data Predicates n r = Predicates

@@ -316,9 +325,8 @@ infixr 6 <%>

316

325

317finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]

326finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]

318finishPredicates p req mgr = do

327finishPredicates p req mgr = do

319− resps <- reqResps (reqPreds p) req mgr

328+ (soFar, resps) <- reqResps (reqPreds p) req mgr

320− let preds = reqPred (reqPreds p) <> respPreds p

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

329+ return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]

322

330

323-- * helpers

331-- * helpers

324

332