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

apps/ios/Shared/Model/AppAPITypes.swift

@@ -193,7 +193,7 @@ enum ChatCommand: ChatCmdProtocol {
     case apiStandaloneFileInfo(url: String)
     // badges
     case apiRedeemBadgeCode(userId: Int64, code: String)
-    case apiPurchaseBadge(userId: Int64, echoedInvoiceId: String?, listed: Bool, payment: ServicePayment)
+    case apiPurchaseBadge(userId: Int64, echoedInvoiceId: String?, origin: StoreReceiptOrigin, payment: ServicePayment)
     case apiSetBadgeSubscriptionStatus(status: BadgeSubscriptionState, payment: ServicePayment)
     case apiCreateBadgeInvoice(userId: Int64)
     case apiGetBadgeState(userId: Int64)
@@ -422,8 +422,8 @@ enum ChatCommand: ChatCmdProtocol {
             case let .apiDownloadStandaloneFile(userId, link, file): return "/_download \(userId) \(link) \(file.filePath)"
             case let .apiStandaloneFileInfo(link): return "/_download info \(link)"
             case let .apiRedeemBadgeCode(userId, code): return "/_redeem_badge_code \(userId) \(code)"
-            case let .apiPurchaseBadge(userId, echoedInvoiceId, listed, payment):
-                return "/_badge purchase \(userId)\(echoedInvoiceId.map { " invoice=\($0)" } ?? "")\(listed ? " listed" : "") \(encodeJSON(payment))"
+            case let .apiPurchaseBadge(userId, echoedInvoiceId, origin, payment):
+                return "/_badge purchase \(userId)\(echoedInvoiceId.map { " invoice=\($0)" } ?? "")\(storeReceiptOriginParam(origin)) \(encodeJSON(payment))"
             case let .apiSetBadgeSubscriptionStatus(status, payment): return "/_badge subscription \(status.text) \(encodeJSON(payment))"
             case let .apiCreateBadgeInvoice(userId): return "/_badge invoice \(userId)"
             case let .apiGetBadgeState(userId): return "/_badge state \(userId)"
@@ -680,8 +680,8 @@ enum ChatCommand: ChatCmdProtocol {
         // a code or a store receipt is a bearer secret until it is redeemed, and the terminal shows and copies cmdString
         case let .apiRedeemBadgeCode(userId, code):
             return .apiRedeemBadgeCode(userId: userId, code: obfuscate(code))
-        case let .apiPurchaseBadge(userId, echoedInvoiceId, listed, .apple(jws)):
-            return .apiPurchaseBadge(userId: userId, echoedInvoiceId: echoedInvoiceId, listed: listed, payment: .apple(jws: obfuscate(jws)))
+        case let .apiPurchaseBadge(userId, echoedInvoiceId, origin, .apple(jws)):
+            return .apiPurchaseBadge(userId: userId, echoedInvoiceId: echoedInvoiceId, origin: origin, payment: .apple(jws: obfuscate(jws)))
         case let .apiSetBadgeSubscriptionStatus(status, .apple(jws)):
             return .apiSetBadgeSubscriptionStatus(status: status, payment: .apple(jws: obfuscate(jws)))
         default: return self
@@ -724,6 +724,14 @@ enum ChatCommand: ChatCmdProtocol {
         }
     }
 
+    private func storeReceiptOriginParam(_ origin: StoreReceiptOrigin) -> String {
+        switch origin {
+        case .purchased: ""
+        case .listed: " listed"
+        case .restored: " restored"
+        }
+    }
+
     private func maybeContent(_ mc: MsgContent?) -> String {
         if case let .text(s) = mc, s.isEmpty {
             ""
@@ -752,6 +760,14 @@ enum ServicePayment: Encodable {
     }
 }
 
+enum StoreReceiptOrigin {
+    case purchased
+    // found in the store's list rather than bought or restored here, so core records it only into a record it has
+    case listed
+    // Restore: core claims it for this profile, moving it from another device or profile it was credited to
+    case restored
+}
+
 struct OpenStorePurchase: Decodable {
     var invoiceId: String?
     var transactionRef: String?

apps/ios/Shared/Model/SimpleXAPI.swift

@@ -2209,9 +2209,8 @@ enum BadgePurchaseResult {
 }
 
 // log: false because a store receipt is a bearer secret, like a badge code - it is in the command.
-// listed: found in the store's list rather than bought or restored here, so core records it only into a record it has.
-func apiPurchaseBadge(_ userId: Int64, _ echoedInvoiceId: String?, listed: Bool, _ payment: ServicePayment) async throws -> BadgePurchaseResult {
-    let r: ChatResponse2 = try await chatSendCmd(.apiPurchaseBadge(userId: userId, echoedInvoiceId: echoedInvoiceId, listed: listed, payment: payment), log: false)
+func apiPurchaseBadge(_ userId: Int64, _ echoedInvoiceId: String?, origin: StoreReceiptOrigin, _ payment: ServicePayment) async throws -> BadgePurchaseResult {
+    let r: ChatResponse2 = try await chatSendCmd(.apiPurchaseBadge(userId: userId, echoedInvoiceId: echoedInvoiceId, origin: origin, payment: payment), log: false)
     switch r {
     case let .badgeState(user, badgeState, storePurchases): return .held(user: user, badgeState: badgeState, storePurchases: storePurchases ?? [])
     case let .badgeRedeemed(user, _, _, badgeState): return .credited(user: user, badgeState: badgeState)

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

@@ -237,7 +237,7 @@ final class BadgeStore: ObservableObject {
                 }
             }
             if case let .purchased(receipt) = outcome, receipt.signatureVerified {
-                try await handOver(receipt, listed: false)
+                try await handOver(receipt, origin: .purchased)
             }
             await MainActor.run { buying = false }
             return outcome
@@ -261,11 +261,11 @@ final class BadgeStore: ObservableObject {
 
     // Core holds the receipt and credits it; the transaction stays unfinished until core answers it credited
     // or refused, as an unfinished transaction is what the store re-delivers if anything is lost on the way.
-    private func handOver(_ receipt: BadgeStoreReceipt, listed: Bool) async throws {
+    private func handOver(_ receipt: BadgeStoreReceipt, origin: StoreReceiptOrigin) async throws {
         guard let userId = await MainActor.run(body: { ChatModel.shared.currentUser?.userId }) else { return }
         // a refusal is announced from core's event for it, so only an unexpected answer reaches the buyer
         do {
-            switch try await apiPurchaseBadge(userId, receipt.echoedInvoiceId, listed: listed, .apple(jws: receipt.jws)) {
+            switch try await apiPurchaseBadge(userId, receipt.echoedInvoiceId, origin: origin, .apple(jws: receipt.jws)) {
             case let .held(user, badgeState, storePurchases):
                 await MainActor.run {
                     // the answer is the owner's, which may be another profile and a hidden one
@@ -290,6 +290,8 @@ final class BadgeStore: ObservableObject {
         } catch let error where badgeReceiptRefused(error) {
             logger.error("BadgeStore.handOver: \(responseError(error))")
             await receipt.transaction.finish()
+            // a limited move raises no event, so Restore learns of it only from this answer
+            if origin == .restored && badgeServiceErrorCode(error) == .transferLimited { throw error }
         }
     }
 
@@ -353,7 +355,7 @@ final class BadgeStore: ObservableObject {
     // the store lists an Apple ID's transactions on every device signed into it, so these are handed over as listed
     private func reconcileListed(_ verification: VerificationResult<Transaction>) async {
         // the receipt stays unfinished, so the next sweep hands it over again
-        do { try await reconcile(verification, listed: true) } catch let error {
+        do { try await reconcile(verification, origin: .listed) } catch let error {
             logger.error("BadgeStore.reconcile: \(responseError(error))")
             await MainActor.run {
                 // showAlert presents on the top view controller, which the launch sweep can precede;
@@ -367,7 +369,7 @@ final class BadgeStore: ObservableObject {
     }
 
     // an unverified transaction is never sent, and left unfinished rather than lost
-    private func reconcile(_ verification: VerificationResult<Transaction>, listed: Bool) async throws {
+    private func reconcile(_ verification: VerificationResult<Transaction>, origin: StoreReceiptOrigin) async throws {
         let receipt = storeReceipt(verification)
         let t = receipt.transaction
         if t.productType == .autoRenewable { await MainActor.run { _ = priorSubscriptions?.insert(String(t.originalID)) } }
@@ -377,7 +379,7 @@ final class BadgeStore: ObservableObject {
         } else if !badgeProductIds.contains(receipt.productId) {
             await t.finish()
         } else if receipt.signatureVerified {
-            try await handOver(receipt, listed: listed)
+            try await handOver(receipt, origin: origin)
         }
     }
 
@@ -424,17 +426,20 @@ final class BadgeStore: ObservableObject {
         await loadCurrentBadgeState()
     }
 
-    // Hands over as the device's own whatever the store lists, so a purchase no record here has is claimed by this profile.
+    // Hands over as restored whatever the store lists, so this profile claims it, also from another install or profile.
     // Answers whether a badge is shown, or a purchase is being added or awaits approval, afterwards.
-    // Reading currentEntitlements would not restore a subscription on another install or profile: the service credited
-    // the payment to the purchase key of the install that bought it, and answers any other key receipt_used.
     func restorePurchases() async throws -> Bool {
         try await AppStore.sync()
         var handOverError: Error? = nil
-        for await verification in Transaction.unfinished {
-            do { try await reconcile(verification, listed: false) } catch let error {
-                logger.error("BadgeStore.restorePurchases: \(responseError(error))")
-                if handOverError == nil { handOverError = error }
+        var handedOver: Set<UInt64> = []
+        for transactions in [Transaction.currentEntitlements, Transaction.unfinished] {
+            for await verification in transactions {
+                // a repeat would be refused once the first hand-over's badge is shown
+                guard handedOver.insert(verification.unsafePayloadValue.id).inserted else { continue }
+                do { try await reconcile(verification, origin: .restored) } catch let error {
+                    logger.error("BadgeStore.restorePurchases: \(responseError(error))")
+                    if handOverError == nil { handOverError = error }
+                }
             }
         }
         await reportSubscriptionStates()
@@ -507,8 +512,11 @@ private func storeReceipt(_ verification: VerificationResult<Transaction>) -> Ba
 // the codes core refuses a receipt with for good, after which the store may stop re-delivering it;
 // a sweep that hands over a receipt refused while the app was not running learns it only from this answer
 private func badgeReceiptRefused(_ error: Error) -> Bool {
-    if case let .error(.badgeRedeemError(.serviceError(code))) = error as? ChatError {
-        return code == .receiptInvalid || code == .receiptUsed || code == .testPurchase
-    }
-    return false
+    let code = badgeServiceErrorCode(error)
+    return code == .receiptInvalid || code == .receiptUsed || code == .testPurchase || code == .transferLimited
+}
+
+private func badgeServiceErrorCode(_ error: Error) -> BadgeServiceErrorCode? {
+    if case let .error(.badgeRedeemError(.serviceError(code))) = error as? ChatError { return code }
+    return nil
 }

apps/ios/SimpleXChat/APITypes.swift

@@ -857,6 +857,7 @@ public enum BadgeServiceErrorCode: Decodable, Hashable {
     case receiptInvalid
     case receiptUsed
     case testPurchase
+    case transferLimited
     case internalError
     case unknown(String)
 
@@ -880,6 +881,7 @@ public enum BadgeServiceErrorCode: Decodable, Hashable {
         case .receiptInvalid: "receipt_invalid"
         case .testPurchase: "test_purchase"
         case .receiptUsed: "receipt_used"
+        case .transferLimited: "transfer_limited"
         case .internalError: "internal"
         case let .unknown(s): s
         }
@@ -905,6 +907,7 @@ public enum BadgeServiceErrorCode: Decodable, Hashable {
         case "receipt_invalid": self = .receiptInvalid
         case "test_purchase": self = .testPurchase
         case "receipt_used": self = .receiptUsed
+        case "transfer_limited": self = .transferLimited
         case "internal": self = .internalError
         case let s: self = .unknown(s)
         }
@@ -923,6 +926,7 @@ public func badgeServiceErrorText(_ code: BadgeServiceErrorCode) -> String? {
     case .receiptInvalid: NSLocalizedString("The store did not confirm this purchase.", comment: "alert message")
     case .testPurchase: NSLocalizedString("Sandbox purchases are not credited. Badges can only be bought in the App Store version of the app.", comment: "alert message")
     case .receiptUsed: NSLocalizedString("This purchase was already credited to a badge on another device or profile.", comment: "alert message")
+    case .transferLimited: NSLocalizedString("This purchase was moved to another device or profile recently.", comment: "alert message")
     case .paymentPending: NSLocalizedString("The payment has not been confirmed yet.", comment: "alert message")
     case .providerUnavailable: NSLocalizedString("The store could not be reached.", comment: "alert message")
     case .providerNotConfigured: NSLocalizedString("Badges cannot be bought in the app yet.", comment: "alert message")

apps/ios/product/gaps.md

@@ -64,11 +64,11 @@ The Haskell Store modules (`Store/Direct.hs`, `Store/Groups.hs`, `Store/Messages
 
 ## Badges: Store Purchases
 
-### GAP: A badge subscription cannot be restored or bought again
+### GAP: A badge moves to another device or profile only once in a while, and is bought again only to continue the last purchase
 **Source:** [Shared/Views/Badges/BadgeStore.swift](../Shared/Views/Badges/BadgeStore.swift)
-Restoring a badge subscription on a new device or under another profile does not work, for two independent reasons. `restorePurchases()` reads `Transaction.unfinished`, so a purchase that was already finished is never found. And the service has credited the payment to the purchase key of the install that bought it, so a new key is answered `receipt_used`. Fixing only the client would turn "Nothing to restore" into a refusal, which is worse. On the same install a lapsed subscriber can subscribe again only to the badge the active profile's newest purchase retired: core resumes that purchase on the new charge, as Apple keeps the original transaction id. The app's gate (`forSale`, comparing the original ids in `Transaction.all`, read once a run, with the purchase's `transactionRef`) shuts subscriptions for any other profile, device or badge, and for the rest of the run after a purchase that awaits approval, which StoreKit does not list.
+`restorePurchases()` hands over `Transaction.currentEntitlements` and `Transaction.unfinished` as restored, and the service moves the subscription to the restoring profile's purchase key. A payment moves again only once the credential issued to the key it last moved from has expired; until then Restore is answered `transfer_limited`, and the first Restore of a limited payment adds nothing and shows nothing, so only the next Restore says why. A badge bought with Stripe or crypto cannot be moved at all. On the same install a lapsed subscriber can subscribe again only to the badge the active profile's newest purchase retired: core resumes that purchase on the new charge, as Apple keeps the original transaction id. The app's gate (`forSale`, comparing the original ids in `Transaction.all`, read once a run, with the purchase's `transactionRef`) shuts subscriptions for any other profile, device or badge, and for the rest of the run after a purchase that awaits approval, which StoreKit does not list.
 
-**REC:** A transfer design, in the service and the client, for new devices and profiles.
+**REC:** Restore by a receipt code for Stripe and crypto purchases, and announce a limited move on the first Restore.
 
 ---
 

apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt

@@ -595,9 +595,8 @@ object ChatController {
   }
 
   // log = false because a store receipt is a bearer secret, like a badge code - it is in the command.
-  // listed: found in the store's list rather than bought or restored here, so core records it only into a record it has.
-  suspend fun apiPurchaseBadge(rh: Long?, userId: Long, echoedInvoiceId: String?, listed: Boolean, payment: ServicePayment): BadgePurchaseResult {
-    val r = sendCmd(rh, CC.ApiPurchaseBadge(userId, echoedInvoiceId, listed, payment), log = false)
+  suspend fun apiPurchaseBadge(rh: Long?, userId: Long, echoedInvoiceId: String?, origin: StoreReceiptOrigin, payment: ServicePayment): BadgePurchaseResult {
+    val r = sendCmd(rh, CC.ApiPurchaseBadge(userId, echoedInvoiceId, origin, payment), log = false)
     return when {
       r is API.Result && r.res is CR.BadgeStateR -> BadgePurchaseResult.Held(r.res.user, r.res.badgeState, r.res.storePurchases)
       r is API.Result && r.res is CR.BadgeRedeemed -> BadgePurchaseResult.Credited(r.res.user.updateRemoteHostId(rh), r.res.badgeState)
@@ -4173,7 +4172,7 @@ sealed class CC {
   class ApiStandaloneFileInfo(val url: String): CC()
   // badges
   class ApiRedeemBadgeCode(val userId: Long, val code: String): CC()
-  class ApiPurchaseBadge(val userId: Long, val echoedInvoiceId: String?, val listed: Boolean, val payment: ServicePayment): CC()
+  class ApiPurchaseBadge(val userId: Long, val echoedInvoiceId: String?, val origin: StoreReceiptOrigin, val payment: ServicePayment): CC()
   class ApiSetBadgeSubscriptionStatus(val status: BadgeSubscriptionState, val payment: ServicePayment): CC()
   class ApiCreateBadgeInvoice(val userId: Long): CC()
   class ApiGetBadgeState(val userId: Long): CC()
@@ -4401,7 +4400,7 @@ sealed class CC {
     is ApiDownloadStandaloneFile -> "/_download $userId $url ${file.filePath}"
     is ApiStandaloneFileInfo -> "/_download info $url"
     is ApiRedeemBadgeCode -> "/_redeem_badge_code $userId $code"
-    is ApiPurchaseBadge -> "/_badge purchase $userId${echoedInvoiceId?.let { " invoice=$it" } ?: ""}${if (listed) " listed" else ""} ${json.encodeToString(payment)}"
+    is ApiPurchaseBadge -> "/_badge purchase $userId${echoedInvoiceId?.let { " invoice=$it" } ?: ""}${storeReceiptOriginParam(origin)} ${json.encodeToString(payment)}"
     is ApiSetBadgeSubscriptionStatus -> "/_badge subscription ${status.text} ${json.encodeToString(payment)}"
     is ApiCreateBadgeInvoice -> "/_badge invoice $userId"
     is ApiGetBadgeState -> "/_badge state $userId"
@@ -4617,7 +4616,7 @@ sealed class CC {
       is TestStorageEncryption -> TestStorageEncryption(obfuscate(key))
       // a code or a store receipt is a bearer secret until it is redeemed, and the terminal shows and copies cmdString
       is ApiRedeemBadgeCode -> ApiRedeemBadgeCode(userId, obfuscate(code))
-      is ApiPurchaseBadge -> ApiPurchaseBadge(userId, echoedInvoiceId, listed, when (payment) {
+      is ApiPurchaseBadge -> ApiPurchaseBadge(userId, echoedInvoiceId, origin, when (payment) {
         is ServicePayment.Google -> ServicePayment.Google(payment.productId, obfuscate(payment.token))
       })
       is ApiSetBadgeSubscriptionStatus -> ApiSetBadgeSubscriptionStatus(status, when (payment) {
@@ -4662,6 +4661,14 @@ sealed class ServicePayment {
   @Serializable @SerialName("google") class Google(val productId: String, val token: String): ServicePayment()
 }
 
+enum class StoreReceiptOrigin {
+  Purchased,
+  // found in the store's list rather than bought or restored here, so core records it only into a record it has
+  Listed,
+  // Restore: core claims it for this profile, moving it from another device or profile it was credited to
+  Restored
+}
+
 fun onOff(b: Boolean): String = if (b) "on" else "off"
 
 // /_badge ack takes the kind in core's text encoding, not the JSON tag; an unknown kind has no banner to dismiss, so it is never acked
@@ -4676,6 +4683,12 @@ private fun badgeAlertKindParam(kind: BadgeAlertKind): String = when (kind) {
   is BadgeAlertKind.Unknown -> kind.kind
 }
 
+private fun storeReceiptOriginParam(origin: StoreReceiptOrigin): String = when (origin) {
+  StoreReceiptOrigin.Purchased -> ""
+  StoreReceiptOrigin.Listed -> " listed"
+  StoreReceiptOrigin.Restored -> " restored"
+}
+
 @Serializable
 data class NewUser(
   val profile: Profile?,
@@ -7515,6 +7528,7 @@ sealed class BadgeServiceErrorCode {
   object ReceiptInvalid: BadgeServiceErrorCode()
   object ReceiptUsed: BadgeServiceErrorCode()
   object TestPurchase: BadgeServiceErrorCode()
+  object TransferLimited: BadgeServiceErrorCode()
   object Internal: BadgeServiceErrorCode()
   data class Unknown(val code: String): BadgeServiceErrorCode()
 
@@ -7538,6 +7552,7 @@ sealed class BadgeServiceErrorCode {
       is ReceiptInvalid -> "receipt_invalid"
       is ReceiptUsed -> "receipt_used"
       is TestPurchase -> "test_purchase"
+      is TransferLimited -> "transfer_limited"
       is Internal -> "internal"
       is Unknown -> code
     }
@@ -7554,6 +7569,7 @@ fun badgeServiceErrorText(code: BadgeServiceErrorCode): String? = when (code) {
   is BadgeServiceErrorCode.ReceiptInvalid -> generalGetString(MR.strings.badges_error_receipt_invalid)
   is BadgeServiceErrorCode.TestPurchase -> generalGetString(MR.strings.badges_error_test_purchase)
   is BadgeServiceErrorCode.ReceiptUsed -> generalGetString(MR.strings.badges_error_receipt_used)
+  is BadgeServiceErrorCode.TransferLimited -> generalGetString(MR.strings.badges_error_transfer_limited)
   is BadgeServiceErrorCode.PaymentPending -> generalGetString(MR.strings.badges_error_payment_pending)
   is BadgeServiceErrorCode.ProviderUnavailable -> generalGetString(MR.strings.badges_error_provider_unavailable)
   is BadgeServiceErrorCode.ProviderNotConfigured -> generalGetString(MR.strings.badges_error_provider_not_configured)
@@ -7583,6 +7599,7 @@ object BadgeServiceErrorCodeSerializer : KSerializer<BadgeServiceErrorCode> {
       "receipt_invalid" -> BadgeServiceErrorCode.ReceiptInvalid
       "receipt_used" -> BadgeServiceErrorCode.ReceiptUsed
       "test_purchase" -> BadgeServiceErrorCode.TestPurchase
+      "transfer_limited" -> BadgeServiceErrorCode.TransferLimited
       "internal" -> BadgeServiceErrorCode.Internal
       else -> BadgeServiceErrorCode.Unknown(v)
     }

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

@@ -244,7 +244,7 @@ object BadgeStore {
     try {
       val outcome = storePurchase(id, invoiceId)
       if (outcome is BadgePurchaseOutcome.Purchased) {
-        handOver(outcome.receipt, listed = false)
+        handOver(outcome.receipt, StoreReceiptOrigin.Purchased)
       }
       return outcome
     } finally {
@@ -271,10 +271,10 @@ object BadgeStore {
 
   // Core holds the receipt and credits it; the purchase stays unfinished until core answers it credited
   // or refused, as an unfinished purchase is what the store re-delivers if anything is lost on the way.
-  private suspend fun handOver(receipt: BadgeStoreReceipt, listed: Boolean) {
+  private suspend fun handOver(receipt: BadgeStoreReceipt, origin: StoreReceiptOrigin) {
     val rhId = chatModel.remoteHostId()
     val userId = chatModel.currentUser.value?.userId ?: return
-    when (val r = chatModel.controller.apiPurchaseBadge(rhId, userId, receipt.invoiceId, listed, ServicePayment.Google(receipt.productId, receipt.token))) {
+    when (val r = chatModel.controller.apiPurchaseBadge(rhId, userId, receipt.invoiceId, origin, ServicePayment.Google(receipt.productId, receipt.token))) {
       is BadgePurchaseResult.Held -> {
         // core holds it durably now, so Play must not refund it after three days unacknowledged;
         // a subscription is acknowledged by the service when it credits it
@@ -305,6 +305,8 @@ object BadgeStore {
         if (badgeReceiptRefused(r.err)) {
           Log.e(TAG, "BadgeStore.handOver: ${r.err?.string}")
           finish(receipt)
+          // a limited move raises no event, so Restore learns of it only from this answer
+          if (origin == StoreReceiptOrigin.Restored && r.err != null && badgeServiceErrorCode(r.err) is BadgeServiceErrorCode.TransferLimited) throw BadgeStoreError.ApiError(r.err)
         } else {
           throw r.err?.let(BadgeStoreError::ApiError) ?: Exception("apiPurchaseBadge: unexpected response")
         }
@@ -376,7 +378,7 @@ object BadgeStore {
   suspend fun reconcileListed(outcome: BadgePurchaseOutcome) {
     // the purchase stays unfinished, so the next sweep hands it over again
     try {
-      reconcile(outcome, listed = true)
+      reconcile(outcome, StoreReceiptOrigin.Listed)
     } catch (e: Exception) {
       if (e is CancellationException) throw e
       Log.e(TAG, "BadgeStore.reconcile: ${e.stackTraceToString()}")
@@ -393,11 +395,11 @@ object BadgeStore {
     }
   }
 
-  private suspend fun reconcile(outcome: BadgePurchaseOutcome, listed: Boolean) {
+  private suspend fun reconcile(outcome: BadgePurchaseOutcome, origin: StoreReceiptOrigin) {
     when (outcome) {
       is BadgePurchaseOutcome.Purchased ->
         if (outcome.receipt.productId !in badgeProductIds) finish(outcome.receipt)
-        else handOver(outcome.receipt, listed)
+        else handOver(outcome.receipt, origin)
       is BadgePurchaseOutcome.Pending ->
         if (outcome.invoiceId != null) withContext(Dispatchers.Main) { waitingForApproval.value += outcome.invoiceId }
       is BadgePurchaseOutcome.Cancelled -> {}
@@ -436,16 +438,14 @@ object BadgeStore {
     platform.androidManageBadgeSubscription(badgeStoreProductId(level, BadgePeriod.Monthly).productId)
   }
 
-  // Hands over as the device's own whatever the store lists, so a purchase no record here has is claimed by this profile.
+  // Hands over as restored whatever the store lists, so this profile claims it, also from another install or profile.
   // Answers whether a badge is shown, or a purchase is being added or awaits approval, afterwards.
-  // Play's list does include the subscription, yet it is not restored on another install or profile: the service credited
-  // the payment to the purchase key of the install that bought it, and answers any other key receipt_used.
   suspend fun restorePurchases(): Boolean {
     var handOverError: Exception? = null
     val purchases = if (useBadgeTestProducts) emptyList() else platform.androidUnfinishedBadgePurchases()
     for (outcome in purchases) {
       try {
-        reconcile(outcome, listed = false)
+        reconcile(outcome, StoreReceiptOrigin.Restored)
       } catch (e: Exception) {
         if (e is CancellationException) throw e
         Log.e(TAG, "BadgeStore.restorePurchases: ${e.stackTraceToString()}")
@@ -518,7 +518,11 @@ private fun compactPrice(product: BadgeProduct): String {
 // the codes core refuses a receipt with for good, after which the store may stop re-delivering it;
 // a sweep that hands over a receipt refused while the app was not running learns it only from this answer
 private fun badgeReceiptRefused(err: ChatError?): Boolean {
-  val redeemError = ((err as? ChatError.ChatErrorChat)?.errorType as? ChatErrorType.CEBadgeRedeemError)?.badgeRedeemError
-  val code = (redeemError as? BadgeRedeemError.ServiceError)?.serviceError
-  return code is BadgeServiceErrorCode.ReceiptInvalid || code is BadgeServiceErrorCode.ReceiptUsed || code is BadgeServiceErrorCode.TestPurchase
+  val code = badgeServiceErrorCode(err)
+  return code is BadgeServiceErrorCode.ReceiptInvalid || code is BadgeServiceErrorCode.ReceiptUsed || code is BadgeServiceErrorCode.TestPurchase || code is BadgeServiceErrorCode.TransferLimited
+}
+
+private fun badgeServiceErrorCode(err: ChatError?): BadgeServiceErrorCode? {
+  val redeemError = ((err as? ChatError.ChatErrorChat)?.errorType as? ChatErrorType.CEBadgeRedeemError)?.badgeRedeemError
+  return (redeemError as? BadgeRedeemError.ServiceError)?.serviceError
 }

apps/multiplatform/common/src/commonMain/moko-resources/base/strings.xml

@@ -3250,6 +3250,7 @@
   <string name="badges_error_service_internal">The badge service reported an internal error.</string>
   <string name="badges_error_receipt_invalid">The store did not confirm this purchase.</string>
   <string name="badges_error_receipt_used">This purchase was already credited to a badge on another device or profile.</string>
+  <string name="badges_error_transfer_limited">This purchase was moved to another device or profile recently.</string>
   <string name="badges_error_test_purchase">Test purchases are not credited. Badges can only be bought with a real purchase.</string>
   <string name="badges_error_payment_pending">The payment has not been confirmed yet.</string>
   <string name="badges_error_provider_unavailable">The store could not be reached.</string>

apps/multiplatform/product/gaps.md

@@ -361,17 +361,18 @@ Desktop users cannot pick a skin tone in the picker, and search in other languag
 
 ### Description
 
-Play gives a resubscription a new purchase token, so subscribing again on the same install is credited as a new purchase. On a new device or under another profile, Restore finds the subscription in Play's list and hands it over, but the service has credited the payment to the purchase key of the install that bought it and answers the new key `receipt_used`.
+Play gives a resubscription a new purchase token, so subscribing again on the same install is credited as a new purchase. On a new device or under another profile, Restore hands over the subscriptions in Play's list as restored, and the service moves the subscription to the restoring profile's purchase key. A payment moves again only once the credential issued to the key it last moved from has expired; until then Restore is answered `transfer_limited`, and the first Restore of a limited payment adds nothing and shows nothing, so only the next Restore says why. A badge bought with Stripe or crypto cannot be moved at all.
 
 ### Affected Locations
 
 - `common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt` -- `restorePurchases()`
-- `../../apps/simplex-badge-service/src/BadgeService/Service.hs` -- a credited receipt answered to another key
+- `../../apps/simplex-badge-service/src/BadgeService/Service.hs` -- the move limit
 
 ### Impact
 
-A subscriber who moves to a new device or profile keeps paying but cannot show the badge there, and Restore reports a refusal.
+A subscriber who moves the badge again before the previous key's credential expires waits until it does, and the first such Restore gives no reason. A badge bought with Stripe or crypto stays with the profile it was credited to.
 
 ### Recommendation
 
-1. A transfer design, in the service and the client and shared with iOS, that moves a credited subscription to a new purchase key.
+1. Restore by a receipt code for Stripe and crypto purchases, shared with iOS.
+2. Announce a limited move on the first Restore.

apps/simplex-badge-service/src/BadgeService/Catalog.hs

@@ -13,7 +13,6 @@ module BadgeService.Catalog
     defaultCatalog,
     StoreProduct (..),
     storeProduct,
-    storePlan,
     playMonthlyPlan,
   )
 where
@@ -161,20 +160,6 @@ storeProduct provider productId = case (provider, productId) of
   (PPGoogle, "subscr_badge_legend_01") -> Just StoreSubscription
   _ -> Nothing
 
--- | 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
-
 -- | A Play subscription product's monthly base plan, which a purchase token alone does not name.
 playMonthlyPlan :: Text -> Maybe Text
 playMonthlyPlan = \case

apps/simplex-badge-service/src/BadgeService/Service.hs

@@ -33,7 +33,7 @@ module BadgeService.Service
   )
 where
 
-import BadgeService.Catalog (StoreProduct (..), defaultCatalog, storePlan, storeProduct)
+import BadgeService.Catalog (StoreProduct (..), defaultCatalog, storeProduct)
 import BadgeService.Codes (issueFailedText, issueOneCode, singleUse)
 import BadgeService.Config (AppleStoreConfig (..), BadgeIssuerKey (..), PlayStoreConfig (..), ServiceConfig (..), readServiceConfig)
 import BadgeService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane)
@@ -64,7 +64,7 @@ import Data.Either (fromRight)
 import Data.Functor (($>), (<&>))
 import Data.Int (Int64)
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, isJust, maybeToList)
+import Data.Maybe (fromMaybe, isJust, isNothing, maybeToList)
 import qualified Data.Text as T
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
 import Data.Word (Word32)
@@ -72,6 +72,7 @@ import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Code
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service
+import Simplex.Chat.Badges.StorePlan (storePlan)
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
 import Simplex.Chat.Bot (initializeBotAddress')
 import Simplex.Chat.Bot.Store (withDB, withDB')
@@ -343,6 +344,9 @@ requestLane checks cc sigKey reqData = case J.fromJSON (J.Object reqData) of
   J.Success BadgeServiceRequest {request = BSCPurchaseBadge {payment = SPGoogle {}, upgrade = Nothing}} -> pure PurchaseLane
   J.Success BadgeServiceRequest {request = BSCPurchaseBadge {payment = SPApple {jws}, upgrade = Nothing}}
     | maybe False autoRenewable (appleTransactionFacts jws) -> pure PurchaseLane
+  J.Success BadgeServiceRequest {request = BSCTransferBadge {payment = SPApple {jws}}}
+    | maybe False autoRenewable (appleTransactionFacts jws) -> pure PurchaseLane
+  J.Success BadgeServiceRequest {request = BSCTransferBadge {payment = SPGoogle {}}} -> pure PurchaseLane
   J.Success BadgeServiceRequest {purchaseKey = Just k, request = BSCIssueBadge {}}
     | sigKey == Just k -> do
         now <- badgeNow cc
@@ -352,6 +356,14 @@ requestLane checks cc sigKey reqData = case J.fromJSON (J.Object reqData) of
           Right _ -> MainLane
           -- a read that failed may hide a due check, and the main lane is what must not wait on a store
           Left _ -> RenewalLane
+  J.Success BadgeServiceRequest {purchaseKey = Just k, request = BSCUpgradeBadgeSubscription {}}
+    | sigKey == Just k -> do
+        now <- badgeNow cc
+        withDB' "requestLane" cc (\db -> getIssuePurchase db k) <&> \case
+          Right (Just (_, Just _, Just subscription@PurchaseSubscription {subscriptionRef = SubscriptionApple _}))
+            | isNothing $ checkWait (addUTCTime routeLookahead now) subscription -> RenewalLane
+          Right _ -> MainLane
+          Left _ -> RenewalLane
   _ -> pure MainLane
 
 -- | The router judges a minute ahead, so a handler reading the clock moments later finds due only what the router routed off the main lane.
@@ -419,13 +431,24 @@ badgeServiceResponse key verifier checks cc trackerQ_ sigKey reqData = case J.fr
           Nothing -> pure $ errorResponse BSEBadRequest
         BSCPurchaseBadge {masterKey, payment, upgrade}
           | Just receipt_ <- toStoreReceipt verifier payment -> case (purchaseKey, upgrade) of
-              (Just k, Nothing) -> either storeRefusalResponse (purchaseWithReceipt key cc verifier checks k masterKey) receipt_
+              (Just k, Nothing) -> either storeRefusalResponse (purchaseWithReceipt key cc verifier checks RUPurchase k masterKey) receipt_
               -- store upgrades are not built, and ignoring one would credit its months at the discounted price
               (Just _, Just _) -> pure $ errorResponse BSEBadRequest
               (Nothing, _) -> pure $ errorResponse BSEBadRequest
         BSCIssueBadge {balance} -> case purchaseKey of
-          Just k -> issueBadgeCmd key cc verifier k balance
+          Just k -> issueBadgeCmd key cc verifier k Nothing balance
           Nothing -> pure $ errorResponse BSEBadRequest
+        -- only an App Store subscription changes tier on the same transaction; Play gives a change a new token
+        BSCUpgradeBadgeSubscription {payment = payment@SPApple {}, balance}
+          | Just k <- purchaseKey,
+            Just receipt_ <- toStoreReceipt verifier payment ->
+              either storeRefusalResponse (upgradeSubscriptionCmd key cc verifier k balance) receipt_
+        BSCUpgradeBadgeSubscription {} -> pure $ errorResponse BSEBadRequest
+        BSCTransferBadge {masterKey, payment}
+          | Just k <- purchaseKey,
+            Just receipt_ <- toStoreReceipt verifier payment ->
+              either storeRefusalResponse (purchaseWithReceipt key cc verifier checks (RUTransfer $ presentedTransaction payment) k masterKey) receipt_
+        BSCTransferBadge {} -> pure $ errorResponse BSEBadRequest
         -- Every command but redeemBadgeCode and purchaseBadge from a store needs a key the service already knows; those two create the purchase, so their key is unknown on a first purchase.
         _ -> case purchaseKey of
           Nothing -> pure $ errorResponse BSEUnsupportedVersion
@@ -501,15 +524,26 @@ redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode
               | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired
               | otherwise -> pure $ Right c
 
+-- | What a store receipt is presented for. A transfer carries the Apple transaction the device presented,
+-- as only the subscription's latest one moves it.
+data ReceiptUse = RUPurchase | RUTransfer (Maybe T.Text)
+
+presentedTransaction :: ServicePayment -> Maybe T.Text
+presentedTransaction = \case
+  SPApple {jws} -> (\AppleTransactionFacts {transactionId} -> transactionId) <$> appleTransactionFacts jws
+  _ -> Nothing
+
 -- | Every refusal is answered before anything is written, so it leaves the receipt unclaimed; and
 -- nothing is written until the credential is signed.
-purchaseWithReceipt :: BadgeIssuerKey -> ChatController -> StoreVerifier -> PurchaseChecks -> C.PublicKeyEd25519 -> BadgeMasterKey -> StoreReceipt -> IO BadgeServiceResponse
-purchaseWithReceipt key cc verifier checks purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, receiptProductId, subscriptionRef, verifyReceipt, acknowledgeReceipt, acknowledgeSubscription} =
-  withDB' "getStorePayment" cc (\db -> getStorePaymentCredit db provider providerRef) >>= \case
+purchaseWithReceipt :: BadgeIssuerKey -> ChatController -> StoreVerifier -> PurchaseChecks -> ReceiptUse -> C.PublicKeyEd25519 -> BadgeMasterKey -> StoreReceipt -> IO BadgeServiceResponse
+purchaseWithReceipt key cc verifier checks use purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, receiptProductId, subscriptionRef, verifyReceipt, acknowledgeReceipt, acknowledgeSubscription} =
+  withDB' "getStorePayment" cc (\db -> (,) <$> getStorePaymentCredit db provider providerRef <*> keyHoldsPurchase db) >>= \case
     Left _ -> pure $ errorResponse BSEInternal
-    Right credit
+    Right (credit, keyHeld)
       -- only the key it credited can ask, and it is told only what it was given, so the store is not asked
       | creditedBy credit -> answerCredit credit
+      -- a payment moves only to a key with no purchase, so one transferOut alone names the purchase holding it
+      | keyHeld -> pure $ errorResponse BSEBadRequest
       -- a Play subscription is verified by asking about the subscription itself
       | Just StoreSubscription <- storeProduct provider =<< receiptProductId -> purchaseSubscription receiptProductId credit
       | otherwise ->
@@ -523,10 +557,17 @@ purchaseWithReceipt key cc verifier checks purchaseKey masterKey StoreReceipt {t
             Right VerifiedStoreTransaction {testPurchase = True}
               | not (creditTestPurchases verifier) -> storeRefusalResponse SRTestPurchase
             -- another key's credit is told only once the store vouched for the receipt, or it would reveal which transactions were credited
-            Right tx -> case credit of
+            Right tx@VerifiedStoreTransaction {productId} -> case credit of
               Uncredited -> newPurchase tx
+              _
+                | RUTransfer _ <- use,
+                  Just StoreSubscription <- storeProduct provider productId ->
+                    purchaseSubscription (Just productId) credit
               _ -> answerCredit credit
   where
+    keyHoldsPurchase db = case use of
+      RUPurchase -> pure False
+      RUTransfer _ -> purchaseKeyExists db purchaseKey
     creditedBy = \case
       Credited CreditedPurchase {purchaseKey = k} -> k == purchaseKey
       _ -> False
@@ -561,8 +602,9 @@ purchaseWithReceipt key cc verifier checks purchaseKey masterKey StoreReceipt {t
             -- no store was asked, so the claim is not held off
             Left SRNotConfigured -> atomically (modifyTVar' claimChecks $ M.delete providerRef) >> storeRefusalResponse SRNotConfigured
             Left refusal -> atLeastCheckInterval <$> storeRefusalResponse refusal
-            Right checked -> atLeastCheckInterval <$> case credit of
-              Uncredited -> newSubscription checked
+            Right checked -> atLeastCheckInterval <$> case (credit, use) of
+              (Uncredited, _) -> newSubscription checked
+              (Credited from, RUTransfer presented) -> moveSubscription presented from checked
               _ -> answerCredit credit
     subscriptionAsk now =
       purchaseCheckWait claimChecks now providerRef >>= \case
@@ -577,20 +619,62 @@ purchaseWithReceipt key cc verifier checks purchaseKey masterKey StoreReceipt {t
       SubscriptionGoogle _ -> (googleChecks checks, Just $ playReads checks)
     newSubscription checked@SubscriptionCheck {subscriptionState} = do
       now <- badgeNow cc
-      case grantableCharge provider Nothing now checked >>= fundsMonthNow now Nothing of
+      case grantableCharge provider now checked >>= fundsMonthNow purchaseKey now Nothing of
         Left notGranted -> firstChargeNotGranted provider notGranted
         Right (charge@StoreCharge {periodStart, chargePaid = paid}, (badgeType, months)) ->
           acknowledged acknowledgeSubscription $ do
             chargeId <- randomId cc
-            entryIds <- (,,) <$> randomId cc <*> randomId cc <*> randomId cc
+            entryIds <- (,,,) <$> randomId cc <*> randomId cc <*> randomId cc <*> randomId cc
             let seed = emptyEntry periodStart badgeType
-            signMonthAfter key cc masterKey now seed (chargeEntries periodStart now months chargeId entryIds seed) >>= \case
+            signMonthAfter key cc masterKey now seed (chargeEntries periodStart now badgeType months purchaseKey chargeId entryIds seed) >>= \case
               Left resp -> pure resp
               Right firstMonth ->
                 claimPurchase now (\paymentId -> NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType, subscriptionState = Just subscriptionState, providerToken}) $
                   \db purchaseId paymentId -> do
                     insertSubscriptionCharge db paymentId chargeId charge now
                     firstMonthResponse db purchaseId Nothing (Just subscriptionState) firstMonth
+    moveSubscription presented CreditedPurchase {badgePurchaseId = fromPurchaseId, purchaseKey = fromKey} checked@SubscriptionCheck {subscriptionState, latestCharge}
+      -- an older transaction stops moving the subscription once the store charges again, so a leaked receipt lapses
+      | SubscriptionApple _ <- subscriptionRef,
+        presented /= ((\StoreCharge {chargeRef} -> chargeRef) <$> latestCharge) =
+          pure $ errorResponse BSEPaymentPending
+      | otherwise = do
+          now <- badgeNow cc
+          withDB' "getMovedPayment" cc (\db -> getPurchaseSubscription db fromPurchaseId >>= mapM (movedPayment db)) >>= \case
+            Right (Just (paymentId, movedFromExpiry_, Just fromTip))
+              -- A store receipt proves control of the store account but is no one-time secret, so this is the only bound on moves:
+              -- waiting out the credential of the key the payment last moved from keeps each paid month with at most two keys.
+              | maybe False (now <) movedFromExpiry_ -> pure $ errorResponse BSETransferLimited
+              | otherwise -> case grantableCharge provider now checked >>= fundsMonthNow purchaseKey now Nothing of
+                  Left notGranted -> firstChargeNotGranted provider notGranted
+                  Right grant -> movePayment now paymentId fromTip grant
+            _ -> pure $ errorResponse BSEInternal
+      where
+        movedPayment db PurchaseSubscription {paymentId} = (paymentId,,) <$> getMovedFromExpiry db paymentId <*> getLedgerTip db fromPurchaseId
+        movePayment now paymentId fromTip (charge@StoreCharge {chargeRef, periodStart}, (badgeType, months)) =
+          withDB' "getSubscriptionCharge" cc (\db -> getSubscriptionCharge db paymentId chargeRef) >>= \case
+            Left _ -> pure $ errorResponse BSEInternal
+            Right recorded -> do
+              chargeId <- maybe (randomId cc) (pure . fst) recorded
+              entryIds <- (,,,) <$> randomId cc <*> randomId cc <*> randomId cc <*> randomId cc
+              (lapseId, transferId) <- (,) <$> randomId cc <*> randomId cc
+              let seed = emptyEntry periodStart badgeType
+                  lapsed = lapseEntry now lapseId fromTip
+                  fromRows = maybeToList lapsed <> [debitEntry now transferId (SDTransferOut purchaseKey) (fromMaybe fromTip lapsed)]
+              signMonthAfter key cc masterKey now seed (chargeEntries periodStart now badgeType months purchaseKey chargeId entryIds seed) >>= \case
+                Left resp -> pure resp
+                Right firstMonth -> do
+                  r <- withDB "transferStorePurchase" cc $ \db -> liftIO $
+                    rebindStorePayment db PaymentRebind {paymentId, fromPurchaseId, fromTipId = entryId fromTip, fromRows, purchaseKey, masterKey, badgeType} now >>= \case
+                      Nothing -> pure Nothing
+                      Just purchaseId -> do
+                        insertSubscriptionCharge db paymentId chargeId charge now
+                        setSubscriptionState db paymentId subscriptionState now
+                        Just <$> firstMonthResponse db purchaseId Nothing (Just subscriptionState) firstMonth
+                  case r of
+                    Right (Just resp) -> logInfo ("store subscription moved from " <> purchaseKeyPart fromKey <> " to " <> purchaseKeyPart purchaseKey) $> resp
+                    Right Nothing -> logError "badge service: a subscription moved, or its ledger changed, while its transfer was signed" $> errorResponse BSEInternal
+                    Left _ -> pure $ errorResponse BSEInternal
     providerToken = case subscriptionRef of
       SubscriptionGoogle token -> Just token
       SubscriptionApple _ -> Nothing
@@ -618,35 +702,33 @@ data NotGranted
   | NGRevoked
   | NGOffer
   | NGUnknownPlan
-  | NGOtherTier
   | NGNotStarted
   | NGPeriodOver
   deriving (Show)
 
 -- | The grant rule of a first purchase and a renewal alike, but for whether a ledger row already references
--- the charge, which is the caller's to check. tier is the ledger's; a first purchase may start on any plan.
-grantableCharge :: PaymentProvider -> Maybe BadgeType -> UTCTime -> SubscriptionCheck -> Either NotGranted (StoreCharge, (BadgeType, Int))
-grantableCharge provider tier now SubscriptionCheck {subscriptionState, latestCharge}
+-- the charge, which is the caller's to check. It grants the tier of the plan the store charged, which may not be the ledger's.
+grantableCharge :: PaymentProvider -> UTCTime -> SubscriptionCheck -> Either NotGranted (StoreCharge, (BadgeType, Int))
+grantableCharge provider now SubscriptionCheck {subscriptionState, latestCharge}
   | subscriptionState == SSEnded = Left NGEnded
   | otherwise = case latestCharge of
       Nothing -> Left NGNoCharge
       -- the plan first: Play derives a period from the plan's length, so a plan it does not know has none
       Just charge@StoreCharge {planId, periodStart, periodEnd, revoked, offer} -> case storePlan provider planId of
         Nothing -> Left NGUnknownPlan
-        Just plan@(badgeType, _)
+        Just plan
           | periodEnd <= periodStart -> Left NGMalformedPeriod
           | revoked -> Left NGRevoked
           | offer -> Left NGOffer
-          | maybe False (/= badgeType) tier -> Left NGOtherTier
           | now < periodStart -> Left NGNotStarted
           | now >= periodEnd -> Left NGPeriodOver
           | otherwise -> Right (charge, plan)
 
 -- | Play dates a period from its end less the plan's months, clipped at month ends, so the months the ledger grants
 -- from that start can end before Play's period does: a charge still in its period may then fund no month now.
-fundsMonthNow :: UTCTime -> Maybe StatementEntry -> (StoreCharge, (BadgeType, Int)) -> Either NotGranted (StoreCharge, (BadgeType, Int))
-fundsMonthNow now tip_ grant@(StoreCharge {periodStart}, (badgeType, months))
-  | isJust $ issueEntry now "" $ last $ tip : chargeEntries periodStart now months "" ("", "", "") tip = Right grant
+fundsMonthNow :: C.PublicKeyEd25519 -> UTCTime -> Maybe StatementEntry -> (StoreCharge, (BadgeType, Int)) -> Either NotGranted (StoreCharge, (BadgeType, Int))
+fundsMonthNow purchaseKey now tip_ grant@(StoreCharge {periodStart}, (badgeType, months))
+  | isJust $ issueEntry now "" $ last $ tip : chargeEntries periodStart now badgeType months purchaseKey "" ("", "", "", "") tip = Right grant
   | otherwise = Left NGPeriodOver
   where
     tip = fromMaybe (emptyEntry periodStart badgeType) tip_
@@ -687,6 +769,7 @@ commandName = \case
   BSCRedeemBadgeCode {} -> "redeemBadgeCode"
   BSCPurchaseBadge {payment} -> "purchaseBadge " <> paymentName payment
   BSCUpgradeBadgeSubscription {payment} -> "upgradeBadgeSubscription " <> paymentName payment
+  BSCTransferBadge {payment} -> "transferBadge " <> paymentName payment
   BSCIssueBadge {} -> "issueBadge"
   BSCPauseBadge -> "pauseBadge"
   where
@@ -725,7 +808,7 @@ signFirstMonth key cc masterKey badgeType months credit now = do
   -- TODO [badges] a top-up grants onto an existing ledger, and must lapse before it or the
   -- months it adds are counted from a start already in the past
   let seed = emptyEntry now badgeType
-  signMonthAfter key cc masterKey now seed [grantEntry now grantUuid months credit seed]
+  signMonthAfter key cc masterKey now seed [grantEntry now grantUuid badgeType months credit seed]
 
 -- | The rows that fund a month, after the entry they follow, with that month issued at now and signed.
 signMonthAfter :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> UTCTime -> StatementEntry -> [StatementEntry] -> IO (Either BadgeServiceResponse ([StatementEntry], (StatementEntry, StatementEntry, BadgeCredential)))
@@ -745,18 +828,39 @@ firstMonthResponse db purchaseId creditPaymentId_ subscription (rows, issuance@(
   entries_ <- getLedgerEntries db purchaseId 0
   pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just credential) Nothing subscription) entries_
 
+-- | The subscription a device's transaction names, and the tier of its product: what an upgrade waits for, never what it grants.
+data SubscriptionUpgrade = SubscriptionUpgrade
+  { upgradeRef :: T.Text,
+    upgradeTier :: BadgeType
+  }
+
+-- | Refused before the store is asked: a transaction that does not verify, or that is of no subscription product.
+upgradeSubscriptionCmd :: BadgeIssuerKey -> ChatController -> StoreVerifier -> C.PublicKeyEd25519 -> BadgeBalance -> StoreReceipt -> IO BadgeServiceResponse
+upgradeSubscriptionCmd key cc verifier purchaseKey balance StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = claimedRef}, verifyReceipt} =
+  verifyReceipt >>= \case
+    Left refusal -> storeRefusalResponse refusal
+    Right VerifiedStoreTransaction {transactionRef}
+      | transactionRef /= claimedRef -> storeRefusalResponse $ SRVerifierFailed "verified a transaction other than the one claimed"
+    Right VerifiedStoreTransaction {productId} -> case storePlan provider productId of
+      Nothing -> pure $ errorResponse BSEBadRequest
+      Just (tier, _) -> issueBadgeCmd key cc verifier purchaseKey (Just SubscriptionUpgrade {upgradeRef = claimedRef, upgradeTier = tier}) balance
+
 -- | The purchase is reached through the verified signer key and no other way.
-issueBadgeCmd :: BadgeIssuerKey -> ChatController -> StoreVerifier -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse
-issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do
+issueBadgeCmd :: BadgeIssuerKey -> ChatController -> StoreVerifier -> C.PublicKeyEd25519 -> Maybe SubscriptionUpgrade -> BadgeBalance -> IO BadgeServiceResponse
+issueBadgeCmd key cc verifier purchaseKey upgrade_ BadgeBalance {lastEntry} = do
   now <- badgeNow cc
   purchase_ <- withDB' "getBadgePurchase" cc (\db -> getIssuePurchase db purchaseKey)
   case purchase_ of
     Left _ -> pure $ errorResponse BSEInternal
     Right Nothing -> pure $ errorResponse BSEUnknownPurchaseKey
-    -- once a subscription's paid coverage has ended, only a new store charge funds another month
     Right (Just (purchase, Just tip, Just subscription))
-      | paidThrough tip <= now -> renewSubscription purchase tip subscription now
+      | Just upgrade <- upgrade_ -> upgradeSubscription upgrade purchase tip subscription now
+      -- once a subscription's paid coverage has ended, only a new store charge funds another month
+      | paidThrough tip <= now -> renewSubscription Nothing purchase tip subscription now
       | ChecksAtEveryRequest <- storeChecks verifier -> checkStoreDuringCoverage purchase tip subscription now
+    Right (Just _) | isJust upgrade_ -> pure $ errorResponse BSEBadRequest
+    Right (Just (ServicePurchase {badgePurchaseId}, Just StatementEntry {entryType = SEDebit SDTransferOut {}}, Nothing)) ->
+      answered "answerMovedOut" $ \db -> withoutCredential <$> issueResponse db badgePurchaseId now (Just SSEnded)
     Right (Just (purchase, tip, subscription_)) -> issueDue purchase tip ((\PurchaseSubscription {storedState} -> storedState) <$> subscription_) now
   where
     issueDue ServicePurchase {badgePurchaseId, masterKey, badgeType} tip state_ now = do
@@ -778,30 +882,41 @@ issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do
         when (fmap entryId tip' == fmap entryId tip) $ appendLedgerPlan db purchaseId Nothing rows issuance_
         issueResponse db purchaseId t state_
       pure $ fromRight (errorResponse BSEInternal) r
+    -- Answered pending until the tier the device saw is granted, so the old tier's credential is never taken for the new one.
+    upgradeSubscription SubscriptionUpgrade {upgradeRef, upgradeTier} purchase@ServicePurchase {badgePurchaseId} tip@StatementEntry {balanceBadgeType} subscription@PurchaseSubscription {subscriptionRef, storedState} now
+      | not ownSubscription = pure $ errorResponse BSEBadRequest
+      | balanceBadgeType == upgradeTier = answered "answerUpgraded" $ \db -> issueResponse db badgePurchaseId now (Just storedState)
+      | Just wait <- checkWait now subscription =
+          pure BSPError {code = BSEPaymentPending, message = Nothing, retryAfter = Just $ ceiling wait}
+      | otherwise = renewSubscription (Just upgradeTier) purchase tip subscription now
+      where
+        ownSubscription = case subscriptionRef of
+          SubscriptionApple ref -> ref == upgradeRef
+          SubscriptionGoogle _ -> False
     -- Nothing but the store's answer is written until a charge is granted: a lapse at now would be dated
     -- after a grant a later check may make at an earlier period start, and the client would read it as a pass that issued.
-    renewSubscription ServicePurchase {badgePurchaseId, masterKey, badgeType} tip subscription@PurchaseSubscription {paymentId, provider, subscriptionRef, storedState} now
-      | not (subscriptionCheckDue (storeChecks verifier) now tip subscription) = answered "answerStoredSubscription" $ \db -> issueResponse db badgePurchaseId now (Just storedState)
+    renewSubscription upgradeTier_ ServicePurchase {badgePurchaseId, masterKey} tip@StatementEntry {balanceBadgeType} subscription@PurchaseSubscription {paymentId, provider, subscriptionRef, storedState} now
+      | isNothing upgradeTier_ && not (subscriptionCheckDue (storeChecks verifier) now tip subscription) = answered "answerStoredSubscription" $ \db -> issueResponse db badgePurchaseId now (Just storedState)
       | otherwise =
           withDB' "stampSubscriptionCheck" cc (\db -> stampSubscriptionCheck db paymentId now) >>= \case
             Left _ -> pure $ errorResponse BSEInternal
             Right () ->
               checkStoreSubscription verifier subscriptionRef Nothing >>= \case
                 Left refusal -> atLeastCheckInterval <$> storeRefusalResponse refusal
-                Right checked@SubscriptionCheck {subscriptionState, latestCharge} -> case grantableCharge provider (Just badgeType) now checked >>= fundsMonthNow now (Just tip) of
+                Right checked@SubscriptionCheck {subscriptionState, latestCharge} -> case grantableCharge provider now checked >>= fundsMonthNow purchaseKey now (Just tip) of
                   Left NGMalformedPeriod -> storeRefusalResponse $ SRVerifierFailed "a charge whose period does not end after its start"
                   Left reason -> do
                     forM_ latestCharge $ \_ -> logInfo $ "store subscription charge not granted: " <> tshow reason
                     recordCheck latestCharge subscriptionState
-                  Right (charge@StoreCharge {chargeRef, periodStart}, (_, months)) ->
+                  Right (charge@StoreCharge {chargeRef, periodStart}, (badgeType, months)) ->
                     withDB' "getSubscriptionCharge" cc (\db -> getSubscriptionCharge db paymentId chargeRef) >>= \case
                       Left _ -> pure $ errorResponse BSEInternal
                       -- the store still reports the charge the ledger last granted
                       Right (Just (_, True)) -> recordCheck (Just charge) subscriptionState
                       Right recorded -> do
                         chargeId <- maybe (randomId cc) (pure . fst) recorded
-                        entryIds <- (,,) <$> randomId cc <*> randomId cc <*> randomId cc
-                        signMonthAfter key cc masterKey now tip (chargeEntries periodStart now months chargeId entryIds tip) >>= \case
+                        entryIds <- (,,,) <$> randomId cc <*> randomId cc <*> randomId cc <*> randomId cc
+                        signMonthAfter key cc masterKey now tip (chargeEntries periodStart now badgeType months purchaseKey chargeId entryIds tip) >>= \case
                           Left resp -> pure resp
                           Right (rows, issuance) -> do
                             r <- withDB "renewSubscription" cc $ \db -> liftIO $ do
@@ -811,8 +926,9 @@ issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do
                                 else do
                                   insertSubscriptionCharge db paymentId chargeId charge now
                                   appendLedgerPlan db badgePurchaseId Nothing rows $ Just issuance
+                                  setPurchaseBadgeType db badgePurchaseId badgeType now
                                   setSubscriptionState db paymentId subscriptionState now
-                                  Just <$> issueResponse db badgePurchaseId now (Just subscriptionState)
+                                  Just <$> checkedResponse db badgeType subscriptionState
                             case r of
                               Right (Just resp) -> logBanked months $> resp
                               Right Nothing -> logError "badge service: a subscription's ledger moved while its renewal was signed" $> errorResponse BSEInternal
@@ -824,9 +940,12 @@ issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do
           answered "recordSubscriptionCheck" $ \db -> do
             forM_ charge_ $ \charge -> insertSubscriptionCharge db paymentId chargeId charge now
             setSubscriptionState db paymentId state now
-            issueResponse db badgePurchaseId now (Just state)
+            checkedResponse db balanceBadgeType state
+        checkedResponse db ledgerTier state = case upgradeTier_ of
+          Just tier | tier /= ledgerTier -> pure $ atLeastCheckInterval $ errorResponse BSEPaymentPending
+          _ -> issueResponse db badgePurchaseId now (Just state)
     -- A charge a dev deployment's store reports while coverage runs is banked with no issuance, and its month issued once coverage reaches it.
-    checkStoreDuringCoverage purchase@ServicePurchase {badgePurchaseId, badgeType} tip PurchaseSubscription {paymentId, provider, subscriptionRef} now =
+    checkStoreDuringCoverage purchase@ServicePurchase {badgePurchaseId} tip PurchaseSubscription {paymentId, provider, subscriptionRef} now =
       withDB' "stampSubscriptionCheck" cc (\db -> stampSubscriptionCheck db paymentId now) >>= \case
         Left _ -> pure $ errorResponse BSEInternal
         Right () ->
@@ -834,20 +953,21 @@ issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do
             Left refusal -> atLeastCheckInterval <$> storeRefusalResponse refusal
             Right checked@SubscriptionCheck {subscriptionState, latestCharge} -> do
               newChargeId <- randomId cc
-              entryIds <- (,,) <$> randomId cc <*> randomId cc <*> randomId cc
+              entryIds <- (,,,) <$> randomId cc <*> randomId cc <*> randomId cc <*> randomId cc
               r <- withDB' "checkStoreDuringCoverage" cc $ \db -> do
                 tip' <- getLedgerTip db badgePurchaseId
                 banked <-
                   if fmap entryId tip' == Just (entryId tip)
                     then do
-                      bankedMonths <- case grantableCharge provider (Just badgeType) now checked of
-                        Right (charge@StoreCharge {chargeRef, periodStart}, (_, months)) ->
+                      bankedMonths <- case grantableCharge provider now checked of
+                        Right (charge@StoreCharge {chargeRef, periodStart}, (badgeType, months)) ->
                           getSubscriptionCharge db paymentId chargeRef >>= \case
                             Just (_, True) -> pure Nothing
                             recorded -> do
                               let chargeId = maybe newChargeId fst recorded
                               insertSubscriptionCharge db paymentId chargeId charge now
-                              appendLedgerPlan db badgePurchaseId Nothing (chargeEntries periodStart now months chargeId entryIds tip) Nothing
+                              appendLedgerPlan db badgePurchaseId Nothing (chargeEntries periodStart now badgeType months purchaseKey chargeId entryIds tip) Nothing
+                              setPurchaseBadgeType db badgePurchaseId badgeType now
                               pure $ Just months
                         Left _ -> Nothing <$ forM_ latestCharge (\charge -> insertSubscriptionCharge db paymentId newChargeId charge now)
                       setSubscriptionState db paymentId subscriptionState now
@@ -860,6 +980,9 @@ issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do
                   forM_ banked logBanked
                   issueDue purchase tip_ (Just subscriptionState) now
     answered what action = fromRight (errorResponse BSEInternal) <$> withDB' what cc action
+    withoutCredential = \case
+      BSPBadgeCredential {receipt, statement, subscription} -> BSPBadgeCredential {credential = Nothing, receipt, statement, subscription}
+      resp -> resp
     logBanked months = logInfo $ "store subscription charge banked: " <> tshow months <> " months for " <> purchaseKeyPart purchaseKey
     -- Only the asserted entry's identity is read, never the months it claims.
     issueResponse db purchaseId t subscription = do
@@ -878,8 +1001,13 @@ getIssuePurchase db purchaseKey = do
 
 subscriptionCheckDue :: StoreChecks -> UTCTime -> StatementEntry -> PurchaseSubscription -> Bool
 subscriptionCheckDue ChecksAtEveryRequest _ _ _ = True
-subscriptionCheckDue ChecksAfterCoverage now tip PurchaseSubscription {checkedAt} =
-  paidThrough tip <= now && maybe True (\t -> diffUTCTime now t >= subscriptionCheckInterval) checkedAt
+subscriptionCheckDue ChecksAfterCoverage now tip subscription =
+  paidThrough tip <= now && isNothing (checkWait now subscription)
+
+-- | What remains of the interval since the subscription last asked its store, if anything.
+checkWait :: UTCTime -> PurchaseSubscription -> Maybe NominalDiffTime
+checkWait now PurchaseSubscription {checkedAt} =
+  mfilter (> 0) $ (\t -> subscriptionCheckInterval - diffUTCTime now t) <$> checkedAt
 
 -- | Each subscription asks its store at most this often, failed attempts included, so a client
 -- repeating its requests cannot spend the store quota every subscriber shares.

apps/simplex-badge-service/src/BadgeService/Store.hs

@@ -25,6 +25,7 @@ module BadgeService.Store
     getStorePaymentCredit,
     purchaseKeyExists,
     getPurchaseByKey,
+    setPurchaseBadgeType,
     getLedgerTip,
     getLedgerEntryId,
     getLedgerEntries,
@@ -32,6 +33,9 @@ module BadgeService.Store
     appendLedgerPlan,
     createCodePurchase,
     createStorePurchase,
+    PaymentRebind (..),
+    rebindStorePayment,
+    getMovedFromExpiry,
     PurchaseSubscription (..),
     getPurchaseSubscription,
     stampSubscriptionCheck,
@@ -59,7 +63,7 @@ import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType)
 import Simplex.Chat.Badges.Ledger
-import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementEntry (..), StatementEntryType (..), SubscriptionState)
+import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), SubscriptionState)
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus, BadgePurchaseStatus (..))
 import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), PaymentProvider (..), PaymentStatus (..))
 import Simplex.Chat.Store.Shared (insertedRowId)
@@ -202,7 +206,7 @@ getCodePurchaseForKey db badgeCodeId key =
         FROM sx_badge_service_badge_purchases p
         LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id
         WHERE p.badge_code_id = ? AND p.purchase_key = ?
-        ORDER BY i.period_end DESC
+        ORDER BY i.entry_id DESC
         LIMIT 1
       |]
       (badgeCodeId, key)
@@ -222,7 +226,7 @@ getStorePaymentCredit db provider providerRef =
         JOIN sx_badge_service_badge_purchases p ON p.payment_id = pay.payment_id
         LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id
         WHERE pay.provider = ? AND pay.provider_ref = ?
-        ORDER BY i.period_end DESC
+        ORDER BY i.entry_id DESC
         LIMIT 1
       |]
       (textEncode provider, providerRef)
@@ -254,6 +258,11 @@ getPurchaseByKey db key =
     toPurchase (badgePurchaseId, Binary mk, badgeType) =
       ServicePurchase {badgePurchaseId, masterKey = BadgeMasterKey mk, badgeType}
 
+-- | In the transaction that writes the ledger rows of that tier.
+setPurchaseBadgeType :: DB.Connection -> Int64 -> BadgeType -> UTCTime -> IO ()
+setPurchaseBadgeType db purchaseId badgeType now =
+  DB.execute db "UPDATE sx_badge_service_badge_purchases SET current_badge_type = ?, updated_at = ? WHERE badge_purchase_id = ?" (badgeType, now, purchaseId)
+
 getLedgerTip :: DB.Connection -> Int64 -> IO (Maybe StatementEntry)
 getLedgerTip db purchaseId =
   maybeFirstRow' Nothing toEntry $
@@ -261,9 +270,12 @@ getLedgerTip db purchaseId =
       db
       [sql|
         SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type,
-               l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id, l.charge_id
+               l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id, l.charge_id,
+               fp.purchase_key, tp.purchase_key
         FROM sx_badge_service_badge_ledger l
         LEFT JOIN sx_badge_service_payments pay ON pay.payment_id = l.payment_id
+        LEFT JOIN sx_badge_service_badge_purchases fp ON fp.badge_purchase_id = l.from_purchase_id
+        LEFT JOIN sx_badge_service_badge_purchases tp ON tp.badge_purchase_id = l.to_purchase_id
         WHERE l.badge_purchase_id = ?
         ORDER BY l.entry_id DESC
         LIMIT 1
@@ -286,37 +298,48 @@ getLedgerEntries db purchaseId afterEntryId =
       db
       [sql|
         SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type,
-               l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id, l.charge_id
+               l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id, l.charge_id,
+               fp.purchase_key, tp.purchase_key
         FROM sx_badge_service_badge_ledger l
         LEFT JOIN sx_badge_service_payments pay ON pay.payment_id = l.payment_id
+        LEFT JOIN sx_badge_service_badge_purchases fp ON fp.badge_purchase_id = l.from_purchase_id
+        LEFT JOIN sx_badge_service_badge_purchases tp ON tp.badge_purchase_id = l.to_purchase_id
         WHERE l.badge_purchase_id = ? AND l.entry_id > ?
         ORDER BY l.entry_id
       |]
       (purchaseId, afterEntryId)
 
-toEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType, Text, Maybe Text, Maybe Text, UTCTime) :. (Maybe Text, Maybe Text, Maybe Text) -> Maybe StatementEntry
-toEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, entryType_, credit_, debit_, createdAt) :. (paymentId_, invoiceId_, chargeId_)) =
+toEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType, Text, Maybe Text, Maybe Text, UTCTime) :. (Maybe Text, Maybe Text, Maybe Text, Maybe C.PublicKeyEd25519, Maybe C.PublicKeyEd25519) -> Maybe StatementEntry
+toEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, entryType_, credit_, debit_, createdAt) :. (paymentId_, invoiceId_, chargeId_, fromKey_, toKey_)) =
   (\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince = Nothing, createdAt, entryType})
-    <$> entryTypeFromColumns ((InvoiceId <$> invoiceId_) <$ paymentId_) chargeId_ entryType_ credit_ debit_
+    <$> entryTypeFromColumns references entryType_ credit_ debit_
+  where
+    references =
+      EntryReferences
+        { refPayment = (InvoiceId <$> invoiceId_) <$ paymentId_,
+          refChargeId = chargeId_,
+          refFromPurchaseKey = fromKey_,
+          refToPurchaseKey = toKey_
+        }
 
+-- | The newest issuance, and only while it runs: after a tier change the superseded tier's month can end later.
 getCurrentIssuance :: DB.Connection -> Int64 -> UTCTime -> IO (Maybe BadgeCredential)
 getCurrentIssuance db purchaseId now = do
   rs <-
     DB.query
       db
       [sql|
-        SELECT credential FROM sx_badge_service_badge_issuances
-        WHERE badge_purchase_id = ? AND period_end > ?
-        ORDER BY period_end DESC
+        SELECT credential, period_end FROM sx_badge_service_badge_issuances
+        WHERE badge_purchase_id = ?
+        ORDER BY entry_id DESC
         LIMIT 1
       |]
-      (purchaseId, now)
+      (Only purchaseId)
   pure $ case rs of
-    [Only (Binary bs)] -> J.decodeStrict' bs
+    [(Binary bs, periodEnd)] | periodEnd > now -> J.decodeStrict' bs
     _ -> Nothing
 
 -- | creditPaymentId_ names the payment behind a payment credit among the rows.
--- TODO write the other reference columns (from_purchase_id, to_purchase_id) for entry types that carry one; only the tag is written today.
 appendLedgerPlan :: DB.Connection -> Int64 -> Maybe Text -> [StatementEntry] -> Maybe (StatementEntry, StatementEntry, BadgeCredential) -> IO ()
 appendLedgerPlan db purchaseId creditPaymentId_ rows issuance_ = do
   mapM_ appendRow rows
@@ -337,20 +360,31 @@ appendLedgerPlan db purchaseId creditPaymentId_ rows issuance_ = do
   where
     appendRow StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, createdAt, entryType} = do
       let (entryTypeT, creditType, debitType) = entryTypeColumns entryType
-          (paymentId_, chargeId_) = case entryType of
-            SECredit SCPayment {} -> (creditPaymentId_, Nothing)
-            SECredit SCCharge {chargeId} -> (Nothing, Just chargeId)
-            _ -> (Nothing, Nothing)
+          (paymentId_, chargeId_, fromKey_, toKey_) = case entryType of
+            SECredit SCPayment {} -> (creditPaymentId_, Nothing, Nothing, Nothing)
+            SECredit SCCharge {chargeId} -> (Nothing, Just chargeId, Nothing, Nothing)
+            SECredit SCTransferIn {fromPurchaseKey} -> (Nothing, Nothing, Just fromPurchaseKey, Nothing)
+            SEDebit SDUpgrade {toPurchaseKey} -> (Nothing, Nothing, Nothing, Just toPurchaseKey)
+            SEDebit SDTransferOut {toPurchaseKey} -> (Nothing, Nothing, Nothing, Just toPurchaseKey)
+            _ -> (Nothing, Nothing, Nothing, Nothing)
+      fromPurchaseId_ <- mapM purchaseIdOf fromKey_
+      toPurchaseId_ <- mapM purchaseIdOf toKey_
       DB.execute
         db
         [sql|
           INSERT INTO sx_badge_service_badge_ledger
             (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts,
-             balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id)
-          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+             balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id,
+             from_purchase_id, to_purchase_id)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
         |]
-        ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType, paymentId_, chargeId_))
+        ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType, paymentId_, chargeId_) :. (fromPurchaseId_, toPurchaseId_))
       insertedRowId db
+    -- a row whose reference is lost can never be read back, so the write fails and its transaction rolls back
+    purchaseIdOf :: C.PublicKeyEd25519 -> IO Int64
+    purchaseIdOf key =
+      maybeFirstRow fromOnly (DB.query db "SELECT badge_purchase_id FROM sx_badge_service_badge_purchases WHERE purchase_key = ?" (Only key))
+        >>= maybe (fail "badge ledger row names a purchase key with no purchase") pure
 
 -- The claim takes one use before adding the purchase, so a concurrent revoke or redemption waits on this row and sees the new count.
 -- Run it in the credential's transaction.
@@ -403,6 +437,65 @@ createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid,
         (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, paymentId, now, now)
       Just <$> insertedRowId db
 
+-- | A payment's move from the purchase holding it to a new purchase under another key. fromRows are the old
+-- purchase's rows that end its share, written after the new purchase exists, as they name its key.
+data PaymentRebind = PaymentRebind
+  { paymentId :: Text,
+    fromPurchaseId :: Int64,
+    fromTipId :: Text,
+    fromRows :: [StatementEntry],
+    purchaseKey :: C.PublicKeyEd25519,
+    masterKey :: BadgeMasterKey,
+    badgeType :: BadgeType
+  }
+
+-- | In the transaction of the new purchase's own rows. Writes nothing and returns Nothing when another request
+-- moved the payment or the old purchase's ledger since fromTipId was read.
+rebindStorePayment :: DB.Connection -> PaymentRebind -> UTCTime -> IO (Maybe Int64)
+rebindStorePayment db PaymentRebind {paymentId, fromPurchaseId, fromTipId, fromRows, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do
+  tip <- getLedgerTip db fromPurchaseId
+  if fmap entryId tip /= Just fromTipId
+    then pure Nothing
+    else do
+      released <-
+        executeChanging
+          db
+          "UPDATE sx_badge_service_badge_purchases SET payment_id = NULL, updated_at = ? WHERE badge_purchase_id = ? AND payment_id = ?"
+          (now, fromPurchaseId, paymentId)
+      if released == 0
+        then pure Nothing
+        else do
+          DB.execute
+            db
+            [sql|
+              INSERT INTO sx_badge_service_badge_purchases
+                (purchase_key, master_key, initial_badge_type, current_badge_type, status, payment_id, created_at, updated_at)
+              VALUES (?,?,?,?,?,?,?,?)
+            |]
+            (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, paymentId, now, now)
+          purchaseId <- insertedRowId db
+          appendLedgerPlan db fromPurchaseId Nothing fromRows Nothing
+          DB.execute db "UPDATE sx_badge_service_payments SET rebound_at = ?, updated_at = ? WHERE payment_id = ?" (now, now, paymentId)
+          pure $ Just purchaseId
+
+-- | The latest credential expiry of the purchase the payment last moved from; Nothing if it never moved.
+-- Only that purchase's transferOut names the holder, as a payment moves only to a key that held no purchase.
+getMovedFromExpiry :: DB.Connection -> Text -> IO (Maybe UTCTime)
+getMovedFromExpiry db paymentId =
+  maybeFirstRow fromOnly $
+    DB.query
+      db
+      [sql|
+        SELECT i.expiry
+        FROM sx_badge_service_badge_purchases p
+        JOIN sx_badge_service_badge_ledger l ON l.to_purchase_id = p.badge_purchase_id
+        JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = l.badge_purchase_id
+        WHERE p.payment_id = ? AND l.entry_type = 'debit' AND l.entry_debit_type = 'transferOut'
+        ORDER BY i.expiry DESC
+        LIMIT 1
+      |]
+      (Only paymentId)
+
 -- | What a renewal asks the store about, for a purchase a subscription funds.
 data PurchaseSubscription = PurchaseSubscription
   { paymentId :: Text,

apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs

@@ -213,7 +213,15 @@ CREATE TABLE @subscription_charges(
 
 ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges;
 
-CREATE UNIQUE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id);
+CREATE UNIQUE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id, 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);
 
 ALTER TABLE @payments ADD COLUMN subscription_state TEXT;
 
@@ -221,6 +229,8 @@ ALTER TABLE @payments ADD COLUMN subscription_checked_at TIMESTAMPTZ;
 
 ALTER TABLE @payments ADD COLUMN provider_token TEXT;
 
+ALTER TABLE @payments ADD COLUMN rebound_at TIMESTAMPTZ;
+
 ALTER TABLE @payments DROP COLUMN subscription_renews_at;
 
 ALTER TABLE @payments DROP COLUMN grace_until;
@@ -239,12 +249,22 @@ ALTER TABLE @payments ADD COLUMN grace_until TIMESTAMPTZ;
 
 ALTER TABLE @payments ADD COLUMN cancelled SMALLINT NOT NULL DEFAULT 0;
 
+ALTER TABLE @payments DROP COLUMN rebound_at;
+
 ALTER TABLE @payments DROP COLUMN provider_token;
 
 ALTER TABLE @payments DROP COLUMN subscription_checked_at;
 
 ALTER TABLE @payments DROP COLUMN subscription_state;
 
+DROP INDEX @idx_badge_ledger_to_purchase;
+
+DROP INDEX @idx_badge_ledger_from_purchase;
+
+ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id;
+
+ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id;
+
 DROP INDEX @idx_badge_ledger_charge;
 
 ALTER TABLE @badge_ledger DROP COLUMN charge_id;

apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs

@@ -214,7 +214,15 @@ CREATE TABLE @subscription_charges(
 
 ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges;
 
-CREATE UNIQUE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id);
+CREATE UNIQUE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id, 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);
 
 ALTER TABLE @payments ADD COLUMN subscription_state TEXT;
 
@@ -222,6 +230,8 @@ ALTER TABLE @payments ADD COLUMN subscription_checked_at TEXT;
 
 ALTER TABLE @payments ADD COLUMN provider_token TEXT;
 
+ALTER TABLE @payments ADD COLUMN rebound_at TEXT;
+
 ALTER TABLE @payments DROP COLUMN subscription_renews_at;
 
 ALTER TABLE @payments DROP COLUMN grace_until;
@@ -240,12 +250,22 @@ ALTER TABLE @payments ADD COLUMN grace_until TEXT;
 
 ALTER TABLE @payments ADD COLUMN cancelled INTEGER NOT NULL DEFAULT 0;
 
+ALTER TABLE @payments DROP COLUMN rebound_at;
+
 ALTER TABLE @payments DROP COLUMN provider_token;
 
 ALTER TABLE @payments DROP COLUMN subscription_checked_at;
 
 ALTER TABLE @payments DROP COLUMN subscription_state;
 
+DROP INDEX @idx_badge_ledger_to_purchase;
+
+DROP INDEX @idx_badge_ledger_from_purchase;
+
+ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id;
+
+ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id;
+
 DROP INDEX @idx_badge_ledger_charge;
 
 ALTER TABLE @badge_ledger DROP COLUMN charge_id;

apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs

@@ -7,7 +7,6 @@
 
 module BadgeService.StoreReceipts.Google (PlayVerifier (..), playStoreVerifier) where
 
-import BadgeService.Catalog (storePlan)
 import BadgeService.Config (PlayStoreConfig (..))
 import BadgeService.StoreReceipts (StoreCharge (..), StoreRefusal (..), SubscriptionCheck (..), VerifiedStoreTransaction (..), storeRequest)
 import Control.Concurrent.STM
@@ -38,6 +37,7 @@ import Network.HTTP.Client.TLS (newTlsManager)
 import Network.HTTP.Types (hAuthorization, hContentType, methodPost, renderSimpleQuery)
 import Simplex.Chat.Badges.Ledger (addMonths)
 import Simplex.Chat.Badges.Service (SubscriptionState (..))
+import Simplex.Chat.Badges.StorePlan (storePlan)
 import Simplex.Chat.PaymentService (googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (PaymentProvider (..))
 import Simplex.Messaging.Util (tshow)

apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs

@@ -4,7 +4,7 @@
 
 module BadgeService.StoreReceipts.Mock (newMockStoreVerifier) where
 
-import BadgeService.Catalog (playMonthlyPlan, storePlan)
+import BadgeService.Catalog (playMonthlyPlan)
 import BadgeService.StoreReceipts
 import Control.Applicative ((<|>))
 import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO)
@@ -19,6 +19,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime, addUTCTime)
 import Simplex.Chat.Badges.Ledger (addMonths)
 import Simplex.Chat.Badges.Service (SubscriptionState (..))
+import Simplex.Chat.Badges.StorePlan (storePlan)
 import Simplex.Chat.PaymentService (appleTransactionRef, googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (PaymentProvider (..))
 import Simplex.Messaging.Util (eitherToMaybe, tshow)

docs/protocol/badges-overview.md

@@ -203,7 +203,7 @@ Service requests are protected by the double ratchet of the [SimpleX agent](http
 1. A proof discloses no value that links it to another proof or to the purchase.
 2. A proof used in one context, whether a session, a conversation or a file, cannot be used in another context.
 3. The timing of presentations does not identify the holder: all credentials expiring in the same week share the same expiry, and the renewal request and the profile update are made on different days.
-4. Requests to the badge service cannot be linked to each other, to a profile or to a network address, other than the redemptions of one multi-use code and the codes issued in the service's managed group or redeemed by its members, and a request about a purchase can be made only by the holder of the purchase key.
+4. Requests to the badge service cannot be linked to each other, to a profile or to a network address, other than the redemptions of one multi-use code, the codes issued in the service's managed group or redeemed by its members, and a store subscription moved to a new key by Restore, which the service links to the key it moved from as the store account already links both, and a request about a purchase can be made only by the holder of the purchase key.
 5. A credential cannot be forged: the issuer keys are fixed in apps and servers, and the app verifies a credential before storing it.
 6. A missing or failed proof leaves the default limit in place, and a server cannot be configured to grant a badge type less than the default.
 

docs/protocol/badges-rpc.md

@@ -22,12 +22,13 @@ A timeout hides the outcome, so the client repeats the identical signed request
 - `redeemBadgeCode` — a code already redeemed by the signing key returns its latest `badgeCredential` and writes nothing; once other keys have taken all its uses, `code_used`. The client must therefore keep the key it first signed with, or a retry cannot be recognised.
 - `purchaseBadge` — a payment already credited returns the same `badgeCredential` and writes nothing; a store payment credited to another key, `receipt_used`.
 - `upgradeBadgeSubscription` — evidence already applied returns the same result and writes nothing.
+- `transferBadge` — a payment already moved to the signing key returns the same `badgeCredential`, without asking the store and without the move limit.
 - `issueBadge` — repeated within an issued period, returns the cached credential and writes nothing.
 - `purchaseBadge` with the recovery `receipt` — presented again by the same key it returns the same result; presented by another key, `receipt_used`.
 
 ## Commands
 
-The client never states what is signed. The tier is that of whatever funded the purchase; the expiry is the `sundayAfter` of the period issued (`endOfMondayAfter` in code), shared by every credential of that week; `badgeExtra` is reserved and empty. A client-proposed expiry, even one capped by the funded coverage, would fall off that shared boundary and single its holder out of the week's anonymity set — so no command carries `badgeRequest`. `upgradeBadgeSubscription` still has the field in the schema; that is wrong and it must be dropped when the command is implemented.
+The client never states what is signed. The tier is that of whatever funded the purchase; the expiry is the `sundayAfter` of the period issued (`endOfMondayAfter` in code), shared by every credential of that week; `badgeExtra` is reserved and empty. A client-proposed expiry, even one capped by the funded coverage, would fall off that shared boundary and single its holder out of the week's anonymity set — so no command carries `badgeRequest`.
 
 - `getBadgeCatalog` → `badgeCatalog` — the prices and offers; signed, also the purchase's `badgeStatement`. Store builds never send it: prices come from the store and SKUs from app config.
 - `getBadgeInvoice` → `badgeInvoice` — prices the purchase for `badgeInfo` and `paymentVia` (`card` — Stripe; `crypto` — btc, xmr). The response holds the generic `invoice` — `invoiceId`, `price`, `discount`, the upgrade `credit`, `amount` = price − discount − credit, `currency`, `expiresAt`, and `paymentTo` (`url` for card; `address` and `cryptoAmount` for crypto) — beside the badge part, `badgeType` and `months`. `priceId` pins the price the client displayed; `offerId` selects a discounted duration, and its absence buys one month at that price. Price and offer status is checked here only: `deprecated` is still accepted, `disabled` is rejected; a badge type with no active price yields `product_unavailable`.
@@ -58,9 +59,10 @@ The client never states what is signed. The tier is that of whatever funded the
       - `product_unavailable` and `provider_not_configured` as for the App Store, the latter without a `[google]` section.
       - Before crediting a purchase of a product it prices, the service acknowledges it, unless Play already reports it acknowledged or consumed; a subscription is acknowledged with `purchases.subscriptions.acknowledge` before its first charge is credited. It acknowledges and never consumes, so the app's purchase query still lists the purchase. The app may not be honest, and only acknowledgement stops Play refunding the purchase after three days, so nothing is credited unacknowledged. A failed acknowledgement credits nothing and is answered like a failed read — `provider_unavailable` when Play does not answer, `internal` when it refuses this service, both logged with "acknowledging" in the reason — and the app presents the purchase again. A deployment whose service account lacks the permission to acknowledge therefore answers `internal` to every Play purchase the app has not already acknowledged itself.
   - Funding by `receipt` is a transfer (post-MVP): the unissued months of the purchase that receipt belongs to move to the signing key, recorded as `debit(transferOut)` on the source and `credit(transferIn)` on the new purchase, and the presented receipt is retired for a fresh one. The transferred period's issuance debits a month like any other. Lifetime badges hold no receipt, so support handles them.
-- `upgradeBadgeSubscription` → `badgeCredential` — the app-led store subscription change, on the same key: verifies the store evidence of the replaced subscription and records the new plan; an immediate upgrade returns the new credential, a deferred change returns none. Its `badgeRequest` is to be dropped (see above).
+- `upgradeBadgeSubscription` → `badgeCredential` — the app-led store subscription change, on the same key: it carries `payment`, an App Store transaction of the purchase's own subscription after the change, and `balance`, and makes the service ask the store now rather than at the next renewal. It is refused before the store is asked when the transaction does not verify (`receipt_invalid`), when it is of no subscription product, of another subscription, of a purchase no App Store subscription funds, or from Play (`bad_request`), and for an unknown key (`unknown_purchase_key`). The store is asked at most once an hour per subscription, an hour shared with the renewal checks. A transaction of the tier the ledger already holds is answered from the record. Otherwise the store is asked and its latest charge is granted as a renewal check grants it, of whatever tier, and the answer is the new tier's credential once that tier is granted; until then the answer is `payment_pending` with a `retryAfter` to the next allowed check, never the old tier's credential. The tier granted is the store's; the transaction only names the subscription and the tier to wait for.
+- `transferBadge` → `badgeCredential` — Restore on another device or profile: it carries `masterKey` and `payment`, the store receipt of a subscription credited to another key, and moves the subscription to the signing key, which must hold no purchase yet (`bad_request`). The store is asked first, at most once an hour per subscription as for `purchaseBadge`, and an App Store transaction must be the subscription's latest, so an older receipt stops moving it once the store charges again (`payment_pending` until then). The old purchase is lapsed and debited `transferOut {toPurchaseKey}` of its remaining months, even none, and is answered `subscription = ended` with no `credential` from then on; the new purchase is credited the store's current charge from its period start, as a first purchase is, and the month due is issued. A payment moves again only once the credential issued to the key it last moved from has expired (`transfer_limited`): a store receipt is not a one-time secret, so this keeps each paid month with at most two keys. A payment credited to no key is credited as by `purchaseBadge`. A one-time purchase is not moved: its months were issued at purchase.
 - `issueBadge` → `badgeCredential` — issues the next period from the balance, the only source of issuance. It carries `balance` alone: the credential is signed with the purchase's stored master key, for the type the balance funds, expiring at the `sundayAfter` of the period issued. The ledger is advanced first; the credential is signed before the `debit(badge)` and issuance rows are written, in one transaction. An exhausted balance yields no `credential`; the `statement` shows why. Issuing on a paused badge resumes it (model 2.13).
-  - **Subscriptions.** While a store subscription's paid coverage runs, `issueBadge` is answered as above, without asking the store. Once it has ended, the service asks the store, at most once an hour per subscription whether or not the store answers, and answers requests in between from what it last read. A charge it can grant, by the rule `purchaseBadge` applies to a first charge but only for the purchase's own badge type and never twice, is granted at the store's period start, after a lapse of what ran out before it, and the month due is issued. Otherwise no ledger row is written: the charge, if any, and the state are recorded, and the answer carries no new `credential` and the `subscription` the store reported. A store that does not answer is answered `provider_unavailable` with a `retryAfter` of the hour. Every answer for a subscription purchase carries `subscription`. A development deployment may ask its store at every request, during coverage too, and bank the months of a charge it can grant, issued once coverage reaches them; a real store is asked during coverage only by a development deployment that also credits test purchases.
+  - **Subscriptions.** While a store subscription's paid coverage runs, `issueBadge` is answered as above, without asking the store. Once it has ended, the service asks the store, at most once an hour per subscription whether or not the store answers, and answers requests in between from what it last read. A charge it can grant, by the rule `purchaseBadge` applies to a first charge but never twice, is granted at the store's period start, or at the ledger's last row when that is later, so rows are never dated before the row they follow, after a lapse of what ran out before it, and the month due is issued. A charge of another badge type is granted as that type: what remains of the old run is debited as `upgrade` naming the purchase's own key, the new run starts at that date, and the purchase's badge type follows it. Otherwise no ledger row is written: the charge, if any, and the state are recorded, and the answer carries no new `credential` and the `subscription` the store reported. A store that does not answer is answered `provider_unavailable` with a `retryAfter` of the hour. Every answer for a subscription purchase carries `subscription`. A development deployment may ask its store at every request, during coverage too, and bank the months of a charge it can grant, issued once coverage reaches them; a real store is asked during coverage only by a development deployment that also credits test purchases.
 - `pauseBadge` (post-MVP) → `badgeCredential` — suspends issuance and lapse (model 2.13).
 
 ## Upgrades
@@ -70,7 +72,7 @@ Always a new purchase under a new key, except store subscriptions, where the sto
 - Non-store: `getBadgeInvoice.upgrade` — `fromPurchaseKey`, the old purchase's `receipt`, `receiptSignature` binding the old key to the new, and the asserted old `balance`. The invoice returns the conversion `credit`; settlement records `debit(upgrade)` on the old purchase and the credit on the new.
 - Store one-time: an upgrade SKU at a fixed discounted price; `purchaseBadge.upgrade` — `fromPurchaseKey`, `receipt`, `receiptSignature` — proves eligibility (an unexpired cheaper badge), because the store cannot gate who buys the SKU.
 - Store subscription, app-led: the native subscription-group flow (Apple — immediate, with the store's prorated refund; Google — per replacement mode), then `upgradeBadgeSubscription` with the new evidence.
-- Store subscription, sheet-led, and every downgrade: the client sends nothing — the service discovers the change from provider state and notifications. Until tier changes are supported, a charge for another badge type is recorded and not granted.
+- Store subscription, sheet-led, and every downgrade: the client sends nothing — the service discovers the change from provider state and notifications, and grants the badge type the store charged at its next check after coverage ends.
 
 ## Catalog
 
@@ -90,4 +92,4 @@ An assertion that names an entry the service holds is a prefix: the service proc
 
 ## Errors
 
-`retryAfter` marks the transient codes: `payment_pending`, `provider_unavailable`, `rate_limited`. `offer_disabled` calls for a catalog refresh. `code_invalid` covers unknown, malformed and revoked codes alike, so a guesser learns nothing from the difference; `code_used` — all its uses taken by other keys; `code_expired` — past its redemption deadline. `receipt_invalid` covers forged, malformed and refunded receipts alike, so a guesser learns nothing from the difference; `test_purchase` is named apart from them because the device that bought it already knows; `receipt_used` — credited to another key; `provider_not_configured` — no verifier for that store is deployed, so the receipt is neither credited nor refused. All other codes are terminal for the attempted command.
+`retryAfter` marks the transient codes: `payment_pending`, `provider_unavailable`, `rate_limited`. `offer_disabled` calls for a catalog refresh. `code_invalid` covers unknown, malformed and revoked codes alike, so a guesser learns nothing from the difference; `code_used` — all its uses taken by other keys; `code_expired` — past its redemption deadline. `receipt_invalid` covers forged, malformed and refunded receipts alike, so a guesser learns nothing from the difference; `test_purchase` is named apart from them because the device that bought it already knows; `receipt_used` — credited to another key; `transfer_limited` — the subscription moved from a key whose credential is still valid, with no `retryAfter`; `provider_not_configured` — no verifier for that store is deployed, so the receipt is neither credited nor refused. All other codes are terminal for the attempted command.

docs/protocol/badges-rpc.schema.json

@@ -22,12 +22,6 @@
         "badgeExpiry": {"type": "timestamp"}
       }
     },
-    "badgeRequest": {
-      "properties": {
-        "masterKey": {"ref": "base64url"},
-        "badgeInfo": {"ref": "badgeInfo"}
-      }
-    },
     "credential": {
       "properties": {
         "badgeKeyIdx": {"type": "uint16"},
@@ -322,17 +316,22 @@
         },
         "upgradeBadgeSubscription": {
           "properties": {
-            "badgeRequest": {
-              "ref": "badgeRequest",
-              "metadata": {"comment": "known wrong: to be dropped when implemented, see badges-rpc.md"}
-            },
             "payment": {
               "ref": "payment",
-              "metadata": {"comment": "store payments only"}
+              "metadata": {"comment": "apple only: a transaction of the purchase's own subscription"}
             },
             "balance": {"ref": "balance"}
           }
         },
+        "transferBadge": {
+          "properties": {
+            "masterKey": {"ref": "base64url"},
+            "payment": {
+              "ref": "payment",
+              "metadata": {"comment": "a store subscription's receipt, credited to another key"}
+            }
+          }
+        },
         "issueBadge": {
           "properties": {
             "balance": {"ref": "balance"}

plans/2026-10-20-badge-ledger-transitions.md

@@ -28,7 +28,7 @@ Base: `f/badge-subscriptions` at 26f846e1a (line numbers at that commit). `SVC/`
 
 **Schema.**
 
-- Service: `badge_ledger.from_purchase_id`, `badge_ledger.to_purchase_id`; `payments.rebound_at` (when the payment was last moved to another key, logged and answered in `transfer_limited`; the limit itself is checked against the previous key's latest credential expiry, which the service signed); charge index `UNIQUE(charge_id)` → `UNIQUE(badge_purchase_id, charge_id)`.
+- Service: `badge_ledger.from_purchase_id`, `badge_ledger.to_purchase_id`; `payments.rebound_at` (when the payment was last moved to another key, logged; the limit itself is checked against the previous key's latest credential expiry, which the service signed, and `transfer_limited` carries no date); charge index `UNIQUE(charge_id)` → `UNIQUE(badge_purchase_id, charge_id)`.
 - Client: `badge_store_receipts.hold_kind` (purchase, transfer, tier change).
 - Later, receipts: `badge_purchases.receipt_hash` (service), `badge_purchases.receipt` (client).
 
@@ -90,7 +90,7 @@ A payment credited nowhere is treated as a first purchase. `purchaseBadge` from
 
 The worker sends `transferBadge` for transfer records. On success the record links to the new purchase; on a refusal it goes back to the old one.
 
-**Apps (R3).** Restore hands over `Transaction.currentEntitlements` and `Transaction.unfinished` on iOS, and Play's subscriptions on Android, with the `restored` origin. The result shows through the existing "being added" state and alerts. One new text, for `transfer_limited`: "This purchase was moved to another device or profile recently. It can be moved again on {date}."
+**Apps (R3).** Restore hands over `Transaction.currentEntitlements` and `Transaction.unfinished` on iOS, and Play's subscriptions on Android, with the `restored` origin. The result shows through the existing "being added" state and alerts. One new text, for `transfer_limited`: "This purchase was moved to another device or profile recently."
 
 ### Restore by receipt for Stripe and crypto (later, R4-R6)
 

simplex-chat.cabal

@@ -43,6 +43,7 @@ library
       Simplex.Chat.Badges.Code
       Simplex.Chat.Badges.Ledger
       Simplex.Chat.Badges.Service
+      Simplex.Chat.Badges.StorePlan
       Simplex.Chat.Badges.Types
       Simplex.Chat.Names
       Simplex.Chat.Call

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(

tests/BadgeTests.hs

@@ -96,6 +96,8 @@ badgeTests = do
     it "leaves an entry type it cannot derive unchecked, its months still checked" testChecksUnknownType
     it "rejects an entry it cannot rebuild whose coverage or months contradict the ledger" testChecksUncheckedInvariants
     it "accepts every row a store charge adds, on each path a subscription renews by" testChargeRowsVerify
+    it "re-runs an upgrade or a transfer debit, and rejects one that leaves months" testDebitRowsVerify
+    it "accepts every row a change of tier adds, and rejects a new tier granted over months still held" testTierChangeRowsVerify
   describe "worker retry" $ do
     it "repeats a failure that can clear on its own, and no other" testRetryClassification
     it "backs off to the cap" testRetryBackoff
@@ -370,7 +372,7 @@ newBalance t = emptyEntry t BTSupporter
 
 -- these tests never write, so the id each operation stamps on its entry is never read
 grant :: UTCTime -> Int -> StatementEntry -> StatementEntry
-grant t n = grantEntry t "" n SCCode
+grant t n = grantEntry t "" BTSupporter n SCCode
 
 lapse :: UTCTime -> StatementEntry -> Maybe StatementEntry
 lapse t = lapseEntry t ""
@@ -675,6 +677,8 @@ testChecksUnknownType = do
   let unknown = issued {entryType = SEDebit SDUnknown {tag = "future", json = KM.empty}}
   verdicts start (Just granted) [unknown] `shouldBe` [Nothing]
   verdicts start (Just granted) [issued {entryType = SEDebit SDRefund}] `shouldBe` [Nothing]
+  -- nor may it switch tier over the months the balance holds
+  verdicts start (Just granted) [issued {entryType = SEDebit SDRefund, balanceBadgeType = BTLegend}] `shouldBe` [Just False]
   verdicts start (Just granted) [unknown {balanceMonths = 5}] `shouldBe` [Just False]
   verdicts start (Just granted) [stampedAt (at 2026 3 1) unknown] `shouldBe` [Just False]
   -- an unknown credit takes the same path: fall through to grantEntry and its negative count,
@@ -697,10 +701,10 @@ testChecksUncheckedInvariants = do
   bMonths owing `shouldBe` bMonths issued - 3
 
 -- the service's step for a charge it grants: the planner's rows, then the issue at now
-charged :: UTCTime -> UTCTime -> Int -> StatementEntry -> [StatementEntry]
-charged periodStart now months tip = rows <> maybeToList (issue now $ finalBalance tip rows)
+charged :: C.PublicKeyEd25519 -> UTCTime -> UTCTime -> BadgeType -> Int -> StatementEntry -> [StatementEntry]
+charged ownKey periodStart now badgeType months tip = rows <> maybeToList (issue now $ finalBalance tip rows)
   where
-    rows = chargeEntries periodStart now months "ch1" ("", "", "") tip
+    rows = chargeEntries periodStart now badgeType months ownKey "ch1" ("", "", "", "") tip
 
 rowKind :: StatementEntry -> T.Text
 rowKind StatementEntry {entryType} = case entryType of
@@ -722,9 +726,10 @@ allVerify rows = verdicts (rowAt $ last rows) Nothing rows `shouldBe` map (const
 -- renews by must keep both the dates in order and the recompute exact.
 testChargeRowsVerify :: IO ()
 testChargeRowsVerify = do
+  ownKey <- newPurchaseKey
   let p0 = at 2026 3 10
       days n = addUTCTime (n * nominalDay)
-      firstCharge = charged p0 (addUTCTime 600 p0) 1 (newBalance p0)
+      firstCharge = charged ownKey p0 (addUTCTime 600 p0) BTSupporter 1 (newBalance p0)
       afterFirst = finalBalance (newBalance p0) firstCharge
   -- a first charge, granted onto the seed the service starts a purchase from
   map rowKind firstCharge `shouldBe` ["charge", "badge"]
@@ -732,20 +737,20 @@ testChargeRowsVerify = do
   -- monthly renewals, each charged at the store's period start and asked about some days after it
   let renew (tip, rows) (k, late) =
         let periodStart = addMonths k p0
-            new = charged periodStart (days late periodStart) 1 tip
+            new = charged ownKey periodStart (days late periodStart) BTSupporter 1 tip
          in (finalBalance tip new, rows <> new)
       (_, monthly) = foldl renew (afterFirst, firstCharge) [(1, 3), (2, 6), (3, 1)]
   map rowKind monthly `shouldBe` concat (replicate 4 ["charge", "badge"])
   allVerify monthly
   -- a period start equal to the balance start continues the run on its anchor
-  let sameStart = charged (bStart afterFirst) (days 4 $ bStart afterFirst) 1 afterFirst
+  let sameStart = charged ownKey (bStart afterFirst) (days 4 $ bStart afterFirst) BTSupporter 1 afterFirst
   map rowKind sameStart `shouldBe` ["charge", "badge"]
   map bAnchor (take 1 sameStart) `shouldBe` [p0]
   allVerify (firstCharge <> sameStart)
   -- and a store clock a minute either side of it still verifies, whichever branch the grant takes
   mapM_
     ( \offset -> do
-        let rows = charged (addUTCTime offset $ bStart afterFirst) (days 4 $ bStart afterFirst) 1 afterFirst
+        let rows = charged ownKey (addUTCTime offset $ bStart afterFirst) (days 4 $ bStart afterFirst) BTSupporter 1 afterFirst
         map rowKind rows `shouldBe` ["charge", "badge"]
         allVerify (firstCharge <> rows)
     )
@@ -753,37 +758,118 @@ testChargeRowsVerify = do
   -- a renewal after billing retry: the store's new period starts when the charge recovered, and the
   -- run restarts there, so coverage follows the store's new renewal date
   let recoveredAt = days 9 (addMonths 1 p0)
-      recovered = charged recoveredAt (days 1 recoveredAt) 1 afterFirst
+      recovered = charged ownKey recoveredAt (days 1 recoveredAt) BTSupporter 1 afterFirst
   map rowKind recovered `shouldBe` ["charge", "badge"]
   map bStart (take 1 recovered) `shouldBe` [recoveredAt]
   map paidThrough (take 1 recovered) `shouldBe` [addMonths 1 recoveredAt]
   allVerify (firstCharge <> recovered)
   -- annual: the first month issued at purchase, then one at each month's start
-  let annualFirst = charged p0 p0 12 (newBalance p0)
+  let annualFirst = charged ownKey p0 p0 BTSupporter 12 (newBalance p0)
       annualTip = finalBalance (newBalance p0) annualFirst
       yearEnd = addMonths 12 p0
       monthsIssued n = take n (issueAll annualTip)
       -- the device was offline for the year's last month, which is still unissued at the renewal
       tenMore = monthsIssued 10
       monthLeft = finalBalance annualTip tenMore
-      renewedAnnual = charged yearEnd (days 3 yearEnd) 12 monthLeft
+      renewedAnnual = charged ownKey yearEnd (days 3 yearEnd) BTSupporter 12 monthLeft
   bMonths monthLeft `shouldBe` 1
   map rowKind renewedAnnual `shouldBe` ["lapse", "charge", "badge"]
   allVerify (annualFirst <> tenMore <> renewedAnnual)
   -- the same, with the store's year starting an hour before the ledger's: that month has not run out
   -- at the period start, so it is carried and lapses after the grant
-  let earlyAnnual = charged (addUTCTime (-3600) yearEnd) (days 3 yearEnd) 12 monthLeft
+  let earlyAnnual = charged ownKey (addUTCTime (-3600) yearEnd) (days 3 yearEnd) BTSupporter 12 monthLeft
   map rowKind earlyAnnual `shouldBe` ["charge", "lapse", "badge"]
   allVerify (annualFirst <> tenMore <> earlyAnnual)
   -- away from month nine until 45 days past the year end, while the renewal failed and recovered
   -- inside the store's grace period, which keeps the original period start
   let eightMore = monthsIssued 8
       awayTip = finalBalance annualTip eightMore
-      graced = charged yearEnd (days 45 yearEnd) 12 awayTip
+      graced = charged ownKey yearEnd (days 45 yearEnd) BTSupporter 12 awayTip
   bMonths awayTip `shouldBe` 3
   map rowKind graced `shouldBe` ["lapse", "charge", "lapse", "badge"]
   allVerify (annualFirst <> eightMore <> graced)
 
+newPurchaseKey :: IO C.PublicKeyEd25519
+newPurchaseKey = fst <$> (C.newRandom >>= \g -> atomically (C.generateKeyPair g) :: IO (C.KeyPair 'C.Ed25519))
+
+bTier :: StatementEntry -> BadgeType
+bTier StatementEntry {balanceBadgeType} = balanceBadgeType
+
+-- An upgrade or a transfer takes every month left and keeps the balance start and anchor, so coverage
+-- ends where the issued months end; re-running it verifies the row, and catches one that left months behind.
+testDebitRowsVerify :: IO ()
+testDebitRowsVerify = do
+  k <- newPurchaseKey
+  let start = at 2026 3 10
+      t = at 2026 3 20
+  Just issued <- pure $ issue start $ grant start 12 (newBalance start)
+  let upgraded = debitEntry t "" (SDUpgrade k) issued
+  (bMonths upgraded, bStart upgraded, bAnchor upgraded) `shouldBe` (0, bStart issued, bAnchor issued)
+  verdicts t (Just issued) [upgraded] `shouldBe` [Just True]
+  verdicts t (Just issued) [debitEntry t "" (SDTransferOut k) issued] `shouldBe` [Just True]
+  -- a transfer is written even when nothing is left, as the mark that the purchase moved
+  verdicts t (Just upgraded) [debitEntry t "" (SDTransferOut k) upgraded] `shouldBe` [Just True]
+  verdicts t (Just issued) [upgraded {changeMonths = -10, balanceMonths = 1}] `shouldBe` [Just False]
+
+-- A charge of another tier ends the old run with an upgrade debit of what it still held and starts
+-- a new one: every row it writes must re-run on the client, on each path a tier changes by.
+testTierChangeRowsVerify :: IO ()
+testTierChangeRowsVerify = do
+  k <- newPurchaseKey
+  let p0 = at 2026 3 10
+      days n = addUTCTime (n * nominalDay)
+      p1 = addMonths 1 p0
+  -- a monthly Legend subscription downgraded to Supporter, which the store charges at renewal
+  let legendTip = finalBalance (emptyEntry p0 BTLegend) $ charged k p0 (addUTCTime 600 p0) BTLegend 1 (emptyEntry p0 BTLegend)
+      downgraded = charged k p1 (days 2 p1) BTSupporter 1 legendTip
+  map rowKind downgraded `shouldBe` ["charge", "badge"]
+  map bTier downgraded `shouldBe` [BTSupporter, BTSupporter]
+  map bAnchor (take 1 downgraded) `shouldBe` [p1]
+  verdicts (days 2 p1) (Just legendTip) downgraded `shouldBe` [Just True, Just True]
+  -- an annual Supporter subscription upgraded to annual Legend in its third month, every month so
+  -- far issued: the nine left are debited, and the new year starts at the upgrade
+  let annual = charged k p0 (addUTCTime 600 p0) BTSupporter 12 (newBalance p0)
+      afterFirst = finalBalance (newBalance p0) annual
+      secondMonth = pass p1 afterFirst
+      thirdMonth = pass (addMonths 2 p0) (finalBalance afterFirst secondMonth)
+      afterThird = finalBalance afterFirst (secondMonth <> thirdMonth)
+      u = days 10 (addMonths 2 p0)
+      upgraded = charged k u (addUTCTime 60 u) BTLegend 12 afterThird
+  map rowKind upgraded `shouldBe` ["upgrade", "charge", "badge"]
+  map bMonths upgraded `shouldBe` [0, 12, 11]
+  map (\e -> (bStart e, bAnchor e, bTier e)) (take 1 $ drop 1 upgraded) `shouldBe` [(u, u, BTLegend)]
+  case upgraded of
+    StatementEntry {entryType = SEDebit SDUpgrade {toPurchaseKey}} : _ -> toPurchaseKey `shouldBe` k
+    _ -> expectationFailure "no upgrade debit"
+  allVerify (annual <> secondMonth <> thirdMonth <> upgraded)
+  -- the same upgrade after two months nobody asked for: they lapse before the rest is debited
+  let late = days 10 (addMonths 3 p0)
+      lapsedUpgrade = charged k late (addUTCTime 60 late) BTLegend 12 afterFirst
+  map rowKind lapsedUpgrade `shouldBe` ["lapse", "upgrade", "charge", "badge"]
+  map bMonths lapsedUpgrade `shouldBe` [9, 0, 12, 11]
+  allVerify (annual <> lapsedUpgrade)
+  -- a period the store starts before a month the service issued since is dated at that issue, so
+  -- the rows still follow it
+  let issuedAt = days 3 p1
+      issuedLate = pass issuedAt afterFirst
+      clamped = charged k (days 1 p1) (addUTCTime 3600 issuedAt) BTLegend 12 (finalBalance afterFirst issuedLate)
+  map rowKind clamped `shouldBe` ["upgrade", "charge", "badge"]
+  map rowAt (take 2 clamped) `shouldBe` [issuedAt, issuedAt]
+  allVerify (annual <> issuedLate <> clamped)
+  -- a grant of another tier straight over the months still held would discard them
+  let overwritten = grantEntry u "" BTLegend 12 (SCCharge "ch1") afterThird
+  verdicts u (Just afterThird) [overwritten] `shouldBe` [Just False]
+  -- an upgrade found only at the renewal check, after every month of the old year was issued: the new run
+  -- starts at the last issue, and the next charge of the new tier, from a period that started earlier, follows it
+  let yearIssued = issueAll afterFirst
+      found = charged k u (addMonths 12 p0) BTLegend 12 (finalBalance afterFirst yearIssued)
+      legendIssued = issueAll (finalBalance afterFirst (yearIssued <> found))
+      legendYearTip = finalBalance afterFirst (yearIssued <> found <> legendIssued)
+      renewed = charged k (addMonths 12 u) (days 3 $ paidThrough legendYearTip) BTLegend 12 legendYearTip
+  map rowKind found `shouldBe` ["charge", "lapse", "badge"]
+  map rowKind renewed `shouldBe` ["charge", "badge"]
+  allVerify (annual <> yearIssued <> found <> legendIssued <> renewed)
+
 -- A failed renewal is otherwise left until the next chat start or activate, which on a desktop
 -- left running can be days - long enough for a funded badge to lapse.
 testRetryClassification :: IO ()
@@ -843,7 +929,7 @@ testServiceRetryAfter = do
   badgeErrorRetryAfter BSEInternal `shouldBe` Nothing
   mapM_
     (\code -> badgeErrorRetryAfter code `shouldBe` Nothing)
-    [BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEProviderNotConfigured, BSETestPurchase, BSEUnknown "future_code"]
+    [BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEProviderNotConfigured, BSETestPurchase, BSETransferLimited, BSEUnknown "future_code"]
 
 -- The app shows the recorded failure in a sentence, so an agent error is stored as the agent
 -- error and not as the chat error wrapping it, whether or not it can clear on its own.
@@ -917,19 +1003,31 @@ testEntryTypeColumns = do
   mapM_ (\c -> wireTag (J.toJSON (SECredit c)) "credit" `shouldBe` Just (creditTypeTag c)) credits
   mapM_ (\d -> wireTag (J.toJSON (SEDebit d)) "debit" `shouldBe` Just (debitTypeTag d)) debits
   -- the types this version writes survive a round trip through the columns, a payment credit
-  -- through the payment its row references, and a charge credit through its charge
+  -- through the payment its row references, a charge credit through its charge, and a transfer
+  -- or an upgrade through the purchase it names
   mapM_
-    (\t -> uncurry3 (entryTypeFromColumns Nothing Nothing) (entryTypeColumns t) `shouldSatisfy` sameEntryType t)
+    (\t -> uncurry3 (entryTypeFromColumns noEntryReferences) (entryTypeColumns t) `shouldSatisfy` sameEntryType t)
     [SECredit SCCode, SEDebit SDBadge, SEDebit SDLapse]
   let storeCredit = SECredit (SCPayment Nothing)
       invoiceCredit = SECredit (SCPayment (Just (InvoiceId "inv1")))
       chargeCredit = SECredit (SCCharge "ch1")
-  uncurry3 (entryTypeFromColumns (Just Nothing) Nothing) (entryTypeColumns storeCredit) `shouldSatisfy` sameEntryType storeCredit
-  uncurry3 (entryTypeFromColumns (Just (Just (InvoiceId "inv1"))) Nothing) (entryTypeColumns invoiceCredit) `shouldSatisfy` sameEntryType invoiceCredit
-  uncurry3 (entryTypeFromColumns Nothing (Just "ch1")) (entryTypeColumns chargeCredit) `shouldSatisfy` sameEntryType chargeCredit
-  -- a type that needs a reference column is not silently read back as something else
-  uncurry3 (entryTypeFromColumns Nothing Nothing) (entryTypeColumns storeCredit) `shouldSatisfy` isNothing
-  uncurry3 (entryTypeFromColumns Nothing Nothing) (entryTypeColumns chargeCredit) `shouldSatisfy` isNothing
+      transferInCredit = SECredit (SCTransferIn k)
+      upgradeDebit = SEDebit (SDUpgrade k)
+      transferOutDebit = SEDebit (SDTransferOut k)
+      fromKey = noEntryReferences {refFromPurchaseKey = Just k}
+      toKey = noEntryReferences {refToPurchaseKey = Just k}
+  uncurry3 (entryTypeFromColumns noEntryReferences {refPayment = Just Nothing}) (entryTypeColumns storeCredit) `shouldSatisfy` sameEntryType storeCredit
+  uncurry3 (entryTypeFromColumns noEntryReferences {refPayment = Just (Just (InvoiceId "inv1"))}) (entryTypeColumns invoiceCredit) `shouldSatisfy` sameEntryType invoiceCredit
+  uncurry3 (entryTypeFromColumns noEntryReferences {refChargeId = Just "ch1"}) (entryTypeColumns chargeCredit) `shouldSatisfy` sameEntryType chargeCredit
+  uncurry3 (entryTypeFromColumns fromKey) (entryTypeColumns transferInCredit) `shouldSatisfy` sameEntryType transferInCredit
+  mapM_ (\t -> uncurry3 (entryTypeFromColumns toKey) (entryTypeColumns t) `shouldSatisfy` sameEntryType t) [upgradeDebit, transferOutDebit]
+  -- a type that needs a reference column is not silently read back as something else, nor from
+  -- the other purchase column
+  mapM_
+    (\t -> uncurry3 (entryTypeFromColumns noEntryReferences) (entryTypeColumns t) `shouldSatisfy` isNothing)
+    [storeCredit, chargeCredit, transferInCredit, upgradeDebit, transferOutDebit]
+  uncurry3 (entryTypeFromColumns toKey) (entryTypeColumns transferInCredit) `shouldSatisfy` isNothing
+  mapM_ (\t -> uncurry3 (entryTypeFromColumns fromKey) (entryTypeColumns t) `shouldSatisfy` isNothing) [upgradeDebit, transferOutDebit]
   -- which is why every type is stored as its own JSON as well, and read from that first: the
   -- columns alone would answer a row naming an invoice or a purchase as no row at all
   mapM_ roundTrips credits
@@ -1018,8 +1116,10 @@ testAppleTransactionFacts = do
   let jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"]
       part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
       renewal = ["transactionId" J..= ("2000000900000002" :: T.Text), "type" J..= ("Auto-Renewable Subscription" :: T.Text)]
-      facts purchaseDate revoked autoRenewable = Just AppleTransactionFacts {transactionId = "2000000900000002", purchaseDate, expiresDate = Nothing, revoked, autoRenewable}
+      facts purchaseDate revoked autoRenewable = Just AppleTransactionFacts {transactionId = "2000000900000002", productId = Nothing, purchaseDate, expiresDate = Nothing, revoked, autoRenewable}
   appleTransactionFacts (jws $ ("purchaseDate" J..= (1769904000000 :: Int)) : renewal) `shouldBe` facts (Just 1769904000000) False True
+  appleTransactionFacts (jws $ ("productId" J..= ("SUBSCR_BADGE_LEGEND_YEAR_01" :: T.Text)) : renewal)
+    `shouldBe` Just AppleTransactionFacts {transactionId = "2000000900000002", productId = Just "SUBSCR_BADGE_LEGEND_YEAR_01", purchaseDate = Nothing, expiresDate = Nothing, revoked = False, autoRenewable = True}
   appleTransactionFacts (jws $ ("expiresDate" J..= (1772582400000 :: Int)) : renewal) `shouldBe` ((\f -> f {expiresDate = Just 1772582400000}) <$> facts Nothing False True)
   appleTransactionFacts (jws $ ("expiresDate" J..= ("next month" :: T.Text)) : renewal) `shouldBe` facts Nothing False True
   -- the service reads a null revocationDate as not revoked, and so does the client
@@ -1066,7 +1166,7 @@ testChargePeriodOver = do
   let startsAt = UTCTime (fromGregorian 2026 10 20) 43200
       endsAt = addUTCTime 300 startsAt
       charge = StoreCharge {chargeRef = "2000000900000002", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = startsAt, periodEnd = endsAt, chargePaid = Nothing, revoked = False, offer = False}
-      grantAt t = grantableCharge PPApple Nothing t SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = False, latestCharge = Just charge}
+      grantAt t = grantableCharge PPApple t SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = False, latestCharge = Just charge}
       periodOver = \case
         Left NGPeriodOver -> True
         _ -> False
@@ -1085,6 +1185,7 @@ testShownServiceRequest = do
       typeOnly t = J.object ["request" J..= J.object ["type" J..= (t :: T.Text)]]
   shown BSCPurchaseBadge {masterKey = mk, payment = SPApple {jws = "a.b.c"}, upgrade = Nothing} `shouldBe` typeOnly "purchaseBadge"
   shown BSCRedeemBadgeCode {masterKey = mk, code = "SB-00000-00000-00000-00001"} `shouldBe` typeOnly "redeemBadgeCode"
+  shown BSCTransferBadge {masterKey = mk, payment = SPApple {jws = "a.b.c"}} `shouldBe` typeOnly "transferBadge"
 
 testGoogleProductIdPath :: IO ()
 testGoogleProductIdPath = do

tests/Bots/BadgeService/BotTests.hs

@@ -54,12 +54,12 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Calendar (addDays, fromGregorian, toGregorian)
 import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Data.Word (Word32)
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType (..), generateMasterKey)
 import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode)
-import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, emptyEntry, endOfMondayAfter)
+import Simplex.Chat.Badges.Ledger (addMonths, balanceChecked, creditTypeTag, debitTypeTag, emptyEntry, endOfMondayAfter)
 import Simplex.Chat.Badges.Service
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
 import qualified Simplex.Chat.Badges.Types as BT
@@ -199,12 +199,37 @@ badgeServiceTests = do
       it "should answer other requests while a renewal check is with the store, and the renewal once the store answers" testRenewalHoldsNoOtherRequest
       it "should answer a renewal check while a Play purchase is with the store" testPurchaseHoldsNoRenewal
       it "should answer other requests while an App Store subscription is with the store, and credit it once the store answers" testAppleSubscriptionHoldsNoOtherRequest
+    describe "transfers" $ do
+      it "should move a store subscription to a new key, ending the old key's share, and renew it for the new key" testStoreRebind
+      it "should move a payment again only once the credential of the key it last moved from has expired" testStoreRebindCapped
+      it "should fund the new key from a charge the service never recorded, ending the idle old key at zero months" testStoreRebindNewCharge
+      it "should answer the old key ended with no credential, without asking the store, and its purchase receipt_used" testStoreRebindOldKeyEnded
+      it "should move an App Store subscription only with its latest transaction, writing nothing for an older one" testStoreRebindStaleAppleTransaction
+      it "should credit a transfer of a payment credited nowhere as a first purchase" testTransferUncredited
+      it "should answer a repeated transfer from the record, without asking the store or limiting it" testTransferReplayAnswered
+      it "should refuse a transfer to a key that holds a purchase, without asking the store" testTransferKnownKeyRefused
+    describe "restore" $ do
+      it "should move a subscription to another device on Restore, retire it on the old one, and credit one credited nowhere" testRestoreOnNewDevice
+      it "should move a subscription to another profile on Restore, and refuse a move on before the first key's credential expires, once" testRestoreOnOtherProfile
+      it "should turn a held or receipt_used hand-over into a transfer on Restore" testRestoreAfterUnfinishedPass
+      it "should leave a resume held for one profile unchanged when a Restore on another profile finds it" testRestoreLeavesResumeHold
+      it "should move a subscription back to the device it left once the first key's credential expired" testRestoreMovesBack
+      it "should refuse Restore while a badge is shown, recording nothing, and answer a limited move's next Restore with the limit, holding it again" testRestoreLimitedOnNewDevice
+      it "should leave a tier change held for one profile unchanged when a Restore on another profile finds it" testRestoreLeavesTierChangeHold
+      it "should hold a tier change at once after a move of its subscription was refused transfer_limited" testRefusedMoveKeepsTierChange
+      it "should give a move held for a deleted profile back to the profile whose purchase it funds" testRestoreHeldProfileDeleted
+      it "should take a purchase hand-over held for one profile to the profile that restores it, and credit it there" testRestoreTakesHeldPurchase
   describe "subscriptions" $ do
     it "should credit a subscription's charge from the store's period start, and answer replays from the record" testSubscriptionPurchase
     it "should credit nothing for a subscription with no charge it can grant, retrying as the charge may still come" testSubscriptionPurchaseNotGrantable
     it "should grant each store charge once, and answer a repeat inside the issued month without asking the store" testSubscriptionChargeGrantedOnce
     it "should ask the store only once coverage has ended, and at most once an hour, failed checks included" testSubscriptionStoreChecksBounded
-    it "should record and not grant a revoked, other-tier, offer, unstarted or ended charge" testSubscriptionChargeNotGranted
+    it "should record and not grant a revoked, offer, unstarted or ended charge" testSubscriptionChargeNotGranted
+    it "should grant a store charge of another tier at renewal, on both sides, and back again" testSubscriptionTierChangeAtRenewal
+    it "should grant an App Store upgrade during coverage once the store charges it, answering pending until then and asking at most hourly" testSubscriptionUpgradeNow
+    it "should answer the upgraded tier's month after an upgrade late in the month, and nothing once it ends, though the old tier's month ends later" testSubscriptionUpgradeLateInMonth
+    it "should grant the old tier's renewal from an upgrade's store check, answering the upgrade pending until its own tier is charged" testUpgradeCheckGrantsRenewal
+    it "should refuse an upgrade from another key, of another subscription, of a prepaid purchase or from Play, without asking the store" testUpgradeRequestRefused
     it "should not grant a Play charge whose month from its clipped period start has already run out" testClippedPlayPeriodNotGranted
     it "should answer an unreachable store with the check interval, writing no charge or ledger row" testSubscriptionStoreUnreachable
     it "should renew an App Store subscription by its original id, granting a charge first recorded before its period started" testAppleSubscriptionRenews
@@ -240,6 +265,9 @@ badgeServiceTests = do
     it "should present an adopted Apple transaction at once though the attempt with the one before it failed, and credit it once the subscription's hourly check allows" testAdoptedReceiptNotOverwritten
     it "should resume a retired Apple subscription on the same purchase when its store charges it again" testAppleResubscribeResumes
     it "should resume an Apple subscription retired within its coverage, with the state the service ended it with cleared" testAppleResubscribeResumesWithinCoverage
+    it "should hold an Apple charge of another tier while its badge is shown, grant it through the worker and show it at once, and send nothing for one of the same tier" testAppleTierChangeHandOver
+    it "should keep an Apple tier change held while the store reports the old tier, without failing the renewal, and grant it once the store reports the new one" testAppleTierChangeStoreLags
+    it "should settle an Apple tier change with no change and no request once its window has passed" testAppleTierChangeWindowEnds
     it "should answer an Apple resubscription from the record when it cannot resume, refuse a held one that stops being resumable or that the service does not grant within its hold, and keep one behind another held receipt unfinished" testAppleResubscribeBounded
     it "should ask the App Store about a subscription claim at most once an hour, whoever presents it and as any of its transactions" testApplePurchaseChecksBounded
     it "should ask Play about a subscription token at most once an hour, whoever presents it, credited to another key or not" testPlayPurchaseChecksBounded
@@ -2258,7 +2286,6 @@ testSubscriptionChargeNotGranted ps =
         checkedAt i = addUTCTime (3 * nominalDay + fromIntegral (i :: Int) * 3700) (addMonths 1 firstStart)
         notGranted =
           [ (monthlyCharge monthly firstStart 1) {revoked = True},
-            monthlyCharge "subscr-badge-legend-month-01" firstStart 2,
             (monthlyCharge monthly firstStart 3) {offer = True},
             (monthlyCharge monthly firstStart 4) {periodStart = addUTCTime nominalDay (checkedAt 3), periodEnd = addMonths 1 (addUTCTime nominalDay (checkedAt 3))},
             (monthlyCharge monthly firstStart 5) {periodStart = firstStart, periodEnd = addMonths 1 firstStart},
@@ -2404,6 +2431,712 @@ testSubscriptionRenews ps =
       alice <## "ok"
       waitShownIssued (chatController alice)
 
+testSubscriptionTierChangeAtRenewal :: HasCallStack => TestParams -> IO ()
+testSubscriptionTierChangeAtRenewal ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      firstStart <- addUTCTime (-3600) <$> serviceNow env
+      let monthly plan n = (storeCharge plan (addMonths n firstStart) 1) {chargeRef = "apple.renewal." <> tshow n}
+          tiersOf = map (\(_, ch, m, start, tier, t) -> (ch, m, start, tier, t))
+          renewAs plan n = do
+            rows <- ledgerRows (chatController alice) "badge_ledger"
+            let (requestAt, presentAt) = renewalMoments rows
+            appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ monthly plan n
+            setClockAt bsClock requestAt
+            alice ##> "/_app activate"
+            alice <## "ok"
+            renewed <- waitLedgerRows (chatController alice) (length rows + 2)
+            pure (drop (length rows) renewed, presentAt)
+      appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" firstStart 1
+      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS})
+      inAnyOrder alice [[openPurchase ""], ["1: supporter"]]
+      waitWakeArmed (chatController alice)
+      -- the store charges Legend at the renewal: a new run from its period start, on both sides
+      (upgraded, presentAt) <- renewAs "SUBSCR_BADGE_LEGEND_MONTH_01" 1
+      alice <##. "1: legend"
+      let legendStart = addMonths 1 firstStart
+      tiersOf upgraded `shouldBe` [(1, 1, legendStart, "legend", Just "charge"), (-1, 0, addMonths 1 legendStart, "legend", Just "badge")]
+      balanceChecks (chatController alice) `shouldReturn` replicate 4 (Just True)
+      purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["legend"]
+      purchaseBadgeTypes cc "sx_badge_service_badge_purchases" `shouldReturn` ["legend"]
+      issuedBadgeTypes (chatController alice) `shouldReturn` ["supporter", "legend"]
+      setClockAt bsClock presentAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      waitShownIssued (chatController alice)
+      -- and back to Supporter at the next renewal
+      (downgraded, _) <- renewAs "SUBSCR_BADGE_SUPPORTER_MONTH_01" 2
+      alice <##. "1: supporter"
+      tiersOf downgraded `shouldBe` [(1, 1, addMonths 2 firstStart, "supporter", Just "charge"), (-1, 0, addMonths 3 firstStart, "supporter", Just "badge")]
+      balanceChecks (chatController alice) `shouldReturn` replicate 6 (Just True)
+      purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["supporter"]
+      purchaseBadgeTypes cc "sx_badge_service_badge_purchases" `shouldReturn` ["supporter"]
+    -- an annual Supporter upgraded to Legend in its third month, found only once its year ended, after a month
+    -- issued since the upgrade: the new run starts at that issue, and every row still follows the one before it
+    yearStart <- addUTCTime (-3600) <$> serviceNow env
+    storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-year-01" yearStart 12
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay
+    setClockAt bsClock $ addUTCTime 600 (addMonths 11 yearStart)
+    lastMonth <- assertBalance env purchaseKey (last $ fst $ statementOf purchased)
+    let tip = last $ fst $ statementOf lastMonth
+        upgradedAt = addUTCTime (10 * nominalDay) (addMonths 2 yearStart)
+    storeReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-legend-year-01" upgradedAt 12) {chargeRef = "GPA.legend"}
+    setClockAt bsClock $ addUTCTime (3 * nominalDay) (addMonths 12 yearStart)
+    found <- assertBalance env purchaseKey tip
+    let rows = fst $ statementOf found
+    map entryTag rows `shouldBe` ["charge", "lapse", "badge"]
+    map createdAtOf (take 1 rows) `shouldBe` [createdAtOf tip]
+    map (\StatementEntry {balanceBadgeType} -> balanceBadgeType) rows `shouldBe` [BTLegend, BTLegend, BTLegend]
+    badgeTypeOf found `shouldBe` Just BTLegend
+    now <- serviceNow env
+    map snd (balanceChecked now BTSupporter (Just tip) rows) `shouldBe` [Just True, Just True, Just True]
+
+purchaseBadgeTypes :: ChatController -> String -> IO [Text]
+purchaseBadgeTypes ChatController {chatStore} table =
+  withTransaction chatStore $ \db ->
+    map fromOnly <$> DB.query_ db (fromString $ "SELECT current_badge_type FROM " <> table <> " ORDER BY badge_purchase_id")
+
+issuedBadgeTypes :: ChatController -> IO [Text]
+issuedBadgeTypes ChatController {chatStore} =
+  withTransaction chatStore $ \db -> map fromOnly <$> DB.query_ db "SELECT badge_type FROM badge_issuances ORDER BY period_end"
+
+upgradeCmdWith :: Text -> StatementEntry -> BadgeServiceCommand
+upgradeCmdWith jws lastEntry = BSCUpgradeBadgeSubscription {payment = SPApple {jws}, balance = BadgeBalance {lastEntry}}
+
+testSubscriptionUpgradeNow :: HasCallStack => TestParams -> IO ()
+testSubscriptionUpgradeNow ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS}} -> do
+    firstStart <- addUTCTime (-3600) <$> serviceNow env
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" firstStart 12
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPApple {jws = appleSubscriptionJWS}
+    setClockAt bsClock $ addUTCTime 600 (addMonths 1 firstStart)
+    second <- assertBalance env purchaseKey (last $ fst $ statementOf purchased)
+    setClockAt bsClock $ addUTCTime 600 (addMonths 2 firstStart)
+    third <- assertBalance env purchaseKey (last $ fst $ statementOf second)
+    let tip = last $ fst $ statementOf third
+        upgradedAt = addUTCTime (10 * nominalDay) (addMonths 2 firstStart)
+        upgrade jws = serviceCmd env purchaseKey $ upgradeCmdWith jws tip
+    setClockAt bsClock upgradedAt
+    checks <- subscriptionChecks store
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    -- a transaction of the tier the ledger holds is answered from the record
+    sameTier <- upgrade appleSubscriptionJWS
+    badgeTypeOf sameTier `shouldBe` Just BTSupporter
+    subscriptionChecks store `shouldReturn` checks
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+    -- while the store still reports the Supporter plan, nothing is granted and the Supporter credential is not given
+    refusalOf <$> upgrade appleLegendSubscriptionJWS `shouldReturn` (BSEPaymentPending, Just 3600)
+    subscriptionChecks store `shouldReturn` checks + 1
+    subscriptionCheckedAt cc >>= (`shouldSatisfy` \case [Just t] -> abs (diffUTCTime t upgradedAt) < 60; _ -> False)
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+    -- the store now reports Legend, but the hour since it was asked holds
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_LEGEND_YEAR_01" upgradedAt 12) {chargeRef = "apple.legend"}
+    setClockAt bsClock $ addUTCTime 1800 upgradedAt
+    refusalOf <$> upgrade appleLegendSubscriptionJWS >>= (`shouldSatisfy` \case (BSEPaymentPending, Just s) -> s > 1740 && s <= 1801; _ -> False)
+    subscriptionChecks store `shouldReturn` checks + 1
+    -- past it, the unissued Supporter months are debited and the Legend year starts at the store's period
+    setClockAt bsClock $ addUTCTime 3700 upgradedAt
+    upgraded <- upgrade appleLegendSubscriptionJWS
+    subscriptionChecks store `shouldReturn` checks + 2
+    let rows = fst $ statementOf upgraded
+    map entryTag rows `shouldBe` ["upgrade", "charge", "badge"]
+    map createdAtOf (take 2 rows) `shouldBe` [upgradedAt, upgradedAt]
+    badgeTypeOf upgraded `shouldBe` Just BTLegend
+    now <- serviceNow env
+    map snd (balanceChecked now BTSupporter (Just tip) rows) `shouldBe` [Just True, Just True, Just True]
+    purchaseBadgeTypes cc "sx_badge_service_badge_purchases" `shouldReturn` ["legend"]
+    -- asked again, it is answered from the record with the Legend credential
+    again <- upgrade appleLegendSubscriptionJWS
+    credentialOf again `shouldBe` credentialOf upgraded
+    subscriptionChecks store `shouldReturn` checks + 2
+
+testSubscriptionUpgradeLateInMonth :: HasCallStack => TestParams -> IO ()
+testSubscriptionUpgradeLateInMonth ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS}} -> do
+    let anchor = UTCTime (fromGregorian 2027 1 31) 36000
+        upgradedAt = UTCTime (fromGregorian 2027 2 28) 54000
+        legendEnd = addMonths 1 upgradedAt
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" anchor 12
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    setClockAt bsClock $ addUTCTime 300 anchor
+    purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPApple {jws = appleSubscriptionJWS}
+    setClockAt bsClock $ addUTCTime 600 (addMonths 1 anchor)
+    second <- assertBalance env purchaseKey (last $ fst $ statementOf purchased)
+    -- the Supporter month issued on 28 February runs to 31 March, past the end of the Legend month it is upgraded to
+    nextDue (fst $ statementOf second) `shouldBe` addMonths 2 anchor
+    let tip = last $ fst $ statementOf second
+        upgrade = serviceCmd env purchaseKey $ upgradeCmdWith appleLegendSubscriptionJWS tip
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_LEGEND_MONTH_01" upgradedAt 1) {chargeRef = "apple.legend"}
+    setClockAt bsClock upgradedAt
+    upgraded <- upgrade
+    map entryTag (fst $ statementOf upgraded) `shouldBe` ["upgrade", "charge", "badge"]
+    nextDue (fst $ statementOf upgraded) `shouldBe` legendEnd
+    badgeTypeOf upgraded `shouldBe` Just BTLegend
+    replayed <- upgrade
+    credentialOf replayed `shouldBe` credentialOf upgraded
+    -- the purchase replayed is answered with the newest issuance, though the Supporter month ends later
+    repurchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPApple {jws = appleSubscriptionJWS}
+    badgeTypeOf repurchased `shouldBe` Just BTLegend
+    let legendTip = last $ fst $ statementOf upgraded
+    setClockAt bsClock $ addUTCTime (-3600) legendEnd
+    beforeEnd <- assertBalance env purchaseKey legendTip
+    credentialOf beforeEnd `shouldBe` credentialOf upgraded
+    -- the Legend month has ended and its next charge is not granted: nothing is current, though the Supporter month runs on
+    setClockAt bsClock $ addUTCTime 3600 legendEnd
+    afterEnd <- assertBalance env purchaseKey legendTip
+    credentialOf afterEnd `shouldBe` Nothing
+
+testUpgradeCheckGrantsRenewal :: HasCallStack => TestParams -> IO ()
+testUpgradeCheckGrantsRenewal ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS}} -> do
+    firstStart <- addUTCTime (-3600) <$> serviceNow env
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" firstStart 1
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPApple {jws = appleSubscriptionJWS}
+    let tip = last $ fst $ statementOf purchased
+        renewalStart = addMonths 1 firstStart
+        upgradedAt = addUTCTime 600 renewalStart
+    -- coverage has ended and Apple charged the Supporter renewal, while its status still shows Supporter
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" renewalStart 1) {chargeRef = "apple.renewal"}
+    setClockAt bsClock upgradedAt
+    checks <- subscriptionChecks store
+    refusalOf <$> serviceCmd env purchaseKey (upgradeCmdWith appleLegendSubscriptionJWS tip) `shouldReturn` (BSEPaymentPending, Just 3600)
+    subscriptionChecks store `shouldReturn` checks + 1
+    -- the check granted the renewal, so the hour's requests get its month without asking the store
+    renewed <- assertBalance env purchaseKey tip
+    map entryTag (fst $ statementOf renewed) `shouldBe` ["charge", "badge"]
+    badgeTypeOf renewed `shouldBe` Just BTSupporter
+    subscriptionChecks store `shouldReturn` checks + 1
+    purchaseBadgeTypes cc "sx_badge_service_badge_purchases" `shouldReturn` ["supporter"]
+    -- Apple reports Legend, and past the hour the upgrade grants it
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_LEGEND_MONTH_01" (addUTCTime 1800 upgradedAt) 1) {chargeRef = "apple.legend"}
+    setClockAt bsClock $ addUTCTime 3700 upgradedAt
+    upgraded <- serviceCmd env purchaseKey $ upgradeCmdWith appleLegendSubscriptionJWS $ last $ fst $ statementOf renewed
+    badgeTypeOf upgraded `shouldBe` Just BTLegend
+    subscriptionChecks store `shouldReturn` checks + 2
+    purchaseBadgeTypes cc "sx_badge_service_badge_purchases" `shouldReturn` ["legend"]
+
+testUpgradeRequestRefused :: HasCallStack => TestParams -> IO ()
+testUpgradeRequestRefused ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsIssuerKey, bsVerifier, bsPurchaseChecks, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS, appleSecondSubscriptionJWS, appleSupporterJWS}} -> do
+    now <- serviceNow env
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1
+    (appleKey, appleMasterKey) <- newPurchaseKeys
+    apple <- serviceCmd env appleKey $ purchaseCmd appleMasterKey SPApple {jws = appleSubscriptionJWS}
+    (playKey, _, played) <- subscribedMonthly env
+    (prepaidKey, prepaidMasterKey) <- newPurchaseKeys
+    prepaid <- serviceCmd env prepaidKey $ purchaseCmd prepaidMasterKey SPApple {jws = appleSupporterJWS}
+    (unknownKey, _) <- newPurchaseKeys
+    checks <- subscriptionChecks store
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    let appleTip = last $ fst $ statementOf apple
+        refused key cmd = refusalOf <$> serviceCmd env key cmd
+    -- signed by another key than the purchase it names
+    refusalOf <$> badgeServiceResponse bsIssuerKey bsVerifier bsPurchaseChecks cc Nothing (Just playKey) (requestObject appleKey $ upgradeCmdWith appleLegendSubscriptionJWS appleTip)
+      `shouldReturn` (BSEBadRequest, Nothing)
+    refused unknownKey (upgradeCmdWith appleLegendSubscriptionJWS appleTip) `shouldReturn` (BSEUnknownPurchaseKey, Nothing)
+    -- another purchase's subscription, and another subscription for this purchase
+    refused playKey (upgradeCmdWith appleLegendSubscriptionJWS $ last played) `shouldReturn` (BSEBadRequest, Nothing)
+    refused appleKey (upgradeCmdWith appleSecondSubscriptionJWS appleTip) `shouldReturn` (BSEBadRequest, Nothing)
+    refused prepaidKey (upgradeCmdWith appleLegendSubscriptionJWS $ last $ fst $ statementOf prepaid) `shouldReturn` (BSEBadRequest, Nothing)
+    -- a transaction the verifier does not vouch for, one of no subscription product, and Play
+    refused appleKey (upgradeCmdWith (subscriptionJWS appleSubscriptionOriginalId "2000000812345689" []) appleTip) `shouldReturn` (BSEReceiptInvalid, Nothing)
+    refused appleKey (upgradeCmdWith appleSupporterJWS appleTip) `shouldReturn` (BSEBadRequest, Nothing)
+    refused playKey BSCUpgradeBadgeSubscription {payment = subscriptionPlay, balance = BadgeBalance {lastEntry = last played}} `shouldReturn` (BSEBadRequest, Nothing)
+    subscriptionChecks store `shouldReturn` checks
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+
+transferCmd :: BadgeMasterKey -> ServicePayment -> BadgeServiceCommand
+transferCmd masterKey payment = BSCTransferBadge {masterKey, payment}
+
+transferWithNewKey :: HasCallStack => BadgeServiceEnv -> ServicePayment -> IO (C.PublicKeyEd25519, BadgeServiceResponse)
+transferWithNewKey env payment = do
+  (purchaseKey, masterKey) <- newPurchaseKeys
+  (purchaseKey,) <$> serviceCmd env purchaseKey (transferCmd masterKey payment)
+
+-- | Past the hour a claim's store check holds the next one off.
+nextClaimCheck :: BadgeServiceEnv -> IO ()
+nextClaimCheck BadgeServiceEnv {bsClock} = testClockTime bsClock >>= setClockAt bsClock . addUTCTime 3700
+
+movedOutTo :: StatementEntry -> Maybe C.PublicKeyEd25519
+movedOutTo StatementEntry {entryType = SEDebit (SDTransferOut k)} = Just k
+movedOutTo _ = Nothing
+
+reboundPayments :: ChatController -> IO Int
+reboundPayments cc = rowCount cc "sx_badge_service_payments WHERE rebound_at IS NOT NULL"
+
+testStoreRebind :: HasCallStack => TestParams -> IO ()
+testStoreRebind ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do
+    let changes = map (\e -> let (c, m, _) = entryOf e in (c, m))
+        verified badgeType rows = verifiedAfter badgeType Nothing rows
+        verifiedAfter badgeType tip_ rows = do
+          now <- serviceNow env
+          map snd (balanceChecked now badgeType tip_ rows) `shouldBe` map (const $ Just True) rows
+    (playKey, firstStart, purchased) <- subscribedMonthly env
+    setClockAt bsClock $ addUTCTime (10 * nominalDay) firstStart
+    (movedKey, moved) <- transferWithNewKey env subscriptionPlay
+    let movedRows = fst $ statementOf moved
+    map entryTag movedRows `shouldBe` ["charge", "badge"]
+    map createdAtOf (take 1 movedRows) `shouldBe` [firstStart]
+    subscriptionOf moved `shouldBe` Just SSRenewing
+    credentialOf moved `shouldSatisfy` isJust
+    verified BTSupporter movedRows
+    reboundPayments cc `shouldReturn` 1
+    ended <- assertBalance env playKey (last purchased)
+    map entryTag (fst $ statementOf ended) `shouldBe` ["transferOut"]
+    map movedOutTo (fst $ statementOf ended) `shouldBe` [Just movedKey]
+    verifiedAfter BTSupporter (Just $ last purchased) (fst $ statementOf ended)
+    -- the next charge renews the new key's purchase
+    storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1
+    setClockAt bsClock $ addUTCTime (3 * nominalDay) (addMonths 1 firstStart)
+    renewed <- assertBalance env movedKey (last movedRows)
+    map entryTag (fst $ statementOf renewed) `shouldBe` ["charge", "badge"]
+    credentialOf renewed `shouldSatisfy` isJust
+    -- an annual App Store subscription two months in: the old key's passed month lapses before the rest moves
+    appleStart <- addUTCTime (-3600) <$> serviceNow env
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" appleStart 12) {chargeRef = "2000000812345681"}
+    (appleKey, appleMasterKey) <- newPurchaseKeys
+    applePurchased <- serviceCmd env appleKey $ purchaseCmd appleMasterKey SPApple {jws = appleSubscriptionJWS}
+    setClockAt bsClock $ addUTCTime (10 * nominalDay) (addMonths 2 appleStart)
+    (appleMovedKey, appleMoved) <- transferWithNewKey env SPApple {jws = appleSubscriptionJWS}
+    let appleMovedRows = fst $ statementOf appleMoved
+    map entryTag appleMovedRows `shouldBe` ["charge", "lapse", "badge"]
+    changes appleMovedRows `shouldBe` [(12, 12), (-2, 10), (-1, 9)]
+    verified BTSupporter appleMovedRows
+    appleEnded <- fst . statementOf <$> assertBalance env appleKey (last $ fst $ statementOf applePurchased)
+    map entryTag appleEnded `shouldBe` ["lapse", "transferOut"]
+    changes appleEnded `shouldBe` [(-1, 10), (-10, 0)]
+    map movedOutTo appleEnded `shouldBe` [Nothing, Just appleMovedKey]
+    verifiedAfter BTSupporter (Just $ last $ fst $ statementOf applePurchased) appleEnded
+    reboundPayments cc `shouldReturn` 2
+
+testStoreRebindNewCharge :: HasCallStack => TestParams -> IO ()
+testStoreRebindNewCharge ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do
+    (oldKey, firstStart, purchased) <- subscribedMonthly env
+    let chargeStart = addMonths 2 firstStart
+        changes = map (\e -> let (c, m, _) = entryOf e in (c, m))
+        verifiedAfter tip_ rows = do
+          now <- serviceNow env
+          map snd (balanceChecked now BTSupporter tip_ rows) `shouldBe` map (const $ Just True) rows
+    -- the old key went idle after its first month, and the store has since charged a month the service never recorded
+    storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 2
+    setClockAt bsClock $ addUTCTime (3 * nominalDay) chargeStart
+    (newKey, moved) <- transferWithNewKey env subscriptionPlay
+    let movedRows = fst $ statementOf moved
+    map entryTag movedRows `shouldBe` ["charge", "badge"]
+    map createdAtOf (take 1 movedRows) `shouldBe` [chargeStart]
+    verifiedAfter Nothing movedRows
+    ended <- fst . statementOf <$> assertBalance env oldKey (last purchased)
+    map entryTag ended `shouldBe` ["transferOut"]
+    changes ended `shouldBe` [(0, 0)]
+    verifiedAfter (Just $ last purchased) ended
+    -- asked again in the same period, the new key is granted nothing more
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    again <- assertBalance env newKey (last movedRows)
+    map entryTag (fst $ statementOf again) `shouldBe` []
+    credentialOf again `shouldBe` credentialOf moved
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+
+testStoreRebindCapped :: HasCallStack => TestParams -> IO ()
+testStoreRebindCapped ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsStore = store} -> do
+    (_, firstStart, _) <- subscribedMonthly env
+    let firstExpiry = endOfMondayAfter (addMonths 1 firstStart)
+    nextClaimCheck env
+    (firstMoveKey, firstMove) <- transferWithNewKey env subscriptionPlay
+    credentialOf firstMove `shouldSatisfy` isJust
+    expiryOf firstMove `shouldBe` Just firstExpiry
+    nextClaimCheck env
+    checks <- subscriptionChecks store
+    refusalOf . snd <$> transferWithNewKey env subscriptionPlay `shouldReturn` (BSETransferLimited, Nothing)
+    subscriptionChecks store `shouldReturn` checks + 1
+    -- past the first key's credential the first move's key renews, into a credential that outlives the first
+    storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1
+    setClockAt bsClock $ addUTCTime 3600 firstExpiry
+    renewed <- assertBalance env firstMoveKey (last $ fst $ statementOf firstMove)
+    expiryOf renewed `shouldBe` Just (endOfMondayAfter $ addMonths 2 firstStart)
+    (_, secondMove) <- transferWithNewKey env subscriptionPlay
+    credentialOf secondMove `shouldSatisfy` isJust
+    nextClaimCheck env
+    refusalOf . snd <$> transferWithNewKey env subscriptionPlay `shouldReturn` (BSETransferLimited, Nothing)
+
+testStoreRebindOldKeyEnded :: HasCallStack => TestParams -> IO ()
+testStoreRebindOldKeyEnded ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsStore = store} -> do
+    (purchaseKey, _, purchased) <- subscribedMonthly env
+    nextClaimCheck env
+    (_, moved) <- transferWithNewKey env subscriptionPlay
+    credentialOf moved `shouldSatisfy` isJust
+    checks <- subscriptionChecks store
+    ended <- assertBalance env purchaseKey (last purchased)
+    subscriptionOf ended `shouldBe` Just SSEnded
+    credentialOf ended `shouldBe` Nothing
+    subscriptionChecks store `shouldReturn` checks
+    nextClaimCheck env
+    (_, masterKey) <- newPurchaseKeys
+    refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey subscriptionPlay) `shouldReturn` (BSEReceiptUsed, Nothing)
+
+testStoreRebindStaleAppleTransaction :: HasCallStack => TestParams -> IO ()
+testStoreRebindStaleAppleTransaction ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleRenewalSubscriptionJWS}} -> do
+    now <- serviceNow env
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1) {chargeRef = "2000000812345683"}
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    _ <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPApple {jws = appleSubscriptionJWS}
+    nextClaimCheck env
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    checks <- subscriptionChecks store
+    refusalOf . snd <$> transferWithNewKey env SPApple {jws = appleSubscriptionJWS} `shouldReturn` (BSEPaymentPending, Just 3600)
+    subscriptionChecks store `shouldReturn` checks + 1
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+    rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
+    reboundPayments cc `shouldReturn` 0
+    nextClaimCheck env
+    credentialOf . snd <$> transferWithNewKey env SPApple {jws = appleRenewalSubscriptionJWS} >>= (`shouldSatisfy` isJust)
+    reboundPayments cc `shouldReturn` 1
+
+testTransferUncredited :: HasCallStack => TestParams -> IO ()
+testTransferUncredited ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store} -> do
+    periodStart <- addUTCTime (-3600) <$> serviceNow env
+    storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" periodStart 1
+    (_, transferred) <- transferWithNewKey env subscriptionPlay
+    map entryTag (fst $ statementOf transferred) `shouldBe` ["charge", "badge"]
+    map createdAtOf (take 1 $ fst $ statementOf transferred) `shouldBe` [periodStart]
+    subscriptionOf transferred `shouldBe` Just SSRenewing
+    credentialOf transferred `shouldSatisfy` isJust
+    rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
+    reboundPayments cc `shouldReturn` 0
+
+testTransferReplayAnswered :: HasCallStack => TestParams -> IO ()
+testTransferReplayAnswered ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsStore = store} -> do
+    _ <- subscribedMonthly env
+    nextClaimCheck env
+    (movedKey, movedMasterKey) <- newPurchaseKeys
+    moved <- serviceCmd env movedKey $ transferCmd movedMasterKey subscriptionPlay
+    checks <- subscriptionChecks store
+    replayed <- serviceCmd env movedKey $ transferCmd movedMasterKey subscriptionPlay
+    credentialOf replayed `shouldBe` credentialOf moved
+    credentialOf replayed `shouldSatisfy` isJust
+    subscriptionChecks store `shouldReturn` checks
+
+testTransferKnownKeyRefused :: HasCallStack => TestParams -> IO ()
+testTransferKnownKeyRefused ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store} -> do
+    _ <- subscribedMonthly env
+    (heldKey, heldMasterKey) <- newPurchaseKeys
+    _ <- serviceCmd env heldKey $ purchaseCmd heldMasterKey supporterPlay
+    nextClaimCheck env
+    checks <- subscriptionChecks store
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    refusalOf <$> serviceCmd env heldKey (transferCmd heldMasterKey subscriptionPlay) `shouldReturn` (BSEBadRequest, Nothing)
+    subscriptionChecks store `shouldReturn` checks
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+    rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 2
+    reboundPayments cc `shouldReturn` 0
+
+restoredCmd :: Int64 -> ServicePayment -> String
+restoredCmd userId payment = "/_badge purchase " <> show userId <> " restored " <> paymentArg payment
+
+shownBadges :: ChatController -> IO [(Int64, Maybe Int64)]
+shownBadges ChatController {chatStore} =
+  withTransaction chatStore $ \db -> DB.query_ db "SELECT user_id, shown_badge_id FROM users ORDER BY user_id"
+
+-- | Each purchase's owner, and whether it still links the store record, through which its subscription's transaction is read.
+purchaseReceiptLinks :: ChatController -> IO [(Int64, Bool)]
+purchaseReceiptLinks ChatController {chatStore} =
+  withTransaction chatStore $ \db -> DB.query_ db "SELECT user_id, badge_store_receipt_id IS NOT NULL FROM badge_purchases ORDER BY badge_purchase_id"
+
+ledgerTags :: ChatController -> IO [Maybe Text]
+ledgerTags cc = map (\(_, _, _, _, _, t) -> t) <$> ledgerRows cc "badge_ledger"
+
+restoreToken :: Text -> Text
+restoreToken n = "fake-play-token-restore-" <> n <> ".AO-J1Om8l3biV8pPk4"
+
+storeReceiptHolds :: ChatController -> IO [(Int64, Text)]
+storeReceiptHolds ChatController {chatStore} =
+  withTransaction chatStore $ \db -> DB.query_ db "SELECT user_id, hold_kind FROM badge_store_receipts ORDER BY badge_store_receipt_id"
+
+-- | For clients checked through their databases: what they printed is read and dropped, until a second passes with nothing.
+dropOutput :: TestCC -> IO ()
+dropOutput cc = timeout 1000000 (atomically $ readTQueue $ termQ cc) >>= mapM_ (\_ -> dropOutput cc)
+
+testRestoreOnNewDevice :: HasCallStack => TestParams -> IO ()
+testRestoreOnNewDevice ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
+      withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do
+        firstStart <- addUTCTime (-3600) <$> serviceNow env
+        storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+        alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+        waitShownBadge (chatController alice) (Just 1)
+        aliceRows <- ledgerRows (chatController alice) "badge_ledger"
+        nextClaimCheck env
+        bob `send` restoredCmd 1 subscriptionPlay
+        waitShownBadge (chatController bob) (Just 1)
+        ledgerTags (chatController bob) `shouldReturn` [Just "charge", Just "badge"]
+        reboundPayments cc `shouldReturn` 1
+        -- the old device's badge retires at its next request, which the service answers ended
+        setClockAt bsClock $ fst $ renewalMoments aliceRows
+        alice `send` "/_app activate"
+        waitShownBadge (chatController alice) Nothing
+        withNewTestChatCfg ps bsClientCfg "cath" cathProfile $ \cath -> do
+          creditedNowhere <- addUTCTime (-3600) <$> serviceNow env
+          setSubscription store (SubscriptionGoogle $ restoreToken "1") $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" creditedNowhere 1
+          cath `send` restoredCmd 1 (googlePayment "subscr_badge_supporter_01" $ restoreToken "1")
+          waitShownBadge (chatController cath) (Just 1)
+          ledgerTags (chatController cath) `shouldReturn` [Just "charge", Just "badge"]
+          reboundPayments cc `shouldReturn` 1
+          mapM_ dropOutput [alice, bob, cath]
+
+testRestoreOnOtherProfile :: HasCallStack => TestParams -> IO ()
+testRestoreOnOtherProfile ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      let a = chatController alice
+      firstStart <- addUTCTime (-3600) <$> serviceNow env
+      storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+      alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+      waitShownBadge a (Just 1)
+      aliceRows <- ledgerRows a "badge_ledger"
+      alice `send` "/create user alisa"
+      shownBadges a `shouldEventuallyReturn` [(1, Just 1), (2, Nothing)]
+      nextClaimCheck env
+      alice `send` restoredCmd 2 subscriptionPlay
+      shownBadges a `shouldEventuallyReturn` [(1, Just 1), (2, Just 2)]
+      purchaseReceiptLinks a `shouldReturn` [(1, False), (2, True)]
+      storeReceiptRows a `shouldReturn` [(2, Nothing, True)]
+      -- the move settles the record, so it is not sent as a transfer again
+      storeReceiptHolds a `shouldReturn` [(2, "purchase")]
+      setClockAt bsClock $ fst $ renewalMoments aliceRows
+      alice `send` "/_app activate"
+      shownBadges a `shouldEventuallyReturn` [(1, Nothing), (2, Just 2)]
+      -- before the first key's credential expires, a move on is refused once and not retried, and the record returns to its owner
+      alice `send` "/create user alisa2"
+      shownBadges a `shouldEventuallyReturn` [(1, Nothing), (2, Just 2), (3, Nothing)]
+      purchases <- rowCount cc "sx_badge_service_badge_purchases"
+      alice `send` restoredCmd 3 subscriptionPlay
+      storeReceiptCreditErrors a `shouldEventuallyReturn` ["service_error final transfer_limited"]
+      storeReceiptRows a `shouldReturn` [(2, Nothing, True)]
+      heldStoreReceipts a `shouldReturn` 0
+      setClockAt bsClock $ addUTCTime 7200 (fst $ renewalMoments aliceRows)
+      threadDelay 1000000
+      heldStoreReceipts a `shouldReturn` 0
+      rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` purchases
+      -- a later Restore says why, and holds the record for this profile again; the worker's attempt is refused again
+      let restoreLimited = either show (const "answered without a refusal") <$> sendChatCmdStr a (restoredCmd 3 subscriptionPlay) >>= (`shouldSatisfy` ("TransferLimited" `isInfixOf`))
+      restoreLimited
+      storeReceiptHolds a `shouldEventuallyReturn` [(2, "purchase")]
+      -- within the hour of that attempt's store check the next one waits, so the record stays this profile's move
+      restoreLimited
+      storeReceiptHolds a `shouldEventuallyReturn` [(3, "transfer")]
+      heldStoreReceiptErrors a `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      shownBadges a `shouldReturn` [(1, Nothing), (2, Just 2), (3, Nothing)]
+      dropOutput alice
+
+testRestoreMovesBack :: HasCallStack => TestParams -> IO ()
+testRestoreMovesBack ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
+      withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do
+        firstStart <- addUTCTime (-3600) <$> serviceNow env
+        storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+        alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+        waitShownBadge (chatController alice) (Just 1)
+        (renewalAt, firstExpiry) <- renewalMoments <$> ledgerRows (chatController alice) "badge_ledger"
+        nextClaimCheck env
+        bob `send` restoredCmd 1 subscriptionPlay
+        waitShownBadge (chatController bob) (Just 1)
+        setClockAt bsClock renewalAt
+        alice `send` "/_app activate"
+        waitShownBadge (chatController alice) Nothing
+        -- past the first key's credential, the subscription moves back to the purchase it left, as a new purchase
+        storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1
+        setClockAt bsClock $ addUTCTime 3600 firstExpiry
+        alice `send` restoredCmd 1 subscriptionPlay
+        waitShownBadge (chatController alice) (Just 2)
+        purchaseReceiptLinks (chatController alice) `shouldReturn` [(1, False), (1, True)]
+        storeReceiptHolds (chatController alice) `shouldReturn` [(1, "purchase")]
+        bob `send` "/_app activate"
+        waitShownBadge (chatController bob) Nothing
+        mapM_ dropOutput [alice, bob]
+
+testRestoreLimitedOnNewDevice :: HasCallStack => TestParams -> IO ()
+testRestoreLimitedOnNewDevice ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
+      withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob ->
+        withNewTestChatCfg ps bsClientCfg "cath" cathProfile $ \cath -> do
+          let refusedWith err cc cmd = either show (const "answered without a refusal") <$> sendChatCmdStr cc cmd >>= (`shouldSatisfy` (err `isInfixOf`))
+          firstStart <- addUTCTime (-3600) <$> serviceNow env
+          storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+          alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+          waitShownBadge (chatController alice) (Just 1)
+          nextClaimCheck env
+          bob `send` restoredCmd 1 subscriptionPlay
+          waitShownBadge (chatController bob) (Just 1)
+          -- a Restore on a profile showing a badge is refused, recording nothing
+          refusedWith "BadgeActive" (chatController bob) $ restoredCmd 1 $ googlePayment "subscr_badge_supporter_01" $ restoreToken "3"
+          storeReceiptRows (chatController bob) `shouldReturn` [(1, Nothing, True)]
+          -- before the first key's credential expires a third device's move is refused, and its next Restore says why and holds it again
+          nextClaimCheck env
+          cath `send` restoredCmd 1 subscriptionPlay
+          storeReceiptCreditErrors (chatController cath) `shouldEventuallyReturn` ["service_error final transfer_limited"]
+          heldStoreReceipts (chatController cath) `shouldReturn` 0
+          refusedWith "TransferLimited" (chatController cath) $ restoredCmd 1 subscriptionPlay
+          heldStoreReceiptErrors (chatController cath) `shouldEventuallyReturn` ["service_error retry payment_pending"]
+          storeReceiptHolds (chatController cath) `shouldReturn` [(1, "transfer")]
+          mapM_ dropOutput [alice, bob, cath]
+
+testRestoreLeavesTierChangeHold :: HasCallStack => TestParams -> IO ()
+testRestoreLeavesTierChangeHold ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = FakeStore {appleLegendSubscriptionJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      let a = chatController alice
+          legend = SPApple {jws = appleLegendSubscriptionJWS}
+      appleSupporterBeforeLegend env alice
+      -- the store still reports Supporter, so the tier change stays held
+      alice `send` ("/_badge purchase 1 " <> paymentArg legend)
+      heldStoreReceiptErrors a `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      alice `send` "/create user alisa"
+      shownBadges a `shouldEventuallyReturn` [(1, Just 1), (2, Nothing)]
+      isRight <$> sendChatCmdStr a (restoredCmd 2 legend) `shouldReturn` True
+      storeReceiptHolds a `shouldReturn` [(1, "tier_change")]
+      heldStoreReceipts a `shouldReturn` 1
+      dropOutput alice
+
+testRefusedMoveKeepsTierChange :: HasCallStack => TestParams -> IO ()
+testRefusedMoveKeepsTierChange ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS}, bsClientCfg} ->
+    withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob ->
+      withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+        let a = chatController alice
+            supporter = SPApple {jws = appleSubscriptionJWS}
+        appleSupporterBeforeLegend env bob
+        -- the status names the transaction presented as the latest, so it moves
+        appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-5 * nominalDay) legendBoughtAt) 1) {chargeRef = "2000000812345681"}
+        alice `send` restoredCmd 1 supporter
+        waitShownBadge a (Just 1)
+        alice `send` "/create user alisa"
+        shownBadges a `shouldEventuallyReturn` [(1, Just 1), (2, Nothing)]
+        nextClaimCheck env
+        alice `send` restoredCmd 2 supporter
+        storeReceiptCreditErrors a `shouldEventuallyReturn` ["service_error final transfer_limited"]
+        storeReceiptHolds a `shouldReturn` [(1, "purchase")]
+        -- the refused move is not the purchase's own refused change, so a tier change of it is held at once
+        isRight <$> sendChatCmdStr a "/user alice" `shouldReturn` True
+        either show (const "answered") <$> sendChatCmdStr a ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) `shouldReturn` "answered"
+        storeReceiptHolds a `shouldReturn` [(1, "tier_change")]
+        heldStoreReceipts a `shouldReturn` 1
+        mapM_ dropOutput [alice, bob]
+
+testRestoreHeldProfileDeleted :: HasCallStack => TestParams -> IO ()
+testRestoreHeldProfileDeleted ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      let a = chatController alice
+      firstStart <- addUTCTime (-3600) <$> serviceNow env
+      storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+      alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+      waitShownBadge a (Just 1)
+      alice `send` "/create user alisa"
+      shownBadges a `shouldEventuallyReturn` [(1, Just 1), (2, Nothing)]
+      -- within the hour of the purchase's store check the move waits, held for the second profile
+      alice `send` restoredCmd 2 subscriptionPlay
+      heldStoreReceiptErrors a `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      storeReceiptHolds a `shouldReturn` [(2, "transfer")]
+      isRight <$> sendChatCmdStr a "/user alice" `shouldReturn` True
+      isRight <$> sendChatCmdStr a "/_delete user 2 del_smp=off" `shouldReturn` True
+      storeReceiptHolds a `shouldReturn` [(1, "purchase")]
+      -- the move's failures are not the owner's refused resume or tier change
+      storeReceiptCreditErrors a `shouldReturn` []
+      heldStoreReceipts a `shouldReturn` 0
+      purchaseReceiptLinks a `shouldReturn` [(1, True)]
+      -- handed over again, it is answered from the record
+      isRight <$> sendChatCmdStr a ("/_badge purchase 1 " <> paymentArg subscriptionPlay) `shouldReturn` True
+      heldStoreReceipts a `shouldReturn` 0
+      dropOutput alice
+
+testRestoreTakesHeldPurchase :: HasCallStack => TestParams -> IO ()
+testRestoreTakesHeldPurchase ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob ->
+      withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+        let a = chatController alice
+        firstStart <- addUTCTime (-3600) <$> serviceNow env
+        storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+        bob `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+        waitShownBadge (chatController bob) (Just 1)
+        -- a hand-over on profile 1 within the hour of the purchase's store check is held
+        alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+        heldStoreReceiptErrors a `shouldEventuallyReturn` ["service_error retry payment_pending"]
+        storeReceiptHolds a `shouldReturn` [(1, "purchase")]
+        alice `send` "/create user alisa"
+        shownBadges a `shouldEventuallyReturn` [(1, Nothing), (2, Nothing)]
+        isRight <$> sendChatCmdStr a (restoredCmd 2 subscriptionPlay) `shouldReturn` True
+        storeReceiptHolds a `shouldReturn` [(2, "transfer")]
+        nextClaimCheck env
+        isRight <$> sendChatCmdStr a (restoredCmd 2 subscriptionPlay) `shouldReturn` True
+        shownBadges a `shouldEventuallyReturn` [(1, Nothing), (2, Just 1)]
+        purchaseReceiptLinks a `shouldReturn` [(2, True)]
+        mapM_ dropOutput [alice, bob]
+
+testRestoreLeavesResumeHold :: HasCallStack => TestParams -> IO ()
+testRestoreLeavesResumeHold ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "dan" danProfile $ \dan -> do
+      requestAt <- appleSubscriptionRetired env dan
+      let resubscribedAt = addUTCTime 7200 requestAt
+          resubscription = SPApple {jws = appleTransactionDated "2000000812345695" resubscribedAt (addMonths 1 resubscribedAt)}
+      setClockAt bsClock resubscribedAt
+      appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" resubscribedAt 1) {chargeRef = "apple.revoked", revoked = True}
+      dan `send` ("/_badge purchase 1 " <> paymentArg resubscription)
+      heldStoreReceiptErrors (chatController dan) `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      dan `send` "/create user daniel"
+      shownBadges (chatController dan) `shouldEventuallyReturn` [(1, Nothing), (2, Nothing)]
+      isRight <$> sendChatCmdStr (chatController dan) (restoredCmd 2 resubscription) `shouldReturn` True
+      storeReceiptHolds (chatController dan) `shouldReturn` [(1, "purchase")]
+      heldStoreReceipts (chatController dan) `shouldReturn` 1
+      dropOutput dan
+
+testRestoreAfterUnfinishedPass :: HasCallStack => TestParams -> IO ()
+testRestoreAfterUnfinishedPass ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
+      withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob ->
+        withNewTestChatCfg ps bsClientCfg "cath" cathProfile $ \cath -> do
+          firstStart <- addUTCTime (-3600) <$> serviceNow env
+          let other = googlePayment "subscr_badge_supporter_01" $ restoreToken "2"
+          storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+          setSubscription store (SubscriptionGoogle $ restoreToken "2") $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+          alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+          waitShownBadge (chatController alice) (Just 1)
+          -- a sweep's hand-over, held while the claim's hour holds the store check off, becomes a transfer on Restore
+          bob `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay)
+          heldStoreReceiptErrors (chatController bob) `shouldEventuallyReturn` ["service_error retry payment_pending"]
+          nextClaimCheck env
+          bob `send` restoredCmd 1 subscriptionPlay
+          waitShownBadge (chatController bob) (Just 1)
+          heldStoreReceipts (chatController bob) `shouldReturn` 0
+          -- a hand-over refused receipt_used is held again as a transfer
+          alice `send` "/create user alisa"
+          shownBadges (chatController alice) `shouldEventuallyReturn` [(1, Just 1), (2, Nothing)]
+          alice `send` ("/_badge purchase 2 " <> paymentArg other)
+          shownBadges (chatController alice) `shouldEventuallyReturn` [(1, Just 1), (2, Just 2)]
+          nextClaimCheck env
+          cath `send` ("/_badge purchase 1 " <> paymentArg other)
+          storeReceiptCreditErrors (chatController cath) `shouldEventuallyReturn` ["service_error final receipt_used"]
+          nextClaimCheck env
+          cath `send` restoredCmd 1 other
+          waitShownBadge (chatController cath) (Just 1)
+          storeReceiptCreditErrors (chatController cath) `shouldReturn` []
+          mapM_ dropOutput [alice, bob, cath]
+
 testSubscriptionAwaitsCharge :: HasCallStack => TestParams -> IO ()
 testSubscriptionAwaitsCharge ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} ->
@@ -3312,14 +4045,14 @@ testAppleResubscribeBounded ps =
             heldStoreReceipts (chatController alice) `shouldReturn` 0
       -- a charge whose paid period has ended
       answeredFromRecord $ appleTransactionDated "2000000812345692" (addUTCTime (-40 * nominalDay) requestAt) (addUTCTime (-10 * nominalDay) requestAt)
-      -- the store charges another tier, which the service does not grant
+      -- the store reports a revoked charge, which the service does not grant
       let resubscribedAt = addUTCTime 7200 requestAt
           handOverHeld jws = do
             handOver jws
             expectLinesWithin 30 alice ["1: supporter", "badge alert: subscription_ended ", openPurchase ""] ["subscribed "]
             heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"]
       setClockAt bsClock resubscribedAt
-      appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_LEGEND_MONTH_01" resubscribedAt 1) {chargeRef = "apple.legend"}
+      appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" resubscribedAt 1) {chargeRef = "apple.revoked", revoked = True}
       -- a charge whose paid period ends while it is held is refused before it is sent again
       handOverHeld $ appleTransactionDated "2000000812345695" resubscribedAt (addUTCTime 7200 resubscribedAt)
       checks <- subscriptionChecks store
@@ -3331,15 +4064,15 @@ testAppleResubscribeBounded ps =
       subscriptionChecks store `shouldReturn` checks
       shownBadgeId (chatController alice) `shouldReturn` Nothing
       -- a later charge is held again though a resume was refused, while its own hold, from its purchase date, runs
-      let otherTier = appleResubscription "2000000812345693" (addUTCTime 60 resubscribedAt)
-      handOverHeld otherTier
+      let laterCharge = appleResubscription "2000000812345693" (addUTCTime 60 resubscribedAt)
+      handOverHeld laterCharge
       setClockAt bsClock $ addUTCTime (resumeHoldLimit + 120) resubscribedAt
       alice ##> "/_app activate"
       alice <## "ok"
       heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0
       storeReceiptCreditErrors (chatController alice) `shouldReturn` ["service_error final receipt_invalid"]
       shownBadgeId (chatController alice) `shouldReturn` Nothing
-      answeredFromRecord otherTier
+      answeredFromRecord laterCharge
       invoiceId <- createInvoice alice 1
       -- while another receipt of the owner is held, a resubscription is answered held and left unfinished, not held here
       setGoogleDown store True
@@ -3351,6 +4084,96 @@ testAppleResubscribeBounded ps =
       heldLines
       heldStoreReceipts (chatController alice) `shouldReturn` 1
 
+-- | When appleLegendSubscriptionJWS says it was bought, which the client compares with its clock.
+legendBoughtAt :: UTCTime
+legendBoughtAt = posixSecondsToUTCTime 1769904000
+
+-- | A monthly Apple Supporter subscription bought five days before the Legend transaction, shown; the clock an hour into that transaction.
+appleSupporterBeforeLegend :: HasCallStack => BadgeServiceEnv -> TestCC -> IO ()
+appleSupporterBeforeLegend BadgeServiceEnv {bsClock, bsStore = store@FakeStore {appleSubscriptionJWS}} alice = do
+  let firstStart = addUTCTime (-5 * nominalDay) legendBoughtAt
+  setClockAt bsClock $ addUTCTime 3600 firstStart
+  appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" firstStart 1
+  alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS})
+  inAnyOrder alice [[openPurchase ""], ["1: supporter"]]
+  waitWakeArmed (chatController alice)
+  setClockAt bsClock $ addUTCTime 3600 legendBoughtAt
+
+appleReportsLegend :: FakeStore -> IO ()
+appleReportsLegend store = appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_LEGEND_YEAR_01" legendBoughtAt 12) {chargeRef = "apple.legend"}
+
+testAppleTierChangeHandOver :: HasCallStack => TestParams -> IO ()
+testAppleTierChangeHandOver ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleRenewalSubscriptionJWS, appleLegendSubscriptionJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      appleSupporterBeforeLegend env alice
+      let handOver jws = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws})
+      checks <- subscriptionChecks store
+      -- a charge of the tier shown is answered from the record and sends nothing
+      handOver appleRenewalSubscriptionJWS
+      alice <## "badge already redeemed"
+      heldStoreReceipts (chatController alice) `shouldReturn` 0
+      subscriptionChecks store `shouldReturn` checks
+      -- a Legend charge is held, and the worker's request grants it and shows its credential at once
+      appleReportsLegend store
+      handOver appleLegendSubscriptionJWS
+      expectLinesWithin 30 alice ["1: legend"] ["1: supporter", "store purchase open", "subscribed "]
+      heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0
+      subscriptionChecks store `shouldReturn` checks + 1
+      waitShownIssued (chatController alice)
+      issuedBadgeTypes (chatController alice) `shouldReturn` ["supporter", "legend"]
+      purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["legend"]
+      balanceChecks (chatController alice) `shouldReturn` replicate 4 (Just True)
+      issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing)
+      -- handed over again, it is answered from the record
+      handOver appleLegendSubscriptionJWS
+      alice <## "badge already redeemed"
+      subscriptionChecks store `shouldReturn` checks + 1
+
+testAppleTierChangeStoreLags :: HasCallStack => TestParams -> IO ()
+testAppleTierChangeStoreLags ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      appleSupporterBeforeLegend env alice
+      -- the store still reports Supporter: the record stays held, and the purchase records no failed renewal
+      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS})
+      heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      expectLinesWithin 30 alice ["bad chat command: badge service error: payment_pending"] ["1: supporter", "store purchase open", "subscribed "]
+      purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["supporter"]
+      issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing)
+      -- once the store reports Legend and the hour since it was asked has passed, the next attempt grants it
+      appleReportsLegend store
+      setClockAt bsClock $ addUTCTime (2 * 3600 + 120) legendBoughtAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      expectLinesWithin 30 alice ["1: legend"] ["1: supporter", "store purchase open", "subscribed "]
+      heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0
+      purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["legend"]
+
+testAppleTierChangeWindowEnds :: HasCallStack => TestParams -> IO ()
+testAppleTierChangeWindowEnds ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      appleSupporterBeforeLegend env alice
+      let handOver = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS})
+      handOver
+      heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      expectLinesWithin 30 alice ["bad chat command: badge service error: payment_pending"] ["1: supporter", "store purchase open", "subscribed "]
+      -- past the window the record settles with no change and no request, and the renewal check is left to grant it
+      checks <- subscriptionChecks store
+      ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+      appleReportsLegend store
+      setClockAt bsClock $ addUTCTime (nominalDay + 7200) legendBoughtAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0
+      subscriptionChecks store `shouldReturn` checks
+      ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+      purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["supporter"]
+      handOver
+      alice <## "badge already redeemed"
+      heldStoreReceipts (chatController alice) `shouldReturn` 0
+
 -- | A monthly Apple subscription bought an hour into its first period and retired past its coverage, at its request
 -- moment, on the service's answer that it ended: that moment.
 appleSubscriptionRetired :: HasCallStack => BadgeServiceEnv -> TestCC -> IO UTCTime
@@ -4255,7 +5078,7 @@ testStoreChecksConfigured _ = do
 
 testStoreRouting :: HasCallStack => TestParams -> IO ()
 testStoreRouting ps =
-  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleSupporterJWS}} -> do
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS, appleSupporterJWS}} -> do
     let routedAs signer key cmd = requestLane ChecksAfterCoverage cc (Just signer) (requestObject key cmd)
         routed key = routedAs key key
     (purchaseKey, masterKey) <- newPurchaseKeys
@@ -4264,6 +5087,9 @@ testStoreRouting ps =
     purchase subscriptionPlay `shouldReturn` PurchaseLane
     purchase SPApple {jws = appleSubscriptionJWS} `shouldReturn` PurchaseLane
     purchase SPApple {jws = appleSupporterJWS} `shouldReturn` MainLane
+    routed purchaseKey (transferCmd masterKey subscriptionPlay) `shouldReturn` PurchaseLane
+    routed purchaseKey (transferCmd masterKey SPApple {jws = appleSubscriptionJWS}) `shouldReturn` PurchaseLane
+    routed purchaseKey (transferCmd masterKey SPApple {jws = appleSupporterJWS}) `shouldReturn` MainLane
     g <- C.newRandom
     (fromPurchaseKey, fromPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
     now <- getCurrentTime
@@ -4296,8 +5122,25 @@ testStoreRouting ps =
     answeredWithoutStore
     routedAt (addUTCTime 3700 lastCheck) `shouldReturn` RenewalLane
     routedAs purchaseKey subscriberKey issue `shouldReturn` MainLane
+    let upgradeCmd = BSCUpgradeBadgeSubscription {payment = SPApple {jws = appleSubscriptionJWS}, balance = BadgeBalance {lastEntry = last purchased}}
+    routed subscriberKey upgradeCmd `shouldReturn` MainLane
+    routedAs purchaseKey subscriberKey upgradeCmd `shouldReturn` MainLane
+    routed codeKey upgradeCmd `shouldReturn` MainLane
     (unknownKey, _) <- newPurchaseKeys
     routed unknownKey issue `shouldReturn` MainLane
+    routed unknownKey upgradeCmd `shouldReturn` MainLane
+    -- an App Store subscription's upgrade may ask the store once the hour since its last check has passed
+    let boughtAt = addUTCTime 7200 lastCheck
+    setClockAt bsClock boughtAt
+    appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) boughtAt) 1
+    (appleKey, appleMasterKey) <- newPurchaseKeys
+    bought <- serviceCmd env appleKey $ purchaseCmd appleMasterKey SPApple {jws = appleSubscriptionJWS}
+    let appleUpgrade = upgradeCmdWith appleLegendSubscriptionJWS $ last $ fst $ statementOf bought
+        upgradeRoutedAt t = setClockAt bsClock t >> routed appleKey appleUpgrade
+    upgradeRoutedAt (addUTCTime 3530 boughtAt) `shouldReturn` MainLane
+    upgradeRoutedAt (addUTCTime 3550 boughtAt) `shouldReturn` RenewalLane
+    upgradeRoutedAt (addUTCTime 3700 boughtAt) `shouldReturn` RenewalLane
+    routedAs purchaseKey appleKey appleUpgrade `shouldReturn` MainLane
 
 testRenewalHoldsNoOtherRequest :: HasCallStack => TestParams -> IO ()
 testRenewalHoldsNoOtherRequest ps = do

tests/Bots/BadgeService/FakeStore.hs

@@ -64,6 +64,8 @@ data FakeStore = FakeStore
     appleRenewalSubscriptionJWS :: Text,
     appleSandboxSubscriptionJWS :: Text,
     appleRevokedSubscriptionJWS :: Text,
+    -- a transaction of the same subscription after it was changed to annual Legend
+    appleLegendSubscriptionJWS :: Text,
     -- two other subscriptions, the first under appleSecondSubscriptionOriginalId and the second one the store does not know
     appleSecondSubscriptionJWS :: Text,
     appleThirdSubscriptionJWS :: Text,
@@ -87,6 +89,7 @@ newFakeStore = do
       appleRenewalSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345683" [purchasedAt 1769904000000]
       appleSandboxSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345682" [purchasedAt 1767225600000]
       appleRevokedSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345684" [purchasedAt 1769904000000, "revocationDate" J..= (1770000000000 :: Int64)]
+      appleLegendSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345688" [purchasedAt 1769904000000, "productId" J..= ("SUBSCR_BADGE_LEGEND_YEAR_01" :: Text)]
       appleSecondSubscriptionJWS = subscriptionJWS appleSecondSubscriptionOriginalId "2000000812345701" [purchasedAt 1767225600000]
       appleThirdSubscriptionJWS = subscriptionJWS "2000000812345710" "2000000812345711" [purchasedAt 1767225600000]
   pendingSettled <- newIORef False
@@ -104,6 +107,7 @@ newFakeStore = do
           (appleSubscriptionJWS, appleSubscription appleSubscriptionJWS False),
           (appleRenewalSubscriptionJWS, appleSubscription appleRenewalSubscriptionJWS False),
           (appleSandboxSubscriptionJWS, appleSubscription appleSandboxSubscriptionJWS True),
+          (appleLegendSubscriptionJWS, appleTransaction appleSubscriptionOriginalId "SUBSCR_BADGE_LEGEND_YEAR_01" False 7000),
           (appleSecondSubscriptionJWS, appleSubscription appleSecondSubscriptionJWS False),
           (appleThirdSubscriptionJWS, appleSubscription appleThirdSubscriptionJWS False)
         ]
@@ -129,6 +133,7 @@ newFakeStore = do
         appleRenewalSubscriptionJWS,
         appleSandboxSubscriptionJWS,
         appleRevokedSubscriptionJWS,
+        appleLegendSubscriptionJWS,
         appleSecondSubscriptionJWS,
         appleThirdSubscriptionJWS,
         pendingSettled,

tests/Bots/BadgeService/WebTests.hs

@@ -14,7 +14,7 @@ import BadgeService.Poller
 import BadgeService.Providers
 import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages)
 import BadgeService.Providers.Stripe (stripeProvider)
-import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), NewStorePurchase (..), RevokeResult (..), appendLedgerPlan, createCodePurchase, createStorePurchase, getCodePurchaseForKey, getLedgerEntries, getLedgerTip, getManagedGroup, insertBadgeCode, insertManagedGroup, insertSubscriptionCharge, markOwnerBootstrapped, revokeCode)
+import BadgeService.Store (CreditedPurchase (..), FundingCredit (..), KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), NewStorePurchase (..), PaymentRebind (..), PurchaseSubscription (..), RevokeResult (..), appendLedgerPlan, createCodePurchase, createStorePurchase, getCodePurchaseForKey, getLedgerEntries, getLedgerTip, getManagedGroup, getMovedFromExpiry, getPurchaseByKey, getPurchaseSubscription, getStorePaymentCredit, insertBadgeCode, insertManagedGroup, insertSubscriptionCharge, markOwnerBootstrapped, rebindStorePayment, revokeCode)
 import BadgeService.StoreReceipts (StoreCharge (..))
 import BadgeService.Store.Invoices
 import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount)
@@ -41,6 +41,7 @@ import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (toLower)
 import Data.Either (isLeft)
+import Data.Functor ((<&>))
 import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
 import Data.Int (Int64)
 import Data.List (isInfixOf, sort, sortOn)
@@ -60,8 +61,8 @@ import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType)
 import Network.HTTP.Types.Status (statusCode)
 import qualified Network.Wai.Handler.Warp as Warp
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeType (..))
-import Simplex.Chat.Badges.Ledger (addMonths, emptyEntry, grantEntry)
-import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..), StatementCreditType (..), SubscriptionState (..))
+import Simplex.Chat.Badges.Ledger (addMonths, debitEntry, emptyEntry, grantEntry, issueEntry)
+import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..), StatementCreditType (..), StatementDebitType (..), StatementEntry (..), SubscriptionState (..))
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..))
 import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction)
@@ -159,6 +160,11 @@ badgeWebTests = do
     it "a multi-use code can be revoked while it has uses left, and not once they are gone" testRevokeMultiUseCode
     it "every timestamp round-trips to the second" testTimestampRoundTrip
     it "stores a charge credit with its charge, and reads it back at the tip and in the statement" testChargeCreditRoundTrip
+    it "stores transfers and an upgrade with the purchase each names, and reads them back at the tip and in the statement" testTransferEntriesRoundTrip
+    it "refuses a ledger row naming a purchase key with no purchase, writing nothing" testUnknownPurchaseKeyRefused
+    it "moves a store payment to a new key, ending the old purchase's share with a transferOut naming it" testPaymentRebind
+    it "moves nothing when the old purchase's ledger or the payment's binding moved since they were read" testPaymentRebindLostRace
+    it "reads the latest credential expiry of the purchase a payment last moved from" testMovedFromExpiry
   describe "managed group" $ do
     it "round-trips and bootstraps once" testManagedGroupRoundTripsAndBootstrapsOnce
     it "refuses a second row and burns the flag per group" testManagedGroupIsSingleRow
@@ -328,9 +334,9 @@ assertSubscriptionColumns :: HasCallStack => DBStore -> IO ()
 assertSubscriptionColumns st = do
   columnsOf st "sx_badge_service_subscription_charges"
     >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["charge_id", "payment_id", "provider_charge_ref", "plan_id", "period_start", "period_end", "amount", "currency", "created_at"])
-  columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldSatisfy` elem "charge_id")
+  columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["charge_id", "from_purchase_id", "to_purchase_id"])
   payments <- columnsOf st "sx_badge_service_payments"
-  payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token"]
+  payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token", "rebound_at"]
   payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"])
 
 testGroupOpsColumns :: IO ()
@@ -368,10 +374,10 @@ testSubscriptionsDownUp = withServiceStore $ \st -> do
   length subscriptions `shouldBe` 1
   runMigrations st $ MTRDown (mapMaybe toDownMigration subscriptions)
   columnsOf st "sx_badge_service_subscription_charges" `shouldReturn` []
-  columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldNotSatisfy` elem "charge_id")
+  columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldNotSatisfy` \cs -> any (`elem` cs) ["charge_id", "from_purchase_id", "to_purchase_id"])
   payments <- columnsOf st "sx_badge_service_payments"
   payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"]
-  payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token"])
+  payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token", "rebound_at"])
   runMigrations st $ MTRUp subscriptions
   assertSubscriptionColumns st
 
@@ -733,11 +739,136 @@ testChargeCreditRoundTrip = withServiceStore $ \st -> do
     createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
   withTransaction st $ \db ->
     insertSubscriptionCharge db "pay1" "ch1" StoreCharge {chargeRef = "2000000812345672", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = now, periodEnd = addMonths 1 now, chargePaid = Nothing, revoked = False, offer = False} now
-  let charge = grantEntry now "e1" 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
+  let charge = grantEntry now "e1" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
   withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [charge] Nothing
   withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just [J.toJSON charge]) . fmap (map J.toJSON)
   withTransaction st (`getLedgerTip` purchaseId) >>= (`shouldBe` Just (J.toJSON charge)) . fmap J.toJSON
 
+testTransferEntriesRoundTrip :: IO ()
+testTransferEntriesRoundTrip = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  (purchaseKey, masterKey) <- newPurchaseKeys
+  (otherKey, otherMasterKey) <- newPurchaseKeys
+  Just purchaseId <- withTransaction st $ \db ->
+    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
+  Just _ <- withTransaction st $ \db ->
+    createStorePurchase db NewStorePurchase {paymentId = "pay2", provider = PPApple, providerRef = "2000000812345673", paid = Nothing, purchaseKey = otherKey, masterKey = otherMasterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
+  let transferIn = grantEntry now "e1" BTSupporter 2 (SCTransferIn otherKey) (emptyEntry now BTSupporter)
+      upgrade = debitEntry now "e2" (SDUpgrade purchaseKey) transferIn
+      transferOut = debitEntry now "e3" (SDTransferOut otherKey) upgrade
+      rows = [transferIn, upgrade, transferOut]
+  withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing rows Nothing
+  withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just (map J.toJSON rows)) . fmap (map J.toJSON)
+  withTransaction st (`getLedgerTip` purchaseId) >>= (`shouldBe` Just (J.toJSON transferOut)) . fmap J.toJSON
+
+testUnknownPurchaseKeyRefused :: IO ()
+testUnknownPurchaseKeyRefused = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  (purchaseKey, masterKey) <- newPurchaseKeys
+  (unknownKey, _) <- newPurchaseKeys
+  Just purchaseId <- withTransaction st $ \db ->
+    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Nothing, providerToken = Nothing} now
+  let granted = grantEntry now "e1" BTSupporter 2 SCCode (emptyEntry now BTSupporter)
+  withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [granted] Nothing
+  let upgraded = debitEntry now "e2" (SDUpgrade purchaseKey) granted
+  refused <- E.try $ withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [upgraded, debitEntry now "e3" (SDTransferOut unknownKey) upgraded] Nothing
+  (refused :: Either E.SomeException ()) `shouldSatisfy` isLeft
+  withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just [J.toJSON granted]) . fmap (map J.toJSON)
+
+testPaymentRebind :: IO ()
+testPaymentRebind = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  (k2, mk2) <- newPurchaseKeys
+  (p1, k1Rows@[_, issued1]) <- chargedStorePurchase st now
+  reboundAt st "pay1" `shouldReturn` [Nothing]
+  let transferOut = debitEntry now "e3" (SDTransferOut k2) issued1
+      charge2 = grantEntry now "e4" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
+  Just issued2 <- pure $ issueEntry now "e5" charge2
+  Just p2 <- withTransaction st $ \db -> do
+    p2_ <- rebindStorePayment db PaymentRebind {paymentId = "pay1", fromPurchaseId = p1, fromTipId = "e2", fromRows = [transferOut], purchaseKey = k2, masterKey = mk2, badgeType = BTSupporter} now
+    forM_ p2_ $ \p2 -> appendLedgerPlan db p2 Nothing [charge2] (Just (charge2, issued2, seededCredential mk2 (balanceStartTs issued2)))
+    pure p2_
+  withTransaction st (`getLedgerTip` p1) >>= (`shouldBe` Just (J.toJSON transferOut)) . fmap J.toJSON
+  withTransaction st (\db -> getLedgerEntries db p1 0) >>= (`shouldBe` Just (map J.toJSON (k1Rows <> [transferOut]))) . fmap (map J.toJSON)
+  withTransaction st (\db -> getLedgerEntries db p2 0) >>= (`shouldBe` Just (map J.toJSON [charge2, issued2])) . fmap (map J.toJSON)
+  subscriptionPayment st p1 `shouldReturn` Nothing
+  subscriptionPayment st p2 `shouldReturn` Just "pay1"
+  creditedPurchaseId st `shouldReturn` Just p2
+  reboundAt st "pay1" `shouldReturn` [Just now]
+
+testPaymentRebindLostRace :: IO ()
+testPaymentRebindLostRace = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  (k2, mk2) <- newPurchaseKeys
+  (k3, mk3) <- newPurchaseKeys
+  (p1, k1Rows@[charge1, issued1]) <- chargedStorePurchase st now
+  let rebindTo (k, mk) fromTipId tip = PaymentRebind {paymentId = "pay1", fromPurchaseId = p1, fromTipId, fromRows = [debitEntry now "x" (SDTransferOut k) tip], purchaseKey = k, masterKey = mk, badgeType = BTSupporter}
+      k1Entries = withTransaction st (\db -> getLedgerEntries db p1 0) <&> fmap (map J.toJSON)
+  withTransaction st (\db -> rebindStorePayment db (rebindTo (k3, mk3) "e1" charge1) now) `shouldReturn` Nothing
+  k1Entries `shouldReturn` Just (map J.toJSON k1Rows)
+  creditedPurchaseId st `shouldReturn` Just p1
+  reboundAt st "pay1" `shouldReturn` [Nothing]
+  let transferOut = debitEntry now "x" (SDTransferOut k2) issued1
+  Just _ <- withTransaction st $ \db -> rebindStorePayment db (rebindTo (k2, mk2) "e2" issued1) now
+  withTransaction st (\db -> rebindStorePayment db (rebindTo (k3, mk3) "x" transferOut) (addUTCTime 60 now)) `shouldReturn` Nothing
+  k1Entries `shouldReturn` Just (map J.toJSON (k1Rows <> [transferOut]))
+  reboundAt st "pay1" `shouldReturn` [Just now]
+  isNothing <$> withTransaction st (`getPurchaseByKey` k3) `shouldReturn` True
+
+testMovedFromExpiry :: IO ()
+testMovedFromExpiry = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  [(k0, mk0), (k1, mk1), (k2, mk2)] <- replicateM 3 newPurchaseKeys
+  let day n = addUTCTime (n * 86400) now
+      granted uuid = grantEntry now uuid BTSupporter 1 SCCode (emptyEntry now BTSupporter)
+      movedFromExpiry = withTransaction st (`getMovedFromExpiry` "pay1")
+      move fromPurchaseId fromTipId (k, mk) tipId =
+        withTransaction st $ \db -> do
+          Just purchaseId <- rebindStorePayment db PaymentRebind {paymentId = "pay1", fromPurchaseId, fromTipId, fromRows = [debitEntry now (fromTipId <> "-out") (SDTransferOut k) (granted fromTipId)], purchaseKey = k, masterKey = mk, badgeType = BTSupporter} now
+          appendLedgerPlan db purchaseId Nothing [granted tipId] Nothing
+          pure purchaseId
+  Just p0 <- withTransaction st $ \db ->
+    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey = k0, masterKey = mk0, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
+  withTransaction st $ \db -> appendLedgerPlan db p0 Nothing [granted "g0"] Nothing
+  seedIssuance st p0 "i0a" mk0 now (day 10)
+  seedIssuance st p0 "i0b" mk0 now (day 20)
+  movedFromExpiry `shouldReturn` Nothing
+  p1 <- move p0 "g0" (k1, mk1) "g1"
+  seedIssuance st p1 "i1b" mk1 now (day 40)
+  seedIssuance st p1 "i1a" mk1 now (day 30)
+  movedFromExpiry `shouldReturn` Just (day 20)
+  p2 <- move p1 "g1" (k2, mk2) "g2"
+  seedIssuance st p2 "i2a" mk2 now (day 50)
+  seedIssuance st p2 "i2b" mk2 now (day 60)
+  movedFromExpiry `shouldReturn` Just (day 40)
+
+-- A purchase holding payment pay1 (provider ref 2000000812345671), funded by charge ch1, with its month issued as e2.
+chargedStorePurchase :: DBStore -> UTCTime -> IO (Int64, [StatementEntry])
+chargedStorePurchase st now = do
+  (purchaseKey, masterKey) <- newPurchaseKeys
+  Just purchaseId <- withTransaction st $ \db ->
+    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
+  withTransaction st $ \db ->
+    insertSubscriptionCharge db "pay1" "ch1" StoreCharge {chargeRef = "2000000812345672", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = now, periodEnd = addMonths 1 now, chargePaid = Nothing, revoked = False, offer = False} now
+  let charge = grantEntry now "e1" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
+  Just issued <- pure $ issueEntry now "e2" charge
+  withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [charge] (Just (charge, issued, seededCredential masterKey (balanceStartTs issued)))
+  pure (purchaseId, [charge, issued])
+
+reboundAt :: DBStore -> Text -> IO [Maybe UTCTime]
+reboundAt st paymentId =
+  withConnection st $ \db -> map fromOnly <$> DB.query db "SELECT rebound_at FROM sx_badge_service_payments WHERE payment_id = ?" (Only paymentId)
+
+subscriptionPayment :: DBStore -> Int64 -> IO (Maybe Text)
+subscriptionPayment st purchaseId =
+  fmap (\PurchaseSubscription {paymentId} -> paymentId) <$> withTransaction st (`getPurchaseSubscription` purchaseId)
+
+creditedPurchaseId :: DBStore -> IO (Maybe Int64)
+creditedPurchaseId st =
+  withTransaction st (\db -> getStorePaymentCredit db PPApple "2000000812345671") <&> \case
+    Credited CreditedPurchase {badgePurchaseId} -> Just badgePurchaseId
+    _ -> Nothing
+
 testManagedGroupRoundTripsAndBootstrapsOnce :: IO ()
 testManagedGroupRoundTripsAndBootstrapsOnce = withServiceStore $ \st -> do
   now <- truncateToSecond <$> getCurrentTime