From 2655f77c83b1ebd2479764eabd093e6ba0057403 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Mon, 28 Feb 2022 16:27:30 -0500
Subject: [PATCH] handle the IOException thrown by `payForVoucher`
`throwError voucherAlreadyPaid` above is a red herring. That codepath works
fine. It's just unreachable because `payForVoucher` never returns `Left
AlreadyPaid`. Instead, it does `throwIO AlreadyPaid`. Servant doesn't know
how to do anything good with `AlreadyPaid` (a `PaymentError` rather than a
`ServerError`) so it logs it and returns a 500 error to the client.
This change adds an exception handler to the `payForVoucher` call that
transforms all `PaymentError` exceptions into `Left e` values which `charge`
is already handling. `throwError` will eventually throw a `ServerError` with
correct details filled in for these.
---
src/PaymentServer/Processors/Stripe.hs | 15 ++++++++++++++-
1 file changed, 14 insertions(+), 1 deletion(-)
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
index 4dc1ad9..5745ad6 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module PaymentServer.Processors.Stripe
( StripeAPI
@@ -12,6 +13,9 @@ module PaymentServer.Processors.Stripe
, charge
) where
+import Control.Exception
+ ( catch
+ )
import Control.Monad.IO.Class
( liftIO
)
@@ -153,16 +157,25 @@ withSuccessFailureMetrics attemptCount successCount op = do
-- and if the Charge is okay, then set the voucher as "paid" in the database.
charge :: VoucherDatabase d => StripeConfig -> d -> Charges -> Handler Acknowledgement
charge stripeConfig d (Charges token voucher 650 USD) = do
- result <- liftIO ((payForVoucher d voucher (completeStripeCharge USD)) :: IO ProcessorResult)
+ result <- liftIO payForVoucher'
case result of
Left AlreadyPaid ->
throwError voucherAlreadyPaid
+
Left (PaymentFailed (StripeError { errorType = errorType, errorMsg = msg })) -> do
liftIO $ print "Stripe createCharge failed:"
liftIO $ print msg
throwError . errorForStripeType $ errorType
+
Right chargeId -> return Ok
+
where
+ payForVoucher' :: IO ProcessorResult
+ payForVoucher' = do
+ payForVoucher d voucher (completeStripeCharge USD) `catch` (
+ \(e :: PaymentError) -> return $ Left e
+ )
+
tokenId = TokenId token
completeStripeCharge :: Currency -> IO ProcessorResult
completeStripeCharge currency = do
--
GitLab