From 7a0d14354c20bb76455d43fb4e50c0e8b8c07f5a Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Mon, 25 Nov 2019 12:51:33 -0500
Subject: [PATCH] Make sure to handle AlreadyPaid and turn it into a Servant
error
---
src/PaymentServer/Processors/Stripe.hs | 22 +++++++++++++++++-----
1 file changed, 17 insertions(+), 5 deletions(-)
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
index bee378c..43f47f5 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -15,6 +15,9 @@ import Control.Monad.IO.Class
import Control.Monad
( mzero
)
+import Control.Exception
+ ( try
+ )
import Data.ByteString
( ByteString
)
@@ -77,6 +80,7 @@ import Web.Stripe
import PaymentServer.Persistence
( Voucher
, VoucherDatabase(payForVoucher)
+ , PaymentError(AlreadyPaid)
)
type StripeSecretKey = ByteString
@@ -125,12 +129,16 @@ instance FromJSON Charges where
charge :: VoucherDatabase d => d -> StripeSecretKey -> Charges -> Handler Acknowledgement
charge d key (Charges token voucher amount currency) = do
currency' <- getCurrency currency
- result <- liftIO $ payForVoucher d voucher (completeStripeCharge currency')
+ result <- liftIO (try (payForVoucher d voucher (completeStripeCharge currency')))
case result of
- Right Charge { chargeMetaData = metadata } ->
- checkVoucherMetadata metadata
- Left StripeError {} ->
- throwError stripeChargeFailed
+ Left AlreadyPaid ->
+ throwError voucherAlreadyPaid
+ Right stripeResult ->
+ case stripeResult of
+ Right Charge { chargeMetaData = metadata } ->
+ checkVoucherMetadata metadata
+ Left StripeError {} ->
+ throwError stripeChargeFailed
where
getCurrency :: Text -> Handler Currency
getCurrency maybeCurrency =
@@ -171,3 +179,7 @@ charge d key (Charges token voucher amount currency) = do
err400
{ errBody = "Stripe charge didn't succeed"
}
+ voucherAlreadyPaid =
+ err400
+ { errBody = "Payment for voucher already supplied"
+ }
--
GitLab