diff --git a/src/PaymentServer/Persistence.hs b/src/PaymentServer/Persistence.hs index db4525437293c258f97b1dec49c7b0b66fabefe1..f4ae39fc91d8ce877fa0b68f9bfd057d528c99bf 100644 --- a/src/PaymentServer/Persistence.hs +++ b/src/PaymentServer/Persistence.hs @@ -44,6 +44,10 @@ import Data.Maybe ( listToMaybe ) +import Web.Stripe.Error + ( StripeError + ) + -- | A voucher is a unique identifier which can be associated with a payment. -- A paid voucher can be redeemed for ZKAPs which can themselves be exchanged -- for service elsewhere with better privacy-preserving properties than the @@ -55,11 +59,16 @@ data PaymentError = -- | The voucher has already been paid for. AlreadyPaid -- | The payment transaction has failed. - | PaymentFailed - deriving (Show, Eq) + | PaymentFailed StripeError + deriving (Show) instance Exception PaymentError +instance Eq PaymentError where + AlreadyPaid == AlreadyPaid = True + PaymentFailed self == PaymentFailed other = show self == show other + self == other = False + -- | Reasons that a voucher cannot be redeemed. data RedeemError = -- | The voucher has not been paid for. diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs index 45b5af38613cc4cafff878ba2a4ae79e2097ff2d..c279b4bbaf7f6601f55835dceb23a5b95f2de647 100644 --- a/src/PaymentServer/Processors/Stripe.hs +++ b/src/PaymentServer/Processors/Stripe.hs @@ -14,10 +14,6 @@ import Control.Monad.IO.Class import Control.Monad ( mzero ) -import Control.Exception - ( try - , throwIO - ) import Data.Text ( Text , unpack @@ -46,6 +42,10 @@ import Servant.API , Post , (:>) ) +import Web.Stripe.Error + ( StripeError(StripeError, errorType, errorMsg) + , StripeErrorType(InvalidRequest, APIError, ConnectionFailure, CardError) + ) import Web.Stripe.Types ( Charge(Charge, chargeMetaData) , MetaData(MetaData) @@ -149,12 +149,14 @@ withSuccessFailureMetrics attemptCount successCount op = do charge :: VoucherDatabase d => StripeConfig -> d -> Charges -> Handler Acknowledgement charge stripeConfig d (Charges token voucher amount currency) = do currency' <- getCurrency currency - result <- liftIO (try (payForVoucher d voucher (completeStripeCharge currency'))) + result <- liftIO ((payForVoucher d voucher (completeStripeCharge currency')) :: IO (Either PaymentError Charge)) case result of Left AlreadyPaid -> throwError voucherAlreadyPaid - Left PaymentFailed -> - throwError stripeChargeFailed + Left (PaymentFailed (StripeError { errorType = errorType, errorMsg = msg })) -> do + liftIO $ print "Stripe createCharge failed:" + liftIO $ print msg + throwError . errorForStripeType $ errorType Right Charge { chargeMetaData = metadata } -> checkVoucherMetadata metadata where @@ -165,17 +167,19 @@ charge stripeConfig d (Charges token voucher amount currency) = do Nothing -> throwError unsupportedCurrency tokenId = TokenId token + completeStripeCharge :: Currency -> IO (Either PaymentError Charge) completeStripeCharge currency' = do - result <- stripe stripeConfig $ - createCharge (Amount amount) currency' - -&- tokenId - -&- MetaData [("Voucher", voucher)] + result <- (stripe stripeConfig charge) :: IO (Either StripeError Charge) case result of - Left err -> do - print "Stripe createCharge failed:" - print err - throwIO PaymentFailed - Right result -> return result + Left any -> + return . Left $ PaymentFailed any + Right any -> + return . Right $ any + where + charge = + createCharge (Amount amount) currency' + -&- tokenId + -&- MetaData [("Voucher", voucher)] checkVoucherMetadata :: MetaData -> Handler Acknowledgement checkVoucherMetadata metadata = @@ -187,11 +191,31 @@ charge stripeConfig d (Charges token voucher amount currency) = do else throwError voucherCodeMismatch _ -> throwError voucherCodeNotFound + -- "Invalid request errors arise when your request has invalid parameters." + errorForStripeType InvalidRequest = internalServerError + + -- "API errors cover any other type of problem (e.g., a temporary + -- problem with Stripe's servers), and are extremely uncommon." + errorForStripeType APIError = serviceUnavailable + + -- "Failure to connect to Stripe's API." + errorForStripeType ConnectionFailure = serviceUnavailable + + -- "Card errors are the most common type of error you should expect to + -- handle. They result when the user enters a card that can't be charged + -- for some reason." + errorForStripeType CardError = stripeChargeFailed + + -- Something else we don't know about... + errorForStripeType _ = internalServerError + + serviceUnavailable = jsonErr 503 "Service temporarily unavailable" + internalServerError = jsonErr 500 "Internal server error" 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" + stripeChargeFailed = jsonErr 400 "Stripe charge didn't succeed" + voucherAlreadyPaid = jsonErr 400 "Payment for voucher already supplied" jsonErr httpCode reason = ServerError { errHTTPCode = httpCode