stripe-hs 0.1.2.0 → 0.2.0.0
raw patch · 8 files changed
+358/−196 lines, 8 filesdep +containersdep +http-typesdep +servant-client-corePVP ok
version bump matches the API change (PVP)
Dependencies added: containers, http-types, servant-client-core
API changes (from Hackage documentation)
+ Stripe.Client.Internal.Helpers: runRequest :: Int -> Int -> IO (Either ClientError a) -> IO (Either ClientError a)
- Stripe.Client: makeStripeClient :: ApiKey -> Manager -> StripeClient
+ Stripe.Client: makeStripeClient :: ApiKey -> Manager -> Int -> StripeClient
Files
- README.md +3/−1
- src/Stripe/Client.hs +11/−4
- src/Stripe/Client/Internal/Helpers.hs +25/−0
- stripe-hs.cabal +10/−2
- test/ApiSpec.hs +166/−0
- test/HelperSpec.hs +100/−0
- test/Spec.hs +6/−189
- test/WebhookSpec.hs +37/−0
README.md view
@@ -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
src/Stripe/Client.hs view
@@ -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 <https://stripe.com/docs/error-handling#safely-retrying-requests-with-idempotency Stripe Error Handling>+ -> 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)
+ src/Stripe/Client/Internal/Helpers.hs view
@@ -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
stripe-hs.cabal view
@@ -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
+ test/ApiSpec.hs view
@@ -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
+ test/HelperSpec.hs view
@@ -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
test/Spec.hs view
@@ -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
+ test/WebhookSpec.hs view
@@ -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