From de16b1a556e723da101bb56449c75ec7376d76d7 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Fri, 23 Aug 2019 15:13:40 -0400
Subject: [PATCH] Make gen of charges with vouchers more than vanishingly
unlikely
This does a better job covering good and bad cases in the implementation,
though currently none of the values resulting are used so they're still not actually covered.
---
test/SpecStripe.hs | 39 ++++++--------
test/Util/Gen.hs | 123 ++++++++++++++++++++++++++++-----------------
2 files changed, 90 insertions(+), 72 deletions(-)
diff --git a/test/SpecStripe.hs b/test/SpecStripe.hs
index 9c4f61f..d825bbe 100644
--- a/test/SpecStripe.hs
+++ b/test/SpecStripe.hs
@@ -35,23 +35,19 @@ import Test.QuickCheck
( Property
, Gen
, arbitrary
- , suchThat
- , suchThatMap
, generate
, forAll
, (===)
, (=/=)
)
-import Test.QuickCheck.Instances.Tuple
- ( (>*<)
- )
import Util.WAI
( postJSON
)
import Util.Gen
- ( GoodChargeEvent(GoodChargeEvent)
+ ( ChargeEvents(GoodChargeEvent, BadChargeEvent)
, chargeSucceededEvents
- , hasVoucher
+ , metaDatasWithVoucher
+ , metaDatasWithoutVoucher
)
import Util.JSON
( -- ToJSON instance for Event
@@ -76,9 +72,6 @@ import PaymentServer.Persistence
( Voucher
, memory
)
-import Data.List.Index
- ( insertAt
- )
stripeAPI :: Proxy StripeAPI
stripeAPI = Proxy
@@ -102,26 +95,22 @@ spec_webhook = with app $ do
-- 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)" $
- property $
- \(GoodChargeEvent event) ->
- postJSON "/webhook" (encode event) `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }
+ let
+ test e =
+ postJSON "/webhook" (encode e) `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }
+ -- For now these are the same. Maybe they always will be? The HTTP
+ -- behavior is the same though the backend behavior may differ.
+ xtest_postWithEventBody (GoodChargeEvent e) = test e
+ xtest_postWithEventBody (BadChargeEvent e) = test e
+ in
+ property xtest_postWithEventBody
+
+
bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String
bodyMatcher _ "{}" = Nothing
bodyMatcher _ body = Just $ show body
-metaDatasWithoutVoucher = (arbitrary :: Gen MetaData) `suchThat` (not . hasVoucher)
-
--- Just filtering out random metadatas that don't have a voucher makes for an
--- incredibly inefficient generator. So start without a voucher and then add
--- one.
-metaDatasWithVoucher = ((arbitrary :: Gen Voucher) >*< metaDatasWithoutVoucher) `suchThatMap` (Just. uncurry addVoucher)
-
-addVoucher :: Voucher -> MetaData -> MetaData
-addVoucher voucher (MetaData []) = MetaData [("Voucher", voucher)]
-addVoucher voucher (MetaData items) =
- MetaData (insertAt (1234567 `mod` length items) ("Voucher", voucher) items)
-
prop_getVoucherFindsVoucher :: Property
prop_getVoucherFindsVoucher = forAll metaDatasWithVoucher $ \x ->
getVoucher x =/= Nothing
diff --git a/test/Util/Gen.hs b/test/Util/Gen.hs
index 863116c..e74de2b 100644
--- a/test/Util/Gen.hs
+++ b/test/Util/Gen.hs
@@ -2,24 +2,26 @@
module Util.Gen
( chargeSucceededEvents
+ , metaDatasWithoutVoucher
+ , metaDatasWithVoucher
, posixTimes
, hasVoucher
- , GoodChargeEvent(GoodChargeEvent)
+ , ChargeEvents(GoodChargeEvent, BadChargeEvent)
) where
import Data.Text
( Text
)
-
+import Data.List.Index
+ ( insertAt
+ )
import Data.Time.Clock
( UTCTime(UTCTime)
)
-
import Data.Time.Clock.POSIX
( POSIXTime
, posixSecondsToUTCTime
)
-
import Web.Stripe.Types
( Charge(Charge)
, StatementDescription(StatementDescription)
@@ -33,60 +35,36 @@ import Web.Stripe.Types
, Amount(Amount)
, StripeList(StripeList, list, totalCount, hasMore)
)
-
import Web.Stripe.Event
( Event(Event, eventId, eventCreated, eventLiveMode, eventType, eventData, eventObject, eventPendingWebHooks, eventRequest)
, EventType(ChargeSucceededEvent)
, EventData(ChargeEvent)
, EventId(EventId)
)
-
-
import Test.QuickCheck
( Gen
, Arbitrary
, arbitrary
, Positive(Positive)
, oneof
+ , suchThat
, suchThatMap
)
-
+import Test.QuickCheck.Instances.Tuple
+ ( (>*<)
+ )
import Test.QuickCheck.Instances.Time
( -- Get the `Gen UTCTime` instance
)
import Test.QuickCheck.Instances.Text
( -- Get the `Gen Text` instance
)
+import PaymentServer.Persistence
+ ( Voucher
+ )
instance Arbitrary Charge where
- arbitrary = Charge
- <$> arbitrary -- chargeId :: ChargeId
- <*> return "charge" -- chargeObject :: Text
- <*> posixTimes -- chargeCreated :: UTCTime
- <*> arbitrary -- chargeLiveMode :: Bool
- <*> arbitrary -- chargePaid :: Bool
- <*> arbitrary -- chargeAmount :: Amount
- <*> oneof
- [ return UnknownCurrency
- , return USD
- ] -- chargeCurrency :: Currency
- <*> return False -- chargeRefunded :: Bool
- <*> return Nothing -- chargeCreditCard :: Maybe Card
- <*> arbitrary -- chargeCaptured :: Bool
- <*> return mempty -- chargeRefunds :: StripeList Refund
- <*> return Nothing -- chargeBalanceTransaction :: Maybe (Expandable TransactionId)
- <*> return Nothing -- chargeFailureMessage :: Maybe Text
- <*> return Nothing -- chargeFailureCode :: Maybe Text
- <*> return 0 -- chargeAmountRefunded :: Int
- <*> arbitrary -- chargeCustomerId :: Maybe (Expandable CustomerId)
- <*> return Nothing -- chargeInvoice :: Maybe (Expandable InvoiceId)
- <*> arbitrary -- chargeDescription :: Maybe Description
- <*> return Nothing -- chargeDispute :: Maybe Dispute
- <*> arbitrary -- chargeMetaData :: MetaData
- <*> arbitrary -- chargeStatementDescription :: Maybe StatementDescription
- <*> arbitrary -- chargeReceiptEmail :: Maybe Text
- <*> arbitrary -- chargeReceiptNumber :: Maybe Text
-
+ arbitrary = charges True
instance Semigroup (StripeList a) where
-- Very weak implementation
@@ -106,11 +84,20 @@ instance Arbitrary EventId where
instance Arbitrary StatementDescription where
arbitrary = StatementDescription <$> arbitrary
+metaDatasWithoutVoucher = (arbitrary :: Gen MetaData) `suchThat` (not . hasVoucher)
+-- Just filtering out random metadatas that don't have a voucher makes for an
+-- incredibly inefficient generator. So start without a voucher and then add
+-- one.
+metaDatasWithVoucher = ((arbitrary :: Gen Voucher) >*< metaDatasWithoutVoucher) `suchThatMap` (Just. uncurry addVoucher)
+
+addVoucher :: Voucher -> MetaData -> MetaData
+addVoucher voucher (MetaData []) = MetaData [("Voucher", voucher)]
+addVoucher voucher (MetaData items) =
+ MetaData (insertAt (1234567 `mod` length items) ("Voucher", voucher) items)
instance Arbitrary MetaData where
arbitrary = MetaData <$> arbitrary
-
instance Arbitrary Description where
arbitrary = Description <$> arbitrary
@@ -130,26 +117,68 @@ instance Arbitrary CustomerId where
instance Arbitrary a => Arbitrary (Expandable a) where
arbitrary = Id <$> arbitrary
-chargeSucceededEvents :: Gen Event
-chargeSucceededEvents =
+chargeSucceededEvents :: Bool -> Gen Event
+chargeSucceededEvents withVoucher =
Event
<$> arbitrary -- eventId
<*> posixTimes -- eventCreated
<*> arbitrary -- eventLiveMode
<*> return ChargeSucceededEvent -- eventType
- <*> (ChargeEvent
- <$> arbitrary -- the charge
- ) -- eventData
+ <*> chargeEvents withVoucher -- eventData
<*> return "event" -- eventObject
<*> arbitrary -- eventPendingWebHooks
<*> arbitrary -- eventRequest
-data GoodChargeEvent = GoodChargeEvent Event deriving (Show, Eq)
-
-instance Arbitrary GoodChargeEvent where
- arbitrary = chargeSucceededEvents `suchThatMap` (Just . GoodChargeEvent)
-
+chargeEvents :: Bool -> Gen EventData
+chargeEvents withVoucher =
+ ChargeEvent <$> charges withVoucher
+
+charges :: Bool -> Gen Charge
+charges withVoucher =
+ Charge
+ <$> arbitrary -- chargeId :: ChargeId
+ <*> return "charge" -- chargeObject :: Text
+ <*> posixTimes -- chargeCreated :: UTCTime
+ <*> arbitrary -- chargeLiveMode :: Bool
+ <*> arbitrary -- chargePaid :: Bool
+ <*> arbitrary -- chargeAmount :: Amount
+ <*> oneof
+ [ return UnknownCurrency
+ , return USD
+ ] -- chargeCurrency :: Currency
+ <*> return False -- chargeRefunded :: Bool
+ <*> return Nothing -- chargeCreditCard :: Maybe Card
+ <*> arbitrary -- chargeCaptured :: Bool
+ <*> return mempty -- chargeRefunds :: StripeList Refund
+ <*> return Nothing -- chargeBalanceTransaction :: Maybe (Expandable TransactionId)
+ <*> return Nothing -- chargeFailureMessage :: Maybe Text
+ <*> return Nothing -- chargeFailureCode :: Maybe Text
+ <*> return 0 -- chargeAmountRefunded :: Int
+ <*> arbitrary -- chargeCustomerId :: Maybe (Expandable CustomerId)
+ <*> return Nothing -- chargeInvoice :: Maybe (Expandable InvoiceId)
+ <*> arbitrary -- chargeDescription :: Maybe Description
+ <*> return Nothing -- chargeDispute :: Maybe Dispute
+ <*> (
+ if withVoucher then
+ metaDatasWithVoucher
+ else
+ metaDatasWithVoucher
+ ) -- chargeMetaData :: MetaData
+ <*> arbitrary -- chargeStatementDescription :: Maybe StatementDescription
+ <*> arbitrary -- chargeReceiptEmail :: Maybe Text
+ <*> arbitrary -- chargeReceiptNumber :: Maybe Text
+
+data ChargeEvents
+ = GoodChargeEvent Event
+ | BadChargeEvent Event
+ deriving (Show, Eq)
+
+instance Arbitrary ChargeEvents where
+ arbitrary = oneof
+ [ chargeSucceededEvents True `suchThatMap` (Just . GoodChargeEvent)
+ , chargeSucceededEvents False `suchThatMap` (Just . BadChargeEvent)
+ ]
posixTimes :: Gen UTCTime
posixTimes = (arbitrary :: Gen Integer) `suchThatMap` (Just . posixSecondsToUTCTime . fromIntegral . abs)
--
GitLab