diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 6fb7773e85603d6b96bc5772bc270222882ca9e1..6aa2bf4a74aaceef8f0dae146de76c7991c51adb 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -16,6 +16,7 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: PaymentServer.Processors.Stripe
+ , PaymentServer.Persistence
build-depends: base >= 4.7 && < 5
, aeson
, servant
@@ -23,6 +24,8 @@ library
, wai
, warp
, stripe-core
+ , text
+ , containers
default-language: Haskell2010
executable PaymentServer-exe
@@ -51,6 +54,7 @@ test-suite PaymentServer-test
, time
, QuickCheck
, quickcheck-instances
+ , checkers
, wai-extra
, bytestring
, text
@@ -58,10 +62,12 @@ test-suite PaymentServer-test
, 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/src/PaymentServer/Persistence.hs b/src/PaymentServer/Persistence.hs
new file mode 100644
index 0000000000000000000000000000000000000000..23b95dce86da68508118ae4829714ec371e29316
--- /dev/null
+++ b/src/PaymentServer/Persistence.hs
@@ -0,0 +1,78 @@
+module PaymentServer.Persistence
+ ( Voucher
+ , VoucherDatabase(payForVoucher, redeemVoucher)
+ , memory
+ ) where
+
+import Data.Text
+ ( Text
+ )
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.IORef
+ ( IORef
+ , newIORef
+ , modifyIORef
+ )
+
+-- | 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
+
+-- | 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. This
+-- is primarily useful for testing.
+data MemoryVoucherDatabase =
+ Memory
+ { paid :: IORef (Set.Set Voucher)
+ , redeemed :: IORef (Map.Map Voucher Fingerprint)
+ }
+
+instance VoucherDatabase MemoryVoucherDatabase where
+ payForVoucher Memory{ paid = paid, redeemed = redeemed } voucher = do
+ modifyIORef paid (Set.insert voucher)
+ return ()
+
+-- | 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
index 94b10a361a2d7282e592749ed3fa50cb4240de68..3aa84a6eea156bc01e442cacaf67170f8a46da0a 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -1,9 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module PaymentServer.Processors.Stripe
( StripeAPI
, stripeServer
+ , getVoucher
) where
import Control.Monad.IO.Class
@@ -33,8 +35,14 @@ import Web.Stripe.Event
, EventData(ChargeEvent)
)
import Web.Stripe.Types
- ( Charge(Charge)
+ ( Charge(Charge, chargeMetaData)
+ , MetaData(MetaData)
)
+import PaymentServer.Persistence
+ ( Voucher
+ , VoucherDatabase(payForVoucher)
+ )
+
data Acknowledgement = Ok
@@ -43,14 +51,35 @@ instance ToJSON Acknowledgement where
type StripeAPI = "webhook" :> ReqBody '[JSON] Event :> Post '[JSON] Acknowledgement
-stripeServer :: Server StripeAPI
+-- | 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 :: Event -> Handler Acknowledgement
+webhook :: VoucherDatabase d => d -> Event -> Handler Acknowledgement
-- Process charge succeeded events
-webhook Event{eventId=Just (EventId eventId), eventType=ChargeSucceededEvent, eventData=ChargeEvent{}} = do
- return Ok
+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 _ = return Ok
+webhook d _ =
+ -- TODO: Record the eventId somewhere.
+ return Ok
diff --git a/test/SpecStripe.hs b/test/SpecStripe.hs
index 878fac5907029d645dda2a1835db8000e5e3f58d..870154085a718d03b2a85cd037478ecc273e9116 100644
--- a/test/SpecStripe.hs
+++ b/test/SpecStripe.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
--
-- Test suite for Stripe support in the payment server.
@@ -6,8 +7,8 @@
module SpecStripe where
-import Data.ByteString as BS
-import Data.ByteString.Lazy as LazyBS
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LazyBS
import Data.Aeson
( encode
)
@@ -28,13 +29,26 @@ import Test.Hspec.Wai
, liftIO
)
import Test.QuickCheck
- ( generate
+ ( Property
+ , Gen
+ , arbitrary
+ , suchThat
+ , suchThatMap
+ , property
+ , generate
+ , forAll
+ , (===)
+ , (=/=)
+ )
+import Test.QuickCheck.Instances.Tuple
+ ( (>*<)
)
import Util.WAI
( postJSON
)
import Util.Gen
( chargeSucceededEvents
+ , hasVoucher
)
import Util.JSON
( -- ToJSON instance for Event
@@ -47,22 +61,33 @@ import Servant
, Proxy(Proxy)
, serve
)
+import Web.Stripe.Types
+ ( MetaData(MetaData)
+ )
import PaymentServer.Processors.Stripe
( StripeAPI
, stripeServer
+ , getVoucher
+ )
+import PaymentServer.Persistence
+ ( Voucher
+ , memory
+ )
+import Data.List.Index
+ ( insertAt
)
stripeAPI :: Proxy StripeAPI
stripeAPI = Proxy
-app :: Application
-app = serve stripeAPI stripeServer
+app :: IO Application
+app = memory >>= return . stripeServer >>= return . serve stripeAPI
aChargeEvent :: IO LazyBS.ByteString
aChargeEvent = encode <$> generate chargeSucceededEvents
spec_webhook :: Spec
-spec_webhook = with (return app) $ do
+spec_webhook = with app $ do
-- I would like to make these property tests but I can't figure out how to
-- use QuickCheck (or Hedgehog) to write property tests for web code.
@@ -81,3 +106,23 @@ spec_webhook = with (return app) $ do
bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String
bodyMatcher _ "{}" = Nothing
bodyMatcher _ body = Just $ show body
+
+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)
+
+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
index 5bdeffdf0205832efab09d8a67fea4da231a077d..5bdcd45f38ae14e3eae3b20b01ac4f53ebd07262 100644
--- a/test/Util/Gen.hs
+++ b/test/Util/Gen.hs
@@ -2,6 +2,8 @@
module Util.Gen
( chargeSucceededEvents
+ , posixTimes
+ , hasVoucher
) where
import Data.Text
@@ -144,5 +146,5 @@ chargeSucceededEvents =
posixTimes :: Gen UTCTime
posixTimes = (arbitrary :: Gen Integer) `suchThatMap` (Just . posixSecondsToUTCTime . fromIntegral . abs)
--- dropFractionalSeconds :: UTCTime -> UTCTime
--- dropFractionalSeconds (UTCTime day dayTime) = UTCTime day (round dayTime)
+hasVoucher :: MetaData -> Bool
+hasVoucher (MetaData items) = any (== "Voucher") . (map fst) $ items