From 1bbbad99cb7cf66cd925cf6a2d1a41d58c9dc6ff Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Wed, 21 Oct 2026 16:53:15 +0000 Subject: [PATCH] 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 | 26 +- apps/ios/Shared/Model/SimpleXAPI.swift | 5 +- apps/ios/Shared/Views/Badges/BadgeStore.swift | 42 +- apps/ios/SimpleXChat/APITypes.swift | 4 + apps/ios/product/gaps.md | 6 +- .../chat/simplex/common/model/SimpleXAPI.kt | 29 +- .../simplex/common/views/badges/BadgeStore.kt | 30 +- .../moko-resources/base/strings.xml | 1 + apps/multiplatform/product/gaps.md | 9 +- .../src/BadgeService/Catalog.hs | 15 - .../src/BadgeService/Service.hs | 214 ++++- .../src/BadgeService/Store.hs | 135 ++- .../BadgeService/Store/Postgres/Migrations.hs | 22 +- .../BadgeService/Store/SQLite/Migrations.hs | 22 +- .../src/BadgeService/StoreReceipts/Google.hs | 2 +- .../src/BadgeService/StoreReceipts/Mock.hs | 3 +- docs/protocol/badges-overview.md | 2 +- docs/protocol/badges-rpc.md | 12 +- docs/protocol/badges-rpc.schema.json | 21 +- plans/2026-10-20-badge-ledger-transitions.md | 4 +- simplex-chat.cabal | 1 + src/Simplex/Chat/Badges/Ledger.hs | 94 +- src/Simplex/Chat/Badges/Service.hs | 7 +- src/Simplex/Chat/Badges/StorePlan.hs | 21 + src/Simplex/Chat/Badges/Types.hs | 6 +- src/Simplex/Chat/Library/Commands.hs | 135 ++- src/Simplex/Chat/PaymentService.hs | 4 +- src/Simplex/Chat/Store/Badges.hs | 166 +++- .../Migrations/M20260915_user_badges.hs | 14 +- .../M20261017_badge_subscriptions.hs | 4 + src/Simplex/Chat/Store/Profiles.hs | 13 +- .../Migrations/M20260915_user_badges.hs | 14 +- .../M20261017_badge_subscriptions.hs | 4 + .../SQLite/Migrations/chat_query_plans.txt | 5 +- .../Store/SQLite/Migrations/chat_schema.sql | 1 + tests/BadgeTests.hs | 149 ++- tests/Bots/BadgeService/BotTests.hs | 863 +++++++++++++++++- tests/Bots/BadgeService/FakeStore.hs | 5 + tests/Bots/BadgeService/WebTests.hs | 147 ++- 39 files changed, 1937 insertions(+), 320 deletions(-) create mode 100644 src/Simplex/Chat/Badges/StorePlan.hs diff --git a/apps/ios/Shared/Model/AppAPITypes.swift b/apps/ios/Shared/Model/AppAPITypes.swift index f49164639c..30fa5c67b5 100644 --- a/apps/ios/Shared/Model/AppAPITypes.swift +++ b/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? diff --git a/apps/ios/Shared/Model/SimpleXAPI.swift b/apps/ios/Shared/Model/SimpleXAPI.swift index f624d42ed4..909f56a320 100644 --- a/apps/ios/Shared/Model/SimpleXAPI.swift +++ b/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) diff --git a/apps/ios/Shared/Views/Badges/BadgeStore.swift b/apps/ios/Shared/Views/Badges/BadgeStore.swift index 8ac8d2ee73..816897dd82 100644 --- a/apps/ios/Shared/Views/Badges/BadgeStore.swift +++ b/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) 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, listed: Bool) async throws { + private func reconcile(_ verification: VerificationResult, 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 = [] + 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) -> 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 } diff --git a/apps/ios/SimpleXChat/APITypes.swift b/apps/ios/SimpleXChat/APITypes.swift index b25ec5ef97..2385a1e816 100644 --- a/apps/ios/SimpleXChat/APITypes.swift +++ b/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") diff --git a/apps/ios/product/gaps.md b/apps/ios/product/gaps.md index 2858f29e96..8968103b1e 100644 --- a/apps/ios/product/gaps.md +++ b/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. --- diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt index 239576cb18..389d74c682 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt +++ b/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 { "receipt_invalid" -> BadgeServiceErrorCode.ReceiptInvalid "receipt_used" -> BadgeServiceErrorCode.ReceiptUsed "test_purchase" -> BadgeServiceErrorCode.TestPurchase + "transfer_limited" -> BadgeServiceErrorCode.TransferLimited "internal" -> BadgeServiceErrorCode.Internal else -> BadgeServiceErrorCode.Unknown(v) } diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt index 842cac454b..2f61b3ece1 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt +++ b/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 } diff --git a/apps/multiplatform/common/src/commonMain/moko-resources/base/strings.xml b/apps/multiplatform/common/src/commonMain/moko-resources/base/strings.xml index 02489a8a7f..cecb6a5bab 100644 --- a/apps/multiplatform/common/src/commonMain/moko-resources/base/strings.xml +++ b/apps/multiplatform/common/src/commonMain/moko-resources/base/strings.xml @@ -3250,6 +3250,7 @@ The badge service reported an internal error. The store did not confirm this purchase. This purchase was already credited to a badge on another device or profile. + This purchase was moved to another device or profile recently. Test purchases are not credited. Badges can only be bought with a real purchase. The payment has not been confirmed yet. The store could not be reached. diff --git a/apps/multiplatform/product/gaps.md b/apps/multiplatform/product/gaps.md index fc7315a458..081214cf89 100644 --- a/apps/multiplatform/product/gaps.md +++ b/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. diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs index 3a2d7e49e8..58fc246399 100644 --- a/apps/simplex-badge-service/src/BadgeService/Catalog.hs +++ b/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 diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 5e7dd67830..35f673ee78 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/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. diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index 5b8680c1d9..76cbbddd8e 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/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, diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs index 53bdd84e96..b2c3b86002 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs +++ b/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; diff --git a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs index 3d5ee32c21..7f8659d60d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs +++ b/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; diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs index 750b807a6d..048e4ac6f1 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs +++ b/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) diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs index 7c857126f3..17638ac19b 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs +++ b/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) diff --git a/docs/protocol/badges-overview.md b/docs/protocol/badges-overview.md index 255f3cd88f..1ae7dc4fa6 100644 --- a/docs/protocol/badges-overview.md +++ b/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. diff --git a/docs/protocol/badges-rpc.md b/docs/protocol/badges-rpc.md index 1763473ced..90a19474db 100644 --- a/docs/protocol/badges-rpc.md +++ b/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. diff --git a/docs/protocol/badges-rpc.schema.json b/docs/protocol/badges-rpc.schema.json index abc2560fa8..bd339d1a35 100644 --- a/docs/protocol/badges-rpc.schema.json +++ b/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"} diff --git a/plans/2026-10-20-badge-ledger-transitions.md b/plans/2026-10-20-badge-ledger-transitions.md index 74820a1864..2698aa3832 100644 --- a/plans/2026-10-20-badge-ledger-transitions.md +++ b/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) diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 136456fe0d..09b6210553 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/src/Simplex/Chat/Badges/Ledger.hs b/src/Simplex/Chat/Badges/Ledger.hs index b707a4c14d..3378c6a8fb 100644 --- a/src/Simplex/Chat/Badges/Ledger.hs +++ b/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 diff --git a/src/Simplex/Chat/Badges/Service.hs b/src/Simplex/Chat/Badges/Service.hs index 70611bd788..a828cfbf6b 100644 --- a/src/Simplex/Chat/Badges/Service.hs +++ b/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 } diff --git a/src/Simplex/Chat/Badges/StorePlan.hs b/src/Simplex/Chat/Badges/StorePlan.hs new file mode 100644 index 0000000000..cc5e3eea92 --- /dev/null +++ b/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 diff --git a/src/Simplex/Chat/Badges/Types.hs b/src/Simplex/Chat/Badges/Types.hs index 18e6e9972f..8d6a1f23e2 100644 --- a/src/Simplex/Chat/Badges/Types.hs +++ b/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 diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 2a9fa7fed8..cc5e6b7e4f 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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), diff --git a/src/Simplex/Chat/PaymentService.hs b/src/Simplex/Chat/PaymentService.hs index 22185e0686..f117183356 100644 --- a/src/Simplex/Chat/PaymentService.hs +++ b/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. diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 997b5e80ff..fba92e86d7 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/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. diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs index 86ecaa8831..d4cf2308d0 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs +++ b/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; diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20261017_badge_subscriptions.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20261017_badge_subscriptions.hs index a97a78d262..199ca481bc 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20261017_badge_subscriptions.hs +++ b/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; diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 3b52c46fef..10248255e3 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/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 () diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs index 185c2fa189..218fbd2410 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs +++ b/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; diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20261017_badge_subscriptions.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20261017_badge_subscriptions.hs index 59e9cb244b..ca548f7331 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20261017_badge_subscriptions.hs +++ b/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; diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index cb1d66352b..f3fcbf72e4 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/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 diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 40c6ff9dbc..81e2475732 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/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( diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index d90edd5c27..6d5cdda74a 100644 --- a/tests/BadgeTests.hs +++ b/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 diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 5305ead4e3..0ad1cc20a9 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/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 diff --git a/tests/Bots/BadgeService/FakeStore.hs b/tests/Bots/BadgeService/FakeStore.hs index 287e9523b1..a8a29bfc57 100644 --- a/tests/Bots/BadgeService/FakeStore.hs +++ b/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, diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index 4c7440a3f0..1a18d53137 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/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