core, badge-service, ios, android: change badge tier in the store, and restore a subscription on another device (#7795)

src/Simplex/Chat/Badges/Ledger.hs

@@ -8,12 +8,15 @@ module Simplex.Chat.Badges.Ledger
     lapseEntry,
     grantEntry,
     issueEntry,
+    debitEntry,
     chargeEntries,
     paidThrough,
     balanceChecked,
     addMonths,
     endOfMondayAfter,
     entryTypeColumns,
+    EntryReferences (..),
+    noEntryReferences,
     entryTypeFromColumns,
     creditTypeTag,
     debitTypeTag,
@@ -28,6 +31,7 @@ import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime)
 import Simplex.Chat.Badges (BadgeType)
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
 import Simplex.Chat.PaymentService.Types (InvoiceId)
+import qualified Simplex.Messaging.Crypto as C
 
 -- The calendar difference overshoots by at most one month, so one comparison settles it.
 monthsBetween :: UTCTime -> UTCTime -> Integer
@@ -90,16 +94,17 @@ lapseEntry t entryId e@StatementEntry {balanceMonths}
     k = elapsedMonths t e
 
 -- | New months start where the current coverage ends, or at t if it has already lapsed - so they
--- are neither spent on the month still running nor backdated over a gap.
-grantEntry :: UTCTime -> Text -> Int -> StatementCreditType -> StatementEntry -> StatementEntry
-grantEntry t entryId n credit e@StatementEntry {balanceMonths, balanceStartTs}
-  -- only a lapsed run restarts; topping up before coverage ends continues the run on its anchor,
-  -- so buying a month at a time keeps the same day of month as buying a year at once
-  | lapsed = credited {balanceMonths = n, balanceStartTs = t, balanceAnchorTs = t}
+-- are neither spent on the month still running nor backdated over a gap. Months of another tier
+-- replace the balance, so they are granted only onto an empty one.
+grantEntry :: UTCTime -> Text -> BadgeType -> Int -> StatementCreditType -> StatementEntry -> StatementEntry
+grantEntry t entryId badgeType n credit e@StatementEntry {balanceMonths, balanceStartTs, balanceBadgeType}
+  -- only a lapsed run, or one of another tier, restarts; topping up before coverage ends continues the
+  -- run on its anchor, so buying a month at a time keeps the same day of month as buying a year at once
+  | lapsed || badgeType /= balanceBadgeType = credited {balanceMonths = n, balanceStartTs = t, balanceAnchorTs = t}
   | otherwise = credited {balanceMonths = balanceMonths + n}
   where
     lapsed = balanceMonths == 0 && t > balanceStartTs
-    credited = e {entryId, createdAt = t, changeMonths = n, entryType = SECredit credit}
+    credited = e {entryId, createdAt = t, changeMonths = n, balanceBadgeType = badgeType, entryType = SECredit credit}
 
 -- | The period issued runs from the previous entry's balanceStartTs to this one's.
 issueEntry :: UTCTime -> Text -> StatementEntry -> Maybe StatementEntry
@@ -116,15 +121,29 @@ issueEntry t entryId e@StatementEntry {balanceMonths, balanceStartTs}
             entryType = SEDebit SDBadge
           }
 
--- | A store charge's rows, dated to its billing period start so coverage follows the store's periods:
--- a lapse to the period start, the grant, and a lapse to now; the caller issues at now. createdAt stays
--- non-decreasing as long as the period does not start before the tip was written.
-chargeEntries :: UTCTime -> UTCTime -> Int -> Text -> (Text, Text, Text) -> StatementEntry -> [StatementEntry]
-chargeEntries periodStart now months chargeId (lapseBeforeId, grantId, lapseSinceId) tip =
-  maybeToList lapsedBefore <> [granted] <> maybeToList lapsedSince
+-- | Takes every remaining month, even none; the balance start and anchor stay, so coverage ends where the issued months end.
+debitEntry :: UTCTime -> Text -> StatementDebitType -> StatementEntry -> StatementEntry
+debitEntry t entryId debit e@StatementEntry {balanceMonths} =
+  e {entryId, createdAt = t, changeMonths = negate balanceMonths, balanceMonths = 0, entryType = SEDebit debit}
+
+-- | A store charge's rows, dated to its billing period start so coverage follows the store's periods, or to
+-- the tip when the period started before it was written, so createdAt never decreases: a lapse to that date,
+-- the grant, and a lapse to now; the caller issues at now.
+-- A charge of another tier ends the run with an upgrade debit naming ownKey before its grant restarts it.
+chargeEntries :: UTCTime -> UTCTime -> BadgeType -> Int -> C.PublicKeyEd25519 -> Text -> (Text, Text, Text, Text) -> StatementEntry -> [StatementEntry]
+chargeEntries periodStart now badgeType months ownKey chargeId (lapseBeforeId, debitId, grantId, lapseSinceId) tip@StatementEntry {balanceBadgeType, createdAt} =
+  maybeToList lapsedBefore <> maybeToList debited <> [granted] <> maybeToList lapsedSince
   where
-    lapsedBefore = lapseEntry periodStart lapseBeforeId tip
-    granted = grantEntry periodStart grantId months (SCCharge chargeId) $ fromMaybe tip lapsedBefore
+    otherTier = badgeType /= balanceBadgeType
+    -- while the run continues on its anchor, dating the grant at the tip moves only the row's date;
+    -- a run that has lapsed restarts at t
+    t = max periodStart createdAt
+    lapsedBefore = lapseEntry t lapseBeforeId tip
+    current = fromMaybe tip lapsedBefore
+    debited
+      | otherTier && balanceMonths current /= 0 = Just $ debitEntry t debitId (SDUpgrade ownKey) current
+      | otherwise = Nothing
+    granted = grantEntry t grantId badgeType months (SCCharge chargeId) $ fromMaybe current debited
     lapsedSince = lapseEntry now lapseSinceId granted
 
 -- Generous because postdating only writes off a month by crossing a month boundary, which takes
@@ -154,8 +173,8 @@ entryChecked now badgeType prev e
       SEDebit SDLapse -> maybe (Just False) matches $ lapseEntry t "" prev
       SEDebit SDBadge -> maybe (Just False) matches $ issueEntry t "" prev
       SEDebit SDRefund -> uncontradicted
-      SEDebit SDUpgrade {} -> uncontradicted
-      SEDebit SDTransferOut {} -> uncontradicted
+      SEDebit d@SDUpgrade {} -> matches $ debitEntry t "" d prev
+      SEDebit d@SDTransferOut {} -> matches $ debitEntry t "" d prev
       SEDebit SDSupport -> uncontradicted
       SEDebit SDUnknown {} -> uncontradicted
       -- an opening credit resets the ledger to the amount it states, with no relation to the entry
@@ -167,7 +186,9 @@ entryChecked now badgeType prev e
         -- including a negative count, which shortens what the user paid for.
         -- TODO [badges] a purchase made in the app knows the months it bought; check them here.
         | changeMonths e < 0 -> Just False
-        | otherwise -> matches $ grantEntry t "" (changeMonths e) c prev
+        -- the recompute would agree, as a grant of another tier replaces the balance
+        | tierSwitched -> Just False
+        | otherwise -> matches $ grantEntry t "" (balanceBadgeType e) (changeMonths e) c prev
   where
     t = createdAt e
     postdated = t > addUTCTime maxCreatedAtSkew now
@@ -175,11 +196,17 @@ entryChecked now badgeType prev e
     -- Equal is not behind: a service pass writes its lapse and its issue with one clock reading
     backdated = t < createdAt prev
     matches = Just . sameBalance e
+    -- only a debit that emptied the old run may be followed by another tier, which the seed of a purchase with no ledger is not
+    tierSwitched = balanceBadgeType e /= balanceBadgeType prev && not (emptiedByDebit prev)
+    emptiedByDebit StatementEntry {balanceMonths, entryType} = case entryType of
+      SEDebit _ -> balanceMonths == 0
+      SECredit _ -> False
     restated = balanceMonths e == changeMonths e && balanceMonths e >= 0 && balanceBadgeType e == badgeType
     uncontradicted
       | balanceMonths e /= balanceMonths prev + changeMonths e = Just False
       | balanceMonths e < 0 = Just False
       | balanceStartTs e < balanceStartTs prev = Just False
+      | tierSwitched = Just False
       | otherwise = Nothing
 
 sameBalance :: StatementEntry -> StatementEntry -> Bool
@@ -217,17 +244,30 @@ debitTypeTag = \case
   SDLapse -> "lapse"
   SDUnknown {tag} -> tag
 
--- | Rebuilds only what the columns determine: constructors with no fields, a payment credit and a charge credit.
--- payment_ is Nothing when the row references no payment, and Just Nothing when that payment had no
--- invoice, as a store purchase has none. The rest answer Nothing rather than invent a payload.
+-- | What a ledger row's reference columns name. refPayment is Nothing when the row references no payment,
+-- and Just Nothing when that payment had no invoice, as a store purchase has none.
+data EntryReferences = EntryReferences
+  { refPayment :: Maybe (Maybe InvoiceId),
+    refChargeId :: Maybe Text,
+    refFromPurchaseKey :: Maybe C.PublicKeyEd25519,
+    refToPurchaseKey :: Maybe C.PublicKeyEd25519
+  }
+
+noEntryReferences :: EntryReferences
+noEntryReferences = EntryReferences {refPayment = Nothing, refChargeId = Nothing, refFromPurchaseKey = Nothing, refToPurchaseKey = Nothing}
+
+-- | Rebuilds only what the columns determine: constructors with no fields, and the types that name a
+-- payment, a charge or a purchase, through the reference their row holds. The rest answer Nothing
+-- rather than invent a payload.
 -- The client stores each type's JSON and reads that first, so this is its fallback; the service has none.
--- TODO [badges] rebuild transferIn, upgrade and transferOut from their reference columns,
--- without which the service cannot re-emit a statement carrying one.
-entryTypeFromColumns :: Maybe (Maybe InvoiceId) -> Maybe Text -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType
-entryTypeFromColumns payment_ chargeId_ entryType credit_ debit_ = case (entryType, credit_, debit_) of
-  ("credit", Just "payment", _) -> SECredit . SCPayment <$> payment_
-  ("credit", Just "charge", _) -> SECredit . SCCharge <$> chargeId_
+entryTypeFromColumns :: EntryReferences -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType
+entryTypeFromColumns EntryReferences {refPayment, refChargeId, refFromPurchaseKey, refToPurchaseKey} entryType credit_ debit_ = case (entryType, credit_, debit_) of
+  ("credit", Just "payment", _) -> SECredit . SCPayment <$> refPayment
+  ("credit", Just "charge", _) -> SECredit . SCCharge <$> refChargeId
+  ("credit", Just "transferIn", _) -> SECredit . SCTransferIn <$> refFromPurchaseKey
   ("credit", Just t, _) -> SECredit <$> creditType t
+  ("debit", _, Just "upgrade") -> SEDebit . SDUpgrade <$> refToPurchaseKey
+  ("debit", _, Just "transferOut") -> SEDebit . SDTransferOut <$> refToPurchaseKey
   ("debit", _, Just t) -> SEDebit <$> debitType t
   _ -> Nothing
   where

src/Simplex/Chat/Badges/Service.hs

@@ -93,10 +93,13 @@ data BadgeServiceCommand
         upgrade :: Maybe BadgeUpgrade -- upgrade store 1-time badge
       }
   | BSCUpgradeBadgeSubscription
-      { badgeRequest :: BadgeRequest, -- TODO [badges] drop when implemented: a client-stated expiry leaves the week's anonymity set
-        payment :: ServicePayment, -- store payments only
+      { payment :: ServicePayment, -- names the subscription and the tier to wait for; the store's answer is what is granted
         balance :: BadgeBalance
       }
+  | BSCTransferBadge
+      { masterKey :: BadgeMasterKey,
+        payment :: ServicePayment -- the store receipt of the subscription to move to the signing key
+      }
   | BSCIssueBadge
       { balance :: BadgeBalance -- no badgeRequest: the service holds the key, the tier and the expiry
       }

src/Simplex/Chat/Badges/StorePlan.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Badges.StorePlan (storePlan) where
+
+import Data.Text (Text)
+import Simplex.Chat.Badges (BadgeType (..))
+import Simplex.Chat.PaymentService.Types (PaymentProvider (..))
+
+-- | What a subscription charge grants, from the plan it was for: Apple's product id, or Play's base
+-- plan, which only Play's subscription record names. The months are the plan's, never the period's length.
+storePlan :: PaymentProvider -> Text -> Maybe (BadgeType, Int)
+storePlan provider planId = case (provider, planId) of
+  (PPApple, "SUBSCR_BADGE_SUPPORTER_MONTH_01") -> Just (BTSupporter, 1)
+  (PPApple, "SUBSCR_BADGE_SUPPORTER_YEAR_01") -> Just (BTSupporter, 12)
+  (PPApple, "SUBSCR_BADGE_LEGEND_MONTH_01") -> Just (BTLegend, 1)
+  (PPApple, "SUBSCR_BADGE_LEGEND_YEAR_01") -> Just (BTLegend, 12)
+  (PPGoogle, "subscr-badge-supporter-month-02") -> Just (BTSupporter, 1)
+  (PPGoogle, "subscr-badge-supporter-year-01") -> Just (BTSupporter, 12)
+  (PPGoogle, "subscr-badge-legend-month-01") -> Just (BTLegend, 1)
+  (PPGoogle, "subscr-badge-legend-year-01") -> Just (BTLegend, 12)
+  _ -> Nothing

src/Simplex/Chat/Badges/Types.hs

@@ -249,6 +249,7 @@ data BadgeServiceErrorCode
   | BSECodeExpired
   | BSEReceiptInvalid
   | BSEReceiptUsed
+  | BSETransferLimited -- the subscription moved from another key whose credential has not expired yet
   | BSETestPurchase -- the store vouched for a purchase that cost nothing: Apple's sandbox, a Play license tester
   | BSEInternal
   | BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
@@ -321,8 +322,9 @@ data OpenStorePurchase = OpenStorePurchase
 -- | Where the app found a store transaction it hands over. The store lists an account's purchases on every
 -- device signed into it, so a listed one is claimed only by a core that already has a record for it.
 data StoreReceiptOrigin
-  = SROPurchased -- the app's own purchase call, or Restore
+  = SROPurchased -- the app's own purchase call
   | SROListed -- the store's list of unfinished transactions, or its updates
+  | SRORestored -- Restore's hand-over of what the store lists as this account's, moved to this profile
   deriving (Eq, Show)
 
 instance TextEncoding BadgePurchaseStatus where
@@ -376,6 +378,7 @@ instance TextEncoding BadgeServiceErrorCode where
     BSECodeExpired -> "code_expired"
     BSEReceiptInvalid -> "receipt_invalid"
     BSEReceiptUsed -> "receipt_used"
+    BSETransferLimited -> "transfer_limited"
     BSETestPurchase -> "test_purchase"
     BSEInternal -> "internal"
     BSEUnknown t -> t
@@ -397,6 +400,7 @@ instance TextEncoding BadgeServiceErrorCode where
     "code_expired" -> BSECodeExpired
     "receipt_invalid" -> BSEReceiptInvalid
     "receipt_used" -> BSEReceiptUsed
+    "transfer_limited" -> BSETransferLimited
     "test_purchase" -> BSETestPurchase
     "internal" -> BSEInternal
     t -> BSEUnknown t

src/Simplex/Chat/Library/Commands.hs

@@ -65,6 +65,7 @@ import qualified Simplex.Chat.Badges.Ledger as L
 import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), BadgeSubscription (..), OpenStorePurchase (..), StoreReceiptOrigin (..))
 import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
 import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), SubscriptionState (..), currentBadgeServiceVersion)
+import Simplex.Chat.Badges.StorePlan (storePlan)
 import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
@@ -5368,21 +5369,34 @@ handOverStoreReceipt presentingUser echoedInvoiceId origin payment = do
   void requireBadgeService
   g <- asks random
   now <- badgeNow
+  limited <- case origin of
+    -- a move would retire the shown badge's own payment elsewhere, or wait behind it
+    SRORestored -> refuseWhileBadgeHeld presentingUser >> withStore' (\db -> holdStoreTransfer db g presentingUser txRef payment now)
+    _ -> pure False
   withStore' (\db -> holdStoreReceipt db g presentingUser origin echoedInvoiceId txRef payment now) >>= \case
     Nothing -> case origin of
       SROListed -> pure $ CRStoreReceiptNotRecorded presentingUser
-      SROPurchased -> throwChatError $ CEInternalError "store receipt was not recorded"
+      _ -> throwChatError $ CEInternalError "store receipt was not recorded"
     Just BadgeReceiptRecord {receiptId, ownerId, status} -> do
       owner <- withStore $ \db -> getUser db ownerId
+      when limited $ lift (resumeStoreReceiptWork ownerId) >> throwRedeemError (BREServiceError BSETransferLimited)
       case status of
         RSHeld {} -> lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
         RSCredited {badgePurchaseId, refusalRecorded} -> do
+          let rehold kind = withStore' $ \db -> reholdStoreReceipt db owner receiptId badgePurchaseId kind payment now
           answeredHeld <- case resumableCharge now payment of
             -- a charge refused after its hold is answered from the record, or the app's sweep would hold it again at every launch
-            Just purchasedAt | not (refusalRecorded && resumeHoldEnded now purchasedAt) ->
-              withStore' $ \db -> reholdStoreReceipt db owner receiptId badgePurchaseId payment now
+            Just purchasedAt | not (refusalRecorded && resumeHoldEnded now purchasedAt) -> rehold SHKPurchase
             _ -> pure False
-          if answeredHeld
+          -- a refused tier change is answered from the record, or every sweep would hold it and send it again
+          tierChangeHeld <- case tierChangeCharge now payment of
+            Just tier
+              | not (answeredHeld || refusalRecorded) ->
+                  withStore' (`getBadgePurchase` badgePurchaseId) >>= \case
+                    Just UserBadgePurchase {badgeType} | badgeType /= tier -> rehold SHKTierChange
+                    _ -> pure False
+            _ -> pure False
+          if answeredHeld || tierChangeHeld
             then lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
             else do
               cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
@@ -5420,6 +5434,8 @@ storeReceiptRefused :: BadgeServiceErrorCode -> Bool
 storeReceiptRefused = \case
   BSEReceiptInvalid -> True
   BSEReceiptUsed -> True
+  -- a badge moves only on the user's Restore, never by a retry once the limit has passed
+  BSETransferLimited -> True
   BSETestPurchase -> True
   _ -> False
 
@@ -5448,6 +5464,22 @@ resumableCharge now = \case
 resumeHoldEnded :: UTCTime -> UTCTime -> Bool
 resumeHoldEnded now purchasedAt = resumeHoldLimit `addUTCTime` purchasedAt <= now
 
+-- | How far a tier change's purchase date may be from this device's clock, either way, for it to be asked of the service
+-- at once; past it, the service grants the change at its next renewal check.
+tierChangeWindow :: NominalDiffTime
+tierChangeWindow = nominalDay
+
+-- | The tier of an Apple subscription charge that may change the tier of a shown purchase: not revoked, and bought
+-- within the window. Read from the unverified payload, which decides only what to ask the service and wait for.
+tierChangeCharge :: UTCTime -> ServicePayment -> Maybe BadgeType
+tierChangeCharge now = \case
+  SPApple {jws}
+    | Just AppleTransactionFacts {productId = Just planId, purchaseDate = Just purchased, revoked = False, autoRenewable = True} <- appleTransactionFacts jws,
+      Just (tier, _) <- storePlan PPApple planId,
+      abs (diffUTCTime (posixSecondsToUTCTime $ fromIntegral purchased / 1000) now) < tierChangeWindow ->
+        Just tier
+  _ -> Nothing
+
 -- | The same reference the service claims a transaction by, read without verifying anything.
 storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef
 storeTransactionRef = \case
@@ -5644,7 +5676,7 @@ runStoreReceiptWorker a userId Worker {doWork} = do
   forever $ do
     lift $ waitForWork doWork
     withWork_ a doWork (getDueReceipt scheduled) $ \case
-      BadgeReceiptRecord {receiptId, status = RSHeld {stash, invoiceId, payment, retryDelay}} -> creditStoreReceipt a userId receiptId stash invoiceId payment retryDelay
+      BadgeReceiptRecord {receiptId, status = RSHeld {stash, invoiceId, payment, retryDelay, holdKind}} -> creditStoreReceipt a userId receiptId stash invoiceId payment retryDelay holdKind
       BadgeReceiptRecord {receiptId} -> notHeld receiptId
   where
     getDueReceipt scheduled =
@@ -5668,23 +5700,23 @@ runStoreReceiptWorker a userId Worker {doWork} = do
 data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused BadgeIssueFailure | SRORetry | SRODeferred
 
 -- | Under the owner's badge lock, which keeps a profile's requests to the service serial.
-creditStoreReceipt :: AgentClient -> UserId -> Int64 -> BadgeStash -> Maybe Text -> Text -> Maybe Int64 -> CM ()
-creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ payment retryDelay = do
+creditStoreReceipt :: AgentClient -> UserId -> Int64 -> BadgeStash -> Maybe Text -> Text -> Maybe Int64 -> StoreHoldKind -> CM ()
+creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ payment retryDelay holdKind = do
   ChatConfig {badgeRetryInterval = ri, badgeConsecutiveRetries} <- asks config
   withRetryIntervalCount (maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) retryDelay) $ \n delay loop -> do
     liftIO $ waitWhileSuspended a
     liftIO $ waitForUserNetwork a
     -- decided under the lock and acted on outside it: the retry sleeps, and announcing takes the chat lock
     outcome <- withEntityLock "badgePurchase" (CLBadgeUser userId) $
-      withStore' (`getStashBadgePurchase` stash) >>= \case
-        Just purchaseId -> resume ri delay purchaseId
-        Nothing ->
-          tryAllErrors attempt >>= \case
-            Right (Right (present_, _)) -> pure $ SROCredited present_
-            Right (Left (code, retryAfter))
-              | storeReceiptRefused code -> refuse $ serviceFailure code retryAfter
-              | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter
-            Left e -> failed ri delay (badgeIssueFailure e) Nothing
+      if holdKind == SHKTransfer
+        -- before the stash lookup: the record still links the purchase its payment moves from
+        then credit ri delay transferCmd
+        else
+          withStore' (`getStashBadgePurchase` stash) >>= \case
+            -- before the resume, which settles any record whose purchase is shown
+            Just purchaseId | holdKind == SHKTierChange -> changeTier ri delay purchaseId
+            Just purchaseId -> resume ri delay purchaseId
+            Nothing -> credit ri delay purchaseCmd
     -- the invoice id is the app's only key to the store transaction, so without one nothing is emitted and its sweep finishes it
     case outcome of
       SROCredited present_ -> do
@@ -5699,12 +5731,21 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
       SRORetry | n + 1 < badgeConsecutiveRetries -> loop
       _ -> pure ()
   where
-    attempt = do
+    credit ri delay cmd =
+      tryAllErrors (attempt cmd) >>= \case
+        Right (Right (present_, _)) -> pure $ SROCredited present_
+        Right (Left (code, retryAfter))
+          | storeReceiptRefused code -> refuse $ serviceFailure code retryAfter
+          | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter
+        Left e -> failed ri delay (badgeIssueFailure e) Nothing
+    purchaseCmd payment' = BSCPurchaseBadge {masterKey, payment = payment', upgrade = Nothing}
+    transferCmd payment' = BSCTransferBadge {masterKey, payment = payment'}
+    attempt cmd = 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}
+      requestBadgeStash NRMBackground user sendTarget stash (cmd payment')
     -- a held record whose keys already fund a purchase is a resume of that retired subscription, checked before every send
     resume ri delay purchaseId = do
       user <- withStore $ \db -> getUser db userId
@@ -5718,9 +5759,9 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
           | isNewest, Just purchasedAt <- resumableCharge now =<< decodeJSON payment -> resumeIssue ri delay user p purchasedAt now
         _ -> refuse receiptInvalid
     resumeIssue ri delay user p@UserBadgePurchase {badgePurchaseId} purchasedAt now = do
-      answer <- tryAllErrors $ requireBadgeService >>= \sendTarget -> sendBadgeIssue sendTarget userId p now
+      answer <- tryAllErrors $ requireBadgeService >>= \sendTarget -> sendBadgeIssue sendTarget userId p BSCIssueBadge (recordBadgeIssueFailure p) now
       answeredAt <- badgeNow
-      -- a charge the service does not grant, as one of another tier, stops holding the profile once its hold ends
+      -- a charge the service does not grant, as a revoked one, stops holding the profile once its hold ends
       let notCredited holding
             | resumeHoldEnded answeredAt purchasedAt = refuse receiptInvalid
             | otherwise = holding
@@ -5740,6 +5781,39 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
                   pure $ SROCredited (Just user')
             -- the service's own check interval
             _ -> notCredited $ failed ri delay BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600)
+    -- Past the window, or once the tier shown is the one charged, the record settles with nothing to announce:
+    -- the service grants the change at its next renewal check.
+    changeTier ri delay purchaseId = do
+      user <- withStore $ \db -> getUser db userId
+      p_ <- withStore' (`getBadgePurchase` purchaseId)
+      now <- badgeNow
+      case (p_, decodeJSON payment) of
+        (Just p@UserBadgePurchase {badgeType, shown = True}, Just payment')
+          | Just tier <- tierChangeCharge now payment', tier /= badgeType -> upgradeIssue ri delay user p payment' tier now
+        _ -> SRODeferred <$ withStore' (`settleStoreReceipt` receiptId)
+    -- the receipt's failures are recorded on the record, not as the purchase's failed renewal, as the badge shown still covers
+    upgradeIssue ri delay user p@UserBadgePurchase {badgePurchaseId} payment' tier now = do
+      failure_ <- newTVarIO Nothing
+      let upgradeCmd balance = BSCUpgradeBadgeSubscription {payment = payment', balance}
+      answer <- tryAllErrors $ requireBadgeService >>= \sendTarget -> sendBadgeIssue sendTarget userId p upgradeCmd (atomically . writeTVar failure_ . Just) now
+      answeredAt <- badgeNow
+      recorded_ <- readTVarIO failure_
+      case answer of
+        Left e -> failed ri delay (badgeIssueFailure e) Nothing
+        Right (Left (code, retryAfter))
+          | storeReceiptRefused code -> SRODeferred <$ withStore' (\db -> refuseStoreReceipt db receiptId $ serviceFailure code retryAfter)
+          | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter
+        Right (Right _) | Just failure <- recorded_ -> failed ri delay failure Nothing
+        Right (Right _) ->
+          withStore' (`getLatestIssuedCredential` badgePurchaseId) >>= \case
+            Just cred@(BadgeCredential _ _ _ info@BadgeInfo {badgeType = issuedType})
+              | issuedType == tier && credentialExpiry cred > answeredAt -> do
+                  user' <- withStore $ \db -> do
+                    liftIO $ settleStoreReceipt db receiptId
+                    setUserBadge db user (Just $ OwnBadge cred (mkBadgeStatus answeredAt (Just True) info))
+                  lift $ startBadgeWork user'
+                  pure $ SROCredited (Just user')
+            _ -> failed ri delay BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600)
     receiptInvalid = BIFServiceError {code = BSEReceiptInvalid, retryable = False}
     refuse failure = SRORefused failure <$ withStore' (\db -> refuseStoreReceipt db receiptId failure)
     serviceFailure code retryAfter = BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter}
@@ -6047,18 +6121,23 @@ badgeErrorRetry = badgeFailureTransient . badgeIssueFailure
 requestBadgeIssue :: UserId -> UserBadgePurchase -> UTCTime -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (StatementEntry, Maybe SubscriptionState))
 requestBadgeIssue userId p now = do
   sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwCmdError "badge service not configured") pure
-  withEntityLock "badgeIssue" (CLBadgeUser userId) $ sendBadgeIssue sendTarget userId p now
+  withEntityLock "badgeIssue" (CLBadgeUser userId) $ sendBadgeIssue sendTarget userId p BSCIssueBadge (recordBadgeIssueFailure p) now
+
+recordBadgeIssueFailure :: UserBadgePurchase -> BadgeIssueFailure -> CM ()
+recordBadgeIssueFailure UserBadgePurchase {badgePurchaseId} failure = do
+  failedAt <- badgeNow
+  withStore' $ \db -> setBadgeIssueError db badgePurchaseId failedAt failure
 
 -- | 'requestBadgeIssue' for a caller that already holds the owner's badge lock, which is not reentrant.
-sendBadgeIssue :: ConnectTarget 'CMContact -> UserId -> UserBadgePurchase -> UTCTime -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (StatementEntry, Maybe SubscriptionState))
-sendBadgeIssue sendTarget userId UserBadgePurchase {badgePurchaseId, badgeType, purchaseKey, purchasePrivKey, masterKey} now = do
+sendBadgeIssue :: ConnectTarget 'CMContact -> UserId -> UserBadgePurchase -> (BadgeBalance -> BadgeServiceCommand) -> (BadgeIssueFailure -> CM ()) -> UTCTime -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (StatementEntry, Maybe SubscriptionState))
+sendBadgeIssue sendTarget userId UserBadgePurchase {badgePurchaseId, badgeType, purchaseKey, purchasePrivKey, masterKey} command recordFailure now = do
   user <- withStore $ \db -> getUser db userId
   lastEntry <- withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= maybe (throwCmdError "badge ledger has no entry to assert") pure
   let req =
         BadgeServiceRequest
           { version = currentBadgeServiceVersion,
             purchaseKey = Just purchaseKey,
-            request = BSCIssueBadge {balance = BadgeBalance {lastEntry}}
+            request = command BadgeBalance {lastEntry}
           }
   respData <-
     sendServiceRequestTo NRMBackground user sendTarget Nothing (Just purchasePrivKey) req
@@ -6072,7 +6151,7 @@ sendBadgeIssue sendTarget userId UserBadgePurchase {badgePurchaseId, badgeType,
       storedAt <- badgeNow
       let -- past the asserted coverage the state is the store's, except within an hour of an earlier check, when it can be
           -- the last successful check's (a later fresh answer or device report corrects it); before then it can be a year old.
-          -- Ended is never stale: the service writes it only from a store check, after which it grants nothing.
+          -- Ended is never stale: the service answers it only from a store check, or once the payment moved to another key, after which it grants nothing.
           -- Its receiver must retire on it: a pass reads a stored ended with the badge still shown as the device's report
           storedSubscription = boundedSubscriptionState <$> find (\s -> L.paidThrough lastEntry <= now || s == SSEnded) subscription
       (applied, balance_) <- withStore' $ \db -> do
@@ -6102,9 +6181,6 @@ sendBadgeIssue sendTarget userId UserBadgePurchase {badgePurchaseId, badgeType,
     recordUnexpected message = do
       eToView $ ChatError $ CEInternalError $ T.unpack message
       recordFailure BIFUnexpected {message}
-    recordFailure failure = do
-      failedAt <- badgeNow
-      withStore' $ \db -> setBadgeIssueError db badgePurchaseId failedAt failure
 
 -- | The signature covers the master key inside the credential, so it verifies no matter which key
 -- that is - the credential is stored only when that key is also this purchase's.
@@ -6190,6 +6266,7 @@ applyBadgeStatement db g purchaseId badgeType BadgeStatement {entries} cred_ now
   -- and restate as one opening credit instead (badges-rpc.md), which is checked without a tip.
   tip <- getBadgeLedgerLastEntry db purchaseId
   storeBadgeStatement db purchaseId badgeType tip entries now
+  getBadgeLedgerLastEntry db purchaseId >>= mapM_ (\StatementEntry {balanceBadgeType} -> setBadgePurchaseType db purchaseId balanceBadgeType now)
   case (,) <$> cred_ <*> issuedEntryId of
     Nothing -> pure True
     Just (cred, entryUuid) ->
@@ -6617,7 +6694,7 @@ chatCommandP =
       "/_reject " *> (APIRejectContact <$> A.decimal <*> (" notify=" *> onOffP <|> pure False)),
       "/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP),
       "/_redeem_badge_code " *> (APIRedeemBadgeCode <$> A.decimal <* A.space <*> textP),
-      "/_badge purchase " *> (APIPurchaseBadge <$> A.decimal <*> optional (" invoice=" *> (safeDecodeUtf8 <$> A.takeTill (== ' '))) <*> (" listed" $> SROListed <|> pure SROPurchased) <* A.space <*> jsonP),
+      "/_badge purchase " *> (APIPurchaseBadge <$> A.decimal <*> optional (" invoice=" *> (safeDecodeUtf8 <$> A.takeTill (== ' '))) <*> (" listed" $> SROListed <|> " restored" $> SRORestored <|> pure SROPurchased) <* A.space <*> jsonP),
       "/_badge subscription " *> (APISetBadgeSubscriptionStatus <$> subscriptionStateP <* A.space <*> jsonP),
       "/_badge invoice " *> (APICreateBadgeInvoice <$> A.decimal),
       "/_badge state " *> (APIGetBadgeState <$> A.decimal),

src/Simplex/Chat/PaymentService.hs

@@ -68,6 +68,7 @@ appleTransactionRef = applePayloadRef <=< applePayload
 -- presents next: the service verifies whatever it is sent.
 data AppleTransactionFacts = AppleTransactionFacts
   { transactionId :: Text,
+    productId :: Maybe Text,
     purchaseDate :: Maybe Int64, -- epoch milliseconds
     expiresDate :: Maybe Int64, -- epoch milliseconds
     revoked :: Bool,
@@ -81,12 +82,13 @@ appleTransactionFacts = JT.parseMaybe facts <=< applePayload
   where
     facts o = do
       transactionId <- o J..: "transactionId"
+      productId <- o J..:? "productId" <|> pure Nothing
       purchaseDate <- o J..:? "purchaseDate" <|> pure Nothing
       expiresDate <- o J..:? "expiresDate" <|> pure Nothing
       -- as the service reads it: null is not revoked
       revoked <- isJust <$> (o J..:? "revocationDate" :: JT.Parser (Maybe J.Value))
       type_ <- o J..:? "type" <|> pure Nothing
-      pure AppleTransactionFacts {transactionId, purchaseDate, expiresDate, revoked, autoRenewable = type_ == Just ("Auto-Renewable Subscription" :: Text)}
+      pure AppleTransactionFacts {transactionId, productId, purchaseDate, expiresDate, revoked, autoRenewable = type_ == Just ("Auto-Renewable Subscription" :: Text)}
 
 -- | A subscription is named by its original transaction id, which every renewal keeps, so all its
 -- charges claim one purchase; any other transaction by its own id.

src/Simplex/Chat/Store/Badges.hs

@@ -25,7 +25,9 @@ module Simplex.Chat.Store.Badges
     createBadgeCodeRedemption,
     BadgeReceiptRecord (..),
     BadgeReceiptStatus (..),
+    StoreHoldKind (..),
     holdStoreReceipt,
+    holdStoreTransfer,
     getReceiptRecord,
     createBadgeStoreReceipt,
     getOpenStorePurchases,
@@ -43,6 +45,7 @@ module Simplex.Chat.Store.Badges
     storeBadgeIssuance,
     getLatestIssuedCredential,
     storeBadgeStatement,
+    setBadgePurchaseType,
     getBadgeLedgerLastEntry,
     getBadgeLedger,
     getBadgeLedgerEntryId,
@@ -62,24 +65,28 @@ 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 (..), BadgeSubscription (..), OpenStorePurchase (..), StoreReceiptOrigin (..), SubscriptionState)
+import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure (..), BadgePurchaseStatus (..), BadgeServiceErrorCode (..), BadgeSubscription (..), OpenStorePurchase (..), StoreReceiptOrigin (..), SubscriptionState)
 import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts)
 import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..))
 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 (..))
+import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), fromTextField_)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String (strEncode)
+import Simplex.Messaging.Encoding.String (TextEncoding (..), strEncode)
 import Simplex.Messaging.Util (decodeJSON, maybeFirstRow, maybeFirstRow', safeDecodeUtf8)
 
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple (Only (..), (:.) (..))
+import Database.PostgreSQL.Simple.FromField (FromField (..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
 #else
 import Database.SQLite.Simple (Only (..), (:.) (..))
+import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.QQ (sql)
+import Database.SQLite.Simple.ToField (ToField (..))
 #endif
 
 -- | The keys one attempt to fund a badge is signed with, stashed before the request is sent so that
@@ -127,10 +134,30 @@ data BadgeReceiptRecord = BadgeReceiptRecord
   }
 
 data BadgeReceiptStatus
-  = RSHeld {stash :: BadgeStash, invoiceId :: Maybe Text, payment :: Text, nextAttemptAt :: UTCTime, retryDelay :: Maybe Int64}
-  | RSCredited {badgePurchaseId :: Int64, refusalRecorded :: Bool} -- a resume of it was refused
+  = RSHeld {stash :: BadgeStash, invoiceId :: Maybe Text, payment :: Text, nextAttemptAt :: UTCTime, retryDelay :: Maybe Int64, holdKind :: StoreHoldKind}
+  | RSCredited {badgePurchaseId :: Int64, refusalRecorded :: Bool} -- a resume or a tier change of it was refused
   | RSRefused {refusal :: Maybe BadgeIssueFailure}
 
+-- | What a held record waits for: its own purchase, or the resume of one, a move of its payment to new keys,
+-- or a change of the tier of the purchase it funds.
+data StoreHoldKind = SHKPurchase | SHKTransfer | SHKTierChange
+  deriving (Eq, Show)
+
+instance TextEncoding StoreHoldKind where
+  textEncode = \case
+    SHKPurchase -> "purchase"
+    SHKTransfer -> "transfer"
+    SHKTierChange -> "tier_change"
+  textDecode = \case
+    "purchase" -> Just SHKPurchase
+    "transfer" -> Just SHKTransfer
+    "tier_change" -> Just SHKTierChange
+    _ -> Nothing
+
+instance FromField StoreHoldKind where fromField = fromTextField_ textDecode
+
+instance ToField StoreHoldKind where toField = toField . textEncode
+
 -- | Resolves a store transaction to the record that owns it, looking up by its reference again after each step
 -- rather than trusting the write: finding none still leaves the echoed invoice's record to attach it to, and a
 -- concurrent hand-over of the same transaction may win either write. It stays with the record that already has
@@ -163,12 +190,15 @@ holdStoreReceipt db g User {userId} origin invoiceId_ txRef@StoreTransactionRef
         Just r -> pure $ Just r
         Nothing -> case origin of
           SROPurchased -> do
-            insertReceipt
+            insertReceipt SHKPurchase
+            getReceiptRecord db txRef
+          SRORestored -> do
+            insertReceipt SHKTransfer
             getReceiptRecord db txRef
           SROListed -> pure Nothing
   where
     paymentJSON = safeDecodeUtf8 . LB.toStrict $ J.encode payment
-    insertReceipt = do
+    insertReceipt holdKind = do
       (purchaseKey, purchasePrivKey) <- atomically (C.generateKeyPair g) :: IO C.KeyPairEd25519
       BadgeMasterKey mk <- generateMasterKey g
       -- an invoice id another record holds is not repeated: this record is then keyed by its transaction alone
@@ -179,11 +209,54 @@ holdStoreReceipt db g User {userId} origin invoiceId_ txRef@StoreTransactionRef
         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, next_attempt_at, purchase_key, purchase_priv_key, master_key, hold_kind, created_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?)
           ON CONFLICT DO NOTHING
         |]
-        ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, now))
+        ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, holdKind, now))
+
+-- | Restore's hand-over of a transaction already recorded: a record that funds no purchase of this profile, or only one
+-- its payment moved away from, is taken by this profile and held as a move of its payment to it. True when its last refusal was transfer_limited, which the hand-over answers.
+holdStoreTransfer :: DB.Connection -> TVar ChaChaDRG -> User -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO Bool
+holdStoreTransfer db g User {userId} txRef payment now =
+  getReceiptRecord db txRef >>= \case
+    Just BadgeReceiptRecord {receiptId, status = RSHeld {stash, holdKind = SHKPurchase}} ->
+      getStashBadgePurchase db stash >>= \case
+        Nothing ->
+          False
+            <$ DB.execute
+              db
+              "UPDATE badge_store_receipts SET user_id = ?, hold_kind = ?, next_attempt_at = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL AND hold_kind = ?"
+              (userId, SHKTransfer, now, receiptId, SHKPurchase)
+        Just _ -> pure False
+    Just BadgeReceiptRecord {receiptId, status = RSRefused {refusal = Just BIFServiceError {code}}}
+      | code == BSEReceiptUsed || code == BSETransferLimited -> (code == BSETransferLimited) <$ holdTransfer receiptId
+    Just BadgeReceiptRecord {receiptId, ownerId, status = RSCredited {badgePurchaseId}} ->
+      movesHere ownerId badgePurchaseId >>= \case
+        False -> pure False
+        True -> do
+          lastRefusal <- maybeFirstRow fromOnly $ DB.query db "SELECT credit_error FROM badge_store_receipts WHERE badge_store_receipt_id = ?" (Only receiptId)
+          (purchaseKey, purchasePrivKey) <- atomically (C.generateKeyPair g) :: IO C.KeyPairEd25519
+          BadgeMasterKey mk <- generateMasterKey g
+          DB.execute db "UPDATE badge_store_receipts SET purchase_key = ?, purchase_priv_key = ?, master_key = ? WHERE badge_store_receipt_id = ? AND payment IS NULL" (purchaseKey, purchasePrivKey, Binary mk, receiptId)
+          holdTransfer receiptId
+          pure $ case join lastRefusal of
+            Just BIFServiceError {code = BSETransferLimited} -> True
+            _ -> False
+    _ -> pure False
+  where
+    -- the service answers a purchase whose payment moved away ended, so a resume of it never succeeds
+    movesHere ownerId badgePurchaseId
+      | ownerId /= userId = pure True
+      | otherwise = maybe False movedOut <$> getBadgeLedgerLastEntry db badgePurchaseId
+    movedOut StatementEntry {entryType} = case entryType of
+      SEDebit SDTransferOut {} -> True
+      _ -> False
+    holdTransfer receiptId =
+      DB.execute
+        db
+        "UPDATE badge_store_receipts SET user_id = ?, payment = ?, next_attempt_at = ?, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ? WHERE badge_store_receipt_id = ? AND payment IS NULL"
+        (userId, safeDecodeUtf8 . LB.toStrict $ J.encode payment, now, SHKTransfer, receiptId)
 
 -- | Whether a held Apple record presents this payment next: another transaction of its subscription, bought
 -- later and not revoked. The core decides which is newest, since the app's store listener races its sweep, and a
@@ -204,19 +277,23 @@ getReceiptRecord db StoreTransactionRef {provider, transactionRef} =
       db
       [sql|
         SELECT r.badge_store_receipt_id, r.user_id, r.purchase_key, r.purchase_priv_key, r.master_key,
-          r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, p.badge_purchase_id, r.credit_error
+          r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, p.badge_purchase_id, r.credit_error, r.hold_kind
         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 = ?
       |]
       (provider, transactionRef)
   where
-    toReceiptRecord ((receiptId, ownerId, purchaseKey, purchasePrivKey, mk) :. (invoiceId, payment_, nextAttemptAt_, retryDelay, purchaseId_, refusal)) =
+    toReceiptRecord ((receiptId, ownerId, purchaseKey, purchasePrivKey, mk) :. (invoiceId, payment_, nextAttemptAt_, retryDelay, purchaseId_, refusal, holdKind)) =
       BadgeReceiptRecord {receiptId, ownerId, status}
       where
         status = case (payment_, nextAttemptAt_) of
-          (Just payment, Just nextAttemptAt) -> RSHeld {stash = toBadgeStash BSRStoreReceipt (receiptId, purchaseKey, purchasePrivKey, mk), invoiceId, payment, nextAttemptAt, retryDelay}
-          _ -> maybe (RSRefused refusal) (\badgePurchaseId -> RSCredited {badgePurchaseId, refusalRecorded = isJust refusal}) purchaseId_
+          (Just payment, Just nextAttemptAt) -> RSHeld {stash = toBadgeStash BSRStoreReceipt (receiptId, purchaseKey, purchasePrivKey, mk), invoiceId, payment, nextAttemptAt, retryDelay, holdKind}
+          _ -> maybe (RSRefused refusal) (\badgePurchaseId -> RSCredited {badgePurchaseId, refusalRecorded = maybe False ownRefusal refusal}) purchaseId_
+        -- only a move is refused transfer_limited, and a refused move must not hold off the purchase's own resume or tier change
+        ownRefusal = \case
+          BIFServiceError {code = BSETransferLimited} -> False
+          _ -> True
 
 -- | 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 ()
@@ -252,23 +329,26 @@ getPendingStoreReceipts :: DB.Connection -> User -> IO [(Text, Maybe BadgeIssueF
 getPendingStoreReceipts db User {userId} =
   DB.query db "SELECT payment, credit_error FROM badge_store_receipts WHERE user_id = ? AND payment IS NOT NULL" (Only userId)
 
+-- | A profile showing a badge waits with its held records, but for a change of the tier of the badge it shows.
 getNextHeldStoreReceipt :: DB.Connection -> UserId -> IO (Either StoreError (Maybe BadgeReceiptRecord))
 getNextHeldStoreReceipt db userId =
   fmap Right . maybeFirstRow toHeld $
     DB.query
       db
       [sql|
-        SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay
+        SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, r.hold_kind
         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
+        LEFT JOIN badge_purchases p ON p.badge_store_receipt_id = r.badge_store_receipt_id
+        WHERE r.user_id = ? AND r.payment IS NOT NULL
+          AND (u.shown_badge_id IS NULL OR (r.hold_kind = ? AND u.shown_badge_id = p.badge_purchase_id))
         ORDER BY r.next_attempt_at, r.retry_count, r.badge_store_receipt_id
         LIMIT 1
       |]
-      (Only userId)
+      (userId, SHKTierChange)
   where
-    toHeld (stashRow@(receiptId, _, _, _) :. (invoiceId, payment, nextAttemptAt, retryDelay)) =
-      BadgeReceiptRecord {receiptId, ownerId = userId, status = RSHeld {stash = toBadgeStash BSRStoreReceipt stashRow, invoiceId, payment, nextAttemptAt, retryDelay}}
+    toHeld (stashRow@(receiptId, _, _, _) :. (invoiceId, payment, nextAttemptAt, retryDelay, holdKind)) =
+      BadgeReceiptRecord {receiptId, ownerId = userId, status = RSHeld {stash = toBadgeStash BSRStoreReceipt stashRow, invoiceId, payment, nextAttemptAt, retryDelay, holdKind}}
 
 -- | Only while the record still holds the payment that failed: one adopted meanwhile is due at once.
 recordStoreReceiptFailure :: DB.Connection -> Int64 -> Text -> Int64 -> UTCTime -> BadgeIssueFailure -> IO ()
@@ -283,37 +363,43 @@ recordStoreReceiptFailure db receiptId payment retryDelay nextAttemptAt failure
     (retryDelay, nextAttemptAt, failure, receiptId, payment)
 
 -- | Kept rather than deleted, so that a later hand-over of the same transaction is answered from the record.
+-- A refused move returns the record to the profile whose purchase it still funds.
 refuseStoreReceipt :: DB.Connection -> Int64 -> BadgeIssueFailure -> IO ()
 refuseStoreReceipt db receiptId refusal =
   DB.execute
     db
-    "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ? WHERE badge_store_receipt_id = ?"
-    (refusal, receiptId)
+    [sql|
+      UPDATE badge_store_receipts
+      SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ?, hold_kind = ?,
+        user_id = COALESCE((SELECT p.user_id FROM badge_purchases p WHERE p.badge_store_receipt_id = ?), user_id)
+      WHERE badge_store_receipt_id = ?
+    |]
+    (refusal, SHKPurchase, receiptId, receiptId)
 
--- | Every settle clears the failure, so one recorded on a credited record is a refused resume.
+-- | Every settle clears the failure, so one recorded on a credited record is a refused resume or tier change.
 settleStoreReceipt :: DB.Connection -> Int64 -> IO ()
 settleStoreReceipt db receiptId =
   DB.execute
     db
-    "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL WHERE badge_store_receipt_id = ?"
-    (Only receiptId)
+    "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ? WHERE badge_store_receipt_id = ?"
+    (SHKPurchase, receiptId)
 
 -- | Whether a later charge of a credited record's subscription is answered as held: its purchase must be its owner's
--- newest, a subscription and not shown. The record is held again only while no other receipt of the owner is held,
--- which the receipt worker would credit first and then skip this one while its badge is shown; until then the app
--- keeps the charge unfinished and hands it over again.
-reholdStoreReceipt :: DB.Connection -> User -> Int64 -> Int64 -> ServicePayment -> UTCTime -> IO Bool
-reholdStoreReceipt db owner receiptId badgePurchaseId payment now = do
+-- newest and a subscription, not shown for a resume and shown for a tier change. The record is held again only while no
+-- other receipt of the owner is held, which the receipt worker would credit first and then skip this one while its badge
+-- is shown; until then the app keeps the charge unfinished and hands it over again.
+reholdStoreReceipt :: DB.Connection -> User -> Int64 -> Int64 -> StoreHoldKind -> ServicePayment -> UTCTime -> IO Bool
+reholdStoreReceipt db owner receiptId badgePurchaseId holdKind payment now = do
   newest_ <- getUserBadgePurchase db owner
   pending <- getPendingStoreReceipts db owner
   case newest_ of
-    Just UserBadgePurchase {badgePurchaseId = newestId, shown = False, purchaseKind = PKSubscription _}
-      | newestId == badgePurchaseId -> do
+    Just UserBadgePurchase {badgePurchaseId = newestId, shown, purchaseKind = PKSubscription _}
+      | newestId == badgePurchaseId && shown == (holdKind == SHKTierChange) -> do
           when (null pending) $
             DB.execute
               db
-              "UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, retry_count = 0, credit_error = NULL WHERE badge_store_receipt_id = ? AND payment IS NULL"
-              (safeDecodeUtf8 . LB.toStrict $ J.encode payment, now, receiptId)
+              "UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ? WHERE badge_store_receipt_id = ? AND payment IS NULL"
+              (safeDecodeUtf8 . LB.toStrict $ J.encode payment, now, holdKind, receiptId)
           pure True
     _ -> pure False
 
@@ -358,6 +444,12 @@ deleteBadgeCodeRedemption db User {userId} code =
 -- 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 = do
+  -- a moved payment's record still links the purchase it moved from, which would be taken for a replay
+  forM_ storeReceiptId_ $ \receiptId ->
+    DB.execute
+      db
+      "UPDATE badge_purchases SET badge_store_receipt_id = NULL WHERE badge_store_receipt_id = ? AND EXISTS (SELECT 1 FROM badge_store_receipts WHERE badge_store_receipt_id = ? AND hold_kind = ?)"
+      (receiptId, receiptId, SHKTransfer)
   -- the credit settles a held receipt in the transaction that stores its purchase, a replay included
   forM_ storeReceiptId_ $ settleStoreReceipt db
   getStashBadgePurchase db stash >>= \case
@@ -416,7 +508,7 @@ getLatestIssuedCredential db badgePurchaseId = do
       [sql|
         SELECT credential FROM badge_issuances
         WHERE badge_purchase_id = ?
-        ORDER BY period_end DESC
+        ORDER BY entry_id DESC
         LIMIT 1
       |]
       (Only badgePurchaseId)
@@ -618,6 +710,10 @@ storeBadgeStatement db badgePurchaseId badgeType tip entries now =
           SEDebit SDUnknown {} -> True
           _ -> False
 
+setBadgePurchaseType :: DB.Connection -> Int64 -> BadgeType -> UTCTime -> IO ()
+setBadgePurchaseType db badgePurchaseId badgeType now =
+  DB.execute db "UPDATE badge_purchases SET current_badge_type = ?, updated_at = ? WHERE badge_purchase_id = ?" (badgeType, now, badgePurchaseId)
+
 -- | The balance is the last row; nothing derives it by summing the history.
 getBadgeLedgerLastEntry :: DB.Connection -> Int64 -> IO (Maybe StatementEntry)
 getBadgeLedgerLastEntry db badgePurchaseId =
@@ -653,7 +749,7 @@ getBadgeLedger db User {userId} badgePurchaseId =
 toStatementEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType) :. (Maybe UTCTime, UTCTime, Text, Maybe Text, Maybe Text, Maybe Text) -> Maybe StatementEntry
 toStatementEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType) :. (wasPausedSince, createdAt, entryType_, credit_, debit_, value_)) =
   (\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType})
-    <$> maybe (entryTypeFromColumns Nothing Nothing entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
+    <$> maybe (entryTypeFromColumns noEntryReferences entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
 
 -- | Decodes the stored JSON rather than rebuilding from the tag, so a version that has since
 -- learnt the type reads it with its fields, and one that has not still gets it back verbatim.

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

@@ -152,7 +152,7 @@ DROP TABLE @badge_prices;
 |]
 
 {- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
-The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, and @subscription_charges and @badge_ledger.charge_id in its 20261012_badge_subscriptions, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
+The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, and @subscription_charges, @badge_ledger.charge_id, @badge_ledger.from_purchase_id and to_purchase_id in its 20261012_badge_subscriptions, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
 
 CREATE TABLE @badge_invoices(
   invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE,
@@ -185,19 +185,7 @@ CREATE TABLE @badge_subscription_changes(
 
 CREATE INDEX @idx_badge_subscription_changes_purchase ON @badge_subscription_changes(badge_purchase_id);
 
-ALTER TABLE @badge_ledger ADD COLUMN from_purchase_id BIGINT REFERENCES @badge_purchases;
-
-ALTER TABLE @badge_ledger ADD COLUMN to_purchase_id BIGINT REFERENCES @badge_purchases;
-
-CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id);
-
-CREATE INDEX @idx_badge_ledger_to_purchase ON @badge_ledger(to_purchase_id);
-
 -- down
-DROP INDEX @idx_badge_ledger_from_purchase;
-DROP INDEX @idx_badge_ledger_to_purchase;
-ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id;
-ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id;
 DROP INDEX @idx_badge_subscription_changes_purchase;
 DROP TABLE @badge_subscription_changes;
 DROP INDEX @idx_badge_invoices_purchase;

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

@@ -14,11 +14,15 @@ ALTER TABLE badge_purchases ADD COLUMN subscription_status TEXT;
 ALTER TABLE badge_purchases ADD COLUMN unrenewed_since TIMESTAMPTZ;
 
 ALTER TABLE badge_purchases ADD COLUMN last_unrenewed_at TIMESTAMPTZ;
+
+ALTER TABLE badge_store_receipts ADD COLUMN hold_kind TEXT NOT NULL DEFAULT 'purchase';
 |]
 
 down_m20261017_badge_subscriptions :: Text
 down_m20261017_badge_subscriptions =
   [r|
+ALTER TABLE badge_store_receipts DROP COLUMN hold_kind;
+
 UPDATE badge_purchases SET alert_acked_kind = NULL, alert_acked_episode = NULL, alert_snooze_until = NULL WHERE alert_acked_kind = 'subscription_cancelled';
 
 ALTER TABLE badge_purchases DROP COLUMN last_unrenewed_at;

src/Simplex/Chat/Store/Profiles.hs

@@ -287,7 +287,18 @@ getUserFileInfo db User {userId} =
     <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ?") (Only userId)
 
 deleteUserRecord :: DB.Connection -> User -> IO ()
-deleteUserRecord db User {userId} =
+deleteUserRecord db User {userId} = do
+  -- a move held for this profile returns the record to the profile whose purchase still links it, without the move's failures
+  DB.execute
+    db
+    [sql|
+      UPDATE badge_store_receipts
+      SET user_id = (SELECT p.user_id FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id),
+        payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = 'purchase'
+      WHERE user_id = ?
+        AND EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id AND p.user_id != ?)
+    |]
+    (userId, userId)
   DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId)
 
 updateUserPrivacy :: DB.Connection -> User -> IO ()

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

@@ -153,7 +153,7 @@ DROP TABLE @badge_prices;
 |]
 
 {- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
-The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, and @subscription_charges and @badge_ledger.charge_id in its 20261012_badge_subscriptions, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
+The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, and @subscription_charges, @badge_ledger.charge_id, @badge_ledger.from_purchase_id and to_purchase_id in its 20261012_badge_subscriptions, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
 
 CREATE TABLE @badge_invoices(
   invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE,
@@ -186,19 +186,7 @@ CREATE TABLE @badge_subscription_changes(
 
 CREATE INDEX @idx_badge_subscription_changes_purchase ON @badge_subscription_changes(badge_purchase_id);
 
-ALTER TABLE @badge_ledger ADD COLUMN from_purchase_id INTEGER REFERENCES @badge_purchases;
-
-ALTER TABLE @badge_ledger ADD COLUMN to_purchase_id INTEGER REFERENCES @badge_purchases;
-
-CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id);
-
-CREATE INDEX @idx_badge_ledger_to_purchase ON @badge_ledger(to_purchase_id);
-
 -- down
-DROP INDEX @idx_badge_ledger_from_purchase;
-DROP INDEX @idx_badge_ledger_to_purchase;
-ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id;
-ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id;
 DROP INDEX @idx_badge_subscription_changes_purchase;
 DROP TABLE @badge_subscription_changes;
 DROP INDEX @idx_badge_invoices_purchase;

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

@@ -13,11 +13,15 @@ ALTER TABLE badge_purchases ADD COLUMN subscription_status TEXT;
 ALTER TABLE badge_purchases ADD COLUMN unrenewed_since TEXT;
 
 ALTER TABLE badge_purchases ADD COLUMN last_unrenewed_at TEXT;
+
+ALTER TABLE badge_store_receipts ADD COLUMN hold_kind TEXT NOT NULL DEFAULT 'purchase';
 |]
 
 down_m20261017_badge_subscriptions :: Query
 down_m20261017_badge_subscriptions =
   [sql|
+ALTER TABLE badge_store_receipts DROP COLUMN hold_kind;
+
 UPDATE badge_purchases SET alert_acked_kind = NULL, alert_acked_episode = NULL, alert_snooze_until = NULL WHERE alert_acked_kind = 'subscription_cancelled';
 
 ALTER TABLE badge_purchases DROP COLUMN last_unrenewed_at;

src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt

@@ -3830,12 +3830,11 @@ SEARCH cp USING INTEGER PRIMARY KEY (rowid=?)
 Query: 
         SELECT credential FROM badge_issuances
         WHERE badge_purchase_id = ?
-        ORDER BY period_end DESC
+        ORDER BY entry_id DESC
         LIMIT 1
-      
+
 Plan:
 SEARCH badge_issuances USING INDEX idx_badge_issuances_purchase_entry (badge_purchase_id=?)
-USE TEMP B-TREE FOR ORDER BY
 
 Query: 
         SELECT ct.contact_id

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

@@ -1015,6 +1015,7 @@ CREATE TABLE badge_store_receipts(
   retry_delay INTEGER,
   retry_count INTEGER NOT NULL DEFAULT 0,
   credit_error TEXT,
+  hold_kind TEXT NOT NULL DEFAULT 'purchase',
   UNIQUE(provider, transaction_ref)
 ) STRICT;
 CREATE INDEX contact_profiles_index ON contact_profiles(