diff --git a/src/PaymentServer/Persistence.hs b/src/PaymentServer/Persistence.hs index b13d79668f49bb31f8da165e05b199a92df24a00..324a8880e5ca8f6f2af12ee5e8435742f2c23acc 100644 --- a/src/PaymentServer/Persistence.hs +++ b/src/PaymentServer/Persistence.hs @@ -4,7 +4,7 @@ module PaymentServer.Persistence ( Voucher , Fingerprint , RedeemError(NotPaid, AlreadyRedeemed) - , PaymentError(AlreadyPaid) + , PaymentError(AlreadyPaid, PaymentFailed) , VoucherDatabase(payForVoucher, redeemVoucher) , VoucherDatabaseState(MemoryDB, SQLiteDB) , memory @@ -49,6 +49,8 @@ type Voucher = Text data PaymentError = -- | The voucher has already been paid for. AlreadyPaid + -- | The payment transaction has failed. + | PaymentFailed deriving (Show, Eq) instance Exception PaymentError diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs index 43f47f55879e68cf9b9161c65f8cca7ee45ff4a2..66efadcd22f88ecd4faf6221644d4849326242ae 100644 --- a/src/PaymentServer/Processors/Stripe.hs +++ b/src/PaymentServer/Processors/Stripe.hs @@ -17,6 +17,7 @@ import Control.Monad ) import Control.Exception ( try + , throwIO ) import Data.ByteString ( ByteString @@ -25,6 +26,7 @@ import Data.Text ( Text , unpack ) +import qualified Data.Map as Map import Text.Read ( readMaybe ) @@ -33,14 +35,16 @@ import Data.Aeson , FromJSON(parseJSON) , Value(Object) , object + , encode , (.:) + , (.=) ) import Servant ( Server , Handler , err400 , err500 - , ServerError(errHTTPCode, errBody) + , ServerError(ServerError, errHTTPCode, errBody, errHeaders, errReasonPhrase) , throwError ) import Servant.API @@ -80,7 +84,7 @@ import Web.Stripe import PaymentServer.Persistence ( Voucher , VoucherDatabase(payForVoucher) - , PaymentError(AlreadyPaid) + , PaymentError(AlreadyPaid, PaymentFailed) ) type StripeSecretKey = ByteString @@ -133,12 +137,10 @@ charge d key (Charges token voucher amount currency) = do case result of Left AlreadyPaid -> throwError voucherAlreadyPaid - Right stripeResult -> - case stripeResult of - Right Charge { chargeMetaData = metadata } -> - checkVoucherMetadata metadata - Left StripeError {} -> - throwError stripeChargeFailed + Left PaymentFailed -> + throwError stripeChargeFailed + Right Charge { chargeMetaData = metadata } -> + checkVoucherMetadata metadata where getCurrency :: Text -> Handler Currency getCurrency maybeCurrency = @@ -148,10 +150,14 @@ charge d key (Charges token voucher amount currency) = do config = StripeConfig (StripeKey key) Nothing tokenId = TokenId token - completeStripeCharge currency' = stripe config $ - createCharge (Amount amount) currency' - -&- tokenId - -&- MetaData [("Voucher", voucher)] + completeStripeCharge currency' = do + result <- stripe config $ + createCharge (Amount amount) currency' + -&- tokenId + -&- MetaData [("Voucher", voucher)] + case result of + Left StripeError {} -> throwIO PaymentFailed + Right result -> return result checkVoucherMetadata :: MetaData -> Handler Acknowledgement checkVoucherMetadata metadata = @@ -163,23 +169,26 @@ charge d key (Charges token voucher amount currency) = do else throwError voucherCodeMismatch _ -> throwError voucherCodeNotFound - unsupportedCurrency = - err400 - { errBody = "Invalid currency specified" - } - voucherCodeNotFound = - err400 - { errBody = "Voucher code not found" - } - voucherCodeMismatch = - err500 - { errBody = "Voucher code mismatch" - } - stripeChargeFailed = - err400 - { errBody = "Stripe charge didn't succeed" - } - voucherAlreadyPaid = - err400 - { errBody = "Payment for voucher already supplied" + 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" + + jsonErr httpCode reason = ServerError + { errHTTPCode = httpCode + , errReasonPhrase = "" + , errBody = encode $ Failure reason + , errHeaders = [("content-type", "application/json")] } + + +data Failure = Failure Text + deriving (Show, Eq) + + +instance ToJSON Failure where + toJSON (Failure reason) = object + [ "success" .= False + , "reason" .= reason + ] diff --git a/test/Persistence.hs b/test/Persistence.hs index 794e9efa32f61adb986a56b854c889cff5f33b1a..f425e2fd06738ca71739e91fbf8870038f8bd6b9 100644 --- a/test/Persistence.hs +++ b/test/Persistence.hs @@ -98,7 +98,7 @@ makeVoucherPaymentTests label makeDatabase = second <- redeem (Text.cons 'a' $ Text.tail fingerprint) assertEqual "redeeming paid voucher" (Right ()) first assertEqual "re-redeeming paid voucher" (Left AlreadyRedeemed) second - , testCase "pay with error" $ do + , testCase "pay with exception" $ do db <- makeDatabase payResult <- try $ payForVoucher db voucher failPayment assertEqual "failing a payment for a voucher" (Left ArbitraryException) payResult