From c5240ad31225fdb482713f8799016bde87ffcc2f Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Wed, 3 Jun 2020 10:58:24 -0400
Subject: [PATCH] Take a shot at this with the `retrying` function
---
PaymentServer.cabal | 1 +
nix/PaymentServer.nix | 1 +
src/PaymentServer/Redemption.hs | 29 ++++++++++++++++++++++++++++-
3 files changed, 30 insertions(+), 1 deletion(-)
diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 8e6fee7..2db7528 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -42,6 +42,7 @@ library
, containers
, cryptonite
, sqlite-simple
+ , retry
default-language: Haskell2010
ghc-options: -Wmissing-import-lists -Wunused-imports
pkgconfig-depends: libchallenge_bypass_ristretto_ffi
diff --git a/nix/PaymentServer.nix b/nix/PaymentServer.nix
index 5416280..af085ed 100644
--- a/nix/PaymentServer.nix
+++ b/nix/PaymentServer.nix
@@ -76,6 +76,7 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
(hsPkgs."containers" or (buildDepError "containers"))
(hsPkgs."cryptonite" or (buildDepError "cryptonite"))
(hsPkgs."sqlite-simple" or (buildDepError "sqlite-simple"))
+ (hsPkgs."retry" or (buildDepError "retry"))
];
pkgconfig = [
(pkgconfPkgs."libchallenge_bypass_ristretto_ffi" or (pkgConfDepError "libchallenge_bypass_ristretto_ffi"))
diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs
index 701677d..ca7ec93 100644
--- a/src/PaymentServer/Redemption.hs
+++ b/src/PaymentServer/Redemption.hs
@@ -14,6 +14,13 @@ module PaymentServer.Redemption
import GHC.Generics
( Generic
)
+
+import Control.Retry
+ ( retrying
+ , constantDelay
+ , limitRetries
+ )
+
import Control.Monad.IO.Class
( liftIO
)
@@ -155,6 +162,25 @@ jsonErr400 reason = err400
redemptionServer :: VoucherDatabase d => Issuer -> d -> Server RedemptionAPI
redemptionServer = redeem
+-- | Try an operation repeatedly for several minutes with a brief delay
+-- between tries.
+retry :: IO (Either RedeemError()) -> IO (Either RedeemError())
+retry op =
+ retrying policy shouldRetry (\_ -> op)
+ where
+ -- Total duration for which to retry in milliseconds.
+ totalRetryDuration = 3 * 60 * 1000
+ -- Time to delay between each try in milliseconds.
+ perRetryDelay = 500
+ -- Limit on the number of retries.
+ numRetries = totalRetryDuration `div` totalRetryDuration
+
+ policy = constantDelay (perRetryDelay * 1000) <> limitRetries numRetries
+ shouldRetry status value =
+ case value of
+ Left NotPaid -> return True
+ _ -> return False
+
-- | Handler for redemption requests. Use the database to try to redeem the
-- voucher and return signatures. Return a failure if this is not possible
-- (eg because the voucher was already redeemed).
@@ -163,8 +189,9 @@ redeem issue database (Redeem voucher tokens counter) =
if counter < 0 || counter >= maxCounter then
throwError $ jsonErr400 (CounterOutOfBounds 0 maxCounter counter)
else do
+
let fingerprint = fingerprintFromTokens tokens
- result <- liftIO $ redeemVoucherWithCounter database voucher fingerprint counter
+ result <- liftIO . retry $ redeemVoucherWithCounter database voucher fingerprint counter
case result of
Left NotPaid -> do
throwError $ jsonErr400 Unpaid
--
GitLab