diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +# stripe-hs + +Unofficial and incomplete Stripe SDK/client for Haskell. It's generated via `servant-client` from `stripe-servant` with a small amount of hand-written code. Contributions are welcome! + +## Install + +``` sh +# stack +stack install stripe-hs + +# cabal +cabal install stripe-hs +``` + +## Example + +``` haskell +{-# LANGUAGE OverloadedStrings #-} +import Stripe.Client + +import System.Environment (getEnv) +import Network.HTTP.Client +import Network.HTTP.Client.TLS + +main :: IO () +main = + do manager <- newManager tlsManagerSettings + apiKey <- T.pack <$> getEnv "STRIPE_KEY" + let client = makeStripeClient apiKey manager + result <- + createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) + print result +``` + +## Features + +The package provides a module for webhook signature verification (see `Stripe.Webhook.Verify`). + +Supported APIs/Resources: +* Customers +* Products +* Prices +* CustomerPortal +* CheckoutSession +* Events + +*Note that all resources are likely missing fields. The library is currently focused on to be used in combination with Stripe's hosted surfaces (Customer Portal and Checkout).* + +## Running the tests + +You can run all tests with `stack test`. You'll need a Stripe testmode API Key assigned to the `STRIPE_KEY` environment variable and you'll need to setup a Customer Portal configuration in the Stripe dashboard before running them. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Stripe/Client.hs b/src/Stripe/Client.hs new file mode 100644 --- /dev/null +++ b/src/Stripe/Client.hs @@ -0,0 +1,101 @@ +{-# OPTIONS_GHC -cpp -pgmPcpphs -optP--cpp #-} +{-# LANGUAGE CPP #-} +module Stripe.Client + ( -- * Basics + ApiKey, StripeClient, makeStripeClient + -- * Helper types + , TimeStamp(..), StripeList(..) + -- * Customers + , createCustomer, retrieveCustomer, updateCustomer, listCustomers + , Customer(..), CustomerCreate(..), CustomerUpdate(..) + -- * Product catalog + , ProductId(..), PriceId(..), Product(..), Price(..), PriceRecurring(..) + , ProductCreate(..), PriceCreate(..), PriceCreateRecurring(..) + , createProduct, retrieveProduct + , createPrice, retrievePrice, listPrices + -- * Subscriptions + , SubscriptionId(..) + -- * Customer Portal + , CustomerPortalId(..), CustomerPortal(..), CustomerPortalCreate(..) + , createCustomerPortal + -- * Checkout + , CheckoutSessionId(..), CheckoutSession(..), CheckoutSessionCreate(..), CheckoutSessionCreateLineItem(..) + , createCheckoutSession, retrieveCheckoutSession + -- * Events + , retrieveEvent, listEvents + , Event(..), EventData(..) + ) +where + +import Stripe.Api +import Stripe.Resources + +import Data.Proxy +import Servant.API +import Servant.Client +import Network.HTTP.Client (Manager) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +-- | Your Stripe API key. Can be obtained from the Stripe dashboard. Format: @sk__@ +type ApiKey = T.Text + +-- | Holds a 'Manager' and your API key. +data StripeClient + = StripeClient + { scBasicAuthData :: BasicAuthData + , scManager :: Manager + } + +-- | Construct a 'StripeClient'. Note that the passed 'Manager' must support https (e.g. via @http-client-tls@) +makeStripeClient :: ApiKey -> Manager -> StripeClient +makeStripeClient k = StripeClient (BasicAuthData (T.encodeUtf8 k) "") + +api :: Proxy StripeApi +api = Proxy + +stripeBaseUrl :: BaseUrl +stripeBaseUrl = BaseUrl Https "api.stripe.com" 443 "" + +#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) + +#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) + +#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) + +EP(createCustomer, CustomerCreate, Customer) +EP(retrieveCustomer, CustomerId, Customer) +EP2(updateCustomer, CustomerId, CustomerUpdate, Customer) +EP(listCustomers, Maybe CustomerId, (StripeList Customer)) + +EP(createProduct, ProductCreate, Product) +EP(retrieveProduct, ProductId, Product) + +EP(createPrice, PriceCreate, Price) +EP(retrievePrice, PriceId, Price) +EP(listPrices, Maybe T.Text, (StripeList Price)) + +EP(createCheckoutSession, CheckoutSessionCreate, CheckoutSession) +EP(retrieveCheckoutSession, CheckoutSessionId, CheckoutSession) + +EP(createCustomerPortal, CustomerPortalCreate, CustomerPortal) + +EP(retrieveEvent, EventId, Event) +EP(listEvents, Maybe EventId, (StripeList Event)) + +(createCustomer' :<|> retrieveCustomer' :<|> updateCustomer' :<|> listCustomers') + :<|> (createProduct' :<|> retrieveProduct') + :<|> (createPrice' :<|> retrievePrice' :<|> listPrices') + :<|> (createCheckoutSession' :<|> retrieveCheckoutSession') + :<|> (createCustomerPortal') + :<|> (retrieveEvent' :<|> listEvents') + = client api diff --git a/src/Stripe/Webhook/Verify.hs b/src/Stripe/Webhook/Verify.hs new file mode 100644 --- /dev/null +++ b/src/Stripe/Webhook/Verify.hs @@ -0,0 +1,55 @@ +module Stripe.Webhook.Verify + ( verifyStripeSignature + , WebhookSecret, VerificationResult(..) + ) +where + +import Crypto.Hash.Algorithms +import Crypto.MAC.HMAC +import Data.Bifunctor +import Data.ByteArray.Encoding +import Data.Time +import Data.Time.Clock.POSIX +import Safe +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC + +-- | Your webhook secret, can be obtained from the Stripe dashboard. Format: @whsec_@ +type WebhookSecret = BS.ByteString + +-- | Output of the webhook signature verification +data VerificationResult + = VOk UTCTime + -- ^ Signature verification successful, check the time against the current time and reject /too old/ requests. + | VFailed + -- ^ Signature verification failed. Check that your 'WebhookSecret' is correct. + | VInvalidSignature + -- ^ Invalid signature. Verify that you are passing the raw contents of the @stripe-signature@ header. + deriving (Show, Eq) + +-- | Verify the @stripe-signature@ header +verifyStripeSignature :: + WebhookSecret + -- ^ Your webhook secret + -> BS.ByteString + -- ^ Value of the @stripe-signature@ header + -> BS.ByteString + -- ^ Raw request body received from Stripe + -> VerificationResult +verifyStripeSignature secret sig rawBody = + let sigMap = map (second (BS.drop 1) . BSC.break (\c -> c == '=')) . BSC.split ',' $ sig + needed = + do t <- lookup "t" sigMap + (parsedTime :: Int) <- readMay (BSC.unpack t) + v1 <- lookup "v1" sigMap + pure (t, posixSecondsToUTCTime $ fromIntegral parsedTime, v1) + in case needed of + Nothing -> VInvalidSignature + Just (rawTime, time, v1) -> + let payload = rawTime <> BSC.singleton '.' <> rawBody + computedSig :: HMAC SHA256 + computedSig = hmac secret payload + hexSig = convertToBase Base16 computedSig + in if hexSig == v1 + then VOk time + else VFailed diff --git a/stripe-hs.cabal b/stripe-hs.cabal new file mode 100644 --- /dev/null +++ b/stripe-hs.cabal @@ -0,0 +1,83 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: e3b93721f97a9a10c4c1eac1e38649e238caceee6ce78dce82361e9f569a82e8 + +name: stripe-hs +version: 0.1.0.0 +synopsis: Unofficial Stripe client +description: Unofficial Stripe client +category: Web +homepage: https://github.com/agrafix/stripe-hs#readme +bug-reports: https://github.com/agrafix/stripe-hs/issues +author: Alexander Thiemann +maintainer: Alexander Thiemann +copyright: 2020 Alexander Thiemann +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/agrafix/stripe-hs + +library + exposed-modules: + Stripe.Client + Stripe.Webhook.Verify + other-modules: + Paths_stripe_hs + hs-source-dirs: + src + default-extensions: OverloadedStrings DataKinds TypeOperators TypeFamilies GADTs FlexibleInstances FlexibleContexts MultiParamTypeClasses StrictData ScopedTypeVariables DeriveGeneric DeriveFunctor + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , casing + , cpphs + , cryptonite + , http-client + , memory + , safe + , servant + , servant-client + , stripe-servant + , text + , time + default-language: Haskell2010 + +test-suite stripe-hs-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_stripe_hs + hs-source-dirs: + test + default-extensions: OverloadedStrings DataKinds TypeOperators TypeFamilies GADTs FlexibleInstances FlexibleContexts MultiParamTypeClasses StrictData ScopedTypeVariables DeriveGeneric DeriveFunctor + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , casing + , cpphs + , cryptonite + , hspec + , http-client + , http-client-tls + , memory + , safe + , servant + , servant-client + , stripe-hs + , stripe-servant + , text + , time + , vector + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,161 @@ +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Test.Hspec +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 + +main :: IO () +main = + hspec $ + do describe "api" apiTests + 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 = + before 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 "customer portal" $ + do it "allows creating a customer portal (needs setup in dashboard)" $ \cli -> + do customer <- + forceSuccess $ + createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) + portal <- + forceSuccess $ + createCustomerPortal cli (CustomerPortalCreate (cId customer) (Just "https://athiemann.net/return")) + cpCustomer portal `shouldBe` cId customer + cpReturnUrl portal `shouldBe` Just "https://athiemann.net/return" + describe "checkout" $ + do it "create and retrieves a checkout session" $ \cli -> + do prod <- forceSuccess $ createProduct cli (ProductCreate "Test" Nothing) + price <- + forceSuccess $ + createPrice cli $ + PriceCreate "usd" (Just 1000) (prId prod) Nothing False $ + Just (PriceCreateRecurring "month" Nothing) + customer <- + forceSuccess $ + createCustomer cli (CustomerCreate Nothing (Just "mail@athiemann.net")) + 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 customer) + , cscLineItems = [CheckoutSessionCreateLineItem (pId price) 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 + + 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"