Add notLongerThan predicate.

servant-quickcheck.cabal

@@ -36,6 +36,7 @@ library
                      , aeson > 0.8 && < 2
                      , bytestring == 0.10.*
                      , case-insensitive == 1.2.*
+                     , clock >= 0.7 && < 0.8
                      , data-default-class >= 0.0 && < 0.2
                      , hspec == 2.2.*
                      , http-client >= 0.4.30 && < 0.6

src/Servant/QuickCheck.hs

@@ -27,6 +27,7 @@ module Servant.QuickCheck
   -- in RFCs. The __Best Practices__ includes, in addition to RFC
   -- recommendations, recommendations found elsewhere or generally accepted.
   , not500
+  , notLongerThan
   , onlyJsonObjects
   , notAllowedContainsAllowHeader
   , unauthorizedContainsWWWAuthenticate

src/Servant/QuickCheck/Internal/HasGenRequest.hs

@@ -5,7 +5,6 @@ module Servant.QuickCheck.Internal.HasGenRequest where
 import Data.Monoid              ((<>))
 import Data.String              (fromString)
 import Data.String.Conversions  (cs)
-import qualified Data.ByteString as BS
 import GHC.TypeLits             (KnownSymbol, Nat, symbolVal)
 import Network.HTTP.Client      (Request, RequestBody (..), host, method, path,
                                  port, queryString, requestBody, requestHeaders,
@@ -16,6 +15,9 @@ import Servant
 import Servant.API.ContentTypes (AllMimeRender (..))
 import Servant.Client           (BaseUrl (..), Scheme (..))
 import Test.QuickCheck          (Arbitrary (..), Gen, elements, oneof)
+#if MIN_VERSION_servant(0,8,0)
+import qualified Data.ByteString as BS
+#endif
 
 
 class HasGenRequest a where

src/Servant/QuickCheck/Internal/Predicates.hs

@@ -22,6 +22,7 @@ import           Network.HTTP.Types    (methodGet, methodHead, parseMethod,
                                         renderStdMethod, status100, status200,
                                         status201, status300, status401,
                                         status405, status500)
+import           System.Clock           (toNanoSecs, Clock(Monotonic), getTime, diffTimeSpec)
 import           Prelude.Compat
 
 import Servant.QuickCheck.Internal.ErrorTypes
@@ -40,6 +41,22 @@ not500 :: ResponsePredicate
 not500 = ResponsePredicate $ \resp ->
   when (responseStatus resp == status500) $ fail "not500"
 
+-- | [__Optional__]
+--
+-- This function checks that the response from the server does not take longer
+-- than the specified number of nanoseconds.
+--
+-- #SINCE#
+notLongerThan :: Integer -> RequestPredicate
+notLongerThan maxAllowed
+  = RequestPredicate $ \req mgr -> do
+     start <- getTime Monotonic
+     resp <- httpLbs req mgr
+     end <- getTime Monotonic
+     when (toNanoSecs (end `diffTimeSpec` start) > maxAllowed) $
+       throw $ PredicateFailure "notLongerThan" (Just req) resp
+     return []
+
 -- | [__Best Practice__]
 --
 -- Returning anything other than an object when returning JSON is considered
@@ -126,7 +143,7 @@ createContainsValidLocation
 --   * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
 --   * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
 --
--- #SINCECURRENT#
+-- #SINCE#
 getsHaveLastModifiedHeader :: RequestPredicate
 getsHaveLastModifiedHeader
   = RequestPredicate $ \req mgr ->

test/Servant/QuickCheck/InternalSpec.hs

@@ -25,6 +25,7 @@ spec = do
   serverSatisfiesSpec
   isComprehensiveSpec
   onlyJsonObjectSpec
+  notLongerThanSpec
 
 serversEqualSpec :: Spec
 serversEqualSpec = describe "serversEqual" $ do
@@ -80,6 +81,18 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
         (onlyJsonObjects <%> mempty)
     err `shouldContain` "onlyJsonObjects"
 
+notLongerThanSpec :: Spec
+notLongerThanSpec = describe "notLongerThan" $ do
+
+  it "fails correctly" $ do
+    Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
+      evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
+        (notLongerThan 1 <%> mempty)
+    err `shouldContain` "notLongerThan"
+
+  it "succeeds correctly" $ do
+    withServantServerAndContext api ctx server $ \burl ->
+      serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)
 
 isComprehensiveSpec :: Spec
 isComprehensiveSpec = describe "HasGenRequest" $ do