core: hold a store receipt until its worker credits it, report why it is not credited yet, and delete records that fund no badge after a month

src/Simplex/Chat.hs

@@ -195,6 +195,7 @@ newChatController
         deliveryJobWorkers <- TM.emptyIO
         relayRequestWorkers <- TM.emptyIO
         badgeWorkers <- TM.emptyIO
+        storeReceiptWorkers <- TM.emptyIO
         badgeSeq <- newTVarIO 0
         relayGroupLinkChecksAsync <- newTVarIO Nothing
         webPreviewState <- forM webPreviewConfig $ \_ -> newWebPreviewState
@@ -243,6 +244,7 @@ newChatController
               deliveryJobWorkers,
               relayRequestWorkers,
               badgeWorkers,
+              storeReceiptWorkers,
               badgeSeq,
               relayGroupLinkChecksAsync,
               webPreviewState,

src/Simplex/Chat/Badges/Types.hs

@@ -283,12 +283,14 @@ data BadgeState = BadgeState
   }
   deriving (Show)
 
--- | One of a profile's open store purchases, neither credited nor closed. The app matches invoiceId
--- against the transactions its store still holds; transactionRef is set once a receipt arrived.
--- Neither reference is a secret: Apple's is the transaction id, Google's is a hash of the token.
+-- | One of a profile's store purchases that no receipt has reached yet, or whose receipt is held until
+-- the service credits it; transactionRef is set once a receipt arrived. Neither reference is a secret:
+-- Apple's is the transaction id, Google's is a hash of the token. creditError is set only while the
+-- held receipt's last attempt failed in a way that cannot clear on its own.
 data OpenStorePurchase = OpenStorePurchase
   { invoiceId :: Maybe Text,
-    transactionRef :: Maybe Text
+    transactionRef :: Maybe Text,
+    creditError :: Maybe BadgeIssueFailure
   }
   deriving (Show)
 

src/Simplex/Chat/Controller.hs

@@ -328,6 +328,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),
     badgeSeq :: TVar Int,
     relayGroupLinkChecksAsync :: TVar (Maybe (Async ())),
     webPreviewState :: Maybe WebPreviewState,
@@ -660,7 +661,7 @@ data ChatCommand
   | UpdateProfileImageFromFile FilePath -- set profile image from a .png/.jpg/.jpeg file
   | AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`)
   | APIRedeemBadgeCode {userId :: UserId, code :: Text} -- redeem a badge code with the configured badge service
-  | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, payment :: ServicePayment} -- redeem an App Store or Google Play purchase; without an invoice id it is credited by transaction reference
+  | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, payment :: ServicePayment} -- hand over an App Store or Google Play receipt, held until a worker credits it; answers from the record and sends nothing
   | APICreateBadgeInvoice {userId :: UserId} -- the record of a store purchase, created before the store charges; answers the id the store echoes
   | APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert
   | APIGetBadgeLedger {userId :: UserId, badgePurchaseId :: Int64} -- the purchase's ledger, oldest first
@@ -994,6 +995,7 @@ data ChatEvent
   | CEvtServiceReplySent {connectionId :: AgentConnId}
   | CEvtBadgeChanged {user :: User, badgeState :: Maybe BadgeState} -- badge state changed, including a renewal that arrived without a command
   | CEvtBadgeAlert {user :: User, badgeAlert :: BadgeAlert}
+  | CEvtStorePurchaseSettled {user :: User} -- a held store receipt was credited or refused, so its store transaction can be finished
   | CEvtContactRequestRejected {user :: User, contact :: Contact, rejectionReason :: Maybe ContactRejectionReason}
   | CEvtAcceptingContactRequest {user :: User, contact :: Contact} -- there is the same command response
   | CEvtAcceptingBusinessRequest {user :: User, groupInfo :: GroupInfo}

src/Simplex/Chat/Library/Commands.hs

@@ -61,7 +61,7 @@ import Crypto.Random (ChaChaDRG)
 import Simplex.Messaging.Session (SessionVar (..), withGetSessVar')
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential)
 import qualified Simplex.Chat.Badges.Ledger as L
-import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..))
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), OpenStorePurchase (..))
 import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
 import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), currentBadgeServiceVersion)
 import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
@@ -107,7 +107,7 @@ import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSizeHar
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), withRetryInterval)
+import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay, withRetryInterval)
 import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Agent.Store.Interface (execSQL)
 import Simplex.Messaging.Agent.Store.Shared (upMigration)
@@ -263,6 +263,7 @@ startChatController mainApp enableSndFiles serviceRequests = do
           startRelayRequestWorker_
           startCleanupManager
           mapM_ startBadgeWork users
+          mapM_ startStoreReceiptWork users
           void $ forkIO $ mapM_ startExpireCIs users
           startRelayChecks users
           startWebPreview users
@@ -359,7 +360,7 @@ restoreCalls = do
   atomically $ writeTVar calls callsMap
 
 stopChatController :: ChatController -> IO ()
-stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, cleanupManagerAsync, relayGroupLinkChecksAsync, webPreviewState, expireCIThreads, timedItemThreads, deliveryTaskWorkers, deliveryJobWorkers, relayRequestWorkers, badgeWorkers} = do
+stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, cleanupManagerAsync, relayGroupLinkChecksAsync, webPreviewState, expireCIThreads, timedItemThreads, deliveryTaskWorkers, deliveryJobWorkers, relayRequestWorkers, badgeWorkers, storeReceiptWorkers} = do
   readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd)
   atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd)
   disconnectAgentClient smpAgent
@@ -373,6 +374,7 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles,
   clearMap deliveryJobWorkers >>= mapM_ cancelWorker
   clearMap relayRequestWorkers >>= mapM_ cancelWorker
   stopBadgeWorkers badgeWorkers
+  stopBadgeWorkers storeReceiptWorkers
   closeFiles sndFiles
   closeFiles rcvFiles
   atomically $ do
@@ -605,6 +607,7 @@ processChatCommand cxt nm = \case
         void . forkIO $ startFilesToReceive users
         setAllExpireCIFlags True
         mapM_ startBadgeWork users
+        mapM_ startStoreReceiptWork users
     ok_
   APISuspendChat t -> do
     chatWriteVar chatActivated False
@@ -3564,14 +3567,14 @@ processChatCommand cxt nm = \case
   ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile)
   AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user
   APIRedeemBadgeCode userId codeText -> withUserId userId $ \user -> redeemBadgeCode nm user codeText
-  APIPurchaseBadge userId echoedInvoiceId payment -> withUserId userId $ \user -> purchaseBadge nm user echoedInvoiceId payment
+  APIPurchaseBadge userId echoedInvoiceId payment -> withUserId userId $ \user -> handOverStoreReceipt user echoedInvoiceId payment
   APICreateBadgeInvoice userId -> withUserId userId $ \user -> do
     void requireBadgeService
     refuseWhileBadgeHeld user
     g <- asks random
-    now <- liftIO getCurrentTime
+    now <- badgeNow
     invoiceId <- UUID.toText <$> liftIO V4.nextRandom
-    _ <- withStore' $ \db -> createBadgeStoreReceipt db g user (Just invoiceId) Nothing now
+    withStore' $ \db -> createBadgeStoreReceipt db g user invoiceId now
     pure $ CRBadgeInvoice user invoiceId
   APIGetBadgeState userId -> withUserId' userId $ \user -> do
     -- the read also signals the worker, whose results follow as CEvtBadgeChanged
@@ -5251,28 +5254,36 @@ redeemBadgeCode nm user@User {userId} codeText = do
       BSECodeExpired -> True
       _ -> False
 
--- | The app presents a purchase until this returns its badge, under whichever profile is active; the
--- stash stays with the profile it was first presented under, so every retry is the signer first credited.
-purchaseBadge :: NetworkRequestMode -> User -> Maybe Text -> ServicePayment -> CM ChatResponse
-purchaseBadge nm presentingUser echoedInvoiceId payment = do
+-- | The app hands a receipt over until it is answered credited or refused, under whichever profile is
+-- active; the answer is the owner's, read from the record. Nothing is sent: the owner's receipt worker is.
+handOverStoreReceipt :: User -> Maybe Text -> ServicePayment -> CM ChatResponse
+handOverStoreReceipt presentingUser echoedInvoiceId payment = do
   txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment
-  sendTarget <- requireBadgeService
+  void requireBadgeService
   g <- asks random
-  now <- liftIO getCurrentTime
-  user@User {userId} <- withStore $ \db -> liftIO (attachBadgeStoreReceipt db echoedInvoiceId txRef) >>= maybe (pure presentingUser) (getUser db)
-  (present_, purchased) <- withEntityLock "badgePurchase" (CLBadgeUser userId) $ do
-    stash_ <- withStore' $ \db -> getBadgeStoreReceipt db user txRef
-    stash@BadgeStash {masterKey} <- stashBadgeKeys user stash_ $ \db -> createBadgeStoreReceipt db g user echoedInvoiceId (Just txRef) now
-    redeemBadgeStash nm user sendTarget stash BSCPurchaseBadge {masterKey, payment, upgrade = Nothing} terminalReceiptError
-  -- outside the badge lock: the chat lock must not be taken under it
-  mapM_ presentUserBadgeToContacts present_
-  pure purchased
-  where
-    -- the receipt will never be credited to this key; any other refusal may pass on a retry
-    terminalReceiptError = \case
-      BSEReceiptInvalid -> True
-      BSEReceiptUsed -> True
-      _ -> False
+  now <- badgeNow
+  (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
+  answer <- case status of
+    RSHeld -> badgeStateResponse owner
+    RSCredited {badgePurchaseId} -> do
+      cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
+      cred@(BadgeCredential _ _ _ info) <- maybe (throwChatError $ CEInternalError "credited store purchase has no credential") pure cred_
+      CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner
+    RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code
+    RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason"
+  -- after the answer is read, so it shows the receipt held whatever the worker does next
+  when newlyHeld $ lift $ startStoreReceiptWork owner
+  pure answer
+
+-- | The receipt will never be credited to its key; any other refusal may pass on a retry.
+storeReceiptRefused :: BadgeServiceErrorCode -> Bool
+storeReceiptRefused = \case
+  BSEReceiptInvalid -> True
+  BSEReceiptUsed -> True
+  _ -> False
 
 -- | The same reference the service claims a transaction by, read without verifying anything.
 storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef
@@ -5298,16 +5309,23 @@ refuseWhileBadgeHeld user = whenM (withStore' (`userHasBadge` user)) $ throwRede
 
 -- | One attempt to turn a stash into a badge, dropping the stash only on a refusal no retry can fix.
 redeemBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> (BadgeServiceErrorCode -> Bool) -> CM (Maybe User, ChatResponse)
-redeemBadgeStash nm user sendTarget stash@BadgeStash {purchaseKey, purchasePrivKey} request stashDead = do
+redeemBadgeStash nm user sendTarget stash request stashDead =
+  requestBadgeStash nm user sendTarget stash request >>= \case
+    Left (errCode, _) -> do
+      when (stashDead errCode) $ withStore' (`deleteBadgeStash` stash)
+      throwRedeemError $ BREServiceError errCode
+    Right redeemed -> pure redeemed
+
+-- | A refusal is answered rather than thrown, with the service's retryAfter.
+requestBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (Maybe User, ChatResponse))
+requestBadgeStash nm user sendTarget stash@BadgeStash {purchaseKey, purchasePrivKey} request = do
   let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request}
   respBytes <- sendServiceRequestBytes nm user sendTarget Nothing (Just purchasePrivKey) req
   respData <- either (const $ throwRedeemError $ BREInvalidResponse "not JSON") pure $ J.eitherDecodeStrict' respBytes
   case J.fromJSON (J.Object respData) of
     J.Error _ -> throwRedeemError $ BREInvalidResponse "not a badge service response"
-    J.Success BSPError {code = errCode} -> do
-      when (stashDead errCode) $ withStore' (`deleteBadgeStash` stash)
-      throwRedeemError $ BREServiceError errCode
-    J.Success BSPBadgeCredential {credential = Just cred, statement} -> storeRedeemedBadge user stash cred statement
+    J.Success BSPError {code, retryAfter} -> pure $ Left (code, retryAfter)
+    J.Success BSPBadgeCredential {credential = Just cred, statement} -> Right <$> storeRedeemedBadge user stash cred statement
     J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type"
 
 throwRedeemError :: BadgeRedeemError -> CM a
@@ -5335,20 +5353,23 @@ 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 user
+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
 
 -- | 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 :: User -> CM' BadgeWorker
-getBadgeWorker User {userId} = do
-  ws <- asks badgeWorkers
+getBadgeWorker :: (ChatController -> TM.TMap UserId (SessionVar BadgeWorker)) -> (UserId -> TMVar () -> CM ()) -> User -> CM' BadgeWorker
+getBadgeWorker workers runWorker User {userId} = do
+  ws <- asks workers
   seq' <- asks badgeSeq
   now <- liftIO getCurrentTime
   withGetSessVar' seq' userId ws now startWorker signalWorker
   where
     startWorker v = do
       badgeWork <- newEmptyTMVarIO
-      badgeWorkerAsync <- async $ void $ runExceptT $ runBadgeWorker userId badgeWork
+      badgeWorkerAsync <- async $ void $ runExceptT $ runWorker userId badgeWork
       let w = BadgeWorker {badgeWorkerAsync, badgeWork}
       w <$ atomically (putTMVar (sessionVar v) w)
     signalWorker v = do
@@ -5418,6 +5439,70 @@ 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_
+
+-- | 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)
+
+data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused | SRODeferred
+
+-- | 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: the app answers it with a sweep, which signals this worker
+  case outcome of
+    SROCredited present_ -> do
+      -- outside the badge lock: the chat lock must not be taken under it
+      mapM_ presentUserBadgeToContacts present_
+      user <- withStore $ \db -> getUser db userId
+      toView . CEvtBadgeChanged user =<< getUserBadgeState user
+      toView $ CEvtStorePurchaseSettled user
+    SRORefused -> withStore (`getUser` userId) >>= toView . CEvtStorePurchaseSettled
+    SRODeferred -> pure ()
+  where
+    attempt = do
+      user <- withStore $ \db -> getUser db userId
+      refuseWhileBadgeHeld user
+      sendTarget <- requireBadgeService
+      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 (wait, retryDelay') = storeReceiptRetry ri failure retryAfter retryDelay
+      withStore' $ \db -> deferStoreReceipt db receiptId (wait `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
+
 -- | 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.
 updateUserBadge :: UserId -> TVar (Maybe BadgeOccurrence) -> UTCTime -> CM (Maybe UTCTime)
@@ -5499,8 +5584,10 @@ emitBadgeAlert user emitted p@UserBadgePurchase {alertSnoozeUntil} shownCred now
 badgeStateResponse :: User -> CM ChatResponse
 badgeStateResponse user = do
   badgeState <- getUserBadgeState user
-  now <- badgeNow
-  CRBadgeState user badgeState <$> withStore' (\db -> getOpenStorePurchases db user now)
+  CRBadgeState user badgeState . map finalError <$> withStore' (`getOpenStorePurchases` user)
+  where
+    -- like a renewal's, only a failure that cannot clear on its own is the user's to know about
+    finalError p@OpenStorePurchase {creditError} = p {creditError = find (not . badgeFailureTransient) creditError}
 
 -- | Read from stored rows alone; the worker's results follow as CEvtBadgeChanged.
 getUserBadgeState :: User -> CM (Maybe BadgeState)
@@ -5535,9 +5622,10 @@ badgeStalledInterval = nominalDay
 -- | The wait after a service refusal, floored at initialInterval so answering 0 cannot spin the
 -- worker, and uncapped above it.
 badgeRetryAfter :: RetryInterval -> Maybe Word32 -> NominalDiffTime
-badgeRetryAfter RetryInterval {initialInterval} = maybe badgeStalledInterval (max floorWait . fromIntegral)
-  where
-    floorWait = fromIntegral initialInterval / 1000000
+badgeRetryAfter ri = maybe badgeStalledInterval (max (retryFloor ri) . fromIntegral)
+
+retryFloor :: RetryInterval -> NominalDiffTime
+retryFloor RetryInterval {initialInterval} = fromIntegral initialInterval / 1000000
 
 -- | How far ahead of the shown credential's expiry the renewal is requested - a day, so a failure
 -- has that long to retry. The wake and the due check both derive from it and have to agree.
@@ -5881,6 +5969,7 @@ cleanupManager = do
       cleanupDeliveryJobs `catchAllErrors` eToView
       -- TODO possibly, also cleanup async commands
       cleanupProbes `catchAllErrors` eToView
+      cleanupStoreReceipts `catchAllErrors` eToView
     liftIO $ threadDelay' $ diffToMicroseconds interval
   where
     runWithoutInitialDelay cleanupInterval = flip catchAllErrors eToView $ do
@@ -5950,6 +6039,11 @@ cleanupManager = do
       ts <- liftIO getCurrentTime
       let cutoffTs = addUTCTime (-(14 * nominalDay)) ts
       withStore' (`deleteOldProbes` cutoffTs)
+    -- the badge clock, which the records are written with
+    cleanupStoreReceipts = do
+      ts <- badgeNow
+      let cutoffTs = addUTCTime (-(30 * nominalDay)) ts
+      withStore' (`deleteUnfundedStoreReceipts` cutoffTs)
 
 deleteInProgressGroup :: User -> GroupInfo -> CM ()
 deleteInProgressGroup user gInfo = do

src/Simplex/Chat/Store/Badges.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Simplex.Chat.Store.Badges
@@ -19,11 +20,17 @@ module Simplex.Chat.Store.Badges
     clearShownBadge,
     getBadgeCodeRedemption,
     createBadgeCodeRedemption,
-    getBadgeStoreReceiptUserId,
-    attachBadgeStoreReceipt,
-    getOpenStorePurchases,
-    getBadgeStoreReceipt,
+    StoreReceipt (..),
+    StoreReceiptStatus (..),
+    HeldStoreReceipt (..),
+    holdStoreReceipt,
     createBadgeStoreReceipt,
+    getOpenStorePurchases,
+    getDueStoreReceipts,
+    getNextStoreReceiptAttempt,
+    deferStoreReceipt,
+    refuseStoreReceipt,
+    deleteUnfundedStoreReceipts,
     deleteBadgeStash,
     createStashBadgePurchase,
     getStashBadgePurchase,
@@ -45,11 +52,12 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
 import Data.Maybe (isJust, mapMaybe)
 import Data.Text (Text)
-import Data.Time.Clock (UTCTime, addUTCTime, nominalDay)
+import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
 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.Types
@@ -105,80 +113,157 @@ createBadgeCodeRedemption db g User {userId} code now = do
   redemptionId <- insertedRowId db
   pure BadgeStash {stashRef = BSRCodeRedemption redemptionId, purchaseKey, purchasePrivKey, masterKey}
 
--- | A store transaction belongs to the store account, not to a profile, so its stash is looked up
--- across profiles: presented under another, it still reaches the service as the key it was credited to.
-getBadgeStoreReceiptUserId :: DB.Connection -> StoreTransactionRef -> IO (Maybe UserId)
-getBadgeStoreReceiptUserId db StoreTransactionRef {provider, transactionRef} =
-  maybeFirstRow fromOnly $
-    DB.query db "SELECT user_id FROM badge_store_receipts WHERE provider = ? AND transaction_ref = ?" (provider, transactionRef)
+-- | A store receipt as the record has it: held until the service credits or refuses it.
+data StoreReceipt = StoreReceipt
+  { receiptId :: Int64,
+    ownerId :: UserId,
+    status :: StoreReceiptStatus
+  }
 
--- | The profile a receipt belongs to, attaching it to the record created when Buy was tapped. A
--- transaction already attached stays with its record, whose keys the service may have credited.
-attachBadgeStoreReceipt :: DB.Connection -> Maybe Text -> StoreTransactionRef -> IO (Maybe UserId)
-attachBadgeStoreReceipt db invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} =
-  getBadgeStoreReceiptUserId db txRef >>= \case
-    Just userId -> pure $ Just userId
-    Nothing -> fmap join . forM invoiceId_ $ \invoiceId -> do
-      userId_ <-
-        maybeFirstRow fromOnly $
-          DB.query db "SELECT user_id FROM badge_store_receipts WHERE invoice_id = ? AND transaction_ref IS NULL" (Only invoiceId)
-      forM_ userId_ $ \_ ->
+data StoreReceiptStatus
+  = RSHeld
+  | RSCredited {badgePurchaseId :: Int64}
+  | RSRefused {refusal :: Maybe BadgeIssueFailure}
+
+-- | A store transaction belongs to the store account, not to a profile, so it is found across profiles and
+-- stays with the record whose keys the service may have credited. A new one goes to the record created when
+-- Buy was tapped, or else to the presenting profile. 'True' when this hand-over is the one that held it.
+holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Maybe Text -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO (Maybe (StoreReceipt, Bool))
+holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now =
+  getStoreReceipt db txRef >>= \case
+    Just r@StoreReceipt {receiptId} -> do
+      -- a settled record stays settled, so a hand-over landing just after its credit cannot hold it again
+      DB.execute db "UPDATE badge_store_receipts SET payment = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL" (paymentJSON, receiptId)
+      pure $ Just (r, False)
+    Nothing -> do
+      forM_ invoiceId_ $ \invoiceId ->
         DB.execute
           db
-          "UPDATE badge_store_receipts SET provider = ?, transaction_ref = ? WHERE invoice_id = ?"
-          (provider, transactionRef, invoiceId)
-      pure userId_
-
-getOpenStorePurchases :: DB.Connection -> User -> UTCTime -> IO [OpenStorePurchase]
-getOpenStorePurchases db User {userId} now =
-  map (uncurry OpenStorePurchase)
-    <$> DB.query
-      db
-      [sql|
-        SELECT r.invoice_id, r.transaction_ref
-        FROM badge_store_receipts r
-        WHERE r.user_id = ? AND (r.transaction_ref IS NOT NULL OR r.created_at > ?)
-          AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = r.badge_store_receipt_id)
-        ORDER BY r.badge_store_receipt_id
-      |]
-      (userId, receiptDueSince)
+          "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)
+      getStoreReceipt db txRef >>= \case
+        Just r -> pure $ Just (r, True)
+        Nothing -> do
+          insertReceipt
+          -- read back rather than trusted: a concurrent hand-over of the same transaction may have inserted first
+          fmap (,True) <$> getStoreReceipt db txRef
   where
-    -- a record with no receipt is dropped after a week: longer than an Ask to Buy approval or a Play slow
-    -- payment can take, and those are the only waits that still need it. One a receipt reached is paid for.
-    receiptDueSince = addUTCTime (negate $ 7 * nominalDay) now
+    paymentJSON = safeDecodeUtf8 . LB.toStrict $ J.encode payment
+    insertReceipt = do
+      (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g
+      BadgeMasterKey mk <- generateMasterKey g
+      -- an invoice id another record holds is not repeated: this record is then keyed by its transaction alone
+      invoiceId' <- fmap join . forM invoiceId_ $ \invoiceId -> do
+        taken <- DB.query db "SELECT badge_store_receipt_id FROM badge_store_receipts WHERE invoice_id = ?" (Only invoiceId) :: IO [Only Int64]
+        pure $ if null taken then Just invoiceId else Nothing
+      DB.execute
+        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 (?,?,?,?,?,?,?,?,?,?)
+          ON CONFLICT DO NOTHING
+        |]
+        ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, now))
 
-getBadgeStoreReceipt :: DB.Connection -> User -> StoreTransactionRef -> IO (Maybe BadgeStash)
-getBadgeStoreReceipt db User {userId} StoreTransactionRef {provider, transactionRef} =
-  maybeFirstRow (toBadgeStash BSRStoreReceipt) $
+-- | held is a CASE because in Postgres a comparison is boolean, which BoolInt rejects.
+getStoreReceipt :: DB.Connection -> StoreTransactionRef -> IO (Maybe StoreReceipt)
+getStoreReceipt db StoreTransactionRef {provider, transactionRef} =
+  maybeFirstRow toStoreReceipt $
     DB.query
       db
       [sql|
-        SELECT badge_store_receipt_id, purchase_key, purchase_priv_key, master_key
-        FROM badge_store_receipts
-        WHERE user_id = ? AND provider = ? AND transaction_ref = ?
+        SELECT r.badge_store_receipt_id, r.user_id, (CASE WHEN r.payment IS NULL THEN 0 ELSE 1 END), p.badge_purchase_id, r.credit_error
+        FROM badge_store_receipts r
+        LEFT JOIN badge_purchases p ON p.badge_store_receipt_id = r.badge_store_receipt_id
+        WHERE r.provider = ? AND r.transaction_ref = ?
       |]
-      (userId, provider, transactionRef)
+      (provider, transactionRef)
+  where
+    toStoreReceipt (receiptId, ownerId, BI held, purchaseId_, refusal) =
+      StoreReceipt {receiptId, ownerId, status = if held then RSHeld else maybe (RSRefused refusal) RSCredited purchaseId_}
 
--- | An invoice id another record already holds is not repeated: the record is then keyed by its transaction alone.
-createBadgeStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Maybe Text -> Maybe StoreTransactionRef -> UTCTime -> IO BadgeStash
-createBadgeStoreReceipt db g User {userId} invoiceId_ txRef_ now = do
+-- | The record made when Buy is tapped, before any receipt: the store echoes its invoice id.
+createBadgeStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO ()
+createBadgeStoreReceipt db g User {userId} invoiceId now = do
   (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g
-  masterKey@(BadgeMasterKey mk) <- generateMasterKey g
-  invoiceId' <- fmap join . forM invoiceId_ $ \invoiceId -> do
-    taken <- DB.query db "SELECT badge_store_receipt_id FROM badge_store_receipts WHERE invoice_id = ?" (Only invoiceId) :: IO [Only Int64]
-    pure $ if null taken then Just invoiceId else Nothing
-  let (provider_, transactionRef_) = case txRef_ of
-        Just StoreTransactionRef {provider, transactionRef} -> (Just provider, Just transactionRef)
-        Nothing -> (Nothing, Nothing)
+  BadgeMasterKey mk <- generateMasterKey g
   DB.execute
     db
     [sql|
-      INSERT INTO badge_store_receipts (user_id, invoice_id, provider, transaction_ref, purchase_key, purchase_priv_key, master_key, created_at)
-      VALUES (?,?,?,?,?,?,?,?)
+      INSERT INTO badge_store_receipts (user_id, invoice_id, purchase_key, purchase_priv_key, master_key, created_at)
+      VALUES (?,?,?,?,?,?)
     |]
-    ((userId, invoiceId', provider_, transactionRef_) :. (purchaseKey, purchasePrivKey, Binary mk, now))
-  storeReceiptId <- insertedRowId db
-  pure BadgeStash {stashRef = BSRStoreReceipt storeReceiptId, purchaseKey, purchasePrivKey, masterKey}
+    (userId, invoiceId, purchaseKey, purchasePrivKey, Binary mk, now)
+
+-- | No receipt yet, or one held: a credited or refused record is settled and not listed.
+getOpenStorePurchases :: DB.Connection -> User -> IO [OpenStorePurchase]
+getOpenStorePurchases db User {userId} =
+  map toOpenStorePurchase
+    <$> DB.query
+      db
+      [sql|
+        SELECT invoice_id, transaction_ref, credit_error
+        FROM badge_store_receipts
+        WHERE user_id = ? AND (transaction_ref IS NULL OR payment IS NOT NULL)
+        ORDER BY badge_store_receipt_id
+      |]
+      (Only userId)
+  where
+    toOpenStorePurchase (invoiceId, transactionRef, creditError) = OpenStorePurchase {invoiceId, transactionRef, creditError}
+
+data HeldStoreReceipt = HeldStoreReceipt
+  { receiptId :: Int64,
+    stash :: BadgeStash,
+    payment :: Text,
+    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
+    <$> DB.query
+      db
+      [sql|
+        SELECT badge_store_receipt_id, purchase_key, purchase_priv_key, master_key, payment, retry_delay
+        FROM badge_store_receipts
+        WHERE user_id = ? AND payment IS NOT NULL AND next_attempt_at <= ?
+        ORDER BY next_attempt_at
+      |]
+      (userId, now)
+  where
+    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 "SELECT MIN(next_attempt_at) FROM badge_store_receipts WHERE user_id = ? AND payment IS NOT NULL" (Only userId)
+
+deferStoreReceipt :: DB.Connection -> Int64 -> UTCTime -> Maybe Int64 -> BadgeIssueFailure -> IO ()
+deferStoreReceipt db receiptId nextAttemptAt 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)
+
+-- | 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)
+
+-- | A held record is paid for and a credited one is referenced by its purchase, so neither is deleted.
+deleteUnfundedStoreReceipts :: DB.Connection -> UTCTime -> IO ()
+deleteUnfundedStoreReceipts db createdBefore =
+  DB.execute
+    db
+    [sql|
+      DELETE FROM badge_store_receipts
+      WHERE payment IS NULL AND created_at < ?
+        AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id)
+    |]
+    (Only createdBefore)
 
 toBadgeStash :: (Int64 -> BadgeStashRef) -> (Int64, C.PublicKeyEd25519, C.PrivateKeyEd25519, Binary ByteString) -> BadgeStash
 toBadgeStash ref (stashId, purchaseKey, purchasePrivKey, Binary mk) =
@@ -210,7 +295,9 @@ deleteBadgeStash db BadgeStash {stashRef} = case stashRef of
 -- | 'False' when the stash already funded a purchase here: the service replays the credential it
 -- issued, and that must add no purchase and leave the shown badge alone.
 createStashBadgePurchase :: DB.Connection -> User -> BadgeStash -> BadgeCredential -> UTCTime -> IO (Int64, Bool)
-createStashBadgePurchase db User {userId} stash credential now =
+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)
   getStashBadgePurchase db stash >>= \case
     Just purchaseId -> pure (purchaseId, False)
     Nothing -> do

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

@@ -8,7 +8,8 @@ import Text.RawString.QQ (r)
 
 -- | invoice_id is null for a receipt naming one another row holds: the transaction still has to be
 -- creditable, and its reference identifies it. provider and transaction_ref are null until a receipt
--- arrives, and distinct NULLs let several rows await one at once.
+-- arrives, and distinct NULLs let several rows await one at once. payment is held from the receipt's
+-- arrival until the service credits or refuses it; a refused row keeps its refusal in credit_error.
 m20260925_badge_store_receipts :: Text
 m20260925_badge_store_receipts =
   [r|
@@ -22,6 +23,10 @@ CREATE TABLE badge_store_receipts(
   purchase_priv_key BYTEA NOT NULL,
   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

@@ -305,7 +305,11 @@ CREATE TABLE test_chat_schema.badge_store_receipts (
     purchase_key bytea NOT NULL,
     purchase_priv_key bytea NOT NULL,
     master_key bytea NOT NULL,
-    created_at timestamp with time zone 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

@@ -7,7 +7,8 @@ import Database.SQLite.Simple.QQ (sql)
 
 -- | invoice_id is null for a receipt naming one another row holds: the transaction still has to be
 -- creditable, and its reference identifies it. provider and transaction_ref are null until a receipt
--- arrives, and distinct NULLs let several rows await one at once.
+-- arrives, and distinct NULLs let several rows await one at once. payment is held from the receipt's
+-- arrival until the service credits or refuses it; a refused row keeps its refusal in credit_error.
 m20260925_badge_store_receipts :: Query
 m20260925_badge_store_receipts =
   [sql|
@@ -21,6 +22,10 @@ CREATE TABLE badge_store_receipts(
   purchase_priv_key BLOB NOT NULL,
   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)
 ) STRICT;
 

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

@@ -992,6 +992,10 @@ CREATE TABLE badge_store_receipts(
   purchase_priv_key BLOB NOT NULL,
   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)
 ) STRICT;
 CREATE INDEX contact_profiles_index ON contact_profiles(

src/Simplex/Chat/View.hs

@@ -484,6 +484,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
   CEvtServiceReplySent (AgentConnId cId) -> [plain $ "service reply sent, connection id: " <> safeDecodeUtf8 (strEncode cId)]
   CEvtBadgeChanged u st -> ttyUser u $ viewUserBadgeState st
   CEvtBadgeAlert u alert -> ttyUser u $ viewBadgeAlert alert
+  CEvtStorePurchaseSettled u -> ttyUser u ["store purchase settled"]
   CEvtContactRequestRejected u Contact {localDisplayName = c} _reason -> ttyUser u [ttyContact c <> ": contact request rejected"]
   CEvtRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci
   CEvtRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci
@@ -1865,8 +1866,12 @@ viewBadgeAlert :: BadgeAlert -> [StyledString]
 viewBadgeAlert BadgeAlert {kind, date} = [plain $ "badge alert: " <> textEncode kind <> " " <> day date]
 
 viewOpenStorePurchase :: OpenStorePurchase -> StyledString
-viewOpenStorePurchase OpenStorePurchase {invoiceId, transactionRef} =
-  plain $ "store purchase open: invoice " <> fromMaybe "none" invoiceId <> maybe "" (", transaction " <>) transactionRef
+viewOpenStorePurchase OpenStorePurchase {invoiceId, transactionRef, creditError} =
+  plain $
+    "store purchase open: invoice "
+      <> fromMaybe "none" invoiceId
+      <> maybe "" (", transaction " <>) transactionRef
+      <> maybe "" ((", not credited: " <>) . safeDecodeUtf8 . strEncode) creditError
 
 viewBadgeLedger :: [StatementEntry] -> [StyledString]
 viewBadgeLedger [] = ["no ledger entries"]