diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 89f755458e41e87cfe74c2ed2247fff9871f7fd6..4bba8eea5a2d1bc944ac946fb030c539a3bc978e 100644
--- a/PaymentServer.cabal
+++ b/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
diff --git a/README.rst b/README.rst
index ef238ee4c5c59a41cd391d0f5be41a5a8dde7363..211cf19bfb7a568f1ad99094911e50072c0a8bb2 100644
--- a/README.rst
+++ b/README.rst
@@ -1,2 +1,45 @@
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
diff --git a/app/Main.hs b/app/Main.hs
index f66a415f02080ad1b552d1fb655750fe9ed0b03a..f0c5b6052d5c360e5f5bbaaec48fee9dc48001ef 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,6 +1,7 @@
-module Main where
+module Main
+ ( main
+ ) where
-import Lib
-
-main :: IO ()
-main = startApp
+import PaymentServer.Main
+ ( main -- re-export
+ )
diff --git a/src/Lib.hs b/src/Lib.hs
deleted file mode 100644
index 3844204aadfc686548ee94661bb696ead5d67e35..0000000000000000000000000000000000000000
--- a/src/Lib.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# 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"
- ]
diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
new file mode 100644
index 0000000000000000000000000000000000000000..adbc78b7754d89481363380c483f17064f42c9fe
--- /dev/null
+++ b/src/PaymentServer/Main.hs
@@ -0,0 +1,32 @@
+-- | 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
diff --git a/src/PaymentServer/Persistence.hs b/src/PaymentServer/Persistence.hs
new file mode 100644
index 0000000000000000000000000000000000000000..eea14b43cf92b45c2977e1e6801306aa4dd194db
--- /dev/null
+++ b/src/PaymentServer/Persistence.hs
@@ -0,0 +1,104 @@
+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
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
new file mode 100644
index 0000000000000000000000000000000000000000..3aa84a6eea156bc01e442cacaf67170f8a46da0a
--- /dev/null
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -0,0 +1,85 @@
+{-# 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
diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f4ecaf3eb1f62a307e9a8dbc9651b05b6447855e
--- /dev/null
+++ b/src/PaymentServer/Server.hs
@@ -0,0 +1,39 @@
+{-# 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
diff --git a/stack.yaml b/stack.yaml
index 9879a51389f8ae856386953ccd3db2a4ea146b24..75399a2e58530adf91ef7986d22afc5aff66d297 100644
--- a/stack.yaml
+++ b/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: {}
diff --git a/test/Driver.hs b/test/Driver.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f2287e7136655bb1b55f1262258bcbd21bb32cb8
--- /dev/null
+++ b/test/Driver.hs
@@ -0,0 +1,8 @@
+{-# 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
diff --git a/test/Spec.hs b/test/Spec.hs
deleted file mode 100644
index 8aefe968b9a875f97786a3ab87cdf4bd7dbd20b6..0000000000000000000000000000000000000000
--- a/test/Spec.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# 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
diff --git a/test/SpecPersistence.hs b/test/SpecPersistence.hs
new file mode 100644
index 0000000000000000000000000000000000000000..db6d8a5be3f33853454c11bb95f3439b71766128
--- /dev/null
+++ b/test/SpecPersistence.hs
@@ -0,0 +1,86 @@
+{-# 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
diff --git a/test/SpecStripe.hs b/test/SpecStripe.hs
new file mode 100644
index 0000000000000000000000000000000000000000..23ad2932d4368416880b5383a23f9d947017eea8
--- /dev/null
+++ b/test/SpecStripe.hs
@@ -0,0 +1,123 @@
+{-# 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
diff --git a/test/Util/Gen.hs b/test/Util/Gen.hs
new file mode 100644
index 0000000000000000000000000000000000000000..ffba41237a591d05a7834df9663564f46d7b5d2b
--- /dev/null
+++ b/test/Util/Gen.hs
@@ -0,0 +1,187 @@
+{-# 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
diff --git a/test/Util/JSON.hs b/test/Util/JSON.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f43be9f362f703a9cc376cfa3fb8f72dd6dce601
--- /dev/null
+++ b/test/Util/JSON.hs
@@ -0,0 +1,175 @@
+{-# 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
+ ]
diff --git a/test/Util/WAI.hs b/test/Util/WAI.hs
new file mode 100644
index 0000000000000000000000000000000000000000..53d29ff74af1c937a477b89390868a23d7090d3d
--- /dev/null
+++ b/test/Util/WAI.hs
@@ -0,0 +1,24 @@
+{-# 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")]