git.iko.soy/servant-quickcheck
on master help sign in
Merge pull request #17 from haskell-servant/notLongerThan

Add notLongerThan predicate.

commit49cfb78f1d1c89a542b559f89de315cfbc5f3c24 authorJulian Arni <jkarni@gmail.com> dateWed 5 Oct 2016, 16:33 (10 years ago) parentb4876462219d2e
6 files changed+41−2
compare with master
unifiedsplit
CHANGELOG.yaml+5 servant-quickcheck.cabal+1 src/Servant/QuickCheck.hs+1 src/Servant/QuickCheck/Internal/HasGenRequest.hs+3−1 src/Servant/QuickCheck/Internal/Predicates.hs+18−1 test/Servant/QuickCheck/InternalSpec.hs+13
CHANGELOG.yaml+5
@@ -2,6 +2,11 @@ upcoming:
22
33 changes:
44
5+ - description: Add notLongerThan predicate
6+ pr: 17
7+ authors: jkarni
8+ date: 2016-10-05
9+
510 - description: Add getsHaveLastModifiedHeader predicate
611 pr: none
712 authors: jkarni
servant-quickcheck.cabal+1
@@ -36,6 +36,7 @@ library
3636 , aeson > 0.8 && < 2
3737 , bytestring == 0.10.*
3838 , case-insensitive == 1.2.*
39+ , clock >= 0.7 && < 0.8
3940 , data-default-class >= 0.0 && < 0.2
4041 , hspec == 2.2.*
4142 , http-client >= 0.4.30 && < 0.6
src/Servant/QuickCheck.hs+1
@@ -27,6 +27,7 @@ module Servant.QuickCheck
2727 -- in RFCs. The __Best Practices__ includes, in addition to RFC
2828 -- recommendations, recommendations found elsewhere or generally accepted.
2929 , not500
30+ , notLongerThan
3031 , onlyJsonObjects
3132 , notAllowedContainsAllowHeader
3233 , unauthorizedContainsWWWAuthenticate
src/Servant/QuickCheck/Internal/HasGenRequest.hs+3−1
@@ -5,7 +5,6 @@ module Servant.QuickCheck.Internal.HasGenRequest where
55import Data.Monoid ((<>))
66import Data.String (fromString)
77import Data.String.Conversions (cs)
8−import qualified Data.ByteString as BS
98import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
109import Network.HTTP.Client (Request, RequestBody (..), host, method, path,
1110 port, queryString, requestBody, requestHeaders,
@@ -16,6 +15,9 @@ import Servant
1615import Servant.API.ContentTypes (AllMimeRender (..))
1716import Servant.Client (BaseUrl (..), Scheme (..))
1817import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)
18+#if MIN_VERSION_servant(0,8,0)
19+import qualified Data.ByteString as BS
20+#endif
1921
2022
2123class HasGenRequest a where
src/Servant/QuickCheck/Internal/Predicates.hs+18−1
@@ -22,6 +22,7 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod,
2222 renderStdMethod, status100, status200,
2323 status201, status300, status401,
2424 status405, status500)
25+import System.Clock (toNanoSecs, Clock(Monotonic), getTime, diffTimeSpec)
2526import Prelude.Compat
2627
2728import Servant.QuickCheck.Internal.ErrorTypes
@@ -40,6 +41,22 @@ not500 :: ResponsePredicate
4041not500 = ResponsePredicate $ \resp ->
4142 when (responseStatus resp == status500) $ fail "not500"
4243
44+-- | [__Optional__]
45+--
46+-- This function checks that the response from the server does not take longer
47+-- than the specified number of nanoseconds.
48+--
49+-- #SINCE#
50+notLongerThan :: Integer -> RequestPredicate
51+notLongerThan maxAllowed
52+ = RequestPredicate $ \req mgr -> do
53+ start <- getTime Monotonic
54+ resp <- httpLbs req mgr
55+ end <- getTime Monotonic
56+ when (toNanoSecs (end `diffTimeSpec` start) > maxAllowed) $
57+ throw $ PredicateFailure "notLongerThan" (Just req) resp
58+ return []
59+
4360-- | [__Best Practice__]
4461--
4562-- Returning anything other than an object when returning JSON is considered
@@ -126,7 +143,7 @@ createContainsValidLocation
126143-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
127144-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
128145--
129−-- #SINCECURRENT#
146+-- #SINCE#
130147getsHaveLastModifiedHeader :: RequestPredicate
131148getsHaveLastModifiedHeader
132149 = RequestPredicate $ \req mgr ->
test/Servant/QuickCheck/InternalSpec.hs+13
@@ -25,6 +25,7 @@ spec = do
2525 serverSatisfiesSpec
2626 isComprehensiveSpec
2727 onlyJsonObjectSpec
28+ notLongerThanSpec
2829
2930serversEqualSpec :: Spec
3031serversEqualSpec = describe "serversEqual" $ do
@@ -80,6 +81,18 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
8081 (onlyJsonObjects <%> mempty)
8182 err `shouldContain` "onlyJsonObjects"
8283
84+notLongerThanSpec :: Spec
85+notLongerThanSpec = describe "notLongerThan" $ do
86+
87+ it "fails correctly" $ do
88+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
89+ evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
90+ (notLongerThan 1 <%> mempty)
91+ err `shouldContain` "notLongerThan"
92+
93+ it "succeeds correctly" $ do
94+ withServantServerAndContext api ctx server $ \burl ->
95+ serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)
8396
8497isComprehensiveSpec :: Spec
8598isComprehensiveSpec = describe "HasGenRequest" $ do