diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 53e4975..40f2bc4 100644 --- a/servant-quickcheck.cabal +++ b/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 diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index 6afc7a6..962615e 100644 --- a/src/Servant/QuickCheck.hs +++ b/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 diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs index 2047dee..d71ac93 100644 --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/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 diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 523bfd0..297760b 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/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: -- * Date format: -- --- #SINCECURRENT# +-- #SINCE# getsHaveLastModifiedHeader :: RequestPredicate getsHaveLastModifiedHeader = RequestPredicate $ \req mgr -> diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index f0e306f..71b790e 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/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