Merge pull request #2 from PrivateStorageio/1.stripe-webhook-endpoint

Set up a basic HTTP server and expose a Stripe webhook endpoint on it

PaymentServer.cabal

@@ -15,12 +15,21 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Lib
+  exposed-modules:     PaymentServer.Processors.Stripe
+                     , PaymentServer.Persistence
+                     , PaymentServer.Server
+                     , PaymentServer.Main
   build-depends:       base >= 4.7 && < 5
                      , aeson
+                     , servant
                      , servant-server
                      , wai
+                     , wai-extra
+                     , data-default
                      , warp
+                     , stripe-core
+                     , text
+                     , containers
   default-language:    Haskell2010
 
 executable PaymentServer-exe
@@ -34,13 +43,37 @@ executable PaymentServer-exe
 test-suite PaymentServer-test
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
-  main-is:             Spec.hs
+  main-is:             Driver.hs
+  other-modules:       SpecStripe
+                     , SpecPersistence
+                     , Util.WAI
+                     , Util.Gen
+                     , Util.JSON
   build-depends:       base
                      , PaymentServer
                      , hspec
                      , hspec-wai
                      , hspec-wai-json
+                     , hspec-expectations
                      , aeson
+                     , stripe-core
+                     , time
+                     , QuickCheck
+                     , quickcheck-instances
+                     , checkers
+                     , wai-extra
+                     , bytestring
+                     , text
+                     , http-types
+                     , tasty
+                     , tasty-th
+                     , tasty-discover
+                     , tasty-quickcheck
+                     , tasty-hspec
+                     , servant-server
+                     , containers
+                     , unordered-containers
+                     , ilist
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010
 

README.rst

 PaymentServer
 =============
+
+PaymentServer maintains the state of a voucher database with respect to payments.
+It receives payment notifications from payment processors and notes this in the database.
+
+Currently, Stripe is supported.
+
+Building
+--------
+
+Build using Stack::
+
+  $ stack build
+
+Testing
+-------
+
+You can run the PaymentServer automated test suite using stack::
+
+  $ stack test
+
+You may also want to perform manual integration testing against Stripe.
+First, run the server::
+
+  $ stack run
+
+Then configure Stripe with a `webhook`_ pointing at the server and receiving the *charge.successful* event.
+Configure Stripe with ``http://<youraddress>:8081/v1/stripe/webhook``.
+
+Then create a testing charge using Stripe::
+
+   $ STRIPE_SECRET_KEY=sk_test_...
+   $ curl \
+     https://api.stripe.com/v1/charges   \
+     -u ${STRIPE_SECRET_KEY}:   \
+     -d amount=999   \
+     -d currency=usd   \
+     -d source=tok_visa   \
+     -d 'metadata[Voucher]=abcdefghijk'
+
+This results in Stripe making a callback to the PaymentServer with the charge details.
+The PaymentServer marks the voucher as paid in its database.
+
+.. _webhook: https://stripe.com/docs/webhooks/setup#configure-webhook-settings

app/Main.hs

-module Main where
+module Main
+  ( main
+  ) where
 
-import Lib
-
-main :: IO ()
-main = startApp
+import PaymentServer.Main
+  ( main -- re-export
+  )

src/Lib.hs

-{-# LANGUAGE DataKinds       #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeOperators   #-}
-module Lib
-    ( startApp
-    , app
-    ) where
-
-import Data.Aeson
-import Data.Aeson.TH
-import Network.Wai
-import Network.Wai.Handler.Warp
-import Servant
-
-data User = User
-  { userId        :: Int
-  , userFirstName :: String
-  , userLastName  :: String
-  } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''User)
-
-type API = "users" :> Get '[JSON] [User]
-
-startApp :: IO ()
-startApp = run 8080 app
-
-app :: Application
-app = serve api server
-
-api :: Proxy API
-api = Proxy
-
-server :: Server API
-server = return users
-
-users :: [User]
-users = [ User 1 "Isaac" "Newton"
-        , User 2 "Albert" "Einstein"
-        ]

src/PaymentServer/Main.hs

+-- | This module implements the main entrypoint to the PaymentServer.
+module PaymentServer.Main
+  ( main
+  ) where
+
+import Data.Default
+  ( def
+  )
+import Network.Wai.Handler.Warp
+  ( run
+  )
+import Network.Wai.Middleware.RequestLogger
+  ( OutputFormat(Detailed, CustomOutputFormatWithDetails)
+  , outputFormat
+  , mkRequestLogger
+  )
+import Network.Wai.Middleware.RequestLogger.JSON
+  ( formatAsJSON
+  )
+import PaymentServer.Persistence
+  ( memory
+  )
+import PaymentServer.Server
+  ( paymentServerApp
+  )
+
+main :: IO ()
+main = do
+  db <- memory
+  let app = paymentServerApp db
+  logger <- mkRequestLogger $ def { outputFormat = Detailed True}
+  run 8081 $ logger app

src/PaymentServer/Persistence.hs

+module PaymentServer.Persistence
+  ( Voucher
+  , Fingerprint
+  , RedeemError(NotPaid, AlreadyRedeemed)
+  , VoucherDatabase(payForVoucher, redeemVoucher)
+  , memory
+  ) where
+
+import Control.Monad
+  ( liftM
+  )
+import Data.Text
+  ( Text
+  )
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.IORef
+  ( IORef
+  , newIORef
+  , modifyIORef
+  , readIORef
+  )
+
+-- | A voucher is a unique identifier which can be associated with a payment.
+-- A paid voucher can be redeemed for ZKAPs which can themselves be exchanged
+-- for service elsewhere with better privacy-preserving properties than the
+-- voucher itself.
+type Voucher = Text
+
+-- | Reasons that a voucher cannot be redeemed.
+data RedeemError =
+  -- | The voucher has not been paid for.
+  NotPaid
+  -- | The voucher has already been redeemed.
+  | AlreadyRedeemed
+  deriving (Show, Eq)
+
+-- | A fingerprint cryptographically identifies a redemption of a voucher.
+-- When a voucher is redeemed, a number of random tokens are received
+-- alongside it.  These tokens are signed to create ZKAPs to return to the
+-- redeemer.  To support fault tolerance (particularly network fault
+-- tolerance) it is allowed to redeem a voucher more than once *so long as*
+-- the same tokens are received with each attempt.  The tokens are
+-- cryptographically hashed to produce a fingerprint that can be persisted
+-- along with the voucher state and checked on possibly-duplicate redemption
+-- to support this case.
+type Fingerprint = Text
+
+-- | A VoucherDatabase provides persistence for state related to vouchers.
+class VoucherDatabase d where
+  -- | Change the state of the given voucher to indicate that it has been paid.
+  payForVoucher
+    :: d             -- ^ The database in which to record the change
+    -> Voucher       -- ^ A voucher which should be considered paid
+    -> IO ()
+
+  -- | Attempt to redeem a voucher.  If it has not been redeemed before or it
+  -- has been redeemed with the same fingerprint, the redemption succeeds.
+  -- Otherwise, it fails.
+  redeemVoucher
+    :: d                          -- ^ The database
+    -> Voucher                    -- ^ A voucher to consider for redemption
+    -> Fingerprint                -- ^ The retry-enabling fingerprint for this redemption
+    -> IO (Either RedeemError ()) -- ^ Left indicating the redemption is not allowed or Right indicating it is.
+
+-- | MemoryVoucherDatabase is a voucher database that only persists state
+-- in-memory.  The state does not outlive the process which creates it (nor
+-- even the MemoryVoucherDatabase value).  This is primarily useful for
+-- testing.
+data MemoryVoucherDatabase =
+  Memory {
+    -- | A set of vouchers which have been paid for.
+    paid :: IORef (Set.Set Voucher)
+    -- | A mapping from redeemed vouchers to fingerprints associated with the
+    -- redemption.
+  , redeemed :: IORef (Map.Map Voucher Fingerprint)
+  }
+
+instance VoucherDatabase MemoryVoucherDatabase where
+  payForVoucher Memory{ paid = paid, redeemed = redeemed } voucher = do
+    modifyIORef paid (Set.insert voucher)
+    return ()
+
+  redeemVoucher Memory{ paid = paid, redeemed = redeemed } voucher fingerprint = do
+    unpaid <- Set.notMember voucher <$> readIORef paid
+    existingFingerprint <- Map.lookup voucher <$> readIORef redeemed
+    case (unpaid, existingFingerprint) of
+      (True, _) ->
+        return $ Left NotPaid
+      (False, Nothing) -> do
+        modifyIORef redeemed (Map.insert voucher fingerprint)
+        return $ Right ()
+      (False, Just fingerprint') ->
+        if fingerprint == fingerprint' then
+          return $ Right ()
+        else
+          return $ Left AlreadyRedeemed
+
+-- | Create a new, empty MemoryVoucherDatabase.
+memory :: IO MemoryVoucherDatabase
+memory = do
+  paid <- newIORef mempty
+  redeemed <- newIORef mempty
+  return $ Memory paid redeemed

src/PaymentServer/Processors/Stripe.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module PaymentServer.Processors.Stripe
+  ( StripeAPI
+  , stripeServer
+  , getVoucher
+  ) where
+
+import Control.Monad.IO.Class
+  ( liftIO
+  )
+import Text.Printf
+  ( printf
+  )
+import Data.Aeson
+  ( ToJSON(toJSON)
+  , object
+  )
+import Servant
+  ( Server
+  , Handler
+  )
+import Servant.API
+  ( ReqBody
+  , JSON
+  , Post
+  , (:>)
+  )
+import Web.Stripe.Event
+  ( Event(Event, eventId, eventCreated, eventLiveMode, eventType, eventData, eventObject, eventPendingWebHooks, eventRequest)
+  , EventId(EventId)
+  , EventType(ChargeSucceededEvent)
+  , EventData(ChargeEvent)
+  )
+import Web.Stripe.Types
+  ( Charge(Charge, chargeMetaData)
+  , MetaData(MetaData)
+  )
+import PaymentServer.Persistence
+  ( Voucher
+  , VoucherDatabase(payForVoucher)
+  )
+
+
+data Acknowledgement = Ok
+
+instance ToJSON Acknowledgement where
+  toJSON Ok = object []
+
+type StripeAPI = "webhook" :> ReqBody '[JSON] Event :> Post '[JSON] Acknowledgement
+
+-- | 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 => d -> Server StripeAPI
+stripeServer = webhook
+
+webhook :: VoucherDatabase d => d -> Event -> Handler Acknowledgement
+
+-- Process charge succeeded events
+webhook d Event{eventId=Just (EventId eventId), eventType=ChargeSucceededEvent, eventData=(ChargeEvent charge)} =
+  case getVoucher $ chargeMetaData charge 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 Ok
+
+-- Disregard anything else - but return success so that Stripe doesn't retry.
+webhook d _ =
+  -- TODO: Record the eventId somewhere.
+  return Ok

src/PaymentServer/Server.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | This module exposes a Servant-based Network.Wai server for payment
+-- interactions.
+module PaymentServer.Server
+  ( paymentServerApp
+  ) where
+
+import Servant
+  ( Proxy(Proxy)
+  , Server
+  , Application
+  , serve
+  , (:>)
+  )
+import PaymentServer.Processors.Stripe
+  ( StripeAPI
+  , stripeServer
+  )
+import PaymentServer.Persistence
+  ( VoucherDatabase
+  )
+
+-- | This is the complete type of the server API.
+type PaymentServerAPI = "v1" :> "stripe" :> StripeAPI
+
+-- | Create a server which uses the given database.
+paymentServer :: VoucherDatabase d => d -> Server PaymentServerAPI
+paymentServer = stripeServer
+
+paymentServerAPI :: Proxy PaymentServerAPI
+paymentServerAPI = Proxy
+
+-- | Create a Servant Application which serves the payment server API using
+-- the given database.
+paymentServerApp :: VoucherDatabase d => d -> Application
+paymentServerApp = (serve paymentServerAPI) . paymentServer

stack.yaml

@@ -37,7 +37,8 @@ packages:
 # Dependency packages to be pulled from upstream that are not in the resolver
 # using the same syntax as the packages field.
 # (e.g., acme-missiles-0.3)
-# extra-deps: []
+extra-deps:
+  - "stripe-core-2.5.0"
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

test/Driver.hs

+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+
+-- This is a module where we can hang the above preprocessor definition to
+-- direct tasty-discover to find our test suite spread across the rest of the
+-- modules rooted in this directory.
+--
+-- See the test-suite definition in PaymentServer.cabal
+-- See also https://git.coop/decentral1se/tasty-discover

test/Spec.hs

-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Main (main) where
-
-import Lib (app)
-import Test.Hspec
-import Test.Hspec.Wai
-import Test.Hspec.Wai.JSON
-
-main :: IO ()
-main = hspec spec
-
-spec :: Spec
-spec = with (return app) $ do
-    describe "GET /users" $ do
-        it "responds with 200" $ do
-            get "/users" `shouldRespondWith` 200
-        it "responds with [User]" $ do
-            let users = "[{\"userId\":1,\"userFirstName\":\"Isaac\",\"userLastName\":\"Newton\"},{\"userId\":2,\"userFirstName\":\"Albert\",\"userLastName\":\"Einstein\"}]"
-            get "/users" `shouldRespondWith` users

test/SpecPersistence.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+--
+-- Test suite related to the persistence system.
+--
+
+module SpecPersistence where
+
+import Control.Monad.IO.Class
+  ( liftIO
+  )
+import Test.Hspec
+  ( Spec
+  , describe
+  , it
+  )
+import Test.Hspec.Expectations
+  ( shouldReturn
+  )
+import Test.QuickCheck
+  ( Property
+  , property
+  , (==>)
+  )
+import Test.QuickCheck.Monadic
+  ( monadicIO
+  , run
+  , assert
+  , pre
+  )
+import Test.QuickCheck.Instances.Text
+  (
+  )
+import PaymentServer.Persistence
+  ( RedeemError(NotPaid, AlreadyRedeemed)
+  , Voucher
+  , Fingerprint
+  , VoucherDatabase(payForVoucher, redeemVoucher)
+  , memory
+  )
+
+-- | A voucher which has not been paid for cannot be redeemed.
+unpaidVoucherNotRedeemable :: VoucherDatabase d => IO d -> Property
+unpaidVoucherNotRedeemable getDB = property $ \voucher fingerprint -> do
+  db <- liftIO getDB
+  redeemVoucher db voucher fingerprint `shouldReturn` Left NotPaid
+
+-- | A voucher which is paid for can be redeemed with any fingerprint.
+paidVoucherRedeemable :: VoucherDatabase d => IO d -> Property
+paidVoucherRedeemable getDB = property $ \voucher fingerprint -> do
+  db <- liftIO getDB
+  () <- payForVoucher db voucher
+  redeemVoucher db voucher fingerprint `shouldReturn` Right ()
+
+-- | A voucher which is paid for can be redeemed more than once as long as the
+-- same fingerprint is used each time.
+paidVoucherMultiRedeemable :: VoucherDatabase d => IO d -> Property
+paidVoucherMultiRedeemable getDB = property $ \voucher fingerprint -> do
+  db <- liftIO getDB
+  () <- payForVoucher db voucher
+  let redeem = redeemVoucher db voucher fingerprint
+  redeem
+  redeem `shouldReturn` Right ()
+
+-- | A voucher which is paid for can not be redeemed a second time with a
+-- different fingerprint than was used on the first attempt.
+paidVoucherMismatchFingerprint :: VoucherDatabase d => IO d -> Property
+paidVoucherMismatchFingerprint getDB = property $ \voucher fingerprint fingerprint' ->
+  fingerprint /= fingerprint' ==> do
+  db <- liftIO getDB
+  () <- payForVoucher db voucher
+  let redeem = redeemVoucher db voucher
+  redeem fingerprint
+  redeem fingerprint' `shouldReturn` Left AlreadyRedeemed
+
+makeSpec :: VoucherDatabase d => IO d -> Spec
+makeSpec getDB =
+  describe "voucher interactions" $
+  do
+    it "denies redemption of a not-paid-for voucher" $ unpaidVoucherNotRedeemable getDB
+    it "allows redemption of paid-for vouchers" $ paidVoucherRedeemable getDB
+    it "allows multiple redemption as long as the same fingerprint is used" $ paidVoucherMultiRedeemable getDB
+    it "denies a subsequent redemption with a different fingerprint" $ paidVoucherMismatchFingerprint getDB
+
+spec_memory = makeSpec memory

test/SpecStripe.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+--
+-- Test suite for Stripe support in the payment server.
+--
+
+module SpecStripe where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LazyBS
+import Data.Aeson
+  ( encode
+  )
+import Test.Hspec
+  ( Spec
+  , describe
+  , it
+  )
+import Test.Hspec.Wai
+  ( WaiSession
+  , WaiExpectation
+  , MatchBody(MatchBody)
+  , ResponseMatcher(matchBody)
+  , Body
+  , with
+  , post
+  , shouldRespondWith
+  , liftIO
+  )
+import Test.Hspec.Wai.QuickCheck
+  ( property
+  )
+import Test.QuickCheck
+  ( Property
+  , Gen
+  , arbitrary
+  , generate
+  , forAll
+  , (===)
+  , (=/=)
+  )
+import Util.WAI
+  ( postJSON
+  )
+import Util.Gen
+  ( ChargeEvents(GoodChargeEvent, BadChargeEvent)
+  , chargeSucceededEvents
+  , metaDatasWithVoucher
+  , metaDatasWithoutVoucher
+  )
+import Util.JSON
+  ( -- ToJSON instance for Event
+  )
+import Network.HTTP.Types
+  ( Header
+  )
+import Servant
+  ( Application
+  , Proxy(Proxy)
+  , serve
+  )
+import Web.Stripe.Types
+  ( MetaData(MetaData)
+  )
+import PaymentServer.Processors.Stripe
+  ( StripeAPI
+  , stripeServer
+  , getVoucher
+  )
+import PaymentServer.Persistence
+  ( Voucher
+  , memory
+  )
+
+stripeAPI :: Proxy StripeAPI
+stripeAPI = Proxy
+
+app :: IO Application
+app = serve stripeAPI . stripeServer <$> memory
+
+spec_webhook :: Spec
+spec_webhook = with app $ do
+  describe "error behavior of POST /webhook" $ do
+    it "responds to non-JSON Content-Type with 415 (Unsupported Media Type)" $
+      post "/webhook" "xxx" `shouldRespondWith` 415
+
+    it "responds to JSON non-Event body with 400 (Invalid Request)" $
+      postJSON "/webhook" "{}" `shouldRespondWith` 400
+
+  -- I would like to make most or all of these into property tests.  *This*
+  -- test shows how you can do it.  Yay.  The main thing (for me, anyway) to
+  -- remember is to use `property` from Test.Hspec.Wai.QuickCheck and not from
+  -- `Test.QuickCheck`. :/ Unsure whether I love the apparent Haskell
+  -- convention of giving the same name to *similar* functions.
+  describe "success behavior of POST /webhook" $
+    it "responds to a JSON Event body with 200 (OK)" $
+    let
+      test e =
+        postJSON "/webhook" (encode e) `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }
+      -- For now these are the same.  Maybe they always will be?  The HTTP
+      -- behavior is the same though the backend behavior may differ.  Note
+      -- that a "test_" prefix would cause tasty-discover to find this and try
+      -- to call it - but it can't since it's not a top-level, let alone
+      -- exported.
+      xtest_postWithEventBody (GoodChargeEvent e) = test e
+      xtest_postWithEventBody (BadChargeEvent e) = test e
+    in
+      property xtest_postWithEventBody
+
+
+
+bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String
+bodyMatcher _ "{}" = Nothing
+bodyMatcher _ body = Just $ show body
+
+prop_getVoucherFindsVoucher :: Property
+prop_getVoucherFindsVoucher = forAll metaDatasWithVoucher $ \x ->
+  getVoucher x =/= Nothing
+
+prop_getVoucherWithoutVoucher :: Property
+prop_getVoucherWithoutVoucher = forAll metaDatasWithoutVoucher $ \x ->
+  getVoucher x === Nothing

test/Util/Gen.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Util.Gen
+  ( chargeSucceededEvents
+  , metaDatasWithoutVoucher
+  , metaDatasWithVoucher
+  , posixTimes
+  , hasVoucher
+  , ChargeEvents(GoodChargeEvent, BadChargeEvent)
+  ) where
+
+import Data.Text
+  ( Text
+  )
+import Data.List.Index
+  ( insertAt
+  )
+import Data.Time.Clock
+  ( UTCTime(UTCTime)
+  )
+import Data.Time.Clock.POSIX
+  ( POSIXTime
+  , posixSecondsToUTCTime
+  )
+import Web.Stripe.Types
+  ( Charge(Charge)
+  , StatementDescription(StatementDescription)
+  , MetaData(MetaData)
+  , Description(Description)
+  , CustomerId(CustomerId)
+  , InvoiceId(InvoiceId)
+  , ChargeId(ChargeId)
+  , Expandable(Id)
+  , Currency(USD, UnknownCurrency)
+  , Amount(Amount)
+  , StripeList(StripeList, list, totalCount, hasMore)
+  )
+import Web.Stripe.Event
+  ( Event(Event, eventId, eventCreated, eventLiveMode, eventType, eventData, eventObject, eventPendingWebHooks, eventRequest)
+  , EventType(ChargeSucceededEvent)
+  , EventData(ChargeEvent)
+  , EventId(EventId)
+  )
+import Test.QuickCheck
+  ( Gen
+  , Arbitrary
+  , arbitrary
+  , Positive(Positive)
+  , oneof
+  , suchThat
+  , suchThatMap
+  )
+import Test.QuickCheck.Instances.Tuple
+  ( (>*<)
+  )
+import Test.QuickCheck.Instances.Time
+  ( -- Get the `Gen UTCTime` instance
+  )
+import Test.QuickCheck.Instances.Text
+  ( -- Get the `Gen Text` instance
+  )
+import PaymentServer.Persistence
+  ( Voucher
+  )
+
+instance Arbitrary Charge where
+  arbitrary = charges True
+
+instance Semigroup (StripeList a) where
+  -- Very weak implementation
+  x <> y = StripeList (list x <> list y) "" "" Nothing (hasMore x || hasMore y)
+
+instance Monoid (StripeList a) where
+  mempty = StripeList [] "" "" (Just 0) False
+
+instance Arbitrary Amount where
+  arbitrary = Amount <$> arbitrary
+
+
+instance Arbitrary EventId where
+  arbitrary = EventId <$> arbitrary
+
+
+instance Arbitrary StatementDescription where
+  arbitrary = StatementDescription <$> arbitrary
+
+metaDatasWithoutVoucher = (arbitrary :: Gen MetaData) `suchThat` (not . hasVoucher)
+-- Just filtering out random metadatas that don't have a voucher makes for an
+-- incredibly inefficient generator.  So start without a voucher and then add
+-- one.
+metaDatasWithVoucher = ((arbitrary :: Gen Voucher) >*< metaDatasWithoutVoucher) `suchThatMap` (Just. uncurry addVoucher)
+
+addVoucher :: Voucher -> MetaData -> MetaData
+addVoucher voucher (MetaData []) = MetaData [("Voucher", voucher)]
+addVoucher voucher (MetaData items) =
+  MetaData (insertAt (1234567 `mod` length items) ("Voucher", voucher) items)
+
+instance Arbitrary MetaData where
+  arbitrary = MetaData <$> arbitrary
+
+instance Arbitrary Description where
+  arbitrary = Description <$> arbitrary
+
+
+instance Arbitrary InvoiceId where
+  arbitrary = InvoiceId <$> arbitrary
+
+
+instance Arbitrary ChargeId where
+  arbitrary = ChargeId <$> arbitrary
+
+
+instance Arbitrary CustomerId where
+  arbitrary = CustomerId <$> arbitrary
+
+
+instance Arbitrary a => Arbitrary (Expandable a) where
+  arbitrary = Id <$> arbitrary
+
+chargeSucceededEvents :: Bool -> Gen Event
+chargeSucceededEvents withVoucher =
+  Event
+  <$> arbitrary -- eventId
+  <*> posixTimes -- eventCreated
+  <*> arbitrary -- eventLiveMode
+  <*> return ChargeSucceededEvent -- eventType
+  <*> chargeEvents withVoucher -- eventData
+  <*> return "event" -- eventObject
+  <*> arbitrary -- eventPendingWebHooks
+  <*> arbitrary -- eventRequest
+
+
+chargeEvents :: Bool -> Gen EventData
+chargeEvents withVoucher =
+  ChargeEvent <$> charges withVoucher
+
+charges :: Bool -> Gen Charge
+charges withVoucher =
+  Charge
+  <$> arbitrary         --   chargeId :: ChargeId
+  <*> return "charge"   --   chargeObject :: Text
+  <*> posixTimes        --   chargeCreated :: UTCTime
+  <*> arbitrary         --   chargeLiveMode :: Bool
+  <*> arbitrary         --   chargePaid :: Bool
+  <*> arbitrary         --   chargeAmount :: Amount
+  <*> oneof
+  [ return UnknownCurrency
+  , return USD
+  ]                     --   chargeCurrency :: Currency
+  <*> return False      --   chargeRefunded :: Bool
+  <*> return Nothing    --   chargeCreditCard :: Maybe Card
+  <*> arbitrary         --   chargeCaptured :: Bool
+  <*> return mempty     --   chargeRefunds :: StripeList Refund
+  <*> return Nothing    --   chargeBalanceTransaction :: Maybe (Expandable TransactionId)
+  <*> return Nothing    --   chargeFailureMessage :: Maybe Text
+  <*> return Nothing    --   chargeFailureCode :: Maybe Text
+  <*> return 0          --   chargeAmountRefunded :: Int
+  <*> arbitrary         --   chargeCustomerId :: Maybe (Expandable CustomerId)
+  <*> return Nothing    --   chargeInvoice :: Maybe (Expandable InvoiceId)
+  <*> arbitrary         --   chargeDescription :: Maybe Description
+  <*> return Nothing    --   chargeDispute :: Maybe Dispute
+  <*> (
+  if withVoucher then
+    metaDatasWithVoucher
+  else
+    metaDatasWithoutVoucher
+  )                     --   chargeMetaData :: MetaData
+  <*> arbitrary         --   chargeStatementDescription :: Maybe StatementDescription
+  <*> arbitrary         --   chargeReceiptEmail :: Maybe Text
+  <*> arbitrary         --   chargeReceiptNumber :: Maybe Text
+
+data ChargeEvents
+  = GoodChargeEvent Event
+  | BadChargeEvent Event
+  deriving (Show, Eq)
+
+instance Arbitrary ChargeEvents where
+  arbitrary = oneof
+    [ chargeSucceededEvents True `suchThatMap` (Just . GoodChargeEvent)
+    , chargeSucceededEvents False `suchThatMap` (Just . BadChargeEvent)
+    ]
+
+posixTimes :: Gen UTCTime
+posixTimes = (arbitrary :: Gen Integer) `suchThatMap` (Just . posixSecondsToUTCTime . fromIntegral . abs)
+
+hasVoucher :: MetaData -> Bool
+hasVoucher (MetaData items) = elem "Voucher" . map fst $ items

test/Util/JSON.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Util.JSON where
+
+import Data.Time.Clock.POSIX
+  ( utcTimeToPOSIXSeconds
+  )
+import Data.HashMap.Lazy
+  ( fromList
+  )
+import qualified Data.Sequence as Seq
+import Web.Stripe.Types
+  ( Charge(Charge)
+  , ChargeId(ChargeId)
+  , InvoiceId(InvoiceId)
+  , Amount(Amount)
+  , Currency(USD, UnknownCurrency)
+  , MetaData(MetaData)
+  , StripeList(StripeList)
+  , Refund(Refund)
+  , RefundId(RefundId)
+  , TransactionId(TransactionId)
+  , Expandable(Id)
+  )
+import Web.Stripe.Event
+  ( Event(Event)
+  , EventData(ChargeEvent)
+  , EventType(ChargeSucceededEvent)
+  , EventId(EventId)
+  )
+import Data.Aeson
+  ( ToJSON(toJSON)
+  , Value(String, Number, Object, Array)
+  , object
+  , (.=)
+  )
+import Data.Aeson.Types
+  ( listValue
+  )
+
+instance ToJSON Event where
+  toJSON (Event
+           eventId
+           eventCreated
+           eventLiveMode
+           eventType
+           eventData
+           eventObject
+           eventPendingWebHooks
+           eventRequest)
+    = object
+    [ "id" .= eventId
+    , "object" .= eventObject
+    , "api_version" .= String "2018-05-21"
+    , "created" .= utcTimeToPOSIXSeconds eventCreated
+    , "data" .= object [ "object" .= eventData ]
+    , "type" .= eventType
+    , "livemode" .= eventLiveMode
+    , "pending_webhooks" .= eventPendingWebHooks
+    , "request" .= eventRequest
+    ]
+
+instance ToJSON a => ToJSON (Expandable a) where
+  toJSON (Id eId) = toJSON eId
+
+instance ToJSON EventId where
+  toJSON (EventId eId) = String eId
+
+instance ToJSON InvoiceId where
+  toJSON (InvoiceId iId) = String iId
+
+instance ToJSON ChargeId where
+  toJSON (ChargeId cId) = String cId
+
+instance ToJSON RefundId where
+  toJSON (RefundId rId) = String rId
+
+instance ToJSON TransactionId where
+  toJSON (TransactionId tId) = String tId
+
+instance ToJSON Currency where
+  toJSON USD = "USD"
+  toJSON UnknownCurrency = "???"
+
+instance ToJSON EventType where
+  toJSON ChargeSucceededEvent = "charge.succeeded"
+
+instance ToJSON EventData where
+  toJSON (ChargeEvent charge) = toJSON charge
+
+instance ToJSON Amount where
+  toJSON (Amount a) = Number $ fromIntegral a
+
+instance ToJSON MetaData where
+  toJSON (MetaData items) = (Object . fromList . map (\(k, v) -> (k, String v))) items
+
+instance ToJSON Refund where
+  toJSON (Refund
+           refundId
+           refundAmount
+           refundCurrency
+           refundCreated
+           refundObject
+           refundCharge
+           refundBalanceTransaction
+           refundMetaData
+         )
+    = object
+    [ "id" .= refundId
+    , "amount" .= refundAmount
+    , "currency" .= refundCurrency
+    , "created" .= utcTimeToPOSIXSeconds refundCreated
+    , "object" .= refundObject
+    , "charge" .= refundCharge
+    , "balance_transaction" .= refundBalanceTransaction
+    , "metadata" .= refundMetaData
+    ]
+
+instance (ToJSON a) => ToJSON (StripeList a) where
+  toJSON (StripeList elements stripeUrl obj totalCount hasMore)
+    = object
+    [ "data" .= toJSON elements
+    , "url" .= stripeUrl
+    , "object" .= obj
+    , "has_more" .= hasMore
+    ]
+
+instance ToJSON Charge where
+  toJSON (Charge
+           chargeId
+           chargeObject
+           chargeCreated
+           chargeLiveMode
+           chargePaid
+           chargeAmount
+           chargeCurrency
+           chargeRefunded
+           chargeCreditChard
+           chargeCaptured
+           chargeRefunds
+           chargeBalanceTransaction
+           chargeFailureMessage
+           chargeFailureCode
+           chargeAmountRefunded
+           chargeCustomerId
+           chargeInvoice
+           chargeDescription
+           chargeDispute
+           chargeMetaData
+           chargeStatementDescription
+           chargeReceiptEmail
+           chargeNumber
+         )
+    = object
+    [ "id"         .= chargeId
+    , "object"     .= chargeObject
+    , "amount"     .= chargeAmount
+    , "amount_refunded" .= chargeAmountRefunded
+    -- , "balance_transaction" .= chargeBalanceTransaction
+    , "captured" .= chargeCaptured
+    , "created"    .= utcTimeToPOSIXSeconds chargeCreated
+    , "currency"   .= chargeCurrency
+    -- , "customer" .= chargeCustomerId
+    -- , "description" .= chargeDescription
+    -- , "dispute" .= chargeDispute
+    -- , "failure_code" .= chargeFailureCode
+    -- , "failure_message" .= chargeFailureMessage
+    -- , "invoice" .= chargeInvoice
+    , "livemode" .= chargeLiveMode
+    , "metadata" .= chargeMetaData
+    , "paid" .= chargePaid
+    , "receipt_email" .= chargeReceiptEmail
+    , "refunded" .= chargeRefunded
+    , "refunds" .= chargeRefunds
+    ]

test/Util/WAI.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Util.WAI
+  ( postJSON
+  ) where
+
+import Data.ByteString.Lazy as LazyBS
+import Data.ByteString as BS
+import Test.Hspec.Wai
+  ( WaiSession
+  , request
+  )
+import Network.HTTP.Types.Method
+  ( methodPost
+  )
+import Network.Wai.Test
+  ( SResponse
+  )
+
+-- Post some JSON to a path.
+-- Return a function from path to a response
+postJSON :: BS.ByteString -> (LazyBS.ByteString -> WaiSession SResponse)
+postJSON path =
+  request methodPost path [("Content-Type", "application/json")]