core: credit store receipts from a standard work queue

apps/ios/Shared/Views/Badges/BadgeStore.swift

@@ -109,8 +109,8 @@ final class BadgeStore: ObservableObject {
     // kept for this run only: StoreKit lists no deferred purchase, and a declined one delivers nothing
     // by invoice id, so a pending purchase shows only under the profile whose record it names
     @Published private var waitingForApproval: Set<String> = []
-    // set when the first sweep has returned, which is after every transaction the store holds was handed
-    // to core - until then a purchase made while the app was not running is unknown
+    // set once presentUnfinished has read the store: until then, an Ask to Buy approved while the app was
+    // closed, or a purchase it died before handing over, are both unknown, so canBuy refuses to buy again
     @Published private var reconciledOnce = false
     // purchases the user started this run, by transaction: the store is not relied on to echo the invoice back
     private var awaitedTransactions: Set<UInt64> = []

apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt

@@ -156,8 +156,8 @@ object BadgeStore {
   private val buying = mutableStateOf(false)
   // by invoice id, so a pending purchase shows only under the profile whose record it names
   private val waitingForApproval = mutableStateOf<Set<String>>(emptySet())
-  // set when the first sweep has returned or failed, which is after every purchase the store holds was handed
-  // to core - until then a purchase made while the app was not running is unknown
+  // set once presentUnfinished has read the store, or failed to: until then, a slow payment completed while
+  // the app was closed, or a purchase it died before handing over, are both unknown, so canBuy refuses
   private val reconciledOnce = mutableStateOf(false)
   // purchases the user started this run, by token: the store is not relied on to echo the invoice back
   private val awaitedTransactions = mutableSetOf<String>()

src/Simplex/Chat/Controller.hs

@@ -294,6 +294,11 @@ data BadgeWorker = BadgeWorker
     badgeWork :: TMVar ()
   }
 
+data StoreReceiptWorker = StoreReceiptWorker
+  { receiptWorker :: Worker,
+    parkedReceipts :: TVar (Set Int64)
+  }
+
 data ChatController = ChatController
   { currentUser :: TVar (Maybe User),
     randomPresetServers :: NonEmpty PresetOperator,
@@ -328,7 +333,7 @@ data ChatController = ChatController
     relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework
     -- one badge worker per user: badge state is per profile, and one profile must not stall another
     badgeWorkers :: TMap UserId (SessionVar BadgeWorker),
-    storeReceiptWorkers :: TMap UserId (SessionVar BadgeWorker),
+    storeReceiptWorkers :: TMap UserId StoreReceiptWorker,
     badgeSeq :: TVar Int,
     relayGroupLinkChecksAsync :: TVar (Maybe (Async ())),
     webPreviewState :: Maybe WebPreviewState,

src/Simplex/Chat/Library/Commands.hs

@@ -105,9 +105,10 @@ import qualified Simplex.Chat.Util as U
 import Simplex.Chat.Web (webPreviewWorker)
 import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSizeHard)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
+import Simplex.Messaging.Agent.Client (getAgentWorker', hasWorkToDo, waitForUserNetwork, waitForWork, waitWhileSuspended, withWork_)
+import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), Worker (..), allRoles)
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay, withRetryInterval)
+import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), withRetryInterval)
 import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Agent.Store.Interface (execSQL)
 import Simplex.Messaging.Agent.Store.Shared (upMigration)
@@ -263,7 +264,7 @@ startChatController mainApp enableSndFiles serviceRequests = do
           startRelayRequestWorker_
           startCleanupManager
           mapM_ startBadgeWork users
-          mapM_ startStoreReceiptWork users
+          startStoreReceiptWorkers users
           void $ forkIO $ mapM_ startExpireCIs users
           startRelayChecks users
           startWebPreview users
@@ -282,6 +283,10 @@ startChatController mainApp enableSndFiles serviceRequests = do
       runExceptT startRelayRequestWorker >>= \case
         Left e -> liftIO $ putStrLn $ "Error starting relay request worker: " <> show e
         Right _ -> pure ()
+    startStoreReceiptWorkers users =
+      runExceptT (mapM_ startStoreReceiptWork users) >>= \case
+        Left e -> liftIO $ putStrLn $ "Error starting store receipt workers: " <> show e
+        Right _ -> pure ()
     startCleanupManager = do
       cleanupAsync <- asks cleanupManagerAsync
       readTVarIO cleanupAsync >>= \case
@@ -374,7 +379,7 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles,
   clearMap deliveryJobWorkers >>= mapM_ cancelWorker
   clearMap relayRequestWorkers >>= mapM_ cancelWorker
   stopBadgeWorkers badgeWorkers
-  stopBadgeWorkers storeReceiptWorkers
+  clearMap storeReceiptWorkers >>= mapM_ (cancelWorker . receiptWorker)
   closeFiles sndFiles
   closeFiles rcvFiles
   atomically $ do
@@ -607,7 +612,7 @@ processChatCommand cxt nm = \case
         void . forkIO $ startFilesToReceive users
         setAllExpireCIFlags True
         mapM_ startBadgeWork users
-        mapM_ startStoreReceiptWork users
+      mapM_ startStoreReceiptWork users
     ok_
   APISuspendChat t -> do
     chatWriteVar chatActivated False
@@ -5269,9 +5274,9 @@ handOverStoreReceipt presentingUser echoedInvoiceId payment = do
   (StoreReceipt {ownerId, status}, newlyHeld) <-
     withStore' (\db -> holdStoreReceipt db g presentingUser echoedInvoiceId txRef payment now)
       >>= maybe (throwChatError $ CEInternalError "store receipt was not recorded") pure
-  owner <- withStore $ \db -> getUser db ownerId
   -- before the answer, which can throw: no later hand-over of this receipt signals, and a spare signal costs an empty pass
-  when newlyHeld $ lift $ startStoreReceiptWork owner
+  when newlyHeld $ lift $ resumeStoreReceiptWork ownerId
+  owner <- withStore $ \db -> getUser db ownerId
   case status of
     RSHeld -> badgeStateResponse owner
     RSCredited {badgePurchaseId} -> do
@@ -5348,23 +5353,20 @@ badgeNow = asks (badgeCurrentTime . config) >>= liftIO
 -- | A signal carries nothing: each pass derives its work from stored state, so a signal lost or
 -- duplicated changes no outcome.
 startBadgeWork :: User -> CM' ()
-startBadgeWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker badgeWorkers runBadgeWorker user
-
-startStoreReceiptWork :: User -> CM' ()
-startStoreReceiptWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker storeReceiptWorkers runStoreReceiptWorker user
+startBadgeWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker user
 
 -- | Exactly one caller starts the thread and the rest wait for it: the lookup and the create cannot
 -- be one transaction, because starting a thread is not STM.
-getBadgeWorker :: (ChatController -> TM.TMap UserId (SessionVar BadgeWorker)) -> (UserId -> TMVar () -> CM ()) -> User -> CM' BadgeWorker
-getBadgeWorker workers runWorker User {userId} = do
-  ws <- asks workers
+getBadgeWorker :: User -> CM' BadgeWorker
+getBadgeWorker User {userId} = do
+  ws <- asks badgeWorkers
   seq' <- asks badgeSeq
   now <- liftIO getCurrentTime
   withGetSessVar' seq' userId ws now startWorker signalWorker
   where
     startWorker v = do
       badgeWork <- newEmptyTMVarIO
-      badgeWorkerAsync <- async $ void $ runExceptT $ runWorker userId badgeWork
+      badgeWorkerAsync <- async $ void $ runExceptT $ runBadgeWorker userId badgeWork
       let w = BadgeWorker {badgeWorkerAsync, badgeWork}
       w <$ atomically (putTMVar (sessionVar v) w)
     signalWorker v = do
@@ -5434,46 +5436,74 @@ waitBadgeWake badgeWork now = \case
 badgeMaxWake :: NominalDiffTime
 badgeMaxWake = 100 * 365 * nominalDay
 
--- | The only sender of held store receipts; each row's next_attempt_at is when it is tried again. The
--- wait is floored, so a row still due because its outcome could not be written does not spin the worker.
-runStoreReceiptWorker :: UserId -> TMVar () -> CM ()
-runStoreReceiptWorker userId work = forever $ do
-  lift waitChatStartedAndActivated
-  nextAt_ <- creditStoreReceipts userId `catchAllErrors` \e -> eToView e >> Just <$> badgeNow
-  now <- badgeNow
-  ri <- asks $ badgeRetryInterval . config
-  liftIO $ waitBadgeWake work now $ max (retryFloor ri `addUTCTime` now) <$> nextAt_
+startStoreReceiptWork :: User -> CM ()
+startStoreReceiptWork User {userId} = do
+  due <- withStore' $ \db -> getNextDueStoreReceipt db userId S.empty
+  when (either (const False) isJust due) $ lift $ resumeStoreReceiptWork userId
 
--- | The due rows are read once, so a pass tries each at most once.
-creditStoreReceipts :: UserId -> CM (Maybe UTCTime)
-creditStoreReceipts userId = do
-  now <- badgeNow
-  due <- withStore' $ \db -> getDueStoreReceipts db userId now
-  forM_ due $ \r -> creditStoreReceipt userId r `catchAllErrors` eToView
-  withStore' (`getNextStoreReceiptAttempt` userId)
+resumeStoreReceiptWork :: UserId -> CM' ()
+resumeStoreReceiptWork userId = do
+  StoreReceiptWorker {receiptWorker, parkedReceipts} <- getStoreReceiptWorker userId
+  atomically $ writeTVar parkedReceipts S.empty >> hasWorkToDo receiptWorker
 
-data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused | SRODeferred
+getStoreReceiptWorker :: UserId -> CM' StoreReceiptWorker
+getStoreReceiptWorker userId = do
+  ws <- asks storeReceiptWorkers
+  a <- asks smpAgent
+  getAgentWorker' receiptWorker newStoreReceiptWorker "store_receipt" False a userId ws $
+    runStoreReceiptWorker a userId
+  where
+    newStoreReceiptWorker w = StoreReceiptWorker w <$> newTVar S.empty
+
+runStoreReceiptWorker :: AgentClient -> UserId -> StoreReceiptWorker -> CM ()
+runStoreReceiptWorker a userId StoreReceiptWorker {receiptWorker = Worker {doWork}, parkedReceipts} =
+  forever $ do
+    lift $ waitForWork doWork
+    withWork_ a doWork getNextReceipt $ \r@HeldStoreReceipt {receiptId} ->
+      (creditStoreReceipt a userId r `catchAllErrors` \e -> False <$ eToView e) >>= \case
+        True -> pure ()
+        -- unlike the agent's workers, a final failure keeps the row: the purchase is paid for, so the next trigger tries it again
+        False -> atomically $ modifyTVar' parkedReceipts $ S.insert receiptId
+  where
+    getNextReceipt = do
+      parked <- readTVarIO parkedReceipts
+      withStore' $ \db -> getNextDueStoreReceipt db userId parked
+
+data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused | SRORetry (Maybe Word32) | SROFailed
 
 -- | Under the owner's badge lock, which keeps a profile's requests to the service serial.
-creditStoreReceipt :: UserId -> HeldStoreReceipt -> CM ()
-creditStoreReceipt userId HeldStoreReceipt {receiptId, stash = stash@BadgeStash {masterKey}, payment, retryDelay} = do
-  outcome <- withEntityLock "badgePurchase" (CLBadgeUser userId) $
-    tryAllErrors attempt >>= \case
-      Right (Right (present_, _)) -> pure $ SROCredited present_
-      Right (Left (code, retryAfter))
-        | storeReceiptRefused code -> SRORefused <$ withStore' (\db -> refuseStoreReceipt db receiptId $ serviceFailure code retryAfter)
-        | otherwise -> SRODeferred <$ defer (serviceFailure code retryAfter) retryAfter
-      Left e -> SRODeferred <$ defer (badgeIssueFailure e) Nothing
-  -- only a settlement is announced, and the app's sweep in answer signals this worker only for a newly held receipt, so it cannot loop
-  case outcome of
-    SROCredited present_ -> do
-      user <- withStore $ \db -> getUser db userId
-      toView . CEvtBadgeChanged user =<< getUserBadgeState user
-      toView $ CEvtStorePurchaseSettled user
-      -- last, so a failed broadcast cannot lose the settlement; outside the badge lock, as it takes the chat lock
-      mapM_ presentUserBadgeToContacts present_
-    SRORefused -> withStore (`getUser` userId) >>= toView . CEvtStorePurchaseSettled
-    SRODeferred -> pure ()
+creditStoreReceipt :: AgentClient -> UserId -> HeldStoreReceipt -> CM Bool
+creditStoreReceipt a userId HeldStoreReceipt {receiptId, stash = stash@BadgeStash {masterKey}, payment, retryDelay} = do
+  ri <- asks $ badgeRetryInterval . config
+  notBefore <- newTVarIO Nothing
+  withRetryInterval (maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) retryDelay) $ \delay loop -> do
+    liftIO $ waitWhileSuspended a
+    liftIO $ waitForUserNetwork a
+    now <- badgeNow
+    readTVarIO notBefore >>= \case
+      Just at | now < at -> loop
+      _ -> do
+        outcome <- withEntityLock "badgePurchase" (CLBadgeUser userId) $
+          tryAllErrors attempt >>= \case
+            Right (Right (present_, _)) -> pure $ SROCredited present_
+            Right (Left (code, retryAfter))
+              | storeReceiptRefused code -> SRORefused <$ withStore' (\db -> refuseStoreReceipt db receiptId $ serviceFailure code retryAfter)
+              | otherwise -> failed delay (serviceFailure code retryAfter) retryAfter
+            Left e -> failed delay (badgeIssueFailure e) Nothing
+        -- only a settlement is announced, and the app's sweep in answer signals this worker only for a newly held receipt, so it cannot loop
+        case outcome of
+          SROCredited present_ -> do
+            user <- withStore $ \db -> getUser db userId
+            toView . CEvtBadgeChanged user =<< getUserBadgeState user
+            toView $ CEvtStorePurchaseSettled user
+            -- last, so a failed broadcast cannot lose the settlement; outside the badge lock, as it takes the chat lock
+            mapM_ presentUserBadgeToContacts present_
+            pure True
+          SRORefused -> True <$ (withStore (`getUser` userId) >>= toView . CEvtStorePurchaseSettled)
+          SRORetry retryAfter_ -> do
+            atomically $ writeTVar notBefore $ (`addUTCTime` now) . fromIntegral <$> retryAfter_
+            loop
+          SROFailed -> pure False
   where
     attempt = do
       user <- withStore $ \db -> getUser db userId
@@ -5482,21 +5512,9 @@ creditStoreReceipt userId HeldStoreReceipt {receiptId, stash = stash@BadgeStash
       payment' <- maybe (throwChatError $ CEInternalError "held store payment does not decode") pure $ decodeJSON payment
       requestBadgeStash NRMBackground user sendTarget stash BSCPurchaseBadge {masterKey, payment = payment', upgrade = Nothing}
     serviceFailure code retryAfter = BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter}
-    defer failure retryAfter = do
-      ri <- asks $ badgeRetryInterval . config
-      now <- badgeNow
-      let (delay, retryDelay') = storeReceiptRetry ri failure retryAfter retryDelay
-      withStore' $ \db -> deferStoreReceipt db receiptId (delay `addUTCTime` now) retryDelay' failure
-
--- | The service's retryAfter when given; otherwise a failure that can clear grows its own delay, and any
--- other waits a day. Unlike a renewal, an answered internal grows too: a buyer is watching the purchase.
-storeReceiptRetry :: RetryInterval -> BadgeIssueFailure -> Maybe Word32 -> Maybe Int64 -> (NominalDiffTime, Maybe Int64)
-storeReceiptRetry ri@RetryInterval {initialInterval} failure retryAfter retryDelay
-  | isJust retryAfter = (badgeRetryAfter ri retryAfter, retryDelay)
-  | badgeFailureTransient failure = (fromIntegral delay / 1000000, Just delay)
-  | otherwise = (badgeStalledInterval, retryDelay)
-  where
-    delay = maybe initialInterval (\d -> nextRetryDelay 0 d ri) retryDelay
+    failed delay failure retryAfter = do
+      withStore' $ \db -> recordStoreReceiptFailure db receiptId delay failure
+      pure $ if badgeFailureTransient failure then SRORetry retryAfter else SROFailed
 
 -- | Retire what has ended, renew what is due, then report the next wake. Waking early, late or not
 -- at all changes only timing: each run reads stored state and works out what to do.

src/Simplex/Chat/Store/Badges.hs

@@ -26,9 +26,8 @@ module Simplex.Chat.Store.Badges
     holdStoreReceipt,
     createBadgeStoreReceipt,
     getOpenStorePurchases,
-    getDueStoreReceipts,
-    getNextStoreReceiptAttempt,
-    deferStoreReceipt,
+    getNextDueStoreReceipt,
+    recordStoreReceiptFailure,
     refuseStoreReceipt,
     deleteUnfundedStoreReceipts,
     deleteBadgeCodeRedemption,
@@ -50,7 +49,10 @@ import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
+import Data.List (find)
 import Data.Maybe (isJust, mapMaybe)
+import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Badges
@@ -59,7 +61,7 @@ import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType
 import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..), OpenStorePurchase (..))
 import Simplex.Chat.PaymentService (ServicePayment)
 import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..))
-import Simplex.Chat.Store.Shared (insertedRowId)
+import Simplex.Chat.Store.Shared (StoreError, insertedRowId)
 import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Protocol (UserId)
 import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
@@ -139,8 +141,8 @@ holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provid
       forM_ invoiceId_ $ \invoiceId ->
         DB.execute
           db
-          "UPDATE badge_store_receipts SET provider = ?, transaction_ref = ?, payment = ?, next_attempt_at = ? WHERE invoice_id = ? AND transaction_ref IS NULL"
-          (provider, transactionRef, paymentJSON, now, invoiceId)
+          "UPDATE badge_store_receipts SET provider = ?, transaction_ref = ?, payment = ? WHERE invoice_id = ? AND transaction_ref IS NULL"
+          (provider, transactionRef, paymentJSON, invoiceId)
       getStoreReceipt db txRef >>= \case
         Just r -> pure $ Just (r, True)
         Nothing -> do
@@ -160,11 +162,11 @@ holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provid
         db
         [sql|
           INSERT INTO badge_store_receipts
-            (user_id, invoice_id, provider, transaction_ref, payment, next_attempt_at, purchase_key, purchase_priv_key, master_key, created_at)
-          VALUES (?,?,?,?,?,?,?,?,?,?)
+            (user_id, invoice_id, provider, transaction_ref, payment, purchase_key, purchase_priv_key, master_key, created_at)
+          VALUES (?,?,?,?,?,?,?,?,?)
           ON CONFLICT DO NOTHING
         |]
-        ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, now))
+        ((userId, invoiceId', provider, transactionRef, paymentJSON) :. (purchaseKey, purchasePrivKey, Binary mk, now))
 
 -- | held is a CASE because in Postgres a comparison is boolean, which BoolInt rejects.
 getStoreReceipt :: DB.Connection -> StoreTransactionRef -> IO (Maybe StoreReceipt)
@@ -219,48 +221,35 @@ data HeldStoreReceipt = HeldStoreReceipt
     retryDelay :: Maybe Int64
   }
 
--- | Due only from next_attempt_at, so a pass a signal starts cannot send a deferred receipt early.
-getDueStoreReceipts :: DB.Connection -> UserId -> UTCTime -> IO [HeldStoreReceipt]
-getDueStoreReceipts db userId now =
-  map toHeld
+getNextDueStoreReceipt :: DB.Connection -> UserId -> Set Int64 -> IO (Either StoreError (Maybe HeldStoreReceipt))
+getNextDueStoreReceipt db userId parked =
+  Right . find notParked . map toHeld
     <$> DB.query
       db
       [sql|
         SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.payment, r.retry_delay
         FROM badge_store_receipts r
         JOIN users u ON u.user_id = r.user_id
-        WHERE r.user_id = ? AND r.payment IS NOT NULL AND r.next_attempt_at <= ? AND u.shown_badge_id IS NULL
-        ORDER BY r.next_attempt_at
+        WHERE r.user_id = ? AND r.payment IS NOT NULL AND u.shown_badge_id IS NULL
+        ORDER BY r.badge_store_receipt_id
       |]
-      (userId, now)
+      (Only userId)
   where
+    notParked HeldStoreReceipt {receiptId} = receiptId `S.notMember` parked
     toHeld (stashRow@(receiptId, _, _, _) :. (payment, retryDelay)) =
       HeldStoreReceipt {receiptId, stash = toBadgeStash BSRStoreReceipt stashRow, payment, retryDelay}
 
-getNextStoreReceiptAttempt :: DB.Connection -> UserId -> IO (Maybe UTCTime)
-getNextStoreReceiptAttempt db userId =
-  fmap join . maybeFirstRow fromOnly $
-    DB.query
-      db
-      [sql|
-        SELECT MIN(r.next_attempt_at)
-        FROM badge_store_receipts r
-        JOIN users u ON u.user_id = r.user_id
-        WHERE r.user_id = ? AND r.payment IS NOT NULL AND u.shown_badge_id IS NULL
-      |]
-      (Only userId)
-
-deferStoreReceipt :: DB.Connection -> Int64 -> UTCTime -> Maybe Int64 -> BadgeIssueFailure -> IO ()
-deferStoreReceipt db receiptId nextAttemptAt retryDelay failure =
+recordStoreReceiptFailure :: DB.Connection -> Int64 -> Int64 -> BadgeIssueFailure -> IO ()
+recordStoreReceiptFailure db receiptId retryDelay failure =
   DB.execute
     db
-    "UPDATE badge_store_receipts SET next_attempt_at = ?, retry_delay = ?, credit_error = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL"
-    (nextAttemptAt, retryDelay, failure, receiptId)
+    "UPDATE badge_store_receipts SET retry_delay = ?, credit_error = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL"
+    (retryDelay, failure, receiptId)
 
 -- | Kept rather than deleted, so that a later hand-over of the same transaction is answered from the record.
 refuseStoreReceipt :: DB.Connection -> Int64 -> BadgeIssueFailure -> IO ()
 refuseStoreReceipt db receiptId refusal =
-  DB.execute db "UPDATE badge_store_receipts SET payment = NULL, credit_error = ? WHERE badge_store_receipt_id = ?" (refusal, receiptId)
+  DB.execute db "UPDATE badge_store_receipts SET payment = NULL, retry_delay = NULL, credit_error = ? WHERE badge_store_receipt_id = ?" (refusal, receiptId)
 
 -- | A held record is paid for and a credited one is referenced by its purchase, so neither is deleted.
 deleteUnfundedStoreReceipts :: DB.Connection -> UTCTime -> IO ()
@@ -296,7 +285,7 @@ deleteBadgeCodeRedemption db User {userId} code =
 createStashBadgePurchase :: DB.Connection -> User -> BadgeStash -> BadgeCredential -> UTCTime -> IO (Int64, Bool)
 createStashBadgePurchase db User {userId} stash credential now = do
   -- the credit settles a held receipt in the transaction that stores its purchase, a replay included
-  forM_ storeReceiptId_ $ \storeReceiptId -> DB.execute db "UPDATE badge_store_receipts SET payment = NULL WHERE badge_store_receipt_id = ?" (Only storeReceiptId)
+  forM_ storeReceiptId_ $ \storeReceiptId -> DB.execute db "UPDATE badge_store_receipts SET payment = NULL, retry_delay = NULL WHERE badge_store_receipt_id = ?" (Only storeReceiptId)
   getStashBadgePurchase db stash >>= \case
     Just purchaseId -> pure (purchaseId, False)
     Nothing -> do

src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs

@@ -24,7 +24,6 @@ CREATE TABLE badge_store_receipts(
   master_key BYTEA NOT NULL,
   created_at TIMESTAMPTZ NOT NULL,
   payment TEXT,
-  next_attempt_at TIMESTAMPTZ,
   retry_delay BIGINT,
   credit_error TEXT,
   UNIQUE(provider, transaction_ref)

src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql

@@ -307,7 +307,6 @@ CREATE TABLE test_chat_schema.badge_store_receipts (
     master_key bytea NOT NULL,
     created_at timestamp with time zone NOT NULL,
     payment text,
-    next_attempt_at timestamp with time zone,
     retry_delay bigint,
     credit_error text
 );

src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs

@@ -23,7 +23,6 @@ CREATE TABLE badge_store_receipts(
   master_key BLOB NOT NULL,
   created_at TEXT NOT NULL,
   payment TEXT,
-  next_attempt_at TEXT,
   retry_delay INTEGER,
   credit_error TEXT,
   UNIQUE(provider, transaction_ref)

src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql

@@ -993,7 +993,6 @@ CREATE TABLE badge_store_receipts(
   master_key BLOB NOT NULL,
   created_at TEXT NOT NULL,
   payment TEXT,
-  next_attempt_at TEXT,
   retry_delay INTEGER,
   credit_error TEXT,
   UNIQUE(provider, transaction_ref)

tests/Bots/BadgeService/BotTests.hs

@@ -18,7 +18,7 @@ import BadgeService.Options
 import BadgeService.Service
 import BadgeService.Store (NewStorePurchase (..), createStorePurchase)
 import BadgeService.Store.Invoices (markCodePaid)
-import BadgeService.StoreReceipts (StoreVerifier, noStoreVerifier)
+import BadgeService.StoreReceipts (StoreRefusal (..), StoreVerifier (..), noStoreVerifier)
 import Simplex.Messaging.Agent.Store.DB (Binary (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import ChatClient
@@ -39,6 +39,7 @@ import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
 import Data.List (isPrefixOf, stripPrefix)
 import qualified Data.Map.Strict as M
 import Data.Maybe (isJust, isNothing)
+import qualified Data.Set as S
 import Data.String (fromString)
 import System.Timeout (timeout)
 import Data.Text (Text)
@@ -57,7 +58,7 @@ import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
 import Simplex.Chat.PaymentService (ServicePayment (..))
 import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..))
-import Simplex.Chat.Store.Badges (getDueStoreReceipts, getNextStoreReceiptAttempt)
+import Simplex.Chat.Store.Badges (getNextDueStoreReceipt)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
@@ -153,14 +154,13 @@ badgeServiceTests = do
     it "should refuse an invoice with no service configured or while a badge is held, creating no record" testInvoiceRefusedBeforeCharge
     it "should hold a receipt for an invoice while a badge is held, without attempting it" testInvoiceWhileBadgeHeld
     it "should list only the asking profile's open store purchases" testInvoiceStateOtherProfile
-    it "should credit a receipt the store could not verify once its retryAfter has passed, with no second hand-over" testStoreReceiptRetried
-    it "should send nothing for a deferred receipt handed over again before it is due" testStoreReceiptNotSentEarly
-    it "should retry a receipt with no verifier a day later, and never drop it" testStoreReceiptRetriedDaily
+    it "should credit a receipt the store could not verify once its retryAfter has passed, with no trigger at all" testStoreReceiptRetried
+    it "should keep a receipt with no verifier held, and attempt it again only on the next trigger" testStoreReceiptRetriedOnTrigger
     it "should answer a refused receipt from the record, sending nothing, and not list it" testStoreRefusalKept
     it "should announce a settlement to an owner that is not active, and print nothing for a hidden one" testStoreSettledOtherProfile
     it "should resolve one new transaction handed over twice at once to one record" testStoreReceiptTwoAtOnce
     it "should delete a month-old record that will fund no badge, and keep held and credited ones" testStoreReceiptCleanup
-    it "should defer a receipt whose attempt throws, and not send it again in the pass" testStoreReceiptAttemptThrows
+    it "should keep a receipt whose attempt throws, sending nothing" testStoreReceiptAttemptThrows
 
 badgeProfile :: Profile
 badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing}
@@ -1592,32 +1592,28 @@ testStoreVerifiedOtherTransaction ps =
 
 testStoreQuantityRefused :: HasCallStack => TestParams -> IO ()
 testStoreQuantityRefused ps =
-  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = FakeStore {appleQuantityJWS}} -> do
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = FakeStore {appleQuantityJWS}} -> do
     (purchaseKey, masterKey) <- newPurchaseKeys
     refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey SPApple {jws = appleQuantityJWS}) `shouldReturn` (BSEInternal, Nothing)
     nothingPurchased cc
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
-      since <- testClockTime bsClock
       alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleQuantityJWS})
       storePurchaseOpen alice ""
-      (at, failure) <- waitStoreReceiptDeferred (chatController alice) since
-      failure `shouldBe` "service_error final internal"
-      at `shouldSatisfy` (< addUTCTime 60 since)
+      waitStoreReceiptError (chatController alice) "service_error final internal"
       heldStoreReceipts (chatController alice) `shouldReturn` 1
     nothingPurchased cc
 
 testPurchaseWithNoVerifier :: HasCallStack => TestParams -> IO ()
 testPurchaseWithNoVerifier ps =
-  withBadgeServiceVerifier ps (const noStoreVerifier) $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} -> do
+  withBadgeServiceVerifier ps (const noStoreVerifier) $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc} -> do
     (purchaseKey, masterKey) <- newPurchaseKeys
     refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey supporterPlay) `shouldReturn` (BSEProviderNotConfigured, Nothing)
     nothingPurchased cc
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
-      since <- testClockTime bsClock
       alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
       storePurchaseOpen alice ""
       -- not yet rather than never, so the receipt stays held for the retry once a verifier is deployed
-      snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error final provider_not_configured"
+      waitStoreReceiptError (chatController alice) "service_error final provider_not_configured"
       heldStoreReceipts (chatController alice) `shouldReturn` 1
       alice ##> "/_badge state 1"
       alice .<## ", not credited: service_error final provider_not_configured"
@@ -1716,7 +1712,7 @@ testPurchaseBadgeAppStore ps =
 testPurchaseStash :: HasCallStack => TestParams -> IO ()
 testPurchaseStash ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} ->
-    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+    withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do
       let records = rowCount (chatController alice) "badge_store_receipts"
           refused = "/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase")
       -- the store does not vouch for it, so it can never be credited, and the record says so
@@ -1732,12 +1728,12 @@ testPurchaseStash ps =
       records `shouldReturn` 1
       nothingPurchased cc
       -- pending keeps the receipt held, and the settled purchase is credited to its keys, once
-      since <- testClockTime bsClock
       alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken))
       storePurchaseOpen alice ""
-      snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error retry payment_pending"
+      waitStoreReceiptError (chatController alice) "service_error retry payment_pending"
       settlePending store
-      retryStoreReceiptsAfter alice bsClock 300 $ creditedLines "" "1: supporter"
+      passRetryAfter bsClock
+      mapM_ (alice <##.) $ creditedLines "" "1: supporter"
       records `shouldReturn` 2
       heldStoreReceipts (chatController alice) `shouldReturn` 0
       rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
@@ -1763,12 +1759,11 @@ testPurchaseStashReceiptUsed ps =
 
 testPurchaseUnsentPlayToken :: HasCallStack => TestParams -> IO ()
 testPurchaseUnsentPlayToken ps =
-  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} ->
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
-      since <- testClockTime bsClock
       alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "token/other"))
       storePurchaseOpen alice ""
-      snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error retry provider_unavailable"
+      waitStoreReceiptError (chatController alice) "service_error retry provider_unavailable"
       heldStoreReceipts (chatController alice) `shouldReturn` 1
       nothingPurchased cc
 
@@ -1781,7 +1776,7 @@ testPurchaseWhileBadgeHeld ps =
       alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
       alice <##. "1: supporter"
       storePurchaseOpen alice ""
-      selectableStoreReceipts (chatController alice) 1 `shouldReturn` (0, Nothing)
+      storeReceiptDue (chatController alice) 1 `shouldReturn` False
       heldStoreReceipts (chatController alice) `shouldReturn` 1
       rowCount cc "sx_badge_service_payments" `shouldReturn` 0
 
@@ -1803,19 +1798,19 @@ testPurchaseSameReceiptOtherProfile ps =
 testPurchaseStrandedUnderOtherProfile :: HasCallStack => TestParams -> IO ()
 testPurchaseStrandedUnderOtherProfile ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} ->
-    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+    withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do
       let unsettled userId = "/_badge purchase " <> show (userId :: Int) <> " " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken)
-      since <- testClockTime bsClock
       alice ##> unsettled 1
       storePurchaseOpen alice ""
-      _ <- waitStoreReceiptDeferred (chatController alice) since
+      waitStoreReceiptError (chatController alice) "service_error retry payment_pending"
       alice ##> "/create user alisa"
       showActiveUser alice "alisa"
       settlePending store
       -- handed over again under whichever profile is active, the purchase stays with the keys alice holds
       alice ##> unsettled 2
       storePurchaseOpen alice "[user: alice] "
-      retryStoreReceiptsAfter alice bsClock 300 $ creditedLines "[user: alice] " "1: supporter"
+      passRetryAfter bsClock
+      mapM_ (alice <##.) $ creditedLines "[user: alice] " "1: supporter"
       (alice </)
       rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1
       rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
@@ -1825,12 +1820,11 @@ testPurchaseStrandedUnderOtherProfile ps =
 testPurchaseDeliveredToHiddenProfile :: HasCallStack => TestParams -> IO ()
 testPurchaseDeliveredToHiddenProfile ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} ->
-    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+    withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do
       let unsettled userId = "/_badge purchase " <> show (userId :: Int) <> " " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken)
-      since <- testClockTime bsClock
       alice ##> unsettled 1
       storePurchaseOpen alice ""
-      _ <- waitStoreReceiptDeferred (chatController alice) since
+      waitStoreReceiptError (chatController alice) "service_error retry payment_pending"
       alice ##> "/create user alisa"
       showActiveUser alice "alisa"
       alice ##> "/_hide user 1 \"password\""
@@ -1841,7 +1835,7 @@ testPurchaseDeliveredToHiddenProfile ps =
       -- the answer and the credit are the hidden owner's, so the view prints none of them
       alice ##> unsettled 2
       (alice </)
-      retryStoreReceiptsAfter alice bsClock 300 []
+      passRetryAfter bsClock
       waitHeldStoreReceipts (chatController alice) 0
       (alice </)
       alice ##> "/user alice password"
@@ -1905,21 +1899,19 @@ testInvoiceAgedOut ps =
       unpaid <- createInvoice alice 1
       presented <- createInvoice alice 1
       refused <- createInvoice alice 1
-      since <- testClockTime clock
-      alice ##> purchaseWithInvoice 1 presented (googlePayment "badge_supporter_01" googlePendingToken)
-      alice <## ("store purchase open: invoice " <> unpaid)
-      alice <##. ("store purchase open: invoice " <> presented <> ", transaction ")
-      alice <## ("store purchase open: invoice " <> refused)
-      _ <- waitStoreReceiptDeferred (chatController alice) since
       alice ##> purchaseWithInvoice 1 refused (googlePayment "badge_supporter_01" "not-a-purchase")
       inAnyOrder
         alice
         [ [ "store purchase open: invoice " <> unpaid,
-            "store purchase open: invoice " <> presented <> ", transaction ",
+            "store purchase open: invoice " <> presented,
             "store purchase open: invoice " <> refused <> ", transaction "
           ],
           ["store purchase settled"]
         ]
+      alice ##> purchaseWithInvoice 1 presented (googlePayment "badge_supporter_01" googlePendingToken)
+      alice <## ("store purchase open: invoice " <> unpaid)
+      alice <##. ("store purchase open: invoice " <> presented <> ", transaction ")
+      waitStoreReceiptError (chatController alice) "service_error retry payment_pending"
       -- no age hides a record: one with no receipt and one held stay listed, and only a settled one goes
       getCurrentTime >>= setClockAt clock . addUTCTime (8 * nominalDay)
       alice ##> "/_badge state 1"
@@ -1951,7 +1943,7 @@ testInvoiceWhileBadgeHeld ps =
       alice ##> purchaseWithInvoice 1 invoiceId supporterPlay
       alice <##. "1: supporter"
       alice <##. ("store purchase open: invoice " <> invoiceId <> ", transaction ")
-      selectableStoreReceipts (chatController alice) 1 `shouldReturn` (0, Nothing)
+      storeReceiptDue (chatController alice) 1 `shouldReturn` False
       storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack invoiceId), True)]
       heldStoreReceipts (chatController alice) `shouldReturn` 1
       rowCount cc "sx_badge_service_payments" `shouldReturn` 0
@@ -1973,54 +1965,38 @@ testInvoiceStateOtherProfile ps =
       (alice </)
 
 testStoreReceiptRetried :: HasCallStack => TestParams -> IO ()
-testStoreReceiptRetried ps =
-  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} ->
-    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
-      setGoogleDown store True
-      since <- testClockTime bsClock
-      alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
-      storePurchaseOpen alice ""
-      (at, failure) <- waitStoreReceiptDeferred (chatController alice) since
-      failure `shouldBe` "service_error retry provider_unavailable"
-      at `shouldSatisfy` (> addUTCTime 290 since)
-      setGoogleDown store False
-      retryStoreReceiptsAfter alice bsClock 300 $ creditedLines "" "1: supporter"
-      rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
-
-testStoreReceiptNotSentEarly :: HasCallStack => TestParams -> IO ()
-testStoreReceiptNotSentEarly ps = do
+testStoreReceiptRetried ps = do
   hook <- newIORef (pure ())
   verifications <- countGoogleVerifications hook
-  withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} ->
-    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+  withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} ->
+    withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do
       setGoogleDown store True
-      let purchase = "/_badge purchase 1 " <> paymentArg supporterPlay
-      since <- testClockTime bsClock
-      alice ##> purchase
-      storePurchaseOpen alice ""
-      deferred <- waitStoreReceiptDeferred (chatController alice) since
-      verifications `shouldReturn` 1
-      alice ##> purchase
-      storePurchaseOpen alice ""
-      alice ##> "/_app activate"
-      alice <## "ok"
-      (alice </)
-      verifications `shouldReturn` 1
-      waitStoreReceiptDeferred (chatController alice) since `shouldReturn` deferred
-
-testStoreReceiptRetriedDaily :: HasCallStack => TestParams -> IO ()
-testStoreReceiptRetriedDaily ps =
-  withBadgeServiceVerifier ps (const noStoreVerifier) $ \BadgeServiceEnv {bsClientCfg, bsClock} ->
-    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
-      since <- testClockTime bsClock
       alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
       storePurchaseOpen alice ""
-      (firstAt, _) <- waitStoreReceiptDeferred (chatController alice) since
-      firstAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) since)
-      retryStoreReceiptsAfter alice bsClock nominalDay []
-      (secondAt, failure) <- waitStoreReceiptDeferred (chatController alice) firstAt
-      failure `shouldBe` "service_error final provider_not_configured"
-      secondAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) firstAt)
+      waitStoreReceiptError (chatController alice) "service_error retry provider_unavailable"
+      setGoogleDown store False
+      threadDelay 1000000
+      verifications `shouldReturn` 1
+      passRetryAfter bsClock
+      mapM_ (alice <##.) $ creditedLines "" "1: supporter"
+      verifications `shouldReturn` 2
+      rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
+
+testStoreReceiptRetriedOnTrigger :: HasCallStack => TestParams -> IO ()
+testStoreReceiptRetriedOnTrigger ps = do
+  hook <- newIORef (pure ())
+  verifications <- countGoogleVerifications hook
+  withBadgeServiceVerifier ps (notConfiguredGoogle hook) $ \BadgeServiceEnv {bsClientCfg} ->
+    withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do
+      alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
+      storePurchaseOpen alice ""
+      waitStoreReceiptError (chatController alice) "service_error final provider_not_configured"
+      threadDelay 1000000
+      verifications `shouldReturn` 1
+      alice ##> "/_app activate"
+      alice <## "ok"
+      waitGoogleVerifications verifications 2
+      (alice </)
       heldStoreReceipts (chatController alice) `shouldReturn` 1
 
 testStoreRefusalKept :: HasCallStack => TestParams -> IO ()
@@ -2083,13 +2059,12 @@ testStoreReceiptCleanup ps =
       unpaid <- createInvoice alice 1
       alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase"))
       inAnyOrder alice [["store purchase open: invoice " <> unpaid, openPurchase ""], ["store purchase settled"]]
-      since <- testClockTime bsClock
+      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS})
+      inAnyOrder alice [["store purchase open: invoice " <> unpaid, openPurchase ""], creditedLines "" "1: supporter"]
       alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googleUnreachableToken))
+      alice <##. "1: supporter"
       alice <## ("store purchase open: invoice " <> unpaid)
       storePurchaseOpen alice ""
-      _ <- waitStoreReceiptDeferred (chatController alice) since
-      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS})
-      inAnyOrder alice [["store purchase open: invoice " <> unpaid, openPurchase "", openPurchase ""], creditedLines "" "1: supporter"]
       storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack unpaid), False), (1, Nothing, True), (1, Nothing, True), (1, Nothing, True)]
       -- a month on, the record no receipt reached and the refusal go; the credited and the held one stay
       testClockTime bsClock >>= setClockAt bsClock . addUTCTime (31 * nominalDay)
@@ -2109,20 +2084,17 @@ testStoreReceiptAttemptThrows :: HasCallStack => TestParams -> IO ()
 testStoreReceiptAttemptThrows ps = do
   hook <- newIORef (pure ())
   verifications <- countGoogleVerifications hook
-  withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} ->
+  withBadgeServiceVerifier ps (notConfiguredGoogle hook) $ \BadgeServiceEnv {bsClientCfg} ->
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
-      setGoogleDown store True
-      since <- testClockTime bsClock
       alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
       storePurchaseOpen alice ""
-      (firstAt, _) <- waitStoreReceiptDeferred (chatController alice) since
+      waitStoreReceiptError (chatController alice) "service_error final provider_not_configured"
       verifications `shouldReturn` 1
       -- a stored payment this version cannot read makes the attempt throw before anything is sent
       setStoreReceiptPayment (chatController alice) "not a payment"
-      retryStoreReceiptsAfter alice bsClock 300 []
-      (secondAt, failure) <- waitStoreReceiptDeferred (chatController alice) firstAt
-      failure `shouldBe` "unexpected held store payment does not decode"
-      secondAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) firstAt)
+      alice ##> "/_app activate"
+      alice <## "ok"
+      waitStoreReceiptError (chatController alice) "unexpected held store payment does not decode"
       (alice </)
       verifications `shouldReturn` 1
       heldStoreReceipts (chatController alice) `shouldReturn` 1
@@ -2152,13 +2124,10 @@ waitStoreReceiptRows cc n = loop (100 :: Int)
       rows <- storeReceiptRows cc
       if length rows == n then pure rows else threadDelay 50000 >> loop (i - 1)
 
--- | The receipts the owner's worker could select, and when it would wake for them. Read two days ahead, so
--- a receipt the worker has already deferred by a day is still counted.
-selectableStoreReceipts :: ChatController -> Int64 -> IO (Int, Maybe UTCTime)
-selectableStoreReceipts ChatController {chatStore} userId = do
-  later <- addUTCTime (2 * nominalDay) <$> getCurrentTime
+storeReceiptDue :: ChatController -> Int64 -> IO Bool
+storeReceiptDue ChatController {chatStore} userId =
   withTransaction chatStore $ \db ->
-    (,) <$> (length <$> getDueStoreReceipts db userId later) <*> getNextStoreReceiptAttempt db userId
+    getNextDueStoreReceipt db userId S.empty >>= either (error . show) (pure . isJust)
 
 heldStoreReceipts :: ChatController -> IO Int
 heldStoreReceipts ChatController {chatStore} =
@@ -2172,31 +2141,30 @@ waitHeldStoreReceipts cc n = loop (100 :: Int)
     loop 0 = heldStoreReceipts cc >>= (`shouldBe` n)
     loop i = heldStoreReceipts cc >>= \held -> if held == n then pure () else threadDelay 50000 >> loop (i - 1)
 
--- | The next attempt and the failure of the receipt deferred last, once an attempt made after since has
--- deferred it - every deferral is at least the retry floor ahead, which a fresh hand-over's due time is not.
-waitStoreReceiptDeferred :: HasCallStack => ChatController -> UTCTime -> IO (UTCTime, Text)
-waitStoreReceiptDeferred ChatController {chatStore} since = loop (100 :: Int)
+waitStoreReceiptError :: HasCallStack => ChatController -> Text -> IO ()
+waitStoreReceiptError ChatController {chatStore} failure = loop (100 :: Int)
   where
-    loop i = do
-      rows :: [(UTCTime, Text)] <-
-        withTransaction chatStore $ \db ->
-          DB.query_ db "SELECT next_attempt_at, credit_error FROM badge_store_receipts WHERE credit_error IS NOT NULL ORDER BY next_attempt_at DESC LIMIT 1"
-      case rows of
-        [r@(at, _)] | at > addUTCTime 10 since -> pure r
-        _ | i == 0 -> error $ "expected a store receipt deferred after " <> show since <> ", got " <> show rows
-          | otherwise -> threadDelay 50000 >> loop (i - 1)
+    loop 0 = heldFailures >>= (`shouldContain` [failure])
+    loop i = heldFailures >>= \failures -> if failure `elem` failures then pure () else threadDelay 50000 >> loop (i - 1)
+    heldFailures =
+      withTransaction chatStore $ \db ->
+        map fromOnly <$> DB.query_ db "SELECT credit_error FROM badge_store_receipts WHERE payment IS NOT NULL AND credit_error IS NOT NULL"
 
 setStoreReceiptPayment :: ChatController -> Text -> IO ()
 setStoreReceiptPayment ChatController {chatStore} payment =
   withTransaction chatStore $ \db -> DB.execute db "UPDATE badge_store_receipts SET payment = ?" (Only payment)
 
--- | Moves the badge clock past a deferred receipt's next attempt, and signals the worker as the app's
--- return to the foreground does; the events the worker prints may come before or after the "ok".
-retryStoreReceiptsAfter :: HasCallStack => TestCC -> TestClock -> NominalDiffTime -> [String] -> IO ()
-retryStoreReceiptsAfter cc clock wait events = do
-  testClockTime clock >>= setClockAt clock . addUTCTime (wait + 1)
-  cc ##> "/_app activate"
-  inAnyOrder cc $ ["ok"] : [events | not (null events)]
+-- | Past the 300 seconds the service asks a client to wait while a store is pending or unreachable.
+passRetryAfter :: TestClock -> IO ()
+passRetryAfter clock = testClockTime clock >>= setClockAt clock . addUTCTime 301
+
+fastRetryCfg :: ChatConfig -> ChatConfig
+fastRetryCfg cfg = cfg {badgeRetryInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 500000}}
+
+-- | Google answered as by a service with no Play verifier deployed, each verification counted by the hook.
+notConfiguredGoogle :: IORef (IO ()) -> FakeStore -> StoreVerifier
+notConfiguredGoogle hook store =
+  googleVerifierWithHook hook store {fakeVerifier = noStoreVerifier {verifyGoogle = Just $ \_ _ -> pure $ Left SRNotConfigured}}
 
 -- | Each block's lines in order, the blocks in any order: the worker is signalled before the command that
 -- signalled it has answered, so its events can print first. Every line is matched as a prefix.
@@ -2222,6 +2190,12 @@ countGoogleVerifications hook = do
   writeIORef hook count
   pure $ readIORef n
 
+waitGoogleVerifications :: HasCallStack => IO Int -> Int -> IO ()
+waitGoogleVerifications verifications n = loop (100 :: Int)
+  where
+    loop 0 = verifications `shouldReturn` n
+    loop i = verifications >>= \made -> if made == n then pure () else threadDelay 50000 >> loop (i - 1)
+
 storePurchaseOpen :: HasCallStack => TestCC -> String -> IO ()
 storePurchaseOpen cc userPrefix = cc <##. openPurchase userPrefix