From 431e8af880f20a8e2ef993891cb8a975c973a583 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Mon, 25 Nov 2019 14:21:35 -0500
Subject: [PATCH] keep vouchers out of db for stripe charge failures
transaction rollback logic relied on exceptions, stripe charge function
signaled failure with Either, thus stripe failues had no effect on transaction
rollback
---
src/PaymentServer/Persistence.hs | 4 +-
src/PaymentServer/Processors/Stripe.hs | 71 +++++++++++++++-----------
test/Persistence.hs | 2 +-
3 files changed, 44 insertions(+), 33 deletions(-)
diff --git a/src/PaymentServer/Persistence.hs b/src/PaymentServer/Persistence.hs
index b13d796..324a888 100644
--- a/src/PaymentServer/Persistence.hs
+++ b/src/PaymentServer/Persistence.hs
@@ -4,7 +4,7 @@ module PaymentServer.Persistence
( Voucher
, Fingerprint
, RedeemError(NotPaid, AlreadyRedeemed)
- , PaymentError(AlreadyPaid)
+ , PaymentError(AlreadyPaid, PaymentFailed)
, VoucherDatabase(payForVoucher, redeemVoucher)
, VoucherDatabaseState(MemoryDB, SQLiteDB)
, memory
@@ -49,6 +49,8 @@ type Voucher = Text
data PaymentError =
-- | The voucher has already been paid for.
AlreadyPaid
+ -- | The payment transaction has failed.
+ | PaymentFailed
deriving (Show, Eq)
instance Exception PaymentError
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
index 43f47f5..66efadc 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -17,6 +17,7 @@ import Control.Monad
)
import Control.Exception
( try
+ , throwIO
)
import Data.ByteString
( ByteString
@@ -25,6 +26,7 @@ import Data.Text
( Text
, unpack
)
+import qualified Data.Map as Map
import Text.Read
( readMaybe
)
@@ -33,14 +35,16 @@ import Data.Aeson
, FromJSON(parseJSON)
, Value(Object)
, object
+ , encode
, (.:)
+ , (.=)
)
import Servant
( Server
, Handler
, err400
, err500
- , ServerError(errHTTPCode, errBody)
+ , ServerError(ServerError, errHTTPCode, errBody, errHeaders, errReasonPhrase)
, throwError
)
import Servant.API
@@ -80,7 +84,7 @@ import Web.Stripe
import PaymentServer.Persistence
( Voucher
, VoucherDatabase(payForVoucher)
- , PaymentError(AlreadyPaid)
+ , PaymentError(AlreadyPaid, PaymentFailed)
)
type StripeSecretKey = ByteString
@@ -133,12 +137,10 @@ charge d key (Charges token voucher amount currency) = do
case result of
Left AlreadyPaid ->
throwError voucherAlreadyPaid
- Right stripeResult ->
- case stripeResult of
- Right Charge { chargeMetaData = metadata } ->
- checkVoucherMetadata metadata
- Left StripeError {} ->
- throwError stripeChargeFailed
+ Left PaymentFailed ->
+ throwError stripeChargeFailed
+ Right Charge { chargeMetaData = metadata } ->
+ checkVoucherMetadata metadata
where
getCurrency :: Text -> Handler Currency
getCurrency maybeCurrency =
@@ -148,10 +150,14 @@ charge d key (Charges token voucher amount currency) = do
config = StripeConfig (StripeKey key) Nothing
tokenId = TokenId token
- completeStripeCharge currency' = stripe config $
- createCharge (Amount amount) currency'
- -&- tokenId
- -&- MetaData [("Voucher", voucher)]
+ completeStripeCharge currency' = do
+ result <- stripe config $
+ createCharge (Amount amount) currency'
+ -&- tokenId
+ -&- MetaData [("Voucher", voucher)]
+ case result of
+ Left StripeError {} -> throwIO PaymentFailed
+ Right result -> return result
checkVoucherMetadata :: MetaData -> Handler Acknowledgement
checkVoucherMetadata metadata =
@@ -163,23 +169,26 @@ charge d key (Charges token voucher amount currency) = do
else throwError voucherCodeMismatch
_ -> throwError voucherCodeNotFound
- unsupportedCurrency =
- err400
- { errBody = "Invalid currency specified"
- }
- voucherCodeNotFound =
- err400
- { errBody = "Voucher code not found"
- }
- voucherCodeMismatch =
- err500
- { errBody = "Voucher code mismatch"
- }
- stripeChargeFailed =
- err400
- { errBody = "Stripe charge didn't succeed"
- }
- voucherAlreadyPaid =
- err400
- { errBody = "Payment for voucher already supplied"
+ voucherCodeMismatch = jsonErr 500 "Voucher code mismatch"
+ unsupportedCurrency = jsonErr 400 "Invalid currency specified"
+ voucherCodeNotFound = jsonErr 400 "Voucher code not found"
+ stripeChargeFailed = jsonErr 400 "Stripe charge didn't succeed"
+ voucherAlreadyPaid = jsonErr 400 "Payment for voucher already supplied"
+
+ jsonErr httpCode reason = ServerError
+ { errHTTPCode = httpCode
+ , errReasonPhrase = ""
+ , errBody = encode $ Failure reason
+ , errHeaders = [("content-type", "application/json")]
}
+
+
+data Failure = Failure Text
+ deriving (Show, Eq)
+
+
+instance ToJSON Failure where
+ toJSON (Failure reason) = object
+ [ "success" .= False
+ , "reason" .= reason
+ ]
diff --git a/test/Persistence.hs b/test/Persistence.hs
index 794e9ef..f425e2f 100644
--- a/test/Persistence.hs
+++ b/test/Persistence.hs
@@ -98,7 +98,7 @@ makeVoucherPaymentTests label makeDatabase =
second <- redeem (Text.cons 'a' $ Text.tail fingerprint)
assertEqual "redeeming paid voucher" (Right ()) first
assertEqual "re-redeeming paid voucher" (Left AlreadyRedeemed) second
- , testCase "pay with error" $ do
+ , testCase "pay with exception" $ do
db <- makeDatabase
payResult <- try $ payForVoucher db voucher failPayment
assertEqual "failing a payment for a voucher" (Left ArbitraryException) payResult
--
GitLab