diff --git a/.circleci/config.yml b/.circleci/config.yml index 38c6cfd..9af1876 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -83,7 +83,10 @@ jobs: --option extra-trusted-public-keys "${TRUSTED_PUBLIC_KEYS}" \ -j 4 \ ./nix/ \ - -A PaymentServer.components.exes."PaymentServer-exe" + -A PaymentServer.components.exes."PaymentServer-exe" \ + -A PaymentServer.components.exes."PaymentServer-generate-key" \ + -A PaymentServer.components.exes."PaymentServer-get-public-key" \ + -A PaymentServer.components.exes."PaymentServer-complete-payment" - run: name: "Building Tests" diff --git a/PaymentServer.cabal b/PaymentServer.cabal index 825c79e..e72b908 100644 --- a/PaymentServer.cabal +++ b/PaymentServer.cabal @@ -28,17 +28,21 @@ library , aeson , bytestring , utf8-string + , base16-bytestring , servant , servant-server , http-types + , http-media , wai , wai-extra , wai-cors , data-default , warp , warp-tls + , stripe-concepts , stripe-haskell , stripe-core + , stripe-signature , text , containers , cryptonite @@ -78,6 +82,22 @@ executable PaymentServer-get-public-key , PaymentServer default-language: Haskell2010 +executable PaymentServer-complete-payment + hs-source-dirs: complete-payment + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports + build-depends: base + , time + , text + , bytestring + , optparse-applicative + , unix-compat + , http-client + , stripe-concepts + , raw-strings-qq + , PaymentServer + default-language: Haskell2010 + test-suite PaymentServer-tests type: exitcode-stdio-1.0 hs-source-dirs: test @@ -91,6 +111,8 @@ test-suite PaymentServer-tests build-depends: aeson , base , bytestring + , stripe-signature + , stripe-concepts , text , transformers , raw-strings-qq diff --git a/README.rst b/README.rst index 03d02ad..8c9ddab 100644 --- a/README.rst +++ b/README.rst @@ -14,7 +14,11 @@ Get all the build dependencies with nix:: $ nix-shell PrivateStorageio/shell.nix # Might be needed depending on your system, see #88 $ nix-shell PaymentServer/shell.nix -Build using Stack:: +Build using Nix:: + + $ nix-build nix/ -A PaymentServer.components.exes.PaymentServer-exe -o exe + +Or using Stack:: $ stack build @@ -24,15 +28,19 @@ Testing You can perform manual integration testing against Stripe. First, run the server:: - $ stack run + $ ./exe/bin/PaymentServer-exe [arguments] -Then create a testing charge:: +Or with stack:: - $ curl \ - http://:8081/v1/stripe/charge \ - -X POST \ - -H 'content-type: application/json' \ - --data '{ "token":"tok_visa", "voucher":"abcdefg", "amount":"650", "currency":"USD" }' + $ stack run -- [arguments] + +Then report that payment has been received for a given voucher: + + $ stack run -- \ + PaymentServer-complete-payment \ + --voucher abcdefg \ + --server-url http://localhost:8081/ \ + --webhook-secret-path ../stripe.webhook-secret The PaymentServer marks the voucher as paid in its database. Then redeem the vouncher for tokens:: @@ -42,3 +50,21 @@ Then redeem the vouncher for tokens:: -X POST \ -H 'content-type: application/json' \ --data '{ "redeemVoucher": "abcdefg", "redeemTokens":[]}' + +Stripe Integration +------------------ + +PaymentServer listens for Stripe events at a "webhook" endpoint. +The endpoint is at ``/v1/stripe/webhook``. +It handles only ``checkout.session.completed`` events. +These events must include a voucher in the ``client_reference_id`` field. +A voucher so referenced will be marked as paid when this event is processed. + +The webhook must be correctly configured in the associated Stripe account. +One way to configure it is with a request like:: + + curl \ + https://api.stripe.com/v1/webhook_endpoints \ + -u sk_test_yourkey: \ + -d url="https://serveraddress/v1/stripe/webhook" \ + -d "enabled_events[]"="checkout.session.completed" diff --git a/complete-payment/Main.hs b/complete-payment/Main.hs new file mode 100644 index 0000000..b41a3a3 --- /dev/null +++ b/complete-payment/Main.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main + ( main + ) where + +import Text.Printf + ( printf + ) + +import Data.Text + ( Text + , pack + , unpack + ) + +import GHC.Natural + ( naturalFromInteger + ) + +import Data.Text.Encoding + ( encodeUtf8 + ) + +import Data.ByteString + ( ByteString + , readFile + ) +import Data.ByteString.Char8 + ( strip + ) + +import Text.RawString.QQ + ( r + ) + +import Options.Applicative + ( Parser + , ParserInfo + , strOption + , option + , auto + , long + , help + , showDefault + , value + , info + , (<**>) + , helper + , fullDesc + , progDesc + , header + , execParser + ) + +import Network.HTTP.Client + ( Request(method, requestBody, requestHeaders, path) + , RequestBody(RequestBodyBS) + , parseRequest + , newManager + , defaultManagerSettings + , httpLbs + , responseStatus + , responseBody + ) + +import Data.Time.Clock.POSIX + ( getPOSIXTime + ) + +import Stripe.Concepts + ( WebhookSecretKey(WebhookSecretKey) + ) + +import PaymentServer.Processors.Stripe + ( stripeSignature + ) + +data Config = Config + { configServerURL :: Text + , configVoucher :: Text + , configWebhookSecretPath :: FilePath + } + +config :: Parser Config +config = Config + <$> strOption + ( long "server-url" + <> help "The root URL of the PaymentServer on which to complete the payment." + <> showDefault + <> value "http://localhost:8000/" + ) + <*> strOption + ( long "voucher" + <> help "The voucher for which to complete payment." + ) + <*> strOption + ( long "webhook-secret-path" + <> help "The path to a file containing the webhook secret to use to sign the request." + ) + +options :: ParserInfo Config +options = info (config <**> helper) + ( fullDesc + <> progDesc "" + <> header "" + ) + +-- Construct the request body for a `checkout.session.complete` event +-- containing the given voucher. +completePaymentBody :: Text -> ByteString +completePaymentBody = + encodeUtf8 . pack . printf template + where + template = [r| +{ + "id": "evt_1LxcsdBHXBAMm9bPSq6UWAZe", + "object": "event", + "api_version": "2019-11-05", + "created": 1666903247, + "data": { + "object": { + "id": "cs_test_a1kWLWGoXZPa6ywyVnuib8DPA3BqXCWZX5UEjLfKh7gLjdZy2LD3F5mEp3", + "object": "checkout.session", + "after_expiration": null, + "allow_promotion_codes": null, + "amount_subtotal": 3000, + "amount_total": 3000, + "automatic_tax": { + "enabled": false, + "status": null + }, + "billing_address_collection": null, + "cancel_url": "https://httpbin.org/post", + "client_reference_id": "%s", + "consent": null, + "consent_collection": null, + "created": 1666903243, + "currency": "usd", + "customer": "cus_Mh0u62xtelUehD", + "customer_creation": "always", + "customer_details": { + "address": { + "city": null, + "country": null, + "line1": null, + "line2": null, + "postal_code": null, + "state": null + }, + "email": "stripe@example.com", + "name": null, + "phone": null, + "tax_exempt": "none", + "tax_ids": [ + + ] + }, + "customer_email": null, + "display_items": [ + { + "amount": 1500, + "currency": "usd", + "custom": { + "description": "comfortable cotton t-shirt", + "images": null, + "name": "t-shirt" + }, + "quantity": 2, + "type": "custom" + } + ], + "expires_at": 1666989643, + "livemode": false, + "locale": null, + "metadata": { + }, + "mode": "payment", + "payment_intent": "pi_3LxcsZBHXBAMm9bP1daBGoPV", + "payment_link": null, + "payment_method_collection": "always", + "payment_method_options": { + }, + "payment_method_types": [ + "card" + ], + "payment_status": "paid", + "phone_number_collection": { + "enabled": false + }, + "recovered_from": null, + "setup_intent": null, + "shipping": null, + "shipping_address_collection": null, + "shipping_options": [ + + ], + "shipping_rate": null, + "status": "complete", + "submit_type": null, + "subscription": null, + "success_url": "https://httpbin.org/post", + "total_details": { + "amount_discount": 0, + "amount_shipping": 0, + "amount_tax": 0 + }, + "url": null + } + }, + "livemode": false, + "pending_webhooks": 2, + "request": { + "id": null, + "idempotency_key": null + }, + "type": "checkout.session.completed" +} +|] + + +main :: IO () +main = do + Config + { configServerURL + , configVoucher + , configWebhookSecretPath + } <- execParser options + + let body = completePaymentBody configVoucher + webhookSecret <- WebhookSecretKey . strip <$> Data.ByteString.readFile configWebhookSecretPath + now <- naturalFromInteger . truncate <$> getPOSIXTime + + req <- parseRequest . unpack $ configServerURL + let req' = req + { method = "POST" + , path = "/v1/stripe/webhook" + , requestBody = RequestBodyBS body + , requestHeaders = + [ ( "Stripe-Signature" + , stripeSignature webhookSecret now body + ) + , ( "Content-Type" + , "application/json; charset=utf-8" + ) + ] + } + + manager <- newManager defaultManagerSettings + response <- httpLbs req' manager + print ((responseStatus response), (responseBody response)) diff --git a/nix/materialized.paymentserver/.stack-to-nix.cache b/nix/materialized.paymentserver/.stack-to-nix.cache index f0ac606..b3607b1 100644 --- a/nix/materialized.paymentserver/.stack-to-nix.cache +++ b/nix/materialized.paymentserver/.stack-to-nix.cache @@ -1 +1,2 @@ https://github.com/PrivateStorageio/servant-prometheus.git 622eb77cb08c5f13729173b8feb123a6700ff91f . 09dcwj5ac2x2ilb4a0rai3qhl875vvvjr12af5plpz86faga3lnz servant-prometheus .stack-to-nix.cache.0 +https://github.com/PrivateStorageio/stripe.git 6c340eea6dc23c4245762b937b9701a40761a5c9 stripe-core 1bhw1dcmr2fiphxjvjl80qwg1yrw1ifldm4w4s11q3z0a6yphl5r stripe-core .stack-to-nix.cache.1 diff --git a/nix/materialized.paymentserver/.stack-to-nix.cache.1 b/nix/materialized.paymentserver/.stack-to-nix.cache.1 new file mode 100644 index 0000000..b1ccce5 --- /dev/null +++ b/nix/materialized.paymentserver/.stack-to-nix.cache.1 @@ -0,0 +1,42 @@ +{ system + , compiler + , flags + , pkgs + , hsPkgs + , pkgconfPkgs + , errorHandler + , config + , ... }: + { + flags = {}; + package = { + specVersion = "1.10"; + identifier = { name = "stripe-core"; version = "2.6.2"; }; + license = "MIT"; + copyright = "Copyright (c) 2016 David M. Johnson, Jeremy Shaw"; + maintainer = "djohnson.m@gmail.com"; + author = "David Johnson, Jeremy Shaw"; + homepage = "https://github.com/dmjio/stripe-haskell"; + url = ""; + synopsis = "Stripe API for Haskell - Pure Core"; + description = "\n<>\n\n[Pure API Wrapper]\n`stripe-core` provides a complete binding to the Stripe API. `stripe-core` provides pure wrappers around all the Stripe API objects and methods. `stripe-core` is pure and is not tied to any particular HTTP client library. End users will typically install the `stripe-haskell` package which pulls in the `stripe-http-client` library to obtain a complete set of functionality."; + buildType = "Simple"; + }; + components = { + "library" = { + depends = [ + (hsPkgs."aeson" or (errorHandler.buildDepError "aeson")) + (hsPkgs."base" or (errorHandler.buildDepError "base")) + (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) + (hsPkgs."mtl" or (errorHandler.buildDepError "mtl")) + (hsPkgs."text" or (errorHandler.buildDepError "text")) + (hsPkgs."time" or (errorHandler.buildDepError "time")) + (hsPkgs."transformers" or (errorHandler.buildDepError "transformers")) + (hsPkgs."unordered-containers" or (errorHandler.buildDepError "unordered-containers")) + ]; + buildable = true; + }; + }; + } // rec { + src = (pkgs.lib).mkDefault /nix/store/5np9iplqv5nqcawrwlng38ak0l847nid-stripe-6c340ee/stripe-core; + } diff --git a/nix/materialized.paymentserver/PaymentServer.nix b/nix/materialized.paymentserver/PaymentServer.nix index 5c7f3c0..b884df1 100644 --- a/nix/materialized.paymentserver/PaymentServer.nix +++ b/nix/materialized.paymentserver/PaymentServer.nix @@ -38,17 +38,21 @@ (hsPkgs."aeson" or (errorHandler.buildDepError "aeson")) (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) (hsPkgs."utf8-string" or (errorHandler.buildDepError "utf8-string")) + (hsPkgs."base16-bytestring" or (errorHandler.buildDepError "base16-bytestring")) (hsPkgs."servant" or (errorHandler.buildDepError "servant")) (hsPkgs."servant-server" or (errorHandler.buildDepError "servant-server")) (hsPkgs."http-types" or (errorHandler.buildDepError "http-types")) + (hsPkgs."http-media" or (errorHandler.buildDepError "http-media")) (hsPkgs."wai" or (errorHandler.buildDepError "wai")) (hsPkgs."wai-extra" or (errorHandler.buildDepError "wai-extra")) (hsPkgs."wai-cors" or (errorHandler.buildDepError "wai-cors")) (hsPkgs."data-default" or (errorHandler.buildDepError "data-default")) (hsPkgs."warp" or (errorHandler.buildDepError "warp")) (hsPkgs."warp-tls" or (errorHandler.buildDepError "warp-tls")) + (hsPkgs."stripe-concepts" or (errorHandler.buildDepError "stripe-concepts")) (hsPkgs."stripe-haskell" or (errorHandler.buildDepError "stripe-haskell")) (hsPkgs."stripe-core" or (errorHandler.buildDepError "stripe-core")) + (hsPkgs."stripe-signature" or (errorHandler.buildDepError "stripe-signature")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."containers" or (errorHandler.buildDepError "containers")) (hsPkgs."cryptonite" or (errorHandler.buildDepError "cryptonite")) @@ -105,6 +109,23 @@ hsSourceDirs = [ "get-public-key" ]; mainPath = [ "Main.hs" ]; }; + "PaymentServer-complete-payment" = { + depends = [ + (hsPkgs."base" or (errorHandler.buildDepError "base")) + (hsPkgs."time" or (errorHandler.buildDepError "time")) + (hsPkgs."text" or (errorHandler.buildDepError "text")) + (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) + (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) + (hsPkgs."unix-compat" or (errorHandler.buildDepError "unix-compat")) + (hsPkgs."http-client" or (errorHandler.buildDepError "http-client")) + (hsPkgs."stripe-concepts" or (errorHandler.buildDepError "stripe-concepts")) + (hsPkgs."raw-strings-qq" or (errorHandler.buildDepError "raw-strings-qq")) + (hsPkgs."PaymentServer" or (errorHandler.buildDepError "PaymentServer")) + ]; + buildable = true; + hsSourceDirs = [ "complete-payment" ]; + mainPath = [ "Main.hs" ]; + }; }; tests = { "PaymentServer-tests" = { @@ -112,6 +133,8 @@ (hsPkgs."aeson" or (errorHandler.buildDepError "aeson")) (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) + (hsPkgs."stripe-signature" or (errorHandler.buildDepError "stripe-signature")) + (hsPkgs."stripe-concepts" or (errorHandler.buildDepError "stripe-concepts")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."transformers" or (errorHandler.buildDepError "transformers")) (hsPkgs."raw-strings-qq" or (errorHandler.buildDepError "raw-strings-qq")) diff --git a/nix/materialized.paymentserver/default.nix b/nix/materialized.paymentserver/default.nix index dcaf7f6..dd74a3c 100644 --- a/nix/materialized.paymentserver/default.nix +++ b/nix/materialized.paymentserver/default.nix @@ -2,8 +2,11 @@ extras = hackage: { packages = { + "network" = (((hackage.network)."3.1.2.7").revisions).default; + "stripe-signature" = (((hackage.stripe-signature)."1.0.0.14").revisions).default; PaymentServer = ./PaymentServer.nix; servant-prometheus = ./.stack-to-nix.cache.0; + stripe-core = ./.stack-to-nix.cache.1; }; }; resolver = "lts-18.28"; diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs index e5d4ef7..22c73bc 100644 --- a/src/PaymentServer/Main.hs +++ b/src/PaymentServer/Main.hs @@ -55,6 +55,10 @@ import Network.Wai.Middleware.RequestLogger , mkRequestLogger ) +import Stripe.Concepts + ( WebhookSecretKey(WebhookSecretKey) + ) + import Web.Stripe.Client ( Protocol(HTTPS) , StripeConfig(StripeConfig) @@ -71,6 +75,10 @@ import PaymentServer.Issuer , trivialIssue , ristrettoIssue ) +import PaymentServer.Processors.Stripe + ( WebhookConfig(WebhookConfig) + ) + import PaymentServer.Server ( RedemptionConfig(RedemptionConfig) , paymentServerApp @@ -105,6 +113,7 @@ import System.Exit import Data.Semigroup ((<>)) import qualified Data.Text.IO as TIO import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy.UTF8 as LBS data IssuerFlavor = @@ -125,6 +134,7 @@ data ServerConfig = ServerConfig , databasePath :: Maybe Text , endpoint :: Endpoint , stripeKeyPath :: FilePath + , stripeWebhookKeyPath :: FilePath , stripeEndpointUrl :: ByteString , stripeEndpointProtocol :: Protocol , stripeEndpointPort :: Int @@ -218,6 +228,9 @@ sample = ServerConfig ( long "stripe-key-path" <> help "Path to Stripe Secret key" ) <*> option str + ( long "stripe-webhook-key-path" + <> help "Path to Stripe Webhook signing key" ) + <*> option str ( long "stripe-endpoint-domain" <> help "The domain name for the Stripe API HTTP endpoint." <> value "api.stripe.com" @@ -311,11 +324,18 @@ getApp config = , stripeEndpointPort } = do - key <- B.readFile stripeKeyPath + key <- Char8.strip <$> B.readFile stripeKeyPath return $ StripeConfig (StripeKey key) (Just $ Stripe.Endpoint stripeEndpointUrl stripeEndpointProtocol stripeEndpointPort) + + webhookConfig ServerConfig + { stripeWebhookKeyPath + } = + do + webhookKey <- Char8.strip <$> B.readFile stripeWebhookKeyPath + return $ WebhookConfig (WebhookSecretKey webhookKey) in do issuer <- getIssuer config case issuer of @@ -330,10 +350,11 @@ getApp config = Right getDB -> do db <- getDB stripeConfig' <- stripeConfig config + webhookConfig' <- webhookConfig config let origins = corsOrigins config redemptionConfig = getRedemptionConfig config issuer - app = paymentServerApp origins stripeConfig' redemptionConfig db + app = paymentServerApp origins stripeConfig' webhookConfig' redemptionConfig db metricsMiddleware <- makeMetricsMiddleware logger <- mkRequestLogger (def { outputFormat = Detailed True}) return . logger . metricsMiddleware $ app diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs index be5a8ec..bf4ea67 100644 --- a/src/PaymentServer/Processors/Stripe.hs +++ b/src/PaymentServer/Processors/Stripe.hs @@ -3,19 +3,24 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} module PaymentServer.Processors.Stripe - ( StripeAPI + ( ChargesAPI + , WebhookAPI + , WebhookConfig(WebhookConfig) , Charges(Charges) , Acknowledgement(Ok) , Failure(Failure) - , stripeServer + , chargeServer + , webhookServer , getVoucher , charge + , stripeSignature ) where -import Prelude hiding - ( concat +import GHC.Natural + ( Natural ) import Control.Exception @@ -29,13 +34,11 @@ import Control.Monad ) import Data.Text ( Text - , unpack , concat - ) -import Text.Read - ( readMaybe + , pack ) +import qualified Network.HTTP.Media as M import Network.HTTP.Types ( Status(Status) , status400 @@ -43,16 +46,23 @@ import Network.HTTP.Types , status503 ) +import Data.ByteString (ByteString, concat) + +import Data.ByteString.Lazy (toStrict, fromStrict) + import Data.ByteString.UTF8 ( toString ) +import qualified Data.ByteString.Base16 as Base16 + import Data.Aeson ( ToJSON(toJSON) , FromJSON(parseJSON) , Value(Object) , object , encode + , eitherDecode , (.:) , (.=) ) @@ -63,17 +73,32 @@ import Servant , throwError ) import Servant.API - ( ReqBody + ( Header + , ReqBody , JSON + , OctetStream + , PlainText , Post + , Accept(contentType) + , MimeUnrender(mimeUnrender) , (:>) ) +import Web.Stripe.Event + ( Event(Event, eventId, eventType, eventData) + , EventId(EventId) + , EventType(ChargeSucceededEvent, CheckoutSessionCompleted, PaymentIntentCreated) + , EventData(ChargeEvent, CheckoutSessionEvent) + ) + +import Stripe.Signature (digest, natBytes, parseSig, isSigValid) + import Web.Stripe.Error ( StripeError(StripeError, errorType, errorMsg) , StripeErrorType(InvalidRequest, APIError, ConnectionFailure, CardError) ) import Web.Stripe.Types - ( Charge(Charge, chargeId) + ( Charge(Charge, chargeId, chargeMetaData) + , CheckoutSession(checkoutSessionClientReferenceId) , ChargeId , MetaData(MetaData) , Currency(USD) @@ -84,13 +109,18 @@ import Web.Stripe.Charge , TokenId(TokenId) ) import Web.Stripe.Client - ( StripeConfig + ( StripeConfig(StripeConfig, secretKey) + , StripeKey(StripeKey) ) import Web.Stripe ( stripe , (-&-) ) +import Stripe.Concepts + ( WebhookSecretKey + ) + import qualified Prometheus as P import PaymentServer.Persistence @@ -99,6 +129,8 @@ import PaymentServer.Persistence , PaymentError(AlreadyPaid, PaymentFailed) , ProcessorResult ) +import Data.Data (Typeable) +import Servant.API.ContentTypes (AcceptHeader(AcceptHeader)) data Acknowledgement = Ok deriving (Eq, Show) @@ -107,19 +139,85 @@ instance ToJSON Acknowledgement where [ "success" .= True ] -type StripeAPI = ChargesAPI +-- Represent configuration options for setting up the webhook endpoint for +-- receiving event notifications from Stripe. +data WebhookConfig = WebhookConfig + { webhookConfigKey :: WebhookSecretKey + } --- | getVoucher finds the metadata item with the key `"Voucher"` and returns +-- Create the value for the `Stripe-Signature` header item in a webhook request. +stripeSignature :: WebhookSecretKey -> Natural -> ByteString -> ByteString +stripeSignature key when what = Data.ByteString.concat + [ "t=" + , natBytes when + , "," + , "v1=" + , Base16.encode $ digest key when what + ] + +-- getVoucher finds the metadata item with the key `"Voucher"` and returns -- the corresponding value, or Nothing. -getVoucher :: MetaData -> Maybe Voucher -getVoucher (MetaData []) = Nothing -getVoucher (MetaData (("Voucher", value):xs)) = Just value -getVoucher (MetaData (x:xs)) = getVoucher (MetaData xs) - -stripeServer :: VoucherDatabase d => StripeConfig -> d -> Server StripeAPI -stripeServer stripeConfig d = +getVoucher :: Event -> Maybe Voucher +getVoucher Event{eventData=(CheckoutSessionEvent checkoutSession)} = + checkoutSessionClientReferenceId checkoutSession +getVoucher Event{eventData=(ChargeEvent charge)} = + voucherFromMetadata . chargeMetaData $ charge + where + voucherFromMetadata (MetaData []) = Nothing + voucherFromMetadata (MetaData (("Voucher", value):xs)) = Just value + voucherFromMetadata (MetaData (x:xs)) = voucherFromMetadata (MetaData xs) +getVoucher _ = Nothing + +chargeServer :: VoucherDatabase d => StripeConfig -> d -> Server ChargesAPI +chargeServer stripeConfig d = withSuccessFailureMetrics chargeAttempts chargeSuccesses . charge stripeConfig d +data UnparsedJSON deriving Typeable + +instance Accept UnparsedJSON where + -- We could also require charset=utf-8 on this but we think Stripe doesn't + -- actually include that in its requests. + contentType _ = "application" M.// "json" + +instance MimeUnrender UnparsedJSON ByteString where + mimeUnrender _ = Right . toStrict + +type WebhookAPI = "webhook" :> Header "Stripe-Signature" Text :> ReqBody '[UnparsedJSON] ByteString :> Post '[JSON] Acknowledgement + +-- | Process charge succeeded +webhookServer :: VoucherDatabase d => WebhookConfig -> d -> Maybe Text -> ByteString -> Handler Acknowledgement +webhookServer _ _ Nothing _ = throwError $ jsonErr status400 "missing signature" +webhookServer WebhookConfig { webhookConfigKey } d (Just signatureText) payload = + case parseSig signatureText of + Nothing -> throwError $ jsonErr status400 "malformed signature" + Just sig -> + -- We check the signature but we don't otherwise interpret the timestamp + -- it carries. In the future perhaps we should. + -- https://github.com/PrivateStorageio/PaymentServer/issues/129 + if isSigValid sig webhookConfigKey payload + then fundVoucher + else throwError $ jsonErr status400 "invalid signature" + where + fundVoucher = + case eitherDecode . fromStrict $ payload of + Left s -> throwError $ jsonErr status400 (pack s) + Right event@Event { eventType = CheckoutSessionCompleted } -> + case getVoucher event of + Nothing -> + -- TODO: Record the eventId somewhere. In all cases where we don't + -- associate the value of the charge with something in our system, we + -- probably need enough information to issue a refund. We're early + -- enough in the system here that refunds are possible and not even + -- particularly difficult. + return Ok + Just v -> do + -- TODO: What if it is a duplicate payment? payForVoucher + -- should be able to indicate error I guess. + _ <- liftIO . payForVoucher d v . return . Right $ () + return Ok + Right event@Event { eventType } -> + throwError . jsonErr status400 . pack $ "unsupported event type " ++ show eventType + -- | Browser facing API that takes token, voucher and a few other information -- and calls stripe charges API. If payment succeeds, then the voucher is stored -- in the voucher database. @@ -184,7 +282,7 @@ charge stripeConfig d (Charges token voucher 650 USD) = do Left (PaymentFailed (StripeError { errorType = errorType, errorMsg = msg })) -> do liftIO $ print "Stripe createCharge failed:" liftIO $ print msg - let err = errorForStripe errorType ( concat [ "Stripe charge didn't succeed: ", msg ]) + let err = errorForStripe errorType ( Data.Text.concat [ "Stripe charge didn't succeed: ", msg ]) throwError err Right _ -> return Ok diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs index 3c0c5ee..4115989 100644 --- a/src/PaymentServer/Server.hs +++ b/src/PaymentServer/Server.hs @@ -37,8 +37,11 @@ import Web.Stripe.Client ) import PaymentServer.Processors.Stripe - ( StripeAPI - , stripeServer + ( ChargesAPI + , WebhookAPI + , WebhookConfig + , chargeServer + , webhookServer ) import PaymentServer.Redemption ( RedemptionConfig(RedemptionConfig) @@ -58,14 +61,16 @@ import PaymentServer.Persistence -- | This is the complete type of the server API. type PaymentServerAPI - = "v1" :> "stripe" :> StripeAPI + = "v1" :> "stripe" :> ChargesAPI + :<|> "v1" :> "stripe" :> WebhookAPI :<|> "v1" :> "redeem" :> RedemptionAPI :<|> MetricsAPI -- | Create a server which uses the given database. -paymentServer :: VoucherDatabase d => StripeConfig -> RedemptionConfig -> d -> Server PaymentServerAPI -paymentServer stripeConfig redemptionConfig database = - stripeServer stripeConfig database +paymentServer :: VoucherDatabase d => StripeConfig -> WebhookConfig -> RedemptionConfig -> d -> Server PaymentServerAPI +paymentServer stripeConfig webhookConfig redemptionConfig database = + chargeServer stripeConfig database + :<|> webhookServer webhookConfig database :<|> redemptionServer redemptionConfig database :<|> metricsServer @@ -78,12 +83,13 @@ paymentServerApp :: VoucherDatabase d => [Origin] -- ^ A list of CORS Origins to accept. -> StripeConfig + -> WebhookConfig -> RedemptionConfig -> d -> Application -paymentServerApp corsOrigins stripeConfig redemptionConfig = +paymentServerApp corsOrigins stripeConfig webhookConfig redemptionConfig = let - app = serve paymentServerAPI . paymentServer stripeConfig redemptionConfig + app = serve paymentServerAPI . paymentServer stripeConfig webhookConfig redemptionConfig withCredentials = False corsResourcePolicy = simpleCorsResourcePolicy { corsOrigins = Just (corsOrigins, withCredentials) diff --git a/stack.yaml b/stack.yaml index 45a5364..abdfe63 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,10 +38,21 @@ packages: # using the same syntax as the packages field. # (e.g., acme-missiles-0.3) extra-deps: + - "network-3.1.2.7" - github: "PrivateStorageio/servant-prometheus" commit: "622eb77cb08c5f13729173b8feb123a6700ff91f" # https://input-output-hk.github.io/haskell.nix/tutorials/source-repository-hashes/#stack - # nix-sha256: 09dcwj5ac2x2ilb4a0rai3qhl875vvvjr12af5plpz86faga3lnz + # nix-sha256: 39KhnnIG/UtvcUqELPfe5SAK8YgqA0UWjaILporkrCU= + - "stripe-signature-1.0.0.14" + + # Our fork of the stripe library supports *just* enough of Stripe's newer + # API version to get some extra information our webhook needs. + - github: "PrivateStorageio/stripe" + commit: "6c340eea6dc23c4245762b937b9701a40761a5c9" + subdirs: + - "stripe-core" + # nix-sha256: uVB4vVHgDxyCJpzURl0MPPvwOAaIyi07vNGJXFkLHK4= + # Override default flag values for local packages and extra-deps # flags: {} diff --git a/test/FakeStripe.hs b/test/FakeStripe.hs index dde808a..d48da37 100644 --- a/test/FakeStripe.hs +++ b/test/FakeStripe.hs @@ -11,6 +11,8 @@ module FakeStripe ) where import Text.RawString.QQ + ( r + ) import Data.ByteString.Lazy ( ByteString @@ -50,6 +52,14 @@ import Web.Stripe.Types ( ChargeId(ChargeId) ) +import PaymentServer.Processors.Stripe + ( WebhookConfig(WebhookConfig) + ) + +import Stripe.Concepts + ( WebhookSecretKey(WebhookSecretKey) + ) + cardError :: ByteString cardError = [r| { @@ -182,9 +192,11 @@ chargeFailed stripeResponse req respond = -- Pass a Stripe-flavored configuration for a running Wai application to a -- function and evaluate the resulting IO action. -withFakeStripe :: IO Application -> (StripeConfig -> IO a) -> IO a +withFakeStripe :: IO Application -> (WebhookConfig -> StripeConfig -> IO a) -> IO a withFakeStripe app f = - testWithApplication app $ f . makeConfig + testWithApplication app $ f webhookConfig . makeConfig where makeConfig = StripeConfig stripeKey . Just . Endpoint "127.0.0.1" HTTP stripeKey = StripeKey "pk_test_aaaaaaaaaaaaaaaaaaaaaa" + webhookKey = WebhookSecretKey "whsec_bbbbbbbbbbbbbbbbbbbbbbb" + webhookConfig = WebhookConfig webhookKey diff --git a/test/Metrics.hs b/test/Metrics.hs index 67392b2..d232808 100644 --- a/test/Metrics.hs +++ b/test/Metrics.hs @@ -103,7 +103,7 @@ serverTests = testCase "metrics endpoint" $ let app :: Application - app = paymentServerApp mempty undefined undefined (undefined :: VoucherDatabaseState) + app = paymentServerApp mempty undefined undefined undefined (undefined :: VoucherDatabaseState) in flip runSession app $ do response <- readMetrics diff --git a/test/Redemption.hs b/test/Redemption.hs index 79d1f0b..f435b7a 100644 --- a/test/Redemption.hs +++ b/test/Redemption.hs @@ -129,13 +129,13 @@ redemptionTests = -- response with the given status. assertRedemptionStatus redemption expectedStatus = withFakeStripe (return chargeOkay) $ - \stripeConfig -> do + \webhookConfig stripeConfig -> do db <- memory payForVoucher db aVoucher (return $ Right $ ChargeId "xyz") -- It would be nice if we exercised `getApp` here instead of doing it -- all ourselves. - let app = paymentServerApp origins stripeConfig redemptionConfig db + let app = paymentServerApp origins stripeConfig webhookConfig redemptionConfig db flip runSession app $ do response <- request redemption diff --git a/test/Stripe.hs b/test/Stripe.hs index eaa8350..a1b8aa6 100644 --- a/test/Stripe.hs +++ b/test/Stripe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} -- | Tests related to PaymentServer.Processors.Stripe. @@ -10,6 +11,10 @@ import Prelude hiding ( concat ) +import Text.RawString.QQ + ( r + ) + import Test.Tasty ( TestTree , testGroup @@ -29,6 +34,7 @@ import Data.Text.Lazy , concat ) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Control.Monad.IO.Class ( liftIO @@ -38,6 +44,10 @@ import Control.Monad.Trans.Except ( runExceptT ) +import Stripe.Concepts + ( WebhookSecretKey(WebhookSecretKey) + ) + import Servant.Server ( Handler(runHandler') , ServerError(ServerError) @@ -45,15 +55,25 @@ import Servant.Server import Data.Aeson ( decode + , encode + ) + +import Web.Stripe.Client + ( StripeConfig(StripeConfig) + , StripeKey(StripeKey) ) import Web.Stripe.Types ( Currency(USD, AED) , ChargeId(ChargeId) ) - +import Network.HTTP.Types + ( status200 + , status400 + ) import Network.Wai.Test ( SRequest(SRequest) + , SResponse(simpleStatus, simpleBody) , runSession , request , srequest @@ -69,16 +89,20 @@ import Network.Wai import PaymentServer.Persistence ( Voucher + , RedeemError(NotPaid) , memory , payForVoucher + , redeemVoucher ) import PaymentServer.Processors.Stripe ( Charges(Charges) , Acknowledgement(Ok) , Failure(Failure) + , WebhookConfig(WebhookConfig) , charge - + , webhookServer + , stripeSignature ) import PaymentServer.Issuer @@ -102,6 +126,7 @@ tests :: TestTree tests = testGroup "Stripe" [ chargeTests , corsTests + , webhookTests ] corsTests :: TestTree @@ -146,10 +171,10 @@ corsTests = assertCORSHeader' db stripeResponse method headers body = withFakeStripe (return stripeResponse) $ - \stripeConfig -> do + \webhookConfig stripeConfig -> do let origins = ["example.invalid"] let redemptionConfig = RedemptionConfig 16 1024 trivialIssue - let app = paymentServerApp origins stripeConfig redemptionConfig db + let app = paymentServerApp origins stripeConfig webhookConfig redemptionConfig db let path = "/v1/stripe/charge" let theRequest = setPath defaultRequest @@ -166,7 +191,7 @@ chargeTests :: TestTree chargeTests = testGroup "Charges" [ testCase "non-USD currency is rejected" $ - withFakeStripe (return chargeOkay) $ \stripeConfig -> do + withFakeStripe (return chargeOkay) $ \webhookConfig stripeConfig -> do let amount = 650 let currency = AED db <- memory @@ -176,7 +201,7 @@ chargeTests = assertEqual "The JSON body includes the reason" (Just $ Failure "Unsupported currency") (decode body) , testCase "incorrect USD amount is rejected" $ - withFakeStripe (return chargeOkay) $ \stripeConfig -> do + withFakeStripe (return chargeOkay) $ \webhookConfig stripeConfig -> do let amount = 649 let currency = USD db <- memory @@ -186,7 +211,7 @@ chargeTests = assertEqual "The JSON body includes the reason" (Just $ Failure "Incorrect charge amount") (decode body) , testCase "a Stripe charge failure is propagated" $ - withFakeStripe (return (chargeFailed cardError)) $ \stripeConfig -> do + withFakeStripe (return (chargeFailed cardError)) $ \webhookConfig stripeConfig -> do let amount = 650 let currency = USD db <- memory @@ -198,7 +223,7 @@ chargeTests = (Just $ Failure "Stripe charge didn't succeed: Your card is expired.") (decode body) , testCase "the HTTP error code is derived from the specific failure" $ - withFakeStripe (return (chargeFailed apiError)) $ \stripeConfig -> do + withFakeStripe (return (chargeFailed apiError)) $ \webhookConfig stripeConfig -> do let amount = 650 let currency = USD db <- memory @@ -208,7 +233,7 @@ chargeTests = assertEqual "The HTTP phrase matches the code" "Service Unavailable" phrase , testCase "currect USD amount is accepted" $ - withFakeStripe (return chargeOkay) $ \stripeConfig -> do + withFakeStripe (return chargeOkay) $ \webhookConfig stripeConfig -> do let amount = 650 let currency = USD db <- memory @@ -218,3 +243,294 @@ chargeTests = where token = "foo" voucher = "bar" + +webhookTests :: TestTree +webhookTests = + testGroup "The Stripe charge web hook" + [ testCase "If the signature is missing then the response is Bad Request" $ do + db <- memory + + let + theSRequest = SRequest jsonRequest checkoutSessionCompleted + app = makeApp db + + response <- (flip runSession) app $ srequest theSRequest + assertEqual "The body reflects the error" (Just $ Failure "missing signature") (decode . simpleBody $ response) + assertEqual "The response is 400" status400 (simpleStatus response) + assertNotRedeemable db voucher fingerprint + + , testCase "If the signature is misformatted then the response is Bad Request" $ do + db <- memory + let + app = makeApp db + theRequest = signedRequest "Do you like my signature?" + theSRequest = SRequest theRequest checkoutSessionCompleted + + response <- (flip runSession) app $ srequest theSRequest + assertEqual "The body reflects the error" (Just $ Failure "malformed signature") (decode . simpleBody $ response) + assertEqual "The response is 400" status400 (simpleStatus response) + assertNotRedeemable db voucher fingerprint + + , testCase "If the signature is incorrect then no attempt is made to parse the request body and the response is Bad Request" $ do + db <- memory + let + app = makeApp db + theRequest = signedRequest $ stripeSignature (WebhookSecretKey "key") timestamp "Some other body" + theSRequest = SRequest theRequest checkoutSessionCompleted + + response <- (flip runSession) app $ srequest theSRequest + assertEqual "The body reflects the error" (Just $ Failure "invalid signature") (decode . simpleBody $ response) + assertEqual "The response is 400" status400 (simpleStatus response) + assertNotRedeemable db voucher fingerprint + + , testCase "If the signature is correct and the body is not JSON then the response is Bad Request" $ do + db <- memory + let + nonJSONBody = "Some other body" + app = makeApp db + theRequest = signedRequest $ stripeSignature webhookSecret timestamp nonJSONBody + theSRequest = SRequest theRequest (LBS.fromStrict nonJSONBody) + + response <- (flip runSession) app $ srequest theSRequest + + -- It should fail but we don't really care what the message is. + let (Just (Failure _)) = decode . simpleBody $ response + assertEqual "The response is 400" status400 (simpleStatus response) + + , testCase "If the request body contains a checkout.session.completed event and the signature is correct then the voucher is marked as paid and the response is OK" $ do + db <- runRequest checkoutSessionCompleted >>= assertOkResponse + -- It has been paid so we should be allowed to redeem it. + assertRedeemable db voucher fingerprint + + , testCase "The response to any other event is Bad Request" $ + runRequest productCreated >>= assertResponse status400 + + ] + where + runRequest body = do + db <- memory + let + app = makeApp db + theRequest = (flip setPath) path defaultRequest + { requestMethod = "POST" + , requestHeaders = [ ("content-type", "application/json; charset=utf-8") + , ("Stripe-Signature", stripeSignature webhookSecret timestamp (LBS.toStrict body)) + ] + } + theSRequest = SRequest theRequest body + + response <- (flip runSession) app $ srequest theSRequest + return (db, response) + + -- Assert that the response to a correctly signed applicaton/json request + -- with the given body is 200 OK. + assertOkResponse (db, response) = do + assertEqual "The body reflects success" (encode Ok) (simpleBody response) + assertResponse status200 (db, response) + return db + + assertResponse status (db, response) = + assertEqual ("The response is " ++ (show status)) status (simpleStatus response) + + -- Assert that the database allows us to redeem a voucher, demonstrating + -- that the voucher has persistent state consistent with payment having + -- been received. + assertRedeemable db voucher fingerprint = do + redeemed <- redeemVoucher db voucher fingerprint + assertEqual "The voucher is redeemable." (Right True) redeemed + + -- Assert the opposite of assertRedeemable + assertNotRedeemable db voucher fingerprint = do + redeemed <- redeemVoucher db voucher fingerprint + assertEqual "The unpaid voucher is not redeemable." (Left NotPaid) redeemed + + makeApp = paymentServerApp origins stripeConfig webhookConfig redemptionConfig + + -- Arbitrary strings that don't matter apart from how they compare to + -- other values in the same range. Maybe Voucher and Fingerprint should + -- be newtype instead of type. Note that the voucher value does appear in + -- the checkoutSessionCompleted value below, though. + voucher = "abcdefghi" + fingerprint = "rstuvwxyz" + + timestamp = 1234567890 + + keyBytes = "an extremely good key" + stripeKey = StripeKey keyBytes + stripeConfig = StripeConfig stripeKey Nothing + webhookSecretBytes = "very secret bytes" + webhookSecret = WebhookSecretKey webhookSecretBytes + webhookConfig = WebhookConfig webhookSecret + origins = [] + redemptionConfig = RedemptionConfig 16 1024 trivialIssue + + -- The path at which our server exposes the Stripe webhook handler. + path = "/v1/stripe/webhook" + + -- Some request values useful for the various cases we want to test. + postRequest = (flip setPath) path defaultRequest + { requestMethod = "POST" + } + + jsonRequest = postRequest + { requestHeaders = [("content-type", "application/json; charset=utf-8")] + } + + signedRequest sig = jsonRequest + { requestHeaders = ("Stripe-Signature", sig):requestHeaders jsonRequest + } + +-- Note the client_reference_id contained within matches the voucher defined +-- above. +checkoutSessionCompleted :: LBS.ByteString +checkoutSessionCompleted = [r| +{ + "id": "evt_1LxcsdBHXBAMm9bPSq6UWAZe", + "object": "event", + "api_version": "2019-11-05", + "created": 1666903247, + "data": { + "object": { + "id": "cs_test_a1kWLWGoXZPa6ywyVnuib8DPA3BqXCWZX5UEjLfKh7gLjdZy2LD3F5mEp3", + "object": "checkout.session", + "after_expiration": null, + "allow_promotion_codes": null, + "amount_subtotal": 3000, + "amount_total": 3000, + "automatic_tax": { + "enabled": false, + "status": null + }, + "billing_address_collection": null, + "cancel_url": "https://httpbin.org/post", + "client_reference_id": "abcdefghi", + "consent": null, + "consent_collection": null, + "created": 1666903243, + "currency": "usd", + "customer": "cus_Mh0u62xtelUehD", + "customer_creation": "always", + "customer_details": { + "address": { + "city": null, + "country": null, + "line1": null, + "line2": null, + "postal_code": null, + "state": null + }, + "email": "stripe@example.com", + "name": null, + "phone": null, + "tax_exempt": "none", + "tax_ids": [ + + ] + }, + "customer_email": null, + "display_items": [ + { + "amount": 1500, + "currency": "usd", + "custom": { + "description": "comfortable cotton t-shirt", + "images": null, + "name": "t-shirt" + }, + "quantity": 2, + "type": "custom" + } + ], + "expires_at": 1666989643, + "livemode": false, + "locale": null, + "metadata": { + }, + "mode": "payment", + "payment_intent": "pi_3LxcsZBHXBAMm9bP1daBGoPV", + "payment_link": null, + "payment_method_collection": "always", + "payment_method_options": { + }, + "payment_method_types": [ + "card" + ], + "payment_status": "paid", + "phone_number_collection": { + "enabled": false + }, + "recovered_from": null, + "setup_intent": null, + "shipping": null, + "shipping_address_collection": null, + "shipping_options": [ + + ], + "shipping_rate": null, + "status": "complete", + "submit_type": null, + "subscription": null, + "success_url": "https://httpbin.org/post", + "total_details": { + "amount_discount": 0, + "amount_shipping": 0, + "amount_tax": 0 + }, + "url": null + } + }, + "livemode": false, + "pending_webhooks": 2, + "request": { + "id": null, + "idempotency_key": null + }, + "type": "checkout.session.completed" +} +|] + + +productCreated :: LBS.ByteString +productCreated = [r| +{ + "id": "evt_1LyxesBHXBAMm9bPqekQW4Yj", + "object": "event", + "api_version": "2019-11-05", + "created": 1667221446, + "data": { + "object": { + "id": "prod_MiOR6hX1zcaGfJ", + "object": "product", + "active": true, + "attributes": [ + + ], + "created": 1667221445, + "default_price": null, + "description": "(created by Stripe CLI)", + "images": [ + + ], + "livemode": false, + "metadata": { + }, + "name": "myproduct", + "package_dimensions": null, + "shippable": null, + "statement_descriptor": null, + "tax_code": null, + "type": "service", + "unit_label": null, + "updated": 1667221446, + "url": null + } + }, + "livemode": false, + "pending_webhooks": 2, + "request": { + "id": "req_kvFraITogK8pZB", + "idempotency_key": "74150cd6-6ac5-4144-859f-4e6774adb09d" + }, + "type": "product.created" +} +|]