diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs index 4dc1ad9fa2fbb7fe7a6326a7104f20c9c785efb3..5745ad60adc3c2d45316faeee25614955fa1adc4 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 diff --git a/test/Stripe.hs b/test/Stripe.hs index c938d5fc9b767f7603f47021c14d97ab954dacfe..5bd0abde0caec65de3cb5eb9bdc7f356e4647889 100644 --- a/test/Stripe.hs +++ b/test/Stripe.hs @@ -6,6 +6,10 @@ module Stripe ( tests ) where +import Prelude hiding + ( concat + ) + import Test.Tasty ( TestTree , testGroup @@ -16,6 +20,16 @@ import Test.Tasty.HUnit ) +import Data.Text.Lazy.Encoding + ( encodeUtf8 + ) +import Data.Text.Lazy + ( Text + , toStrict + , concat + ) + +import qualified Data.ByteString.Lazy as LBS import Control.Monad.IO.Class ( liftIO ) @@ -31,6 +45,7 @@ import Servant.Server import Web.Stripe.Types ( Currency(USD, AED) + , ChargeId(ChargeId) ) import Network.Wai.Test @@ -49,7 +64,9 @@ import Network.Wai ) import PaymentServer.Persistence - ( memory + ( Voucher + , memory + , payForVoucher ) import PaymentServer.Processors.Stripe @@ -97,6 +114,12 @@ corsTests = , testCase "a request with a valid charge in the body receives a CORS-enabled response" $ assertCORSHeader chargeOkay "POST" applicationJSON validChargeBytes + + , testCase "a request with an already-paid voucher receives a CORS-enabled response" $ do + let pay = return . Right . ChargeId $ "abc" + db <- memory + payForVoucher db (toStrict alreadyPaidVoucher') pay + assertCORSHeader' db chargeOkay "POST" applicationJSON (alreadyPaidVoucher alreadyPaidVoucher') ] where textPlain = [("content-type", "text/plain")] @@ -104,10 +127,19 @@ corsTests = validChargeBytes = "{\"token\": \"abcdef\", \"voucher\": \"lmnopqrst\", \"amount\": \"650\", \"currency\": \"USD\"}" invalidChargeBytes = "[1, 2, 3]" - assertCORSHeader stripeResponse method headers body = + alreadyPaidVoucher' :: Text + alreadyPaidVoucher' = "hello world" + + alreadyPaidVoucher :: Text -> LBS.ByteString + alreadyPaidVoucher voucher = encodeUtf8 $ concat ["{\"token\": \"abcdef\", \"voucher\": \"", voucher, "\", \"amount\": \"650\", \"currency\": \"USD\"}"] + + assertCORSHeader stripeResponse method headers body = do + db <- memory + assertCORSHeader' db stripeResponse method headers body + + assertCORSHeader' db stripeResponse method headers body = withFakeStripe (return stripeResponse) $ \stripeConfig -> do - db <- memory let origins = ["example.invalid"] let redemptionConfig = RedemptionConfig 16 1024 trivialIssue let app = paymentServerApp origins stripeConfig redemptionConfig db