From 6dc390aa3efbca183f64ba8e99ae01fabccc6c3a Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Wed, 2 Jun 2021 09:32:49 -0400
Subject: [PATCH] Constrain charges to USD in the correct amount
---
PaymentServer.cabal | 2 +
nix/PaymentServer.nix | 13 +++--
src/PaymentServer/Processors/Stripe.hs | 32 +++++++----
test/Spec.hs | 2 +
test/Stripe.hs | 80 ++++++++++++++++++++++++++
5 files changed, 113 insertions(+), 16 deletions(-)
create mode 100644 test/Stripe.hs
diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index c85cb5a..32a86db 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -73,10 +73,12 @@ test-suite PaymentServer-tests
main-is: Spec.hs
other-modules: Persistence
, Metrics
+ , Stripe
, FakeStripe
build-depends: base
, bytestring
, text
+ , transformers
, raw-strings-qq
, time
, tasty
diff --git a/nix/PaymentServer.nix b/nix/PaymentServer.nix
index a8df27a..d4e81b5 100644
--- a/nix/PaymentServer.nix
+++ b/nix/PaymentServer.nix
@@ -57,10 +57,10 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
"library" = {
depends = [
(hsPkgs."base" or (buildDepError "base"))
- (hsPkgs."bytestring" or (buildDepError "bytestring"))
- (hsPkgs."utf8-string" or (buildDepError "utf8-string"))
(hsPkgs."optparse-applicative" or (buildDepError "optparse-applicative"))
(hsPkgs."aeson" or (buildDepError "aeson"))
+ (hsPkgs."bytestring" or (buildDepError "bytestring"))
+ (hsPkgs."utf8-string" or (buildDepError "utf8-string"))
(hsPkgs."servant" or (buildDepError "servant"))
(hsPkgs."servant-server" or (buildDepError "servant-server"))
(hsPkgs."http-types" or (buildDepError "http-types"))
@@ -70,8 +70,8 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
(hsPkgs."data-default" or (buildDepError "data-default"))
(hsPkgs."warp" or (buildDepError "warp"))
(hsPkgs."warp-tls" or (buildDepError "warp-tls"))
- (hsPkgs."stripe-core" or (buildDepError "stripe-core"))
(hsPkgs."stripe-haskell" or (buildDepError "stripe-haskell"))
+ (hsPkgs."stripe-core" or (buildDepError "stripe-core"))
(hsPkgs."text" or (buildDepError "text"))
(hsPkgs."containers" or (buildDepError "containers"))
(hsPkgs."cryptonite" or (buildDepError "cryptonite"))
@@ -105,6 +105,9 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
(hsPkgs."base" or (buildDepError "base"))
(hsPkgs."bytestring" or (buildDepError "bytestring"))
(hsPkgs."text" or (buildDepError "text"))
+ (hsPkgs."transformers" or (buildDepError "transformers"))
+ (hsPkgs."raw-strings-qq" or (buildDepError "raw-strings-qq"))
+ (hsPkgs."time" or (buildDepError "time"))
(hsPkgs."tasty" or (buildDepError "tasty"))
(hsPkgs."tasty-hunit" or (buildDepError "tasty-hunit"))
(hsPkgs."directory" or (buildDepError "directory"))
@@ -113,6 +116,8 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
(hsPkgs."http-types" or (buildDepError "http-types"))
(hsPkgs."wai" or (buildDepError "wai"))
(hsPkgs."wai-extra" or (buildDepError "wai-extra"))
+ (hsPkgs."warp" or (buildDepError "warp"))
+ (hsPkgs."http-types" or (buildDepError "http-types"))
(hsPkgs."servant-server" or (buildDepError "servant-server"))
(hsPkgs."prometheus-client" or (buildDepError "prometheus-client"))
(hsPkgs."stripe-core" or (buildDepError "stripe-core"))
@@ -121,4 +126,4 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
};
};
};
- } // rec { src = (pkgs.lib).mkDefault ../.; }
+ } // rec { src = (pkgs.lib).mkDefault .././.; }
\ No newline at end of file
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
index dca6457..2c4c7f8 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -5,8 +5,11 @@
module PaymentServer.Processors.Stripe
( StripeAPI
+ , Charges(Charges)
+ , Acknowledgement(Ok)
, stripeServer
, getVoucher
+ , charge
) where
import Control.Monad.IO.Class
@@ -50,7 +53,7 @@ import Web.Stripe.Error
import Web.Stripe.Types
( Charge(Charge, chargeId)
, MetaData(MetaData)
- , Currency
+ , Currency(USD)
)
import Web.Stripe.Charge
( createCharge
@@ -74,7 +77,7 @@ import PaymentServer.Persistence
, ProcessorResult
)
-data Acknowledgement = Ok
+data Acknowledgement = Ok deriving (Eq, Show)
instance ToJSON Acknowledgement where
toJSON Ok = object
@@ -149,8 +152,8 @@ withSuccessFailureMetrics attemptCount successCount op = do
-- | call the stripe Charge API (with token, voucher in metadata, amount, currency etc
-- 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 amount currency) = do
- result <- liftIO ((payForVoucher d voucher (completeStripeCharge currency)) :: IO ProcessorResult)
+charge stripeConfig d (Charges token voucher 650 USD) = do
+ result <- liftIO ((payForVoucher d voucher (completeStripeCharge USD)) :: IO ProcessorResult)
case result of
Left AlreadyPaid ->
throwError voucherAlreadyPaid
@@ -171,7 +174,7 @@ charge stripeConfig d (Charges token voucher amount currency) = do
return . Right $ chargeId
where
charge =
- createCharge (Amount amount) currency
+ createCharge (Amount 650) currency
-&- tokenId
-&- MetaData [("Voucher", voucher)]
@@ -199,13 +202,18 @@ charge stripeConfig d (Charges token voucher amount currency) = do
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")]
- }
-
+-- The wrong currency
+charge _ _ (Charges _ _ 650 _) = throwError (jsonErr 400 "Unsupported currency")
+-- The wrong amount
+charge _ _ (Charges _ _ _ USD) = throwError (jsonErr 400 "Incorrect charge amount")
+
+jsonErr :: Int -> Text -> ServerError
+jsonErr httpCode reason = ServerError
+ { errHTTPCode = httpCode
+ , errReasonPhrase = ""
+ , errBody = encode $ Failure reason
+ , errHeaders = [("content-type", "application/json")]
+ }
data Failure = Failure Text
deriving (Show, Eq)
diff --git a/test/Spec.hs b/test/Spec.hs
index e52ca13..d52d0af 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -12,11 +12,13 @@ import Test.Tasty
import qualified Persistence
import qualified Metrics
+import qualified Stripe
tests :: TestTree
tests = testGroup "Tests"
[ Persistence.tests
, Metrics.tests
+ , Stripe.tests
]
main = defaultMain tests
diff --git a/test/Stripe.hs b/test/Stripe.hs
new file mode 100644
index 0000000..49b2a34
--- /dev/null
+++ b/test/Stripe.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Tests related to PaymentServer.Processors.Stripe.
+
+module Stripe
+ ( tests
+ ) where
+
+import Test.Tasty
+ ( TestTree
+ , testGroup
+ )
+import Test.Tasty.HUnit
+ ( testCase
+ , assertEqual
+ )
+
+
+import Control.Monad.Trans.Except
+ ( runExceptT
+ )
+
+import Servant.Server
+ ( Handler(runHandler')
+ , ServerError(ServerError)
+ )
+
+import Web.Stripe.Types
+ ( Currency(USD, AED)
+ )
+
+import PaymentServer.Persistence
+ ( memory
+ )
+
+import PaymentServer.Processors.Stripe
+ ( Charges(Charges)
+ , Acknowledgement(Ok)
+ , charge
+
+ )
+
+import FakeStripe
+ ( withFakeStripe
+ , chargeOkay
+ )
+
+tests :: TestTree
+tests = testGroup "Stripe"
+ [ chargeTests
+ ]
+
+chargeTests :: TestTree
+chargeTests =
+ testGroup "Charges"
+ [ testCase "non-USD currency is rejected" $
+ withFakeStripe (return chargeOkay) $ \stripeConfig -> do
+ let amount = 650
+ let currency = AED
+ db <- memory
+ (Left (ServerError code _ _ _)) <- runExceptT . runHandler' $ charge stripeConfig db (Charges token voucher amount currency)
+ assertEqual "The result is an error" 400 code
+ , testCase "incorrect USD amount is rejected" $
+ withFakeStripe (return chargeOkay) $ \stripeConfig -> do
+ let amount = 649
+ let currency = USD
+ db <- memory
+ (Left (ServerError code _ _ _)) <- runExceptT . runHandler' $ charge stripeConfig db (Charges token voucher amount currency)
+ assertEqual "The result is an error" 400 code
+ , testCase "currect USD amount is accepted" $
+ withFakeStripe (return chargeOkay) $ \stripeConfig -> do
+ let amount = 650
+ let currency = USD
+ db <- memory
+ result <- runExceptT . runHandler' $ charge stripeConfig db (Charges token voucher amount currency)
+ assertEqual "The result is Ok" (Right Ok) result
+ ]
+ where
+ token = "foo"
+ voucher = "bar"
--
GitLab