From 0876e0d3b743ce9bfaf5aad80415b1cbf5656d40 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Fri, 23 Aug 2019 14:35:37 -0400
Subject: [PATCH] Get property tests working
---
test/SpecStripe.hs | 25 ++++++++++++++-----------
test/Util/Gen.hs | 8 ++++++++
2 files changed, 22 insertions(+), 11 deletions(-)
diff --git a/test/SpecStripe.hs b/test/SpecStripe.hs
index 8701540..9c4f61f 100644
--- a/test/SpecStripe.hs
+++ b/test/SpecStripe.hs
@@ -28,13 +28,15 @@ import Test.Hspec.Wai
, shouldRespondWith
, liftIO
)
+import Test.Hspec.Wai.QuickCheck
+ ( property
+ )
import Test.QuickCheck
( Property
, Gen
, arbitrary
, suchThat
, suchThatMap
- , property
, generate
, forAll
, (===)
@@ -47,7 +49,8 @@ import Util.WAI
( postJSON
)
import Util.Gen
- ( chargeSucceededEvents
+ ( GoodChargeEvent(GoodChargeEvent)
+ , chargeSucceededEvents
, hasVoucher
)
import Util.JSON
@@ -83,14 +86,8 @@ stripeAPI = Proxy
app :: IO Application
app = memory >>= return . stripeServer >>= return . serve stripeAPI
-aChargeEvent :: IO LazyBS.ByteString
-aChargeEvent = encode <$> generate chargeSucceededEvents
-
spec_webhook :: Spec
spec_webhook = with app $ do
- -- I would like to make these property tests but I can't figure out how to
- -- use QuickCheck (or Hedgehog) to write property tests for web code.
-
describe "error behavior of POST /webhook" $ do
it "responds to non-JSON Content-Type with 415 (Unsupported Media Type)" $
post "/webhook" "xxx" `shouldRespondWith` 415
@@ -98,10 +95,16 @@ spec_webhook = with app $ do
it "responds to JSON non-Event body with 400 (Invalid Request)" $
postJSON "/webhook" "{}" `shouldRespondWith` 400
+ -- I would like to make most or all of these into property tests. *This*
+ -- test shows how you can do it. Yay. The main thing (for me, anyway) to
+ -- remember is to use `property` from Test.Hspec.Wai.QuickCheck and not from
+ -- `Test.QuickCheck`. :/ Unsure whether I love the apparent Haskell
+ -- convention of giving the same name to *similar* functions.
describe "success behavior of POST /webhook" $
- it "responds to a JSON Event body with 200 (OK)" $ do
- event <- liftIO aChargeEvent
- postJSON "/webhook" event `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }
+ it "responds to a JSON Event body with 200 (OK)" $
+ property $
+ \(GoodChargeEvent event) ->
+ postJSON "/webhook" (encode event) `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }
bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String
bodyMatcher _ "{}" = Nothing
diff --git a/test/Util/Gen.hs b/test/Util/Gen.hs
index 5bdcd45..863116c 100644
--- a/test/Util/Gen.hs
+++ b/test/Util/Gen.hs
@@ -4,6 +4,7 @@ module Util.Gen
( chargeSucceededEvents
, posixTimes
, hasVoucher
+ , GoodChargeEvent(GoodChargeEvent)
) where
import Data.Text
@@ -143,6 +144,13 @@ chargeSucceededEvents =
<*> arbitrary -- eventPendingWebHooks
<*> arbitrary -- eventRequest
+
+data GoodChargeEvent = GoodChargeEvent Event deriving (Show, Eq)
+
+instance Arbitrary GoodChargeEvent where
+ arbitrary = chargeSucceededEvents `suchThatMap` (Just . GoodChargeEvent)
+
+
posixTimes :: Gen UTCTime
posixTimes = (arbitrary :: Gen Integer) `suchThatMap` (Just . posixSecondsToUTCTime . fromIntegral . abs)
--
GitLab