feff40b · servant-quickcheck

servant-quickcheck.cabal+1

compare with master

unifiedsplit

@@ -36,6 +36,7 @@ library

36 , aeson > 0.8 && < 2

37 , bytestring == 0.10.*

38 , case-insensitive == 1.2.*

39+ , clock >= 0.7 && < 0.8

39 , data-default-class >= 0.0 && < 0.2

40 , data-default-class >= 0.0 && < 0.2

40 , hspec == 2.2.*

41 , hspec == 2.2.*

41 , http-client >= 0.4.30 && < 0.6

42 , http-client >= 0.4.30 && < 0.6

src/Servant/QuickCheck.hs+1

@@ -27,6 +27,7 @@ module Servant.QuickCheck

27 -- in RFCs. The __Best Practices__ includes, in addition to RFC

28 -- recommendations, recommendations found elsewhere or generally accepted.

29 , not500

30+ , notLongerThan

30 , onlyJsonObjects

31 , onlyJsonObjects

31 , notAllowedContainsAllowHeader

32 , notAllowedContainsAllowHeader

32 , unauthorizedContainsWWWAuthenticate

33 , unauthorizedContainsWWWAuthenticate

src/Servant/QuickCheck/Internal/HasGenRequest.hs+3−1

@@ -5,7 +5,6 @@ module Servant.QuickCheck.Internal.HasGenRequest where

5import Data.Monoid ((<>))

6import Data.String (fromString)

7import Data.String.Conversions (cs)

8−import qualified Data.ByteString as BS

9import GHC.TypeLits (KnownSymbol, Nat, symbolVal)

8import GHC.TypeLits (KnownSymbol, Nat, symbolVal)

10import Network.HTTP.Client (Request, RequestBody (..), host, method, path,

9import Network.HTTP.Client (Request, RequestBody (..), host, method, path,

11 port, queryString, requestBody, requestHeaders,

10 port, queryString, requestBody, requestHeaders,

@@ -16,6 +15,9 @@ import Servant

16import Servant.API.ContentTypes (AllMimeRender (..))

15import Servant.API.ContentTypes (AllMimeRender (..))

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

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

18import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)

17import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)

18+#if MIN_VERSION_servant(0,8,0)

19+import qualified Data.ByteString as BS

20+#endif

19

21

20

22

21class HasGenRequest a where

23class HasGenRequest a where

src/Servant/QuickCheck/Internal/Predicates.hs+18−1

@@ -22,6 +22,7 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod,

22 renderStdMethod, status100, status200,

23 status201, status300, status401,

24 status405, status500)

25+import System.Clock (toNanoSecs, Clock(Monotonic), getTime, diffTimeSpec)

25import Prelude.Compat

26import Prelude.Compat

26

27

27import Servant.QuickCheck.Internal.ErrorTypes

28import Servant.QuickCheck.Internal.ErrorTypes

@@ -40,6 +41,22 @@ not500 :: ResponsePredicate

40not500 = ResponsePredicate $ \resp ->

41not500 = ResponsePredicate $ \resp ->

41 when (responseStatus resp == status500) $ fail "not500"

42 when (responseStatus resp == status500) $ fail "not500"

42

43

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+

43-- | [__Best Practice__]

60-- | [__Best Practice__]

44--

61--

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

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

@@ -126,7 +143,7 @@ createContainsValidLocation

126-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>

143-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>

127-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>

144-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>

128--

145--

129−-- #SINCECURRENT#

146+-- #SINCE#

130getsHaveLastModifiedHeader :: RequestPredicate

147getsHaveLastModifiedHeader :: RequestPredicate

131getsHaveLastModifiedHeader

148getsHaveLastModifiedHeader

132 = RequestPredicate $ \req mgr ->

149 = RequestPredicate $ \req mgr ->

test/Servant/QuickCheck/InternalSpec.hs+13

@@ -25,6 +25,7 @@ spec = do

25 serverSatisfiesSpec

26 isComprehensiveSpec

27 onlyJsonObjectSpec

28+ notLongerThanSpec

28

29

29serversEqualSpec :: Spec

30serversEqualSpec :: Spec

30serversEqualSpec = describe "serversEqual" $ do

31serversEqualSpec = describe "serversEqual" $ do

@@ -80,6 +81,18 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do

80 (onlyJsonObjects <%> mempty)

81 (onlyJsonObjects <%> mempty)

81 err `shouldContain` "onlyJsonObjects"

82 err `shouldContain` "onlyJsonObjects"

82

83

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)

83

96

84isComprehensiveSpec :: Spec

97isComprehensiveSpec :: Spec

85isComprehensiveSpec = describe "HasGenRequest" $ do

98isComprehensiveSpec = describe "HasGenRequest" $ do