diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -26,7 +26,7 @@ main = do manager <- newManager tlsManagerSettings apiKey <- T.pack <$> getEnv "STRIPE_KEY" - let client = makeStripeClient apiKey manager + let client = makeStripeClient apiKey manager 4 result <- createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) print result @@ -35,6 +35,8 @@ ## Features The package provides a module for webhook signature verification (see `Stripe.Webhook.Verify`). + +The implementation retries automatically according to [Stripe's error handling documentation](https://stripe.com/docs/error-handling#safely-retrying-requests-with-idempotency Stripe Error Handling). Supported APIs/Resources: * Customers diff --git a/src/Stripe/Client.hs b/src/Stripe/Client.hs --- a/src/Stripe/Client.hs +++ b/src/Stripe/Client.hs @@ -30,6 +30,7 @@ import Stripe.Api import Stripe.Resources +import Stripe.Client.Internal.Helpers import Data.Proxy import Servant.API @@ -46,10 +47,16 @@ = StripeClient { scBasicAuthData :: BasicAuthData , scManager :: Manager + , scMaxRetries :: Int } -- | Construct a 'StripeClient'. Note that the passed 'Manager' must support https (e.g. via @http-client-tls@) -makeStripeClient :: ApiKey -> Manager -> StripeClient +makeStripeClient :: + ApiKey + -> Manager + -> Int + -- ^ Number of automatic retries the library should attempt. See also + -> StripeClient makeStripeClient k = StripeClient (BasicAuthData (T.encodeUtf8 k) "") api :: Proxy StripeApi @@ -61,17 +68,17 @@ #define EP(N, ARG, R) \ N##' :: BasicAuthData -> ARG -> ClientM R;\ N :: StripeClient -> ARG -> IO (Either ClientError R);\ - N sc a = runClientM (N##' (scBasicAuthData sc) a) (mkClientEnv (scManager sc) stripeBaseUrl) + N sc a = runRequest (scMaxRetries sc) 0 $ runClientM (N##' (scBasicAuthData sc) a) (mkClientEnv (scManager sc) stripeBaseUrl) #define EP2(N, ARG, ARG2, R) \ N##' :: BasicAuthData -> ARG -> ARG2 -> ClientM R;\ N :: StripeClient -> ARG -> ARG2 -> IO (Either ClientError R);\ - N sc a b = runClientM (N##' (scBasicAuthData sc) a b) (mkClientEnv (scManager sc) stripeBaseUrl) + N sc a b = runRequest (scMaxRetries sc) 0 $ runClientM (N##' (scBasicAuthData sc) a b) (mkClientEnv (scManager sc) stripeBaseUrl) #define EP3(N, ARG, ARG2, ARG3, R) \ N##' :: BasicAuthData -> ARG -> ARG2 -> ARG3 -> ClientM R;\ N :: StripeClient -> ARG -> ARG2 -> ARG3 -> IO (Either ClientError R);\ - N sc a b c = runClientM (N##' (scBasicAuthData sc) a b c) (mkClientEnv (scManager sc) stripeBaseUrl) + N sc a b c = runRequest (scMaxRetries sc) 0 $ runClientM (N##' (scBasicAuthData sc) a b c) (mkClientEnv (scManager sc) stripeBaseUrl) EP(createCustomer, CustomerCreate, Customer) EP(retrieveCustomer, CustomerId, Customer) diff --git a/src/Stripe/Client/Internal/Helpers.hs b/src/Stripe/Client/Internal/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Stripe/Client/Internal/Helpers.hs @@ -0,0 +1,25 @@ +-- | Private helper functions. Note that all contents of this module are excluded from the versioning scheme. +{-# LANGUAGE BangPatterns #-} +module Stripe.Client.Internal.Helpers where + +import Servant.Client +import Network.HTTP.Types.Status + +runRequest :: Int -> Int -> IO (Either ClientError a) -> IO (Either ClientError a) +runRequest maxRetries !retryCount makeRequest = + do res <- makeRequest + case res of + Right ok -> pure (Right ok) + Left err@(ConnectionError _) -> maybeRetry err + Left err@(FailureResponse _ resp) + | ("stripe-should-retry", "true") `elem` responseHeaders resp -> maybeRetry err + | ("stripe-should-retry", "false") `elem` responseHeaders resp -> pure (Left err) + | responseStatusCode resp == conflict409 -> maybeRetry err + | statusCode (responseStatusCode resp) >= 500 -> maybeRetry err + | otherwise -> pure (Left err) + Left err -> pure (Left err) + where + maybeRetry err = + if retryCount + 1 >= maxRetries + then pure (Left err) + else runRequest maxRetries (retryCount + 1) makeRequest diff --git a/stripe-hs.cabal b/stripe-hs.cabal --- a/stripe-hs.cabal +++ b/stripe-hs.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 17b2ceab62158580838655099f2170895429f74c64b322b3eb2f98f12f7571ea +-- hash: 4b82770025cbf946f65cc037f6aeb6f5634f2070cbbe49073a237fea81b0f94c name: stripe-hs -version: 0.1.2.0 +version: 0.2.0.0 synopsis: Unofficial Stripe client description: Unofficial Stripe client category: Web @@ -29,6 +29,7 @@ library exposed-modules: Stripe.Client + Stripe.Client.Internal.Helpers Stripe.Webhook.Verify other-modules: Paths_stripe_hs @@ -43,6 +44,7 @@ , cpphs , cryptonite , http-client + , http-types , memory , safe , servant @@ -56,6 +58,9 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + ApiSpec + HelperSpec + WebhookSpec Paths_stripe_hs hs-source-dirs: test @@ -66,15 +71,18 @@ , base >=4.7 && <5 , bytestring , casing + , containers , cpphs , cryptonite , hspec , http-client , http-client-tls + , http-types , memory , safe , servant , servant-client + , servant-client-core , stripe-hs , stripe-servant , text diff --git a/test/ApiSpec.hs b/test/ApiSpec.hs new file mode 100644 --- /dev/null +++ b/test/ApiSpec.hs @@ -0,0 +1,166 @@ +module ApiSpec (apiSpec) where + +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Test.Hspec +import Data.Time +import Data.Time.TimeSpan +import System.Environment (getEnv) +import qualified Data.Text as T +import qualified Data.Vector as V + +import Stripe.Client + +makeClient :: IO StripeClient +makeClient = + do manager <- newManager tlsManagerSettings + apiKey <- T.pack <$> getEnv "STRIPE_KEY" + pure (makeStripeClient apiKey manager 2) + +forceSuccess :: (MonadFail m, Show a) => m (Either a b) -> m b +forceSuccess req = + req >>= \res -> + case res of + Left err -> fail (show err) + Right ok -> pure ok + +apiSpec :: Spec +apiSpec = + do describe "core api" apiTests + describe "api" apiWorldTests + +apiTests :: SpecWith () +apiTests = + beforeAll makeClient $ + do describe "events" $ + do it "lists events" $ \cli -> + do _ <- forceSuccess $ createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) + res <- forceSuccess $ listEvents cli Nothing + V.null (slData res) `shouldBe` False + describe "products" $ + do it "creates a product" $ \cli -> + do res <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) + prName res `shouldBe` "Test" + it "retrieves a product" $ \cli -> + do res <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) + res2 <- forceSuccess $ retrieveProduct cli (prId res) + res `shouldBe` res2 + describe "prices" $ + do it "creates a price" $ \cli -> + do prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) + res <- + forceSuccess $ + createPrice cli $ + PriceCreate "usd" (Just 1000) (prId prod) (Just "lk") True $ + Just (PriceCreateRecurring "month" Nothing) + pCurrency res `shouldBe` "usd" + pUnitAmount res `shouldBe` Just 1000 + pType res `shouldBe` "recurring" + pLookupKey res `shouldBe` Just "lk" + pRecurring res `shouldBe` Just (PriceRecurring "month" 1) + it "retrieves a price" $ \cli -> + do prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) + res <- + forceSuccess $ + createPrice cli $ + PriceCreate "usd" (Just 1000) (prId prod) Nothing False $ + Just (PriceCreateRecurring "month" Nothing) + res2 <- forceSuccess $ retrievePrice cli (pId res) + res `shouldBe` res2 + it "lists by lookup_key" $ \cli -> + do prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) + price <- + forceSuccess $ + createPrice cli $ + PriceCreate "usd" (Just 1000) (prId prod) (Just "the_key") True $ + Just (PriceCreateRecurring "month" Nothing) + res <- forceSuccess $ listPrices cli (Just "the_key") + pId (V.head (slData res)) `shouldBe` pId price + res2 <- forceSuccess $ listPrices cli (Just "KEY_NOT_EXISTING_OK") + V.null (slData res2) `shouldBe` True + describe "customers" $ + do it "creates a customer" $ \cli -> + do cr <- forceSuccess $ createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) + cEmail cr `shouldBe` Just "mail@athiemann.net" + it "retrieves a customer" $ \cli -> + do cr <- forceSuccess $ createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) + cu <- forceSuccess $ retrieveCustomer cli (cId cr) + cu `shouldBe` cr + it "updates a customer" $ \cli -> + do cr <- forceSuccess $ createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) + cu <- forceSuccess $ updateCustomer cli (cId cr) (CustomerUpdate Nothing (Just "mail+2@athiemann.net")) + cEmail cu `shouldBe` Just "mail+2@athiemann.net" + +data StripeWorld + = StripeWorld + { swProduct :: Product + , swPrice :: Price + , swCustomer :: Customer + } deriving (Show, Eq) + +makeStripeWorld :: IO (StripeClient, StripeWorld) +makeStripeWorld = + do cli <- makeClient + customer <- + forceSuccess $ + createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) + prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) + price <- + forceSuccess $ + createPrice cli $ + PriceCreate "usd" (Just 1000) (prId prod) Nothing False $ + Just (PriceCreateRecurring "month" Nothing) + pure (cli, StripeWorld prod price customer) + +apiWorldTests :: SpecWith () +apiWorldTests = + beforeAll makeStripeWorld $ + do describe "subscriptions" $ + do it "allows creating a subscription" $ \(cli, sw) -> + do trialEnd <- TimeStamp . addUTCTimeTS (hours 1) <$> getCurrentTime + subscription <- + forceSuccess $ + createSubscription cli $ + SubscriptionCreate + { scCustomer = cId (swCustomer sw) + , scItems = [SubscriptionCreateItem (pId (swPrice sw)) (Just 1)] + , scCancelAtPeriodEnd = Just False + , scTrialEnd = Just trialEnd + } + sCancelAtPeriodEnd subscription `shouldBe` False + sCustomer subscription `shouldBe` cId (swCustomer sw) + let items = sItems subscription + fmap siPrice items `shouldBe` pure (swPrice sw) + fmap siQuantity items `shouldBe` pure (Just 1) + fmap siSubscription items `shouldBe` pure (sId subscription) + sStatus subscription `shouldBe` "trialing" + describe "customer portal" $ + do it "allows creating a customer portal (needs setup in dashboard)" $ \(cli, sw) -> + do portal <- + forceSuccess $ + createCustomerPortal cli (CustomerPortalCreate (cId (swCustomer sw)) (Just "https://athiemann.net/return")) + cpCustomer portal `shouldBe` cId (swCustomer sw) + cpReturnUrl portal `shouldBe` Just "https://athiemann.net/return" + describe "checkout" $ + do it "create and retrieves a checkout session" $ \(cli, sw) -> + do session <- + forceSuccess $ + createCheckoutSession cli $ + CheckoutSessionCreate + { cscCancelUrl = "https://athiemann.net/cancel" + , cscMode = "subscription" + , cscPaymentMethodTypes = ["card"] + , cscSuccessUrl = "https://athiemann.net/success" + , cscClientReferenceId = Just "cool" + , cscCustomer = Just (cId (swCustomer sw)) + , cscLineItems = [CheckoutSessionCreateLineItem (pId (swPrice sw)) 1] + } + csClientReferenceId session `shouldBe` Just "cool" + csCancelUrl session `shouldBe` "https://athiemann.net/cancel" + csSuccessUrl session `shouldBe` "https://athiemann.net/success" + csPaymentMethodTypes session `shouldBe` V.singleton "card" + + sessionRetrieved <- + forceSuccess $ + retrieveCheckoutSession cli (csId session) + sessionRetrieved `shouldBe` session diff --git a/test/HelperSpec.hs b/test/HelperSpec.hs new file mode 100644 --- /dev/null +++ b/test/HelperSpec.hs @@ -0,0 +1,100 @@ +module HelperSpec (helperSpec) where + +import Test.Hspec +import Data.IORef +import Servant.Client +import Servant.Client.Core.Request +import Network.HTTP.Types.Status +import Network.HTTP.Types.Version +import Network.HTTP.Types.Header +import qualified Data.Sequence as Seq +import qualified Data.ByteString as BS +import Data.Maybe +import Control.Exception.Base +import System.Exit + +import Stripe.Client.Internal.Helpers + +helperSpec :: Spec +helperSpec = + do describe "retries" retryTests + +makeFakeAction :: + (Int -> Either ClientError a) + -> IO (IO Int, IO (Either ClientError a)) +makeFakeAction makeResult = + do calls <- newIORef 0 + let action = + do call <- atomicModifyIORef calls $ \i -> (i + 1, i) + pure (makeResult call) + pure (readIORef calls, action) + +dummyReq :: RequestF () (BaseUrl, BS.ByteString) +dummyReq = + defaultRequest + { requestBody = Nothing + , requestPath = (fromJust $ parseBaseUrl "api.example.com", "") + } + +retryAction :: + Int + -> Status + -> Seq.Seq Header + -> IO (ClientError, IO Int, IO (Either ClientError Bool)) +retryAction n status headers = + do let errResp = + Response + { responseStatusCode = status + , responseHeaders = headers + , responseHttpVersion = http11 + , responseBody = mempty + } + err = FailureResponse dummyReq errResp + (getCalls, action) <- + makeFakeAction $ \call -> + if call < n + then Left $ err + else Right True + pure (err, getCalls, action) + +retryTests :: SpecWith () +retryTests = + do it "does not retry on success" $ + do (getCalls, action) <- makeFakeAction (const $ Right True) + runRequest 10 0 action `shouldReturn` Right True + getCalls `shouldReturn` 1 + it "retries on connection errors" $ + do (getCalls, action) <- + makeFakeAction $ \call -> + if call == 0 + then Left (ConnectionError $ toException ExitSuccess) + else Right True + runRequest 10 0 action `shouldReturn` Right True + getCalls `shouldReturn` 2 + it "retries on stripe-should-retry=true headers" $ + do (_, getCalls, action) <- + retryAction 1 status404 $ + Seq.fromList [("stripe-should-retry", "true")] + runRequest 10 0 action `shouldReturn` Right True + getCalls `shouldReturn` 2 + it "retries on 409 status code" $ + do (_, getCalls, action) <- + retryAction 1 status409 mempty + runRequest 10 0 action `shouldReturn` Right True + getCalls `shouldReturn` 2 + it "retries on 500 status code" $ + do (_, getCalls, action) <- + retryAction 1 status500 mempty + runRequest 10 0 action `shouldReturn` Right True + getCalls `shouldReturn` 2 + it "does not retry on status 500 with should retry false" $ + do (err, getCalls, action) <- + retryAction 1 status500 $ + Seq.fromList [("stripe-should-retry", "false")] + runRequest 10 0 action `shouldReturn` Left err + getCalls `shouldReturn` 1 + it "does not retry on status 500 if limit exceeded" $ + do (err, getCalls, action) <- + retryAction 11 status500 mempty + runRequest 10 0 action `shouldReturn` Left err + getCalls `shouldReturn` 10 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,195 +1,12 @@ -import Network.HTTP.Client -import Network.HTTP.Client.TLS import Test.Hspec -import Data.Time -import Data.Time.TimeSpan -import Data.Time.Clock.POSIX -import System.Environment (getEnv) -import qualified Data.Text as T -import qualified Data.ByteString as BS -import qualified Data.Vector as V -import Stripe.Client -import Stripe.Webhook.Verify - -makeClient :: IO StripeClient -makeClient = - do manager <- newManager tlsManagerSettings - apiKey <- T.pack <$> getEnv "STRIPE_KEY" - pure (makeStripeClient apiKey manager) - -forceSuccess :: (MonadFail m, Show a) => m (Either a b) -> m b -forceSuccess req = - req >>= \res -> - case res of - Left err -> fail (show err) - Right ok -> pure ok +import ApiSpec +import WebhookSpec +import HelperSpec main :: IO () main = hspec $ - do describe "core api" apiTests - describe "api" apiWorldTests - describe "webhooks" webhookTests - -testStripeSignature :: BS.ByteString -testStripeSignature = - "t=1608784111" - <> ",v1=3cef61e0cf5ad6e9832925080d463dd7396160f8371c430e426242f3f89f4126" - <> ",v0=aa179c5358b80a557a960137a85279caa13b06a05390816b533c3c146127bbe0" - --- Don't worry, i've long deleted this one... obfuscating a bit so that search tools --- don't find it an try it out. -testStripeSecret :: WebhookSecret -testStripeSecret = - "wh" <> "sec_" <> "2FZJ5Kqdi6AF8fGCLOCP9lH8Hpw9DW6T" - -webhookTests :: SpecWith () -webhookTests = - do it "accepts correctly signed webhooks" $ - do bs <- BS.readFile "test-data/customer_webhook.json" - let stripped = BS.take (BS.length bs - 1) bs -- trim trailing newline - time = posixSecondsToUTCTime 1608784111 - verifyStripeSignature testStripeSecret testStripeSignature stripped `shouldBe` VOk time - it "fails incorrectly signed webhooks" $ - do let bs = "{\"foo\": 1234}" - verifyStripeSignature testStripeSecret testStripeSignature bs `shouldBe` VFailed - it "detects bad signatures" $ - do let bs = "{\"foo\": 1234}" - verifyStripeSignature testStripeSecret "fooo" bs `shouldBe` VInvalidSignature - -apiTests :: SpecWith () -apiTests = - beforeAll makeClient $ - do describe "events" $ - do it "lists events" $ \cli -> - do _ <- forceSuccess $ createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) - res <- forceSuccess $ listEvents cli Nothing - V.null (slData res) `shouldBe` False - describe "products" $ - do it "creates a product" $ \cli -> - do res <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) - prName res `shouldBe` "Test" - it "retrieves a product" $ \cli -> - do res <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) - res2 <- forceSuccess $ retrieveProduct cli (prId res) - res `shouldBe` res2 - describe "prices" $ - do it "creates a price" $ \cli -> - do prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) - res <- - forceSuccess $ - createPrice cli $ - PriceCreate "usd" (Just 1000) (prId prod) (Just "lk") True $ - Just (PriceCreateRecurring "month" Nothing) - pCurrency res `shouldBe` "usd" - pUnitAmount res `shouldBe` Just 1000 - pType res `shouldBe` "recurring" - pLookupKey res `shouldBe` Just "lk" - pRecurring res `shouldBe` Just (PriceRecurring "month" 1) - it "retrieves a price" $ \cli -> - do prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) - res <- - forceSuccess $ - createPrice cli $ - PriceCreate "usd" (Just 1000) (prId prod) Nothing False $ - Just (PriceCreateRecurring "month" Nothing) - res2 <- forceSuccess $ retrievePrice cli (pId res) - res `shouldBe` res2 - it "lists by lookup_key" $ \cli -> - do prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) - price <- - forceSuccess $ - createPrice cli $ - PriceCreate "usd" (Just 1000) (prId prod) (Just "the_key") True $ - Just (PriceCreateRecurring "month" Nothing) - res <- forceSuccess $ listPrices cli (Just "the_key") - pId (V.head (slData res)) `shouldBe` pId price - res2 <- forceSuccess $ listPrices cli (Just "KEY_NOT_EXISTING_OK") - V.null (slData res2) `shouldBe` True - describe "customers" $ - do it "creates a customer" $ \cli -> - do cr <- forceSuccess $ createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) - cEmail cr `shouldBe` Just "mail@athiemann.net" - it "retrieves a customer" $ \cli -> - do cr <- forceSuccess $ createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) - cu <- forceSuccess $ retrieveCustomer cli (cId cr) - cu `shouldBe` cr - it "updates a customer" $ \cli -> - do cr <- forceSuccess $ createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) - cu <- forceSuccess $ updateCustomer cli (cId cr) (CustomerUpdate Nothing (Just "mail+2@athiemann.net")) - cEmail cu `shouldBe` Just "mail+2@athiemann.net" - -data StripeWorld - = StripeWorld - { swProduct :: Product - , swPrice :: Price - , swCustomer :: Customer - } deriving (Show, Eq) - -makeStripeWorld :: IO (StripeClient, StripeWorld) -makeStripeWorld = - do cli <- makeClient - customer <- - forceSuccess $ - createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) - prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) - price <- - forceSuccess $ - createPrice cli $ - PriceCreate "usd" (Just 1000) (prId prod) Nothing False $ - Just (PriceCreateRecurring "month" Nothing) - pure (cli, StripeWorld prod price customer) - -apiWorldTests :: SpecWith () -apiWorldTests = - beforeAll makeStripeWorld $ - do describe "subscriptions" $ - do it "allows creating a subscription" $ \(cli, sw) -> - do trialEnd <- TimeStamp . addUTCTimeTS (hours 1) <$> getCurrentTime - subscription <- - forceSuccess $ - createSubscription cli $ - SubscriptionCreate - { scCustomer = cId (swCustomer sw) - , scItems = [SubscriptionCreateItem (pId (swPrice sw)) (Just 1)] - , scCancelAtPeriodEnd = Just False - , scTrialEnd = Just trialEnd - } - sCancelAtPeriodEnd subscription `shouldBe` False - sCustomer subscription `shouldBe` cId (swCustomer sw) - let items = sItems subscription - fmap siPrice items `shouldBe` pure (swPrice sw) - fmap siQuantity items `shouldBe` pure (Just 1) - fmap siSubscription items `shouldBe` pure (sId subscription) - sStatus subscription `shouldBe` "trialing" - describe "customer portal" $ - do it "allows creating a customer portal (needs setup in dashboard)" $ \(cli, sw) -> - do portal <- - forceSuccess $ - createCustomerPortal cli (CustomerPortalCreate (cId (swCustomer sw)) (Just "https://athiemann.net/return")) - cpCustomer portal `shouldBe` cId (swCustomer sw) - cpReturnUrl portal `shouldBe` Just "https://athiemann.net/return" - describe "checkout" $ - do it "create and retrieves a checkout session" $ \(cli, sw) -> - do session <- - forceSuccess $ - createCheckoutSession cli $ - CheckoutSessionCreate - { cscCancelUrl = "https://athiemann.net/cancel" - , cscMode = "subscription" - , cscPaymentMethodTypes = ["card"] - , cscSuccessUrl = "https://athiemann.net/success" - , cscClientReferenceId = Just "cool" - , cscCustomer = Just (cId (swCustomer sw)) - , cscLineItems = [CheckoutSessionCreateLineItem (pId (swPrice sw)) 1] - } - csClientReferenceId session `shouldBe` Just "cool" - csCancelUrl session `shouldBe` "https://athiemann.net/cancel" - csSuccessUrl session `shouldBe` "https://athiemann.net/success" - csPaymentMethodTypes session `shouldBe` V.singleton "card" - - sessionRetrieved <- - forceSuccess $ - retrieveCheckoutSession cli (csId session) - sessionRetrieved `shouldBe` session + do apiSpec + helperSpec + webhookSpec diff --git a/test/WebhookSpec.hs b/test/WebhookSpec.hs new file mode 100644 --- /dev/null +++ b/test/WebhookSpec.hs @@ -0,0 +1,37 @@ +module WebhookSpec (webhookSpec) where + +import Test.Hspec +import Data.Time.Clock.POSIX +import qualified Data.ByteString as BS + +import Stripe.Webhook.Verify + +webhookSpec :: Spec +webhookSpec = + do describe "webhooks" webhookTests + +testStripeSignature :: BS.ByteString +testStripeSignature = + "t=1608784111" + <> ",v1=3cef61e0cf5ad6e9832925080d463dd7396160f8371c430e426242f3f89f4126" + <> ",v0=aa179c5358b80a557a960137a85279caa13b06a05390816b533c3c146127bbe0" + +-- Don't worry, i've long deleted this one... obfuscating a bit so that search tools +-- don't find it an try it out. +testStripeSecret :: WebhookSecret +testStripeSecret = + "wh" <> "sec_" <> "2FZJ5Kqdi6AF8fGCLOCP9lH8Hpw9DW6T" + +webhookTests :: SpecWith () +webhookTests = + do it "accepts correctly signed webhooks" $ + do bs <- BS.readFile "test-data/customer_webhook.json" + let stripped = BS.take (BS.length bs - 1) bs -- trim trailing newline + time = posixSecondsToUTCTime 1608784111 + verifyStripeSignature testStripeSecret testStripeSignature stripped `shouldBe` VOk time + it "fails incorrectly signed webhooks" $ + do let bs = "{\"foo\": 1234}" + verifyStripeSignature testStripeSecret testStripeSignature bs `shouldBe` VFailed + it "detects bad signatures" $ + do let bs = "{\"foo\": 1234}" + verifyStripeSignature testStripeSecret "fooo" bs `shouldBe` VInvalidSignature