diff --git a/src/PaymentServer/Persistence.hs b/src/PaymentServer/Persistence.hs
index dc499a4e6325abb0055ced3e46e33b929eb50168..db4525437293c258f97b1dec49c7b0b66fabefe1 100644
--- a/src/PaymentServer/Persistence.hs
+++ b/src/PaymentServer/Persistence.hs
@@ -120,21 +120,21 @@ class VoucherDatabase d where
-- This is a backwards compatibility API. Callers should prefer
-- redeemVoucherWithCounter.
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.
+ :: d -- ^ The database
+ -> Voucher -- ^ A voucher to consider for redemption
+ -> Fingerprint -- ^ The retry-enabling fingerprint for this redemption
+ -> IO (Either RedeemError Bool) -- ^ Left indicating the redemption is not allowed or Right indicating it is.
redeemVoucher d v f = redeemVoucherWithCounter d v f 0
-- | Attempt to redeem a voucher. If it has not been redeemed before or it
-- has been redeemed with the same counter and fingerprint, the redemption
-- succeeds. Otherwise, it fails.
redeemVoucherWithCounter
- :: d -- ^ The database
- -> Voucher -- ^ A voucher to consider for redemption
- -> Fingerprint -- ^ The retry-enabling fingerprint for this redemption
- -> Integer -- ^ The counter for this redemption
- -> IO (Either RedeemError ()) -- ^ Left indicating the redemption is not allowed or Right indicating it is.
+ :: d -- ^ The database
+ -> Voucher -- ^ A voucher to consider for redemption
+ -> Fingerprint -- ^ The retry-enabling fingerprint for this redemption
+ -> Integer -- ^ The counter for this redemption
+ -> IO (Either RedeemError Bool) -- ^ Left indicating the redemption is not allowed or Right indicating it is.
-- | VoucherDatabaseState is a type that captures whether we are using an
@@ -246,9 +246,12 @@ redeemVoucherHelper
-- this account.
-> Fingerprint -- ^ The fingerprint of the
-- this attempt.
- -> IO (Either RedeemError ()) -- ^ Right for successful
- -- redemption, left with
- -- details about why it failed.
+ -> IO (Either RedeemError Bool) -- ^ Right True for a new
+ -- successful redemption, Right
+ -- False for a retried
+ -- successful redemption, left
+ -- with details about why it
+ -- failed.
redeemVoucherHelper isVoucherPaid lookupFingerprint lookupVoucherCounter markVoucherRedeemed voucher counter fingerprint = do
paid <- isVoucherPaid voucher
priorUse <- lookupVoucherCounter fingerprint
@@ -263,10 +266,10 @@ redeemVoucherHelper isVoucherPaid lookupFingerprint lookupVoucherCounter markVou
(True, Nothing) -> do
markVoucherRedeemed (voucher, counter) fingerprint
P.incCounter voucherRedeemed
- return $ Right ()
+ return $ Right True
(True, Just fingerprint') ->
if fingerprint == fingerprint' then
- return $ Right ()
+ return $ Right False
else
return $ Left AlreadyRedeemed
diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs
index d1735fc648956accc3b0b8579290f984d62e2542..3f22a198d2bf8ec57476c8693682c0f1ac2da55e 100644
--- a/src/PaymentServer/Redemption.hs
+++ b/src/PaymentServer/Redemption.hs
@@ -170,7 +170,7 @@ redemptionServer = redeem
-- | Try an operation repeatedly for several minutes with a brief delay
-- between tries.
-retry :: IO (Either RedeemError()) -> IO (Either RedeemError())
+retry :: IO (Either RedeemError a) -> IO (Either RedeemError a)
retry op =
retrying policy shouldRetry $ \_ -> op
where
@@ -207,7 +207,7 @@ redeem issue database (Redeem voucher tokens counter) =
throwError $ jsonErr err400 $ OtherFailure "fingerprint already used"
Left DatabaseUnavailable -> do
throwError $ jsonErr err500 $ OtherFailure "database temporarily unavailable"
- Right () -> do
+ Right fresh -> do
let result = issue tokens
case result of
Left reason -> do
diff --git a/test/Persistence.hs b/test/Persistence.hs
index 1f2cd6df0aaa22803656ddb3540f105f1166cc19..4afbb11204b170bc5a3146362e4769f2bddbad3c 100644
--- a/test/Persistence.hs
+++ b/test/Persistence.hs
@@ -94,7 +94,7 @@ makeVoucherPaymentTests label makeDatabase =
conn <- connect
() <- payForVoucher conn voucher paySuccessfully
result <- redeemVoucher conn voucher fingerprint
- assertEqual "redeeming paid voucher" (Right ()) result
+ assertEqual "redeeming paid voucher" (Right True) result
, testCase "allowed double redemption" $ do
connect <- makeDatabase
conn <- connect
@@ -102,8 +102,8 @@ makeVoucherPaymentTests label makeDatabase =
let redeem = redeemVoucher conn voucher fingerprint
first <- redeem
second <- redeem
- assertEqual "redeeming paid voucher" (Right ()) first
- assertEqual "re-redeeming paid voucher" (Right ()) second
+ assertEqual "redeeming paid voucher" (Right True) first
+ assertEqual "re-redeeming paid voucher" (Right False) second
, testCase "disallowed double redemption" $ do
connect <- makeDatabase
conn <- connect
@@ -111,7 +111,7 @@ makeVoucherPaymentTests label makeDatabase =
let redeem = redeemVoucher conn voucher
first <- redeem fingerprint
second <- redeem (Text.cons 'a' $ Text.tail fingerprint)
- assertEqual "redeeming paid voucher" (Right ()) first
+ assertEqual "redeeming paid voucher" (Right True) first
assertEqual "re-redeeming paid voucher" (Left AlreadyRedeemed) second
, testCase "allowed redemption varying by counter" $ do
connect <- makeDatabase
@@ -120,8 +120,8 @@ makeVoucherPaymentTests label makeDatabase =
let redeem = redeemVoucherWithCounter conn voucher
first <- redeem fingerprint 0
second <- redeem anotherFingerprint 1
- assertEqual "redeemed with counter 0" (Right ()) first
- assertEqual "redeemed with counter 1" (Right ()) second
+ assertEqual "redeemed with counter 0" (Right True) first
+ assertEqual "redeemed with counter 1" (Right True) second
, testCase "disallowed redemption varying by counter but not fingerprint" $ do
connect <- makeDatabase
conn <- connect
@@ -129,7 +129,7 @@ makeVoucherPaymentTests label makeDatabase =
let redeem = redeemVoucherWithCounter conn voucher
first <- redeem fingerprint 0
second <- redeem fingerprint 1
- assertEqual "redeemed with counter 0" (Right ()) first
+ assertEqual "redeemed with counter 0" (Right True) first
assertEqual "redeemed with counter 1" (Left DuplicateFingerprint) second
, testCase "pay with exception" $ do
connect <- makeDatabase
@@ -146,7 +146,7 @@ makeVoucherPaymentTests label makeDatabase =
payResult <- try pay
assertEqual "double-paying for a voucher" (Left AlreadyPaid) payResult
redeemResult <- redeemVoucher conn voucher fingerprint
- assertEqual "redeeming double-paid voucher" (Right ()) redeemResult
+ assertEqual "redeeming double-paid voucher" (Right True) redeemResult
, testCase "concurrent payment" $ do
connect <- makeDatabase
connA <- connect
@@ -178,7 +178,7 @@ makeVoucherPaymentTests label makeDatabase =
withAsync anotherRedeem $ \r2 -> do
waitBoth r1 r2
- assertEqual "Both redemptions should succeed" (Right (), Right ()) result
+ assertEqual "Both redemptions should succeed" (Right True, Right True) result
]
-- | Instantiate the persistence tests for the memory backend.