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..ad731dbe38e709f3099159c22698cf9a50a7436f 100644
--- a/src/PaymentServer/Redemption.hs
+++ b/src/PaymentServer/Redemption.hs
@@ -24,7 +24,9 @@ import Control.Retry
, constantDelay
, limitRetries
)
-
+import Control.Monad
+ ( when
+ )
import Control.Monad.IO.Class
( liftIO
)
@@ -67,6 +69,7 @@ import Crypto.Hash
( SHA3_512(SHA3_512)
, hashWith
)
+import qualified Prometheus as P
import PaymentServer.Persistence
( VoucherDatabase(redeemVoucherWithCounter)
, RedeemError(NotPaid, AlreadyRedeemed, DuplicateFingerprint, DatabaseUnavailable)
@@ -170,7 +173,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
@@ -195,10 +198,8 @@ redeem issue database (Redeem voucher tokens counter) =
if counter < 0 || counter >= maxCounter then
throwError $ jsonErr err400 (CounterOutOfBounds 0 maxCounter counter)
else do
-
- let fingerprint = fingerprintFromTokens tokens
- result <- liftIO . retry $ redeemVoucherWithCounter database voucher fingerprint counter
- case result of
+ redeemResult <- liftIO . retry $ redeem
+ case redeemResult of
Left NotPaid -> do
throwError $ jsonErr err400 Unpaid
Left AlreadyRedeemed -> do
@@ -207,13 +208,35 @@ 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
throwError $ jsonErr err400 $ OtherFailure reason
- Right (ChallengeBypass key signatures proof) ->
+ Right (ChallengeBypass key signatures proof) -> do
+ let count = fromInteger . toInteger . length $ signatures
+ -- addCounter returns bool indicating whether its argument was
+ -- greater than or equal to zero or not. We don't care. length
+ -- is greater than or equal to zero.
+ liftIO . when fresh $ (P.addCounter signaturesIssued count >>= \_ -> return ())
return $ Succeeded key signatures proof
+ where
+ fingerprint = fingerprintFromTokens tokens
+ redeem :: IO (Either RedeemError Bool)
+ redeem = redeemVoucherWithCounter database voucher fingerprint counter
+
+
+metricName :: Text -> Text
+metricName name = mappend "redemption." name
+
+
+signaturesIssued :: P.Counter
+signaturesIssued
+ = P.unsafeRegister
+ $ P.counter
+ $ P.Info (metricName "signatures_issued")
+ "The number of unique signatures which have been issued to clients."
+
-- | Compute a cryptographic hash (fingerprint) of a list of tokens which can
-- be used as an identifier for this exact sequence of tokens.
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.