diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index e5b1ac6105..f680c5fe88 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -643,7 +643,7 @@ jobs: shell: bash run: | mkdir -p tests/tmp - sudo mount -t tmpfs -o size=512M tmpfs tests/tmp + sudo mount -t tmpfs -o size=2G tmpfs tests/tmp sudo chown $(id -u):$(id -g) tests/tmp - name: Run tests @@ -1218,7 +1218,7 @@ jobs: if: matrix.should_run == true && matrix.arch == 'aarch64' shell: bash run: | - disk=$(hdiutil attach -nomount ram://1048576 | tr -d '[:space:]') + disk=$(hdiutil attach -nomount ram://4194304 | tr -d '[:space:]') diskutil erasevolume HFS+ tests "$disk" ln -s /Volumes/tests tests/tmp diff --git a/apps/ios/Shared/Model/AppAPITypes.swift b/apps/ios/Shared/Model/AppAPITypes.swift index 2d7855b56b..72cbd5d69b 100644 --- a/apps/ios/Shared/Model/AppAPITypes.swift +++ b/apps/ios/Shared/Model/AppAPITypes.swift @@ -193,7 +193,8 @@ enum ChatCommand: ChatCmdProtocol { case apiStandaloneFileInfo(url: String) // badges case apiRedeemBadgeCode(userId: Int64, code: String) - case apiPurchaseBadge(userId: Int64, echoedInvoiceId: String?, 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) case apiGetBadgeLedger(userId: Int64, badgePurchaseId: Int64) @@ -421,8 +422,9 @@ 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, payment): - return "/_badge purchase \(userId)\(echoedInvoiceId.map { " invoice=\($0)" } ?? "") \(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)" case let .apiGetBadgeLedger(userId, badgePurchaseId): return "/_badge ledger \(userId) \(badgePurchaseId)" @@ -617,6 +619,7 @@ enum ChatCommand: ChatCmdProtocol { case .apiStandaloneFileInfo: return "apiStandaloneFileInfo" case .apiRedeemBadgeCode: return "apiRedeemBadgeCode" case .apiPurchaseBadge: return "apiPurchaseBadge" + case .apiSetBadgeSubscriptionStatus: return "apiSetBadgeSubscriptionStatus" case .apiCreateBadgeInvoice: return "apiCreateBadgeInvoice" case .apiGetBadgeState: return "apiGetBadgeState" case .apiGetBadgeLedger: return "apiGetBadgeLedger" @@ -677,8 +680,10 @@ 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, .apple(jws)): - return .apiPurchaseBadge(userId: userId, echoedInvoiceId: echoedInvoiceId, 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 } } @@ -705,15 +710,25 @@ enum ChatCommand: ChatCmdProtocol { pwd == "" || pwd == nil ? "" : " " + encodeJSON(pwd) } - // /_badge ack takes the kind in core's text encoding, not the JSON tag + // /_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 private func badgeAlertKindParam(_ kind: BadgeAlertKind) -> String { switch kind { case .renewalApproaching: "renewal_approaching" case .paymentIssue: "payment_issue" + case .subscriptionCancelled: "subscription_cancelled" case .subscriptionEnded: "subscription_ended" case .prepaidEnding: "prepaid_ending" case .supportEnded: "support_ended" case .issueFailed: "issue_failed" + case let .unknown(s): s + } + } + + private func storeReceiptOriginParam(_ origin: StoreReceiptOrigin) -> String { + switch origin { + case .purchased: "" + case .listed: " listed" + case .restored: " restored" } } @@ -745,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? @@ -1084,6 +1107,7 @@ enum ChatResponse2: Decodable, ChatAPIResult { // the full user, not UserRef: its profile carries the badge that setUserBadge just stored case badgeRedeemed(user: User, redeemedBadge: LocalBadge, newBadge: Bool, badgeState: BadgeState?) case badgeInvoice(user: UserRef, invoiceId: String) + case storeReceiptNotRecorded(user: UserRef) case badgeState(user: UserRef, badgeState: BadgeState?, storePurchases: [OpenStorePurchase]?) case badgeLedger(user: UserRef, badgeLedger: [StatementEntry]) @@ -1139,6 +1163,7 @@ enum ChatResponse2: Decodable, ChatAPIResult { case .appSettings: "appSettings" case .badgeRedeemed: "badgeRedeemed" case .badgeInvoice: "badgeInvoice" + case .storeReceiptNotRecorded: "storeReceiptNotRecorded" case .badgeState: "badgeState" case .badgeLedger: "badgeLedger" } @@ -1196,6 +1221,7 @@ enum ChatResponse2: Decodable, ChatAPIResult { case let .appSettings(appSettings): return String(describing: appSettings) case let .badgeRedeemed(u, redeemedBadge, newBadge, badgeState): return withUser(u, "redeemedBadge: \(String(describing: redeemedBadge))\nnewBadge: \(newBadge)\nbadgeState: \(String(describing: badgeState))") case let .badgeInvoice(u, invoiceId): return withUser(u, invoiceId) + case let .storeReceiptNotRecorded(u): return withUser(u, "") case let .badgeState(u, badgeState, storePurchases): return withUser(u, "\(String(describing: badgeState))\nstorePurchases: \(String(describing: storePurchases ?? []))") case let .badgeLedger(u, badgeLedger): return withUser(u, String(describing: badgeLedger)) } diff --git a/apps/ios/Shared/Model/ChatModel.swift b/apps/ios/Shared/Model/ChatModel.swift index 1ee79e1c4f..75c6facb30 100644 --- a/apps/ios/Shared/Model/ChatModel.swift +++ b/apps/ios/Shared/Model/ChatModel.swift @@ -384,8 +384,7 @@ class BadgeModel: ObservableObject { } enum ChatListBanner { - case badgeExpired - case badgeIssueFailed + case badgeAlert case badgePitch case getStake } diff --git a/apps/ios/Shared/Model/SimpleXAPI.swift b/apps/ios/Shared/Model/SimpleXAPI.swift index fb1d78f650..89e172c4ee 100644 --- a/apps/ios/Shared/Model/SimpleXAPI.swift +++ b/apps/ios/Shared/Model/SimpleXAPI.swift @@ -12,6 +12,7 @@ import UIKit import Dispatch import BackgroundTasks import SwiftUI +import StoreKit @preconcurrency import SimpleXChat private var chatController: chat_ctrl? @@ -2204,18 +2205,28 @@ func apiRedeemBadgeCode(_ userId: Int64, _ code: String) async throws -> (user: enum BadgePurchaseResult { case held(user: UserRef, badgeState: BadgeState?, storePurchases: [OpenStorePurchase]) case credited(user: User, badgeState: BadgeState?) + // listed, and no record here has it: another device's purchase on the same Apple ID + case notRecorded } // log: false because a store receipt is a bearer secret, like a badge code - it is in the command. -func apiPurchaseBadge(_ userId: Int64, _ echoedInvoiceId: String?, _ payment: ServicePayment) async throws -> BadgePurchaseResult { - let r: ChatResponse2 = try await chatSendCmd(.apiPurchaseBadge(userId: userId, echoedInvoiceId: echoedInvoiceId, 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) + case .storeReceiptNotRecorded: return .notRecorded default: throw r.unexpected } } +// the device store's view of a subscription it charges, which changes what is shown and alerted, and retires its badge once ended +func apiSetBadgeSubscriptionStatus(_ status: BadgeSubscriptionState, _ payment: ServicePayment) async throws { + let r: ChatResponse2 = try await chatSendCmd(.apiSetBadgeSubscriptionStatus(status: status, payment: payment), log: false) + if case .cmdOk = r { return } + throw r.unexpected +} + func apiCreateBadgeInvoice(_ userId: Int64) async throws -> String { let r: ChatResponse2 = try await chatSendCmd(.apiCreateBadgeInvoice(userId: userId)) if case let .badgeInvoice(_, invoiceId) = r { return invoiceId } @@ -2236,12 +2247,33 @@ func redeemErrorText(_ error: Error, purchase: Bool) -> String { return purchase ? NSLocalizedString("This profile already has a badge.", comment: "alert message") : NSLocalizedString("This profile already has a badge. Redeem the code on another profile, or once this badge ends.", comment: "alert message") + case .storePurchaseOpen: + return purchase + ? NSLocalizedString("A store purchase is being added to this profile.", comment: "alert message") + : NSLocalizedString("A store purchase is being added to this profile. Redeem the code once it is added, or on another profile.", comment: "alert message") case let .serviceError(code): if let text = badgeServiceErrorText(code) { return text } case let .invalidResponse(message): return String.localizedStringWithFormat(NSLocalizedString("The badge service sent an unexpected response: %@", comment: "alert message"), message) case .unknownKeyIndex, .credentialNotVerified: return NSLocalizedString("This app version cannot verify this badge. Please update the app.", comment: "alert message") } } + if case .subscribedBefore? = error as? BadgeStoreError { + return NSLocalizedString("This Apple ID already has a badge subscription. Only the profile that bought it can continue it.", comment: "alert message") + } + if let e = error as? Product.PurchaseError { + switch e { + case .productUnavailable: return NSLocalizedString("This badge is not on sale.", comment: "alert message") + case .purchaseNotAllowed: return NSLocalizedString("In-app purchases are not allowed on this device.", comment: "alert message") + default: break + } + } + if let e = error as? StoreKitError { + switch e { + case .networkError: return NSLocalizedString("The store could not be reached.", comment: "alert message") + case .notAvailableInStorefront: return NSLocalizedString("This badge is not on sale.", comment: "alert message") + default: break + } + } return String.localizedStringWithFormat(NSLocalizedString("Error: %@", comment: "alert message"), responseError(error)) } diff --git a/apps/ios/Shared/Views/Badges/BadgeStore.swift b/apps/ios/Shared/Views/Badges/BadgeStore.swift index 0351884085..68a49bb6da 100644 --- a/apps/ios/Shared/Views/Badges/BadgeStore.swift +++ b/apps/ios/Shared/Views/Badges/BadgeStore.swift @@ -9,6 +9,7 @@ import Foundation import Combine import StoreKit +import UIKit import SimpleXChat // TODO [badges] product ids will come from app config and prices from the badge service catalog; @@ -28,16 +29,6 @@ let badgeProductIds: [String] = BadgeLevel.allCases.flatMap { level in BadgePeriod.allCases.map { badgeProductId(level, $0) } } -// the only products sent to the badge service: nothing delivers a subscription yet -let badgeOneTimeProductIds: Set = Set(BadgeLevel.allCases.map { badgeProductId($0, .oneMonth) }) - -// subscriptions are for sale once renewals are delivered -let badgePeriodsForSale: [BadgePeriod] = [.oneMonth] - -// A subscription's id only: core mints a one-time purchase's, and a subscription is never sent to core. -// Apple requires a UUID - it is sent as appAccountToken and echoed back in the signed transaction. -func newBadgeInvoiceId() -> UUID { UUID() } - // the page's app flag rides in the fragment, which never reaches the service let badgePageUrl = "https://badges.simplex.chat/#/tier?app=true" // the dev deployment, for testing store purchases: swap with the line above @@ -92,6 +83,8 @@ enum BadgeStoreError: Error { case unknownPurchaseResult case noActiveProfile case invalidInvoiceId(String) + case noWindowScene + case subscribedBefore } final class BadgeStore: ObservableObject { @@ -111,6 +104,9 @@ final class BadgeStore: ObservableObject { // set once presentUnfinished has read the store: until then, an Ask to Buy approved while the app was // closed, or a purchase it died before handing over, are both unknown, so canBuy refuses to buy again @Published private var reconciledOnce = false + // the original ids of the Apple ID's subscriptions; nil until load() has read them. Apple folds a new subscription + // of an Apple ID that subscribed before into the earlier one, which core resumes only for the profile it retired + @Published private(set) var priorSubscriptions: Set? = nil // the sweep has no buyer waiting and runs at four triggers, so a failure that cannot clear is told once a run private var sweepFailureShown = false private var transactionUpdates: Task? = nil @@ -143,6 +139,27 @@ final class BadgeStore: ObservableObject { return storePurchases.purchases } + func forSale(_ level: BadgeLevel, _ period: BadgePeriod) -> Bool { + switch period { + case .oneMonth: true + case .monthly, .annual: priorSubscriptions?.allSatisfy { $0 == resumableSubscription(level) } ?? false + } + } + + // a subscription of an Apple ID that subscribed before resumes only the active profile's newest purchase, + // once its badge is retired and only at its own level, as the service grants a new charge only of the same tier + private func resumableSubscription(_ level: BadgeLevel) -> String? { + let badgeModel = BadgeModel.shared + guard badgeModel.userId == ChatModel.shared.currentUser?.userId, + let badgeState = badgeModel.badgeState, + !badgeState.shown, + badgeState.badgeType == level.badgeType + else { return nil } + return badgeState.subscription?.transactionRef + } + + var subscribedBefore: Bool { priorSubscriptions?.isEmpty == false } + func price(_ level: BadgeLevel, _ period: BadgePeriod, compact: Bool = true) -> BadgePrice { switch state { case .notLoaded, .loading: return .loading @@ -176,8 +193,10 @@ final class BadgeStore: ObservableObject { let storefront = await Storefront.current logger.warning("BadgeStore.load: no product returned for \(missing.joined(separator: ", ")) - bundle \(Bundle.main.bundleIdentifier ?? "?"), storefront \(storefront?.countryCode ?? "none"), canMakePayments \(AppStore.canMakePayments)") } + let prior = await subscriptionOriginalIds() await MainActor.run { products = byId + priorSubscriptions = prior state = .loaded } } catch let error { @@ -186,17 +205,19 @@ final class BadgeStore: ObservableObject { } } - // A one-time purchase has its core record before the store charges, and every store outcome reaches it. + // A purchase has its core record before the store charges, and every store outcome reaches it. func purchase(_ level: BadgeLevel, _ period: BadgePeriod) async throws -> BadgePurchaseOutcome { let productId = badgeProductId(level, period) guard let product = await MainActor.run(body: { products[productId] }) else { throw BadgeStoreError.productUnavailable(productId: productId) } - // a subscription is never sent to core, so nothing would ever finish it later - guard badgeOneTimeProductIds.contains(productId) else { - let outcome = try await storePurchase(product, newBadgeInvoiceId()) - if case let .purchased(receipt) = outcome { await receipt.transaction.finish() } - return outcome + // another device on this Apple ID may have subscribed since load(), and Apple would fold this purchase into that one + if product.type == .autoRenewable { + let prior = await subscriptionOriginalIds() + await MainActor.run { priorSubscriptions = priorSubscriptions?.union(prior) } + } + guard await MainActor.run(body: { forSale(level, period) }) else { + throw BadgeStoreError.subscribedBefore } guard let userId = await MainActor.run(body: { ChatModel.shared.currentUser?.userId }) else { throw BadgeStoreError.noActiveProfile @@ -207,8 +228,16 @@ final class BadgeStore: ObservableObject { await loadBadgeStateAsync(userId) do { let outcome = try await storePurchase(product, invoiceId) + if product.type == .autoRenewable { + switch outcome { + case let .purchased(receipt): await MainActor.run { _ = priorSubscriptions?.insert(String(receipt.transaction.originalID)) } + // StoreKit lists no deferred purchase, so subscriptions stay shut for this run + case .pending: await MainActor.run { priorSubscriptions = nil } + case .cancelled: break + } + } if case let .purchased(receipt) = outcome, receipt.signatureVerified { - try await handOver(receipt) + try await handOver(receipt, origin: .purchased) } await MainActor.run { buying = false } return outcome @@ -232,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) 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, .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 @@ -254,10 +283,15 @@ final class BadgeStore: ObservableObject { } } await receipt.transaction.finish() + case .notRecorded: + // left unfinished, for the device that bought it, or for Restore to claim it here + break } } catch let error where badgeReceiptRefused(error) { logger.error("BadgeStore.handOver: \(responseError(error))") await receipt.transaction.finish() + // Restore found this purchase, so it says why it was refused rather than that there was nothing to restore + if origin == .restored { throw error } } } @@ -299,10 +333,11 @@ final class BadgeStore: ObservableObject { func presentUnfinished() async { await listenForTransactions() for await verification in Transaction.unfinished { - await reconcile(verification) + await reconcileListed(verification) } await loadCurrentBadgeState() await MainActor.run { reconciledOnce = true } + await reportSubscriptionStates() } // transactions the store settles outside a purchase call, such as an approved Ask to Buy @@ -311,33 +346,133 @@ final class BadgeStore: ObservableObject { if transactionUpdates == nil { transactionUpdates = Task.detached { for await verification in Transaction.updates { - await BadgeStore.shared.reconcile(verification) + await BadgeStore.shared.reconcileListed(verification) } } } } - // an unverified one-time transaction is never sent, and left unfinished rather than lost - private func reconcile(_ verification: VerificationResult) async { - let receipt = storeReceipt(verification) - if !badgeOneTimeProductIds.contains(receipt.productId) { - await receipt.transaction.finish() - } else if receipt.signatureVerified { - // the receipt stays unfinished, so the next sweep hands it over again - do { try await handOver(receipt) } 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; - // an alert with nowhere to go must not spend the one this run gets - if !sweepFailureShown, getTopViewController() != nil { - sweepFailureShown = true - showAlert(NSLocalizedString("Purchase error", comment: "alert title"), message: redeemErrorText(error, purchase: true)) - } + // 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, 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; + // an alert with nowhere to go must not spend the one this run gets + if !sweepFailureShown, getTopViewController() != nil { + sweepFailureShown = true + showAlert(NSLocalizedString("Purchase error", comment: "alert title"), message: redeemErrorText(error, purchase: true)) } } } } + // an unverified transaction is never sent, and left unfinished rather than lost + 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)) } } + if t.productType == .autoRenewable && t.revocationDate != nil { + // the service refuses a revoked charge as invalid, and that would refuse the whole subscription's record + await t.finish() + } else if !badgeProductIds.contains(receipt.productId) { + await t.finish() + } else if receipt.signatureVerified { + try await handOver(receipt, origin: origin) + } + } + + // The service asks the store only once the paid period ends, so a cancellation or a failed charge before + // then is seen only here. Sent with the latest transaction, which names the subscription as its first one did. + func reportSubscriptionStates() async { + guard !(await subscriptionOriginalIds()).isEmpty else { return } + await load() + guard let subscription = await MainActor.run(body: { products.values.first { $0.type == .autoRenewable }?.subscription }) else { return } + do { + for status in try await subscription.status { + guard case let .verified(renewalInfo) = status.renewalInfo, case .verified = status.transaction else { continue } + let state: BadgeSubscriptionState? = switch status.state { + case .subscribed: renewalInfo.willAutoRenew ? .renewing : .cancelled + case .inBillingRetryPeriod, .inGracePeriod: .billingRetry + case .expired, .revoked: .ended + default: nil + } + if let state { + try await apiSetBadgeSubscriptionStatus(state, .apple(jws: status.transaction.jwsRepresentation)) + } + } + } catch let error { + logger.error("BadgeStore.reportSubscriptionStates: \(responseError(error))") + } + } + + func manageSubscriptions() async { + let scene = await MainActor.run { + UIApplication.shared.connectedScenes + .compactMap { $0 as? UIWindowScene } + .first { $0.windows.contains(where: \.isKeyWindow) } + } + do { + guard let scene else { throw BadgeStoreError.noWindowScene } + try await AppStore.showManageSubscriptions(in: scene) + } catch let error { + logger.error("BadgeStore.manageSubscriptions: \(String(describing: error))") + if let url = URL(string: "https://apps.apple.com/account/subscriptions") { + await MainActor.run { UIApplication.shared.open(url) } + } + } + await reportSubscriptionStates() + await loadCurrentBadgeState() + } + + // 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. + func restorePurchases() async throws -> Bool { + try await AppStore.sync() + var handOverError: Error? = nil + 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() + await loadCurrentBadgeState() + let restored: Bool = await MainActor.run { + let userId = ChatModel.shared.currentUser?.userId + let badgeShown = BadgeModel.shared.userId == userId && BadgeModel.shared.badgeState?.shown == true + return badgeShown || purchaseState(userId) != nil + } + if !restored, let handOverError { throw handOverError } + return restored + } + + func subscriptionPrice(_ badgeType: BadgeType, planMonths: Int) -> String? { + let period: BadgePeriod? = switch planMonths { + case 1: .monthly + case 12: .annual + default: nil + } + guard let period, let level = BadgeLevel.allCases.first(where: { $0.badgeType == badgeType }) else { return nil } + return products[badgeProductId(level, period)]?.displayPrice + } + + // an unverified transaction counts too: Apple, not this check, decides what a new subscription folds into + private func subscriptionOriginalIds() async -> Set { + var ids: Set = [] + for await verification in Transaction.all { + let t = verification.unsafePayloadValue + if t.productType == .autoRenewable { ids.insert(String(t.originalID)) } + } + return ids + } + @MainActor private func startLoading() -> Bool { switch state { @@ -378,8 +513,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/Shared/Views/Badges/BadgesCheckOrderView.swift b/apps/ios/Shared/Views/Badges/BadgesCheckOrderView.swift index cd5f4d053a..2684629d43 100644 --- a/apps/ios/Shared/Views/Badges/BadgesCheckOrderView.swift +++ b/apps/ios/Shared/Views/Badges/BadgesCheckOrderView.swift @@ -7,16 +7,20 @@ // import SwiftUI +import StoreKit import SimpleXChat struct BadgesCheckOrderView: View { @EnvironmentObject var theme: AppTheme @EnvironmentObject var chatModel: ChatModel @ObservedObject private var store = BadgeStore.shared + // store.forSale reads the active profile's badge + @ObservedObject private var badgeModel = BadgeModel.shared let level: BadgeLevel let period: BadgePeriod var startDate = Date() @State private var purchasing = false + @State private var privacyPolicyActive = false // presented from this view, not AlertManager: its host is behind the sheet these views open in @State private var alert: SomeAlert? @@ -45,12 +49,45 @@ struct BadgesCheckOrderView: View { .clipShape(RoundedRectangle(cornerRadius: 16)) .padding(.top, 20) + if case let .price(p) = store.price(level, period, compact: false) { + switch period { + case .monthly: footnote("Payment is charged to your Apple ID when you confirm the purchase. The subscription renews automatically at \(p) per month unless you cancel it at least 24 hours before the end of the current period. You can manage and cancel it in your App Store account settings.") + case .annual: footnote("Payment is charged to your Apple ID when you confirm the purchase. The subscription renews automatically at \(p) per year unless you cancel it at least 24 hours before the end of the current period. You can manage and cancel it in your App Store account settings.") + case .oneMonth: EmptyView() + } + } + + if !store.forSale(level, period) && store.subscribedBefore { + footnote("This Apple ID already has a badge subscription. Only the profile that bought it can continue it.") + } + + if !AppStore.canMakePayments { + footnote("In-app purchases are not allowed on this device.") + } + Spacer(minLength: 20) VStack(spacing: 10) { payButton() .padding(.vertical, 10) BadgeBillingFooter(period: period, startDate: startDate) + HStack(spacing: 20) { + Link("Terms of use", destination: appleStandardEULAURL) + ZStack { + Button("Privacy policy") { privacyPolicyActive = true } + NavigationLink(isActive: $privacyPolicyActive) { + ConditionsTextView() + .padding() + .navigationTitle("Privacy policy") + .modifier(ThemedBackground(grouped: true)) + } label: { + EmptyView() + } + .frame(width: 1, height: 1) + .hidden() + } + } + .font(.footnote) } .padding(.bottom, g.safeAreaInsets.bottom == 0 ? 20 : 0) } @@ -66,6 +103,14 @@ struct BadgesCheckOrderView: View { .alert(item: $alert) { $0.alert } } + private func footnote(_ text: LocalizedStringKey) -> some View { + Text(text) + .font(.footnote) + .foregroundColor(theme.colors.secondary) + .frame(maxWidth: .infinity, alignment: .leading) + .fixedSize(horizontal: false, vertical: true) + } + private func orderRow(_ title: LocalizedStringKey, _ value: Text) -> some View { HStack { Text(title) @@ -80,7 +125,7 @@ struct BadgesCheckOrderView: View { private func payButton() -> some View { let price = store.price(level, period, compact: false) - let disabled = !price.canPurchase || purchasing || !store.canBuy(chatModel.currentUser?.userId) + let disabled = !price.canPurchase || purchasing || !store.canBuy(chatModel.currentUser?.userId) || !store.forSale(level, period) || !AppStore.canMakePayments return Button { purchase() } label: { @@ -110,6 +155,8 @@ struct BadgesCheckOrderView: View { logger.error("BadgesCheckOrderView.purchase: \(String(describing: error))") await MainActor.run { purchasing = false + // thrown when the purchase sheet or its sign-in prompt is dismissed, which needs no alert + if case .userCancelled? = error as? StoreKitError { return } alert = SomeAlert( alert: Alert( title: Text("Purchase error"), @@ -123,6 +170,45 @@ struct BadgesCheckOrderView: View { } } +// Apple's standard licence agreement, which an app selling subscriptions links as its terms of use +let appleStandardEULAURL = URL(string: "https://www.apple.com/legal/internet-services/itunes/dev/stdeula/")! + +struct RestorePurchasesButton: View { + @State private var restoring = false + + var body: some View { + Button("Restore purchases") { + restoring = true + Task { + await restore() + await MainActor.run { restoring = false } + } + } + .font(.footnote) + .disabled(restoring) + } + + private func restore() async { + do { + let found = try await BadgeStore.shared.restorePurchases() + if !found { + await MainActor.run { + showAlert( + NSLocalizedString("Nothing to restore", comment: "alert title"), + message: NSLocalizedString("No App Store purchase waiting to be added was found.", comment: "alert message") + ) + } + } + } catch let error { + logger.error("RestorePurchasesButton: \(String(describing: error))") + if case .userCancelled? = error as? StoreKitError { return } + await MainActor.run { + showAlert(NSLocalizedString("Restore failed", comment: "alert title"), message: redeemErrorText(error, purchase: true)) + } + } + } +} + struct BadgesCheckOrderView_Previews: PreviewProvider { static var previews: some View { NavigationView { diff --git a/apps/ios/Shared/Views/Badges/BadgesHowLongView.swift b/apps/ios/Shared/Views/Badges/BadgesHowLongView.swift index 4e7a9184e3..3d3d7559ac 100644 --- a/apps/ios/Shared/Views/Badges/BadgesHowLongView.swift +++ b/apps/ios/Shared/Views/Badges/BadgesHowLongView.swift @@ -71,11 +71,18 @@ enum BadgePeriod: String, CaseIterable, Identifiable { struct BadgesHowLongView: View { @EnvironmentObject var theme: AppTheme @ObservedObject private var store = BadgeStore.shared + // store.forSale reads the active profile's badge + @ObservedObject private var badgeModel = BadgeModel.shared let level: BadgeLevel var startDate = Date() - @State private var selectedPeriod: BadgePeriod = badgePeriodsForSale.contains(.monthly) ? .monthly : .oneMonth + @State private var chosenPeriod: BadgePeriod? = nil @State private var continueActive = false + // monthly once subscriptions turn out to be for sale, unless a period was chosen before that + private var selectedPeriod: BadgePeriod { + chosenPeriod ?? (store.forSale(level, .monthly) ? .monthly : .oneMonth) + } + var body: some View { GeometryReader { g in ScrollView { @@ -105,6 +112,14 @@ struct BadgesHowLongView: View { } .fixedSize(horizontal: false, vertical: true) + if !store.forSale(level, .monthly) && store.subscribedBefore { + Text("This Apple ID already has a badge subscription. Only the profile that bought it can continue it.") + .font(.footnote) + .foregroundColor(theme.colors.secondary) + .multilineTextAlignment(.center) + .fixedSize(horizontal: false, vertical: true) + } + Spacer(minLength: 20) VStack(spacing: 10) { @@ -127,9 +142,9 @@ struct BadgesHowLongView: View { private func periodCard(_ period: BadgePeriod) -> some View { let isSelected = period == selectedPeriod - let forSale = badgePeriodsForSale.contains(period) + let forSale = store.forSale(level, period) return Button { - selectedPeriod = period + chosenPeriod = period } label: { VStack(spacing: 12) { Image(systemName: period.icon) @@ -171,6 +186,7 @@ struct BadgesHowLongView: View { private func continueButton() -> some View { ZStack { Button { + chosenPeriod = selectedPeriod continueActive = true } label: { Text("Continue") diff --git a/apps/ios/Shared/Views/Badges/BadgesSupportSimplexView.swift b/apps/ios/Shared/Views/Badges/BadgesSupportSimplexView.swift index 97e91bfb69..543acd235a 100644 --- a/apps/ios/Shared/Views/Badges/BadgesSupportSimplexView.swift +++ b/apps/ios/Shared/Views/Badges/BadgesSupportSimplexView.swift @@ -45,8 +45,9 @@ struct BadgesSupportSimplexView: View { Spacer(minLength: 0) - // In-app purchase is not released: the badge is chosen on the site, and the code - // redeemed here. Revert this commit to restore the block below. + // Store purchases are not released on iOS: TestFlight buys in the sandbox, which the + // service refuses for good. The badge is chosen on the site, and the code redeemed here. + // Revert this commit to restore the block below. // VStack(spacing: 10) { // chooseLevelButton() // .padding(.vertical, 10) @@ -58,6 +59,14 @@ struct BadgesSupportSimplexView: View { // } // } // .frame(height: 22) + // RestorePurchasesButton() + // .frame(height: 22) + // .padding(.top, 10) + // Text("If you were charged but have no badge, this adds it. A subscription bought with this App Store account moves to this profile, and the device or profile that had it loses its badge at its next renewal.") + // .font(.footnote) + // .foregroundColor(theme.colors.secondary) + // .multilineTextAlignment(.center) + // .fixedSize(horizontal: false, vertical: true) // } VStack(spacing: 10) { chooseBadgeOnSiteButton() @@ -141,7 +150,7 @@ struct BadgesSupportSimplexView: View { } } - // In-app purchase is not released: delete with the commented block above to restore it. + // delete with the commented block above to restore store purchases private func chooseBadgeOnSiteButton() -> some View { Button { UIApplication.shared.open(URL(string: badgePageUrl)!) diff --git a/apps/ios/Shared/Views/Badges/BadgesYourBadgeView.swift b/apps/ios/Shared/Views/Badges/BadgesYourBadgeView.swift index 60c6a0ab77..3b744951cb 100644 --- a/apps/ios/Shared/Views/Badges/BadgesYourBadgeView.swift +++ b/apps/ios/Shared/Views/Badges/BadgesYourBadgeView.swift @@ -14,6 +14,7 @@ struct BadgesYourBadgeView: View { @EnvironmentObject var chatModel: ChatModel @Environment(\.dismiss) private var dismiss @AppStorage(DEFAULT_DEVELOPER_TOOLS) private var developerTools = false + @ObservedObject private var store = BadgeStore.shared let badgeState: BadgeState var showsAsSheet: Bool = false @@ -34,14 +35,42 @@ struct BadgesYourBadgeView: View { Section { BadgeSummary(badgeState: badgeState) } - Section { - Text(badgeState.paidThroughText) - } header: { - Text("Ends") - .foregroundColor(theme.colors.secondary) - } footer: { - Text("Prepaid months have no billing date. The badge is reissued each month from the balance you already paid for, and ends when it runs out.") - .foregroundColor(theme.colors.secondary) + if let subscription = badgeState.subscription { + let ended = badgeState.paidThrough <= Date.now + let date = badgeState.paidThroughText + switch subscription.status { + case .billingRetry: + subscriptionSection( + HStack(spacing: 6) { + Image(systemName: "exclamationmark.triangle") + .foregroundColor(.red) + Text("Payment problem") + }, + footer: "The App Store could not charge your payment method and is retrying. Update it to keep your badge. Until the payment goes through, you cannot buy or redeem another badge." + ) + case .cancelled where !ended: + subscriptionSection(Text("Ends \(date)"), footer: "Your subscription is cancelled. The badge stays until \(date).") + case .ended, .cancelled: + subscriptionSection(Text("Ended"), footer: "Your subscription has ended. The badge will be removed from your profile.") + case .renewing, .unknown, nil: + if ended { + subscriptionSection(Text("Renewing"), footer: "Your badge is renewed once the App Store charges your subscription. Until then you cannot buy or redeem another badge.") + } else if let price = store.subscriptionPrice(badgeState.badgeType, planMonths: subscription.planMonths) { + subscriptionSection(Text("Renews \(date) ยท \(price)"), footer: "Your subscription renews automatically. You can cancel it in the App Store.") + } else { + subscriptionSection(Text("Renews \(date)"), footer: "Your subscription renews automatically. You can cancel it in the App Store.") + } + } + } else { + Section { + Text(badgeState.paidThroughText) + } header: { + Text("Ends") + .foregroundColor(theme.colors.secondary) + } footer: { + Text("Prepaid months have no billing date. The badge is reissued each month from the balance you already paid for, and ends when it runs out.") + .foregroundColor(theme.colors.secondary) + } } Section { NavigationLink { @@ -110,6 +139,23 @@ struct BadgesYourBadgeView: View { .modifier(ThemedBackground(grouped: true)) } + private func subscriptionSection(_ status: some View, footer: LocalizedStringKey) -> some View { + Section { + status + settingsRow("creditcard", color: theme.colors.secondary) { + Button("Manage subscription") { + Task { await BadgeStore.shared.manageSubscriptions() } + } + } + } header: { + Text("Subscription") + .foregroundColor(theme.colors.secondary) + } footer: { + Text(footer) + .foregroundColor(theme.colors.secondary) + } + } + private func badgeTimestamp(_ date: Date) -> String { DateFormatter.localizedString(from: date, dateStyle: .medium, timeStyle: .short) } diff --git a/apps/ios/Shared/Views/ChatList/ChatListView.swift b/apps/ios/Shared/Views/ChatList/ChatListView.swift index 9d5f9bb5d2..b6c8fad9f6 100644 --- a/apps/ios/Shared/Views/ChatList/ChatListView.swift +++ b/apps/ios/Shared/Views/ChatList/ChatListView.swift @@ -379,18 +379,39 @@ struct ChatListView: View { } } - // the onboarding cards replace the whole chat list, and the support-ended banner lives in the - // list - a lapsed supporter is not a newcomer, and must be told even with no conversations yet + // the onboarding cards replace the whole chat list, and the badge alert banner lives in the + // list - a supporter is not a newcomer, and must be told even with no conversations yet private var shouldShowOnboarding: Bool { - !addressCreationCardShown && !chatModel.chats.isEmpty && !hasConversations && !supportEnded && !badgeIssueFailed + !addressCreationCardShown && !chatModel.chats.isEmpty && !hasConversations && bannerBadgeAlert == nil } - private var supportEnded: Bool { - badgeModel.alert?.kind == .supportEnded && badgeModel.userId == chatModel.currentUser?.userId + // the current profile's badge alert, if it is a kind the chat list has a banner for + private var bannerBadgeAlert: BadgeAlert? { + guard let alert = badgeModel.alert, badgeModel.userId == chatModel.currentUser?.userId else { return nil } + switch alert.kind { + case .supportEnded, .issueFailed, .subscriptionEnded, .paymentIssue, .subscriptionCancelled, .renewalApproaching: return alert + case .prepaidEnding, .unknown: return nil + } } - private var badgeIssueFailed: Bool { - badgeModel.alert?.kind == .issueFailed && badgeModel.userId == chatModel.currentUser?.userId + private var renewalPrice: String? { + guard let badgeState = badgeModel.badgeState, let subscription = badgeState.subscription else { return nil } + return BadgeStore.shared.subscriptionPrice(badgeState.badgeType, planMonths: subscription.planMonths) + } + + private var renewalFailure: LocalizedStringKey { + guard let issueError = badgeModel.badgeState?.issueError else { return "Your badge could not be renewed." } + return "\(issueError.reason.text)" + } + + private func badgeAlertBanner(_ title: LocalizedStringKey, _ subtitle: LocalizedStringKey, warning: Bool = false, dismissTitle: String) -> some View { + SupportSimpleXBanner( + title: title, + subtitle: subtitle, + warning: warning, + onTap: { showBadgesSheet = true }, + onDismiss: { showBadgeAlertDismissAlert(dismissTitle) } + ) } private func showBadgeAlertDismissAlert(_ title: String) { @@ -481,34 +502,36 @@ struct ChatListView: View { .listRowSeparator(.hidden) .listRowBackground(Color.clear) } - // one slot: a badge the user paid for ending outranks the pitch to get one - if supportEnded, let alert = badgeModel.alert { - SupportSimpleXBanner( - title: "Your badge expired", - subtitle: "Your badge expired on \(alert.dateText).", - onTap: { showBadgesSheet = true }, - onDismiss: { showBadgeAlertDismissAlert(NSLocalizedString("Your badge expired", comment: "alert title")) } - ) + // one slot: an alert about a badge the user paid for outranks the pitch to get one + if let alert = bannerBadgeAlert { + Group { + switch alert.kind { + case .supportEnded: + badgeAlertBanner("Your badge expired", "Your badge expired on \(alert.dateText).", dismissTitle: NSLocalizedString("Your badge expired", comment: "alert title")) + case .issueFailed: + badgeAlertBanner("Badge renewal failed", renewalFailure, warning: true, dismissTitle: NSLocalizedString("Badge renewal failed", comment: "alert title")) + case .subscriptionEnded: + badgeAlertBanner("Your subscription ended", "Your badge subscription ended on \(alert.dateText).", dismissTitle: NSLocalizedString("Your subscription ended", comment: "alert title")) + case .paymentIssue: + badgeAlertBanner("Badge payment problem", "The store could not charge your payment method.", warning: true, dismissTitle: NSLocalizedString("Badge payment problem", comment: "alert title")) + case .subscriptionCancelled: + badgeAlertBanner("Subscription cancelled", "Your badge stays until \(alert.dateText).", dismissTitle: NSLocalizedString("Subscription cancelled", comment: "alert title")) + case .renewalApproaching: + if let price = renewalPrice { + badgeAlertBanner("Your badge renews soon", "Renews on \(alert.dateText) for \(price).", dismissTitle: NSLocalizedString("Your badge renews soon", comment: "alert title")) + } else { + badgeAlertBanner("Your badge renews soon", "Renews on \(alert.dateText).", dismissTitle: NSLocalizedString("Your badge renews soon", comment: "alert title")) + } + case .prepaidEnding, .unknown: + EmptyView() + } + } .padding(.vertical, 3) .scaleEffect(x: 1, y: oneHandUI ? -1 : 1, anchor: .center) .listRowSeparator(.hidden) .listRowBackground(Color.clear) .zIndex(1) - .onAppear { chatModel.chatListBanner = .badgeExpired } - } else if badgeIssueFailed { - SupportSimpleXBanner( - title: "Badge renewal failed", - subtitle: "Tap for details", - warning: true, - onTap: { showBadgesSheet = true }, - onDismiss: { showBadgeAlertDismissAlert(NSLocalizedString("Badge renewal failed", comment: "alert title")) } - ) - .padding(.vertical, 3) - .scaleEffect(x: 1, y: oneHandUI ? -1 : 1, anchor: .center) - .listRowSeparator(.hidden) - .listRowBackground(Color.clear) - .zIndex(1) - .onAppear { chatModel.chatListBanner = .badgeIssueFailed } + .onAppear { chatModel.chatListBanner = .badgeAlert } // noShownBadge is false until the badge state loads: the pitch must not lock the slot and then // be hidden by a supporter's badge arriving a moment later, leaving the slot empty for the session } else if chatModel.bannerSlotFree(for: .badgePitch) && !supporterBannerShown && noShownBadge() && chatModel.chats.count > 3 { diff --git a/apps/ios/SimpleX Snapshots/References/BadgesCheckOrderView-dark-large.png b/apps/ios/SimpleX Snapshots/References/BadgesCheckOrderView-dark-large.png index 000eaf7e75..39b32f83ed 100644 Binary files a/apps/ios/SimpleX Snapshots/References/BadgesCheckOrderView-dark-large.png and b/apps/ios/SimpleX Snapshots/References/BadgesCheckOrderView-dark-large.png differ diff --git a/apps/ios/SimpleX Snapshots/References/BadgesCheckOrderView-light-large.png b/apps/ios/SimpleX Snapshots/References/BadgesCheckOrderView-light-large.png index 75a56704d7..7dec008a81 100644 Binary files a/apps/ios/SimpleX Snapshots/References/BadgesCheckOrderView-light-large.png and b/apps/ios/SimpleX Snapshots/References/BadgesCheckOrderView-light-large.png differ diff --git a/apps/ios/SimpleX Snapshots/References/BadgesHowLongView-dark-large.png b/apps/ios/SimpleX Snapshots/References/BadgesHowLongView-dark-large.png index f4d10bb7e2..a5dbcafefc 100644 Binary files a/apps/ios/SimpleX Snapshots/References/BadgesHowLongView-dark-large.png and b/apps/ios/SimpleX Snapshots/References/BadgesHowLongView-dark-large.png differ diff --git a/apps/ios/SimpleX Snapshots/References/BadgesHowLongView-light-large.png b/apps/ios/SimpleX Snapshots/References/BadgesHowLongView-light-large.png index 1d17bc44ec..3c6f2bc7c2 100644 Binary files a/apps/ios/SimpleX Snapshots/References/BadgesHowLongView-light-large.png and b/apps/ios/SimpleX Snapshots/References/BadgesHowLongView-light-large.png differ diff --git a/apps/ios/SimpleX.xcodeproj/project.pbxproj b/apps/ios/SimpleX.xcodeproj/project.pbxproj index 35557ebfbc..c55946f1c8 100644 --- a/apps/ios/SimpleX.xcodeproj/project.pbxproj +++ b/apps/ios/SimpleX.xcodeproj/project.pbxproj @@ -193,8 +193,8 @@ 64C3B0212A0D359700E19930 /* CustomTimePicker.swift in Sources */ = {isa = PBXBuildFile; fileRef = 64C3B0202A0D359700E19930 /* CustomTimePicker.swift */; }; 64C8299D2D54AEEE006B9E89 /* libgmp.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 64C829982D54AEED006B9E89 /* libgmp.a */; }; 64C8299E2D54AEEE006B9E89 /* libffi.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 64C829992D54AEEE006B9E89 /* libffi.a */; }; - 64C8299F2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 64C8299A2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs-ghc9.6.3.a */; }; - 64C829A02D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 64C8299B2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs.a */; }; + 64C8299F2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 64C8299A2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE-ghc9.6.3.a */; }; + 64C829A02D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 64C8299B2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE.a */; }; 64C829A12D54AEEE006B9E89 /* libgmpxx.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 64C8299C2D54AEEE006B9E89 /* libgmpxx.a */; }; 64D0C2C029F9688300B38D5F /* UserAddressView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 64D0C2BF29F9688300B38D5F /* UserAddressView.swift */; }; 64D0C2C229FA57AB00B38D5F /* UserAddressLearnMore.swift in Sources */ = {isa = PBXBuildFile; fileRef = 64D0C2C129FA57AB00B38D5F /* UserAddressLearnMore.swift */; }; @@ -599,8 +599,8 @@ 64C3B0202A0D359700E19930 /* CustomTimePicker.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = CustomTimePicker.swift; sourceTree = ""; }; 64C829982D54AEED006B9E89 /* libgmp.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmp.a; sourceTree = ""; }; 64C829992D54AEEE006B9E89 /* libffi.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libffi.a; sourceTree = ""; }; - 64C8299A2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs-ghc9.6.3.a"; sourceTree = ""; }; - 64C8299B2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs.a"; sourceTree = ""; }; + 64C8299A2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE-ghc9.6.3.a"; sourceTree = ""; }; + 64C8299B2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE.a"; sourceTree = ""; }; 64C8299C2D54AEEE006B9E89 /* libgmpxx.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmpxx.a; sourceTree = ""; }; 64D0C2BF29F9688300B38D5F /* UserAddressView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = UserAddressView.swift; sourceTree = ""; }; 64D0C2C129FA57AB00B38D5F /* UserAddressLearnMore.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = UserAddressLearnMore.swift; sourceTree = ""; }; @@ -786,8 +786,8 @@ 64C8299D2D54AEEE006B9E89 /* libgmp.a in Frameworks */, 64C8299E2D54AEEE006B9E89 /* libffi.a in Frameworks */, 64C829A12D54AEEE006B9E89 /* libgmpxx.a in Frameworks */, - 64C8299F2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs-ghc9.6.3.a in Frameworks */, - 64C829A02D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs.a in Frameworks */, + 64C8299F2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE-ghc9.6.3.a in Frameworks */, + 64C829A02D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE.a in Frameworks */, CE38A29C2C3FCD72005ED185 /* SwiftyGif in Frameworks */, ); runOnlyForDeploymentPostprocessing = 0; @@ -874,8 +874,8 @@ 64C829992D54AEEE006B9E89 /* libffi.a */, 64C829982D54AEED006B9E89 /* libgmp.a */, 64C8299C2D54AEEE006B9E89 /* libgmpxx.a */, - 64C8299A2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs-ghc9.6.3.a */, - 64C8299B2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-FQI9ONxXS3x5DhsgnqtwJs.a */, + 64C8299A2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE-ghc9.6.3.a */, + 64C8299B2D54AEEE006B9E89 /* libHSsimplex-chat-7.1.0.14-C2bYStpiFGU19PwEXn8BAE.a */, ); path = Libraries; sourceTree = ""; diff --git a/apps/ios/SimpleXChat/APITypes.swift b/apps/ios/SimpleXChat/APITypes.swift index 6f5f62daf3..2385a1e816 100644 --- a/apps/ios/SimpleXChat/APITypes.swift +++ b/apps/ios/SimpleXChat/APITypes.swift @@ -830,6 +830,7 @@ public enum BadgeRedeemError: Decodable, Hashable { case invalidReceipt case serviceNotConfigured case badgeActive + case storePurchaseOpen case serviceError(serviceError: BadgeServiceErrorCode) case invalidResponse(message: String) case unknownKeyIndex @@ -856,6 +857,7 @@ public enum BadgeServiceErrorCode: Decodable, Hashable { case receiptInvalid case receiptUsed case testPurchase + case transferLimited case internalError case unknown(String) @@ -879,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 } @@ -904,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) } @@ -922,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/SimpleXChat/ChatTypes.swift b/apps/ios/SimpleXChat/ChatTypes.swift index 3cf4a84de8..072d132244 100644 --- a/apps/ios/SimpleXChat/ChatTypes.swift +++ b/apps/ios/SimpleXChat/ChatTypes.swift @@ -388,10 +388,49 @@ public struct BadgeState: Decodable, Hashable { public var alert: BadgeAlert? public var issueError: BadgeIssueError? public var nextWakeAt: Date? + public var subscription: BadgeSubscription? public var paidThroughText: String { badgeDateText(paidThrough) } } +public struct BadgeSubscription: Decodable, Hashable { + public var planMonths: Int + // nil until the service or the device's store has been asked + public var status: BadgeSubscriptionState? + // the store's reference: Apple's original transaction id, or a hash of Play's token + public var transactionRef: String? +} + +// the store's state as last observed; a newer core may know a state this version does not +public enum BadgeSubscriptionState: Decodable, Hashable { + case renewing + case cancelled + case billingRetry + case ended + case unknown + + // as /_badge subscription takes it, which accepts only the four known states + public var text: String { + switch self { + case .renewing: "renewing" + case .cancelled: "cancelled" + case .billingRetry: "billingRetry" + case .ended: "ended" + case .unknown: "unknown" + } + } + + public init(from decoder: Decoder) throws { + switch try decoder.singleValueContainer().decode(String.self) { + case "renewing": self = .renewing + case "cancelled": self = .cancelled + case "billingRetry": self = .billingRetry + case "ended": self = .ended + default: self = .unknown + } + } +} + public struct BadgeIssueError: Decodable, Hashable { public var failedSince: Date public var lastAttemptAt: Date @@ -624,13 +663,47 @@ public struct BadgeAlertPrice: Codable, Hashable { public var currency: String } -public enum BadgeAlertKind: String, Codable, Hashable { +// a kind added by a newer core decodes, so the badge state still does, and shows no banner +public enum BadgeAlertKind: Codable, Hashable { case renewalApproaching case paymentIssue + case subscriptionCancelled case subscriptionEnded case prepaidEnding case supportEnded case issueFailed + case unknown(String) + + public var text: String { + switch self { + case .renewalApproaching: "renewalApproaching" + case .paymentIssue: "paymentIssue" + case .subscriptionCancelled: "subscriptionCancelled" + case .subscriptionEnded: "subscriptionEnded" + case .prepaidEnding: "prepaidEnding" + case .supportEnded: "supportEnded" + case .issueFailed: "issueFailed" + case let .unknown(s): s + } + } + + public init(from decoder: Decoder) throws { + switch try decoder.singleValueContainer().decode(String.self) { + case "renewalApproaching": self = .renewalApproaching + case "paymentIssue": self = .paymentIssue + case "subscriptionCancelled": self = .subscriptionCancelled + case "subscriptionEnded": self = .subscriptionEnded + case "prepaidEnding": self = .prepaidEnding + case "supportEnded": self = .supportEnded + case "issueFailed": self = .issueFailed + case let s: self = .unknown(s) + } + } + + public func encode(to encoder: Encoder) throws { + var container = encoder.singleValueContainer() + try container.encode(text) + } } // the wire proof carried on a profile - opaque to the UI, only round-tripped back to the core (apiPrepareContact) diff --git a/apps/ios/product/gaps.md b/apps/ios/product/gaps.md index 50d6bf2938..ae5e1b46c7 100644 --- a/apps/ios/product/gaps.md +++ b/apps/ios/product/gaps.md @@ -62,3 +62,19 @@ The Haskell Store modules (`Store/Direct.hs`, `Store/Groups.hs`, `Store/Messages --- +## Badges: Store Purchases + +### 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) +`restorePurchases()` hands over `Transaction.currentEntitlements` and `Transaction.unfinished` as restored, and the service moves the subscription to the restoring profile's purchase key. Restore is refused while the restoring profile shows a badge. A payment moves again only once the credential issued to the key it last moved from has expired; until then the move is refused `transfer_limited`. The first Restore's own answer doesn't say so: the app hears of the refusal only from core's purchase-refused event, which core sends only for a record holding an invoice id, and the next Restore is answered `transfer_limited` itself. 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` with the purchase's `transactionRef`; the ids are read at the first load and again before each subscription purchase, and extended by every auto-renewable transaction the sweep, its updates or Restore sees and every subscription bought) 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:** Restore by a receipt code for Stripe and crypto purchases, and announce a limited move on the first Restore. + +### GAP: A device whose subscription Restore moved away still offers to buy it again +**Source:** [Shared/Views/Badges/BadgeStore.swift](../Shared/Views/Badges/BadgeStore.swift) +Once Restore moves a subscription to another device or profile, the service answers the old purchase key ended, and this device retires its badge. Its ledger tip is then the `transferOut` debit, so core knows the payment moved out (`purchaseMovedOut` in `Store/Badges.hs`), but no field of `BadgeState` says so: the newest purchase still reads as a subscription not shown, of its own tier, with the same `subscription.transactionRef`. So `resumableSubscription` returns that original id, `forSale` opens monthly and annual at that tier when it is the only original id in `priorSubscriptions`, and with nothing open (`canBuy`) the order screen's `payButton` is enabled. A charge Apple makes then keeps the original transaction id, whose payment the service has bound to the key Restore moved it to, so it funds that key; here `handOverStoreReceipt` finds the purchase moved out, answers with its old credential, the app finishes the transaction, and this profile shows no badge and no message. + +**REC:** After the first release, carry the move in the badge state, so `forSale` closes subscriptions for a purchase whose payment moved away. + +--- + diff --git a/apps/ios/spec/client/chat-list.md b/apps/ios/spec/client/chat-list.md index 2087d0dee3..00a5583ee1 100644 --- a/apps/ios/spec/client/chat-list.md +++ b/apps/ios/spec/client/chat-list.md @@ -290,10 +290,10 @@ Gradient card inviting the user to invest on Wefunder. Shown only when [`isInUS` | Where | Condition | Layout | |-------|-----------|--------| -| Chat list | rendered whenever [`chatListContent`](../../Shared/Views/ChatList/ChatListView.swift#L413) is, in the `List` after `OneHandUICard` and before the chats | `.padding(.vertical, 3)`, flipped for one-hand UI, `.zIndex(1)` | +| Chat list | rendered whenever [`chatListContent`](../../Shared/Views/ChatList/ChatListView.swift#L477) is, in the `List` after `OneHandUICard` and before the chats | `.padding(.vertical, 3)`, flipped for one-hand UI, `.zIndex(1)` | | Onboarding | below [`ConnectOnboardingView`](../../Shared/Views/NewChat/OnboardingCards.swift#L135) when `shouldShowOnboarding` | `.padding(.horizontal, 20)` (the onboarding cards' margin), `.padding(.bottom, 8)` | -The list has a single banner slot, filled by an `if`/`else if` chain in priority order: the support-ended alert (`supportEnded`), the renewal-failure alert (`badgeIssueFailed`), the pitch, then the Wefunder banner. Each banner records itself in `ChatModel.chatListBanner` (`.badgeExpired`, `.badgeIssueFailed`, `.badgePitch`, `.getStake`) in its `onAppear`, and the pitch and Wefunder conditions start with `chatModel.bannerSlotFree(for:)` โ€” true only while nothing else was shown this app session โ€” so dismissing a banner never puts another in its place until restart. The alerts have no such check: an alert takes the slot whenever present, and once shown it holds it. The pitch also requires `noShownBadge`, false until `BadgeModel` holds the current user's state, so it cannot take the slot from a supporter whose badge loads a moment later. The onboarding placement applies the same `bannerSlotFree` check and records `.getStake`. +The list has a single banner slot, filled by an `if`/`else if` chain in priority order: the badge alert banner, the pitch, then the Wefunder banner. The badge alert banner shows `bannerBadgeAlert`, the current profile's alert when its kind has a banner (support ended, renewal failed, subscription ended, payment problem, subscription cancelled, renewal soon; not prepaid ending or a kind from a newer core), and one `switch` over the kind at the banner site picks its title, subtitle and warning colour; its X leads to the same remind-later or dismiss alert for every kind. The renewal-failed subtitle is `renewalFailure`: the reason in `BadgeModel`'s `badgeState.issueError` (`BadgeIssueFailure.text`), or "Your badge could not be renewed." when the state carries none, as after an alert that arrives without a new state; the payment-problem subtitle is "The store could not charge your payment method.", not `issueError`, which in billing retry is a failed renewal request rather than the payment's reason. Each banner records itself in `ChatModel.chatListBanner` (`.badgeAlert`, `.badgePitch`, `.getStake`) in its `onAppear`, and the pitch and Wefunder conditions start with `chatModel.bannerSlotFree(for:)` โ€” true only while nothing else was shown this app session โ€” so dismissing a banner never puts another in its place until restart. The alerts have no such check: an alert takes the slot whenever present, and once shown it holds it. The pitch also requires `noShownBadge`, false until `BadgeModel` holds the current user's state, so it cannot take the slot from a supporter whose badge loads a moment later. The onboarding placement applies the same `bannerSlotFree` check and records `.getStake`. In the onboarding branch the `.scaleEffect` and `ThemedBackground` are applied to the enclosing `VStack` rather than to each child, so the banner stays below the pages in both toolbar modes. @@ -301,12 +301,12 @@ In the onboarding branch the `.scaleEffect` and `ThemedBackground` are applied t | Default | Set by | Effect | |---------|--------|--------| -| `DEFAULT_GET_STAKE_BANNER_TAPPED` | [`openGetStake()`](../../Shared/Views/ChatList/ChatListView.swift#L408) | the dismiss X appears from then on, while there are chats | +| `DEFAULT_GET_STAKE_BANNER_TAPPED` | [`openGetStake()`](../../Shared/Views/ChatList/ChatListView.swift#L472) | the dismiss X appears from then on, while there are chats | | `DEFAULT_GET_STAKE_BANNER_DISMISSED` | the dismiss X | hides the banner in both placements | | `DEFAULT_SUPPORTER_BANNER_TAPPED` | tapping the supporter pitch | the pitch's dismiss X appears from then on | | `DEFAULT_SUPPORTER_BANNER_SHOWN` | the pitch's dismiss X, through its "You can support SimpleX later in Settings." alert, and a successful code redemption | hides the pitch | -The two badge alert banners always offer the X; only the pitch waits to be tapped once, so a user who has not looked at it cannot dismiss it unseen. +The badge alert banner always offers the X; only the pitch waits to be tapped once, so a user who has not looked at it cannot dismiss it unseen. Both are in `hintDefaults`, so "Reset all hints" in the developer settings restores the banner. The X is never offered in the onboarding branch, so the banner cannot be dismissed before the user has a chat. diff --git a/apps/multiplatform/android/src/foss/java/chat/simplex/app/PlayStore.kt b/apps/multiplatform/android/src/foss/java/chat/simplex/app/PlayStore.kt index 0cad378da6..401b7edd07 100644 --- a/apps/multiplatform/android/src/foss/java/chat/simplex/app/PlayStore.kt +++ b/apps/multiplatform/android/src/foss/java/chat/simplex/app/PlayStore.kt @@ -31,3 +31,6 @@ suspend fun acknowledgeBadgePurchase(receipt: BadgeStoreReceipt) {} suspend fun finishBadgePurchase(receipt: BadgeStoreReceipt) {} suspend fun unfinishedBadgePurchases(): List = emptyList() + +@Suppress("UNUSED_PARAMETER") +fun manageBadgeSubscription(productId: String) {} diff --git a/apps/multiplatform/android/src/google/java/chat/simplex/app/PlayStore.kt b/apps/multiplatform/android/src/google/java/chat/simplex/app/PlayStore.kt index 85b9da1316..32c5a32f8e 100644 --- a/apps/multiplatform/android/src/google/java/chat/simplex/app/PlayStore.kt +++ b/apps/multiplatform/android/src/google/java/chat/simplex/app/PlayStore.kt @@ -1,5 +1,8 @@ package chat.simplex.app +import android.content.ActivityNotFoundException +import android.content.Intent +import android.net.Uri import chat.simplex.common.platform.Log import chat.simplex.common.platform.androidAppContext import chat.simplex.common.platform.androidPlayStoreCountry @@ -9,6 +12,8 @@ import chat.simplex.common.views.helpers.withLongRunningApi import com.android.billingclient.api.* import kotlinx.coroutines.CompletableDeferred import kotlinx.coroutines.Dispatchers +import kotlinx.coroutines.sync.Mutex +import kotlinx.coroutines.sync.withLock import kotlinx.coroutines.withContext const val hasPlatformStore = true @@ -45,6 +50,8 @@ fun loadPlayStoreCountry() { @Volatile private var badgeBillingClient: BillingClient? = null @Volatile private var badgeOffers: Map = emptyMap() @Volatile private var badgePurchase: CompletableDeferred? = null +// two callers connecting at once would each keep a client open, and Play could deliver a purchase event to each +private val badgeBillingConnection = Mutex() // offerToken is null for one-time products, which have no base plan to choose private class BadgeOffer( @@ -92,7 +99,7 @@ suspend fun purchaseBadge(id: BadgeStoreProductId, invoiceId: String): BadgePurc try { val launched = withContext(Dispatchers.Main) { client.launchBillingFlow(activity, params) } if (launched.responseCode != BillingClient.BillingResponseCode.OK) { - throw BadgeStoreError.BillingError(launched.responseCode, launched.debugMessage) + throw badgePurchaseError(launched) } return purchase.await() } finally { @@ -100,10 +107,20 @@ suspend fun purchaseBadge(id: BadgeStoreProductId, invoiceId: String): BadgePurc } } -// one-time purchases Play still holds: bought and not consumed, or awaiting a slow payment +// purchases Play still holds: one-time products bought and not consumed, subscriptions in a paid period, +// and either awaiting a slow payment suspend fun unfinishedBadgePurchases(): List { val client = connectedBadgeBillingClient() - val params = QueryPurchasesParams.newBuilder().setProductType(BillingClient.ProductType.INAPP).build() + val oneTime = queryBadgePurchases(client, BillingClient.ProductType.INAPP) + // a Play that cannot sell subscriptions holds none; any other failure must not read as no purchases + val subscriptions = + if (client.isFeatureSupported(BillingClient.FeatureType.SUBSCRIPTIONS).responseCode == BillingClient.BillingResponseCode.FEATURE_NOT_SUPPORTED) emptyList() + else queryBadgePurchases(client, BillingClient.ProductType.SUBS) + return (oneTime + subscriptions).mapNotNull(::badgePurchaseOutcome) +} + +private suspend fun queryBadgePurchases(client: BillingClient, productType: String): List { + val params = QueryPurchasesParams.newBuilder().setProductType(productType).build() val queried = CompletableDeferred>() client.queryPurchasesAsync(params) { result, purchases -> if (result.responseCode == BillingClient.BillingResponseCode.OK) { @@ -112,7 +129,7 @@ suspend fun unfinishedBadgePurchases(): List { queried.completeExceptionally(BadgeStoreError.BillingError(result.responseCode, result.debugMessage)) } } - return queried.await().mapNotNull(::badgePurchaseOutcome) + return queried.await() } private val badgePurchasesUpdatedListener = PurchasesUpdatedListener { result, purchases -> @@ -120,7 +137,7 @@ private val badgePurchasesUpdatedListener = PurchasesUpdatedListener { result, p if (pending == null) { // settled outside a purchase call, such as a slow payment completing if (result.responseCode == BillingClient.BillingResponseCode.OK && purchases != null) { - withLongRunningApi { purchases.mapNotNull(::badgePurchaseOutcome).forEach { BadgeStore.reconcile(it) } } + withLongRunningApi { purchases.mapNotNull(::badgePurchaseOutcome).forEach { BadgeStore.reconcileListed(it) } } } return@PurchasesUpdatedListener } @@ -128,15 +145,24 @@ private val badgePurchasesUpdatedListener = PurchasesUpdatedListener { result, p result.responseCode == BillingClient.BillingResponseCode.OK && purchases != null -> { val outcomes = purchases.mapNotNull(::badgePurchaseOutcome) pending.complete(outcomes.firstOrNull() ?: BadgePurchaseOutcome.Cancelled) - withLongRunningApi { outcomes.drop(1).forEach { BadgeStore.reconcile(it) } } + withLongRunningApi { outcomes.drop(1).forEach { BadgeStore.reconcileListed(it) } } } result.responseCode == BillingClient.BillingResponseCode.USER_CANCELED -> pending.complete(BadgePurchaseOutcome.Cancelled) else -> - pending.completeExceptionally(BadgeStoreError.BillingError(result.responseCode, result.debugMessage)) + pending.completeExceptionally(badgePurchaseError(result)) } } +private fun badgePurchaseError(result: BillingResult): BadgeStoreError = when (result.responseCode) { + BillingClient.BillingResponseCode.ITEM_ALREADY_OWNED -> BadgeStoreError.AlreadyOwned + BillingClient.BillingResponseCode.NETWORK_ERROR, + BillingClient.BillingResponseCode.SERVICE_UNAVAILABLE, + BillingClient.BillingResponseCode.SERVICE_DISCONNECTED -> BadgeStoreError.StoreUnreachable + BillingClient.BillingResponseCode.ITEM_UNAVAILABLE -> BadgeStoreError.NotOnSale + else -> BadgeStoreError.BillingError(result.responseCode, result.debugMessage) +} + private fun badgePurchaseOutcome(purchase: Purchase): BadgePurchaseOutcome? = when (purchase.purchaseState) { Purchase.PurchaseState.PENDING -> BadgePurchaseOutcome.Pending(purchase.accountIdentifiers?.obfuscatedAccountId) Purchase.PurchaseState.PURCHASED -> BadgePurchaseOutcome.Purchased( @@ -144,14 +170,22 @@ private fun badgePurchaseOutcome(purchase: Purchase): BadgePurchaseOutcome? = wh token = purchase.purchaseToken, productId = purchase.products.firstOrNull() ?: "", invoiceId = purchase.accountIdentifiers?.obfuscatedAccountId, - acknowledged = purchase.isAcknowledged + acknowledged = purchase.isAcknowledged, + // Play answers false for a one-time product + autoRenewing = if (purchase.products.firstOrNull() in badgeOneTimeProductIds) null else purchase.isAutoRenewing ) ) else -> null } -private suspend fun connectedBadgeBillingClient(): BillingClient { - badgeBillingClient?.let { if (it.isReady) return it } +private suspend fun connectedBadgeBillingClient(): BillingClient = badgeBillingConnection.withLock { + badgeBillingClient?.let { replaced -> + if (replaced.isReady) return@withLock replaced + // ended, it no longer hears the result of a purchase launched on it, which the next sweep finds unfinished + badgePurchase?.completeExceptionally(BadgeStoreError.BillingError(BillingClient.BillingResponseCode.SERVICE_DISCONNECTED, "billing client replaced")) + replaced.endConnection() + badgeBillingClient = null + } val client = BillingClient.newBuilder(androidAppContext) .setListener(badgePurchasesUpdatedListener) .enablePendingPurchases(PendingPurchasesParams.newBuilder().enableOneTimeProducts().build()) @@ -163,7 +197,6 @@ private suspend fun connectedBadgeBillingClient(): BillingClient { } override fun onBillingServiceDisconnected() { - badgeBillingClient = null connected.complete( BillingResult.newBuilder().setResponseCode(BillingClient.BillingResponseCode.SERVICE_DISCONNECTED).build() ) @@ -175,7 +208,7 @@ private suspend fun connectedBadgeBillingClient(): BillingClient { throw BadgeStoreError.BillingError(result.responseCode, result.debugMessage) } badgeBillingClient = client - return client + client } private suspend fun queryBadgeProducts(client: BillingClient, ids: List, productType: String): List { @@ -210,7 +243,8 @@ private fun ProductDetails.badgeOffer(id: BadgeStoreProductId): BadgeOffer? { val product = BadgeProduct(id, purchase.formattedPrice, purchase.priceAmountMicros, purchase.priceCurrencyCode) return BadgeOffer(id, product, this, offerToken = null) } - val offer = subscriptionOfferDetails?.firstOrNull { it.basePlanId == id.basePlanId } + // the base plan's own offer: a promotional offer on the same base plan has an offerId and other pricing phases + val offer = subscriptionOfferDetails?.firstOrNull { it.basePlanId == id.basePlanId && it.offerId == null } if (offer == null) { Log.w(TAG, "badgeOffer: ${id.productId} has no base plan ${id.basePlanId}, Play has ${subscriptionOfferDetails?.map { it.basePlanId }}") return null @@ -231,8 +265,8 @@ suspend fun acknowledgeBadgePurchase(receipt: BadgeStoreReceipt) { if (!receipt.acknowledged) acknowledge(connectedBadgeBillingClient(), receipt.token) } -// consumed if one-time so it can be bought again, else acknowledged, as Play refunds an unacknowledged purchase -// after 3 days; decided by product id, as after a restart there is no ProductDetails for the purchase +// consumed if one-time so it can be bought again; a subscription is acknowledged by the service when it credits it, +// and Play lists it until it ends. Decided by product id, as after a restart there is no ProductDetails for the purchase suspend fun finishBadgePurchase(receipt: BadgeStoreReceipt) { val client = connectedBadgeBillingClient() if (receipt.productId in badgeOneTimeProductIds) { @@ -240,8 +274,15 @@ suspend fun finishBadgePurchase(receipt: BadgeStoreReceipt) { val params = ConsumeParams.newBuilder().setPurchaseToken(receipt.token).build() client.consumeAsync(params) { result, _ -> done.complete(result) } checkBillingResult(done.await()) - } else { - acknowledge(client, receipt.token) + } +} + +fun manageBadgeSubscription(productId: String) { + val page = Uri.parse("https://play.google.com/store/account/subscriptions?sku=$productId&package=${androidAppContext.packageName}") + try { + androidAppContext.startActivity(Intent(Intent.ACTION_VIEW, page).addFlags(Intent.FLAG_ACTIVITY_NEW_TASK)) + } catch (e: ActivityNotFoundException) { + Log.e(TAG, "manageBadgeSubscription: ${e.message}") } } diff --git a/apps/multiplatform/android/src/main/java/chat/simplex/app/SimplexApp.kt b/apps/multiplatform/android/src/main/java/chat/simplex/app/SimplexApp.kt index 9093b1427b..4d05afd855 100644 --- a/apps/multiplatform/android/src/main/java/chat/simplex/app/SimplexApp.kt +++ b/apps/multiplatform/android/src/main/java/chat/simplex/app/SimplexApp.kt @@ -361,6 +361,8 @@ class SimplexApp: Application(), LifecycleEventObserver { override suspend fun androidUnfinishedBadgePurchases(): List = unfinishedBadgePurchases() + override fun androidManageBadgeSubscription(productId: String) = manageBadgeSubscription(productId) + @SuppressLint("SourceLockedOrientationActivity") @Composable override fun androidLockPortraitOrientation() { diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt index 77b084020e..13d5609bfe 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt @@ -130,7 +130,7 @@ object BadgeModel { this.rhId.value == rhId && this.userId.value == userId } -enum class ChatListBanner { BadgeExpired, BadgeIssueFailed, BadgePitch, GetStake } +enum class ChatListBanner { BadgeAlert, BadgePitch, GetStake } data class FileToOpen(val fileId: Long, val inChatList: Boolean) @@ -2330,11 +2330,54 @@ data class BadgeState( val willRenew: Boolean, val alert: BadgeAlert? = null, val issueError: BadgeIssueError? = null, - val nextWakeAt: Instant? = null + val nextWakeAt: Instant? = null, + val subscription: BadgeSubscription? = null ) { val paidThroughText: String get() = badgeDateText(paidThrough) } +@Serializable +data class BadgeSubscription( + val planMonths: Int, + // null until the service or the device's store has been asked + val status: BadgeSubscriptionState? = null, + // the store's reference: Apple's original transaction id, or a hash of Play's token + val transactionRef: String? = null +) + +// the store's state as last observed; a newer core may know a state this version does not +@Serializable(with = BadgeSubscriptionStateSerializer::class) +enum class BadgeSubscriptionState { + Renewing, + Cancelled, + BillingRetry, + Ended, + Unknown; + + // as /_badge subscription takes it, which accepts only the four known states + val text: String + get() = when (this) { + Renewing -> "renewing" + Cancelled -> "cancelled" + BillingRetry -> "billingRetry" + Ended -> "ended" + Unknown -> "unknown" + } +} + +object BadgeSubscriptionStateSerializer : KSerializer { + override val descriptor: SerialDescriptor = PrimitiveSerialDescriptor("BadgeSubscriptionState", PrimitiveKind.STRING) + override fun deserialize(decoder: Decoder): BadgeSubscriptionState = + when (decoder.decodeString()) { + "renewing" -> BadgeSubscriptionState.Renewing + "cancelled" -> BadgeSubscriptionState.Cancelled + "billingRetry" -> BadgeSubscriptionState.BillingRetry + "ended" -> BadgeSubscriptionState.Ended + else -> BadgeSubscriptionState.Unknown + } + override fun serialize(encoder: Encoder, value: BadgeSubscriptionState) = encoder.encodeString(value.text) +} + @Serializable data class BadgeIssueError( val failedSince: Instant, @@ -2519,14 +2562,45 @@ data class BadgeAlert( @Serializable data class BadgeAlertPrice(val amount: Long, val currency: String) -@Serializable -enum class BadgeAlertKind { - @SerialName("renewalApproaching") RenewalApproaching, - @SerialName("paymentIssue") PaymentIssue, - @SerialName("subscriptionEnded") SubscriptionEnded, - @SerialName("prepaidEnding") PrepaidEnding, - @SerialName("supportEnded") SupportEnded, - @SerialName("issueFailed") IssueFailed +// a kind added by a newer core decodes, so the badge state still does, and shows no banner +@Serializable(with = BadgeAlertKindSerializer::class) +sealed class BadgeAlertKind { + object RenewalApproaching: BadgeAlertKind() + object PaymentIssue: BadgeAlertKind() + object SubscriptionCancelled: BadgeAlertKind() + object SubscriptionEnded: BadgeAlertKind() + object PrepaidEnding: BadgeAlertKind() + object SupportEnded: BadgeAlertKind() + object IssueFailed: BadgeAlertKind() + data class Unknown(val kind: String): BadgeAlertKind() + + val text: String + get() = when (this) { + is RenewalApproaching -> "renewalApproaching" + is PaymentIssue -> "paymentIssue" + is SubscriptionCancelled -> "subscriptionCancelled" + is SubscriptionEnded -> "subscriptionEnded" + is PrepaidEnding -> "prepaidEnding" + is SupportEnded -> "supportEnded" + is IssueFailed -> "issueFailed" + is Unknown -> kind + } +} + +object BadgeAlertKindSerializer : KSerializer { + override val descriptor: SerialDescriptor = PrimitiveSerialDescriptor("BadgeAlertKind", PrimitiveKind.STRING) + override fun deserialize(decoder: Decoder): BadgeAlertKind = + when (val v = decoder.decodeString()) { + "renewalApproaching" -> BadgeAlertKind.RenewalApproaching + "paymentIssue" -> BadgeAlertKind.PaymentIssue + "subscriptionCancelled" -> BadgeAlertKind.SubscriptionCancelled + "subscriptionEnded" -> BadgeAlertKind.SubscriptionEnded + "prepaidEnding" -> BadgeAlertKind.PrepaidEnding + "supportEnded" -> BadgeAlertKind.SupportEnded + "issueFailed" -> BadgeAlertKind.IssueFailed + else -> BadgeAlertKind.Unknown(v) + } + override fun serialize(encoder: Encoder, value: BadgeAlertKind) = encoder.encodeString(value.text) } private fun badgeDateText(date: Instant): String { 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 e4fb6d2cd1..bc4b521f9d 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 @@ -602,11 +602,12 @@ object ChatController { } // log = false because a store receipt is a bearer secret, like a badge code - it is in the command. - suspend fun apiPurchaseBadge(rh: Long?, userId: Long, echoedInvoiceId: String?, payment: ServicePayment): BadgePurchaseResult { - val r = sendCmd(rh, CC.ApiPurchaseBadge(userId, echoedInvoiceId, 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) + r is API.Result && r.res is CR.StoreReceiptNotRecorded -> BadgePurchaseResult.NotRecorded r is API.Error -> BadgePurchaseResult.Failed(r.err) else -> { // the response type alone - it names a case or a JSON key, never the service's message @@ -616,6 +617,14 @@ object ChatController { } } + // the device store's view of a subscription it charges, which changes what is shown and alerted, and retires its badge once ended + suspend fun apiSetBadgeSubscriptionStatus(rh: Long?, status: BadgeSubscriptionState, payment: ServicePayment) { + val r = sendCmd(rh, CC.ApiSetBadgeSubscriptionStatus(status, payment), log = false) + if (r is API.Result && r.res is CR.CmdOk) return + if (r is API.Error) throw BadgeStoreError.ApiError(r.err) + throw Exception("apiSetBadgeSubscriptionStatus: unexpected ${r.responseType}") + } + suspend fun apiCreateBadgeInvoice(rh: Long?, userId: Long): String { val r = sendCmd(rh, CC.ApiCreateBadgeInvoice(userId)) if (r is API.Result && r.res is CR.BadgeInvoice) return r.res.invoiceId @@ -633,6 +642,8 @@ object ChatController { return generalGetString(if (purchase) MR.strings.badges_error_service_not_configured_purchase else MR.strings.badges_error_service_not_configured) is BadgeRedeemError.BadgeActive -> return generalGetString(if (purchase) MR.strings.badges_error_already_active_purchase else MR.strings.badges_error_already_active) + is BadgeRedeemError.StorePurchaseOpen -> + return generalGetString(if (purchase) MR.strings.badges_error_store_purchase_open_purchase else MR.strings.badges_error_store_purchase_open) is BadgeRedeemError.ServiceError -> badgeServiceErrorText(e.serviceError)?.let { return it } is BadgeRedeemError.InvalidResponse -> return String.format(generalGetString(MR.strings.badges_error_bad_service_response), e.message) is BadgeRedeemError.UnknownKeyIndex, is BadgeRedeemError.CredentialNotVerified -> return generalGetString(MR.strings.badges_error_credential_not_verified) @@ -3983,6 +3994,8 @@ data class OpenStorePurchase(val invoiceId: String? = null, val transactionRef: sealed class BadgePurchaseResult { class Held(val user: UserRef, val badgeState: BadgeState?, val storePurchases: List): BadgePurchaseResult() class Credited(val user: User, val badgeState: BadgeState?): BadgePurchaseResult() + // listed, and no record here has it: another device's purchase on the same Google account + object NotRecorded: BadgePurchaseResult() // err is null for a response of an unexpected type, which is logged where it is received class Failed(val err: ChatError?): BadgePurchaseResult() } @@ -4167,7 +4180,8 @@ 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 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() class ApiGetBadgeLedger(val userId: Long, val badgePurchaseId: Long): CC() @@ -4394,7 +4408,8 @@ 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" } ?: ""} ${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" is ApiGetBadgeLedger -> "/_badge ledger $userId $badgePurchaseId" @@ -4581,6 +4596,7 @@ sealed class CC { is ApiStandaloneFileInfo -> "apiStandaloneFileInfo" is ApiRedeemBadgeCode -> "apiRedeemBadgeCode" is ApiPurchaseBadge -> "apiPurchaseBadge" + is ApiSetBadgeSubscriptionStatus -> "apiSetBadgeSubscriptionStatus" is ApiCreateBadgeInvoice -> "apiCreateBadgeInvoice" is ApiGetBadgeState -> "apiGetBadgeState" is ApiGetBadgeLedger -> "apiGetBadgeLedger" @@ -4608,7 +4624,10 @@ 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, 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) { is ServicePayment.Google -> ServicePayment.Google(payment.productId, obfuscate(payment.token)) }) else -> this @@ -4650,16 +4669,32 @@ 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 +// /_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 private fun badgeAlertKindParam(kind: BadgeAlertKind): String = when (kind) { - BadgeAlertKind.RenewalApproaching -> "renewal_approaching" - BadgeAlertKind.PaymentIssue -> "payment_issue" - BadgeAlertKind.SubscriptionEnded -> "subscription_ended" - BadgeAlertKind.PrepaidEnding -> "prepaid_ending" - BadgeAlertKind.SupportEnded -> "support_ended" - BadgeAlertKind.IssueFailed -> "issue_failed" + is BadgeAlertKind.RenewalApproaching -> "renewal_approaching" + is BadgeAlertKind.PaymentIssue -> "payment_issue" + is BadgeAlertKind.SubscriptionCancelled -> "subscription_cancelled" + is BadgeAlertKind.SubscriptionEnded -> "subscription_ended" + is BadgeAlertKind.PrepaidEnding -> "prepaid_ending" + is BadgeAlertKind.SupportEnded -> "support_ended" + is BadgeAlertKind.IssueFailed -> "issue_failed" + is BadgeAlertKind.Unknown -> kind.kind +} + +private fun storeReceiptOriginParam(origin: StoreReceiptOrigin): String = when (origin) { + StoreReceiptOrigin.Purchased -> "" + StoreReceiptOrigin.Listed -> " listed" + StoreReceiptOrigin.Restored -> " restored" } @Serializable @@ -6989,6 +7024,7 @@ sealed class CR { // the full user, not UserRef: its profile carries the badge that setUserBadge just stored @Serializable @SerialName("badgeRedeemed") class BadgeRedeemed(val user: User, val redeemedBadge: LocalBadge, val newBadge: Boolean, val badgeState: BadgeState?): CR() @Serializable @SerialName("badgeInvoice") class BadgeInvoice(val user: UserRef, val invoiceId: String): CR() + @Serializable @SerialName("storeReceiptNotRecorded") class StoreReceiptNotRecorded(val user: UserRef): CR() @Serializable @SerialName("badgeState") class BadgeStateR(val user: UserRef, val badgeState: BadgeState?, val storePurchases: List = emptyList()): CR() @Serializable @SerialName("badgeLedger") class BadgeLedger(val user: UserRef, val badgeLedger: List): CR() @Serializable @SerialName("badgeChanged") class BadgeChanged(val user: User, val badgeState: BadgeState?): CR() @@ -7184,6 +7220,7 @@ sealed class CR { is AppSettingsR -> "appSettings" is BadgeRedeemed -> "badgeRedeemed" is BadgeInvoice -> "badgeInvoice" + is StoreReceiptNotRecorded -> "storeReceiptNotRecorded" is BadgeStateR -> "badgeState" is BadgeLedger -> "badgeLedger" is BadgeChanged -> "badgeChanged" @@ -7396,6 +7433,7 @@ sealed class CR { is AppSettingsR -> json.encodeToString(appSettings) is BadgeRedeemed -> withUser(user, "redeemedBadge: ${json.encodeToString(redeemedBadge)}\nnewBadge: $newBadge\nbadgeState: ${json.encodeToString(badgeState)}") is BadgeInvoice -> withUser(user, invoiceId) + is StoreReceiptNotRecorded -> withUser(user, noDetails()) is BadgeStateR -> withUser(user, "${json.encodeToString(badgeState)}\nstorePurchases: ${json.encodeToString(storePurchases)}") is BadgeLedger -> withUser(user, json.encodeToString(badgeLedger)) is BadgeChanged -> withUser(user, json.encodeToString(badgeState)) @@ -7460,6 +7498,7 @@ sealed class BadgeRedeemError { is InvalidReceipt -> "invalidReceipt" is ServiceNotConfigured -> "serviceNotConfigured" is BadgeActive -> "badgeActive" + is StorePurchaseOpen -> "storePurchaseOpen" is ServiceError -> "serviceError ${serviceError.text}" is InvalidResponse -> "invalidResponse $message" is UnknownKeyIndex -> "unknownKeyIndex" @@ -7469,6 +7508,7 @@ sealed class BadgeRedeemError { @Serializable @SerialName("invalidReceipt") object InvalidReceipt : BadgeRedeemError() @Serializable @SerialName("serviceNotConfigured") object ServiceNotConfigured : BadgeRedeemError() @Serializable @SerialName("badgeActive") object BadgeActive : BadgeRedeemError() + @Serializable @SerialName("storePurchaseOpen") object StorePurchaseOpen : BadgeRedeemError() @Serializable @SerialName("serviceError") class ServiceError(val serviceError: BadgeServiceErrorCode) : BadgeRedeemError() @Serializable @SerialName("invalidResponse") class InvalidResponse(val message: String) : BadgeRedeemError() @Serializable @SerialName("unknownKeyIndex") object UnknownKeyIndex : BadgeRedeemError() @@ -7496,6 +7536,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() @@ -7519,6 +7560,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 } @@ -7535,6 +7577,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) @@ -7564,6 +7607,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/platform/Platform.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/platform/Platform.kt index f4e902b967..85b5fcd7f2 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/platform/Platform.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/platform/Platform.kt @@ -48,6 +48,7 @@ interface PlatformInterface { suspend fun androidAcknowledgeBadgePurchase(receipt: BadgeStoreReceipt) {} suspend fun androidFinishBadgePurchase(receipt: BadgeStoreReceipt) {} suspend fun androidUnfinishedBadgePurchases(): List = emptyList() + fun androidManageBadgeSubscription(productId: String) {} val androidApiLevel: Int? get() = null // The build distributed via Google Play, which has to follow its policies val androidIsPlayStoreBuild: Boolean get() = false 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 ed971fc1e5..e0d4af9d48 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 @@ -42,16 +42,12 @@ val badgeStoreProductIds: List = BadgeLevel.entries.flatMap BadgePeriod.entries.map { badgeStoreProductId(level, it) } } -// the only products sent to the badge service: nothing delivers a subscription yet +val badgeProductIds: Set = badgeStoreProductIds.map { it.productId }.toSet() + +// a one-time product is acknowledged when core holds it and consumed when finished; a subscription is +// neither, as the service acknowledges it when it credits it, and Play refunds it if it never does val badgeOneTimeProductIds: Set = badgeStoreProductIds.filter { it.basePlanId == null }.map { it.productId }.toSet() -// subscriptions are for sale once renewals are delivered -val badgePeriodsForSale: List = listOf(BadgePeriod.OneMonth) - -// A subscription's id only: core mints a one-time purchase's, and a subscription is never sent to core. -// Sent to Play as obfuscatedAccountId and echoed back on the purchase. -fun newBadgeInvoiceId(): String = UUID.randomUUID().toString() - // the page's app flag rides in the fragment, which never reaches the service fun badgePageUrl(linkReturns: Boolean): String = if (linkReturns) "https://badges.simplex.chat/#/tier?app=true" @@ -95,7 +91,9 @@ data class BadgeStoreReceipt( val token: String, val productId: String, val invoiceId: String?, - val acknowledged: Boolean = false + val acknowledged: Boolean = false, + // a subscription's, as Play lists it; null for a one-time product + val autoRenewing: Boolean? = null ) // TODO [badges] Play Billing has no offline product configuration. Set to true to price the screens @@ -132,6 +130,9 @@ enum class BadgePurchaseState { sealed class BadgeStoreError: Exception() { class ProductUnavailable(val productId: String): BadgeStoreError() class BillingError(val responseCode: Int, val debugMessage: String): BadgeStoreError() + object AlreadyOwned: BadgeStoreError() + object StoreUnreachable: BadgeStoreError() + object NotOnSale: BadgeStoreError() object StoreUnavailable: BadgeStoreError() object NoActiveProfile: BadgeStoreError() class ApiError(val err: ChatError): BadgeStoreError() @@ -140,12 +141,23 @@ sealed class BadgeStoreError: Exception() { get() = when (this) { is ProductUnavailable -> "productUnavailable(productId: $productId)" is BillingError -> "billingError(responseCode: $responseCode, $debugMessage)" + is AlreadyOwned -> "alreadyOwned" + is StoreUnreachable -> "storeUnreachable" + is NotOnSale -> "notOnSale" is StoreUnavailable -> "storeUnavailable" is NoActiveProfile -> "noActiveProfile" is ApiError -> "apiError(${err.string})" } } +// the sentences iOS shows for the same store failures, in redeemErrorText +fun badgeStoreErrorText(e: Exception): String? = when (e) { + is BadgeStoreError.AlreadyOwned -> generalGetString(MR.strings.badges_error_already_owned) + is BadgeStoreError.StoreUnreachable -> generalGetString(MR.strings.badges_error_store_unreachable) + is BadgeStoreError.NotOnSale -> generalGetString(MR.strings.badges_error_not_on_sale) + else -> null +} + object BadgeStore { private enum class LoadState { NotLoaded, Loading, Loaded, Failed } @@ -191,6 +203,10 @@ object BadgeStore { return if (rhId == chatModel.remoteHostId() && readFor == userId) purchases else emptyList() } + // Play gives a subscription bought again a new token, and refuses to sell one the account still has + @Suppress("UNUSED_PARAMETER") + fun forSale(period: BadgePeriod): Boolean = true + fun price(level: BadgeLevel, period: BadgePeriod, compact: Boolean = true): BadgePrice = when (state.value) { LoadState.NotLoaded, LoadState.Loading -> BadgePrice.Loading LoadState.Loaded, LoadState.Failed -> { @@ -230,16 +246,10 @@ object BadgeStore { } } - // A one-time purchase has its core record before the store charges, and every store outcome reaches it. + // A purchase has its core record before the store charges, and every store outcome reaches it. suspend fun purchase(level: BadgeLevel, period: BadgePeriod): BadgePurchaseOutcome { val id = badgeStoreProductId(level, period) if (!products.value.containsKey(id)) throw BadgeStoreError.ProductUnavailable(id.productId) - // a subscription is never sent to core, so nothing would ever finish it later - if (id.productId !in badgeOneTimeProductIds) { - val outcome = storePurchase(id, newBadgeInvoiceId()) - if (outcome is BadgePurchaseOutcome.Purchased) finish(outcome.receipt) - return outcome - } val rhId = chatModel.remoteHostId() val userId = chatModel.currentUser.value?.userId ?: throw BadgeStoreError.NoActiveProfile val invoiceId = chatModel.controller.apiCreateBadgeInvoice(rhId, userId) @@ -248,7 +258,7 @@ object BadgeStore { try { val outcome = storePurchase(id, invoiceId) if (outcome is BadgePurchaseOutcome.Purchased) { - handOver(outcome.receipt) + handOver(outcome.receipt, StoreReceiptOrigin.Purchased) } return outcome } finally { @@ -260,7 +270,8 @@ object BadgeStore { val outcome = if (useBadgeTestProducts) { BadgePurchaseOutcome.Purchased( BadgeStoreReceipt( - token = "test-${UUID.randomUUID()}", + // the dev service's mock reads a subscription's plan from its token, as Play's real ones name none + token = if (id.basePlanId != null) "test.${id.basePlanId}.${UUID.randomUUID()}" else "test-${UUID.randomUUID()}", productId = id.productId, invoiceId = invoiceId ) @@ -274,13 +285,14 @@ 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) { + 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, 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 - acknowledge(receipt) + // 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 + if (receipt.productId in badgeOneTimeProductIds) acknowledge(receipt) withContext(Dispatchers.Main) { // the answer is the owner's, which may be another profile and a hidden one if (chatModel.controller.activeUser(rhId, r.user)) { @@ -299,11 +311,16 @@ object BadgeStore { } finish(receipt) } + is BadgePurchaseResult.NotRecorded -> { + // left unfinished, for the device that bought it, or for Restore to claim it here + } // a refusal is announced from core's event for it, so only an unexpected answer reaches the buyer is BadgePurchaseResult.Failed -> if (badgeReceiptRefused(r.err)) { Log.e(TAG, "BadgeStore.handOver: ${r.err?.string}") finish(receipt) + // Restore found this purchase, so it says why it was refused rather than that there was nothing to restore + if (origin == StoreReceiptOrigin.Restored && r.err != null) throw BadgeStoreError.ApiError(r.err) } else { throw r.err?.let(BadgeStoreError::ApiError) ?: Exception("apiPurchaseBadge: unexpected response") } @@ -358,7 +375,7 @@ object BadgeStore { val purchases = platform.androidUnfinishedBadgePurchases() // Play lists a purchase awaiting payment, so unlike on iOS the waiting state is re-found here withContext(Dispatchers.Main) { waitingForApproval.value = purchases.mapNotNull { (it as? BadgePurchaseOutcome.Pending)?.invoiceId }.toSet() } - purchases.forEach { reconcile(it) } + purchases.forEach { reconcileListed(it) } } catch (e: Exception) { if (e is CancellationException) throw e Log.e(TAG, "BadgeStore.presentUnfinished: ${e.message}") @@ -368,35 +385,110 @@ object BadgeStore { } finally { withContext(Dispatchers.Main + NonCancellable) { reconciledOnce.value = true } } + reportSubscriptionStates() } - suspend fun reconcile(outcome: BadgePurchaseOutcome) { + // Play lists a Google account's purchases on every device signed into it, so these are handed over as listed + suspend fun reconcileListed(outcome: BadgePurchaseOutcome) { + // the purchase stays unfinished, so the next sweep hands it over again + try { + reconcile(outcome, StoreReceiptOrigin.Listed) + } catch (e: Exception) { + if (e is CancellationException) throw e + Log.e(TAG, "BadgeStore.reconcile: ${e.stackTraceToString()}") + withContext(Dispatchers.Main) { + if (!sweepFailureShown) { + sweepFailureShown = true + AlertManager.shared.showAlertMsg( + title = generalGetString(MR.strings.badges_purchase_error), + text = if (e is BadgeStoreError.ApiError) chatModel.controller.redeemErrorText(e.err, purchase = true) + else badgeStoreErrorText(e) ?: "${generalGetString(MR.strings.error_prefix)}: ${e.message ?: e}" + ) + } + } + } + } + + private suspend fun reconcile(outcome: BadgePurchaseOutcome, origin: StoreReceiptOrigin) { when (outcome) { is BadgePurchaseOutcome.Purchased -> - if (outcome.receipt.productId !in badgeOneTimeProductIds) finish(outcome.receipt) - // the purchase stays unfinished, so the next sweep hands it over again - else try { - handOver(outcome.receipt) - } catch (e: Exception) { - if (e is CancellationException) throw e - Log.e(TAG, "BadgeStore.reconcile: ${e.stackTraceToString()}") - withContext(Dispatchers.Main) { - if (!sweepFailureShown) { - sweepFailureShown = true - AlertManager.shared.showAlertMsg( - title = generalGetString(MR.strings.badges_purchase_error), - text = if (e is BadgeStoreError.ApiError) chatModel.controller.redeemErrorText(e.err, purchase = true) - else "${generalGetString(MR.strings.error_prefix)}: ${e.message ?: e}" - ) - } - } - } + if (outcome.receipt.productId !in badgeProductIds) finish(outcome.receipt) + else handOver(outcome.receipt, origin) is BadgePurchaseOutcome.Pending -> if (outcome.invoiceId != null) withContext(Dispatchers.Main) { waitingForApproval.value += outcome.invoiceId } is BadgePurchaseOutcome.Cancelled -> {} } } + // The service asks the store only once the paid period ends, so a cancellation or a failed charge before + // then is seen only here. Play lists no subscription on hold or expired, so it tells renewing or cancelled only. + suspend fun reportSubscriptionStates() { + // the store's purchases are this device's, so they are told to its own core + if (chatModel.remoteHostId() != null || useBadgeTestProducts || !platform.androidHasPlatformStore) return + try { + val purchases = platform.androidUnfinishedBadgePurchases() + if (purchases.none { (it as? BadgePurchaseOutcome.Purchased)?.receipt?.autoRenewing != null }) return + load() + for (outcome in purchases) { + val receipt = (outcome as? BadgePurchaseOutcome.Purchased)?.receipt ?: continue + val state = when (receipt.autoRenewing) { + true -> BadgeSubscriptionState.Renewing + false -> BadgeSubscriptionState.Cancelled + null -> null + } + if (state != null) { + chatModel.controller.apiSetBadgeSubscriptionStatus(null, state, ServicePayment.Google(receipt.productId, receipt.token)) + } + } + } catch (e: Exception) { + if (e is CancellationException) throw e + Log.e(TAG, "BadgeStore.reportSubscriptionStates: ${e.message}") + } + } + + // Play's page opens over the app, so the foreground sweep re-reads the subscription on return + fun manageSubscriptions(badgeType: BadgeType) { + val level = BadgeLevel.entries.firstOrNull { it.badgeType == badgeType } ?: return + platform.androidManageBadgeSubscription(badgeStoreProductId(level, BadgePeriod.Monthly).productId) + } + + // 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. + suspend fun restorePurchases(): Boolean { + var handOverError: Exception? = null + val purchases = if (useBadgeTestProducts) emptyList() else platform.androidUnfinishedBadgePurchases() + for (outcome in purchases) { + try { + reconcile(outcome, StoreReceiptOrigin.Restored) + } catch (e: Exception) { + if (e is CancellationException) throw e + Log.e(TAG, "BadgeStore.restorePurchases: ${e.stackTraceToString()}") + if (handOverError == null) handOverError = e + } + } + reportSubscriptionStates() + val rhId = chatModel.remoteHostId() + chatModel.controller.loadBadgeState(rhId) + val restored = withContext(Dispatchers.Main) { + val userId = chatModel.currentUser.value?.userId + val badgeShown = BadgeModel.isCurrent(rhId, userId) && BadgeModel.badgeState.value?.shown == true + badgeShown || purchaseState(userId) != null + } + if (!restored && handOverError != null) throw handOverError + return restored + } + + fun subscriptionPrice(badgeType: BadgeType, planMonths: Int): String? { + val period = when (planMonths) { + 1 -> BadgePeriod.Monthly + 12 -> BadgePeriod.Annual + else -> null + } + val level = BadgeLevel.entries.firstOrNull { it.badgeType == badgeType } + if (period == null || level == null) return null + return products.value[badgeStoreProductId(level, period)]?.displayPrice + } + private suspend fun acknowledge(receipt: BadgeStoreReceipt) { try { if (!useBadgeTestProducts) platform.androidAcknowledgeBadgePurchase(receipt) @@ -441,7 +533,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/kotlin/chat/simplex/common/views/badges/BadgesCheckOrderView.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesCheckOrderView.kt index fbb3d1a017..ce3a775efb 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesCheckOrderView.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesCheckOrderView.kt @@ -1,6 +1,7 @@ package chat.simplex.common.views.badges import androidx.compose.foundation.background +import androidx.compose.foundation.clickable import androidx.compose.foundation.layout.* import androidx.compose.foundation.shape.RoundedCornerShape import androidx.compose.material.* @@ -17,6 +18,7 @@ import chat.simplex.common.platform.* import chat.simplex.common.ui.theme.* import chat.simplex.common.views.helpers.* import chat.simplex.common.views.onboarding.OnboardingActionButton +import chat.simplex.common.views.usersettings.networkAndServers.ConditionsTextView import chat.simplex.res.* @Composable @@ -55,15 +57,49 @@ fun BadgesCheckOrderView(level: BadgeLevel, period: BadgePeriod, modalManager: M OrderRow(MR.strings.badges_order_total, period.priceText(BadgeStore.price(level, period, compact = false))) } + val price = BadgeStore.price(level, period, compact = false) + if (price is BadgePrice.Price) { + when (period) { + BadgePeriod.Monthly -> Footnote(String.format(stringResource(MR.strings.badges_subscription_disclosure_monthly), price.price)) + BadgePeriod.Annual -> Footnote(String.format(stringResource(MR.strings.badges_subscription_disclosure_annual), price.price)) + BadgePeriod.OneMonth -> {} + } + } + Spacer(Modifier.weight(1f).heightIn(min = 20.dp)) Column(horizontalAlignment = Alignment.CenterHorizontally) { PayButton(level, period, purchasing) BadgeBillingFooter(period) + Text( + stringResource(MR.strings.badges_privacy_policy), + Modifier.clickable { modalManager.showModal { BadgeConditionsView() } }, + style = MaterialTheme.typography.body2, + color = MaterialTheme.colors.primary + ) } } } +@Composable +private fun BadgeConditionsView() { + ColumnWithScrollBar(Modifier.fillMaxSize().padding(horizontal = DEFAULT_PADDING)) { + AppBarTitle(stringResource(MR.strings.badges_privacy_policy), enableAlphaChanges = false, withPadding = false, bottomPadding = DEFAULT_PADDING) + Column(Modifier.weight(1f).padding(bottom = DEFAULT_PADDING, top = DEFAULT_PADDING_HALF)) { + ConditionsTextView(chatModel.remoteHostId()) + } + } +} + +@Composable +private fun Footnote(text: String) { + Text( + text, + style = MaterialTheme.typography.body2, + color = MaterialTheme.colors.secondary + ) +} + @Composable private fun OrderRow(title: StringResource, value: String) { Row(Modifier.fillMaxWidth().padding(vertical = 8.dp)) { @@ -99,9 +135,48 @@ private fun purchase(level: BadgeLevel, period: BadgePeriod, purchasing: Mutable purchasing.value = false AlertManager.shared.showAlertMsg( title = generalGetString(MR.strings.badges_purchase_error), - text = if (e is BadgeStoreError.ApiError) chatModel.controller.redeemErrorText(e.err, purchase = true) - else "${generalGetString(MR.strings.error_prefix)}: ${e.message ?: e}" + text = when (e) { + is BadgeStoreError.ApiError -> chatModel.controller.redeemErrorText(e.err, purchase = true) + else -> badgeStoreErrorText(e) ?: "${generalGetString(MR.strings.error_prefix)}: ${e.message ?: e}" + } ) } } } + +// the store rows act on this device's store, which a profile on a remote host cannot use +val badgeStoreLane: Boolean get() = badgeStoreAvailable && chatModel.remoteHostId() == null + +@Composable +fun RestorePurchasesButton() { + val restoring = remember { mutableStateOf(false) } + Text( + stringResource(MR.strings.badges_restore_purchases), + Modifier.clickable(enabled = !restoring.value) { restoreBadgePurchases(restoring) }, + style = MaterialTheme.typography.body2, + color = MaterialTheme.colors.primary + ) +} + +fun restoreBadgePurchases(restoring: MutableState) { + restoring.value = true + withLongRunningApi { + try { + val found = BadgeStore.restorePurchases() + if (!found) { + AlertManager.shared.showAlertMsg( + title = generalGetString(MR.strings.badges_nothing_to_restore), + text = generalGetString(MR.strings.badges_nothing_to_restore_desc) + ) + } + } catch (e: Exception) { + Log.e(TAG, "RestorePurchasesButton: ${e.stackTraceToString()}") + AlertManager.shared.showAlertMsg( + title = generalGetString(MR.strings.badges_restore_failed), + text = if (e is BadgeStoreError.ApiError) chatModel.controller.redeemErrorText(e.err, purchase = true) + else badgeStoreErrorText(e) ?: "${generalGetString(MR.strings.error_prefix)}: ${e.message ?: e}" + ) + } + restoring.value = false + } +} diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesHowLongView.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesHowLongView.kt index 8b58049276..db1586853a 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesHowLongView.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesHowLongView.kt @@ -75,7 +75,9 @@ enum class BadgePeriod { @Composable fun BadgesHowLongView(level: BadgeLevel, modalManager: ModalManager, unwindToDepth: Int) { - var selectedPeriod by remember { mutableStateOf(if (BadgePeriod.Monthly in badgePeriodsForSale) BadgePeriod.Monthly else BadgePeriod.OneMonth) } + var chosenPeriod by remember { mutableStateOf(null) } + // monthly once subscriptions turn out to be for sale, unless a period was chosen before that + val selectedPeriod = chosenPeriod ?: (if (BadgeStore.forSale(BadgePeriod.Monthly)) BadgePeriod.Monthly else BadgePeriod.OneMonth) LaunchedEffect(Unit) { BadgeStore.load() } CloseWhenSupportGivesWay(modalManager, unwindToDepth) @@ -114,14 +116,14 @@ fun BadgesHowLongView(level: BadgeLevel, modalManager: ModalManager, unwindToDep horizontalArrangement = Arrangement.spacedBy(12.dp) ) { BadgePeriod.entries.forEach { period -> - PeriodCard(level, period, selectedPeriod, Modifier.weight(1f).fillMaxHeight()) { selectedPeriod = it } + PeriodCard(level, period, selectedPeriod, Modifier.weight(1f).fillMaxHeight()) { chosenPeriod = it } } } Spacer(Modifier.weight(1f).heightIn(min = 8.dp)) Column(horizontalAlignment = Alignment.CenterHorizontally) { - ContinueButton(level, selectedPeriod, modalManager, unwindToDepth) + ContinueButton(level, selectedPeriod, modalManager, unwindToDepth) { chosenPeriod = it } BadgeBillingFooter(selectedPeriod) } } @@ -145,7 +147,7 @@ fun BadgeBillingFooter(period: BadgePeriod) { @Composable private fun PeriodCard(level: BadgeLevel, period: BadgePeriod, selectedPeriod: BadgePeriod, modifier: Modifier, onSelect: (BadgePeriod) -> Unit) { val isSelected = period == selectedPeriod - val forSale = period in badgePeriodsForSale + val forSale = BadgeStore.forSale(period) val textColor = if (forSale) Color.Unspecified else MaterialTheme.colors.secondary val borderColor = if (isSelected) MaterialTheme.colors.primary else MaterialTheme.colors.background.mixWith(MaterialTheme.colors.onBackground, 0.92f) // Light: transparent so card matches page background. Dark: subtle gray tint for visible contrast. @@ -186,12 +188,13 @@ private fun savingsPercent(level: BadgeLevel, period: BadgePeriod): Int? = if (period == BadgePeriod.Annual) BadgeStore.annualSavings(level) else null @Composable -private fun ContinueButton(level: BadgeLevel, selectedPeriod: BadgePeriod, modalManager: ModalManager, unwindToDepth: Int) { +private fun ContinueButton(level: BadgeLevel, selectedPeriod: BadgePeriod, modalManager: ModalManager, unwindToDepth: Int, choosePeriod: (BadgePeriod) -> Unit) { OnboardingActionButton( modifier = if (appPlatform.isAndroid) Modifier.padding(horizontal = DEFAULT_ONBOARDING_HORIZONTAL_PADDING).fillMaxWidth() else Modifier.widthIn(min = 300.dp), labelId = MR.strings.badges_continue, onboarding = null, onclick = { + choosePeriod(selectedPeriod) modalManager.showModal(cardScreen = true) { BadgesCheckOrderView(level, selectedPeriod, modalManager, unwindToDepth) } } ) diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesSupportSimplexView.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesSupportSimplexView.kt index c0e1c968b9..da1a656af9 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesSupportSimplexView.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesSupportSimplexView.kt @@ -63,24 +63,26 @@ fun BadgesSupportSimplexView(modalManager: ModalManager, unwindToDepth: Int) { Spacer(Modifier.weight(1f)) - // In-app purchase is not released: the badge is chosen on the site, and the code redeemed - // here. Revert this commit to restore the block below. - // Column(horizontalAlignment = Alignment.CenterHorizontally) { - // if (badgeStoreAvailable) { - // ChooseLevelButton(modalManager, unwindToDepth) - // if (badgeBrowserAllowed()) { - // BuyInBrowserTextButton() - // } else { - // RedeemCodeButton(modalManager, unwindToDepth) - // } - // } else { - // BuyInBrowserButton(modalManager, unwindToDepth) - // RedeemCodeButton(modalManager, unwindToDepth) - // } - // } Column(horizontalAlignment = Alignment.CenterHorizontally) { - ChooseBadgeOnSiteButton(modalManager, unwindToDepth) - RedeemCodeButton(modalManager, unwindToDepth) + if (badgeStoreAvailable) { + ChooseLevelButton(modalManager, unwindToDepth) + if (badgeBrowserAllowed()) { + BuyInBrowserTextButton() + } else { + RedeemCodeButton(modalManager, unwindToDepth) + } + RestorePurchasesButton() + Text( + stringResource(MR.strings.badges_restore_purchases_footnote), + Modifier.padding(top = DEFAULT_PADDING_HALF), + style = MaterialTheme.typography.body2, + color = MaterialTheme.colors.secondary, + textAlign = TextAlign.Center + ) + } else { + BuyInBrowserButton(modalManager, unwindToDepth) + RedeemCodeButton(modalManager, unwindToDepth) + } } } } @@ -140,25 +142,6 @@ private fun BuyInBrowserTextButton() { ) } -// In-app purchase is not released: delete with the commented block above to restore it. -@Composable -private fun ChooseBadgeOnSiteButton(modalManager: ModalManager, unwindToDepth: Int) { - val uriHandler = LocalUriHandler.current - OnboardingActionButton( - modifier = if (appPlatform.isAndroid) Modifier.padding(horizontal = DEFAULT_ONBOARDING_HORIZONTAL_PADDING).fillMaxWidth() else Modifier.widthIn(min = 300.dp), - labelId = MR.strings.badges_choose_your_badge_title, - onboarding = null, - onclick = { - val linkReturns = appLinkSchemeRegistered() - uriHandler.openUriCatching(badgePageUrl(linkReturns)) - // with no scheme to bring the code back, the code is pasted into this screen, opened beside the browser - if (!linkReturns && !modalManager.hasModalOpen(ModalViewId.BADGE_REDEEM_CODE)) { - modalManager.showModal(id = ModalViewId.BADGE_REDEEM_CODE) { BadgesRedeemCodeView(modalManager, unwindToDepth) } - } - } - ) -} - @Composable private fun BuyInBrowserButton(modalManager: ModalManager, unwindToDepth: Int) { val uriHandler = LocalUriHandler.current diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesYourBadgeView.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesYourBadgeView.kt index f6f6ecb12d..a295abd0aa 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesYourBadgeView.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesYourBadgeView.kt @@ -7,6 +7,7 @@ import SectionTextFooter import SectionView import androidx.compose.foundation.Image import androidx.compose.foundation.layout.* +import androidx.compose.material.Icon import androidx.compose.material.MaterialTheme import androidx.compose.material.Text import androidx.compose.runtime.Composable @@ -22,6 +23,8 @@ import androidx.compose.ui.unit.dp import dev.icerock.moko.resources.compose.painterResource import dev.icerock.moko.resources.compose.stringResource import chat.simplex.common.model.BadgeState +import chat.simplex.common.model.BadgeSubscriptionState +import chat.simplex.common.model.BadgeType import chat.simplex.common.model.ChatController.appPrefs import chat.simplex.common.model.localTimestamp import chat.simplex.common.platform.ColumnWithScrollBar @@ -35,6 +38,7 @@ import chat.simplex.common.views.helpers.openVerifiedSimplexUri import chat.simplex.common.views.usersettings.SettingsActionItem import chat.simplex.common.views.usersettings.simplexTeamUri import chat.simplex.res.* +import kotlinx.datetime.Clock @Composable fun BadgesYourBadgeView(badgeState: BadgeState, modalManager: ModalManager) { @@ -45,11 +49,67 @@ fun BadgesYourBadgeView(badgeState: BadgeState, modalManager: ModalManager) { BadgeSummary(badgeState) } SectionSpacer() - SectionView(stringResource(MR.strings.badges_ends)) { - Text(badgeState.paidThroughText, Modifier.padding(horizontal = DEFAULT_PADDING, vertical = 12.dp)) + val subscription = badgeState.subscription + if (subscription != null) { + val ended = badgeState.paidThrough <= Clock.System.now() + val date = badgeState.paidThroughText + when (subscription.status) { + BadgeSubscriptionState.BillingRetry -> + SubscriptionSection( + badgeState.badgeType, + footer = stringResource(if (badgeStoreLane) MR.strings.badges_payment_problem_footer else MR.strings.badges_payment_problem_footer_store) + ) { + Icon(painterResource(MR.images.ic_warning), null, tint = Color.Red) + Spacer(Modifier.width(6.dp)) + Text(stringResource(MR.strings.badges_payment_problem)) + } + BadgeSubscriptionState.Cancelled -> + if (!ended) { + SubscriptionSection(badgeState.badgeType, footer = String.format(stringResource(MR.strings.badges_subscription_cancelled_footer), date)) { + Text(String.format(stringResource(MR.strings.badges_subscription_ends), date)) + } + } else { + SubscriptionSection(badgeState.badgeType, footer = stringResource(MR.strings.badges_subscription_ended_footer)) { + Text(stringResource(MR.strings.badges_subscription_ended)) + } + } + BadgeSubscriptionState.Ended -> + SubscriptionSection(badgeState.badgeType, footer = stringResource(MR.strings.badges_subscription_ended_footer)) { + Text(stringResource(MR.strings.badges_subscription_ended)) + } + BadgeSubscriptionState.Renewing, BadgeSubscriptionState.Unknown, null -> { + val price = BadgeStore.subscriptionPrice(badgeState.badgeType, subscription.planMonths) + if (ended) { + SubscriptionSection( + badgeState.badgeType, + footer = stringResource(if (badgeStoreLane) MR.strings.badges_subscription_renewing_footer else MR.strings.badges_subscription_renewing_footer_store) + ) { + Text(stringResource(MR.strings.badges_subscription_renewing)) + } + } else if (price != null) { + SubscriptionSection( + badgeState.badgeType, + footer = stringResource(if (badgeStoreLane) MR.strings.badges_subscription_renews_footer else MR.strings.badges_subscription_renews_footer_store) + ) { + Text(String.format(stringResource(MR.strings.badges_subscription_renews_price), date, price)) + } + } else { + SubscriptionSection( + badgeState.badgeType, + footer = stringResource(if (badgeStoreLane) MR.strings.badges_subscription_renews_footer else MR.strings.badges_subscription_renews_footer_store) + ) { + Text(String.format(stringResource(MR.strings.badges_subscription_renews), date)) + } + } + } + } + } else { + SectionView(stringResource(MR.strings.badges_ends)) { + Text(badgeState.paidThroughText, Modifier.padding(horizontal = DEFAULT_PADDING, vertical = 12.dp)) + } + SectionTextFooter(stringResource(MR.strings.badges_prepaid_footer)) + SectionSpacer() } - SectionTextFooter(stringResource(MR.strings.badges_prepaid_footer)) - SectionSpacer() SectionView { SettingsActionItem( painterResource(MR.images.ic_info), @@ -107,6 +167,23 @@ fun BadgesYourBadgeView(badgeState: BadgeState, modalManager: ModalManager) { } } +@Composable +private fun SubscriptionSection(badgeType: BadgeType, footer: String, status: @Composable RowScope.() -> Unit) { + SectionView(stringResource(MR.strings.badges_subscription)) { + SectionItemView(content = status) + if (badgeStoreLane) { + SettingsActionItem( + painterResource(MR.images.ic_open_in_new), + stringResource(MR.strings.badges_manage_subscription), + { BadgeStore.manageSubscriptions(badgeType) }, + textColor = MaterialTheme.colors.primary + ) + } + } + SectionTextFooter(footer) + SectionSpacer() +} + @Composable fun BadgeSummary(badgeState: BadgeState) { Column( diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt index 52cb2b338b..1ce01f4a69 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt @@ -64,6 +64,28 @@ sealed class ActiveFilter { data object Unread: ActiveFilter() } +private fun renewalPrice(): String? { + val badgeState = BadgeModel.badgeState.value ?: return null + val subscription = badgeState.subscription ?: return null + return BadgeStore.subscriptionPrice(badgeState.badgeType, subscription.planMonths) +} + +private fun renewalFailure(): String { + val issueError = BadgeModel.badgeState.value?.issueError ?: return generalGetString(MR.strings.badges_renewal_failed_unknown) + return issueError.reason.text +} + +@Composable +private fun BadgeAlertBanner(title: String, subtitle: String, warning: Boolean = false) { + SupportSimpleXBanner( + title = title, + subtitle = subtitle, + warning = warning, + onTap = { ModalManager.start.showCustomModal(id = ModalViewId.BADGES) { close -> BadgesView(ModalManager.start, close) } }, + onDismiss = { showBadgeAlertDismissAlert(title) } + ) +} + private fun showBadgeAlertDismissAlert(title: String) { AlertManager.shared.showAlertDialogButtonsColumn( title = title, @@ -1072,31 +1094,33 @@ private fun BoxScope.ChatList(searchText: MutableState, listStat ToggleChatListCard() } } - // one slot: a badge the user paid for ending outranks the pitch to get one - val alert = BadgeModel.alert.value - if (supportEnded() && alert != null) { + // one slot: an alert about a badge the user paid for outranks the pitch to get one + val alert = bannerBadgeAlert() + if (alert != null) { item { - SideEffect { chatModel.chatListBanner = ChatListBanner.BadgeExpired } + SideEffect { chatModel.chatListBanner = ChatListBanner.BadgeAlert } Box(Modifier.zIndex(1f).padding(16.dp)) { - SupportSimpleXBanner( - title = stringResource(MR.strings.badges_support_ended), - subtitle = String.format(stringResource(MR.strings.badges_support_ended_on), alert.dateText), - onTap = { ModalManager.start.showCustomModal(id = ModalViewId.BADGES) { close -> BadgesView(ModalManager.start, close) } }, - onDismiss = { showBadgeAlertDismissAlert(generalGetString(MR.strings.badges_support_ended)) } - ) - } - } - } else if (badgeIssueFailed()) { - item { - SideEffect { chatModel.chatListBanner = ChatListBanner.BadgeIssueFailed } - Box(Modifier.zIndex(1f).padding(16.dp)) { - SupportSimpleXBanner( - title = stringResource(MR.strings.badges_renewal_failed), - subtitle = stringResource(MR.strings.badges_tap_for_details), - warning = true, - onTap = { ModalManager.start.showCustomModal(id = ModalViewId.BADGES) { close -> BadgesView(ModalManager.start, close) } }, - onDismiss = { showBadgeAlertDismissAlert(generalGetString(MR.strings.badges_renewal_failed)) } - ) + when (alert.kind) { + is BadgeAlertKind.SupportEnded -> + BadgeAlertBanner(stringResource(MR.strings.badges_support_ended), String.format(stringResource(MR.strings.badges_support_ended_on), alert.dateText)) + is BadgeAlertKind.IssueFailed -> + BadgeAlertBanner(stringResource(MR.strings.badges_renewal_failed), renewalFailure(), warning = true) + is BadgeAlertKind.SubscriptionEnded -> + BadgeAlertBanner(stringResource(MR.strings.badges_subscription_ended_title), String.format(stringResource(MR.strings.badges_subscription_ended_on), alert.dateText)) + is BadgeAlertKind.PaymentIssue -> + BadgeAlertBanner(stringResource(MR.strings.badges_payment_problem_title), stringResource(MR.strings.badges_payment_problem_subtitle), warning = true) + is BadgeAlertKind.SubscriptionCancelled -> + BadgeAlertBanner(stringResource(MR.strings.badges_subscription_cancelled_title), String.format(stringResource(MR.strings.badges_stays_until), alert.dateText)) + is BadgeAlertKind.RenewalApproaching -> { + val price = renewalPrice() + if (price != null) { + BadgeAlertBanner(stringResource(MR.strings.badges_renews_soon), String.format(stringResource(MR.strings.badges_renews_on_for), alert.dateText, price)) + } else { + BadgeAlertBanner(stringResource(MR.strings.badges_renews_soon), String.format(stringResource(MR.strings.badges_renews_on), alert.dateText)) + } + } + is BadgeAlertKind.PrepaidEnding, is BadgeAlertKind.Unknown -> {} + } } } } else if (chatModel.bannerSlotFree(ChatListBanner.BadgePitch) && !supporterBannerShown.value && noShownBadge() && chatModel.chats.value.size > 3) { diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/newchat/OnboardingCards.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/newchat/OnboardingCards.kt index cf708c72d8..89be582fa1 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/newchat/OnboardingCards.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/newchat/OnboardingCards.kt @@ -46,20 +46,25 @@ import kotlin.math.sin private const val CARD_HEIGHT_RATIO = 0.75f private const val GRADIENT_ANGLE_RAD = 80.0 * Math.PI / 180.0 -// the onboarding cards replace the whole chat list, and the support-ended banner lives in the -// list - a lapsed supporter is not a newcomer, and must be told even with no conversations yet +// the onboarding cards replace the whole chat list, and the badge alert banner lives in the +// list - a supporter is not a newcomer, and must be told even with no conversations yet @Composable fun shouldShowOnboarding(): Boolean { val addressCreationCardShown = remember { appPrefs.addressCreationCardShown.state } val chats = chatModel.chats.value - return !addressCreationCardShown.value && chats.isNotEmpty() && !hasConversations(chats) && !supportEnded() && !badgeIssueFailed() + return !addressCreationCardShown.value && chats.isNotEmpty() && !hasConversations(chats) && bannerBadgeAlert() == null } -fun supportEnded(): Boolean = - BadgeModel.alert.value?.kind == BadgeAlertKind.SupportEnded && BadgeModel.isCurrent(chatModel.remoteHostId(), chatModel.currentUser.value?.userId) - -fun badgeIssueFailed(): Boolean = - BadgeModel.alert.value?.kind == BadgeAlertKind.IssueFailed && BadgeModel.isCurrent(chatModel.remoteHostId(), chatModel.currentUser.value?.userId) +// the current profile's badge alert, if it is a kind the chat list has a banner for +fun bannerBadgeAlert(): BadgeAlert? { + val alert = BadgeModel.alert.value + if (alert == null || !BadgeModel.isCurrent(chatModel.remoteHostId(), chatModel.currentUser.value?.userId)) return null + return when (alert.kind) { + is BadgeAlertKind.SupportEnded, is BadgeAlertKind.IssueFailed, is BadgeAlertKind.SubscriptionEnded, + is BadgeAlertKind.PaymentIssue, is BadgeAlertKind.SubscriptionCancelled, is BadgeAlertKind.RenewalApproaching -> alert + is BadgeAlertKind.PrepaidEnding, is BadgeAlertKind.Unknown -> null + } +} // false until the badge state loads: if the pitch rendered before that, it would lock the slot, and a supporter's badge // arriving a moment later would hide it, leaving the slot empty for the session 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 9f59c7dc3d..e1023b9887 100644 --- a/apps/multiplatform/common/src/commonMain/moko-resources/base/strings.xml +++ b/apps/multiplatform/common/src/commonMain/moko-resources/base/strings.xml @@ -3249,6 +3249,8 @@ This app version cannot buy badges. This profile already has a badge. Redeem the code on another profile, or once this badge ends. This profile already has a badge. + A store purchase is being added to this profile. Redeem the code once it is added, or on another profile. + A store purchase is being added to this profile. This code was not recognized. This code has already been used. This code has expired. @@ -3260,6 +3262,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. @@ -3297,7 +3300,7 @@ From purchase key To purchase key Badge renewal failed - Tap for details + Your badge could not be renewed. The badge service refused the renewal: %1$s The badge service refused the purchase: %1$s The badge service did not respond. @@ -3308,6 +3311,42 @@ Last attempt Contact SimpleX team Next check + Payment is charged to your Google Play account when you confirm the purchase. The subscription renews automatically at %1$s per month until you cancel it. You can manage and cancel it in Google Play subscriptions. + Payment is charged to your Google Play account when you confirm the purchase. The subscription renews automatically at %1$s per year until you cancel it. You can manage and cancel it in Google Play subscriptions. + Privacy policy + Restore purchases + Adds a badge you paid for. A subscription bought with this Google Play account moves to this profile, and the profile or device that had it loses it. + Nothing to restore + No Google Play purchase waiting to be added was found. + Restore failed + This Google Play account already has this purchase, on another profile or device. To add it to this profile, use Restore purchases. + The store could not be reached. + This badge is not on sale. + Subscription + Manage subscription + Payment problem + Google Play could not charge your payment method and is retrying. Update it to keep your badge. Until the payment goes through, you cannot buy or redeem another badge. + The store could not charge your payment method and is retrying. Update it to keep your badge. Until the payment goes through, you cannot buy or redeem another badge. + Ends %1$s + Your subscription is cancelled. The badge stays until %1$s. + Ended + Your subscription has ended. The badge will be removed from your profile. + Renewing + Your badge is renewed once Google Play charges your subscription. Until then you cannot buy or redeem another badge. + Your badge is renewed once the store charges your subscription. Until then you cannot buy or redeem another badge. + Renews %1$s ยท %2$s + Renews %1$s + Your subscription renews automatically. You can cancel it in Google Play. + Your subscription renews automatically. You can cancel it in the store. + Your subscription ended + Your badge subscription ended on %1$s. + Badge payment problem + The store could not charge your payment method. + Subscription cancelled + Your badge stays until %1$s. + Your badge renews soon + Renews on %1$s for %2$s. + Renews on %1$s. Supporter perks Supporter badge โค๏ธ Help keep the network running โ€” send files up to 2 GB. diff --git a/apps/multiplatform/product/gaps.md b/apps/multiplatform/product/gaps.md index 7e8f841775..2caf213e0e 100644 --- a/apps/multiplatform/product/gaps.md +++ b/apps/multiplatform/product/gaps.md @@ -15,6 +15,7 @@ This document catalogs known gaps in the multiplatform codebase (Android and Des 7. [Desktop: Cryptor Not Implemented](#gap-07-desktop-cryptor-not-implemented) 8. [Desktop: App Link Registration](#gap-08-desktop-app-link-registration) 9. [Desktop: Emoji Picker Without Skin Tones and Localized Search](#gap-09-desktop-emoji-picker-without-skin-tones-and-localized-search) +10. [Badges: Limits on Moving a Badge to a New Device or Profile](#gap-10-badges-limits-on-moving-a-badge-to-a-new-device-or-profile) --- @@ -349,3 +350,30 @@ Desktop users cannot pick a skin tone in the picker, and search in other languag 1. Keep the skin tone variants in the generated data, grouped by base emoji, and add a skin tone choice to the picker. 2. Add localized names (CLDR annotations) to the generated data for search. + +--- + +## GAP-10: Badges: Limits on Moving a Badge to a New Device or Profile + +**Severity:** Low +**Category:** Feature / Payments +**Platforms:** Android + +### 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 hands over the subscriptions in Play's list as restored, and the service moves the subscription to the restoring profile's purchase key. Restore is refused while the restoring profile shows a badge. A payment moves again only once the credential issued to the key it last moved from has expired; until then the move is refused `transfer_limited`. The first Restore's own answer doesn't say so: the app hears of the refusal only from core's purchase-refused event, which core sends only for a record holding an invoice id, and the next Restore is answered `transfer_limited` itself. A badge bought with Stripe or crypto cannot be moved at all. The app starts no plan change, and when tested Play's own pages offered none for these products; a plan change made there, should one become possible, would get a new token, which the app's sweep finds but core does not record, so only Restore claims it, and not under a profile that shows a badge, so the profile showing the old badge claims it only once that badge ends; until then it stays unacknowledged, which Play refunds after three days. + +### Affected Locations + +- `common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt` -- `restorePurchases()` +- `../../apps/simplex-badge-service/src/BadgeService/Service.hs` -- the move limit + +### Impact + +A subscriber who moves the badge again before the previous key's credential expires waits until it does, and the first such Restore may give no reason. A badge bought with Stripe or crypto stays with the profile it was credited to. Should Play offer a plan change for these products, a subscriber who makes one keeps the old badge until its paid months end, or until the service reads the old subscription ended at a month's check, and can lose the new plan to Play's refund before it is credited. + +### Recommendation + +1. Restore by a receipt code for Stripe and crypto purchases, shared with iOS. +2. Announce a limited move on the first Restore. +3. Before a Play plan change becomes possible, credit its new token without waiting for Restore. diff --git a/apps/multiplatform/spec/client/chat-list.md b/apps/multiplatform/spec/client/chat-list.md index 5a63ad92bc..64f7fefc87 100644 --- a/apps/multiplatform/spec/client/chat-list.md +++ b/apps/multiplatform/spec/client/chat-list.md @@ -339,7 +339,7 @@ Gradient card inviting the user to invest on Wefunder. Shown only when `crowdfun | Chat list | in `ChatList`'s `LazyColumn`, after `ToggleChatListCard` and before the chats | `Box(Modifier.zIndex(1f).padding(16.dp))` | | Onboarding | inside `ConnectOnboardingView` (`views/newchat/OnboardingCards.kt`), below the pager, so it shares the pages' width limit on desktop and their dimming while a start modal is open; opens the page in `ModalManager.center` on desktop, `ModalManager.start` on Android | `padding(start/end = DEFAULT_PADDING, bottom = 8.dp)`, in a `Column` where the pager takes `weight(1f)` | -The list has a single banner slot, filled by an `if`/`else if` chain in priority order: the support-ended alert (`supportEnded()`), the renewal-failure alert (`badgeIssueFailed()`), the pitch, then the Wefunder banner. Each banner's `item` records itself in `ChatModel.chatListBanner` (`BadgeExpired`, `BadgeIssueFailed`, `BadgePitch`, `GetStake`) in a `SideEffect`, and the pitch and Wefunder conditions start with `chatModel.bannerSlotFree(banner)` โ€” true only while nothing else was shown this app session โ€” so dismissing a banner never puts another in its place until restart. The alerts have no such check: an alert takes the slot whenever present, and once shown it holds it. The pitch also requires `noShownBadge()` (`views/newchat/OnboardingCards.kt`), false until `BadgeModel.isCurrent` for the current user, so it cannot take the slot from a supporter whose badge loads a moment later. `ConnectOnboardingView` applies the same `bannerSlotFree` check and records `GetStake`. +The list has a single banner slot, filled by an `if`/`else if` chain in priority order: the badge alert banner, the pitch, then the Wefunder banner. The badge alert banner shows `bannerBadgeAlert()` (`views/newchat/OnboardingCards.kt`), the current profile's alert when its kind has a banner (support ended, renewal failed, subscription ended, payment problem, subscription cancelled, renewal soon; not prepaid ending or a kind from a newer core), and one `when` over the kind at the banner site picks its title, subtitle and warning colour; its X leads to the same remind-later or dismiss alert for every kind. The renewal-failed subtitle is `renewalFailure()`: the reason in `BadgeModel.badgeState`'s `issueError` (`BadgeIssueFailure.text`), or `badges_renewal_failed_unknown` ("Your badge could not be renewed.") when the state carries none, as after an alert that arrives without a new state; the payment-problem subtitle is `badges_payment_problem_subtitle` ("The store could not charge your payment method."), not `issueError`, which in billing retry is a failed renewal request rather than the payment's reason. Each banner's `item` records itself in `ChatModel.chatListBanner` (`BadgeAlert`, `BadgePitch`, `GetStake`) in a `SideEffect`, and the pitch and Wefunder conditions start with `chatModel.bannerSlotFree(banner)` โ€” true only while nothing else was shown this app session โ€” so dismissing a banner never puts another in its place until restart. The alerts have no such check: an alert takes the slot whenever present, and once shown it holds it. The pitch also requires `noShownBadge()` (`views/newchat/OnboardingCards.kt`), false until `BadgeModel.isCurrent` for the current user, so it cannot take the slot from a supporter whose badge loads a moment later. `ConnectOnboardingView` applies the same `bannerSlotFree` check and records `GetStake`. `crowdfundingAvailable()` launches an effect to load the store country, so both call sites read it in the composable body rather than inside the `LazyColumn` builder. @@ -352,7 +352,7 @@ The list has a single banner slot, filled by an `if`/`else if` chain in priority | `supporterBannerTapped` | tapping the supporter pitch | the pitch's dismiss X appears from then on | | `supporterBannerShown` | the pitch's dismiss X, through its "You can support SimpleX later in Settings." alert, and a successful code redemption | hides the pitch | -The two badge alert banners always offer the X; only the pitch waits to be tapped once, so a user who has not looked at it cannot dismiss it unseen. +The badge alert banner always offers the X; only the pitch waits to be tapped once, so a user who has not looked at it cannot dismiss it unseen. Both are in `AppPreferences.hintPreferences`, so "Reset all hints" restores the banner. The X is never offered below the onboarding cards, so the banner cannot be dismissed before the user has a chat. diff --git a/apps/multiplatform/spec/client/navigation.md b/apps/multiplatform/spec/client/navigation.md index 4900cfaba7..04da4e9b33 100644 --- a/apps/multiplatform/spec/client/navigation.md +++ b/apps/multiplatform/spec/client/navigation.md @@ -109,11 +109,11 @@ When onboarding is complete: ### URL Deep Link -On Android, [`processIntent()`](../../android/src/main/java/chat/simplex/app/MainActivity.kt#L144) puts the URI of a VIEW intent into `chatModel.appOpenUrl`. Once onboarding is complete, a `LaunchedEffect` in `MainScreen` ([`App.kt`](../../common/src/commonMain/kotlin/chat/simplex/common/App.kt#L241)) hands it to [`connectIfOpenedViaUri()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt#L775), which re-queues it while no profile is active. +On Android, [`processIntent()`](../../android/src/main/java/chat/simplex/app/MainActivity.kt#L144) puts the URI of a VIEW intent into `chatModel.appOpenUrl`. Once onboarding is complete, a `LaunchedEffect` in `MainScreen` ([`App.kt`](../../common/src/commonMain/kotlin/chat/simplex/common/App.kt#L241)) hands it to [`connectIfOpenedViaUri()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt#L797), which re-queues it while no profile is active. On desktop the same state is set from three places, for `simplexchat:` app links and `simplex:` connection links alike. [`isAcceptedLink()`](../../common/src/desktopMain/kotlin/chat/simplex/common/AppLinks.kt#L12) accepts either scheme within 8192 bytes in UTF-8, which leaves room for a one-time link with its post-quantum key (about 2 KB) and for a second such key. A link that starts the app arrives as the only argument of [`main()`](../../desktop/src/jvmMain/kotlin/chat/simplex/desktop/Main.kt#L26) on Windows and Linux ([`linkFromArgs()`](../../common/src/desktopMain/kotlin/chat/simplex/common/AppLinks.kt#L15)). A link for an app that is already running starts a second process, which writes it into the single-instance signal file ([`signalRunningInstance()`](../../common/src/desktopMain/kotlin/chat/simplex/common/SingleInstance.kt#L138)); the running instance renames the file before reading and deleting it ([`takeSignal()`](../../common/src/desktopMain/kotlin/chat/simplex/common/SingleInstance.kt#L159)), retrying once if another program holds the file open, handles a signal already present when its watcher ([`watchShowSignals()`](../../common/src/desktopMain/kotlin/chat/simplex/common/SingleInstance.kt#L247)) starts unless it predates the lock attempt by more than 2 s ([`deleteStaleSignalFiles()`](../../common/src/desktopMain/kotlin/chat/simplex/common/SingleInstance.kt#L116)), and passes the link to [`openDesktopLink()`](../../common/src/desktopMain/kotlin/chat/simplex/common/AppLinks.kt#L19), which queues it for the active host and shows the window. If the running instance does not take the signal within 1 s, the second process asks whether to start anyway ([`startDespiteRunningInstance()`](../../common/src/desktopMain/kotlin/chat/simplex/common/SingleInstance.kt#L93)); on *Yes* it withdraws the signal first and exits instead if the running instance has recovered and taken it, so the link opens once. On macOS the link is an Apple Event handled by [`installOpenUriHandler()`](../../common/src/desktopMain/kotlin/chat/simplex/common/AppLinks.kt#L25). From there `connectIfOpenedViaUri()` handles the link as on Android: a connection link goes to `planAndConnect()`, which asks before connecting. Both schemes are declared by the macOS Info.plist, the deb, AppImage and Flatpak desktop entries, and at runtime by [`registerLinkSchemes()`](../../common/src/desktopMain/kotlin/chat/simplex/common/platform/AppLinkScheme.desktop.kt#L67) (HKCU on Windows, a hidden desktop entry for an AppImage). Only `simplexchat:` is checked: [`appLinkSchemeRegistered()`](../../common/src/desktopMain/kotlin/chat/simplex/common/platform/AppLinkScheme.desktop.kt#L65) decides the badge page's ending through [`badgePageUrl()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt#L53): `app=true` when a link is expected to reach this installation, otherwise `app=desktop` with the Redeem code screen opened beside the browser. [`desktopInstallation()`](../../common/src/desktopMain/kotlin/chat/simplex/common/platform/AppLinkScheme.desktop.kt#L74) tells the installation kind apart. A packaged macOS app and a Flatpak count as registered without a check, since a Flatpak cannot query the host's default handler ([GAP](../../product/gaps.md#gap-08-desktop-app-link-registration)); Windows, where each scheme key is paired with a `SimpleX.` ProgId named in `Capabilities` and listed in `RegisteredApplications`, so the app appears in Windows default-app settings for each scheme that no other program holds, when the shell (`AssocQueryStringW`) reports this exe as the program that opens `simplexchat:` links, which accounts for any app picked in settings ([`registerWindowsSchemes()`](../../common/src/desktopMain/kotlin/chat/simplex/common/platform/AppLinkScheme.desktop.kt#L168)); an AppImage ([`registerAppImageScheme()`](../../common/src/desktopMain/kotlin/chat/simplex/common/platform/AppLinkScheme.desktop.kt#L299)) or deb when its own desktop entry is the default `simplexchat:` handler. Registration takes a scheme only when no handler is set or the current one is no longer installed: another installed program, such as a deb beside an AppImage or on Windows a per-user or machine-wide handler, keeps it, while this app still repairs its own ProgId unless another installed copy holds it, and the page then ends with `app=desktop`. An AppImage is not registered ([`onlyOwnerCanReplace()`](../../common/src/desktopMain/kotlin/chat/simplex/common/platform/AppLinkScheme.desktop.kt#L284)) when its file or any directory above it belongs to a user other than this user or root, or has permission bits that let others write it (POSIX ACLs are not inspected), or when its path contains a line break or `%`. An unpackaged run registers nothing. -App links use the app's own scheme, `simplexchat:`, for everything that is not a connection link. `connectIfOpenedViaUri()` branches on that scheme before the connection dispatch, so an app link never reaches `planAndConnect()`. [`isAppLink()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt#L797) tests the raw prefix, since text that does not parse as a URI is still an app link, and [`openAppLink()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt#L804) dispatches on its path. A badge link (`simplexchat:/badge/code/`) goes to [`openBadgeLink()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesRedeemCodeView.kt#L282), which shows `BadgesRedeemLinkView` as a `ModalManager.start` modal with `ModalViewId.BADGE_LINK`. Once the code parses, every modal is closed first, so the screen opens over the chat list, as iOS dismisses every sheet before a link; a code that does not parse gets an alert and closes nothing. The screen names the active profile and asks before redeeming, since any web page can send the link and a profile holds one badge at a time. On *Add badge* it redeems the code into that profile and then shows `BadgesView`; *Cancel* sends nothing. If that profile already shows a badge (read from `BadgeModel` when the screen composes), which core would refuse, the screen does not offer to add it: it says nothing was added, says where a code for another badge is (on the page it was bought on, under *Show code*), and offers *View your badge*; it cannot tell a repeated link for the badge it shows from another badge's code, so it asserts neither. While the code is being redeemed, *Dismiss* or back closes the screen without cancelling anything; if the redemption then succeeds with the screen closed or covered, an alert says the badge was added and names the profile, unless the profile is hidden and no longer active, when nothing is shown ([`showBadgeAddedAlert()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesRedeemCodeView.kt#L97), which the store lane shares). Its step is held by the modal rather than remembered by the composition, so rotation and being covered do not reset it. While the screen shows a redemption in flight ([`isBadgeLinkIssuing()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesRedeemCodeView.kt#L279)), a further app link is ignored. Any other path is a link type from a later version, and gets an alert asking to check for app updates; text that does not parse is dropped. An app link can carry a secret, and nothing on this path logs the URI: `processIntent()` logs nothing, and `connectIfOpenedViaUri()` logs a fixed string. +App links use the app's own scheme, `simplexchat:`, for everything that is not a connection link. `connectIfOpenedViaUri()` branches on that scheme before the connection dispatch, so an app link never reaches `planAndConnect()`. [`isAppLink()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt#L819) tests the raw prefix, since text that does not parse as a URI is still an app link, and [`openAppLink()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListView.kt#L826) dispatches on its path. A badge link (`simplexchat:/badge/code/`) goes to [`openBadgeLink()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesRedeemCodeView.kt#L282), which shows `BadgesRedeemLinkView` as a `ModalManager.start` modal with `ModalViewId.BADGE_LINK`. Once the code parses, every modal is closed first, so the screen opens over the chat list, as iOS dismisses every sheet before a link; a code that does not parse gets an alert and closes nothing. The screen names the active profile and asks before redeeming, since any web page can send the link and a profile holds one badge at a time. On *Add badge* it redeems the code into that profile and then shows `BadgesView`; *Cancel* sends nothing. If that profile already shows a badge (read from `BadgeModel` when the screen composes), which core would refuse, the screen does not offer to add it: it says nothing was added, says where a code for another badge is (on the page it was bought on, under *Show code*), and offers *View your badge*; it cannot tell a repeated link for the badge it shows from another badge's code, so it asserts neither. While the code is being redeemed, *Dismiss* or back closes the screen without cancelling anything; if the redemption then succeeds with the screen closed or covered, an alert says the badge was added and names the profile, unless the profile is hidden and no longer active, when nothing is shown ([`showBadgeAddedAlert()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesRedeemCodeView.kt#L97), which the store lane shares). Its step is held by the modal rather than remembered by the composition, so rotation and being covered do not reset it. While the screen shows a redemption in flight ([`isBadgeLinkIssuing()`](../../common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgesRedeemCodeView.kt#L279)), a further app link is ignored. Any other path is a link type from a later version, and gets an alert asking to check for app updates; text that does not parse is dropped. An app link can carry a secret, and nothing on this path logs the URI: `processIntent()` logs nothing, and `connectIfOpenedViaUri()` logs a fixed string. ### Overlay Layers (bottom of MainScreen) diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md index bb1cec2230..e2941f565b 100644 --- a/apps/simplex-badge-service/README.md +++ b/apps/simplex-badge-service/README.md @@ -51,7 +51,7 @@ simplex-badge-service --help `simplex-directory-service --run-cli`). This mode is the chat/RPC side and the `//` commands below: it starts no web listener and no poller, and serves no group commands, whatever `--service-config` says. It still updates a code's group message when the code is redeemed or - revoked. `[apple]`, `[google]` and `[dev] accept_unverified_store_receipts` apply to it. + revoked. `[apple]`, `[google]` and `[dev]` apply to it. - `--no-address`: skip address creation on start-up (for operators who provision the address themselves). The service cannot sign credentials without an issuer key and refuses to start without one: @@ -72,7 +72,8 @@ private_key = `index` is the index clients verify against (`badgePublicKeys` in `ChatConfig`), and `private_key` is the secret that signs. Both are required, and the key is checked at startup like the flags. -Rotating is a change to both and a restart, once clients trust the new index. +Rotating is a change to both and a restart, once clients trust the new index. The service logs the +index it signs with at startup. The command line wins over the file when both `--issuer-key-idx` and `--issuer-secret` are given. Note that a secret passed as a flag is visible to every user on the machine through `ps`, where one @@ -84,7 +85,7 @@ Other options: - `--service-config INI_FILE`: path to `badge_service.ini`. Omit it to run the chat/RPC side only; the process never starts a web listener without it, and never starts one under `--run-cli`, which parses and validates the whole file (`[listener] static_dir` included) but - uses only its `[issuer]`, `[apple]` and `[google]` sections and `[dev] accept_unverified_store_receipts`. An issuer key is + uses only its `[issuer]`, `[apple]`, `[google]` and `[dev]` sections. An issuer key is still required either way. - `--service-name NAME`: the bot's display name, without `*`s or spaces (default `SimpleX Badges`). - `--client-service`: use the client service certificate. @@ -221,6 +222,9 @@ account key, or either section beside [apple] bundle_id = chat.simplex.app root_certificates = /etc/simplex-badge-service/AppleRootCA-G3.cer +api_key_id = 2X9R4HXF34 +api_issuer_id = 57246542-96fe-1a63-e053-0824d011072a +api_private_key_file = /etc/simplex-badge-service/AuthKey_2X9R4HXF34.p8 [google] package_name = chat.simplex.app @@ -237,9 +241,22 @@ service_account_file = /etc/simplex-badge-service/play-service-account.json under a new root, list it beside the old one rather than in its place: a purchase signed under the old root still verifies, and one answered `internal` meanwhile is credited when the app presents it again. -- `[google]` asks the Google Play Developer API about each purchase, and acknowledges it before - crediting it, as the service account whose JSON key `service_account_file` holds. The account - needs both Play Console permissions Google's +- With `api_key_id`, `api_issuer_id` and `api_private_key_file`, `[apple]` also verifies + subscriptions: it asks the App Store Server API for a subscription's status, with a token signed + by the in-app purchase key App Store Connect issued (the `.p8` file, its key id and the + account's issuer id), and checks what Apple signed in the answer against the same roots. Without + them, one-time purchases verify as before and every subscription is answered + `provider_not_configured`. The three are set together or not at all. `api_host` defaults to the + production host, `https://api.storekit.itunes.apple.com`, which answers nothing about a Sandbox + transaction; a test deployment with `[dev] credit_test_purchases = on` (below) sets + `https://api.storekit-sandbox.itunes.apple.com`. The service refuses to start with any other host, + or with the Sandbox host while `credit_test_purchases` is off, as the Sandbox never charges anyone; + the host's case and a trailing slash do not matter. A 401 or 403 + from Apple, the key refused, is answered `internal` and logged. Keep the key file readable by this + service alone. +- `[google]` asks the Google Play Developer API about each purchase and subscription, and + acknowledges it before crediting it, as the service account whose JSON key + `service_account_file` holds. The account needs both Play Console permissions Google's [getting started](https://developers.google.com/android-publisher/getting_started) lists for its billing APIs: "View financial data, orders, and cancellation survey responses" to read a purchase, and "Manage orders and subscriptions" to acknowledge it. Without the second, a Play @@ -247,12 +264,57 @@ service_account_file = /etc/simplex-badge-service/play-service-account.json error naming the acknowledgement, and the app presents it again once the permission is granted, which must be within three days, before Play refunds it. The key signs in for an access token, so keep the file readable by this service alone. - Play purchases are verified on a lane of their own, so a slow or unreachable Play delays only - other Play purchases, not code redemptions, renewals or App Store purchases. + A request that may ask a store waits on a lane of its own: Play purchases, App Store + subscription purchases and transfers of a subscription (Restore) on one, and issue requests and + tier raises for a subscription due its hourly store check on another. A slow or unreachable + store therefore delays only those, not code redemptions, App Store one-time purchases or other + renewals; and no purchase or transfer, genuine or made up, delays a renewal check. The purchase + path asks Play about at most 300 subscriptions a minute (a purchase it credits is read once more + to acknowledge it), so made-up tokens can spend at most a tenth of the quota renewal checks share. + +While a subscription's paid coverage runs, as an annual plan's does for a year, the service asks +its store before it issues each new month, at most once an hour. When the store reports the +subscription ended, or the charge the service granted revoked, the months not yet issued are debited +as a refund and the badge ends with the month already issued; a store that fails or does not answer +ends nothing. A Play refund that leaves the subscription active is not seen: the service does not +read Play's voided purchases. Which answers are terminal for a purchase and which leave it to be presented again is listed per store in [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md#commands). +The root certificates, the App Store Server API key and the Play service account key are read only +at startup, so rotating any of them takes a restart. Until then the old key keeps being used, and +each request the store refuses it for is answered `internal` and logged as an error. + +Do not roll back the `20261012_badge_subscriptions` migration on a database that holds store +subscriptions. Its down migration drops their columns without refusing: every subscription becomes +a prepaid purchase that is never renewed, every Play purchase token is lost, and every ledger with a +charge, transfer or tier-change row can no longer be read, so its purchase answers `internal`. +Upgrading again restores none of it. Take a backup first if a rollback is unavoidable. + +#### Store setup + +The subscriptions must be sold under the ids the apps buy and the service credits, and set up as +follows: + +- [ ] App Store: one subscription group holding all four subscriptions, so a change of tier or plan + keeps the original transaction id, and with it the purchase. +- [ ] App Store levels: `SUBSCR_BADGE_LEGEND_MONTH_01` and `SUBSCR_BADGE_LEGEND_YEAR_01` at level 1, + `SUBSCR_BADGE_SUPPORTER_MONTH_01` and `SUBSCR_BADGE_SUPPORTER_YEAR_01` at level 2. Apple charges a + move to a higher level at once, and the apps send only Supporter to Legend as a raise. +- [ ] App Store: Billing Grace Period off, and Family Sharing off, which cannot be turned off once on: + a family-shared subscription is refused. +- [ ] Play: the product `subscr_badge_supporter_01` with the base plans + `subscr-badge-supporter-month-02` and `subscr-badge-supporter-year-01`, and the product + `subscr_badge_legend_01` with `subscr-badge-legend-month-01` and `subscr-badge-legend-year-01`. + A charge for any other base plan is not credited, and a charge for one of these under the other + product is answered `internal`. +- [ ] Play, on each of the four base plans: Resubscribe off, pausing off, the minimum grace period, + and account hold on. +- [ ] Both: no offers of any kind: no free trial, introductory or promotional price, or offer code. + The service credits no App Store charge made with an offer and no Play charge in a free trial or + introductory price. + ### Accepting store receipts unverified, for local testing ```ini @@ -267,9 +329,83 @@ token as given. It applies to both run modes, since `--run-cli` answers service the service logs a warning at every start while it is on. Off by default, and only `on`/`off` parse. The service refuses to start with it on beside an `[apple]` or `[google]` section. +It answers subscriptions too, each as renewing, charged from a minute before the check for the +length of its plan: + +- an App Store subscription: the plan its product names; +- a Play subscription: the base plan a test token `test..` names, when it is a + plan of the product (the apps' test products sign their tokens so), or else the product's + monthly base plan, so a licence tester's purchase is credited too; +- an App Store tier raise: a charge for the raised plan, which its renewals then charge; +- a renewal: a new charge for the plan it last charged. It keeps that plan in memory only, so after + a restart it answers a renewal of a subscription it credited before as ended, and the unissued + months of a plan still covered are refunded at its next month. + +It acknowledges nothing, so Play refunds a licence tester's subscription it credited once Play's +acknowledgement window lapses. + With it on, anyone who can reach the service address can mint badges by sending a made-up receipt. -That is harmless only while this deployment signs with an issuer key released apps do not carry, so -they refuse what it signs โ€” never turn it on where the key is one those apps trust. +The service starts only with an issuer key released apps trust, so they accept every badge it +mints this way, and a subscription credited so renews at every check for as long as the process +runs. Never turn it on where anyone but you can reach the service. + +```ini +[dev] +accept_unverified_store_receipts = on +check_store_during_coverage = on +``` + +With `check_store_during_coverage` on as well, the service asks its store, the mock or a real one +with `credit_test_purchases` on (below), at every `issueBadge` for a subscription, rather than at +most once an hour and only when a month is due. A charge it reports during coverage is banked: a +charge row, the plan's months added to what is left and a later paid-through date, and those +months are issued once coverage reaches them; a deployment without the setting only records it. +So a renewal shows at once, though its credential waits for the paid month to end on the service's +clock, and after a restart the mock answers the subscription ended at once, so the months banked +are refunded. The mock charges anew at every +check, so every such request banks the plan's months again; space requests over a minute apart, as +the mock dates a charge a minute back and the app fails a ledger row dated before the one it +follows. The service logs each banked charge as +`store subscription charge banked: months`, which tells a banked month +from a repeated `badge issued`. Off by default, and the service refuses to start with it on unless +`accept_unverified_store_receipts` or `credit_test_purchases` is on: a real store has not started +its next charge while coverage runs, and asking it then would spend the quota every subscriber +shares. + +### Crediting test purchases, for testing against a real store + +```ini +[dev] +credit_test_purchases = on +``` + +A purchase the store itself calls a test, an App Store Sandbox purchase (which TestFlight builds +buy in) or a Play licence tester's, is refused `test_purchase` by default, which is terminal, so it +can never be credited. With this on, the service credits it as a real one, one-time purchases and +subscriptions alike. It applies beside a real `[apple]` or `[google]` section, which still verifies +every receipt, and changes nothing beside `accept_unverified_store_receipts`, whose mock reports +no test purchase. The service logs a warning at every start while it is on, and at every test +purchase and test subscription it takes as paid. Off by default, and only `on`/`off` parse. + +Beside `[apple]` the service starts with it on only when `[apple]` sets the server API key with +`api_host = https://api.storekit-sandbox.itunes.apple.com`: a Sandbox receipt verifies offline like +any other, so beside the production host, or without the key, Sandbox purchases would be credited as +real ones. Beside `[google]` it is allowed, as Play calls a purchase a test only for the licence +testers the Play Console lists. + +```ini +[dev] +credit_test_purchases = on +check_store_during_coverage = on +``` + +With both on, the real store is asked at every `issueBadge` for a subscription, as above, to watch +its renewals by hand: a Sandbox subscription renews every few minutes. + +The service starts only with an issuer key released apps trust, so they accept every badge it +credits this way. Nothing tells a production `[google]` from a test one, so never turn this on +beside the production Play app's `[google]`, or every licence tester the Play Console lists gets a +badge without paying. ## Issuing codes diff --git a/apps/simplex-badge-service/badge_service.ini.example b/apps/simplex-badge-service/badge_service.ini.example index 26abb5aa7e..5fbce6b7f3 100644 --- a/apps/simplex-badge-service/badge_service.ini.example +++ b/apps/simplex-badge-service/badge_service.ini.example @@ -45,9 +45,19 @@ idle_seconds = 60 ; root_certificates lists, comma-separated, the roots trusted to sign receipts, each in DER. Today that ; is Apple Root CA - G3 as Apple publishes it: https://www.apple.com/certificateauthority/AppleRootCA-G3.cer ; When Apple adds a root, list it beside the old one rather than in its place. +; The api_ keys verify subscriptions through the App Store Server API, with the in-app purchase key +; App Store Connect issues: its .p8 file, its key id and the account's issuer id, set together. Without +; them every App Store subscription is answered provider_not_configured. api_host defaults to production, +; the only host accepted unless [dev] credit_test_purchases = on, which needs +; https://api.storekit-sandbox.itunes.apple.com instead; case and a trailing slash do not matter. +; Keep the key file readable by this service alone. ;[apple] ;bundle_id = chat.simplex.app ;root_certificates = /etc/simplex-badge-service/AppleRootCA-G3.cer +;api_key_id = 2X9R4HXF34 +;api_issuer_id = 57246542-96fe-1a63-e053-0824d011072a +;api_private_key_file = /etc/simplex-badge-service/AuthKey_2X9R4HXF34.p8 +;api_host = https://api.storekit.itunes.apple.com ; verifies Play purchases with the Google Play Developer API. Omit the whole section and the service answers ; every Play receipt provider_not_configured, which the app retries later. @@ -82,6 +92,29 @@ idle_seconds = 60 ; local testing only, in both run modes: accepts any well-formed App Store or Play receipt without ; verifying it, so anyone who can reach this service can mint badges. The service refuses to start -; with this on beside an [apple] or [google] section. +; with this on beside an [apple] or [google] section. Its issuer key is always one released apps +; trust, so they accept every badge minted this way. +; A subscription is answered renewing and charged for its plan: the App Store product's, or the base +; plan a Play test token test.. names when it is a plan of that product, and else +; the product's monthly base plan, so a licence tester's purchase is credited too. An App Store tier +; raise is charged for the raised plan, which its renewals then charge. The plans are kept in memory, +; so a restart answers later renewals as ended, and refunds the unissued +; months of a plan still covered at its next month. Nothing is acknowledged, so Play refunds a +; licence tester's subscription once its acknowledgement window lapses. [dev] accept_unverified_store_receipts = off +; only beside accept_unverified_store_receipts or credit_test_purchases = on: every issue request for a +; subscription asks its store, while coverage runs too, and banks the months each check charges, to +; watch a renewal by hand. +check_store_during_coverage = off + +; local testing only, beside a real [apple] or [google]: credits a purchase the store itself calls a +; test - an App Store sandbox purchase, or a Play licence tester's - which no real buyer pays for. +; Without it such a purchase is refused as test_purchase, which is terminal, so it can never be credited. +; Beside [apple] the service starts with this on only when its api_ keys are set with +; api_host = https://api.storekit-sandbox.itunes.apple.com, since a sandbox receipt verifies like any +; other and would otherwise be credited as a real purchase. Beside [google] it is allowed: never turn it +; on beside the production app's [google], as the issuer key is one released apps trust and every +; licence tester the Play Console lists would get a badge without paying. Each test purchase or test +; subscription taken as paid is logged as a warning. +credit_test_purchases = off diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs index 85b678d8d5..58fc246399 100644 --- a/apps/simplex-badge-service/src/BadgeService/Catalog.hs +++ b/apps/simplex-badge-service/src/BadgeService/Catalog.hs @@ -13,6 +13,7 @@ module BadgeService.Catalog defaultCatalog, StoreProduct (..), storeProduct, + playMonthlyPlan, ) where @@ -136,19 +137,32 @@ defaultCatalog seededAt = (prices, offers) createdAt = seededAt } -data StoreProduct = StoreProduct - { badgeType :: BadgeType, - months :: Int - } +-- | A subscription's badge and months come from each charge's plan, so the product names neither. +data StoreProduct + = StoreOneTime {badgeType :: BadgeType, months :: Int} + | StoreSubscription deriving (Eq, Show) -- | A receipt proves only the product paid for, so the badge comes from here, never from the client. --- Mirrors the one-time SKUs of BadgeStore.swift and .kt; subscriptions wait until renewals add months. +-- Mirrors the SKUs of BadgeStore.swift and .kt. -- Not part of the seeded catalog above, which exists to pin prices this service sets: a store sets its own. storeProduct :: PaymentProvider -> Text -> Maybe StoreProduct storeProduct provider productId = case (provider, productId) of - (PPApple, "BADGE_SUPPORTER_01") -> Just $ StoreProduct BTSupporter 1 - (PPApple, "BADGE_LEGEND_01") -> Just $ StoreProduct BTLegend 1 - (PPGoogle, "badge_supporter_01") -> Just $ StoreProduct BTSupporter 1 - (PPGoogle, "badge_legend_01") -> Just $ StoreProduct BTLegend 1 + (PPApple, "BADGE_SUPPORTER_01") -> Just $ StoreOneTime BTSupporter 1 + (PPApple, "BADGE_LEGEND_01") -> Just $ StoreOneTime BTLegend 1 + (PPGoogle, "badge_supporter_01") -> Just $ StoreOneTime BTSupporter 1 + (PPGoogle, "badge_legend_01") -> Just $ StoreOneTime BTLegend 1 + (PPApple, "SUBSCR_BADGE_SUPPORTER_MONTH_01") -> Just StoreSubscription + (PPApple, "SUBSCR_BADGE_SUPPORTER_YEAR_01") -> Just StoreSubscription + (PPApple, "SUBSCR_BADGE_LEGEND_MONTH_01") -> Just StoreSubscription + (PPApple, "SUBSCR_BADGE_LEGEND_YEAR_01") -> Just StoreSubscription + (PPGoogle, "subscr_badge_supporter_01") -> Just StoreSubscription + (PPGoogle, "subscr_badge_legend_01") -> Just StoreSubscription + _ -> Nothing + +-- | A Play subscription product's monthly base plan, which a purchase token alone does not name. +playMonthlyPlan :: Text -> Maybe Text +playMonthlyPlan = \case + "subscr_badge_supporter_01" -> Just "subscr-badge-supporter-month-02" + "subscr_badge_legend_01" -> Just "subscr-badge-legend-month-01" _ -> Nothing diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index 72e774fdac..8bd240ee56 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -11,6 +11,7 @@ module BadgeService.Config speedPolicyName, PollConfig (..), AppleStoreConfig (..), + AppleServerApi (..), PlayStoreConfig (..), BadgeIssuerKey (..), GroupConfig (..), @@ -24,7 +25,7 @@ where import qualified Control.Exception as E import BadgeService.Log (logWarn) -import Control.Monad (mfilter, when) +import Control.Monad (mfilter, unless, when) import Data.Attoparsec.Text (Parser, endOfInput, isEndOfLine, parseOnly, satisfy, skipMany, skipSpace, skipWhile) import qualified Data.ByteString.Char8 as B import Data.Ini (Ini, iniGlobals, iniParser, keys, lookupValue, sections) @@ -97,7 +98,17 @@ data PollConfig = PollConfig {pWaitingSeconds :: Int, pIdleSeconds :: Int} data AppleStoreConfig = AppleStoreConfig { aBundleId :: Text, - aRootCertificates :: NonEmpty FilePath + aRootCertificates :: NonEmpty FilePath, + aServerApi :: Maybe AppleServerApi -- without it, App Store subscriptions are not verified + } + deriving (Eq, Show) + +-- | The App Store Server API key, which subscription checks sign their requests with. +data AppleServerApi = AppleServerApi + { aKeyId :: Text, + aIssuerId :: Text, + aPrivateKeyFile :: FilePath, + aApiHost :: Text } deriving (Eq, Show) @@ -135,7 +146,11 @@ data ServiceConfig = ServiceConfig issuer :: Maybe BadgeIssuerKey, group :: Maybe GroupConfig, -- Local testing only; anyone who can reach the service can mint badges with any well-formed receipt. - devAcceptUnverifiedStoreReceipts :: Bool + devAcceptUnverifiedStoreReceipts :: Bool, + -- Local testing only; every issue request for a subscription asks its store and banks the months it charges. + devCheckStoreDuringCoverage :: Bool, + -- Local testing only; credits a purchase the store itself calls a test, which no real buyer pays for. + devCreditTestPurchases :: Bool } deriving (Eq, Show) @@ -151,6 +166,13 @@ defaultSessionMinutes = 60 defaultPlayApiHost :: Text defaultPlayApiHost = "https://androidpublisher.googleapis.com" +-- | Production: it answers 404 for a Sandbox transaction, which a test deployment reaches through api_host. +defaultAppleApiHost :: Text +defaultAppleApiHost = "https://api.storekit.itunes.apple.com" + +appleSandboxHost :: Text +appleSandboxHost = "https://api.storekit-sandbox.itunes.apple.com" + defaultPlayTokenUrl :: Text defaultPlayTokenUrl = "https://oauth2.googleapis.com/token" @@ -169,6 +191,16 @@ requireHttps u maxTolerance :: Double maxTolerance = 10 +-- | A Sandbox receipt verifies like a real one, offline too, so test purchases are credited only beside the Sandbox's +-- server API; and the Sandbox charges no one, so without them only the production host can credit a subscription. +checkAppleHost :: Bool -> AppleStoreConfig -> Either String () +checkAppleHost creditTestPurchases AppleStoreConfig {aServerApi} = case (creditTestPurchases, aApiHost <$> aServerApi) of + (False, Nothing) -> Right () + (False, Just h) | h == defaultAppleApiHost -> Right () + (True, Just h) | h == appleSandboxHost -> Right () + (False, _) -> Left $ "apple.api_host must be " <> T.unpack defaultAppleApiHost <> " unless [dev] credit_test_purchases = on, as no other host credits a real subscription" + (True, _) -> Left $ "[dev] credit_test_purchases = on needs [apple]'s server API key with api_host = " <> T.unpack appleSandboxHost <> ", as a Sandbox receipt would otherwise be credited as a real purchase" + readServiceConfig :: FilePath -> IO (Either String ServiceConfig) readServiceConfig path = E.try (TIO.readFile path) >>= \case @@ -192,10 +224,10 @@ knownSettings = ("btcpay", ["host", "api_key", "store_id", "webhook_secret", "expiry_minutes", "speed_policy", "payment_tolerance"]), ("stripe", ["secret_key", "publishable_key", "webhook_secret", "session_minutes"]), ("poll", ["waiting_seconds", "idle_seconds"]), - ("apple", ["bundle_id", "root_certificates"]), + ("apple", ["bundle_id", "root_certificates", "api_key_id", "api_issuer_id", "api_private_key_file", "api_host"]), ("google", ["package_name", "service_account_file"]), ("group", ["display_name", "description"]), - ("dev", ["accept_unverified_store_receipts"]), + ("dev", ["accept_unverified_store_receipts", "check_store_during_coverage", "credit_test_purchases"]), ("issuer", ["index", "private_key"]) ] @@ -232,6 +264,11 @@ parseConfig ini = do devUnverifiedReceipts <- bool "dev" "accept_unverified_store_receipts" False when (devUnverifiedReceipts && (isJust apple || isJust google)) $ Left "[dev] accept_unverified_store_receipts must be off where [apple] or [google] verifies store receipts" + devCheckStoreDuringCoverage <- bool "dev" "check_store_during_coverage" False + devCreditTestPurchases <- bool "dev" "credit_test_purchases" False + mapM_ (checkAppleHost devCreditTestPurchases) apple + when (devCheckStoreDuringCoverage && not (devUnverifiedReceipts || devCreditTestPurchases)) $ + Left "[dev] check_store_during_coverage needs accept_unverified_store_receipts or credit_test_purchases = on, as only a dev deployment may ask a store while coverage runs" pure ServiceConfig { listener = ListenerConfig {lHost, lPort, lStaticDir, lServeWebapp, lWebappExportDir, lTrustForwardedFor}, @@ -242,7 +279,9 @@ parseConfig ini = do playStore = google, issuer = iss, group = grp, - devAcceptUnverifiedStoreReceipts = devUnverifiedReceipts + devAcceptUnverifiedStoreReceipts = devUnverifiedReceipts, + devCheckStoreDuringCoverage, + devCreditTestPurchases } where hasSection s = s `elem` sections ini @@ -339,11 +378,20 @@ parseConfig ini = do | otherwise = do aBundleId <- required "apple" "bundle_id" aRootCertificates <- rootCertificates - pure (Just AppleStoreConfig {aBundleId, aRootCertificates}) + aServerApi <- appleServerApi + pure (Just AppleStoreConfig {aBundleId, aRootCertificates, aServerApi}) rootCertificates = do v <- required "apple" "root_certificates" maybe (Left "apple.root_certificates must list at least one file") Right $ L.nonEmpty $ map T.unpack $ filter (not . T.null) $ map T.strip $ T.splitOn "," v + -- the key is three settings, and one or two of them would leave subscriptions silently unverified + appleServerApi = case (present "apple" "api_key_id", present "apple" "api_issuer_id", present "apple" "api_private_key_file") of + (Nothing, Nothing, Nothing) -> Right Nothing + (Just aKeyId, Just aIssuerId, Just keyFile) -> do + aApiHost <- T.toLower . T.dropWhileEnd (== '/') <$> optional "apple" "api_host" defaultAppleApiHost + unless ("https://" `T.isPrefixOf` aApiHost) $ Left "apple.api_host must be an absolute https URL" + pure (Just AppleServerApi {aKeyId, aIssuerId, aPrivateKeyFile = T.unpack keyFile, aApiHost}) + _ -> Left "apple.api_key_id, apple.api_issuer_id and apple.api_private_key_file are required together" googleSection | not (hasSection "google") = Right Nothing | otherwise = do diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 72389c8cc7..d5d2b318a0 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -13,7 +13,21 @@ module BadgeService.Service badgeService, badgeServiceCLI, badgeServiceResponse, + RequestLane (..), + requestLane, + PurchaseChecks (..), + ClaimChecks, + ClaimKey (..), + ClaimPurpose (..), + newPurchaseChecks, + purchaseCheckWait, + maxPurchaseChecks, + PlayReads, + playReadWait, + maxPlayPurchaseReads, badgeErrorRetryAfter, + grantableCharge, + NotGranted (..), shownServiceRequest, survive, IssueCodeOpts (..), @@ -35,11 +49,11 @@ import BadgeService.Store import BadgeService.Store.Invoices (seedCatalog, truncateToSecond) import BadgeService.Store.Migrate (runBadgeServiceMigrations) import BadgeService.StoreReceipts -import BadgeService.StoreReceipts.Apple (readAppleRoot, verifyAppleTransaction) -import BadgeService.StoreReceipts.Google (playStoreVerifier) -import BadgeService.StoreReceipts.Mock (mockStoreVerifier) +import BadgeService.StoreReceipts.Apple (appleSubscriptionChecker, readAppleRoot, verifyAppleTransaction) +import BadgeService.StoreReceipts.Google (PlayVerifier (..), playStoreVerifier) +import BadgeService.StoreReceipts.Mock (newMockStoreVerifier) import BadgeService.Waiters (Waiters, newWaiters) -import BadgeService.Web.Server (exportWebapp, newWebEnv, runWebListener) +import BadgeService.Web.Server (Bucket, exportWebapp, newWebEnv, runWebListener, takeFrom) import Control.Applicative (optional) import Control.Concurrent.STM import Control.Monad @@ -52,22 +66,23 @@ 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 (UTCTime, getCurrentTime) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) import Data.Word (Word32) 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') import Simplex.Chat.Controller import Simplex.Chat.Core (sendChatCmd, simplexChatCore) import Simplex.Chat.Options (printDbOpts) -import Simplex.Chat.PaymentService (ServicePayment (..)) -import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..)) +import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts) +import Simplex.Chat.PaymentService.Types (PaymentProvider (..), StoreTransactionRef (..)) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') import Simplex.Chat.Types (AgentInvId (..), User (..)) @@ -126,7 +141,7 @@ checkOne ChatConfig {badgePublicKeys} k@BadgeIssuerKey {keyIdx, secretKey} = requireIssuerKey :: BadgeServiceOpts -> Maybe ServiceConfig -> ChatConfig -> IO BadgeIssuerKey requireIssuerKey opts serviceCfg cfg = - checkIssuerKey opts serviceCfg cfg >>= either (\e -> putStrLn ("Error: " <> e) >> exitFailure) pure + checkIssuerKey opts serviceCfg cfg >>= either (\e -> putStrLn ("Error: " <> e) >> exitFailure) (\k@BadgeIssuerKey {keyIdx} -> logInfo ("signing badges with issuer key " <> tshow keyIdx) $> k) readConfigOrExit :: FilePath -> IO ServiceConfig readConfigOrExit path = @@ -134,30 +149,47 @@ readConfigOrExit path = Left e -> putStrLn (path <> ": " <> e) >> exitFailure Right sc -> pure sc --- | The config refuses the dev flag beside a real verifier, so only one of them applies. +-- | Only one of the mock and the real verifiers applies: the config refuses +-- accept_unverified_store_receipts beside [apple] or [google]. The other two dev settings, +-- credit_test_purchases and check_store_during_coverage, are meant to sit beside a real verifier. configureStoreVerifier :: Maybe ServiceConfig -> ServiceState -> IO ServiceState -configureStoreVerifier serviceCfg env@ServiceState {storeVerifier = v} = case serviceCfg of - Just ServiceConfig {devAcceptUnverifiedStoreReceipts = True} -> do +configureStoreVerifier serviceCfg env@ServiceState {serviceCC, storeVerifier = v} = case serviceCfg of + Just ServiceConfig {devAcceptUnverifiedStoreReceipts = True, devCheckStoreDuringCoverage} -> do logWarn "[dev] accept_unverified_store_receipts is on: any store receipt is accepted without verification" - pure env {storeVerifier = mockStoreVerifier} - Just ServiceConfig {appleStore, playStore} -> do - apple <- forM appleStore $ \AppleStoreConfig {aBundleId, aRootCertificates} -> - (\roots -> verifyAppleTransaction roots aBundleId) <$> mapM (orExit . readAppleRoot) aRootCertificates + -- the badge clock is read at each check, as the controller that holds it starts after this + mock <- newMockStoreVerifier $ atomically (readTMVar serviceCC) >>= badgeNow + pure env {storeVerifier = mock {storeChecks = if devCheckStoreDuringCoverage then ChecksAtEveryRequest else ChecksAfterCoverage}} + Just ServiceConfig {appleStore, playStore, devCheckStoreDuringCoverage, devCreditTestPurchases} -> do + when devCreditTestPurchases $ logWarn "[dev] credit_test_purchases is on: a purchase the store calls a test is credited as a real one" + apple <- forM appleStore $ \AppleStoreConfig {aBundleId, aRootCertificates, aServerApi} -> do + roots <- mapM (orExit . readAppleRoot) aRootCertificates + appleSubscriptions <- forM aServerApi $ orExit . appleSubscriptionChecker roots aBundleId + pure (verifyAppleTransaction roots aBundleId, appleSubscriptions) google <- forM playStore $ orExit . playStoreVerifier - forM_ appleStore $ \AppleStoreConfig {aBundleId} -> logInfo $ "verifying App Store receipts for " <> aBundleId + forM_ appleStore $ \AppleStoreConfig {aBundleId, aServerApi} -> + logInfo $ "verifying App Store receipts for " <> aBundleId <> maybe ", but not its subscriptions: [apple] sets no API key" (const "") aServerApi forM_ playStore $ \PlayStoreConfig {gPackageName} -> logInfo $ "verifying Play purchases for " <> gPackageName pure env { storeVerifier = v - { verifyApple = maybe (verifyApple v) Just apple, - verifyGoogle = maybe (verifyGoogle v) (Just . fst) google, - acknowledgeGoogle = maybe (acknowledgeGoogle v) (Just . snd) google + { verifyApple = maybe (verifyApple v) (Just . fst) apple, + verifyGoogle = maybe (verifyGoogle v) (Just . verifyPlayPurchase) google, + acknowledgeGoogle = maybe (acknowledgeGoogle v) (Just . acknowledgePlayPurchase) google, + acknowledgeGoogleSubscription = maybe (acknowledgeGoogleSubscription v) (Just . acknowledgePlaySubscription) google, + checkSubscription = case (snd =<< apple, checkPlaySubscription <$> google) of + (Nothing, Nothing) -> checkSubscription v + (checkApple_, checkGoogle_) -> Just $ \ref _ -> case ref of + SubscriptionApple originalId -> maybe notConfigured ($ originalId) checkApple_ + SubscriptionGoogle token -> maybe notConfigured ($ token) checkGoogle_, + storeChecks = if devCheckStoreDuringCoverage && devCreditTestPurchases then ChecksAtEveryRequest else ChecksAfterCoverage, + creditTestPurchases = devCreditTestPurchases } } Nothing -> pure env where orExit = (>>= either (\e -> putStrLn ("Error: " <> e) >> exitFailure) pure) + notConfigured = pure $ Left SRNotConfigured badgeService :: BadgeServiceOpts -> ChatConfig -> ServiceState -> IO () badgeService opts@BadgeServiceOpts {serviceConfigFile} cfg env = do @@ -289,22 +321,57 @@ issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = processQueuedRequests :: BadgeIssuerKey -> Maybe (TQueue GroupEvent) -> ServiceState -> IO () processQueuedRequests key trackerQ_ env = do cc <- atomically $ readTMVar $ serviceCC env - -- a Play hand-over can wait two verifyTimeouts on Play, so it waits on a lane of its own - playQ <- newTQueueIO - let answer (u, reqId, sigKey, reqData) = handleServiceRequest key (storeVerifier env) cc trackerQ_ u reqId sigKey reqData - route req@(_, _, _, reqData) - | presentsPlayReceipt reqData = atomically $ writeTQueue playQ req - | otherwise = answer req + -- a store call can take verifyTimeout, and a Play hand-over two, so a request that may make one waits on a lane of its own, and renewal checks on one no purchase can fill + purchaseQ <- newTQueueIO + renewalQ <- newTQueueIO + checks <- newPurchaseChecks + let answer (u, reqId, sigKey, reqData) = handleServiceRequest key (storeVerifier env) checks cc trackerQ_ u reqId sigKey reqData + route req@(_, _, sigKey, reqData) = + requestLane (storeChecks $ storeVerifier env) cc sigKey reqData >>= \case + MainLane -> answer req + PurchaseLane -> atomically $ writeTQueue purchaseQ req + RenewalLane -> atomically $ writeTQueue renewalQ req lane q act = forever $ do req@(_, reqId, _, _) <- atomically $ readTQueue q survive ("request " <> safeDecodeUtf8 (strEncode reqId)) $ act req - raceAny_ [lane (serviceRequestQ env) route, lane playQ answer] + raceAny_ [lane (serviceRequestQ env) route, lane purchaseQ answer, lane renewalQ answer] --- | Only what creates a purchase leaves the main lane: an append to an existing ledger is guarded by nothing but that lane being serial. -presentsPlayReceipt :: J.Object -> Bool -presentsPlayReceipt reqData = case J.fromJSON (J.Object reqData) of - J.Success BadgeServiceRequest {request = BSCPurchaseBadge {payment = SPGoogle {}, upgrade = Nothing}} -> True - _ -> False +data RequestLane = MainLane | PurchaseLane | RenewalLane + deriving (Eq, Show) + +-- | Store calls wait off the main lane, so appends to one ledger come from more than one lane: each takes its +-- purchase's row lock before re-reading the tip, so the lanes may run concurrently at any --pool-size. +requestLane :: StoreChecks -> ChatController -> Maybe C.PublicKeyEd25519 -> J.Object -> IO RequestLane +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 + withDB' "requestLane" cc (\db -> getIssuePurchase db k) <&> \case + -- a due month goes to the serial renewal lane even within the hour, so it queues behind a check still in flight + Right (Just (_, Just tip, Just _)) + | checks == ChecksAtEveryRequest || balanceStartTs tip <= addUTCTime routeLookahead now -> RenewalLane + 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. +routeLookahead :: NominalDiffTime +routeLookahead = 60 -- | Cancellation is rethrown, since that is how the race stops this thread. The -- exception itself is not logged: it can quote the request, which carries codes and store receipts. @@ -326,13 +393,14 @@ badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do unless noAddress $ initializeBotAddress' (not testing) (Just True) False cc void $ atomically $ tryPutTMVar (serviceCC env) cc -handleServiceRequest :: BadgeIssuerKey -> StoreVerifier -> ChatController -> Maybe (TQueue GroupEvent) -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO () -handleServiceRequest key verifier cc trackerQ_ User {userId} reqId sigKey reqData = do +handleServiceRequest :: BadgeIssuerKey -> StoreVerifier -> PurchaseChecks -> ChatController -> Maybe (TQueue GroupEvent) -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO () +handleServiceRequest key verifier checks cc trackerQ_ User {userId} reqId sigKey reqData = do let reqIdT = safeDecodeUtf8 (strEncode reqId) logInfo $ "badge service request " <> reqIdT resp <- - badgeServiceResponse key verifier cc trackerQ_ sigKey reqData `catchOwn'` \_ -> + badgeServiceResponse key verifier checks cc trackerQ_ sigKey reqData `catchOwn'` \_ -> logError ("badge service request " <> reqIdT <> " failed") $> errorResponse BSEInternal + logInfo $ "badge answer: " <> responseName resp sendChatCmd cc (APISendServiceResponse userId reqId (responseObject resp)) >>= \case Right _ -> pure () Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e @@ -354,25 +422,36 @@ badgeErrorRetryAfter = \case -- | The agent verified the signature, so sigKey is a key the sender holds; a differing purchaseKey would let a client claim a purchase it cannot sign for. -badgeServiceResponse :: BadgeIssuerKey -> StoreVerifier -> ChatController -> Maybe (TQueue GroupEvent) -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse -badgeServiceResponse key verifier cc trackerQ_ sigKey reqData = case J.fromJSON (J.Object reqData) of +badgeServiceResponse :: BadgeIssuerKey -> StoreVerifier -> PurchaseChecks -> ChatController -> Maybe (TQueue GroupEvent) -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse +badgeServiceResponse key verifier checks cc trackerQ_ sigKey reqData = case J.fromJSON (J.Object reqData) of J.Error _ -> pure $ errorResponse BSEBadRequest J.Success BadgeServiceRequest {version, purchaseKey, request} | not (version `isCompatible` supportedBadgeServiceVRange) -> pure $ errorResponse BSEUnsupportedVersion | purchaseKey /= sigKey -> pure $ errorResponse BSEBadRequest - | otherwise -> case request of + | otherwise -> logInfo ("badge request: " <> commandName request) >> case request of BSCRedeemBadgeCode {masterKey, code} -> case purchaseKey of Just k -> redeemCode key cc trackerQ_ k masterKey code 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 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 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 @@ -397,9 +476,9 @@ credentialForEntry BadgeIssuerKey {keyIdx, secretKey} masterKey e@StatementEntry issuanceAfter :: StatementEntry -> (StatementEntry, BadgeCredential) -> (StatementEntry, StatementEntry, BadgeCredential) issuanceAfter previous (issued, credential) = (previous, issued, credential) -credentialResponse :: Maybe BadgeCredential -> Maybe T.Text -> [StatementEntry] -> BadgeServiceResponse -credentialResponse credential previousEntryId entries = - BSPBadgeCredential {credential, receipt = Nothing, statement = BadgeStatement {entries, previousEntryId}} +credentialResponse :: Maybe BadgeCredential -> Maybe T.Text -> Maybe SubscriptionState -> [StatementEntry] -> BadgeServiceResponse +credentialResponse credential previousEntryId subscription entries = + BSPBadgeCredential {credential, receipt = Nothing, statement = BadgeStatement {entries, previousEntryId}, subscription} -- | Nothing is written until the credential is signed, so a signing failure leaves the code unspent. redeemCode :: BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> C.PublicKeyEd25519 -> BadgeMasterKey -> T.Text -> IO BadgeServiceResponse @@ -421,7 +500,7 @@ redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode readCode now code db >>= \case Left resp -> pure (resp, False) Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> (errorResponse BSEInternal, False) - Just purchaseId -> liftIO $ (,True) <$> firstMonthResponse db purchaseId Nothing firstMonth + Just purchaseId -> liftIO $ (,True) <$> firstMonthResponse db purchaseId Nothing Nothing firstMonth let (resp, claimed) = fromRight (errorResponse BSEInternal, False) r when (claimed && hasTracker redeemLimit) $ refreshTracker cc trackerQ_ badgeCodeId code pure resp @@ -434,7 +513,7 @@ redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode -- A key that already redeemed gets its credential back without a use, even if the code has since -- expired or been revoked: a client whose reply was lost retries, and would otherwise lose the badge. KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> - maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) + maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing Nothing) <$> getLedgerEntries db badgePurchaseId 0 -- code_used would make the client drop its keys, so the holder could never get the badge back. KeyRedeemedUnreadable -> @@ -448,15 +527,28 @@ 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 -> C.PublicKeyEd25519 -> BadgeMasterKey -> StoreReceipt -> IO BadgeServiceResponse -purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, verifyReceipt, acknowledgeReceipt} = - 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 -> verifyReceipt >>= \case Left refusal -> storeRefusalResponse refusal @@ -465,12 +557,20 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran | transactionRef /= providerRef -> storeRefusalResponse $ SRVerifierFailed "verified a transaction other than the one claimed" Right VerifiedStoreTransaction {quantity} | quantity /= 1 -> storeRefusalResponse $ SRVerifierFailed $ "verified a quantity of " <> tshow quantity - Right VerifiedStoreTransaction {testPurchase = True} -> storeRefusalResponse SRTestPurchase + 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 @@ -479,32 +579,222 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran Right (Left resp) -> resp _ -> errorResponse BSEInternal -- the product is read only for a receipt not yet credited, so retiring it leaves its replays answered - newPurchase tx@VerifiedStoreTransaction {productId, paid} = case storeProduct provider productId of + newPurchase tx@VerifiedStoreTransaction {productId, paid, testPurchase} = case storeProduct provider productId of Nothing -> pure $ errorResponse BSEProductUnavailable - Just StoreProduct {badgeType, months} -> - maybe (pure $ Right ()) ($ tx) acknowledgeReceipt >>= \case - Left refusal -> storeRefusalResponse refusal - Right () -> do - now <- badgeNow cc - signFirstMonth key cc masterKey badgeType months (SCPayment Nothing) now >>= \case + -- an Apple subscription, whose JWS was verified offline + Just StoreSubscription -> purchaseSubscription (Just productId) Uncredited + Just StoreOneTime {badgeType, months} -> do + when testPurchase $ logWarn "[dev] crediting a store test purchase as paid: credit_test_purchases is on" + acknowledged (($ tx) <$> acknowledgeReceipt) $ do + now <- badgeNow cc + signFirstMonth key cc masterKey badgeType months (SCPayment Nothing) now >>= \case + Left resp -> pure resp + Right firstMonth -> + claimPurchase now (\paymentId -> NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType, subscriptionState = Nothing, providerToken = Nothing}) $ + \db purchaseId paymentId -> firstMonthResponse db purchaseId (Just paymentId) Nothing firstMonth + -- another key's credit is told only once the store vouched for the subscription, as for a one-time purchase; + -- the store is asked at most once an interval per subscription and per purpose, whoever presents it + purchaseSubscription product_ credit = do + now <- badgeNow cc + atomically (subscriptionAsk now) >>= \case + ClaimHeld remaining -> pure BSPError {code = BSEPaymentPending, message = Nothing, retryAfter = Just (ceiling remaining)} + NoPlayRead wait -> do + logWarn "Play subscription read refused: the purchase path's reads for this minute are used" + pure BSPError {code = BSERateLimited, message = Nothing, retryAfter = Just (ceiling wait)} + AskStore -> + checkStoreSubscription verifier subscriptionRef product_ >>= \case + -- no store was asked, so the claim is not held off + Left SRNotConfigured -> atomically (modifyTVar' claimChecks $ M.delete claimKey) >> storeRefusalResponse SRNotConfigured + Left refusal -> atLeastCheckInterval <$> storeRefusalResponse refusal + 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 claimKey >>= \case + Just remaining -> pure $ ClaimHeld remaining + Nothing -> + maybe (pure Nothing) (`playReadWait` now) playReads_ >>= \case + Nothing -> pure AskStore + -- a claim refused a read is not held, as Play was not asked + Just wait -> modifyTVar' claimChecks (M.delete claimKey) $> NoPlayRead wait + claimKey = ClaimKey {claimRef = providerRef, claimPurpose} + claimPurpose = case use of + RUPurchase -> ClaimPurchase + RUTransfer _ -> ClaimTransfer + (claimChecks, playReads_) = case subscriptionRef of + SubscriptionApple _ -> (appleChecks checks, Nothing) + SubscriptionGoogle _ -> (googleChecks checks, Just $ playReads checks) + newSubscription checked@SubscriptionCheck {subscriptionState} = do + now <- badgeNow cc + 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 <*> randomId cc + let seed = emptyEntry periodStart badgeType + signMonthAfter key cc masterKey now seed (chargeEntries periodStart now badgeType months purchaseKey chargeId entryIds seed) >>= \case Left resp -> pure resp - Right firstMonth -> do - paymentId <- randomId cc - r <- withDB "writeStorePurchase" cc $ \db -> - liftIO (createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType} now) >>= \case - -- Credited to another key, or to this one by a request that ran alongside it, while signing. - Nothing -> - liftIO (getStorePaymentCredit db provider providerRef >>= creditedResponse db purchaseKey) >>= \case - Left resp -> pure resp - Right () -> logError ("badge service: a payment for " <> providerRef <> " exists but funds no purchase") $> errorResponse BSEInternal - Just purchaseId -> liftIO $ firstMonthResponse db purchaseId (Just paymentId) firstMonth - pure $ fromRight (errorResponse BSEInternal) r + 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} 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 to another key" $> 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 + acknowledged acknowledge_ crediting = + fromMaybe (pure $ Right ()) acknowledge_ >>= \case + Left refusal -> storeRefusalResponse refusal + Right () -> crediting + claimPurchase now purchaseFor writeCredit = do + paymentId <- randomId cc + r <- withDB "writeStorePurchase" cc $ \db -> + liftIO (createStorePurchase db (purchaseFor paymentId) now) >>= \case + -- Credited to another key, or to this one by a request that ran alongside it, while signing. + Nothing -> + liftIO (getStorePaymentCredit db provider providerRef >>= creditedResponse db purchaseKey) >>= \case + Left resp -> pure resp + Right () -> logError "badge service: a store payment exists but funds no purchase" $> errorResponse BSEInternal + Just purchaseId -> liftIO $ writeCredit db purchaseId paymentId + pure $ fromRight (errorResponse BSEInternal) r + +-- | Why a store charge grants nothing. +data NotGranted + = NGEnded + | NGNoCharge + | NGMalformedPeriod + | NGRevoked + | NGOffer + | NGUnknownPlan + | 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. 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 + | periodEnd <= periodStart -> Left NGMalformedPeriod + | revoked -> Left NGRevoked + | offer -> Left NGOffer + | 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 :: 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_ + +-- | The store ended the subscription, or revoked the latest charge it reports, one this payment was granted: a refund or a reversal. +coverageEnded :: DB.Connection -> T.Text -> SubscriptionCheck -> IO Bool +coverageEnded db paymentId SubscriptionCheck {subscriptionState, latestCharge} + | subscriptionState == SSEnded = pure True + | Just StoreCharge {chargeRef, revoked = True} <- latestCharge = maybe False snd <$> getSubscriptionCharge db paymentId chargeRef + | otherwise = pure False + +-- | No payment row exists yet to stamp, so a first purchase's checks are bounded by the purchase checks. +firstChargeNotGranted :: PaymentProvider -> NotGranted -> IO BadgeServiceResponse +firstChargeNotGranted provider = \case + NGMalformedPeriod -> storeRefusalResponse $ SRVerifierFailed "a charge whose period does not end after its start" + -- Play issues a new token when an ended subscription is bought again, so this one can never be credited + NGEnded | PPGoogle <- provider -> storeRefusalResponse $ SRInvalid "the subscription ended" + NGNotStarted -> storeRefusalResponse SRPending + -- a later charge, or an Apple resubscription under the same original id, may yet be credited from this receipt + reason -> logInfo ("store subscription not credited yet: " <> tshow reason) $> BSPError {code = BSEPaymentPending, message = Nothing, retryAfter = Just 86400} + +-- | What each request was answered, to pair with its command in a log. No payload: a credential, +-- an invoice and a statement are the client's, and an error's message can quote what it refused. +responseName :: BadgeServiceResponse -> T.Text +responseName = \case + BSPBadgeCatalog {} -> "catalog" + BSPBadgeInvoice {} -> "invoice" + BSPBadgeCredential {credential = Just _, subscription} -> + "badge issued" <> maybe "" (\s -> ", subscription " <> tshow s) subscription + BSPBadgeCredential {credential = Nothing} -> "no month to issue" + BSPError {code} -> "error " <> tshow code + +-- | The command each request ran, so a log can be followed without the request ids. No payload: +-- a payment holds a store receipt, and an upgrade a receipt code. +commandName :: BadgeServiceCommand -> T.Text +commandName = \case + BSCGetBadgeCatalog -> "getBadgeCatalog" + BSCGetBadgeInvoice {} -> "getBadgeInvoice" + BSCRedeemBadgeCode {} -> "redeemBadgeCode" + BSCPurchaseBadge {payment} -> "purchaseBadge " <> paymentName payment + BSCUpgradeBadgeSubscription {payment} -> "upgradeBadgeSubscription " <> paymentName payment + BSCTransferBadge {payment} -> "transferBadge " <> paymentName payment + BSCIssueBadge {} -> "issueBadge" + BSCPauseBadge -> "pauseBadge" + where + paymentName = \case + SPApple {} -> "(App Store)" + SPGoogle {} -> "(Play)" + SPInvoice {} -> "(invoice)" + SPReceipt {} -> "(receipt)" -- | A forged receipt and a refunded one are both receipt_invalid, so the client learns nothing a -- forger could iterate on. A test purchase is named, since the device that made it already knows. storeRefusalResponse :: StoreRefusal -> IO BadgeServiceResponse storeRefusalResponse = \case - SRInvalid reason -> logInfo ("store receipt refused: " <> reason) $> errorResponse BSEReceiptInvalid + -- warn, not info: every one of these ends a purchase for good, and one of them (a store that no longer + -- knows a subscription it once sold) can do that to a purchase the user really paid for + SRInvalid reason -> logWarn ("store receipt refused for good: " <> reason) $> errorResponse BSEReceiptInvalid SRTestPurchase -> logInfo "store receipt refused: test purchase" $> errorResponse BSETestPurchase SRPending -> pure $ errorResponse BSEPaymentPending SRUnreachable reason -> logWarn ("store unreachable: " <> reason) $> errorResponse BSEProviderUnavailable @@ -515,68 +805,322 @@ creditedResponse :: DB.Connection -> C.PublicKeyEd25519 -> FundingCredit -> IO ( creditedResponse db purchaseKey = \case Uncredited -> pure $ Right () CreditedUnreadable -> pure $ Left $ errorResponse BSEInternal - Credited CreditedPurchase {purchaseKey = k, badgePurchaseId, credential} + Credited CreditedPurchase {purchaseKey = k, badgePurchaseId, credential, subscription} | k /= purchaseKey -> pure $ Left $ errorResponse BSEReceiptUsed | otherwise -> - maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) + maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing subscription) <$> getLedgerEntries db badgePurchaseId 0 -signFirstMonth :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> BadgeType -> Int -> StatementCreditType -> UTCTime -> IO (Either BadgeServiceResponse (StatementEntry, (StatementEntry, BadgeCredential))) +signFirstMonth :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> BadgeType -> Int -> StatementCreditType -> UTCTime -> IO (Either BadgeServiceResponse ([StatementEntry], (StatementEntry, StatementEntry, BadgeCredential))) signFirstMonth key cc masterKey badgeType months credit now = do - (grantUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc + grantUuid <- randomId cc -- 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 granted = grantEntry now grantUuid months credit $ emptyEntry now badgeType - -- A grant of at least one month starting now always has a month to issue. - case issueEntry now issueUuid granted of - Nothing -> pure $ Left $ errorResponse BSEInternal + let seed = emptyEntry now badgeType + 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))) +signMonthAfter key cc masterKey now previous rows = do + issueUuid <- randomId cc + let funded = last (previous : rows) + case issueEntry now issueUuid funded of + Nothing -> logError "badge service: the rows written fund no month to issue" $> Left (errorResponse BSEInternal) Just issued -> credentialForEntry key masterKey issued >>= \case Left e -> logError ("badge service signing failed: " <> T.pack e) $> Left (errorResponse BSEInternal) - Right signed -> pure $ Right (granted, signed) + Right signed -> pure $ Right (rows, issuanceAfter funded signed) -firstMonthResponse :: DB.Connection -> Int64 -> Maybe T.Text -> (StatementEntry, (StatementEntry, BadgeCredential)) -> IO BadgeServiceResponse -firstMonthResponse db purchaseId creditPaymentId_ (granted, signed) = do - appendLedgerPlan db purchaseId creditPaymentId_ [granted] $ Just $ issuanceAfter granted signed +firstMonthResponse :: DB.Connection -> Int64 -> Maybe T.Text -> Maybe SubscriptionState -> ([StatementEntry], (StatementEntry, StatementEntry, BadgeCredential)) -> IO BadgeServiceResponse +firstMonthResponse db purchaseId creditPaymentId_ subscription (rows, issuance@(_, _, credential)) = do + appendLedgerPlan db purchaseId creditPaymentId_ rows $ Just issuance entries_ <- getLedgerEntries db purchaseId 0 - pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_ + pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just credential) Nothing subscription) entries_ + +-- | The subscription a device's transaction names, its product and that product's tier: what an upgrade waits for, never what it grants. +data SubscriptionUpgrade = SubscriptionUpgrade + { upgradeRef :: T.Text, + upgradeProductId :: 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, upgradeProductId = productId, upgradeTier = tier}) balance -- | The purchase is reached through the verified signer key and no other way. -issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse -issueBadgeCmd key cc 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 -> do - p_ <- getPurchaseByKey db purchaseKey - forM p_ $ \p@ServicePurchase {badgePurchaseId} -> (p,) <$> getLedgerTip db badgePurchaseId + purchase_ <- withDB' "getBadgePurchase" cc (\db -> getIssuePurchase db purchaseKey) case purchase_ of Left _ -> pure $ errorResponse BSEInternal Right Nothing -> pure $ errorResponse BSEUnknownPurchaseKey - Right (Just (ServicePurchase {badgePurchaseId, masterKey, badgeType}, tip)) -> do + Right (Just (purchase, Just tip, Just subscription)) + | 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 + | balanceStartTs tip <= now -> checkStoreBeforeMonth 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 (lapseUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc let tipEntry = fromMaybe (emptyEntry now badgeType) tip lapsed = lapseEntry now lapseUuid tipEntry current = fromMaybe tipEntry lapsed case issueEntry now issueUuid current of - Nothing -> writeIssued badgePurchaseId tip (maybeToList lapsed) now Nothing + Nothing -> writeIssued badgePurchaseId tip (maybeToList lapsed) now Nothing state_ Just e -> credentialForEntry key masterKey e >>= \case Left err -> logError ("badge service signing failed: " <> T.pack err) $> errorResponse BSEInternal Right signed -> - writeIssued badgePurchaseId tip (maybeToList lapsed) now $ Just $ issuanceAfter current signed - where + writeIssued badgePurchaseId tip (maybeToList lapsed) now (Just $ issuanceAfter current signed) state_ -- Write only if the tip has not moved, since another request may have advanced it. - writeIssued purchaseId tip rows t issuance_ = do + writeIssued purchaseId tip rows t issuance_ state_ = do r <- withDB "issueBadge" cc $ \db -> liftIO $ do - tip' <- getLedgerTip db purchaseId + tip' <- lockedLedgerTip db purchaseId t when (fmap entryId tip' == fmap entryId tip) $ appendLedgerPlan db purchaseId Nothing rows issuance_ - issueResponse db purchaseId t + 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 upgrade@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 upgrade) 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 upgrading_ ServicePurchase {badgePurchaseId, masterKey} tip@StatementEntry {balanceBadgeType} subscription@PurchaseSubscription {paymentId, provider, subscriptionRef, storedState} now + | isNothing upgrading_ && 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 () -> + -- the stores ignore the raise's product; the development mock charges its plan from now on + checkStoreSubscription verifier subscriptionRef (upgradeProductId <$> upgrading_) >>= \case + Left refusal -> atLeastCheckInterval <$> storeRefusalResponse refusal + 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}, (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 <*> 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 + tip' <- lockedLedgerTip db badgePurchaseId now + if fmap entryId tip' /= Just (entryId tip) + then pure Nothing + 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 <$> 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 + Left _ -> pure $ errorResponse BSEInternal + where + -- the store's answer is kept, and a charge it reports is recorded once, granted or not + recordCheck charge_ state = do + chargeId <- randomId cc + answered "recordSubscriptionCheck" $ \db -> do + forM_ charge_ $ \charge -> insertSubscriptionCharge db paymentId chargeId charge now + setSubscriptionState db paymentId state now + checkedResponse db balanceBadgeType state + checkedResponse db ledgerTier state = case upgradeTier <$> upgrading_ 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} tip PurchaseSubscription {paymentId, provider, subscriptionRef} now = + 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} -> do + newChargeId <- randomId cc + entryIds <- (,,,) <$> randomId cc <*> randomId cc <*> randomId cc <*> randomId cc + r <- withDB' "checkStoreDuringCoverage" cc $ \db -> do + tip' <- lockedLedgerTip db badgePurchaseId now + ended <- coverageEnded db paymentId checked + banked <- + if not ended && fmap entryId tip' == Just (entryId tip) + then do + 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 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 + pure bankedMonths + else pure Nothing + (ended, banked,) <$> getLedgerTip db badgePurchaseId + case r of + Left _ -> pure $ errorResponse BSEInternal + Right (True, _, _) -> refundRemaining purchase tip paymentId now + Right (False, banked, tip_) -> do + forM_ banked logBanked + issueDue purchase tip_ (Just subscriptionState) now + -- While coverage runs the store is asked before each new month, so a refund ends the months not yet issued; a store + -- that fails or does not answer ends nothing, and the month is issued as before. + checkStoreBeforeMonth purchase tip subscription@PurchaseSubscription {paymentId, subscriptionRef, storedState} now + | held, storedState == SSEnded = refundRemaining purchase tip paymentId now + | held = issueDue purchase (Just tip) (Just storedState) now + | otherwise = + withDB' "stampSubscriptionCheck" cc (\db -> stampSubscriptionCheck db paymentId now) >>= \case + Left _ -> pure $ errorResponse BSEInternal + Right () -> + checkStoreSubscription verifier subscriptionRef Nothing >>= \case + Left refusal -> storeRefusalResponse refusal >> issueDue purchase (Just tip) (Just storedState) now + Right checked@SubscriptionCheck {subscriptionState, latestCharge} -> do + chargeId <- randomId cc + r <- withDB' "recordSubscriptionCheck" cc $ \db -> do + ended <- coverageEnded db paymentId checked + -- a new charge is only recorded: it is granted once coverage ends, as a renewal + unless ended $ forM_ latestCharge $ \charge -> insertSubscriptionCharge db paymentId chargeId charge now + setSubscriptionState db paymentId (if ended then SSEnded else subscriptionState) now + pure ended + case r of + Left _ -> pure $ errorResponse BSEInternal + Right True -> refundRemaining purchase tip paymentId now + Right False -> issueDue purchase (Just tip) (Just subscriptionState) now + where + held = isJust $ checkWait now subscription + refundRemaining ServicePurchase {badgePurchaseId} tip paymentId now = do + (lapseId, refundId) <- (,) <$> randomId cc <*> randomId cc + let lapsed = lapseEntry now lapseId tip + refund@StatementEntry {changeMonths = refunded} = debitEntry now refundId SDRefund (fromMaybe tip lapsed) + r <- withDB' "refundSubscription" cc $ \db -> do + tip' <- lockedLedgerTip db badgePurchaseId now + if fmap entryId tip' /= Just (entryId tip) + then pure Nothing + else do + -- with no months left there is nothing to refund, as when an earlier request already refunded them + unless (refunded == 0) $ appendLedgerPlan db badgePurchaseId Nothing (maybeToList lapsed <> [refund]) Nothing + setSubscriptionState db paymentId SSEnded now + Just . withoutCredential <$> issueResponse db badgePurchaseId now (Just SSEnded) + case r of + Right (Just resp) -> resp <$ unless (refunded == 0) (logInfo $ "store subscription ended during coverage: " <> tshow (negate refunded) <> " months refunded") + Right Nothing -> logError "badge service: a subscription's ledger moved while its refund was written" $> errorResponse BSEInternal + Left _ -> pure $ errorResponse BSEInternal + 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" -- Only the asserted entry's identity is read, never the months it claims. - issueResponse db purchaseId t = do + issueResponse db purchaseId t subscription = do let StatementEntry {entryId = assertedUuid} = lastEntry assertedId <- getLedgerEntryId db purchaseId assertedUuid -- TODO [badges] when the assertion does not resolve, heal the ledger and restate it as a -- single opening credit, rather than resending the whole history entries_ <- getLedgerEntries db purchaseId (fromMaybe 0 assertedId) credential_ <- getCurrentIssuance db purchaseId t - pure $ maybe (errorResponse BSEInternal) (credentialResponse credential_ (assertedUuid <$ assertedId)) entries_ + pure $ maybe (errorResponse BSEInternal) (credentialResponse credential_ (assertedUuid <$ assertedId) subscription) entries_ + +getIssuePurchase :: DB.Connection -> C.PublicKeyEd25519 -> IO (Maybe (ServicePurchase, Maybe StatementEntry, Maybe PurchaseSubscription)) +getIssuePurchase db purchaseKey = do + p_ <- getPurchaseByKey db purchaseKey + forM p_ $ \p@ServicePurchase {badgePurchaseId} -> (p,,) <$> getLedgerTip db badgePurchaseId <*> getPurchaseSubscription db badgePurchaseId + +-- | Due with each month, within coverage too, so a refund ends the months not yet issued; at most once an interval. +subscriptionCheckDue :: StoreChecks -> UTCTime -> StatementEntry -> PurchaseSubscription -> Bool +subscriptionCheckDue ChecksAtEveryRequest _ _ _ = True +subscriptionCheckDue ChecksAfterCoverage now tip subscription = + balanceStartTs 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. +subscriptionCheckInterval :: NominalDiffTime +subscriptionCheckInterval = 3600 + +-- | The next check waits out the interval whatever the client is told, so its retry waits as long. +atLeastCheckInterval :: BadgeServiceResponse -> BadgeServiceResponse +atLeastCheckInterval = \case + BSPError {code, message, retryAfter = Just t} -> BSPError {code, message, retryAfter = Just $ max t $ round subscriptionCheckInterval} + resp -> resp + +-- | The subscription claims the purchase path asked a store about, one map per store: the App Store's by original +-- transaction id, Play's by the token's hash, so Play tokens, which cost nothing to make up, cannot fill the App Store's; +-- and the minute's allowance of Play reads. +data PurchaseChecks = PurchaseChecks {appleChecks :: ClaimChecks, googleChecks :: ClaimChecks, playReads :: PlayReads} + +type ClaimChecks = TVar (M.Map ClaimKey UTCTime) + +-- | A claim is held per subscription and per what its receipt was presented for, so a restore on another +-- device is not held off by the purchase the buyer made minutes earlier, and each still asks at most once an interval. +data ClaimKey = ClaimKey {claimRef :: T.Text, claimPurpose :: ClaimPurpose} + deriving (Eq, Ord) + +data ClaimPurpose = ClaimPurchase | ClaimTransfer + deriving (Eq, Ord) + +-- | The Play subscription checks the purchase path made in the current minute, counted as the web listener counts requests. +type PlayReads = TVar (Maybe Bucket) + +newPurchaseChecks :: IO PurchaseChecks +newPurchaseChecks = PurchaseChecks <$> newTVarIO M.empty <*> newTVarIO M.empty <*> newTVarIO Nothing + +-- | How long a claim waits before its store is asked again; Nothing records a check at now. A claim that finds +-- the table full of checks inside the interval is asked without being recorded, so a full table refuses no one. +purchaseCheckWait :: ClaimChecks -> UTCTime -> ClaimKey -> STM (Maybe NominalDiffTime) +purchaseCheckWait checks now key = stateTVar checks $ \m -> + let live = M.filter (\t -> diffUTCTime now t < subscriptionCheckInterval) m + in case M.lookup key live of + Just t -> (Just $ subscriptionCheckInterval - diffUTCTime now t, live) + Nothing + | M.size live >= maxPurchaseChecks -> (Nothing, live) + | otherwise -> (Nothing, M.insert key now live) + +-- | Per store, far above an hour of genuine purchases: every App Store key is one Apple signed for this app, +-- while Play keys cost nothing to make up, so a full Play map only stops recording Play claims. +maxPurchaseChecks :: Int +maxPurchaseChecks = 10000 + +data SubscriptionAsk = AskStore | ClaimHeld NominalDiffTime | NoPlayRead NominalDiffTime + +-- | How long until the purchase path may read Play again; Nothing takes one of this minute's reads. +playReadWait :: PlayReads -> UTCTime -> STM (Maybe NominalDiffTime) +playReadWait taken now = stateTVar taken $ \b_ -> either (\wait -> (Just wait, b_)) (\b -> (Nothing, Just b)) (takeFrom maxPlayPurchaseReads now b_) + +-- | A tenth of Play's default Subscriptions quota of 3,000 reads a minute, which renewal checks share: any token in the +-- accepted grammar costs a read, so this caps what made-up tokens can spend; far above a minute of genuine purchases. +maxPlayPurchaseReads :: Int +maxPlayPurchaseReads = 300 diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index 6d238e78f4..cec4de216a 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -25,6 +25,8 @@ module BadgeService.Store getStorePaymentCredit, purchaseKeyExists, getPurchaseByKey, + setPurchaseBadgeType, + lockedLedgerTip, getLedgerTip, getLedgerEntryId, getLedgerEntries, @@ -32,6 +34,15 @@ module BadgeService.Store appendLedgerPlan, createCodePurchase, createStorePurchase, + PaymentRebind (..), + rebindStorePayment, + getMovedFromExpiry, + PurchaseSubscription (..), + getPurchaseSubscription, + stampSubscriptionCheck, + setSubscriptionState, + getSubscriptionCharge, + insertSubscriptionCharge, insertBadgeCode, setCodeGroupItem, CodeTracker (..), @@ -43,6 +54,7 @@ module BadgeService.Store where import BadgeService.Store.Invoices (executeChanging, paymentStatusText) +import BadgeService.StoreReceipts (StoreCharge (..), SubscriptionRef (..)) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB @@ -52,14 +64,14 @@ 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 (..)) +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.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), PaymentProvider (..), PaymentStatus (..)) import Simplex.Chat.Store.Shared (insertedRowId) import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Encoding.String (textEncode) +import Simplex.Messaging.Encoding.String (textDecode, textEncode) import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow') #if defined(dbPostgres) @@ -99,7 +111,8 @@ data FundingCredit data CreditedPurchase = CreditedPurchase { badgePurchaseId :: Int64, purchaseKey :: C.PublicKeyEd25519, - credential :: BadgeCredential + credential :: BadgeCredential, + subscription :: Maybe SubscriptionState } data NewCodePurchase = NewCodePurchase @@ -116,7 +129,9 @@ data NewStorePurchase = NewStorePurchase paid :: Maybe (CurrencyAmount, Text), purchaseKey :: C.PublicKeyEd25519, masterKey :: BadgeMasterKey, - badgeType :: BadgeType + badgeType :: BadgeType, + subscriptionState :: Maybe SubscriptionState, + providerToken :: Maybe Text -- Play's token of a subscription, which every renewal check asks by; never logged or returned } data ServicePurchase = ServicePurchase @@ -192,7 +207,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, i.period_end DESC LIMIT 1 |] (badgeCodeId, key) @@ -207,18 +222,18 @@ getStorePaymentCredit db provider providerRef = DB.query db [sql| - SELECT p.badge_purchase_id, p.purchase_key, i.credential + SELECT p.badge_purchase_id, p.purchase_key, i.credential, pay.subscription_state FROM sx_badge_service_payments pay 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, i.period_end DESC LIMIT 1 |] (textEncode provider, providerRef) where - toCredit (badgePurchaseId, purchaseKey, credential_) = case decodeCredential =<< credential_ of - Just credential -> Credited CreditedPurchase {badgePurchaseId, purchaseKey, credential} + toCredit (badgePurchaseId, purchaseKey, credential_, state_) = case decodeCredential =<< credential_ of + Just credential -> Credited CreditedPurchase {badgePurchaseId, purchaseKey, credential, subscription = textDecode =<< state_} Nothing -> CreditedUnreadable decodeCredential :: Binary ByteString -> Maybe BadgeCredential @@ -244,6 +259,18 @@ 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) + +-- | First in a transaction that appends after the tip it returns: the row lock makes concurrent appends to one +-- ledger wait for each other, as Postgres reads at READ COMMITTED. +lockedLedgerTip :: DB.Connection -> Int64 -> UTCTime -> IO (Maybe StatementEntry) +lockedLedgerTip db purchaseId now = do + DB.execute db "UPDATE sx_badge_service_badge_purchases SET updated_at = ? WHERE badge_purchase_id = ?" (now, purchaseId) + getLedgerTip db purchaseId + getLedgerTip :: DB.Connection -> Int64 -> IO (Maybe StatementEntry) getLedgerTip db purchaseId = maybeFirstRow' Nothing toEntry $ @@ -251,9 +278,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.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 @@ -276,37 +306,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.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 StatementEntry -toEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, entryType_, credit_, debit_, createdAt) :. (paymentId_, invoiceId_)) = +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_) 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, period_end 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 (charge_id, 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 @@ -327,19 +368,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_ = case entryType of - SECredit SCPayment {} -> creditPaymentId_ - _ -> 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) - 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_)) + ((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. @@ -366,16 +419,19 @@ createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = Bad -- | In the transaction of the credential rows. The payment's unique (provider, provider_ref) is the -- claim: a transaction presented twice at once, or under another key, inserts nothing the second time. createStorePurchase :: DB.Connection -> NewStorePurchase -> UTCTime -> IO (Maybe Int64) -createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do +createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey = BadgeMasterKey mk, badgeType, subscriptionState, providerToken} now = do claimed <- executeChanging db [sql| - INSERT INTO sx_badge_service_payments (payment_id, provider, provider_ref, amount, currency, status, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?) + INSERT INTO sx_badge_service_payments + (payment_id, provider, provider_ref, amount, currency, status, subscription_state, subscription_checked_at, provider_token, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?) ON CONFLICT (provider, provider_ref) DO NOTHING |] - (paymentId, textEncode provider, providerRef, (\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, paymentStatusText PSSettled, now, now) + ( (paymentId, textEncode provider, providerRef, (\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, paymentStatusText PSSettled) + :. (textEncode <$> subscriptionState, now <$ subscriptionState, providerToken, now, now) + ) if claimed == 0 then pure Nothing else do @@ -389,6 +445,132 @@ 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 <- lockedLedgerTip db fromPurchaseId now + 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, + provider :: PaymentProvider, + subscriptionRef :: SubscriptionRef, + storedState :: SubscriptionState, + checkedAt :: Maybe UTCTime + } + +-- | Nothing for a purchase no subscription funds. +getPurchaseSubscription :: DB.Connection -> Int64 -> IO (Maybe PurchaseSubscription) +getPurchaseSubscription db purchaseId = + maybeFirstRow' Nothing toSubscription $ + DB.query + db + [sql| + SELECT pay.payment_id, pay.provider, pay.provider_ref, pay.provider_token, pay.subscription_state, pay.subscription_checked_at + FROM sx_badge_service_badge_purchases p + JOIN sx_badge_service_payments pay ON pay.payment_id = p.payment_id + WHERE p.badge_purchase_id = ? AND pay.subscription_state IS NOT NULL + |] + (Only purchaseId) + where + toSubscription (paymentId, provider_, providerRef, token_, state_, checkedAt) = do + provider <- textDecode provider_ + subscriptionRef <- case provider of + PPApple -> Just $ SubscriptionApple providerRef + PPGoogle -> SubscriptionGoogle <$> token_ + _ -> Nothing + storedState <- textDecode state_ + Just PurchaseSubscription {paymentId, provider, subscriptionRef, storedState, checkedAt} + +-- | Taken before the store is asked, so a check that fails or never returns still holds the next one off. +stampSubscriptionCheck :: DB.Connection -> Text -> UTCTime -> IO () +stampSubscriptionCheck db paymentId now = + DB.execute db "UPDATE sx_badge_service_payments SET subscription_checked_at = ?, updated_at = ? WHERE payment_id = ?" (now, now, paymentId) + +setSubscriptionState :: DB.Connection -> Text -> SubscriptionState -> UTCTime -> IO () +setSubscriptionState db paymentId state now = + DB.execute db "UPDATE sx_badge_service_payments SET subscription_state = ?, updated_at = ? WHERE payment_id = ?" (textEncode state, now, paymentId) + +-- | The id a charge was recorded under, and whether a ledger row grants it. +getSubscriptionCharge :: DB.Connection -> Text -> Text -> IO (Maybe (Text, Bool)) +getSubscriptionCharge db paymentId chargeRef = + maybeFirstRow (\(chargeId, granted) -> (chargeId, (granted :: Int) > 0)) $ + DB.query + db + [sql| + SELECT c.charge_id, CASE WHEN EXISTS (SELECT 1 FROM sx_badge_service_badge_ledger l WHERE l.charge_id = c.charge_id) THEN 1 ELSE 0 END + FROM sx_badge_service_subscription_charges c + WHERE c.payment_id = ? AND c.provider_charge_ref = ? + |] + (paymentId, chargeRef) + +-- | A charge the store reports again is recorded once, by its own reference. +insertSubscriptionCharge :: DB.Connection -> Text -> Text -> StoreCharge -> UTCTime -> IO () +insertSubscriptionCharge db paymentId chargeId StoreCharge {chargeRef, planId, periodStart, periodEnd, chargePaid = paid} now = + DB.execute + db + [sql| + INSERT INTO sx_badge_service_subscription_charges + (charge_id, payment_id, provider_charge_ref, plan_id, period_start, period_end, amount, currency, created_at) + VALUES (?,?,?,?,?,?,?,?,?) + ON CONFLICT (payment_id, provider_charge_ref) DO NOTHING + |] + ((chargeId, paymentId, chargeRef, planId, periodStart, periodEnd) :. ((\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, now)) + -- | Revoked and AlreadyRevoked carry the code id, so the caller can retire the code's group tracker, -- or repair one an earlier revoke left live. data RevokeResult = Revoked Int64 | AlreadyRevoked Int64 | AlreadyRedeemed | NoSuchCode 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 92d3b5fd47..b2c3b86002 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs @@ -19,7 +19,8 @@ schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops), - ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts) + ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts), + ("20261012_badge_subscriptions", m20261012_badge_subscriptions, Just down_m20261012_badge_subscriptions) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -191,6 +192,86 @@ DROP INDEX @idx_payments_provider_ref; CREATE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref); |] +m20261012_badge_subscriptions :: Text +m20261012_badge_subscriptions = + withPrefix + servicePrefix + -- provider_token is a Play purchase token, a bearer secret: it is kept only for a subscription, which Play is asked about again. + [r| +CREATE TABLE @subscription_charges( + charge_id TEXT NOT NULL PRIMARY KEY, + payment_id TEXT NOT NULL REFERENCES @payments ON DELETE CASCADE, + provider_charge_ref TEXT NOT NULL, + plan_id TEXT NOT NULL, + period_start TIMESTAMPTZ NOT NULL, + period_end TIMESTAMPTZ NOT NULL, + amount BIGINT, + currency TEXT, + created_at TIMESTAMPTZ NOT NULL, + UNIQUE(payment_id, provider_charge_ref) +); + +ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges; + +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; + +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; + +ALTER TABLE @payments DROP COLUMN cancelled; +|] + +down_m20261012_badge_subscriptions :: Text +down_m20261012_badge_subscriptions = + withPrefix + servicePrefix + [r| +ALTER TABLE @payments ADD COLUMN subscription_renews_at TIMESTAMPTZ; + +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; + +DROP TABLE @subscription_charges; +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA; 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 cd3d97f0ac..7f8659d60d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs @@ -20,7 +20,8 @@ schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations = [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops), - ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts) + ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts), + ("20261012_badge_subscriptions", m20261012_badge_subscriptions, Just down_m20261012_badge_subscriptions) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -192,6 +193,86 @@ DROP INDEX @idx_payments_provider_ref; CREATE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref); |] +m20261012_badge_subscriptions :: Query +m20261012_badge_subscriptions = + withPrefix + servicePrefix + -- provider_token is a Play purchase token, a bearer secret: it is kept only for a subscription, which Play is asked about again. + [sql| +CREATE TABLE @subscription_charges( + charge_id TEXT NOT NULL PRIMARY KEY, + payment_id TEXT NOT NULL REFERENCES @payments ON DELETE CASCADE, + provider_charge_ref TEXT NOT NULL, + plan_id TEXT NOT NULL, + period_start TEXT NOT NULL, + period_end TEXT NOT NULL, + amount INTEGER, + currency TEXT, + created_at TEXT NOT NULL, + UNIQUE(payment_id, provider_charge_ref) +) STRICT; + +ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges; + +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; + +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; + +ALTER TABLE @payments DROP COLUMN cancelled; +|] + +down_m20261012_badge_subscriptions :: Query +down_m20261012_badge_subscriptions = + withPrefix + servicePrefix + [sql| +ALTER TABLE @payments ADD COLUMN subscription_renews_at TEXT; + +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; + +DROP TABLE @subscription_charges; +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BLOB; diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs index 2789e80c54..064cc56ecb 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs @@ -2,23 +2,40 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module BadgeService.StoreReceipts ( VerifiedStoreTransaction (..), StoreRefusal (..), StoreVerifier (..), + StoreChecks (..), StoreReceipt (..), + SubscriptionRef (..), + SubscriptionCheck (..), + StoreCharge (..), + StoreVerifierFailure (..), noStoreVerifier, toStoreReceipt, + checkStoreSubscription, + storeRequest, ) where -import Control.Exception (evaluate) +import BadgeService.Log (logInfo, logWarn) +import Control.Exception (Exception, catch, evaluate, try) +import qualified Data.ByteString.Lazy as LB import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, isControl, isDigit, isPrint, isSpace) +import Data.Functor (($>)) +import Data.Int (Int64) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T -import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef) +import Data.Time.Clock (UTCTime) +import Network.HTTP.Client (HttpException (..), Manager, Request, Response (..), brReadSome, parseRequest, withResponse) +import Network.HTTP.Types (Status (..)) +import Simplex.Chat.Badges.Service (SubscriptionState) +import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef, googlePurchaseRef) import Simplex.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider (..), StoreTransactionRef (..)) import Simplex.Messaging.Util (catchOwn', tshow) import System.Timeout (timeout) @@ -27,7 +44,7 @@ import System.Timeout (timeout) -- TODO [badges] PaymentFunding's PFApple and PFGoogle sketch the same thing and have no producer; -- delete them, or build them out and reconcile. data VerifiedStoreTransaction = VerifiedStoreTransaction - { transactionRef :: Text, -- from what was verified: Apple's transactionId, googlePurchaseRef of the token asked about + { transactionRef :: Text, -- from what was verified: applePayloadRef of Apple's payload, googlePurchaseRef of the token asked about productId :: Text, quantity :: Int, -- as the store reported it; the service refuses any but 1, as the apps never buy more -- costs the buyer nothing: Apple's Sandbox, which a public TestFlight build buys in, and Google's license testers @@ -49,34 +66,92 @@ data StoreRefusal | SRNotConfigured -- no verifier for this store is deployed; the purchase may be real deriving (Eq, Show) --- | Apple signs its receipt and ships the certificate chain in it, so it is verified with no network --- call; a Play token is opaque and must be asked about, which is why only the Play fields are in IO. +-- | What a refusal was, for a log. The reasons carry no receipt, token or key: a store request's +-- exceptions are reduced to their kind, and an unsendable token to its shape. +refusalLabel :: StoreRefusal -> Text +refusalLabel = \case + SRInvalid reason -> "invalid: " <> reason + SRTestPurchase -> "a test purchase" + SRPending -> "not settled yet" + SRUnreachable reason -> "no answer: " <> reason + SRVerifierFailed reason -> "this service failed: " <> reason + SRNotConfigured -> "no verifier configured" + +-- | Apple's receipt is verified offline, from the certificate chain it ships; a Play token is opaque +-- and must be asked about, and a subscription's charges are known only to its store, so those fields are in IO. data StoreVerifier = StoreVerifier { -- the JWS verifyApple :: Maybe (Text -> Either StoreRefusal VerifiedStoreTransaction), verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)), -- the product id and the token acknowledgeGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal ())), + acknowledgeGoogleSubscription :: Maybe (Text -> Text -> IO (Either StoreRefusal ())), + -- with the product the presented receipt names, absent on a renewal + checkSubscription :: Maybe (SubscriptionRef -> Maybe Text -> IO (Either StoreRefusal SubscriptionCheck)), -- microseconds; a lane answers one request at a time, so a verifier that does not finish holds up the rest of its lane - verifyTimeout :: Int + verifyTimeout :: Int, + storeChecks :: StoreChecks, + -- Local testing only: credits a purchase the store itself calls a test, which no real buyer pays for. + creditTestPurchases :: Bool } +-- | When a subscription's store is asked about it. A real store's next charge has not started while coverage +-- runs, and asking spends the quota every subscriber shares, so only a dev deployment checks at every request. +data StoreChecks = ChecksAfterCoverage | ChecksAtEveryRequest + deriving (Eq, Show) + -- | A store payment, named by the store's own reference before anything is verified. data StoreReceipt = StoreReceipt { txRef :: StoreTransactionRef, + receiptProductId :: Maybe Text, -- named by a Play receipt; Apple's is known only once its JWS is verified + subscriptionRef :: SubscriptionRef, verifyReceipt :: IO (Either StoreRefusal VerifiedStoreTransaction), - acknowledgeReceipt :: Maybe (VerifiedStoreTransaction -> IO (Either StoreRefusal ())) + acknowledgeReceipt :: Maybe (VerifiedStoreTransaction -> IO (Either StoreRefusal ())), + acknowledgeSubscription :: Maybe (IO (Either StoreRefusal ())) } +-- | What a store is asked about a subscription by: Apple's original transaction id, or Play's token. +-- The token is a bearer secret, so this has no Show. +data SubscriptionRef = SubscriptionApple Text | SubscriptionGoogle Text + +data SubscriptionCheck = SubscriptionCheck + { subscriptionState :: SubscriptionState, + testSubscription :: Bool, -- costs the buyer nothing, as a testPurchase does + latestCharge :: Maybe StoreCharge -- the latest paid period, if the store charged at all + } + deriving (Show) + +data StoreCharge = StoreCharge + { chargeRef :: Text, -- Apple's transactionId, a hash of Play's order id + planId :: Text, -- Apple's product id, Play's base plan + periodStart :: UTCTime, + periodEnd :: UTCTime, + chargePaid :: Maybe (CurrencyAmount, Text), -- in minor units; Play reports no price + revoked :: Bool, -- refunded or revoked + -- Apple: any offerType, so an introductory offer (free trial, pay as you go, pay up front), a promotional offer, + -- an offer code or a win-back offer; Play: a free-trial or introductory-price phase + offer :: Bool + } + deriving (Show) + noStoreVerifier :: StoreVerifier -noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing, acknowledgeGoogle = Nothing, verifyTimeout = 10000000} +noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing, acknowledgeGoogle = Nothing, acknowledgeGoogleSubscription = Nothing, checkSubscription = Nothing, verifyTimeout = 10000000, storeChecks = ChecksAfterCoverage, creditTestPurchases = False} -- | Nothing for a payment no store made. Exceptions are not logged, since they can quote the receipt -- or, from Google, a URL holding the token. toStoreReceipt :: StoreVerifier -> ServicePayment -> Maybe (Either StoreRefusal StoreReceipt) -toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, verifyTimeout} = \case - SPApple {jws} -> Just $ case appleTransactionId jws of +toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, acknowledgeGoogleSubscription, verifyTimeout} = \case + SPApple {jws} -> Just $ case appleTransactionRef jws of Nothing -> Left $ SRInvalid "names no transaction" - Just ref -> Right $ StoreReceipt (StoreTransactionRef PPApple ref) (maybe unconfigured (\verify -> offline $ verify jws) verifyApple) Nothing + Just ref -> + Right + StoreReceipt + { txRef = StoreTransactionRef PPApple ref, + receiptProductId = Nothing, + subscriptionRef = SubscriptionApple ref, + verifyReceipt = maybe unconfigured (\verify -> offline $ verify jws) verifyApple, + acknowledgeReceipt = Nothing, + acknowledgeSubscription = Nothing + } SPGoogle {productId, token} -- the claim is the token's hash, so neither string may name any purchase but the one it claims, -- whatever path a verifier builds from them @@ -84,24 +159,79 @@ toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, veri -- Play documents no token grammar, so this is our guess, and refusing to ask Play is not its verdict | not (googleToken token) -> Just $ Left $ SRUnreachable $ "a Play token this service will not send: " <> tokenShape token | otherwise -> - Just $ Right $ - StoreReceipt - (StoreTransactionRef PPGoogle (googlePurchaseRef token)) - (maybe unconfigured (\verify -> online "google verifier" $ verify productId token) verifyGoogle) - ((\acknowledge VerifiedStoreTransaction {alreadyAcknowledged} -> if alreadyAcknowledged then pure (Right ()) else online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle) + Just $ + Right + StoreReceipt + { txRef = StoreTransactionRef PPGoogle (googlePurchaseRef token), + receiptProductId = Just productId, + subscriptionRef = SubscriptionGoogle token, + verifyReceipt = maybe unconfigured (\verify -> online "google verifier" $ verify productId token) verifyGoogle, + acknowledgeReceipt = (\acknowledge VerifiedStoreTransaction {alreadyAcknowledged} -> if alreadyAcknowledged then pure (Right ()) else online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle, + acknowledgeSubscription = (\acknowledge -> online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogleSubscription + } SPInvoice {} -> Nothing SPReceipt {} -> Nothing where unconfigured = pure $ Left SRNotConfigured -- nothing was fetched, so a throw or an overrun is this service's failure or a shape it does not know, never an outage - offline verdict = - (fromMaybe (Left $ SRVerifierFailed "apple verifier timed out") <$> timeout verifyTimeout (forced verdict)) - `catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw" - online what call = - (fromMaybe (Left $ SRUnreachable $ what <> " timed out") <$> timeout verifyTimeout (call >>= forced)) - `catchOwn'` \_ -> pure $ Left $ SRUnreachable $ what <> " threw" - -- a verdict holding a thunk that throws would otherwise throw later, outside these handlers - forced = either (fmap Left . evaluate) (fmap Right . evaluate) + offline verdict = do + r <- + (fromMaybe (Left $ SRVerifierFailed "apple verifier timed out") <$> timeout verifyTimeout (forced verdict)) + `catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw" + logInfo $ "apple receipt: " <> either refusalLabel (const "vouched") r + pure r + online = askStore verifyTimeout + +-- | Both stores are asked online about a subscription, so a throw or an overrun is no verdict. A test +-- purchase is refused here, for a first purchase and a renewal alike. +checkStoreSubscription :: StoreVerifier -> SubscriptionRef -> Maybe Text -> IO (Either StoreRefusal SubscriptionCheck) +checkStoreSubscription StoreVerifier {checkSubscription, verifyTimeout, creditTestPurchases} ref product_ = case checkSubscription of + Nothing -> pure $ Left SRNotConfigured + Just check -> askStore verifyTimeout "subscription check" (check ref product_) >>= either (pure . Left) notTest + where + notTest checked@SubscriptionCheck {testSubscription} + | not testSubscription = pure $ Right checked + | creditTestPurchases = logWarn "[dev] a store test subscription is taken as paid: credit_test_purchases is on" $> Right checked + | otherwise = pure $ Left SRTestPurchase + +-- | Thrown by a verifier that cannot place what the store signed: its own failure, never the store's answer or silence. +newtype StoreVerifierFailure = StoreVerifierFailure Text + deriving (Show) + +instance Exception StoreVerifierFailure + +askStore :: Int -> Text -> IO (Either StoreRefusal a) -> IO (Either StoreRefusal a) +askStore limit what call = do + r <- + (fromMaybe (Left $ SRUnreachable $ what <> " timed out") <$> timeout limit ((call >>= forced) `catch` verifierFailed)) + `catchOwn'` \_ -> pure $ Left $ SRUnreachable $ what <> " threw" + -- that the store was asked and what came of it, since not every path answers with the refusal + logInfo $ what <> ": " <> either refusalLabel (const "vouched") r + pure r + where + verifierFailed (StoreVerifierFailure reason) = pure $ Left $ SRVerifierFailed reason + +-- | A request to a store: its status and a body of at most a mebibyte. http-client's exceptions show +-- the request, whose URL can hold a purchase token, so only their kind is kept. +storeRequest :: Manager -> Text -> (Request -> Request) -> Text -> IO (Either StoreRefusal (Int, LB.ByteString)) +storeRequest manager store prepare url = + try (parseRequest (T.unpack url) >>= \req -> withResponse (prepare req) manager readBody) >>= \case + Left (e :: HttpException) -> pure $ Left $ SRUnreachable $ "request to " <> store <> " failed: " <> failureKind e + Right (code, body) + | LB.length body > maxStoreBytes -> pure $ Left $ SRVerifierFailed $ store <> " answered HTTP " <> tshow code <> " with over " <> tshow maxStoreBytes <> " bytes" + | otherwise -> pure $ Right (code, body) + where + readBody resp = (statusCode (responseStatus resp),) <$> brReadSome (responseBody resp) (fromIntegral maxStoreBytes + 1) + failureKind = \case + HttpExceptionRequest _ content -> T.pack $ takeWhile (/= ' ') $ show content + InvalidUrlException _ _ -> "InvalidUrlException" + +maxStoreBytes :: Int64 +maxStoreBytes = 1024 * 1024 + +-- | A verdict holding a thunk that throws would otherwise throw later, outside the handlers. +forced :: Either StoreRefusal a -> IO (Either StoreRefusal a) +forced = either (fmap Left . evaluate) (fmap Right . evaluate) googleProductId :: Text -> Bool googleProductId pid = case T.uncons pid of diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs index c94c6dec61..1942a984e3 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs @@ -6,15 +6,18 @@ module BadgeService.StoreReceipts.Apple ( verifyAppleTransaction, + appleSubscriptionChecker, readAppleRoot, ) where -import BadgeService.StoreReceipts (StoreRefusal (..), VerifiedStoreTransaction (..)) -import Control.Exception (IOException, try) -import Control.Monad (guard, unless) +import BadgeService.Config (AppleServerApi (..)) +import BadgeService.StoreReceipts (StoreCharge (..), StoreRefusal (..), StoreVerifierFailure (..), SubscriptionCheck (..), VerifiedStoreTransaction (..), storeRequest) +import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, writeTVar) +import Control.Exception (IOException, evaluate, throwIO, try) +import Control.Monad (guard, unless, when) import Crypto.Hash.Algorithms (SHA256 (..)) -import Crypto.Number.Serialize (os2ip) +import Crypto.Number.Serialize (i2ospOf_, os2ip) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECC import qualified Data.Aeson as J @@ -24,31 +27,48 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Lazy as LB +import Data.Char (isDigit) import Data.Foldable (toList) +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.List (find) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.Word (Word32) import Data.X509 import Data.X509.EC (unserializePoint) +import Data.X509.Memory (readKeyFileFromMemory) import Data.X509.Validation (SignatureFailure (..), SignatureVerification (..), verifySignedSignature) +import Network.HTTP.Client (Manager, Request (..)) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types (hAuthorization) +import Simplex.Chat.Badges.Service (SubscriptionState (..)) +import Simplex.Chat.PaymentService (applePayloadRef) import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) -import Simplex.Messaging.Util (eitherToMaybe) +import Simplex.Messaging.Util (catchOwn', eitherToMaybe, tshow) verifyAppleTransaction :: NonEmpty SignedCertificate -> Text -> Text -> Either StoreRefusal VerifiedStoreTransaction -verifyAppleTransaction roots ourBundleId jws = case T.splitOn "." jws of +verifyAppleTransaction roots ourBundleId jws = do + o <- verifiedPayload roots jws + tx <- either (const $ failed "the payload Apple signed is not a transaction") Right $ JT.parseEither appleTransactionP o + transaction ourBundleId tx + +-- | The payload of a JWS that a chain to a configured root signed. +verifiedPayload :: NonEmpty SignedCertificate -> Text -> Either StoreRefusal J.Object +verifiedPayload roots jws = case T.splitOn "." jws of [header, payload, signature] -> do leaf <- signingChain roots =<< certificateChain header sig <- jwsSignature signature key <- leafKey leaf unless (ECDSA.verify SHA256 key sig (encodeUtf8 $ header <> "." <> payload)) $ refused "the signature does not verify" - tx <- either (const $ failed "the payload Apple signed is not a transaction") Right $ do - o <- maybe (Left "not base64url JSON") Right $ jsonObject payload - JT.parseEither appleTransactionP o - transaction ourBundleId tx + maybe (failed "the payload Apple signed is not JSON") Right $ jsonObject payload _ -> refused "not three dot-separated parts" -- | A header or chain in a shape Apple may yet adopt proves no forgery, so it fails rather than refuses. @@ -105,7 +125,7 @@ jwsSignature s = case B64U.decodeUnpadded (encodeUtf8 s) of _ -> refused "the signature is not 64 base64url bytes" data AppleTransaction = AppleTransaction - { transactionId :: Text, + { transactionRef :: Text, productId :: Text, bundleId :: Text, environment :: Text, @@ -117,7 +137,8 @@ data AppleTransaction = AppleTransaction appleTransactionP :: J.Object -> JT.Parser AppleTransaction appleTransactionP o = do - transactionId <- o J..: "transactionId" + -- the same function names the claim, so the transaction vouched for is the one claimed + transactionRef <- maybe (fail "names no transaction") pure $ applePayloadRef o productId <- o J..: "productId" bundleId <- o J..: "bundleId" environment <- o J..: "environment" @@ -125,10 +146,10 @@ appleTransactionP o = do revoked <- isJust <$> (o J..:? "revocationDate" :: JT.Parser (Maybe J.Value)) price <- o J..:? "price" currency <- o J..:? "currency" - pure AppleTransaction {transactionId, productId, bundleId, environment, quantity, revoked, price, currency} + pure AppleTransaction {transactionRef, productId, bundleId, environment, quantity, revoked, price, currency} transaction :: Text -> AppleTransaction -> Either StoreRefusal VerifiedStoreTransaction -transaction ourBundleId AppleTransaction {transactionId, productId, bundleId, environment, quantity, revoked, price, currency} +transaction ourBundleId AppleTransaction {transactionRef, productId, bundleId, environment, quantity, revoked, price, currency} -- the configured bundle id may be the wrong one, and refusing for good would destroy every genuine purchase | bundleId /= ourBundleId = failed "another app's bundle id, or ours misconfigured" | revoked = refused "refunded or revoked" @@ -139,7 +160,7 @@ transaction ourBundleId AppleTransaction {transactionId, productId, bundleId, en _ -> failed "an environment this verifier does not know" Right VerifiedStoreTransaction - { transactionRef = transactionId, + { transactionRef, productId, quantity, testPurchase, @@ -187,3 +208,194 @@ readAppleRoot path = checkRoot root | signedBy root root = Right root | otherwise = Left $ path <> ": is not a self-signed root certificate" + +data AppleApi = AppleApi + { roots :: NonEmpty SignedCertificate, + ourBundleId :: Text, + serverApi :: AppleServerApi, + privateKey :: ECDSA.PrivateKey, + manager :: Manager, + apiToken :: TVar (Maybe (ByteString, UTCTime)) + } + +-- | Asks the App Store Server API about a subscription by its original transaction id. The key is read +-- here, at boot, as the Play service account is. +appleSubscriptionChecker :: NonEmpty SignedCertificate -> Text -> AppleServerApi -> IO (Either String (Text -> IO (Either StoreRefusal SubscriptionCheck))) +appleSubscriptionChecker roots ourBundleId serverApi@AppleServerApi {aPrivateKeyFile} = + readApiKey aPrivateKeyFile >>= \case + Left e -> pure $ Left e + Right privateKey -> do + manager <- newTlsManager + apiToken <- newTVarIO Nothing + pure $ Right $ subscriptionStatus AppleApi {roots, ourBundleId, serverApi, privateKey, manager, apiToken} + +readApiKey :: FilePath -> IO (Either String ECDSA.PrivateKey) +readApiKey path = + try (B.readFile path) >>= \case + Left (_ :: IOException) -> pure $ Left $ path <> ": could not be read" + Right pem -> pure $ case readKeyFileFromMemory pem of + [PrivKeyEC (PrivKeyEC_Named ECC.SEC_p256r1 d)] -> Right $ ECDSA.PrivateKey (ECC.getCurveByName ECC.SEC_p256r1) d + _ -> Left $ path <> ": is not one P-256 private key" + +subscriptionStatus :: AppleApi -> Text -> IO (Either StoreRefusal SubscriptionCheck) +subscriptionStatus api@AppleApi {serverApi = AppleServerApi {aApiHost}} originalId + | T.null originalId || not (T.all isDigit originalId) = pure $ failed "not an App Store transaction id" + | otherwise = + apiCall api (aApiHost <> "/inApps/v1/subscriptions/" <> originalId) >>= \case + Left refusal -> pure $ Left refusal + Right body -> checked $ statusVerdict api originalId body + where + -- a throw while checking what Apple signed is this verifier's failure, so it leaves as one + checked verdict = + (evaluate verdict >>= either (fmap Left . evaluate) (fmap Right . evaluate)) + `catchOwn'` \_ -> throwIO $ StoreVerifierFailure "apple verifier: threw checking a subscription status" + +apiCall :: AppleApi -> Text -> IO (Either StoreRefusal LB.ByteString) +apiCall api@AppleApi {manager, apiToken} url = do + bearer <- bearerToken api + storeRequest manager "Apple" (\req -> req {requestHeaders = [(hAuthorization, "Bearer " <> bearer)]}) url >>= \case + Left refusal -> pure $ Left refusal + Right (code, body) | code >= 200 && code < 300 -> pure $ Right body + Right (401, _) -> atomically (writeTVar apiToken Nothing) $> failed "Apple refused this service's API token" + Right (403, _) -> pure $ failed "Apple refused this service's API key" + -- a 404 among them, which Apple answers for a transaction id its environment does not hold + Right (code, _) -> pure $ Left $ SRUnreachable $ "Apple answered HTTP " <> tshow code + +-- | Signed here, so reused until shortly before it expires rather than signed for every call. +bearerToken :: AppleApi -> IO ByteString +bearerToken api@AppleApi {apiToken} = do + now <- getCurrentTime + readTVarIO apiToken >>= \case + Just (bearer, validUntil) | now < validUntil -> pure bearer + _ -> do + bearer <- signedApiToken api now + atomically $ writeTVar apiToken $ Just (bearer, addUTCTime (fromIntegral (apiTokenSeconds - 300)) now) + pure bearer + +apiTokenSeconds :: Int64 +apiTokenSeconds = 1200 + +signedApiToken :: AppleApi -> UTCTime -> IO ByteString +signedApiToken AppleApi {privateKey, ourBundleId, serverApi = AppleServerApi {aKeyId, aIssuerId}} now = do + ECDSA.Signature r s <- ECDSA.sign privateKey SHA256 signingInput + pure $ signingInput <> "." <> B64U.encodeUnpadded (i2ospOf_ 32 r <> i2ospOf_ 32 s) + where + issuedAt = floor (utcTimeToPOSIXSeconds now) :: Int64 + signingInput = segment (J.object ["alg" J..= ("ES256" :: Text), "kid" J..= aKeyId, "typ" J..= ("JWT" :: Text)]) <> "." <> segment claims + claims = + J.object + [ "iss" J..= aIssuerId, + "iat" J..= issuedAt, + "exp" J..= (issuedAt + apiTokenSeconds), + "aud" J..= ("appstoreconnect-v1" :: Text), + "bid" J..= ourBundleId + ] + segment = B64U.encodeUnpadded . LB.toStrict . J.encode + +-- | Everything Apple signed in the answer is checked against the configured roots like a receipt, but a +-- body that fails it is this service's failure: Apple answered, and no client presented it. +statusVerdict :: AppleApi -> Text -> LB.ByteString -> Either StoreRefusal SubscriptionCheck +statusVerdict AppleApi {roots, ourBundleId} originalId body = do + StatusResponse items <- either (const $ failed "could not read Apple's subscription status") Right $ J.eitherDecode' body + -- an omission is no more a verdict than a 404, and refusing it would end a purchase the buyer paid for + item <- maybe (Left $ SRUnreachable "Apple's answer names no such subscription") Right $ find ((== Just originalId) . itemOriginalId) items + LastTransaction {status, signedTransactionInfo, signedRenewalInfo} <- + either (const $ failed "could not read Apple's subscription status") Right $ JT.parseEither J.parseJSON item + SubscriptionTransaction {transactionId, txOriginalId, productId, bundleId, environment, purchaseDate, expiresDate, revoked, offer, familyShared, price, currency} <- + verifiedItem signedTransactionInfo subscriptionTransactionP + RenewalInfo {renewalOriginalId, autoRenewStatus} <- verifiedItem signedRenewalInfo renewalInfoP + when (bundleId /= ourBundleId) $ failed "another app's bundle id, or ours misconfigured" + when (txOriginalId /= originalId || renewalOriginalId /= originalId) $ failed "Apple answered about another subscription" + when familyShared $ refused "family-shared" + testSubscription <- case environment of + "Production" -> Right False + "Sandbox" -> Right True + _ -> failed "an environment this verifier does not know" + subscriptionState <- case (status, autoRenewStatus) of + (1, 1) -> Right SSRenewing + (1, 0) -> Right SSCancelled + (3, _) -> Right SSBillingRetry + (4, _) -> Right SSBillingRetry + (2, _) -> Right SSEnded + (5, _) -> Right SSEnded + _ -> failed $ "a status " <> tshow status <> " with autoRenewStatus " <> tshow autoRenewStatus <> " this verifier does not know" + pure + SubscriptionCheck + { subscriptionState, + testSubscription, + latestCharge = + Just + StoreCharge + { chargeRef = transactionId, + planId = productId, + periodStart = fromMillis purchaseDate, + periodEnd = fromMillis expiresDate, + chargePaid = paidOf price currency, + revoked, + offer + } + } + where + verifiedItem jws p = do + o <- either (Left . asVerifierFailure) Right $ verifiedPayload roots jws + either (const $ failed "the payload Apple signed is not a subscription transaction or renewal info") Right $ JT.parseEither p o + asVerifierFailure = \case + SRInvalid reason -> SRVerifierFailed $ "apple verifier: " <> reason + refusal -> refusal + fromMillis ms = posixSecondsToUTCTime $ fromIntegral ms / 1000 + +newtype StatusResponse = StatusResponse [J.Value] + +instance J.FromJSON StatusResponse where + parseJSON = J.withObject "StatusResponse" $ \o -> do + groups :: [J.Value] <- o J..: "data" + StatusResponse . concat <$> mapM (J.withObject "SubscriptionGroupIdentifierItem" (J..: "lastTransactions")) groups + +itemOriginalId :: J.Value -> Maybe Text +itemOriginalId = JT.parseMaybe $ J.withObject "LastTransactionsItem" (J..: "originalTransactionId") + +data LastTransaction = LastTransaction + { status :: Int, + signedTransactionInfo :: Text, + signedRenewalInfo :: Text + } + +instance J.FromJSON LastTransaction where + parseJSON = J.withObject "LastTransactionsItem" $ \o -> + LastTransaction <$> o J..: "status" <*> o J..: "signedTransactionInfo" <*> o J..: "signedRenewalInfo" + +data SubscriptionTransaction = SubscriptionTransaction + { transactionId :: Text, + txOriginalId :: Text, + productId :: Text, + bundleId :: Text, + environment :: Text, + purchaseDate :: Int64, + expiresDate :: Int64, + revoked :: Bool, + offer :: Bool, -- any offerType: a free trial, an introductory or promotional price, an offer code + familyShared :: Bool, + price :: Maybe Integer, + currency :: Maybe Text + } + +subscriptionTransactionP :: J.Object -> JT.Parser SubscriptionTransaction +subscriptionTransactionP o = do + transactionId <- o J..: "transactionId" + txOriginalId <- o J..: "originalTransactionId" + productId <- o J..: "productId" + bundleId <- o J..: "bundleId" + environment <- o J..: "environment" + purchaseDate <- o J..: "purchaseDate" + expiresDate <- o J..: "expiresDate" + revoked <- isJust <$> (o J..:? "revocationDate" :: JT.Parser (Maybe J.Value)) + offer <- isJust <$> (o J..:? "offerType" :: JT.Parser (Maybe J.Value)) + familyShared <- (== Just ("FAMILY_SHARED" :: Text)) <$> o J..:? "inAppOwnershipType" + price <- o J..:? "price" + currency <- o J..:? "currency" + pure SubscriptionTransaction {transactionId, txOriginalId, productId, bundleId, environment, purchaseDate, expiresDate, revoked, offer, familyShared, price, currency} + +data RenewalInfo = RenewalInfo {renewalOriginalId :: Text, autoRenewStatus :: Int} + +renewalInfoP :: J.Object -> JT.Parser RenewalInfo +renewalInfoP o = RenewalInfo <$> o J..: "originalTransactionId" <*> o J..: "autoRenewStatus" diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs index 98cb1fc050..19699c9da8 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs @@ -5,16 +5,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module BadgeService.StoreReceipts.Google (playStoreVerifier) where +module BadgeService.StoreReceipts.Google (PlayVerifier (..), playStoreVerifier) where import BadgeService.Config (PlayStoreConfig (..)) -import BadgeService.StoreReceipts (StoreRefusal (..), VerifiedStoreTransaction (..)) +import BadgeService.StoreReceipts (StoreCharge (..), StoreRefusal (..), SubscriptionCheck (..), VerifiedStoreTransaction (..), storeRequest) import Control.Concurrent.STM import Control.Exception (IOException, try) +import Control.Monad (forM) import Crypto.Hash.Algorithms (SHA256 (..)) import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM import Data.Bifunctor (bimap) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -22,7 +24,7 @@ import qualified Data.ByteString.Base64.URL as B64U import qualified Data.ByteString.Lazy as LB import Data.Functor (($>)) import Data.Int (Int64) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -30,18 +32,12 @@ import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.X509 (PrivKey (..)) import Data.X509.Memory (readKeyFileFromMemory) -import Network.HTTP.Client - ( HttpException (..), - Manager, - Request (..), - RequestBody (..), - Response (..), - brReadSome, - parseRequest, - withResponse, - ) +import Network.HTTP.Client (Manager, Request (..), RequestBody (..)) import Network.HTTP.Client.TLS (newTlsManager) -import Network.HTTP.Types (Status (..), hAuthorization, hContentType, methodPost, renderSimpleQuery) +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 (playBasePlan) import Simplex.Chat.PaymentService (googlePurchaseRef) import Simplex.Messaging.Util (tshow) @@ -54,7 +50,15 @@ data PlayEnv = PlayEnv accessToken :: TVar (Maybe (ByteString, UTCTime)) } -playStoreVerifier :: PlayStoreConfig -> IO (Either String (Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction), Text -> Text -> IO (Either StoreRefusal ()))) +-- | Each call takes the product id and the token, but the subscription check: subscriptionsv2 reads by token alone. +data PlayVerifier = PlayVerifier + { verifyPlayPurchase :: Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction), + acknowledgePlayPurchase :: Text -> Text -> IO (Either StoreRefusal ()), + checkPlaySubscription :: Text -> IO (Either StoreRefusal SubscriptionCheck), + acknowledgePlaySubscription :: Text -> Text -> IO (Either StoreRefusal ()) + } + +playStoreVerifier :: PlayStoreConfig -> IO (Either String PlayVerifier) playStoreVerifier config@PlayStoreConfig {gServiceAccountFile} = readServiceAccount gServiceAccountFile >>= \case Left e -> pure $ Left e @@ -62,7 +66,14 @@ playStoreVerifier config@PlayStoreConfig {gServiceAccountFile} = manager <- newTlsManager accessToken <- newTVarIO Nothing let env = PlayEnv {config, account, manager, accessToken} - pure $ Right (verifyPurchase env, acknowledgePurchase env) + pure $ + Right + PlayVerifier + { verifyPlayPurchase = verifyPurchase env, + acknowledgePlayPurchase = acknowledgePurchase env, + checkPlaySubscription = checkSubscription env, + acknowledgePlaySubscription = acknowledgeSubscription env + } readServiceAccount :: FilePath -> IO (Either String ServiceAccount) readServiceAccount path = @@ -87,11 +98,20 @@ verifyPurchase env productId token = (>>= purchaseVerdict productId token) <$> r acknowledgePurchase :: PlayEnv -> Text -> Text -> IO (Either StoreRefusal ()) acknowledgePurchase env productId token = bimap acknowledging (const ()) <$> playCall env (\req -> req {method = methodPost}) (purchaseUrl env productId token <> ":acknowledge") - where - acknowledging = \case - SRUnreachable reason -> SRUnreachable $ "acknowledging: " <> reason - SRVerifierFailed reason -> SRVerifierFailed $ "acknowledging: " <> reason - refusal -> refusal + +-- | As a one-time purchase is: once, before it is credited, so Play's three-day refund never hits a credited one. +acknowledgeSubscription :: PlayEnv -> Text -> Text -> IO (Either StoreRefusal ()) +acknowledgeSubscription env productId token = + readSubscription env token >>= \case + Left refusal -> pure $ Left $ acknowledging refusal + Right SubscriptionPurchase {subscriptionAcknowledged = True} -> pure $ Right () + Right _ -> bimap acknowledging (const ()) <$> playCall env (\req -> req {method = methodPost}) (playUrl env ["purchases/subscriptions", productId, "tokens", token <> ":acknowledge"]) + +acknowledging :: StoreRefusal -> StoreRefusal +acknowledging = \case + SRUnreachable reason -> SRUnreachable $ "acknowledging: " <> reason + SRVerifierFailed reason -> SRVerifierFailed $ "acknowledging: " <> reason + refusal -> refusal readPurchase :: PlayEnv -> Text -> Text -> IO (Either StoreRefusal ProductPurchase) readPurchase env productId token = (>>= decoded) <$> playCall env id (purchaseUrl env productId token) @@ -99,21 +119,117 @@ readPurchase env productId token = (>>= decoded) <$> playCall env id (purchaseUr decoded = either (const $ Left $ SRVerifierFailed "could not read Play's purchase record") Right . J.eitherDecode' purchaseUrl :: PlayEnv -> Text -> Text -> Text -purchaseUrl PlayEnv {config = PlayStoreConfig {gApiHost, gPackageName}} productId token = - T.intercalate "/" [gApiHost, "androidpublisher/v3/applications", gPackageName, "purchases/products", productId, "tokens", token] +purchaseUrl env productId token = playUrl env ["purchases/products", productId, "tokens", token] + +playUrl :: PlayEnv -> [Text] -> Text +playUrl PlayEnv {config = PlayStoreConfig {gApiHost, gPackageName}} path = + T.intercalate "/" $ [gApiHost, "androidpublisher/v3/applications", gPackageName] <> path + +checkSubscription :: PlayEnv -> Text -> IO (Either StoreRefusal SubscriptionCheck) +checkSubscription env token = + playResponse env id (subscriptionUrl env token) >>= \case + -- Play answers 410 for a subscription that expired too long ago to be read + Right (410, _) -> pure $ Right SubscriptionCheck {subscriptionState = SSEnded, testSubscription = False, latestCharge = Nothing} + response -> (>>= subscriptionVerdict) . (>>= decodedSubscription) <$> either (pure . Left) (playAnswer env) response + +readSubscription :: PlayEnv -> Text -> IO (Either StoreRefusal SubscriptionPurchase) +readSubscription env token = (>>= decodedSubscription) <$> playCall env id (subscriptionUrl env token) + +subscriptionUrl :: PlayEnv -> Text -> Text +subscriptionUrl env token = playUrl env ["purchases/subscriptionsv2/tokens", token] + +decodedSubscription :: LB.ByteString -> Either StoreRefusal SubscriptionPurchase +decodedSubscription = either (const $ Left $ SRVerifierFailed "could not read Play's subscription record") Right . J.eitherDecode' + +-- | Play reports no current period start, so it is the period end less the plan's length; a plan this +-- service does not sell has no length, and its charge, which is never granted, is given no period. +-- The service grants a Play charge by its base plan alone, so a base plan it sells under another product is refused. +-- Revoking an order shows only as the subscription ending, so a Play charge is never revoked. +subscriptionVerdict :: SubscriptionPurchase -> Either StoreRefusal SubscriptionCheck +subscriptionVerdict SubscriptionPurchase {subscriptionStateName, testSubscription, lineItems} + | subscriptionStateName == "SUBSCRIPTION_STATE_PENDING" = Left SRPending + | otherwise = do + subscriptionState <- case subscriptionStateName of + "SUBSCRIPTION_STATE_ACTIVE" -> renewalState <$> onlyLineItem + "SUBSCRIPTION_STATE_PAUSED" -> renewalState <$> onlyLineItem + "SUBSCRIPTION_STATE_IN_GRACE_PERIOD" -> Right SSBillingRetry + "SUBSCRIPTION_STATE_ON_HOLD" -> Right SSBillingRetry + "SUBSCRIPTION_STATE_CANCELED" -> Right SSCancelled + "SUBSCRIPTION_STATE_EXPIRED" -> Right SSEnded + "SUBSCRIPTION_STATE_PENDING_PURCHASE_CANCELED" -> Right SSEnded + _ -> Left $ SRVerifierFailed "a subscriptionState this service does not know" + latestCharge <- case lineItems of + [] | subscriptionState == SSEnded -> Right Nothing + _ -> onlyLineItem >>= lineItemCharge + pure SubscriptionCheck {subscriptionState, testSubscription, latestCharge} + where + onlyLineItem = case lineItems of + [item] -> Right item + _ -> Left $ SRVerifierFailed "Play answered a subscription without exactly one line item" + renewalState LineItem {autoRenewEnabled} = if autoRenewEnabled then SSRenewing else SSCancelled + lineItemCharge LineItem {expiryTime, itemProductId, basePlanId, latestSuccessfulOrderId, inOffer} = + forM latestSuccessfulOrderId $ \orderId -> case (expiryTime, itemProductId, basePlanId) of + (Just periodEnd, Just productId, Just planId) -> case playBasePlan planId of + Just (planProductId, _) | planProductId /= productId -> Left $ SRVerifierFailed "Play answered a base plan of another product" + plan_ -> + let periodStart = maybe periodEnd (\(_, (_, months)) -> addMonths (negate $ toInteger months) periodEnd) plan_ + -- hashed so the row does not show the order id; unkeyed, so a holder of the buyer's receipt can still find it + in Right StoreCharge {chargeRef = googlePurchaseRef orderId, planId, periodStart, periodEnd, chargePaid = Nothing, revoked = False, offer = inOffer} + _ -> Left $ SRVerifierFailed "Play answered a charge without its expiryTime, product or base plan" + +data SubscriptionPurchase = SubscriptionPurchase + { subscriptionStateName :: Text, + subscriptionAcknowledged :: Bool, + testSubscription :: Bool, + lineItems :: [LineItem] + } + +instance J.FromJSON SubscriptionPurchase where + parseJSON = J.withObject "SubscriptionPurchaseV2" $ \o -> do + subscriptionStateName <- o J..: "subscriptionState" + subscriptionAcknowledged <- (== Just ("ACKNOWLEDGEMENT_STATE_ACKNOWLEDGED" :: Text)) <$> o J..:? "acknowledgementState" + testPurchase :: Maybe J.Value <- o J..:? "testPurchase" + let testSubscription = isJust testPurchase + lineItems <- o J..:? "lineItems" J..!= [] + pure SubscriptionPurchase {subscriptionStateName, subscriptionAcknowledged, testSubscription, lineItems} + +data LineItem = LineItem + { expiryTime :: Maybe UTCTime, + autoRenewEnabled :: Bool, + itemProductId :: Maybe Text, + basePlanId :: Maybe Text, + latestSuccessfulOrderId :: Maybe Text, + -- from the current phase: offerDetails names the offer it was bought with for its whole life + inOffer :: Bool + } + +instance J.FromJSON LineItem where + parseJSON = J.withObject "SubscriptionPurchaseLineItem" $ \o -> do + expiryTime <- o J..:? "expiryTime" + autoRenewEnabled <- maybe (pure False) (\p -> p J..:? "autoRenewEnabled" J..!= False) =<< o J..:? "autoRenewingPlan" + itemProductId <- o J..:? "productId" + basePlanId <- maybe (pure Nothing) (J..:? "basePlanId") =<< o J..:? "offerDetails" + latestSuccessfulOrderId <- o J..:? "latestSuccessfulOrderId" + phase :: Maybe J.Object <- o J..:? "offerPhase" + let inOffer = maybe False (\p -> KM.member "freeTrial" p || KM.member "introductoryPrice" p) phase + pure LineItem {expiryTime, autoRenewEnabled, itemProductId, basePlanId, latestSuccessfulOrderId, inOffer} playCall :: PlayEnv -> (Request -> Request) -> Text -> IO (Either StoreRefusal LB.ByteString) -playCall env@PlayEnv {accessToken} prepare url = +playCall env prepare url = playResponse env prepare url >>= either (pure . Left) (playAnswer env) + +playResponse :: PlayEnv -> (Request -> Request) -> Text -> IO (Either StoreRefusal (Int, LB.ByteString)) +playResponse env prepare url = bearerToken env >>= \case Left refusal -> pure $ Left refusal - Right bearer -> - playRequest env (\req -> (prepare req) {requestHeaders = [(hAuthorization, "Bearer " <> bearer)]}) url >>= \case - Left refusal -> pure $ Left refusal - Right (code, body) | code >= 200 && code < 300 -> pure $ Right body - Right (401, _) -> atomically (writeTVar accessToken Nothing) $> Left (SRVerifierFailed "Play refused this service's access token") - Right (403, _) -> pure $ Left $ SRVerifierFailed "the service account lacks the Play Console permission for this call" - -- a 404 among them, which Play may answer for a token it issued but has not yet recorded - Right (code, _) -> pure $ Left $ SRUnreachable $ "Play answered HTTP " <> tshow code + Right bearer -> playRequest env (\req -> (prepare req) {requestHeaders = [(hAuthorization, "Bearer " <> bearer)]}) url + +playAnswer :: PlayEnv -> (Int, LB.ByteString) -> IO (Either StoreRefusal LB.ByteString) +playAnswer PlayEnv {accessToken} = \case + (code, body) | code >= 200 && code < 300 -> pure $ Right body + (401, _) -> atomically (writeTVar accessToken Nothing) $> Left (SRVerifierFailed "Play refused this service's access token") + (403, _) -> pure $ Left $ SRVerifierFailed "the service account lacks the Play Console permission for this call" + -- a 404 among them, which Play may answer for a token it issued but has not yet recorded + (code, _) -> pure $ Left $ SRUnreachable $ "Play answered HTTP " <> tshow code purchaseVerdict :: Text -> Text -> ProductPurchase -> Either StoreRefusal VerifiedStoreTransaction purchaseVerdict productId token ProductPurchase {purchaseState, purchaseType, purchaseQuantity, purchaseProductId, alreadyAcknowledged} @@ -215,18 +331,4 @@ signedAssertion ServiceAccount {clientEmail, privateKey} audience now = segment = B64U.encodeUnpadded . LB.toStrict . J.encode playRequest :: PlayEnv -> (Request -> Request) -> Text -> IO (Either StoreRefusal (Int, LB.ByteString)) -playRequest PlayEnv {manager} prepare url = - try (parseRequest (T.unpack url) >>= \req -> withResponse (prepare req) manager readBody) >>= \case - -- http-client's exceptions show the request, whose URL can hold the purchase token, so only the kind is kept - Left (e :: HttpException) -> pure $ Left $ SRUnreachable $ "request to Google failed: " <> failureKind e - Right (code, body) - | LB.length body > maxPlayBytes -> pure $ Left $ SRVerifierFailed $ "Google answered HTTP " <> tshow code <> " with over " <> tshow maxPlayBytes <> " bytes" - | otherwise -> pure $ Right (code, body) - where - readBody resp = (statusCode (responseStatus resp),) <$> brReadSome (responseBody resp) (fromIntegral maxPlayBytes + 1) - failureKind = \case - HttpExceptionRequest _ content -> T.pack $ takeWhile (/= ' ') $ show content - InvalidUrlException _ _ -> "InvalidUrlException" - -maxPlayBytes :: Int64 -maxPlayBytes = 1024 * 1024 +playRequest PlayEnv {manager} = storeRequest manager "Google" diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs index f7b1a14c9b..823af288ea 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs @@ -1,22 +1,68 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module BadgeService.StoreReceipts.Mock (mockStoreVerifier) where +module BadgeService.StoreReceipts.Mock (newMockStoreVerifier) where +import BadgeService.Catalog (playMonthlyPlan) import BadgeService.StoreReceipts +import Control.Applicative ((<|>)) +import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO) +import Control.Monad (guard) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as JM import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Simplex.Chat.PaymentService (appleTransactionId, googlePurchaseRef) -import Simplex.Messaging.Util (eitherToMaybe) +import Data.Time.Clock (UTCTime, addUTCTime) +import Simplex.Chat.Badges.Ledger (addMonths) +import Simplex.Chat.Badges.Service (SubscriptionState (..)) +import Simplex.Chat.Badges.StorePlan (playBasePlan, storePlan) +import Simplex.Chat.PaymentService (appleTransactionRef, googlePurchaseRef) +import Simplex.Chat.PaymentService.Types (PaymentProvider (..)) +import Simplex.Messaging.Util (eitherToMaybe, tshow) -- | Vouches for any well-formed receipt without verifying anything. Each transaction is named by --- the same function its claim is named by, so the two cannot differ. -mockStoreVerifier :: StoreVerifier -mockStoreVerifier = noStoreVerifier {verifyApple = Just mockApple, verifyGoogle = Just mockGoogle} +-- the same function its claim is named by, so the two cannot differ. A subscription is charged for +-- the plan its first purchase or a tier raise names, and that plan is kept in memory to charge each renewal again. +newMockStoreVerifier :: IO UTCTime -> IO StoreVerifier +newMockStoreVerifier clock = do + plans <- newTVarIO M.empty + pure noStoreVerifier {verifyApple = Just mockApple, verifyGoogle = Just mockGoogle, checkSubscription = Just $ mockSubscription clock plans} + +-- | Keyed by Apple's original transaction id or by Play's token, which only this process holds. +mockSubscription :: IO UTCTime -> TVar (M.Map (Either Text Text) Text) -> SubscriptionRef -> Maybe Text -> IO (Either StoreRefusal SubscriptionCheck) +mockSubscription clock plans ref = \case + Just productId -> case firstPlan productId of + Nothing -> pure $ Left $ SRUnreachable "the mock knows no plan for this subscription" + Just planId -> do + atomically $ modifyTVar' plans $ M.insert key planId + renewing planId + Nothing -> + M.lookup key <$> readTVarIO plans >>= \case + Nothing -> pure $ Right SubscriptionCheck {subscriptionState = SSEnded, testSubscription = False, latestCharge = Nothing} + Just planId -> renewing planId + where + (provider, key) = case ref of + SubscriptionApple originalId -> (PPApple, Left originalId) + SubscriptionGoogle token -> (PPGoogle, Right token) + firstPlan productId = case ref of + SubscriptionApple _ -> productId <$ storePlan PPApple productId + SubscriptionGoogle token -> testTokenPlan productId token <|> playMonthlyPlan productId + -- a test token names its base plan, test.., as the apps' test products sign it + testTokenPlan productId token = do + (basePlanId, rest) <- T.breakOn "." <$> T.stripPrefix "test." token + guard $ T.length rest > 1 + (planProductId, _) <- playBasePlan basePlanId + basePlanId <$ guard (planProductId == productId) + renewing planId = do + now <- clock + let periodStart = addUTCTime (-60) now + months = maybe 0 snd $ storePlan provider planId + charge = StoreCharge {chargeRef = "mock-" <> tshow periodStart, planId, periodStart, periodEnd = addMonths (fromIntegral months) periodStart, chargePaid = Nothing, revoked = False, offer = False} + pure $ Right SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = False, latestCharge = Just charge} mockApple :: Text -> Either StoreRefusal VerifiedStoreTransaction mockApple signed = case T.splitOn "." signed of @@ -27,7 +73,7 @@ mockApple signed = case T.splitOn "." signed of productId <- case JM.lookup "productId" o of Just (J.String p) -> Right p _ -> Left $ SRInvalid "no productId" - transactionRef <- maybe (Left $ SRInvalid "no transactionId") Right $ appleTransactionId signed + transactionRef <- maybe (Left $ SRInvalid "no transactionId") Right $ appleTransactionRef signed Right $ vouched transactionRef productId _ -> Left $ SRInvalid "not three dot-separated parts" diff --git a/apps/simplex-badge-service/src/BadgeService/Web/Server.hs b/apps/simplex-badge-service/src/BadgeService/Web/Server.hs index 0c742bccf1..f3eb512dc0 100644 --- a/apps/simplex-badge-service/src/BadgeService/Web/Server.hs +++ b/apps/simplex-badge-service/src/BadgeService/Web/Server.hs @@ -6,6 +6,8 @@ module BadgeService.Web.Server ( WebEnv (..), Limit (..), + Bucket (..), + takeFrom, newWebEnv, exportWebapp, takeToken, @@ -130,6 +132,13 @@ reclaim now buckets fresh :: UTCTime -> Bucket -> Bool fresh now Bucket {bkStarted} = diffUTCTime now bkStarted < limitWindow +-- | A request against a minute's limit: the bucket after it, or how long until the minute ends. +takeFrom :: Int -> UTCTime -> Maybe Bucket -> Either NominalDiffTime Bucket +takeFrom limit now = \case + Just b@Bucket {bkCount, bkStarted} + | fresh now b -> if bkCount < limit then Right b {bkCount = bkCount + 1} else Left (limitWindow - diffUTCTime now bkStarted) + _ -> Right Bucket {bkCount = 1, bkStarted = now} + takeToken :: WebEnv -> Limit -> Text -> IO (Maybe Int) takeToken WebEnv {weBuckets} Limit {lmName, lmPerMinute} client = do now <- getCurrentTime @@ -139,16 +148,7 @@ takeToken WebEnv {weBuckets} Limit {lmName, lmPerMinute} client = do count bucket = writeTVar weBuckets (Map.insert key bucket buckets) >> pure Nothing -- write the reclaimed map back here too, or a refused request redoes the filtering every time and the map stays at the limit refuse seconds = writeTVar weBuckets buckets >> pure (Just seconds) - case Map.lookup key buckets of - Just bucket@Bucket {bkCount, bkStarted} - | fresh now bucket -> - if bkCount < lmPerMinute - then count bucket {bkCount = bkCount + 1} - else refuse (secondsLeft now bkStarted) - _ -> count Bucket {bkCount = 1, bkStarted = now} - where - secondsLeft :: UTCTime -> UTCTime -> Int - secondsLeft now started = max 1 (ceiling (limitWindow - diffUTCTime now started)) + either (refuse . max 1 . ceiling) count (takeFrom lmPerMinute now (Map.lookup key buckets)) limited :: WebEnv -> Limit -> Request -> Respond -> IO ResponseReceived -> IO ResponseReceived limited env limit req respond action = diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index 57fc0a2a30..897c540678 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -457,6 +457,9 @@ ServiceNotConfigured: BadgeActive: - type: "badgeActive" +StorePurchaseOpen: +- type: "storePurchaseOpen" + ServiceError: - type: "serviceError" - serviceError: [BadgeServiceErrorCode](#badgeserviceerrorcode) @@ -494,6 +497,7 @@ CredentialNotVerified: - "code_expired" - "receipt_invalid" - "receipt_used" +- "transfer_limited" - "test_purchase" - "internal" diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index f8d3552929..fe81b430b4 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -424,6 +424,7 @@ undocumentedCommands = "APIRejectCall", "APIReorderChatTags", "APIReportMessage", + "APIRequestBadge", "APIRotateAddressRatchetKeys", "APISaveAppSettings", "APISendCallAnswer", @@ -432,6 +433,7 @@ undocumentedCommands = "APISendCallOffer", "APISendServiceRequest", "APISetAppFilePaths", + "APISetBadgeSubscriptionStatus", "APISetChatItemTTL", "APISetChatSettings", "APISetChatTags", diff --git a/bots/src/API/Docs/Responses.hs b/bots/src/API/Docs/Responses.hs index 132e7adf38..d3ed348846 100644 --- a/bots/src/API/Docs/Responses.hs +++ b/bots/src/API/Docs/Responses.hs @@ -209,6 +209,7 @@ undocumentedResponses = "CRSndStandaloneFileCreated", "CRSQLResult", "CRStandaloneFileInfo", + "CRStoreReceiptNotRecorded", "CRTagsUpdated", "CRUsageConditions", "CRUserPrivacy", diff --git a/docs/protocol/badges-overview.md b/docs/protocol/badges-overview.md index 255f3cd88f..b8b6eba65f 100644 --- a/docs/protocol/badges-overview.md +++ b/docs/protocol/badges-overview.md @@ -1,4 +1,4 @@ -Revision 1, 2026-09-18 +Revision 2, 2026-10-22 # SimpleX Supporter Badges @@ -53,6 +53,8 @@ Two other uses are planned and described under [Future work](#future-work): The badge service holds the purchase key, the number of months bought, and the payment record of the purchase. A card payment is linked to the purchase, as in any other service; a user who wants the payment itself to be private may pay with cryptocurrency. In either case the record is held by the service alone, and the service does not learn where the badge is later shown or used, because a zero-knowledge proof contains nothing that refers back to the credential or the purchase. +An app store subscription's record is its store transaction, which renewals keep, and the charges the store reports for it. When Restore purchases, the app's command that hands the store's current subscriptions to the active profile, moves a subscription to another device or profile, the new purchase key presents the same store transaction as the old one, so the service links the two purchase keys, though not the profiles that hold them. + A party that verifies a proof learns the badge type and the expiry date. Since all credentials expiring in the same week have the same expiry date, these two values place the holder among the supporters whose badges expire that week. ### Comparison with Signal badges @@ -85,14 +87,14 @@ In SimpleX: | Presentations per credential | One | Unlimited | | Proof bound to the context of presentation | No | Yes | | Expiry rounded up to | The next day | The end of the following Monday | -| Issuance and presentation on different days | No | Yes | +| Renewal and presentation on different days | No | Yes | | Usable on independently operated servers | No | Yes | ### Non-goals - A badge does not restrict anything that is available today: the defaults are unchanged, and a badge only raises them. - A badge does not create an identity: it has no persistent identifier, it is not linked across conversations, and an incognito profile does not show it. -- A badge cannot be transferred: a code can be redeemed once for each use it was issued with (usually one), and the credential obtained with it is usable only with the master key it was issued for. +- A badge cannot be transferred: a code can be redeemed once for each use it was issued with (usually one), and the credential obtained with it is usable only with the master key it was issued for. The exception is an app store subscription, which Restore moves to a new purchase key of whichever profile presents its store receipt, and moves again only once the last credential of the key it last moved from has expired. - A badge does not exempt its holder from the limits a server applies: it lowers the cost of a resource without removing the limit on it. - A badge cannot be revoked; credentials are issued for one month at a time instead. @@ -147,7 +149,7 @@ In both cases the app generates the master key and the purchase key pair before ### Monthly issuance -A credential is issued for one month at a time, however many months were bought. The service keeps a count of the months remaining for each purchase key, and issues the next credential when the app asks for it. Unused months, e.g. if the app was offline, lapse at the next badge issuance. +A credential is issued for one month at a time, however many months were bought. The service keeps a count of the months remaining for each purchase key, and issues the next credential when the app asks for it. The months of an app store subscription are added as the store charges for them: the service asks the store before issuing each month, so a new charge funds the next month once the paid months have run out, and a refund or revocation the store reports while they run, as in an annual plan, ends the badge; it also asks at once when the app reports a higher tier, which it does for an App Store raise the device sees before the raised charge expires. The app asks about such a raise, or about a lapsed subscription its store charged again, a bounded number of times each time the device hands the charge over, and again after the next hand-over. Any other App Store change of tier is granted at the first check after the old plan's paid months run out, though Apple bills a raise at once. On Play another badge is a new purchase: the app starts no plan change, and Play's pages offered none for these products when tested; one made there would be a new purchase under a new token, credited only when Restore hands it over (see [Upgrades](./badges-rpc.md#upgrades)). Unused months, e.g. if the app was offline, lapse at the next badge issuance. Credentials are issued monthly to limit what the expiry date discloses. If credentials were issued for the whole term, a user who bought a year would hold a credential expiring on a day a year ahead, when few other credentials expire, and this date would be disclosed in every proof for a year. Instead, every credential is issued for one month, and its expiry is rounded to the end of the Monday following the end of the paid month (UTC). For example, if the paid month ends on Wednesday 14 October 2026, the credential expires at the end of Monday 19 October, and so does every credential whose month ends between Monday 12 and Sunday 18 October. All credentials whose paid month ends in the same week thus expire at the same instant. @@ -202,8 +204,8 @@ 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. +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. A new badge (after a purchase, a redemption, a Restore, or a store subscription resumed after it lapsed) is shown as soon as its credential is issued, so for these the request and the profile update are made together. A higher tier is shown as soon as it is issued too, whether the app reported it or a renewal check granted it, since the subscriber raised it in their store; a lower tier granted at a renewal check is shown when the current credential expires, as a renewal is. +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 same store transaction funds 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. @@ -219,6 +221,7 @@ This threat model assumes the [SimpleX network threat model](https://github.com/ - Issue any credential, or refuse to issue one, as it holds the issuer key. - Link a code issued in its managed group to the member who asked for it and to that group, as the group's messages, codes included, are kept in the service's chat database. - Link a redemption to a member of its managed group whose profile shows a new badge soon after it. +- Link the two purchase keys between which Restore moved a store subscription. *cannot:* @@ -289,6 +292,10 @@ An attacker who obtains the credential and the purchase key can use the badge un A code is a bearer secret until its last use is taken; after that, it is refused to any other purchase key. +**Interception of a store receipt** + +Restore moves a store subscription to any new purchase key that presents its store receipt, within the limit on moves, so whoever obtains the receipt can take the badge. The credential already issued on the device it left stays valid until it expires, and then Restore there can move it back. An App Store receipt stops moving the subscription once the store charges again, as only the subscription's latest transaction moves it. A Play purchase token stays the same across renewals, so it moves the subscription for as long as the subscription renews. Each move waits only for the last credential of the key the subscription moved from, so the receipt's holder and the user can take the badge from each other in turn. + **A passive network observer** *can:* @@ -304,4 +311,4 @@ A code is a bearer secret until its last use is taken; after that, it is refused - Backups will be stored on XFTP servers, and a badge will raise their size and their storage time, as described under [What a badge grants](#what-a-badge-grants). - SMP servers and notification servers will verify the proof. A server that verifies it can charge the holder of a badge less for creating queues, file chunks and notification tokens (under the planned proof-of-work scheme, the required effort is divided by a factor configured for each badge type), and can apply higher rate limits and larger quotas. -- Subscriptions that renew automatically, the transfer of remaining months to a new device, and the pausing of a prepaid badge are planned. +- The transfer of a badge bought by card or cryptocurrency to a new device, and the pausing of a prepaid badge, are planned. diff --git a/docs/protocol/badges-rpc.md b/docs/protocol/badges-rpc.md index 249baa5431..549085ac54 100644 --- a/docs/protocol/badges-rpc.md +++ b/docs/protocol/badges-rpc.md @@ -10,9 +10,9 @@ A request is an envelope: `version` โ€” the client's protocol version; `purchase ## Identity -Each purchase runs under a fresh Ed25519 key pair; `purchaseKey` is its public part and identifies the badge. The service cannot link purchases of one user; the exceptions are the declared upgrades below. `getBadgeCatalog` may omit `purchaseKey`: unsigned, it returns the catalog alone; signed, its response adds the purchase's `badgeStatement` โ€” a client holding a lapsed badge checks for credits in the same request that prices a new purchase, and buys under a fresh key only when the statement shows none. Every other command requires the key and is signed with it. The agent delivers the verified signer key alongside the request; the service rejects a `purchaseKey` that differs from it with `bad_request`. +Each purchase runs under a fresh Ed25519 key pair; `purchaseKey` is its public part and identifies the badge. The service cannot link purchases of one user; the exceptions are the declared upgrades below and a store subscription moved by `transferBadge`, whose old purchase's ledger names the new key. `getBadgeCatalog` may omit `purchaseKey`: unsigned, it returns the catalog alone; signed, its response adds the purchase's `badgeStatement` โ€” a client holding a lapsed badge checks for credits in the same request that prices a new purchase, and buys under a fresh key only when the statement shows none. Every other command requires the key and is signed with it. The agent delivers the verified signer key alongside the request; the service rejects a `purchaseKey` that differs from it with `bad_request`. -A purchase record is created by `redeemBadgeCode`, by `getBadgeInvoice`, or by `purchaseBadge` funded with `apple`, `google`, or `receipt`. Those commands accept a key the service holds no record of โ€” on a first purchase it always will. Every other command answers `unknown_purchase_key` for such a key. +A purchase record is created by `redeemBadgeCode`, by `getBadgeInvoice` (not built), by `purchaseBadge` funded with `apple` or `google` (or `receipt`, post-MVP), or by `transferBadge`. Those commands accept a key the service holds no record of โ€” on a first purchase it always will, and `transferBadge` requires one. Every other command answers `unknown_purchase_key` for such a key. ## Idempotency @@ -22,52 +22,57 @@ 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`. - `redeemBadgeCode` โ†’ `badgeCredential` โ€” redeems a code, records the credit, and issues the first credential, in one round trip. It carries `masterKey` and `code` and no `badgeRequest`: a code states no tier and no expiry, so the credential is what reports them. Errors: `code_invalid` for an unknown or malformed code, `code_used` when other keys have taken all its uses (a code has one use unless issued with more), `code_expired` past a redemption deadline. - `purchaseBadge` โ†’ `badgeCredential` โ€” verifies the funding (`apple` JWS offline; `google` product id and token via the Publisher API; `invoice` against webhook-confirmed settlement, `payment_pending` until it lands; `receipt`), records the credit, and issues the first credential, in one round trip. It carries `masterKey` and no `badgeRequest`. The response `receipt` is the recovery bearer secret (model ยง recovery); the service stores its hash; lifetime badges receive none. - - A store transaction is claimed by its own id, read from the evidence before verification, and credited only when the verified transaction carries that same id. A receipt already credited to the signing key is answered from the record, without asking the store. - - Errors: `receipt_invalid`, `test_purchase`, `payment_pending`, `provider_unavailable` โ€” see the classes below; `receipt_used` when another key was credited with it; `product_unavailable` for a product this service does not price; `provider_not_configured` when this deployment has no verifier for the store. `receipt_invalid`, `test_purchase` and `receipt_used` are the only answers on which the client drops the keys it signed with and finishes the store transaction. Every other answer records nothing and leaves the purchase with its keys, to be presented again at the next trigger. - - **Which class an answer belongs to.** The two mistakes do not cost the same, so when it is not certain, answer unreachable. `receipt_invalid` tells the client the purchase is dead: it drops the keys it signed with and finishes the store transaction โ€” consumed on Play, finished on StoreKit โ€” and nothing can present it again, so a buyer answered this by mistake has paid for a badge they can never receive. Answering unreachable by mistake costs one more verification request each time the app presents the purchase again, and a Play purchase left unacknowledged for three days is refunded to the buyer. It also locks the buyer out: the app offers no Buy while a purchase is open, so until that receipt settles the profile holding it cannot buy any badge, and an answer that never changes leaves it that way for good. + - A store transaction is claimed by its own id, read from the evidence before verification, and credited only when the verified transaction carries that same id. An App Store auto-renewable subscription is claimed by its `originalTransactionId`, which every renewal keeps, so all its charges fund one purchase; a Play subscription keeps its token across renewals already. A receipt already credited to the signing key is answered from the record, without asking the store. + - **Subscriptions.** A Play subscription is verified by reading the subscription itself, not by the one-time purchase read; an App Store one by its JWS offline, as any transaction, and then by reading the subscription's status. The latest charge the store reports is credited as a `charge` credit for the months of the plan it was for, dated to the store's billing period start, and the response carries `subscription`. A charge is credited only while its period runs, if it is not revoked, not bought with an offer (on the App Store any offer type; on Play a free-trial or introductory-price phase), for a plan this service sells, while the subscription has not ended, and while the months its plan grants from its period start still run (Play derives that start by clipping at month ends, so a period's last days can fund nothing). Otherwise nothing is written. No record yet bounds how often the store is asked, so a subscription is asked about at most once an hour on this path, an App Store one per original transaction id and a Play one per token, in an hour not shared with `transferBadge`'s: presented to `purchaseBadge` again inside that hour, by any key (and an App Store one as any of its transactions), it is answered `payment_pending` with the time left, and an answer whose `retryAfter` would be shorter carries the hour. Across all requests, this path asks Play about at most 300 subscriptions a minute (one it credits is read once more to acknowledge it): a Play subscription presented when none is left is answered `rate_limited` with the seconds left in the minute, and is not held off. The answers: `payment_pending` with an hour for a period that has not started yet or a store that reports the payment pending; `receipt_invalid` for a Play subscription that has ended, since Play issues a new token when it is bought again; `payment_pending` with a day for everything a later charge on the same receipt could still change โ€” a revoked charge, one in an offer, no charge yet, a period over while the store still retries, a charge whose months from its period start have already run out, a plan this service does not sell, and an App Store subscription that has ended, which a resubscription under the same original id would continue. A charge whose period does not end after it starts is answered `internal`, and a deployment that cannot read a store's subscriptions answers `provider_not_configured`. + - Errors: `receipt_invalid`, `test_purchase`, `payment_pending`, `provider_unavailable` โ€” see the classes below; `rate_limited` for a Play subscription when this path's Play checks for the minute are used; `receipt_used` when another key was credited with it; `product_unavailable` for a product this service does not price; `provider_not_configured` when this deployment has no verifier for the store. `receipt_invalid`, `test_purchase` and `receipt_used` are the only answers on which the client drops the keys it signed with and finishes the store transaction. Every other answer records nothing and leaves the purchase with its keys, to be presented again at the next trigger. + - **Which class an answer belongs to.** The two mistakes do not cost the same, so when it is not certain, answer unreachable. `receipt_invalid` tells the client the purchase is dead: it drops the keys it signed with and finishes the store transaction โ€” consumed on Play, finished on StoreKit โ€” and nothing can present it again, so a buyer answered this by mistake has paid for a badge they can never receive. Answering unreachable by mistake costs one more verification request each time the app presents the purchase again, and a Play purchase left unacknowledged for three days is refunded to the buyer. It also locks the buyer out: the app offers no Buy while a purchase is open, so until that receipt settles the profile holding it cannot buy any badge, and an answer that never changes leaves it that way for good, but for an App Store subscription charge, which stops holding the profile a day after its period ends. - **Terminal**, `receipt_invalid` โ€” only a verdict no later attempt could change: the store answered about this purchase and cannot change its mind, or the evidence can never verify. Anything that might answer differently later โ€” the store's lag, an outage, this service's own misconfiguration or bug, a shape of evidence this service does not know yet โ€” is one of the other classes. - **Terminal and named**, `test_purchase` โ€” the store vouched for a purchase that cost nothing: Apple's `Sandbox`, or Play's `purchaseType` test. It is separated from `receipt_invalid` for one reason: the device that made the purchase already knows it was a test one, so naming it reveals nothing a forger could iterate on, and it lets the app say why instead of reporting a generic failure. Every other refusal stays lumped together for exactly that reason. - **Pending**, `payment_pending` โ€” a real purchase the store has not settled. - **Unreachable**, `provider_unavailable` โ€” the store was not asked or did not answer. - **Internal**, `internal` โ€” this service's own failure, never the store's answer. - - **App Store.** Apple is verified offline, so it has no "not yet". - - `receipt_invalid`: a JWS that is not three base64url parts or names no `transactionId`; an `x5c` certificate that is not base64; a JWS signature that is not 64 bytes; a leaf whose signature does not verify against the intermediate; a JWS signature that does not verify against the leaf; a transaction with a `revocationDate`, refunded or revoked. - - `test_purchase`: refused by the service after the verifier vouched for it, a `Sandbox` transaction. - - `internal`: whatever this service's own configuration decides โ€” an intermediate whose signature verifies against none of the configured roots, and another app's `bundleId`, since a root may be missing or the bundle id wrong as likely as the receipt forged; a transaction from Xcode's StoreKit testing, which Xcode signs and not the App Store, so no configured root verifies it; evidence in a shape this service does not know โ€” a header that does not name `ES256` or carries no `x5c` of exactly three certificates, a certificate that does not decode, a leaf signature the intermediate's key cannot check, an algorithm or key type the library does not support, a chain without Apple's receipt-signing marker extensions, a leaf key that is not P-256, a payload with a missing or mistyped field or an unknown `environment`; the verifier's own failure or overrun; and, refused by the service, a verified transaction other than the one claimed, or a quantity other than 1. + - **App Store.** Apple's receipt is verified offline, so it has no "not yet"; a subscription's status is then read from the App Store Server API, which can fail to answer. + - `receipt_invalid`: a JWS that is not three base64url parts or names no `transactionId`, or, for an auto-renewable subscription, no `originalTransactionId`; an `x5c` certificate that is not base64; a JWS signature that is not 64 bytes; a leaf whose signature does not verify against the intermediate; a JWS signature that does not verify against the leaf; a transaction with a `revocationDate`, refunded or revoked; and a subscription status whose transaction is family-shared. + - `test_purchase`: refused by the service after the verifier vouched for it, a `Sandbox` transaction, and a subscription status from the `Sandbox` environment. + - `provider_unavailable`, for a subscription's status only: network failure or timeout, and every error response but 401 and 403 โ€” a 404 included, which Apple answers for an original transaction id its environment does not hold โ€” 429 and 5xx among them; and an answer that names no such subscription, as after a Sandbox purchase history is cleared, which is no more certain than that 404. + - `internal`: whatever this service's own configuration decides โ€” an intermediate whose signature verifies against none of the configured roots, and another app's `bundleId`, since a root may be missing or the bundle id wrong as likely as the receipt forged; a transaction from Xcode's StoreKit testing, which Xcode signs and not the App Store, so no configured root verifies it; evidence in a shape this service does not know โ€” a header that does not name `ES256` or carries no `x5c` of exactly three certificates, a certificate that does not decode, a leaf signature the intermediate's key cannot check, an algorithm or key type the library does not support, a chain without Apple's receipt-signing marker extensions, a leaf key that is not P-256, a payload with a missing or mistyped field or an unknown `environment`; the verifier's own failure or overrun; and, refused by the service, a verified transaction other than the one claimed, or a quantity other than 1. For a subscription's status: Apple refusing this service's API token or key (401, 403); an original transaction id that is not all digits; an answer over a mebibyte, or whose list of subscriptions or entry for this subscription cannot be read, an unreadable entry for another subscription being ignored; a signed transaction or renewal info that fails any check above (Apple answered it and no client presented it, so it is never `receipt_invalid`), is not a subscription transaction or renewal info, names another app's bundle id or another subscription, or an unknown environment; and a status this service does not know. - `product_unavailable`: a product this service does not price โ€” the verifier vouched for the transaction either way. - - `provider_not_configured`: the deployment has no `[apple]` section. + - `provider_not_configured`: the deployment has no `[apple]` section, and, for a subscription, an `[apple]` section without an App Store Server API key. - **Google Play.** Only a purchase record is a verdict. - - `receipt_invalid`: `purchaseState` canceled, which a purchase token never leaves, and a product id outside the characters Play documents, since no product of this app can have one. - - `test_purchase`: refused by the service after the verifier vouched for it, `purchaseType` test, a license tester's purchase. - - `payment_pending`: `purchaseState` pending. - - `provider_unavailable`: network failure or timeout, and every error response from `purchases.products.get` but 401 and 403 โ€” a 404 included, which Play may answer both for a token it has just issued and not yet recorded and for one that was never a purchase, and a 400 or 410 calling the token invalid; a 5xx or 429 from the token endpoint; and a token this service will not send โ€” whose characters fall outside the grammar it accepts, which is our guess since Play documents none, or which is only dots, which a URL path would resolve away. - - `internal`: Google refusing this service's credentials or permissions โ€” a 401 or 403 from `purchases.products.get`, and any other refusal from the token endpoint; a response that cannot be read, is too large, or names another product; a `purchaseState` this service does not know; and a `purchaseType` other than test or promo โ€” a promo code, which only this app's developer issues, is credited like a purchase. + - `receipt_invalid`: `purchaseState` canceled, which a purchase token never leaves, and a product id outside the characters Play documents, since no product of this app can have one; and a 410 from `purchases.subscriptionsv2.get`, a subscription that expired too long ago to read, on a first purchase (a renewal check answers it as ended). + - `test_purchase`: refused by the service after the verifier vouched for it, `purchaseType` test, a license tester's purchase, and a subscription with `testPurchase`. + - `payment_pending`: `purchaseState` pending, and `SUBSCRIPTION_STATE_PENDING`. + - `provider_unavailable`: network failure or timeout, and every error response from `purchases.products.get` or `purchases.subscriptionsv2.get` except 401, 403 and a subscription check's 410 โ€” a 404 included, which Play may answer both for a token it has just issued and not yet recorded and for one that was never a purchase, and a 400, or a 410 from `purchases.products.get`, calling the token invalid; a 5xx or 429 from the token endpoint; and a token this service will not send โ€” whose characters fall outside the grammar it accepts, which is our guess since Play documents none, or which is only dots, which a URL path would resolve away. + - `internal`: Google refusing this service's credentials or permissions โ€” a 401 or 403 from `purchases.products.get` or `purchases.subscriptionsv2.get`, and any other refusal from the token endpoint; a response that cannot be read, is too large, or names another product; a `purchaseState` or `subscriptionState` this service does not know; a subscription that is not pending with more than one line item, or with none unless it has ended (`SUBSCRIPTION_STATE_EXPIRED` or `SUBSCRIPTION_STATE_PENDING_PURCHASE_CANCELED`); a charge without its `expiryTime`, product or base plan, and a charge for a base plan this service sells under another product; and a `purchaseType` other than test or promo โ€” a promo code, which only this app's developer issues, is credited like a purchase. - `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. 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. + - 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` โ€” an App Store subscription raised to a higher tier, on the same key. The client sends it when the device sees a transaction of the purchase's own subscription for a higher tier, bought after the purchase's last charge credit in its ledger and not expired (see Upgrades); it carries `payment`, that transaction, and `balance`, and makes the service ask the store now rather than at the next renewal check. 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 client retries it a bounded number of times for each hand-over of the transaction, then sets it aside until the device hands it over again. The tier granted is the store's; the transaction only names the subscription and the tier to wait for, so a lower tier sent here is granted only once the store charges it, at its renewal. +- `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` but in an hour of its own, so a Restore right after the purchase is not held off by the purchase's check. An App Store transaction other than the subscription's latest is answered `payment_pending`, so an older receipt stops moving it once the store charges again. The store's current charge must be one a first purchase could be credited, and is answered as for a first purchase when it is not. 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 that 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 (`receipt_used`): 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.** The service asks the store whenever a month is due, at most once an hour per subscription whether or not the store answers, and answers requests in between from what it last read; a request with no month due is answered as above, without asking. While the paid coverage runs, as an annual plan's does, a store that reports the subscription ended, or the charge it was granted for revoked, ends it: the months not yet issued are debited as `refund`, at the time of the request after a lapse of those that ran out, and the answer is `subscription = ended` with no `credential` โ€” also when the service already read it ended within the hour. Any other answer issues the month due as above, a store that fails or does not answer included, and a new charge it reports is recorded and granted only once the coverage ends. Once coverage has ended, 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 `badgeCredential` 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, and ends it as above; a real store is asked at every request only by a development deployment that also credits test purchases. - `pauseBadge` (post-MVP) โ†’ `badgeCredential` โ€” suspends issuance and lapse (model 2.13). ## Upgrades -Always a new purchase under a new key, except store subscriptions, where the store owns the change. +Always a new purchase under a new key, except App Store subscriptions, where the store owns the change and the purchase keeps its key. -- 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, and each renewal credits months of the charged badge type. +- Non-store (not built): `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 (not built: `purchaseBadge` with `upgrade` is answered `bad_request`): 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. +- App Store subscription: the client never starts a change; the user makes it in Apple's manage-subscriptions sheet, and it keeps the original transaction id, as all badge subscriptions share one subscription group. A higher tier, which Apple charges at once with a prorated refund, is sent as `upgradeBadgeSubscription` when the device sees its transaction bought after the purchase's last charge credit and not yet expired, however late the device sees it, and is granted as soon as the store reports the charge; each hand-over is retried a bounded number of times, and the next one holds it again. Every other change โ€” every lower tier, which Apple charges from the next renewal, a change of plan length, and a higher tier whose transaction has expired or is no newer than the last charge credit โ€” the client sends nothing: the service reads the change from the store and grants the badge type the store charged at its next check after coverage ends. +- Play subscription: the client never starts a plan change. Each badge is its own Play product, with a monthly and an annual base plan, and when tested (2026-10-22) Play's own pages offered neither another badge nor another billing period, so another badge is bought as a new purchase once the current one ends. A plan change made in Play's own pages, should one become possible, gets a new purchase token, so it is a new purchase under a fresh key, credited as a first purchase is, and the old token is granted nothing more. No client hands that token over unprompted: the app's sweep finds it in Play's list, but core records a listed token only when it already holds a record of it, so only Restore hands it over, and Restore is refused while the profile shows a badge. Until then it stays unacknowledged, which Play refunds after three days (see Google Play above). ## Catalog @@ -75,9 +80,11 @@ Always a new purchase under a new key, except store subscriptions, where the sto ## Statement and balance -The ledger is written by the service alone (model ยง3); the client keeps a verbatim replica and computes the effective balance from its last entry and the time. Month boundaries are counted from `balanceAnchorTs`, the start of the current run of months, and not from `balanceStartTs` โ€” counting from the moving start would compound the day-of-month clipping of a short month, so a run beginning 31 January would reach 28 February and never return to the 31st. The service sets a new anchor only where a lapsed run restarts; months granted while coverage still runs extend it on its existing anchor. +The ledger is written by the service alone (model ยง3); the client keeps a verbatim replica and computes the effective balance from its last entry and the time. Month boundaries are counted from `balanceAnchorTs`, the start of the current run of months, and not from `balanceStartTs` โ€” counting from the moving start would compound the day-of-month clipping of a short month, so a run beginning 31 January would reach 28 February and never return to the 31st. The service sets a new anchor only where a run restarts: one that has lapsed, or a grant of another badge type, which starts a run of its own; months of the same type granted while coverage still runs extend it on its existing anchor. -`statement` โ€” `entries`, and `previousEntryId` when they attach after an entry the client holds; its absence marks entries that attach to nothing. Each entry states `entryId`, the signed `changeMonths`, the resulting `balanceMonths`, `balanceStartTs`, `balanceAnchorTs`, and `balanceBadgeType`, `wasPausedSince` on the entry ending a pause, `createdAt`, and `entryType` โ€” `credit`: `payment {invoiceId?}`, `code`, `charge {chargeId}`, `support`, `transferIn {fromPurchaseKey}`, `opening`; `debit`: `refund`, `upgrade {toPurchaseKey}`, `transferOut {toPurchaseKey}`, `support`, `badge`, `lapse`. A code grant is `code` rather than `payment` with no `invoiceId`: the invoice of a code belongs to whoever bought it, and the redeemer's ledger must never reference it. An unknown type is stored as received and decoded after an app upgrade. +`statement` โ€” `entries`, and `previousEntryId` when they attach after an entry the client holds; its absence marks entries that attach to nothing. Each entry states `entryId`, the signed `changeMonths`, the resulting `balanceMonths`, `balanceStartTs`, `balanceAnchorTs`, and `balanceBadgeType`, `wasPausedSince` on the entry ending a pause, `createdAt`, and `entryType` โ€” `credit`: `payment {invoiceId?}`, `code`, `charge {chargeId}`, `support`, `transferIn {fromPurchaseKey}`, `opening`; `debit`: `refund`, `upgrade {toPurchaseKey}`, `transferOut {toPurchaseKey}`, `support`, `badge`, `lapse`. A code grant is `code` rather than `payment` with no `invoiceId`: the invoice of a code belongs to whoever bought it, and the redeemer's ledger must never reference it. A `charge` credit is dated to the store's billing period start, its `createdAt`, so coverage follows the store's periods, or to the previous entry's `createdAt` when that is later, so dates never decrease; the entry is its grant re-run at that time. An unknown type is stored as received and decoded after an app upgrade. + +`subscription` โ€” present exactly when a store subscription funds the purchase, as the service last read the store, or funded it before `transferBadge` moved it away, then always `ended`: `renewing`; `cancelled`, auto-renewal is off and the paid period still runs; `billingRetry`, a charge failed and the store is retrying it; `ended`, no charge will come. A client reads any other value as not ended. `balance` โ€” `lastEntry`, the client's last entry, asserting the position and the months it believes it holds. @@ -85,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 f9ca9d4a14..932dcb0449 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"}, @@ -230,7 +224,8 @@ "metadata": {"comment": "a redeemed code; its invoice belongs to the buyer, not the redeemer"} }, "charge": { - "properties": {"chargeId": {"type": "string"}} + "properties": {"chargeId": {"type": "string"}}, + "metadata": {"comment": "a store subscription's charge, dated (createdAt) to the store's billing period start, or to the previous entry's createdAt when that is later"} }, "support": { "optionalProperties": {} @@ -321,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"} @@ -375,6 +375,10 @@ "receipt": { "type": "string", "metadata": {"comment": "not provided for lifetime badges"} + }, + "subscription": { + "type": "string", + "metadata": {"comment": "SubscriptionState: renewing, cancelled, billingRetry, ended; any other value is read as not ended. Present exactly when a store subscription funds the purchase"} } } }, diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index 1a4b2643bc..8514cbd43c 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -253,6 +253,7 @@ export type BadgeRedeemError = | BadgeRedeemError.InvalidReceipt | BadgeRedeemError.ServiceNotConfigured | BadgeRedeemError.BadgeActive + | BadgeRedeemError.StorePurchaseOpen | BadgeRedeemError.ServiceError | BadgeRedeemError.InvalidResponse | BadgeRedeemError.UnknownKeyIndex @@ -264,6 +265,7 @@ export namespace BadgeRedeemError { | "invalidReceipt" | "serviceNotConfigured" | "badgeActive" + | "storePurchaseOpen" | "serviceError" | "invalidResponse" | "unknownKeyIndex" @@ -289,6 +291,10 @@ export namespace BadgeRedeemError { type: "badgeActive" } + export interface StorePurchaseOpen extends Interface { + type: "storePurchaseOpen" + } + export interface ServiceError extends Interface { type: "serviceError" serviceError: BadgeServiceErrorCode @@ -326,6 +332,7 @@ export enum BadgeServiceErrorCode { Code_expired = "code_expired", Receipt_invalid = "receipt_invalid", Receipt_used = "receipt_used", + Transfer_limited = "transfer_limited", Test_purchase = "test_purchase", Internal = "internal", } diff --git a/packages/simplex-chat-python/src/simplex_chat/types/_types.py b/packages/simplex-chat-python/src/simplex_chat/types/_types.py index 910a7ba81d..af9a501d81 100644 --- a/packages/simplex-chat-python/src/simplex_chat/types/_types.py +++ b/packages/simplex-chat-python/src/simplex_chat/types/_types.py @@ -198,6 +198,9 @@ class BadgeRedeemError_serviceNotConfigured(TypedDict): class BadgeRedeemError_badgeActive(TypedDict): type: Literal["badgeActive"] +class BadgeRedeemError_storePurchaseOpen(TypedDict): + type: Literal["storePurchaseOpen"] + class BadgeRedeemError_serviceError(TypedDict): type: Literal["serviceError"] serviceError: "BadgeServiceErrorCode" @@ -217,15 +220,16 @@ BadgeRedeemError = ( | BadgeRedeemError_invalidReceipt | BadgeRedeemError_serviceNotConfigured | BadgeRedeemError_badgeActive + | BadgeRedeemError_storePurchaseOpen | BadgeRedeemError_serviceError | BadgeRedeemError_invalidResponse | BadgeRedeemError_unknownKeyIndex | BadgeRedeemError_credentialNotVerified ) -BadgeRedeemError_Tag = Literal["invalidCode", "invalidReceipt", "serviceNotConfigured", "badgeActive", "serviceError", "invalidResponse", "unknownKeyIndex", "credentialNotVerified"] +BadgeRedeemError_Tag = Literal["invalidCode", "invalidReceipt", "serviceNotConfigured", "badgeActive", "storePurchaseOpen", "serviceError", "invalidResponse", "unknownKeyIndex", "credentialNotVerified"] -BadgeServiceErrorCode = Literal["bad_request", "unsupported_version", "unknown_purchase_key", "unknown_offer_id", "offer_disabled", "offer_mismatch", "product_unavailable", "payment_not_entitled", "payment_pending", "provider_unavailable", "provider_not_configured", "rate_limited", "code_invalid", "code_used", "code_expired", "receipt_invalid", "receipt_used", "test_purchase", "internal"] +BadgeServiceErrorCode = Literal["bad_request", "unsupported_version", "unknown_purchase_key", "unknown_offer_id", "offer_disabled", "offer_mismatch", "product_unavailable", "payment_not_entitled", "payment_pending", "provider_unavailable", "provider_not_configured", "rate_limited", "code_invalid", "code_used", "code_expired", "receipt_invalid", "receipt_used", "transfer_limited", "test_purchase", "internal"] BadgeStatus = Literal["active", "expired", "expiredOld", "failed", "unknownKey"] diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/buy-android.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/buy-android.svg new file mode 100644 index 0000000000..c7281e8983 --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/buy-android.svg @@ -0,0 +1,121 @@ + + + + + + + Buying a subscription on Android + The app sends the product id and token; the service reads the subscription from Play and acknowledges it itself, just before crediting. + + + + + + + + + Android app ยท Play Billing + + Chat core + + Badge service + + Play Developer API + + + + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + + + + + /_badge invoice + + invoiceId + + + + launchBillingFlow: the base + plan's own offer, account id = + invoiceId โ†’ purchase token + + + + /_badge purchase {google} + product id + token + + held + + no acknowledgement here for a + subscription (one-time: yes) + + held under the Buy record's + keys, claimed by token hash + + + + purchaseBadge {google} + signed by the purchase key + + + + purchase lane + routed before verifyReceipt + asked < 1 h ago โ†’ payment_pending + no Play read left โ†’ rate_limited + + + + subscriptionsv2.get(token) + + state; line item: basePlanId, + expiryTime, order id, offerPhase + + + + grantable? start = expiryTime + less the plan's months (clipped); + does it still fund a month now? + + + + read again, then :acknowledge + unless already acknowledged + + acknowledged + + + + one transaction: payment + token, + charge (hashed order id), ledger + (grant at period start), issuance + + + + badgeCredential, subscription: renewing + + + + event: storePurchaseCredited + + finish: nothing to do + + + + Play lists the subscription until it ends; the sweep hands it over as listed and it resolves to the credited record by its token. + If it is never acknowledged (any refusal before step 8), Play refunds it after three days. If anything fails after step 8, + it stays paid and acknowledged, and only a later retry credits it. Renewals keep the token; the service asks Play itself. + Step 8's read is not counted against the 300 subscription checks a minute. + Subscribing again gets a new token: a new purchase. The sweep also hands over tokens core has no record of; core leaves them + for Restore. A retired purchase's token that Play charges again resumes it: up to 24 tries each time the sweep hands it over. + diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/buy-ios.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/buy-ios.svg new file mode 100644 index 0000000000..a711d34a40 --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/buy-ios.svg @@ -0,0 +1,109 @@ + + + + + + + Buying a subscription on iOS + The app sends Apple's signed transaction; the service checks it offline, then asks the App Store Server API. Nothing is acknowledged. + + + + + + + + + iOS app ยท StoreKit 2 + + Chat core + + Badge service + + App Store Server API + + + + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + + + + + Transaction.all: subscribed + before? Sold only to resume. + + + + /_badge invoice + + invoiceId + + + + Product.purchase with + appAccountToken = invoiceId + โ†’ signed transaction (JWS) + + + + /_badge purchase {apple: jws} + + held; transaction stays unfinished + + held under the Buy record's + keys, claimed by original id + + + + purchaseBadge {apple: jws} + signed by the purchase key + + + + purchase lane (auto-renewable) + JWS verified offline, pinned root + Sandbox โ†’ test_purchase + asked < 1 h ago โ†’ payment_pending + + + + Get All Subscription Statuses + original id, ES256 token + + signed transaction + renewal info + + + + both verified to the root; + grantable charge โ†’ one transaction: + payment, purchase, charge, ledger + (grant at purchaseDate), issuance + + + + badgeCredential, subscription: renewing + stored with the state; badge shown + + + + event: storePurchaseCredited + + transaction.finish() + + + + Renewals: StoreKit lists each renewal's transaction, which the app hands over as listed. It names the same original id, + so it joins the credited record and is finished. The service learns of a new charge only from its own renewal check. + A higher tier newer than the last charge credited is held and sent as upgradeBadgeSubscription (see Changing tier), and a new + charge of the profile's retired purchase resumes it. A revoked subscription transaction is finished without being handed + over. Apple has no acknowledgement step. + diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/components.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/components.svg new file mode 100644 index 0000000000..e81cb033bd --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/components.svg @@ -0,0 +1,123 @@ + + + + + + + + Who holds what + The apps buy, restore and report; core holds receipts and the ledger and never calls a store; the service verifies, credits, renews. + + + + + Apps + iOS ยท Android ยท desktop + Buy, then hand the receipt to core + /_badge purchase [listed|restored] + Report what the store says + /_badge subscription <state> + Your badge: Renews, Payment + problem, Ends; Manage subscription + Check your order: disclosure, links + Support SimpleX: Restore purchases + One chat-list banner per alert + Desktop: state only, no store rows + + + + + Chat core + client database + badge_store_receipts + held with fresh keys; + hold_kind + badge_purchases + + subscription_status, + unrenewed_since, last_unrenewed_at + badge_ledger + replica; a charge credit = subscription + receipt worker: buy, move, tier raise + badge worker โ†’ issueBadge, also at + zero months; derives the alerts; + retires on ended or after 67 days + + + + + Badge service + Three serial lanes: + main ยท purchase ยท renewal + Subscription purchases, in memory: + a claim hourly; Play โ‰ค 300 a minute + payments + + subscription_state, checked_at, + provider_token, rebound_at (moved) + subscription_charges + one row per store charge + badge_ledger + + charge_id, from/to_purchase_id + + + + commands + events + + + + upgradeBadgeโ€ฆ + transferBadge + purchaseBadge + issueBadge + credential, + subscription + + + + + buy ยท list ยท status + + + + + check ยท acknowledge + + + + Play Billing + purchase tokens + isAutoRenewing + subscriptions page + + + StoreKit 2 + signed purchases + renewal status + manage sheet + + + + App Store + Server API + statuses by + original id + signed answers + + + Google Play + Developer API + subscriptionsv2 + acknowledge + by token + + + Core never calls a store: the apps + hand it receipts and the device's + view, and the service tells it + what the store charged. + + + + one Apple ID: the same transactions on both sides + + one Google account: the same purchase tokens on both sides + diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/renewal-check.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/renewal-check.svg new file mode 100644 index 0000000000..a17a36e665 --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/renewal-check.svg @@ -0,0 +1,141 @@ + + + + + + + The service's renewal check + issueBadge for a purchase a subscription funds. The store is asked whenever a month is due, or at once for a raised App Store tier. + + + + issueBadge {lastEntry} + + + Coverage still runs? + paidThrough tip > now + + + Checked within the hour? + subscription_checked_at + + + Stamp the check time first, + in its own write + + + Ask the store, โ‰ค 10 s + Apple by original id ยท Play by token + + + Charge grantable now? + grantableCharge, fundsMonthNow + + + + + + + + + + + + + + + no + no + answered + yes + yes + fails + yes + no + + + + + No month due: answer the current credential, + no store call. A month due: checked first (right). + + + + + While coverage runs (annual plans) + + A month due is asked of the store too, at + most once an hour, stamped first. + Ended, or the charge it granted revoked: + one transaction locks, lapses, and debits + the months not yet issued as a refund. + โ†’ no credential, subscription ended + A stored ended within the hour: the same. + Any other answer, or a store that fails: + the month is issued; a new charge is only + recorded, granted once coverage ends. + โ†’ credential + subscription + + + + Answer from what it last read: no new + credential, the stored subscription state. + + + provider_unavailable, or the store's refusal, + retryAfter, if any, โ‰ฅ 1 h; only the stamp written. + + + One transaction, after signing the month: + lock and re-read the tip (moved โ†’ internal); + insert the charge; lapse to its period start; + another tier: debit the old run (upgrade); + grant, lapse to now, issue; set tier, state. + โ†’ credential + subscription + + + Record the charge, if any, and the state; + no ledger row. โ†’ no credential + subscription + + + + Not grantable when + + the state is ended, or there is no charge + the charge was revoked, or is in an offer + its plan is not one this service sells + its period has not started, or is over + its months from the period start ran out + a ledger row already grants it + + A period that ends before it starts: + internal, logged. + + + + + What the app does with the answer + + A credential + stored, shown when the + current one expires; the + unrenewed run ends + + No credential, or an error + the unrenewed run starts or grows; + badge kept until 67 days after the + run started; asked again at the + next daily moment of its expiry + + subscription: ended + badge retired in the same pass; + alert subscription_ended; + nothing more is asked + + No reply (timeout) + nothing retired; the run and the + ledger untouched; the worker + records the failure and retries + on its backoff, 30 s to an hour + + diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/request-lanes.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/request-lanes.svg new file mode 100644 index 0000000000..90d63e8c1d --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/request-lanes.svg @@ -0,0 +1,93 @@ + + + + + + + Request lanes and the store limits on each + requestLane reads the request, and for issueBadge and a tier raise the purchase, and never writes. Each lane answers one at a time. + + + + Service requests + one queue, as they arrive + + redeemBadgeCode + getBadgeInvoice + purchaseBadge + purchaseBadge + purchaseBadge + issueBadge + issueBadge + transferBadge + upgradeBadgeโ€ฆ + + + Apple, one-time + Apple, auto-renewable + Google, any product + no subscription month due + a subscription month due + Restore, a subscription + due a store check + + + + + + + requestLane + + + + + + + + Main lane + codes, invoices, App Store one-time purchases (verified offline), + other issue requests: prepaid, or no subscription month due + + asks no store + + + + Purchase lane + Play purchases and Restores, and App Store ones whose + unverified payload says auto-renewable. Play one-time: no limit + + Subscriptions, per claim: once an hour, whoever presents it (App + Store by original id after the offline check, Play by token hash) + + Play subscriptions: โ‰ค 300 checks a minute, then rate_limited + + + + Renewal lane + issueBadge signed by the key it names, for a subscription with + a month due judged 60 s ahead, or whose routing read failed; + upgradeBadgeSubscription of an App Store one due a check + + Per subscription: once an hour, stamped before asking, failures + included; requests in between are answered from the stored state + + + + Stores + + App Store + Server API + + Play + Developer API + each call up to + verifyTimeout, 10 s + + + + + + + A ledger is appended from every lane (a Restore ends the old purchase's on the purchase lane). Each write first locks its purchase's + row, then re-reads the tip, so the lanes may write concurrently at any Postgres --pool-size. + diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/restore.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/restore.svg new file mode 100644 index 0000000000..7ba366c559 --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/restore.svg @@ -0,0 +1,102 @@ + + + + + + + Restore on another device or profile + Restore moves a store subscription to fresh keys of the active profile; from then on the service answers the old key ended. + + + + + + + + + App on the new device + + Chat core + + Badge service + + App Store or Play API + + + + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + + + + + Support SimpleX โ†’ Restore + hands over the store's current + subscriptions as restored + + + + /_badge purchase โ€ฆ restored + one per transaction + + + + this profile shows a badge? + โ†’ refused: a badge is active + else held as a move, under + fresh keys of this profile + + + + transferBadge {masterKey, payment} + signed by the new purchase key + + + + purchase lane; the key holds no + purchase yet, else bad_request; + asked < 1 h ago โ†’ payment_pending; + Play: โ‰ค 300 checks a minute + + + + the subscription's status + + state and latest charge + + + + App Store, not the latest transaction + โ†’ payment_pending. The key it last + moved from holds an unexpired + credential โ†’ transfer_limited. A charge + it can't credit โ†’ as for a first purchase + + + + one transaction: old purchase lapsed, + debited transferOut {new key}; the + payment moves to the new purchase, + credited from its period start; issue + + + + badgeCredential, subscription + shown and sent to contacts at once + + + + The device it left keeps the credential it holds; its next request is answered ended with no credential, and it retires the badge. + The service now links the two purchase keys, as the same store transaction funds both; it still links neither to a profile. + Whoever holds a store receipt can move the badge to their own keys: an App Store receipt until the store charges again, a Play token + for the subscription's life. A payment moves again only once the last credential of the key it moved from has expired, up to 39 days, + so each paid month stays with at most two keys. The first Restore refused as limited may say nothing; the next says why. + Card, crypto and code badges don't move. + diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/retirement-window.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/retirement-window.svg new file mode 100644 index 0000000000..91a46d6383 --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/retirement-window.svg @@ -0,0 +1,119 @@ + + + + + + + The retirement window + Two columns, no timer: the rule runs in the badge worker's pass. Days are counted from paidThrough. + + + + + a run starts: unrenewed_since + + answer that renewed nothing + + no reply + + renewal + + retired + + + + days after paidThrough + + + + + + + + + + + 0 + 30 + 60 + 90 + 120 + 150 + + + + + + A persistent fault + every answer renews nothing + + + + + + + + + T0 sets both columns + retired at the first answer โ‰ฅ T0 + 67 days, + alert subscription_ended + + 67 days = 60 (longest store recovery) + 7 (contacts' grace) + each answer moves last_unrenewed_at + + + + Away longer than + the window + + + + + app not opened for 75 days + + fresh run: both columns = day 90 + + 75 days โ‰ฅ 67 since last_unrenewed_at (day 15) + earliest retirement now day 157 + + + + A renewal ends + the run + + + + + + renewal: the ledger covers now, both columns cleared + + + + past the new paidThrough, the next unrenewed answer starts a new run + + + + The service + never replies + + + + + + + + + + no reply: the run unchanged, nothing retired + a service that never replies keeps the badge; the device's ended retires it only until the request falls due + next answer: + fresh run + + + + + On any pass after which the ledger covers now, the run is cleared. After an answered request that left nothing covered, + last_unrenewed_at moves to now if it is under 67 days old, and otherwise a fresh run starts. Retire if the answer is ended, if + 67 days have passed since unrenewed_since, or, past paidThrough, if the device reported ended. Dots: an open app asks daily. + + diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/subscription-states.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/subscription-states.svg new file mode 100644 index 0000000000..bf79091dfc --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/subscription-states.svg @@ -0,0 +1,76 @@ + + + + + + + Subscription states and what each shows + The client keeps the store's state as last observed (badge_purchases.subscription_status); the alert comes from it and paidThrough. + + + The store says + State on the client + What the user sees + + + + + Apple: status 1, auto-renew on + Play: active or paused, auto-renew on + + + renewing + + Your badge: โ€œRenews {date} ยท {price}โ€, then โ€œRenewingโ€ + past paidThrough, until the store charges + Banner, annual plans only, 3 days before: + โ€œYour badge renews soonโ€ + + + + Apple: status 1, auto-renew off + Play: active or paused, auto-renew off; canceled + + + cancelled + + Your badge: โ€œEnds {date}โ€, then โ€œEndedโ€ + Banner while paid: โ€œSubscription cancelledโ€, + โ€œYour badge stays until {date}โ€ + + + + Apple: status 3 (billing retry), 4 (grace) + Play: in grace period, on hold + + + billingRetry + + Your badge: โ€œPayment problemโ€ + Banner, as a warning: โ€œBadge payment problemโ€ + badge kept, no credential, asked again daily + + + + Apple: status 2 (expired), 5 (revoked) + Play: expired, pending purchase canceled, HTTP 410 + Service: the subscription moved by Restore + + + ended + + From the service: badge retired, banner + โ€œYour subscription endedโ€. From the device: โ€œEndedโ€; + past paidThrough the badge is retired too, as above + + + + + Writers: the service, at the credit and in an answer past the asserted coverage or saying ended; and the device's report after each + sweep, which never replaces billingRetry or ended with renewing (Play lists a subscription in its grace period as auto-renewing). + No state yet, or one this version does not know: shown as renewing, no banner. Play's pending subscription: payment_pending, no state. + Also retired without ended: once 67 days have passed since the first answer that renewed nothing, again โ€œYour subscription endedโ€. + One banner at a time, first that applies: subscription ended, payment problem, renewal failed, cancelled, renews soon. + โ€œBadge renewal failedโ€ (issue_failed) shows a failure that cannot clear, or any once the shown credential has expired. + + diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/summary.html b/plans/2026-10-13-badge-subscription-renewals-sketches/summary.html new file mode 100644 index 0000000000..bd424ea637 --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/summary.html @@ -0,0 +1,162 @@ +Badge Subscriptions + + + +
+
+

PR #7716

+

Badge subscriptions

+

Supporter badges (supporter and legend tiers) were prepaid: a code bought on the web, or a one-month store purchase not yet offered. This PR sells them as App Store and Google Play subscriptions, monthly or annual, across the badge service, core and apps. On iOS this release keeps buying and Restore hidden: the app opens the badge page on the site and redeems the code bought there.

+
+
Who holds what: the apps buy, restore and report; core holds receipts, each held for a purchase, a move or a tier change, and the client ledger, and talks only to the badge service; the service verifies with the App Store Server API and the Play Developer API, credits, renews, changes tier and moves a subscription to another key.
+
+
+ +
+

Buying

+

The app passes the store's receipt, through core, to the badge service, which checks it with the store and credits the badge.

+
    +
  • iOS: the service checks Apple's signature, then asks Apple about the subscription by its original transaction id, which renewals and tier changes keep. An Apple ID that subscribed before can subscribe again only to the badge its profile's last purchase retired, on the same device; core then resumes that purchase.
  • +
  • Android: the service reads the subscription from Play by its purchase token and acknowledges it. Play refunds purchases left unacknowledged for three days.
  • +
+
+
Buying a subscription on iOS: the app creates the record in core, buys with StoreKit, hands the signed transaction to core, core's worker sends purchaseBadge, the service verifies the JWS offline and asks the App Store Server API by original transaction id, then credits the charge; the app finishes the transaction when core reports it credited.
+
+
+
Buying a subscription on Android: the app creates the record in core, buys with Play Billing, hands the token to core without acknowledging it, core's worker sends purchaseBadge, the service reads the subscription from Play by token, acknowledges it just before crediting, and writes the payment, charge and ledger in one transaction.
+
+
+ +
+

Renewals

+

The app requests each month's badge credential at the weekly moment all apps share, then daily, and before issuing a month the service asks the store, at most hourly per subscription. Once the paid months run out, a new charge funds the next month, from its billing-period start and as the tier the store charged; while they run, as in an annual plan, a refund or revocation the store reports ends the badge, its months not yet issued debited as a refund. The app also reports the device's view of the store, such as auto-renewal off, for the badge screen and banners.

+
+
The renewal check: a request with no month due asks no store; otherwise the service asks the store at most once an hour, stamping the check first. During paid coverage a store that reports the subscription ended or the granted charge revoked ends it, the unissued months debited as a refund, and any other answer issues the month. After coverage a grantable charge, of any tier, is written with the issued month in one transaction that locks the purchase and re-reads the tip; otherwise the charge and state are recorded and the answer carries no credential.
+
+
+
Subscription states: renewing, cancelled, billingRetry and ended, what each store state maps to, and the Your badge row and chat-list banner each shows.
+
+
+ +
+

Changing tier

+

The app never starts a change. On iOS the user changes plan in Apple's subscription sheet; all four subscriptions share one group, so the original transaction id, the purchase and its key stay.

+
    +
  • Raising the tier: Apple charges the new tier at once and refunds the rest of the old period. When the device sees that transaction before it expires, core sends it to the service, retrying up to 24 times each time the device hands it over; the service asks Apple, ends the old tier's remaining months and grants the new tier from the charge. The new badge shows at once.
  • +
  • Lowering the tier, or any other change: the app sends nothing, and the renewal check grants what Apple charged; Apple charges a lower tier from the next renewal.
  • +
  • Play: each badge is its own product, the app starts no plan change, and Play's pages offered none in testing; another badge is a new purchase, which the app allows once the current badge has ended.
  • +
+
+
Changing tier in the App Store: core holds a higher tier bought after the last charge credited and not expired as a tier change and sends upgradeBadgeSubscription on the same key, up to 24 times per hand-over; the service asks Apple, ends the old tier's remaining months, grants the new tier from the charge and issues its month, which core shows at once. A lower tier, or a raise whose transaction expired first, waits for the renewal check.
+
+
+ +
+

Restore: moving to another device or profile

+

Restore purchases (Support SimpleX screen; hidden on iOS in this release) hands the store's current subscriptions to core, which asks the service to move one to fresh keys of the active profile, unless that profile already shows a badge: while it is held, core refuses the others, and the app carries on past those refusals, reporting a failure only when nothing was restored. The service asks the store, ends the old purchase, which it answers "ended" from then on, and credits the new key with the current charge; the new badge shows at once. The device it left keeps the badge it holds until that credential is due for renewal, then retires it.

+

A store receipt is no secret: whoever holds it can move the badge to their own keys. So a subscription moves again only once the badge already issued to the key it left has expired, up to 39 days, which keeps each paid month with at most two keys; an App Store receipt moves it only while it is the subscription's latest transaction, a Play token for the subscription's life. The service now links the two purchase keys, as the same store transaction funds both, but still not either to a profile. Badges bought by card, crypto or code don't move.

+
+
Restore on another device or profile: core holds each restored transaction as a move under fresh keys and sends transferBadge; the service refuses an older App Store transaction, a payment moved too recently or a charge it could not credit, and otherwise ends the old purchase, moves the payment and credits the new key, issuing its month.
+
+
+ +
+

How a subscription ends

+

While the store retries a failed payment, the badge stays (on iOS, until the device reports it expired), though contacts see it as expired a week after its last credential expires, and the profile can't buy or redeem another. It is removed as soon as the service answers that the subscription ended; once the paid months have run out, when Apple's store on the device reports it expired; or after 67 days of answers that renewed nothing: 60 days, the longest either store retries, plus 7 days of contacts' grace. If the service never replies and the device reports nothing, the badge stays. A retired subscription the store charges again comes back when the device next hands that charge over, unless the profile has had another badge since: then a hand-over moves it to fresh keys, as Restore does, once no badge shows, and until then the device keeps the transaction unfinished.

+
+
The retirement window on a day scale after paidThrough: the badge retires at the first answer 67 days after the first answer that renewed nothing; a long gap starts a fresh run, a renewal clears it, and requests that get no reply leave it unchanged.
+
+
+ +
+

Protecting the service and the stores

+

Purchases and Restores that ask a store, requests with a month due and tier changes, and everything else run on separate queues, so fake purchases can delay only other purchases and Restores. Each subscription is checked at most hourly per purpose (purchase, Restore, renewal), and the purchase path makes at most 300 Play subscription checks a minute; a Play purchase turned away for three days is refunded.

+
+
Request lanes: codes, invoices, App Store one-time purchases and issue requests with no month due go to the main lane, which asks no store; Play purchases, App Store subscription purchases and Restores to the purchase lane, limited per claim to once an hour and Play to 300 checks a minute; issue requests with a month due and App Store tier raises due a check to the renewal lane, limited to once an hour per subscription. Every write to a ledger locks its purchase first.
+
+
+ +
+

Protocol and database changes

+
    +
  • Badge RPC (still version 1): an optional subscription state in credential answers; charges use the existing charge ledger entry; upgradeBadgeSubscription for a raised App Store tier and transferBadge for Restore, with a transfer_limited error.
  • +
  • Chat API: a command reporting the store's state, listed and restored receipt flags, a refusal while a store receipt may still be credited, and the subscription and its alerts in the badge state.
  • +
  • Databases: four columns in core's, for the store's state, the answers that renewed nothing, and what a held receipt is held for; on the service, a charges table, the charge and the purchases a move links on ledger rows, and state, check time, Play token and move time on payments.
  • +
+
+ +
+

Known limits

+
    +
  • Automated tests use fake stores built from the stores' documentation. On 22 October the lifecycle was walked by hand on an iPhone and an Android phone, against Apple's sandbox and Play's test purchases, with the real verifiers; the review fixes made that night are tested only automatically. Real money, real billing dates and the stores' own retries and refunds are still unexercised.
  • +
  • A purchase completing while another badge shows waits for it to end, and may meanwhile be refunded or lose paid periods.
  • +
  • A Restore refused because the subscription moved recently may say nothing the first time.
  • +
  • Play purchases are acknowledged before being signed and recorded; if either fails, Play won't refund, and only a later successful retry credits them.
  • +
+
+ +
+

Before sale

+

Not built: iOS resubscription on another device or profile or to another badge, Restore for badges bought by card or crypto, seeing a Play refund that leaves the subscription active, and spreading the weekly moment.

+

Store setup: the product ids and every store setting are the store setup checklist in the badge service's apps/simplex-badge-service/README.md. Besides them: server API credentials, enough quota, translations, store review (Sandbox purchases are refused as test purchases, an open question), and products hidden until these apps ship.

+
+
diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/summary.md b/plans/2026-10-13-badge-subscription-renewals-sketches/summary.md new file mode 100644 index 0000000000..11b313e11f --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/summary.md @@ -0,0 +1,73 @@ +# Badge subscriptions (PR #7716) + +Supporter badges (supporter and legend tiers) were prepaid: a code bought on the web, or a one-month store purchase not yet offered. This PR sells them as App Store and Google Play subscriptions, monthly or annual, across the badge service, core and apps. On iOS this release keeps buying and Restore hidden: the app opens the badge page on the site and redeems the code bought there. + +![Who holds what](components.svg) + +## Buying + +The app passes the store's receipt, through core, to the badge service, which checks it with the store and credits the badge. + +- **iOS:** the service checks Apple's signature, then asks Apple about the subscription by its original transaction id, which renewals and tier changes keep. An Apple ID that subscribed before can subscribe again only to the badge its profile's last purchase retired, on the same device; core then resumes that purchase. +- **Android:** the service reads the subscription from Play by its purchase token and acknowledges it. Play refunds purchases left unacknowledged for three days. + +![Buying on iOS](buy-ios.svg) + +![Buying on Android](buy-android.svg) + +## Renewals + +The app requests each month's badge credential at the weekly moment all apps share, then daily, and before issuing a month the service asks the store, at most hourly per subscription. Once the paid months run out, a new charge funds the next month, from its billing-period start and as the tier the store charged; while they run, as in an annual plan, a refund or revocation the store reports ends the badge, its months not yet issued debited as a refund. The app also reports the device's view of the store, such as auto-renewal off, for the badge screen and banners. + +![The renewal check](renewal-check.svg) + +![Subscription states](subscription-states.svg) + +## Changing tier + +The app never starts a change. On iOS the user changes plan in Apple's subscription sheet; all four subscriptions share one group, so the original transaction id, the purchase and its key stay. + +- **Raising the tier:** Apple charges the new tier at once and refunds the rest of the old period. When the device sees that transaction before it expires, core sends it to the service, retrying up to 24 times each time the device hands it over; the service asks Apple, ends the old tier's remaining months and grants the new tier from the charge. The new badge shows at once. +- **Lowering the tier, or any other change:** the app sends nothing, and the renewal check grants what Apple charged; Apple charges a lower tier from the next renewal. +- **Play:** each badge is its own product, the app starts no plan change, and Play's pages offered none in testing; another badge is a new purchase, which the app allows once the current badge has ended. + +![Changing tier](tier-change.svg) + +## Restore: moving to another device or profile + +Restore purchases (Support SimpleX screen; hidden on iOS in this release) hands the store's current subscriptions to core, which asks the service to move one to fresh keys of the active profile, unless that profile already shows a badge: while it is held, core refuses the others, and the app carries on past those refusals, reporting a failure only when nothing was restored. The service asks the store, ends the old purchase, which it answers "ended" from then on, and credits the new key with the current charge; the new badge shows at once. The device it left keeps the badge it holds until that credential is due for renewal, then retires it. + +A store receipt is no secret: whoever holds it can move the badge to their own keys. So a subscription moves again only once the badge already issued to the key it left has expired, up to 39 days, which keeps each paid month with at most two keys; an App Store receipt moves it only while it is the subscription's latest transaction, a Play token for the subscription's life. The service now links the two purchase keys, as the same store transaction funds both, but still not either to a profile. Badges bought by card, crypto or code don't move. + +![Restore](restore.svg) + +## How a subscription ends + +While the store retries a failed payment, the badge stays (on iOS, until the device reports it expired), though contacts see it as expired a week after its last credential expires, and the profile can't buy or redeem another. It is removed as soon as the service answers that the subscription ended; once the paid months have run out, when Apple's store on the device reports it expired; or after 67 days of answers that renewed nothing: 60 days, the longest either store retries, plus 7 days of contacts' grace. If the service never replies and the device reports nothing, the badge stays. A retired subscription the store charges again comes back when the device next hands that charge over, unless the profile has had another badge since: then a hand-over moves it to fresh keys, as Restore does, once no badge shows, and until then the device keeps the transaction unfinished. + +![The retirement window](retirement-window.svg) + +## Protecting the service and the stores + +Purchases and Restores that ask a store, requests with a month due and tier changes, and everything else run on separate queues, so fake purchases can delay only other purchases and Restores. Each subscription is checked at most hourly per purpose (purchase, Restore, renewal), and the purchase path makes at most 300 Play subscription checks a minute; a Play purchase turned away for three days is refunded. + +![Request lanes](request-lanes.svg) + +## Protocol and database changes + +- **Badge RPC** (still version 1): an optional subscription state in credential answers; charges use the existing `charge` ledger entry; `upgradeBadgeSubscription` for a raised App Store tier and `transferBadge` for Restore, with a `transfer_limited` error. +- **Chat API:** a command reporting the store's state, `listed` and `restored` receipt flags, a refusal while a store receipt may still be credited, and the subscription and its alerts in the badge state. +- **Databases:** four columns in core's, for the store's state, the answers that renewed nothing, and what a held receipt is held for; on the service, a charges table, the charge and the purchases a move links on ledger rows, and state, check time, Play token and move time on payments. + +## Known limits + +- Automated tests use fake stores built from the stores' documentation. On 22 October the lifecycle was walked by hand on an iPhone and an Android phone, against Apple's sandbox and Play's test purchases, with the real verifiers; the review fixes made that night are tested only automatically. Real money, real billing dates and the stores' own retries and refunds are still unexercised. +- A purchase completing while another badge shows waits for it to end, and may meanwhile be refunded or lose paid periods. +- A Restore refused because the subscription moved recently may say nothing the first time. +- Play purchases are acknowledged before being signed and recorded; if either fails, Play won't refund, and only a later successful retry credits them. + +## Before sale + +Not built: iOS resubscription on another device or profile or to another badge, Restore for badges bought by card or crypto, seeing a Play refund that leaves the subscription active, and spreading the weekly moment. + +Store setup: the product ids and every store setting are the store setup checklist in the badge service's [README](../../apps/simplex-badge-service/README.md#store-setup). Besides them: server API credentials, enough quota, translations, store review (Sandbox purchases are refused as test purchases, an open question), and products hidden until these apps ship. diff --git a/plans/2026-10-13-badge-subscription-renewals-sketches/tier-change.svg b/plans/2026-10-13-badge-subscription-renewals-sketches/tier-change.svg new file mode 100644 index 0000000000..0b25418f5f --- /dev/null +++ b/plans/2026-10-13-badge-subscription-renewals-sketches/tier-change.svg @@ -0,0 +1,97 @@ + + + + + + + Changing tier in the App Store + The user changes plan in Apple's sheet; the original transaction id stays, so the purchase and its key stay. Supporter to legend shown. + + + + + + + + + iOS app ยท StoreKit 2 + + Chat core + + Badge service + + App Store Server API + + + + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + + + + + Manage subscription โ†’ Apple's + sheet: legend charged now, + the rest of supporter refunded + + + + /_badge purchase โ€ฆ listed {apple} + the new transaction, same original id + + + + a higher tier, newer than the last + charge credited, not expired? + yes โ†’ held as a tier change + no โ†’ answered from the record; + the renewal check grants it later + + + + upgradeBadgeSubscription + the transaction + balance, same key + + + + its own subscription, not yet legend; + asked < 1 h ago โ†’ payment_pending; + else, on the renewal lane: stamp, ask + + + + Get All Subscription Statuses + + latest charge: legend, its period + + + + one transaction: debit the rest of + the supporter run (upgrade), grant + legend from the charge's period + start, issue its month; tier = legend + + + + badgeCredential: legend + before the grant: payment_pending, never supporter + + + + shown and sent to contacts at + once, not at the old expiry + + + + Any other change (a lower tier, which Apple charges from the next renewal, or a change of plan length): the app sends nothing, and + the renewal check after the old coverage ends grants what Apple charged. A raise whose transaction expired unseen waits the same way. + A held raise is sent up to 24 times each time the device hands it over, then set aside until the next hand-over. + Play: each badge is its own product, with no plan change from the app or, in testing, Play's pages; another badge is a new purchase. + diff --git a/plans/2026-10-13-badge-subscription-renewals.md b/plans/2026-10-13-badge-subscription-renewals.md index 056c059810..b91dc733a6 100644 --- a/plans/2026-10-13-badge-subscription-renewals.md +++ b/plans/2026-10-13-badge-subscription-renewals.md @@ -1,5 +1,7 @@ # Plan: store subscription renewals for supporter badges +For reviewers: a summary of the code as built in PR #7716, with diagrams, is in [`2026-10-13-badge-subscription-renewals-sketches/summary.md`](2026-10-13-badge-subscription-renewals-sketches/summary.md). Where it and this plan differ, the summary describes the code. + Run: 001-badge-subscriptions ยท Base branch: `f/badge-subscriptions`, cut from `badge-in-app-checkout` once `f/badge-store-verifiers` is merged into it ยท Repos: simplex-chat-2 ยท Estimated diff: ~1700 changed lines (~900 code and docs, ~800 tests), one PR in eight slices This run makes App Store and Google Play subscriptions renew badges: in the badge service, including its real connections to Apple's App Store Server API and Google Play's subscriptions API, and in the shared app core. It changes no iOS or Android screens, so nothing here puts a subscription on sale. @@ -85,7 +87,7 @@ The core change: - A subscription purchase is an ordinary purchase whose ledger is refilled by store charges instead of being paid once. - Its store identity is the subscription, not one transaction: Apple's original transaction id (Play's token already is). Every renewal therefore resolves to the same purchase and the same receipt record on both sides, and the service has one thing to ask the store about. -- Months enter a subscription ledger only as `charge` credits whose operation time is the store's billing period start. The grant row's `createdAt` is that period start, as `grantEntry` already stamps its `t`. Coverage follows the store's periods without drift, every row verifies by re-running its operation at its `createdAt`, and `StatementEntry` gains no field. +- Months enter a subscription ledger only as `charge` credits whose operation time is the store's billing period start. The grant row's `createdAt` is that period start, or the previous row's `createdAt` when that is later, so dates never decrease. Coverage follows the store's periods without drift, every row verifies by re-running its operation at its `createdAt`, and `StatementEntry` gains no field. - The first charge and every renewal go through one pure planner: lapse what ran out before the period start, grant the charge's months at the period start, lapse what ran out since, then issue at now. - The service asks the store only when a subscription purchase's paid coverage has ended, and writes nothing unless a charge is granted. - The client keeps asking at the shared weekly moment and keeps the badge until the service answers that the subscription has ended. @@ -114,7 +116,7 @@ The core change: - `Badges/Ledger.hs`: - `entryTypeFromColumns` takes the row's charge id and rebuilds `SCCharge` from it (slice 2). - A pure planner (suggested name `chargeEntries`) takes the tip or a seed, the charge's period start, its months, the charge id, `now` and fresh entry ids. It returns `lapse periodStart` (if any), `grant periodStart months (SCCharge chargeId)`, `lapse now` (if any). The caller issues at `now` with `issueEntry` as today. - - The rows' `createdAt` are non-decreasing whenever the period start is not before the tip's `createdAt`. That holds on every path: the tip was issued before its month ended, the next charge's period starts around that month's end, and the service writes no row while a subscription waits for its charge. + - The rows' `createdAt` are non-decreasing because the planner dates a charge at the later of its period start and the tip's `createdAt`, so a charge asked about late in its period is dated after the row it follows. ### Badge service (`apps/simplex-badge-service/src/BadgeService/`) @@ -327,7 +329,7 @@ None. The timing and grace behaviour, the branch, who runs builds, tier changes, - The Apple verifier checks no certificate validity dates or revocation. - A Play subscription purchase is offered by the first offer on its base plan, not a named offer (`PlayStore.kt`). - Retirement does not signal the receipt worker. -- After a renewal that lands once the shown credential has expired (billing-retry recovery), the request and the profile update happen in the same pass, because `presentIssuedBadge` presents as soon as the shown credential has expired. This already happens to late prepaid renewals; it weakens objective 3 for recovered subscriptions. +- After a renewal that lands once the shown credential has expired (billing-retry recovery), the request and the profile update happen in the same pass, because `presentIssuedBadge` presents as soon as the shown credential has expired. This already happens to late prepaid renewals; it weakens objective 3 for recovered subscriptions. A raised tier is presented at once as well, whichever request granted it (the receipt worker's upgrade request in `creditStoreReceipt`, a renewal check in `presentIssuedBadge`): the subscriber raised the tier in their store, so the broadcast tells the store nothing new. A lower tier keeps the hold-back until the shown credential expires. ## 11. Follow-up runs diff --git a/plans/2026-10-20-badge-ledger-transitions.md b/plans/2026-10-20-badge-ledger-transitions.md new file mode 100644 index 0000000000..26988653ff --- /dev/null +++ b/plans/2026-10-20-badge-ledger-transitions.md @@ -0,0 +1,157 @@ +# Badge subscriptions: tier changes and restore + +Base: `f/badge-subscriptions` at 26f846e1a (line numbers at that commit). `SVC/` = `apps/simplex-badge-service/src/BadgeService/`. "Model" = `plans/2026-07-30-supporter-badges-v3-ux.md`. + +## Summary + +**What.** Two gaps that block selling subscriptions: + +- **Tier change.** All four Apple subscription products share one subscription group, so a user can switch Supporter โ†” Legend in App Store settings. Apple keeps the same subscription and charges the new price; the service records the charge and grants nothing. We grant the tier the store charged. +- **Restore.** A subscriber on a new phone, or on another profile, taps Restore and gets `receipt_used`, because the payment belongs to the old install's purchase key. We let Restore move the subscription to the new key. + +**Why together.** Both move months between tiers or between purchase keys. The ledger entry types for that exist (`transferIn`, `transferOut`, `upgrade`), but the service can neither store nor re-read them, and a grant cannot change a balance's tier. + +**How.** + +- Tier change: on a charge of the other tier, the service ends the old tier's remaining months with an `upgrade` debit and starts a new run of months at the new tier. It finds out at the next renewal check, or, for a raise, at once when the app sees the new App Store transaction and asks (`upgradeBadgeSubscription`, already in the protocol, unimplemented). +- Restore: a new request, `transferBadge`, signed by a fresh key and carrying the store receipt. The service moves the payment to the new key: `transferOut` on the old purchase; the store's current charge credited to the new one, with the current month issued. A payment moves again only once the credential issued to the key it last moved from has expired: a store receipt is not a secret, so this limit is the only safeguard. +- Stripe and crypto purchases are restored by a receipt code (once per receipt, unissued months only): designed here, built later; it does not block subscriptions. + +**Where.** Service (`SVC/Service.hs`, `SVC/Store.hs`, migrations); shared ledger (`src/Simplex/Chat/Badges/Ledger.hs`); core (`Library/Commands.hs`, `Store/Badges.hs`); the Restore button in both apps. + +**New types and wire changes.** + +- `BSCTransferBadge {masterKey, payment}` and error `transfer_limited`. +- `BSCUpgradeBadgeSubscription` implemented; its `badgeRequest` field dropped (never sent). +- `StoreReceiptOrigin` gains `SRORestored`; `AppleTransactionFacts` gains `productId`. +- Ledger: `debitEntry`; `grantEntry` and `chargeEntries` take the grant's tier. No new entry types. + +**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; 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). + +## Current state + +- **Ledger.** The service ledger's only reference columns are `payment_id` and `charge_id`; `appendLedgerPlan` writes only the tag of the three types (`SVC/Store.hs:318-353`), and `entryTypeFromColumns` cannot rebuild them (`Ledger.hs:220-244`). One unreadable row makes every later answer for that purchase `internal` (`SVC/Store.hs:282-300`). The client stores each entry's JSON and needs no column (`Store/Badges.hs:551-616`). +- **Tier.** Fixed per purchase: `current_badge_type` is written once on both sides; every transition keeps the previous tier (`Ledger.hs:76-117`); the service refuses another tier (`NGOtherTier`, `SVC/Service.hs:631`). On the device, a new Apple transaction for the same subscription is answered from the old record and finished, without asking the service (`Commands.hs:5377-5380`). +- **Restore.** A payment belongs to one purchase key; any other key gets `receipt_used`, which the client treats as final (`SVC/Service.hs:666-671`, `Commands.hs:5409-5414`). The client marks a purchase as a subscription only when its ledger holds a `charge` credit (`Store/Badges.hs:464-492`). +- **Builds on:** retirement on `ended` (commit 55d69781e), and the same-install resume being built on this branch (`reholdStoreReceipt`, `resumeWindow`, `sendBadgeIssue`), whose re-hold T3 and R2 reuse. + +## Design + +### Ledger (L1, L2) + +- **Storage (L1).** `appendLedgerPlan` writes `from_purchase_id`/`to_purchase_id` from the entry's key; the reads join `badge_purchases` for the keys; `entryTypeFromColumns` takes one record of references and rebuilds all three types. +- **Transitions (L2).** + - `debitEntry`: all remaining months to zero, start unchanged (the model's `debit`). + - A grant of another tier is allowed only onto an empty balance, and starts a new run at its own time with the new tier. So the model's "start never decreases" now holds within a tier. + - `chargeEntries` for another tier, at `t = max periodStart (createdAt tip)`: lapse to `t`, `upgrade {own key}` debit if months remain, grant at `t`, lapse to now. Clamping `t` keeps `createdAt` non-decreasing. + - The client's check re-runs `debitEntry` for `upgrade` and `transferOut`, and marks false a tier switch over a non-empty balance. + +### Tier change (T1, S0, T2, T3) + +- **At renewal (T1).** `NGOtherTier` is removed: a charge of the other tier is granted through `chargeEntries`, and both sides update `current_badge_type`. On its own this fixes downgrades, which take effect at renewal. +- **At once (T2, T3).** An Apple upgrade is immediate, and the unused part of the old plan is refunded pro rata. Without T2 and T3 an annual subscriber would pay for Legend for up to 11 months while holding Supporter. + - S0 moves `storePlan` (product โ†’ tier and months) into shared code, so core can read a transaction's tier. + - T3: when a handed-over Apple transaction raises the tier of the shown purchase, was bought after the purchase's last charge credit and has not expired, core re-holds the record as a "tier change". The app keeps the transaction unfinished, and the receipt worker sends `upgradeBadgeSubscription`. A raised tier's credential is presented at once, on this path and on T1's renewal check alike: the subscriber raised the tier in their store, so the broadcast tells the store nothing new. A lower tier keeps the renewal's hold-back, presented when the shown credential expires. Any other transaction, a lower tier or an expired one, is answered from the record and finished, and T1 catches the change at renewal. + - T2 (service): the request must be signed by the purchase key and name its own subscription. The store is asked at most once an hour per subscription, sharing the renewal check's stamp. The answer is the new tier's credential once granted; until then `payment_pending` (within the hour, or while Apple's status still shows the old product), never the old credential. +- **Authority.** The tier granted is the one in the store's own verified answer. The JWS the app sends only names the subscription and what to wait for. +- **Apps.** Nothing new is required: Your badge shows `badgeState.badgeType`, which now follows the ledger. An optional iOS notice "Changes to Supporter on {date}" (T4) shows a pending downgrade. + +### Restore for store subscriptions (R1a, R1b, R2, R3) + +**`transferBadge`, signed by a new key K2, for payment P held by K1** โ€” one transaction: + +- K1: lapse, then `transferOut {K2}` of its unissued months. It is written even at zero, as the marker that makes K1's next answer `subscription = ended`, so K1's badge retires. +- K2: a new purchase funded as a first purchase of P would be: the store's current `charge` credit at its period start, then the current month issued. No `transferIn`: the client would then read K2 as prepaid and stop asking for renewals. +- P's binding moves to K2; `rebound_at = now`; the move is logged. +- Store one-time months are not re-bound: they are issued at purchase, and no app path lists them again. + +**Check order**, so a request re-sent after a lost answer gets its credential: + +1. P already credited to K2: answered from the record, with no store call and no limit. +2. K2 already holds another purchase: `bad_request`. +3. The store vouches for the receipt now. For Apple it must be the subscription's latest transaction, so a leaked old receipt stops working at the next renewal. +4. The limit: `transfer_limited`. + +A payment credited nowhere is treated as a first purchase. `purchaseBadge` from another key still gets `receipt_used`, so the automatic sweeps on two devices never move the badge back and forth; only the Restore button transfers. The request is routed to the purchase lane, since it calls the store. + +**Limit: a payment moves again only once the credential issued to the previous key has expired.** That credential stays valid until then, so each paid month is held by at most two keys, however many devices or people share the store account. The bound is the credential's own expiry rather than a calendar month, because a calendar month has an edge: a move on 31 January and another on 1 February are both allowed, and since a credential outlives a month, three keys would briefly hold valid ones. It does not stop someone holding the account, or a receipt from it, from moving the badge to themselves each time a credential lapses; the store account is the authority, as the stores themselves treat it. + +**Core (R2).** Restore hands receipts over with the new origin `restored`: + +- no record โ†’ a held transfer record with fresh keys; +- a held purchase record that funds no purchase yet โ†’ becomes a transfer; +- a record refused `receipt_used` โ†’ re-held as a transfer; +- a subscription record credited to another profile โ†’ re-held for this profile with fresh keys; a one-time record is left alone; +- resume and tier-change holds, and this profile's own retired subscription while it is the profile's newest purchase โ†’ left to the resume; an older one, or one whose payment moved away โ†’ re-held as a transfer with fresh keys. + +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." + +### Restore by receipt for Stripe and crypto (later, R4-R6) + +- **R4 (service).** Each code or web purchase that grants months returns a receipt code; the service stores its hash. +- **R5 (service).** `transferBadge` with `SPReceipt` moves only the unissued months: `transferOut` on K1, `transferIn {K1}` on K2 starting now. The receipt is retired and a fresh one is returned. +- **R6 (apps).** The app stores the receipt, shows it with a "keep your receipt" prompt, and adds a "Move a badge from another device" entry. + +### Threats + +| Threat | Handling | +|---|---| +| Tier change the user did not intend | Granted exactly as the store charged; undone through the store (switch back, refund). The apps never offer a change. | +| Client claims a tier it did not pay for | The tier comes from the store's verified answer, not the JWS. | +| Replayed upgrade or transfer request | Upgrade: answered from state within the hour, and each charge is granted once. Transfer: answered from the record (check 1). | +| Leaked or replayed store receipt | A payment moves again only once the previous key's credential has expired; an Apple receipt expires at the next renewal; every move is logged. A Play token has only that limit. | +| Two devices racing a transfer | The write re-reads K1's tip and P's binding, and writes nothing if either moved. | +| Linking | A transfer links K2 to K1 at the service; the store account already links them. Design objective 4 in `badges-overview.md` gains this exception. Requests follow the user's own action, as purchases do. | + +## Slices + +One PR, built in these slices in order; T3 and R2 need the same-install resume on the branch first. Each slice runs `cabal build --enable-tests` and the suites named. + +| Slice | Change | Tests | Lines | +|---|---|---|---| +| L1 | service reference columns + migration; rebuild the three types | `testEntryTypeColumns`, `testTransferEntriesRoundTrip`, schema down/up (`-m "Supporter badges" -m "badge service schema" -m "badge service store"`) | ~150 | +| L2 | `debitEntry`, tier-aware `grantEntry`/`chargeEntries`, client check | `testDebitRowsVerify`, `testTierChangeRowsVerify` (`-m "Supporter badges"`) | ~200 | +| T1 | grant other tier at renewal; update `current_badge_type` both sides | `testSubscriptionTierChangeAtRenewal`; drop the other-tier case from `testSubscriptionChargeNotGranted` and from the resume's bounded test (`-m "SimpleX badge service e2e/subscriptions/"`) | ~200 | +| S0 | move `storePlan` to shared code (structural) | existing suites | ~60 | +| T2 | `upgradeBadgeSubscription` handler, renewal lane | `testSubscriptionUpgradeNow`, `testUpgradeRequestRefused`, `testStoreRouting` | ~250 | +| T3 | `productId`, `hold_kind` migration, tier-change hold and worker send | `testAppleTierChangeHandOver`, `testAppleTierChangeStoreLags` | ~300 | +| R1a | `rebound_at`, charge index, move-binding store function | schema down/up (these changes are in `20261012_badge_subscriptions`, whose down migration drops them and every other subscription column without refusing, and the service README warns against it on a database holding subscriptions; whether it should refuse there is the owner's open call), store test | ~150 | +| R1b | `transferBadge` handler, `ended` after `transferOut`, docs | `testStoreRebind`, `testStoreRebindCapped`, `testStoreRebindOldKeyEnded`, `testStoreRebindStaleAppleTransaction`, `testTransferUncredited`, `testTransferReplayAnswered`, `testTransferKnownKeyRefused` | ~300 | +| R2 | `SRORestored` and the restore cases in core | `testRestoreOnNewDevice`, `testRestoreOnOtherProfile`, `testRestoreAfterUnfinishedPass` | ~300 | +| R3 | Restore in iOS and Kotlin, `gaps.md` | build both apps; restore on a second device and profile | ~150 | + +**Blocks selling subscriptions:** every slice above. **Does not block:** T4, R4-R6. + +Final checks: `-m "badge"` here; the full suite (query plans) and the Postgres build and schema tests on the host. + +## Risks + +- **Riskiest assumption:** that restarting the run at the clamped `t` keeps every row verifiable on all paths. L2's pure tests check this before any service code depends on it. +- **Apple behaviour from documentation:** an upgrade is immediate, the old plan is refunded pro rata, and the subscription keeps its original id; a downgrade waits for renewal; `currentEntitlements` returns the latest transaction. Confirm in Sandbox before sale. If upgrades are not refunded, the `upgrade` debit becomes a conversion instead. +- A restore soon after an earlier move may be refused by the move limit, which the app reports with no date, as `transfer_limited` carries none; one presenting an Apple transaction older than the subscription's latest is answered `payment_pending` and stays held until a hand-over brings the latest. + +## Decided + +- One Apple subscription group for all four subscription products, so users can change tier in the store and this plan grants it. + +## Open questions (the slices assume the recommended answers) + +1. **The move limit.** Decided: a payment moves again only once the credential issued to the previous key has expired, which is what bounds how many keys hold a valid credential at once. Rejected: once per calendar month, whose month boundary lets two moves through in two days; once per billing period, which would mean once a year for annual plans. +2. **Re-issue the current month on a store restore.** Recommended: yes. Otherwise a monthly subscriber, or an App Reviewer, sees nothing until the next renewal. +3. **Require the latest Apple transaction for a restore.** Recommended: yes. +4. **Keep a tier change on the same key**, where the model's ยง2.10 uses new keys. Recommended: the same key. The service sees changes made in the store's settings without the client, and only the client can make keys. + +## Rejected alternatives + +- **Re-bind on any `purchaseBadge` from another key:** two devices would move the badge back and forth on every launch. +- **`transferIn` for a store restore:** the client would treat the subscription as prepaid and stop asking for renewals. +- **Unissued months only for stores:** a restore mid-month would show nothing. +- **Send the upgrade request from the hand-over itself:** it blocks the app's purchase sweep, and a network error becomes a "Purchase error" alert. +- **Ask the store at every monthly issuance:** twelve times the store calls for annual plans, and still up to a month late. +- **Move a purchase between profiles of one install locally:** more private for that case, but it does not cover a new device, and it would be a second path. diff --git a/scripts/badge-service/badge_service.ini.example b/scripts/badge-service/badge_service.ini.example index f0dea005ac..6728a4f9e3 100644 --- a/scripts/badge-service/badge_service.ini.example +++ b/scripts/badge-service/badge_service.ini.example @@ -40,9 +40,16 @@ idle_seconds = 60 ; root_certificates lists, comma-separated, the roots trusted to sign receipts, each in DER and placed ; in config/. Today that is https://www.apple.com/certificateauthority/AppleRootCA-G3.cer. ; When Apple adds a root, list it beside the old one rather than in its place. +; the api_ keys, set together, verify subscriptions with the in-app purchase key App Store Connect +; issues; without them every App Store subscription is answered provider_not_configured. Place the .p8 +; in config/; it must be readable by the service's user alone. api_host defaults to production, the +; only host accepted unless [dev] credit_test_purchases = on, which needs the Sandbox host instead. ;[apple] ;bundle_id = chat.simplex.app ;root_certificates = /etc/simplex-badge-service/AppleRootCA-G3.cer +;api_key_id = 2X9R4HXF34 +;api_issuer_id = 57246542-96fe-1a63-e053-0824d011072a +;api_private_key_file = /etc/simplex-badge-service/AuthKey_2X9R4HXF34.p8 ; optional; without it every Play receipt is answered provider_not_configured, which the app retries later. ; service_account_file is the JSON key of a service account with the Play Console permissions "View @@ -72,6 +79,29 @@ private_key = replace-me ; local testing only, in both run modes: accepts any well-formed App Store or Play receipt without ; verifying it, so anyone who can reach this service can mint badges. The service refuses to start -; with this on beside an [apple] or [google] section. +; with this on beside an [apple] or [google] section. Its issuer key is always one released apps +; trust, so they accept every badge minted this way. +; A subscription is answered renewing and charged for its plan: the App Store product's, or the base +; plan a Play test token test.. names when it is a plan of that product, and else +; the product's monthly base plan, so a licence tester's purchase is credited too. An App Store tier +; raise is charged for the raised plan, which its renewals then charge. The plans are kept in memory, +; so a restart answers later renewals as ended, and refunds the unissued +; months of a plan still covered at its next month. Nothing is acknowledged, so Play refunds a +; licence tester's subscription once its acknowledgement window lapses. [dev] accept_unverified_store_receipts = off +; only beside accept_unverified_store_receipts or credit_test_purchases = on: every issue request for a +; subscription asks its store, while coverage runs too, and banks the months each check charges, to +; watch a renewal by hand. +check_store_during_coverage = off + +; local testing only, beside a real [apple] or [google]: credits a purchase the store itself calls a +; test - an App Store sandbox purchase, or a Play licence tester's - which no real buyer pays for. +; Without it such a purchase is refused as test_purchase, which is terminal, so it can never be credited. +; Beside [apple] the service starts with this on only when its api_ keys are set with +; api_host = https://api.storekit-sandbox.itunes.apple.com, since a sandbox receipt verifies like any +; other and would otherwise be credited as a real purchase. Beside [google] it is allowed: never turn it +; on beside the production app's [google], as the issuer key is one released apps trust and every +; licence tester the Play Console lists would get a badge without paying. Each test purchase or test +; subscription taken as paid is logged as a warning. +credit_test_purchases = off diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 46fcfd405e..f654c3f843 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 @@ -173,6 +174,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20261012_delivery_job_notification Simplex.Chat.Store.Postgres.Migrations.M20261016_badge_store_receipts Simplex.Chat.Store.Postgres.Migrations.M20261019_chat_layout + Simplex.Chat.Store.Postgres.Migrations.M20261021_badge_subscriptions else exposed-modules: Simplex.Chat.Archive @@ -356,6 +358,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20261016_badge_store_receipts Simplex.Chat.Store.SQLite.Migrations.M20261018_autoincrement_ids Simplex.Chat.Store.SQLite.Migrations.M20261019_chat_layout + Simplex.Chat.Store.SQLite.Migrations.M20261021_badge_subscriptions other-modules: Paths_simplex_chat hs-source-dirs: @@ -763,6 +766,7 @@ test-suite simplex-chat-test Bots.BadgeService.BotTests Bots.BadgeService.CatalogTests Bots.BadgeService.ConfigTests + Bots.BadgeService.FakeAppStore Bots.BadgeService.FakeBTCPay Bots.BadgeService.FakePlay Bots.BadgeService.FakeStore diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 61146c0afa..033bf31837 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -75,6 +75,8 @@ defaultChatConfig = badgeCurrentTime = getCurrentTime, badgeRetryInterval = RetryInterval {initialInterval = 30_000000, increaseAfter = 0, maxInterval = 3600_000000}, badgeConsecutiveRetries = 3, + badgeDevRequests = False, + badgeDevRequestInterval = Nothing, confirmMigrations = MCConsole, -- this property should NOT use operator = Nothing -- non-operator servers can be passed via options diff --git a/src/Simplex/Chat/Badges.hs b/src/Simplex/Chat/Badges.hs index 437b55e24d..7be33212f7 100644 --- a/src/Simplex/Chat/Badges.hs +++ b/src/Simplex/Chat/Badges.hs @@ -29,6 +29,7 @@ module Simplex.Chat.Badges defaultFileSizeLimits, maxXFTPFileSize, maxSndXFTPFileSize, + badgeGraceInterval, badgeSndGraceInterval, badgeServerCredential, maxFileSizeSupporter, diff --git a/src/Simplex/Chat/Badges/Ledger.hs b/src/Simplex/Chat/Badges/Ledger.hs index 870820d7c8..3378c6a8fb 100644 --- a/src/Simplex/Chat/Badges/Ledger.hs +++ b/src/Simplex/Chat/Badges/Ledger.hs @@ -8,18 +8,22 @@ module Simplex.Chat.Badges.Ledger lapseEntry, grantEntry, issueEntry, + debitEntry, + chargeEntries, paidThrough, balanceChecked, addMonths, endOfMondayAfter, entryTypeColumns, + EntryReferences (..), + noEntryReferences, entryTypeFromColumns, creditTypeTag, debitTypeTag, ) where -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, maybeToList) import Data.Text (Text) import Data.Time.Calendar (addDays, addGregorianMonthsClip, toGregorian) import Data.Time.Calendar.WeekDate (toWeekDate) @@ -27,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 @@ -89,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 @@ -115,6 +121,31 @@ issueEntry t entryId e@StatementEntry {balanceMonths, balanceStartTs} entryType = SEDebit SDBadge } +-- | 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 + 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 -- days, while a device clock a few minutes slow would otherwise leave every row unverified. maxCreatedAtSkew :: NominalDiffTime @@ -142,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 @@ -155,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 @@ -163,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 @@ -205,16 +244,30 @@ debitTypeTag = \case SDLapse -> "lapse" SDUnknown {tag} -> tag --- | Rebuilds only what the columns determine: constructors with no fields, and a payment 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 charge, transferIn, upgrade and transferOut from their reference columns, --- without which the service cannot re-emit a statement carrying one. -entryTypeFromColumns :: Maybe (Maybe InvoiceId) -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType -entryTypeFromColumns payment_ entryType credit_ debit_ = case (entryType, credit_, debit_) of - ("credit", Just "payment", _) -> SECredit . SCPayment <$> payment_ +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 80ee632c25..a828cfbf6b 100644 --- a/src/Simplex/Chat/Badges/Service.hs +++ b/src/Simplex/Chat/Badges/Service.hs @@ -18,6 +18,7 @@ module Simplex.Chat.Badges.Service BadgeUpgrade (..), BadgeServiceResponse (..), BadgeServiceErrorCode (..), + SubscriptionState (..), BadgeCatalog (..), BadgePrice (..), BadgeOffer (..), @@ -92,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 } @@ -121,7 +125,8 @@ data BadgeServiceResponse | BSPBadgeCredential { credential :: Maybe BadgeCredential, -- Nothing when no balance to issueBadge or no current credential for pause receipt :: Maybe Text, -- not provided for lifetime badges - statement :: BadgeStatement + statement :: BadgeStatement, + subscription :: Maybe SubscriptionState -- present exactly when a store subscription funds the purchase } | BSPError { code :: BadgeServiceErrorCode, diff --git a/src/Simplex/Chat/Badges/StorePlan.hs b/src/Simplex/Chat/Badges/StorePlan.hs new file mode 100644 index 0000000000..6f4f371843 --- /dev/null +++ b/src/Simplex/Chat/Badges/StorePlan.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Chat.Badges.StorePlan (storePlan, playBasePlan) 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, _) -> snd <$> playBasePlan planId + _ -> Nothing + +-- | A Play base plan's subscription product, and what the plan grants. Play keeps a base plan id unique +-- only within its subscription, so a plan is one of these only under its own product. +playBasePlan :: Text -> Maybe (Text, (BadgeType, Int)) +playBasePlan = \case + "subscr-badge-supporter-month-02" -> Just ("subscr_badge_supporter_01", (BTSupporter, 1)) + "subscr-badge-supporter-year-01" -> Just ("subscr_badge_supporter_01", (BTSupporter, 12)) + "subscr-badge-legend-month-01" -> Just ("subscr_badge_legend_01", (BTLegend, 1)) + "subscr-badge-legend-year-01" -> Just ("subscr_badge_legend_01", (BTLegend, 12)) + _ -> Nothing diff --git a/src/Simplex/Chat/Badges/Types.hs b/src/Simplex/Chat/Badges/Types.hs index f4949848f1..8d6a1f23e2 100644 --- a/src/Simplex/Chat/Badges/Types.hs +++ b/src/Simplex/Chat/Badges/Types.hs @@ -20,6 +20,7 @@ module Simplex.Chat.Badges.Types LedgerDebitType (..), BadgeAlertKind (..), BadgeServiceErrorCode (..), + SubscriptionState (..), BadgeIssueFailure (..), BadgeIssueError (..), BadgeFunding (..), @@ -29,8 +30,10 @@ module Simplex.Chat.Badges.Types BadgeIssuance (..), BadgeAlert (..), BadgeAlertPrice (..), + BadgeSubscription (..), BadgeState (..), OpenStorePurchase (..), + StoreReceiptOrigin (..), ) where import Control.Applicative ((<|>)) @@ -117,13 +120,14 @@ data LedgerDebitType deriving (Eq, Show) -- unconfirmed draft -data BadgeAlertKind = BARenewalApproaching | BAPaymentIssue | BASubscriptionEnded | BAPrepaidEnding | BASupportEnded | BAIssueFailed +data BadgeAlertKind = BARenewalApproaching | BAPaymentIssue | BASubscriptionCancelled | BASubscriptionEnded | BAPrepaidEnding | BASupportEnded | BAIssueFailed deriving (Eq, Show) instance TextEncoding BadgeAlertKind where textEncode = \case BARenewalApproaching -> "renewal_approaching" BAPaymentIssue -> "payment_issue" + BASubscriptionCancelled -> "subscription_cancelled" BASubscriptionEnded -> "subscription_ended" BAPrepaidEnding -> "prepaid_ending" BASupportEnded -> "support_ended" @@ -131,6 +135,7 @@ instance TextEncoding BadgeAlertKind where textDecode = \case "renewal_approaching" -> Just BARenewalApproaching "payment_issue" -> Just BAPaymentIssue + "subscription_cancelled" -> Just BASubscriptionCancelled "subscription_ended" -> Just BASubscriptionEnded "prepaid_ending" -> Just BAPrepaidEnding "support_ended" -> Just BASupportEnded @@ -244,11 +249,21 @@ 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 deriving (Eq, Show) +-- | The store's answer as the service last read it. A client reads a state it does not know as not ended. +data SubscriptionState + = SSRenewing + | SSCancelled -- auto-renew is off, and the paid period still runs + | SSBillingRetry -- a charge failed and the store is retrying it: grace, retry or hold + | SSEnded -- no charge will come: expired, revoked or refunded + | SSUnknown Text -- forwards-compatible: service is deployed ahead of clients + deriving (Eq, Show) + -- | Why a renewal request ended without a credential stored. retryable is the service's own view of -- transience: it gave retryAfter, which holds for codes this version does not know. data BadgeIssueFailure @@ -280,14 +295,23 @@ data BadgeState = BadgeState willRenew :: Bool, alert :: Maybe BadgeAlert, issueError :: Maybe BadgeIssueError, - nextWakeAt :: Maybe UTCTime + nextWakeAt :: Maybe UTCTime, + subscription :: Maybe BadgeSubscription } deriving (Show) +-- | A store subscription funding the purchase: the latest charge's plan, and the store's state as last observed. +data BadgeSubscription = BadgeSubscription + { planMonths :: Int, + status :: Maybe SubscriptionState, + transactionRef :: Maybe Text -- the store receipt's: Apple's original transaction id, or a hash of Play's token + } + deriving (Eq, Show) + -- | One of a profile's store purchases that no receipt has reached yet, or whose receipt is held until -- the service credits it; transactionRef is set once a receipt arrived. Neither reference is a secret: --- Apple's is the transaction id, Google's is a hash of the token. creditError is set only while the --- held receipt's last attempt failed in a way that cannot clear on its own. +-- Apple's is the transaction id, or a subscription's original one; Google's is a hash of the token. +-- creditError is set only while the held receipt's last attempt failed in a way that cannot clear on its own. data OpenStorePurchase = OpenStorePurchase { invoiceId :: Maybe Text, transactionRef :: Maybe Text, @@ -295,6 +319,14 @@ data OpenStorePurchase = OpenStorePurchase } deriving (Show) +-- | 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 + | 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 textEncode = \case PSAcquiring -> "acquiring" @@ -346,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 @@ -367,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 @@ -378,6 +412,31 @@ instance ToJSON BadgeServiceErrorCode where instance FromJSON BadgeServiceErrorCode where parseJSON = textParseJSON "BadgeServiceErrorCode" +instance TextEncoding SubscriptionState where + textEncode = \case + SSRenewing -> "renewing" + SSCancelled -> "cancelled" + SSBillingRetry -> "billingRetry" + SSEnded -> "ended" + SSUnknown t -> t + textDecode s = Just $ case s of + "renewing" -> SSRenewing + "cancelled" -> SSCancelled + "billingRetry" -> SSBillingRetry + "ended" -> SSEnded + t -> SSUnknown t + +instance ToJSON SubscriptionState where + toJSON = textToJSON + toEncoding = textToEncoding + +instance FromJSON SubscriptionState where + parseJSON = textParseJSON "SubscriptionState" + +instance FromField SubscriptionState where fromField = fromTextField_ textDecode + +instance ToField SubscriptionState where toField = toField . textEncode + instance StrEncoding BadgeIssueFailure where strEncode = \case BIFServiceError {code, retryable} -> "service_error " <> (if retryable then "retry " else "final ") <> encodeUtf8 (textEncode code) @@ -427,6 +486,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BIF") ''BadgeIssueFailure) $(JQ.deriveJSON defaultJSON ''BadgeIssueError) +$(JQ.deriveJSON defaultJSON ''BadgeSubscription) + $(JQ.deriveJSON defaultJSON ''BadgeState) $(JQ.deriveJSON defaultJSON ''OpenStorePurchase) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index c2095ea9ef..3731b112a1 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -85,7 +85,7 @@ import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyM import qualified Simplex.Messaging.Crypto as C import Simplex.Chat.Badges (BadgeCredential, FileSizeLimits, LocalBadge) import Simplex.Chat.Badges.Service (BadgeServiceErrorCode, StatementEntry) -import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeIssueFailure, BadgeState (..), OpenStorePurchase (..)) +import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeIssueFailure, BadgeState (..), OpenStorePurchase (..), StoreReceiptOrigin, SubscriptionState) import Simplex.Chat.PaymentService (ServicePayment) import Simplex.Messaging.Crypto.BBS (BBSPublicKey) import Simplex.Messaging.Crypto.File (CryptoFile (..)) @@ -156,6 +156,11 @@ data ChatConfig = ChatConfig badgeRetryInterval :: RetryInterval, -- attempts a store receipt gets in one turn before its next one waits for the stored schedule badgeConsecutiveRetries :: Int, + -- set only by builds for a dev badge service: allows /_badge request, sent off the shared schedule + badgeDevRequests :: Bool, + -- Local testing only: the badge worker treats a request as due this often, instead of near the + -- credential's expiry, so a renewal can be watched without waiting weeks. + badgeDevRequestInterval :: Maybe NominalDiffTime, confirmMigrations :: MigrationConfirmation, presetServers :: PresetServers, shortLinkPresetServers :: NonEmpty SMPServer, @@ -666,13 +671,15 @@ data ChatCommand | UpdateProfileImageFromFile FilePath -- set profile image from a .png/.jpg/.jpeg file | AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`) | APIRedeemBadgeCode {userId :: UserId, code :: Text} -- redeem a badge code with the configured badge service - | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, payment :: ServicePayment} -- hand over an App Store or Google Play receipt, held until a worker credits it; answers from the record and sends nothing + | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, origin :: StoreReceiptOrigin, payment :: ServicePayment} -- hand over an App Store or Google Play receipt, held until a worker credits it; answers from the record and sends nothing + | APISetBadgeSubscriptionStatus {status :: SubscriptionState, payment :: ServicePayment} -- the device store's view of a credited subscription, which changes what is shown and alerted, and retires its badge once ended | APICreateBadgeInvoice {userId :: UserId} -- the record of a store purchase, created before the store charges; answers the id the store echoes | APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert | APIGetBadgeLedger {userId :: UserId, badgePurchaseId :: Int64} -- the purchase's ledger, oldest first -- episode is last because it is free text: it is the value that makes one occurrence of an -- alert distinct from the next, and the app returns whatever it was given | APIAckBadgeAlert {userId :: UserId, badgePurchaseId :: Int64, alertKind :: BadgeAlertKind, snooze :: Bool, episode :: Text} + | APIRequestBadge {userId :: UserId} | ShowProfileImage | SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI) | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed) @@ -777,6 +784,7 @@ allowRemoteCommand = \case DeleteRemoteCtrl _ -> False ExecChatStoreSQL _ -> False ExecAgentStoreSQL _ -> False + APIRequestBadge {} -> False _ -> True data RelayConnectionResult = RelayConnectionResult @@ -880,6 +888,7 @@ data ChatResponse | CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId} | CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool, badgeState :: Maybe BadgeState} | CRBadgeInvoice {user :: User, invoiceId :: Text} + | CRStoreReceiptNotRecorded {user :: User} | CRBadgeState {user :: User, badgeState :: Maybe BadgeState, storePurchases :: [OpenStorePurchase]} | CRBadgeLedger {user :: User, badgeLedger :: [StatementEntry]} | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact} @@ -1501,6 +1510,7 @@ data BadgeRedeemError | BREInvalidReceipt -- names no transaction, or is not a store payment | BREServiceNotConfigured | BREBadgeActive + | BREStorePurchaseOpen -- a store receipt held for this profile may still be credited | BREServiceError {serviceError :: BadgeServiceErrorCode} | BREInvalidResponse {message :: String} | BREUnknownKeyIndex diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index ba76efd741..6737ac1368 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -53,17 +53,19 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime) import Data.Word (Word32) import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Type.Equality import qualified Data.UUID as UUID import qualified Data.UUID.V4 as V4 import Simplex.Chat.Library.Subscriber import Crypto.Random (ChaChaDRG) import Simplex.Messaging.Session (SessionVar (..), withGetSessVar') -import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), ProofPresHeader (..), badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType (..), LocalBadge (..), ProofPresHeader (..), badgeGraceInterval, badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential) import qualified Simplex.Chat.Badges.Ledger as L -import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), OpenStorePurchase (..)) +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 (..), currentBadgeServiceVersion) +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 @@ -76,7 +78,7 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.Operators import Simplex.Chat.Options -import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef) +import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts, appleTransactionRef, googlePurchaseRef) import Simplex.Chat.PaymentService.Types (PaymentProvider (..), StoreTransactionRef (..)) import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol @@ -3623,10 +3625,12 @@ processChatCommand cxt nm = \case ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile) AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user APIRedeemBadgeCode userId codeText -> withUserId userId $ \user -> redeemBadgeCode nm user codeText - APIPurchaseBadge userId echoedInvoiceId payment -> withUserId userId $ \user -> handOverStoreReceipt user echoedInvoiceId payment + APIPurchaseBadge userId echoedInvoiceId origin payment -> withUserId userId $ \user -> handOverStoreReceipt user echoedInvoiceId origin payment + APISetBadgeSubscriptionStatus status payment -> recordStoreSubscriptionStatus status payment >> ok_ APICreateBadgeInvoice userId -> withUserId userId $ \user -> do void requireBadgeService refuseWhileBadgeHeld user + refuseWhileStoreReceiptPending user Nothing g <- asks random now <- badgeNow invoiceId <- UUID.toText <$> liftIO V4.nextRandom @@ -3642,9 +3646,10 @@ processChatCommand cxt nm = \case now <- badgeNow let snoozeUntil = if snooze then Just (addUTCTime nominalDay now) else Nothing withStore' $ \db -> setBadgeAlertAcked db user badgePurchaseId alertKind episode snoozeUntil - -- after the write, so the pass it signals arms a wake for the snooze rather than raising again + -- after the write, so the pass it signals reads the ack rather than raising the alert again lift $ startBadgeWork user badgeStateResponse user + APIRequestBadge userId -> withUserId userId requestBadgeNow SetBotCommands commands -> withUserProfileLock "updateProfile" $ withUser $ \user@User {profile} -> do let LocalProfile {preferences} = profile prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands} @@ -5364,37 +5369,173 @@ redeemBadgeCode nm user@User {userId} codeText = do -- | The app hands a receipt over until it is answered credited or refused, under whichever profile is -- active; the answer is the owner's, read from the record. Nothing is sent: the owner's receipt worker is. -handOverStoreReceipt :: User -> Maybe Text -> ServicePayment -> CM ChatResponse -handOverStoreReceipt presentingUser echoedInvoiceId payment = do +handOverStoreReceipt :: User -> Maybe Text -> StoreReceiptOrigin -> ServicePayment -> CM ChatResponse +handOverStoreReceipt presentingUser echoedInvoiceId origin payment = do txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment void requireBadgeService g <- asks random now <- badgeNow - BadgeReceiptRecord {ownerId, status} <- - withStore' (\db -> holdStoreReceipt db g presentingUser echoedInvoiceId txRef payment now) - >>= maybe (throwChatError $ CEInternalError "store receipt was not recorded") pure - owner <- withStore $ \db -> getUser db ownerId - case status of - RSHeld {} -> lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner - RSCredited {badgePurchaseId} -> do - cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId) - cred@(BadgeCredential _ _ _ info) <- maybe (throwChatError $ CEInternalError "credited store purchase has no credential") pure cred_ - CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner - RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code - RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason" + limited <- case origin of + -- a move would retire the shown badge's own payment elsewhere, or wait behind it or behind another receipt held here, + -- so one Restore claims one transaction + SRORestored -> do + refuseWhileBadgeHeld presentingUser + refuseWhileStoreReceiptPending presentingUser (Just txRef) + 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 + _ -> 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 + -- a resubscription no resume reaches moves to fresh keys of its owner, as Restore moves it, once the owner shows + -- no badge; until then it is answered held, so the app keeps it unfinished + holdAppleResume = + withStore' (\db -> purchaseUnreached db owner badgePurchaseId) >>= \case + False -> rehold SHKPurchase + True -> do + unlessM (withStore' (`userHasBadge` owner)) $ + whenM (withStore' $ \db -> holdStoreTransfer db g owner txRef payment now) $ + lift (resumeStoreReceiptWork ownerId) >> throwRedeemError (BREServiceError BSETransferLimited) + pure True + movedOut <- withStore' (`purchaseMovedOut` badgePurchaseId) + answeredHeld <- case resumeHold now payment of + _ | movedOut -> pure False + -- a charge refused after its hold is answered from the record, or the app's sweep would hold it again at every launch + Just (RHPurchasedAt purchasedAt) | not (refusalRecorded && resumeHoldEnded now purchasedAt) -> holdAppleResume + -- a refused Play resume is held again: the service's hourly check bounds what the sweep can ask of Play + Just RHAttempts -> rehold SHKPurchase + _ -> pure False + lastChargeAt_ <- withStore' (`getLastChargeCreditAt` badgePurchaseId) + -- a refused tier change is answered from the record once, on which the app finishes it, or every sweep would hold it + -- and send it again; the record keeps no transaction id, so the refusal is then cleared and a later charge is held + tierChangeHeld <- case tierChangeCharge now lastChargeAt_ payment of + Just tier + | not answeredHeld -> + withStore' (`getBadgePurchase` badgePurchaseId) >>= \case + Just UserBadgePurchase {badgeType, shown} + | raisesTier badgeType tier -> + if refusalRecorded + then False <$ when shown (withStore' (`clearStoreReceiptRefusal` receiptId)) + else rehold SHKTierChange + _ -> pure False + _ -> pure False + if answeredHeld || tierChangeHeld + then lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner + else do + cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId) + cred@(BadgeCredential _ _ _ info) <- maybe (throwChatError $ CEInternalError "credited store purchase has no credential") pure cred_ + CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner + RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code + RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason" + +-- | Renewing does not replace billing retry: Play lists a subscription in its grace period as renewing, +-- and the service's answer clears billing retry once the store charges. It replaces ended only while the badge is shown: +-- the service's ended answer retires the badge in the same pass, so an ended still shown is a device's report, which a +-- resubscription corrects, while a retired purchase resumes only by its charge. +recordStoreSubscriptionStatus :: SubscriptionState -> ServicePayment -> CM () +recordStoreSubscriptionStatus reported payment = do + txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment + changedOwner_ <- withStore' $ \db -> + getReceiptRecord db txRef >>= \case + Just BadgeReceiptRecord {ownerId, status = RSCredited {badgePurchaseId}} -> + getBadgePurchase db badgePurchaseId >>= \case + Just UserBadgePurchase {shown, purchaseKind = PKSubscription BadgeSubscription {status}} + | replaces shown status -> Just ownerId <$ setBadgeSubscriptionStatus db badgePurchaseId reported + _ -> pure Nothing + _ -> pure Nothing + forM_ changedOwner_ $ \ownerId -> do + owner <- withStore (`getUser` ownerId) + toView . CEvtBadgeChanged owner =<< getUserBadgeState owner + lift $ startBadgeWork owner + where + replaces shown = \case + Just stored | stored == reported -> False + Just SSBillingRetry -> reported /= SSRenewing + Just SSEnded -> shown || reported /= SSRenewing + _ -> True -- | The receipt will never be credited to its key; any other refusal may pass on a retry. storeReceiptRefused :: BadgeServiceErrorCode -> Bool storeReceiptRefused = \case BSEReceiptInvalid -> True BSEReceiptUsed -> True + -- a badge moves only on the user's Restore, never by a retry once the limit has passed + BSETransferLimited -> True BSETestPurchase -> True _ -> False +-- | How far ahead of this device's clock a charge's purchase date may be: a payload dated further ahead is never held. +resumeClockSkew :: NominalDiffTime +resumeClockSkew = nominalDay + +-- | How long after a charge's purchase date a resume the service answers without crediting keeps holding the profile. +resumeHoldLimit :: NominalDiffTime +resumeHoldLimit = nominalDay + +-- | The purchase date of an Apple subscription charge that may resume a retired purchase: not revoked, and bought +-- for a paid period that has not ended. Read from the unverified payload, which decides only whether to ask the service. +resumableCharge :: UTCTime -> ServicePayment -> Maybe UTCTime +resumableCharge now = \case + SPApple {jws} + | Just AppleTransactionFacts {purchaseDate = Just purchased, expiresDate = Just expires, revoked = False, autoRenewable = True} <- appleTransactionFacts jws, + let purchasedAt = millisTime purchased, + purchasedAt < resumeClockSkew `addUTCTime` now, + now < millisTime expires -> + Just purchasedAt + _ -> Nothing + where + millisTime ms = posixSecondsToUTCTime $ fromIntegral ms / 1000 + +resumeHoldEnded :: UTCTime -> UTCTime -> Bool +resumeHoldEnded now purchasedAt = resumeHoldLimit `addUTCTime` purchasedAt <= now + +-- | How long a resume the service answers without crediting keeps holding the profile: an Apple charge until +-- resumeHoldLimit after its purchase date, a Play token, which carries no date, for heldChargeAttempts attempts per hand-over. +data ResumeHold = RHPurchasedAt UTCTime | RHAttempts + +-- | Any Play token may resume, as reholdStoreReceipt and the worker's resume take only a subscription purchase. +resumeHold :: UTCTime -> ServicePayment -> Maybe ResumeHold +resumeHold now = \case + SPGoogle {} -> Just RHAttempts + payment -> RHPurchasedAt <$> resumableCharge now payment + +-- | The attempts, thrown and failed ones included, that one hand-over of a Play resume or an App Store tier change is held +-- for; then the record is set aside, and the next hand-over holds it again. The service still asks its store at most hourly. +heldChargeAttempts :: Int64 +heldChargeAttempts = 24 + +-- | The tier of an Apple subscription charge that may change the tier of a shown purchase: not revoked, not expired, and +-- bought after the purchase's last charge credit, which the service dates no earlier than its charge, so a credited change +-- is never newer. Read from the unverified payload, which decides only what to ask the service and wait for. +tierChangeCharge :: UTCTime -> Maybe UTCTime -> ServicePayment -> Maybe BadgeType +tierChangeCharge now lastChargeAt_ = \case + SPApple {jws} + | Just AppleTransactionFacts {productId = Just planId, purchaseDate = Just purchased, expiresDate, revoked = False, autoRenewable = True} <- appleTransactionFacts jws, + Just (tier, _) <- storePlan PPApple planId, + Just lastChargeAt <- lastChargeAt_, + lastChargeAt < millisTime purchased, + maybe True ((now <) . millisTime) expiresDate -> + Just tier + _ -> Nothing + where + millisTime ms = posixSecondsToUTCTime $ fromIntegral ms / 1000 + +-- | Whether a charge of the second tier raises a purchase of the first: any other change waits for the renewal check. +raisesTier :: BadgeType -> BadgeType -> Bool +raisesTier BTSupporter BTLegend = True +raisesTier _ _ = False + -- | The same reference the service claims a transaction by, read without verifying anything. storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef storeTransactionRef = \case - SPApple {jws} -> StoreTransactionRef PPApple <$> appleTransactionId jws + SPApple {jws} -> StoreTransactionRef PPApple <$> appleTransactionRef jws SPGoogle {token} -> Just $ StoreTransactionRef PPGoogle $ googlePurchaseRef token SPInvoice {} -> Nothing SPReceipt {} -> Nothing @@ -5404,7 +5545,7 @@ storeTransactionRef = \case stashBadgeKeys :: User -> Maybe BadgeStash -> (DB.Connection -> IO BadgeStash) -> CM BadgeStash stashBadgeKeys user stash_ createStash = do replaying <- maybe (pure False) (\s -> withStore' $ \db -> isJust <$> getStashBadgePurchase db s) stash_ - unless replaying $ refuseWhileBadgeHeld user + unless replaying $ refuseWhileBadgeHeld user >> refuseWhileStoreReceiptPending user Nothing maybe (withStore' createStash) pure stash_ requireBadgeService :: CM (ConnectTarget 'CMContact) @@ -5413,6 +5554,21 @@ requireBadgeService = asks (badgeServiceAddress . config) >>= maybe (throwRedeem refuseWhileBadgeHeld :: User -> CM () refuseWhileBadgeHeld user = whenM (withStore' (`userHasBadge` user)) $ throwRedeemError BREBadgeActive +-- | A new badge would leave a held receipt waiting behind it. An Apple subscription blocks until its charge lapses, as Apple +-- keeps charging it; any other only while its last failure, if any, can clear, since one that failed for good waits anyway. +-- The record of the transaction presented, if any, is not another receipt. +refuseWhileStoreReceiptPending :: User -> Maybe StoreTransactionRef -> CM () +refuseWhileStoreReceiptPending user presented_ = do + now <- badgeNow + pending <- withStore' $ \db -> getPendingStoreReceipts db user now + when (any blocks $ filter (not . presented . fst) pending) $ throwRedeemError BREStorePurchaseOpen + where + presented payment = isJust presented_ && (storeTransactionRef =<< decodeJSON payment) == presented_ + blocks (payment, failure_) = appleSubscription payment || maybe True badgeFailureTransient failure_ + appleSubscription payment = case decodeJSON payment of + Just SPApple {jws} | Just AppleTransactionFacts {autoRenewable} <- appleTransactionFacts jws -> autoRenewable + _ -> False + -- | One attempt to turn a stash into a badge. A refusal is answered rather than thrown, with the -- service's retryAfter. requestBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (Maybe User, ChatResponse)) @@ -5423,7 +5579,7 @@ requestBadgeStash nm user sendTarget stash@BadgeStash {purchaseKey, purchasePriv case J.fromJSON (J.Object respData) of J.Error _ -> throwRedeemError $ BREInvalidResponse "not a badge service response" J.Success BSPError {code, retryAfter} -> pure $ Left (code, retryAfter) - J.Success BSPBadgeCredential {credential = Just cred, statement} -> Right <$> storeRedeemedBadge user stash cred statement + J.Success BSPBadgeCredential {credential = Just cred, statement, subscription} -> Right <$> storeRedeemedBadge user stash cred statement (boundedSubscriptionState <$> subscription) J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type" throwRedeemError :: BadgeRedeemError -> CM a @@ -5437,13 +5593,25 @@ badgeServiceErrorText = textEncode . boundedServiceErrorCode -- on controls, or a sentence the app shows the user as its own. boundedServiceErrorCode :: BadgeServiceErrorCode -> BadgeServiceErrorCode boundedServiceErrorCode = \case - BSEUnknown t -> BSEUnknown $ case T.filter errorCodeChar (T.take 32 t) of - "" -> "unknown" - t' -> t' + BSEUnknown t -> boundedServiceText BSEUnknown errorCodeChar t code -> code where errorCodeChar c = isAsciiLower c || isDigit c || c == '_' +-- | A state this version does not know is stored and shown as the service named it, so it is bounded likewise. +boundedSubscriptionState :: SubscriptionState -> SubscriptionState +boundedSubscriptionState = \case + SSUnknown t -> boundedServiceText SSUnknown stateChar t + state -> state + where + stateChar c = isAsciiLower c || isAsciiUpper c || isDigit c + +-- | Kept only if it reads back as unknown: a text that filters down to a known name would be stored, and read, as that value. +boundedServiceText :: (Eq a, TextEncoding a) => (Text -> a) -> (Char -> Bool) -> Text -> a +boundedServiceText unknown allowed t = case T.filter allowed (T.take 32 t) of + t' | not (T.null t') && textDecode t' == Just (unknown t') -> unknown t' + _ -> unknown "unknown" + -- | The only clock badge code reads, so a test can move the client and the service together. badgeNow :: CM UTCTime badgeNow = asks (badgeCurrentTime . config) >>= liftIO @@ -5453,6 +5621,19 @@ badgeNow = asks (badgeCurrentTime . config) >>= liftIO startBadgeWork :: User -> CM' () startBadgeWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker user +-- | Sent off the shared request moment, so only a build for a dev badge service may send it. +requestBadgeNow :: User -> CM ChatResponse +requestBadgeNow user@User {userId} = do + unlessM (asks $ badgeDevRequests . config) $ throwCmdError "/_badge request is only available in builds for a dev badge service" + withStore' (`getUserBadgePurchase` user) >>= \case + Just p@UserBadgePurchase {shown = True} -> do + badgeNow >>= requestBadgeIssue userId p >>= \case + Right (_, Just SSEnded) -> void $ retireBadge user p + _ -> pure () + lift $ startBadgeWork user + badgeStateResponse user + _ -> throwCmdError "no badge is shown" + -- | Exactly one caller starts the thread and the rest wait for it: the lookup and the create cannot -- be one transaction, because starting a thread is not STM. getBadgeWorker :: User -> CM' BadgeWorker @@ -5536,7 +5717,8 @@ badgeMaxWake = 100 * 365 * nominalDay startStoreReceiptWork :: User -> CM () startStoreReceiptWork User {userId} = do - held <- withStore' $ \db -> getNextHeldStoreReceipt db userId + now <- badgeNow + held <- withStore' $ \db -> getNextHeldStoreReceipt db userId now when (either (const False) isJust held) $ lift $ resumeStoreReceiptWork userId resumeStoreReceiptWork :: UserId -> CM' () @@ -5551,13 +5733,13 @@ 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 = - withStore' (`getNextHeldStoreReceipt` userId) >>= \case - Right (Just r@BadgeReceiptRecord {receiptId, status = RSHeld {nextAttemptAt}}) -> do - now <- badgeNow + getDueReceipt scheduled = do + now <- badgeNow + withStore' (\db -> getNextHeldStoreReceipt db userId now) >>= \case + Right (Just r@BadgeReceiptRecord {receiptId, status = RSHeld {nextAttemptAt}}) -> if nextAttemptAt <= now then pure $ Right (Just r) else Right Nothing <$ scheduleReceipt scheduled receiptId (diffUTCTime nextAttemptAt now) @@ -5575,22 +5757,25 @@ 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) $ - tryAllErrors attempt >>= \case - Right (Right (present_, _)) -> pure $ SROCredited present_ - Right (Left (code, retryAfter)) - | storeReceiptRefused code -> do - let failure = serviceFailure code retryAfter - SRORefused failure <$ withStore' (\db -> refuseStoreReceipt db receiptId failure) - | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter - Left e -> failed ri delay (badgeIssueFailure e) Nothing + -- a Restore takes a held record without this lock, so one it took since it was read is left to its new owner's worker + ifM (not <$> withStore' (\db -> storeReceiptHeldFor db receiptId userId holdKind)) (pure SRODeferred) $ + 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 @@ -5605,12 +5790,104 @@ 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) >>= \answer -> serviceAnswered ri delay refuse (failed ri delay) answer $ \(present_, _) -> pure $ SROCredited present_ + -- retried takes only a service error that is not a refusal: a thrown error is recorded as a failure as it is + serviceAnswered :: RetryInterval -> Int64 -> (BadgeIssueFailure -> CM StoreReceiptOutcome) -> (BadgeIssueFailure -> Maybe Word32 -> CM StoreReceiptOutcome) -> Either ChatError (Either (BadgeServiceErrorCode, Maybe Word32) r) -> (r -> CM StoreReceiptOutcome) -> CM StoreReceiptOutcome + serviceAnswered ri delay refused retried answer answered = case answer of + Left e -> failed ri delay (badgeIssueFailure e) Nothing + Right (Left (code, retryAfter)) + | storeReceiptRefused code -> refused $ serviceFailure code retryAfter + | otherwise -> retried (serviceFailure code retryAfter) retryAfter + Right (Right r) -> answered r + 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 + p_ <- withStore' (`getBadgePurchase` purchaseId) + newest_ <- withStore' (`getUserBadgePurchase` user) + movedOut <- withStore' (`purchaseMovedOut` purchaseId) + now <- badgeNow + let isNewest = maybe False (\UserBadgePurchase {badgePurchaseId} -> badgePurchaseId == purchaseId) newest_ + case p_ of + Just UserBadgePurchase {shown = True} -> SROCredited Nothing <$ withStore' (`settleStoreReceipt` receiptId) + -- the service answers a payment moved to another key ended, so a resume of it never succeeds + _ | movedOut -> setAside + Just p@UserBadgePurchase {purchaseKind = PKSubscription _} + | isNewest, Just hold <- resumeHold now =<< decodeJSON payment -> resumeIssue ri delay user p hold now + _ -> refuse receiptInvalid + resumeIssue ri delay user p@UserBadgePurchase {badgePurchaseId} hold now = do + answer <- tryAllErrors $ requireBadgeService >>= \sendTarget -> sendBadgeIssue sendTarget userId p BSCIssueBadge (recordBadgeIssueFailure p) now + answeredAt <- badgeNow + -- a charge the service does not grant, as a revoked one, stops holding the profile once its hold ends + let notCredited failure retryAfter = case hold of + RHPurchasedAt purchasedAt | resumeHoldEnded answeredAt purchasedAt -> refuse receiptInvalid + RHAttempts -> failedHeld ri delay failure retryAfter + _ -> failed ri delay failure retryAfter + serviceAnswered ri delay refuse notCredited answer $ \(balance, stored) -> + withStore' (`getLatestIssuedCredential` badgePurchaseId) >>= \case + -- the answer told this device of a move elsewhere, which no later attempt undoes + _ | paymentMovedOut balance -> setAside + Just cred@(BadgeCredential _ _ _ info) + | L.paidThrough balance > answeredAt && credentialExpiry cred > answeredAt && stored /= Just SSEnded -> do + user' <- withStore $ \db -> do + liftIO $ showChargedPurchase db user receiptId badgePurchaseId stored + setUserBadge db user (Just $ OwnBadge cred (mkBadgeStatus answeredAt (Just True) info)) + lift $ startBadgeWork user' + pure $ SROCredited (Just user') + -- the service's own check interval + _ -> notCredited BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600) + -- Settles with nothing to announce: a charge expired or no newer than the last one credited, or to a tier that is not + -- higher, the renewal check grants the change, and a badge no longer shown is resumed by the charge's next hand-over. + changeTier ri delay purchaseId = do + user <- withStore $ \db -> getUser db userId + p_ <- withStore' (`getBadgePurchase` purchaseId) + lastChargeAt_ <- withStore' (`getLastChargeCreditAt` purchaseId) + now <- badgeNow + case (p_, decodeJSON payment) of + (Just p@UserBadgePurchase {badgeType, shown = True}, Just payment') + | Just tier <- tierChangeCharge now lastChargeAt_ payment', raisesTier badgeType tier -> upgradeIssue ri delay user p payment' tier now + _ -> setAside + -- 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_ + let refusedInSilence failure = SRODeferred <$ withStore' (\db -> refuseStoreReceipt db receiptId payment failure) + serviceAnswered ri delay refusedInSilence (failedHeld ri delay) answer $ \case + _ | Just failure <- recorded_ -> failedHeld ri delay failure Nothing + (_, stored) -> + withStore' (`getLatestIssuedCredential` badgePurchaseId) >>= \case + Just cred@(BadgeCredential _ _ _ info@BadgeInfo {badgeType = issuedType}) + | issuedType == tier && credentialExpiry cred > answeredAt && stored /= Just SSEnded -> do + user' <- withStore $ \db -> do + liftIO $ showChargedPurchase db user receiptId badgePurchaseId stored + setUserBadge db user (Just $ OwnBadge cred (mkBadgeStatus answeredAt (Just True) info)) + lift $ startBadgeWork user' + pure $ SROCredited (Just user') + _ -> failedHeld ri delay BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600) + -- out of attempts, the record is set aside without a refusal, so the next hand-over holds it again; + -- this attempt's failure is not recorded yet, so it is counted here + failedHeld ri delay failure retryAfter = do + attempts <- withStore' (`getStoreReceiptFailures` receiptId) + if attempts + 1 >= heldChargeAttempts + then setAside + else failed ri delay failure retryAfter + setAside = SRODeferred <$ withStore' (`settleStoreReceipt` receiptId) + receiptInvalid = BIFServiceError {code = BSEReceiptInvalid, retryable = False} + -- a payment adopted while this one was with the service stays held and is sent next, so nothing is announced + refuse failure = do + refused <- withStore' $ \db -> refuseStoreReceipt db receiptId payment failure + pure $ if refused then SRORefused failure else SRODeferred serviceFailure code retryAfter = BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter} failed ri delay failure retryAfter = do now <- badgeNow @@ -5619,7 +5896,7 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa -- a buyer is waiting, so unlike a renewal a failure that can clear on its own never waits the day | badgeFailureTransient failure = (fromIntegral delay / 1000000, SRORetry) | otherwise = (badgeStalledInterval, SRODeferred) - withStore' $ \db -> recordStoreReceiptFailure db receiptId (nextRetryDelay 0 delay ri) (retryIn `addUTCTime` now) failure + withStore' $ \db -> recordStoreReceiptFailure db receiptId payment (nextRetryDelay 0 delay ri) (retryIn `addUTCTime` now) failure pure outcome -- | Retire what has ended, renew what is due, then report the next wake. Waking early, late or not @@ -5629,18 +5906,51 @@ updateUserBadge userId emitted now = do user <- withStore $ \db -> getUser db userId withStore' (`getUserBadgePurchase` user) >>= \case Nothing -> pure Nothing - Just p@UserBadgePurchase {badgePurchaseId} -> + Just p@UserBadgePurchase {badgePurchaseId, purchaseKind, nextWakeAt, unrenewedRun} -> withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= \case Nothing -> pure Nothing Just balance -> do - -- retirement needs no service and an unbounded retry would not return before it - retired <- retireExpiredBadge user p now balance + -- No months come after a prepaid purchase's paidThrough, so it is retired before asking, as + -- retirement needs no service and an unbounded retry would not return before it. A subscription's come + -- from the store, so it is asked about first, and retired once its store says it ended: at once by the service's answer, + -- by the stored state (the device's report) only past paidThrough, as StoreKit can report expired during a billing retry + -- that still recovers; or once the window has passed since the first answer after which nothing was covered. + retiredBefore <- case purchaseKind of + PKPrepaid | L.paidThrough balance <= now -> retireBadge user p + _ -> pure False latest <- withStore' (`getLatestIssuedCredential` badgePurchaseId) - let requestDue = not retired && badgeRequestDue now (shownBadgeCredential user p) latest balance - (balance', serviceAt) <- + devRequestInterval <- asks $ badgeDevRequestInterval . config + let due = not retiredBefore && (isJust devRequestInterval && isJust (shownBadgeCredential user p) || badgeRequestDue now purchaseKind (shownBadgeCredential user p) latest balance) + -- a due month waits for the wake the last pass set, so a request that issued nothing is not repeated at every activation; + -- a wake further than this was not set by such a request, but by a device clock set back since. + -- A dev interval reuses the same guard, as it needs the same thing: no second request within it. + askNoSoonerThan = fromMaybe badgeStalledInterval devRequestInterval + heldUntil = if due then find (\w -> w > now && w <= addUTCTime askNoSoonerThan now) nextWakeAt else Nothing + requestDue = due && isNothing heldUntil + (balance', subscription_) <- if requestDue - then either ((balance,) . Just) (,Nothing) <$> requestBadgeIssue userId p now + then fromRight (balance, Nothing) <$> requestBadgeIssue userId p now else pure (balance, Nothing) + let -- the answers after which nothing was covered, each within a window of the one before: an absence or an outage that + -- long may hide a renewal, so the next such answer starts a new run + unrenewedRun' + | L.paidThrough balance' > now = Nothing + | requestDue = Just $ case unrenewedRun of + Just run@UnrenewedRun {lastUnrenewedAt} | not (windowPassedSince lastUnrenewedAt) -> run {lastUnrenewedAt = now} + _ -> UnrenewedRun {unrenewedSince = now, lastUnrenewedAt = now} + | otherwise = unrenewedRun + windowPassedSince t = subscriptionRecoveryWindow `addUTCTime` t <= now + ended = case purchaseKind of + PKSubscription BadgeSubscription {status} -> case subscription_ of + Just answered -> answered == SSEnded + Nothing -> status == Just SSEnded && L.paidThrough balance' <= now + PKPrepaid -> False + when (unrenewedRun' /= unrenewedRun) $ withStore' $ \db -> setBadgeUnrenewedRun db badgePurchaseId unrenewedRun' + retired <- + -- the window only after an answer: a renewal since the run started is known only from an answer + if ended || requestDue && maybe False (windowPassedSince . unrenewedSince) unrenewedRun' + then retireBadge user p + else pure retiredBefore -- presenting broadcasts the record it is handed, and the request above can block for the -- whole service timeout, so this read belongs after it and not at the top of the pass user' <- withStore $ \db -> getUser db userId @@ -5652,30 +5962,56 @@ updateUserBadge userId emitted now = do -- retiring and presenting both replace the badge on the record read above, so it is read again user'' <- withStore $ \db -> getUser db userId emitBadgeAlert user'' emitted p' (shownBadgeCredential user'' p') now balance' - -- a snooze is the one wake that is not in the ledger: nothing else brings the alert back, - -- since support having ended leaves both ledger boundaries in the past let UserBadgePurchase {issueError = failureBefore} = p - UserBadgePurchase {alertSnoozeUntil, issueError = failureAfter} = p' - snoozeAt = find (> now) alertSnoozeUntil - stalledAt = if requestDue && not issued then Just $ badgeStalledInterval `addUTCTime` now else Nothing - wakeAt = earliestTime [serviceAt, snoozeAt, stalledAt, badgeBoundary now (shownBadgeCredential user'' p') balance'] + UserBadgePurchase {alertSnoozeUntil, issueError = failureAfter, purchaseKind = kindAfter} = p' + -- a snooze is a wake only while no request waits: support having ended leaves no ledger moment ahead, + -- and a waiting request's own wake brings the alert back + snoozeAt = if isJust (stalledAt <|> heldUntil) then Nothing else find (> now) alertSnoozeUntil + stalledAt = if requestDue && not issued then badgeStallUntil now <$> shownBadgeCredential user'' p' else Nothing + reminderAt = case kindAfter of + PKSubscription s -> find (> now) $ renewalReminderAt s balance' + PKPrepaid -> Nothing + devWakeAt = (`addUTCTime` now) <$> devRequestInterval + wakeAt = earliestTime [devWakeAt, snoozeAt, stalledAt, heldUntil, reminderAt, badgeBoundary now (shownBadgeCredential user'' p') balance'] failed = failureAfter /= failureBefore + subscriptionChanged = kindAfter /= purchaseKind + balanceMoved = entryId balance' /= entryId balance -- written before the event, so the state it reports carries the attempt it leads to withStore' $ \db -> setBadgeNextWake db badgePurchaseId wakeAt - when (retired || issued || failed) $ toView . CEvtBadgeChanged user'' =<< getUserBadgeState user'' + when (retired || balanceMoved || failed || subscriptionChanged) $ toView . CEvtBadgeChanged user'' =<< getUserBadgeState user'' pure wakeAt --- | The other kinds need subscriptions, and warning before a prepaid badge ends is not actionable --- while topping up cannot credit months without issuing. +-- | Warning before a prepaid badge ends is not actionable while topping up cannot credit months without issuing. -- TODO [badges] BAPrepaidEnding belongs here, three days before paidThrough, once that exists. derivedBadgeAlert :: UTCTime -> UserBadgePurchase -> Maybe BadgeCredential -> StatementEntry -> Maybe BadgeAlert -derivedBadgeAlert now p shownCred b - | endsAt <= now = Just $ alertOf BASupportEnded endsAt - | otherwise = (\BadgeIssueError {failedSince} -> alertOf BAIssueFailed failedSince) <$> shownIssueError now p shownCred +-- Restore moved its payment to another key, so nothing of this purchase ended, lapsed or failed +derivedBadgeAlert _ _ _ b | paymentMovedOut b = Nothing +derivedBadgeAlert now p@UserBadgePurchase {purchaseKind, shown} shownCred b = case purchaseKind of + PKPrepaid + | endsAt <= now -> Just $ alertOf BASupportEnded endsAt + | otherwise -> issueFailed + PKSubscription s@BadgeSubscription {status} + -- a subscription still shown past paidThrough is waiting for its store to charge, not ended + | endsAt <= now && not shown -> Just $ alertOf BASubscriptionEnded endsAt + | status == Just SSBillingRetry -> Just $ alertOf BAPaymentIssue endsAt + | isJust issueFailed -> issueFailed + | now < endsAt && status == Just SSCancelled -> Just $ alertOf BASubscriptionCancelled endsAt + | now < endsAt && maybe False (<= now) (renewalReminderAt s b) -> Just $ alertOf BARenewalApproaching endsAt + | otherwise -> Nothing where endsAt = L.paidThrough b + issueFailed = (\BadgeIssueError {failedSince} -> alertOf BAIssueFailed failedSince) <$> shownIssueError now p shownCred alertOf kind date = BadgeAlert {kind, episode = safeDecodeUtf8 $ strEncode date, date, price = Nothing} +-- | Only an annual plan is reminded of: with no way to turn reminders off, a monthly one would come every month. +renewalReminderAt :: BadgeSubscription -> StatementEntry -> Maybe UTCTime +renewalReminderAt BadgeSubscription {planMonths, status} b + | planMonths == 12 && status == Just SSRenewing = Just $ negate renewalReminderLead `addUTCTime` L.paidThrough b + | otherwise = Nothing + +renewalReminderLead :: NominalDiffTime +renewalReminderLead = 3 * nominalDay + -- | A failure that can clear on its own is only shown once the credential lapses and contacts see it. shownIssueError :: UTCTime -> UserBadgePurchase -> Maybe BadgeCredential -> Maybe BadgeIssueError shownIssueError now UserBadgePurchase {issueError} shownCred = case issueError of @@ -5703,7 +6039,8 @@ emitBadgeAlert user emitted p@UserBadgePurchase {alertSnoozeUntil} shownCred now badgeStateResponse :: User -> CM ChatResponse badgeStateResponse user = do badgeState <- getUserBadgeState user - CRBadgeState user badgeState . map finalError <$> withStore' (`getOpenStorePurchases` user) + now <- badgeNow + CRBadgeState user badgeState . map finalError <$> withStore' (\db -> getOpenStorePurchases db user now) where -- like a renewal's, only a failure that cannot clear on its own is the user's to know about finalError p@OpenStorePurchase {creditError} = p {creditError = find (not . badgeFailureTransient) creditError} @@ -5717,8 +6054,12 @@ getUserBadgeState user = do Just p@UserBadgePurchase {badgePurchaseId} -> fmap (badgeStateOf now p) <$> withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) where - badgeStateOf now p@UserBadgePurchase {badgePurchaseId, purchaseKey, badgeType, shown, nextWakeAt} balance = + badgeStateOf now p@UserBadgePurchase {badgePurchaseId, purchaseKey, badgeType, shown, nextWakeAt, purchaseKind} balance = let shownCred = shownBadgeCredential user p + subscription = case purchaseKind of + PKSubscription s -> Just s + PKPrepaid -> Nothing + (renewsAt, willRenew) = badgeRenewal (L.paidThrough balance) subscription in BadgeState { badgePurchaseId, purchaseKey, @@ -5726,18 +6067,32 @@ getUserBadgeState user = do shown = BoolDef shown, monthsLeft = balanceMonths balance, paidThrough = L.paidThrough balance, - renewsAt = Nothing, - willRenew = False, + renewsAt, + willRenew, alert = unansweredBadgeAlert now p shownCred balance, issueError = shownIssueError now p shownCred, - nextWakeAt + nextWakeAt, + subscription } --- | How long a month that did not issue waits before it is tried again, whatever stopped it. Not --- derived from the failure, so a misclassified one cannot leave a funded badge to expire. +-- | renewsAt and willRenew predate the subscription's state, and say only whether it was last seen renewing. +badgeRenewal :: UTCTime -> Maybe BadgeSubscription -> (Maybe UTCTime, Bool) +badgeRenewal paidThrough = \case + Just BadgeSubscription {status = Just SSRenewing} -> (Just paidThrough, True) + _ -> (Nothing, False) + +-- | The longest a month that did not issue waits before it is tried again, whatever stopped it: until the next +-- daily moment of the shown expiry, or this long after a thrown error. Not derived from the failure, so a +-- misclassified one cannot leave a funded badge to expire. badgeStalledInterval :: NominalDiffTime badgeStalledInterval = nominalDay +-- | Counted from the first answer after which the ledger covered nothing. Apple retries a failed renewal for up to 60 days, the +-- longest either store recovers one with Play's pause off (its grace and hold default to 60 days together); a week more, the grace +-- contacts give an expired credential, covers Play's period ending days after the ledger's and the daily request that finds a charge. +subscriptionRecoveryWindow :: NominalDiffTime +subscriptionRecoveryWindow = 60 * nominalDay + badgeGraceInterval + -- | The wait after a service refusal, floored at initialInterval so answering 0 cannot spin the -- worker, and uncapped above it. badgeRetryAfter :: RetryInterval -> Maybe Word32 -> NominalDiffTime @@ -5765,10 +6120,14 @@ credentialExpiry (BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) = badgeExpiry -- | Timed off the shown credential, not the period end: renewing around its shared expiry is what -- joins the anonymity set. Latest still equal to shown means this month has not been asked for. -badgeRequestDue :: UTCTime -> Maybe BadgeCredential -> Maybe BadgeCredential -> StatementEntry -> Bool -badgeRequestDue now shownCred latestCred balance = - balanceMonths balance > 0 && latestCred == shownCred && maybe False lapsingSoon shownCred +-- A subscription is asked about at zero months too: its next month comes from a store charge. +badgeRequestDue :: UTCTime -> PurchaseKind -> Maybe BadgeCredential -> Maybe BadgeCredential -> StatementEntry -> Bool +badgeRequestDue now purchaseKind shownCred latestCred balance = + (balanceMonths balance > 0 || subscribed) && latestCred == shownCred && maybe False lapsingSoon shownCred where + subscribed = case purchaseKind of + PKSubscription _ -> True + PKPrepaid -> False lapsingSoon cred = credentialExpiry cred <= badgeRequestLead `addUTCTime` now -- | The request and the presentation, a day apart, both read off the credential the profile shows, @@ -5787,6 +6146,14 @@ badgeBoundary now shownCred balance = case filter (> now) moments of let expiry = credentialExpiry cred in [negate badgeRequestLead `addUTCTime` expiry, expiry] +-- | The first moment after now a whole number of stall intervals from the shown credential's expiry. Every client whose +-- credential shares that expiry asks at these moments, so a request an activation sent late is followed by one among them. +badgeStallUntil :: UTCTime -> BadgeCredential -> UTCTime +badgeStallUntil now cred = (fromInteger (stalls + 1) * badgeStalledInterval) `addUTCTime` expiry + where + expiry = credentialExpiry cred + stalls = floor $ diffUTCTime now expiry / badgeStalledInterval + earliestTime :: [Maybe UTCTime] -> Maybe UTCTime earliestTime ts = case catMaybes ts of [] -> Nothing @@ -5818,64 +6185,78 @@ badgeFailureTransient = \case BIFUnexpected {} -> False -- | Only a failure that can clear on its own is repeated; every other throw is terminal, and --- repeating it would spin. Service errors are classified by retryAfter in requestBadgeIssue. +-- repeating it would spin. Service errors are classified by retryAfter in sendBadgeIssue. badgeErrorRetry :: ChatError -> Bool badgeErrorRetry = badgeFailureTransient . badgeIssueFailure -- | Ask the service for the month that is due and apply the response. A timeout stores no ledger row, --- so the same request is sent again on the next pass. 'Left' is a service error, already reported, and --- carries when to try again, since a service error is answered rather than thrown. Any request that +-- so the same request is sent again on the next pass. 'Left' is a service error, already reported, +-- since a service error is answered rather than thrown. Any request that -- ends without a credential the ledger still owes is recorded on the purchase as a failed renewal; -- nothing else records one. -requestBadgeIssue :: UserId -> UserBadgePurchase -> UTCTime -> CM (Either UTCTime StatementEntry) -requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, badgeType, purchaseKey, purchasePrivKey, masterKey} now = do +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) $ 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}} - } - respData <- - sendServiceRequestTo NRMBackground user sendTarget Nothing (Just purchasePrivKey) req - `catchAllErrors` \e -> recordFailure (badgeIssueFailure e) >> throwError e - case J.fromJSON (J.Object respData) of - J.Success BSPBadgeCredential {credential = sentCred_, statement} -> do - verifiedCred_ <- verifyIssuedCredential masterKey sentCred_ - g <- asks random - -- read again: now was taken before a lock wait and an untimed request, and the check reads - -- it as the client's clock against the timestamps the service put on the rows - storedAt <- badgeNow - (applied, balance_) <- withStore' $ \db -> do - applied <- applyBadgeStatement db g badgePurchaseId badgeType statement verifiedCred_ storedAt - (applied,) <$> getBadgeLedgerLastEntry db badgePurchaseId - -- the statement is applied either way, so a month can be spent with nothing to show for it - case (sentCred_, verifiedCred_, applied) of - (Just _, Nothing, _) -> recordFailure BIFInvalidCredential - (_, _, False) -> recordUnexpected "issued badge credential has no ledger row to store it against" - -- no credential is the service saying the months ran out, which its statement then shows - (Nothing, _, _) | maybe False ((> 0) . balanceMonths) balance_ -> recordUnexpected "badge service issued no credential" - _ -> pure () - maybe (throwCmdError "badge ledger has no balance") (pure . Right) balance_ - J.Success BSPError {code, retryAfter} -> do - eToView $ ChatError $ CECommandError $ "badge service error: " <> T.unpack (badgeServiceErrorText code) - recordFailure BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter} - ri <- asks $ badgeRetryInterval . config - pure $ Left $ badgeRetryAfter ri retryAfter `addUTCTime` now - _ -> do - recordFailure BIFUnexpected {message = unexpectedResponse} - throwCmdError $ T.unpack unexpectedResponse + 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 -> (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 = command BadgeBalance {lastEntry} + } + respData <- + sendServiceRequestTo NRMBackground user sendTarget Nothing (Just purchasePrivKey) req + `catchAllErrors` \e -> recordFailure (badgeIssueFailure e) >> throwError e + case J.fromJSON (J.Object respData) of + J.Success BSPBadgeCredential {credential = sentCred_, statement, subscription} -> do + verifiedCred_ <- verifyIssuedCredential masterKey sentCred_ + g <- asks random + -- read again: now was taken before a lock wait and an untimed request, and the check reads + -- it as the client's clock against the timestamps the service put on the rows + 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 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 + applied <- applyBadgeStatement db g badgePurchaseId badgeType statement verifiedCred_ storedAt + forM_ storedSubscription $ setBadgeSubscriptionStatus db badgePurchaseId + (applied,) <$> getBadgeLedgerLastEntry db badgePurchaseId + -- the statement is applied either way, so a month can be spent with nothing to show for it + case (sentCred_, verifiedCred_, applied) of + (Just _, Nothing, _) -> recordFailure BIFInvalidCredential + (_, _, False) -> recordUnexpected "issued badge credential has no ledger row to store it against" + -- no credential is the service saying nothing is owed - the months ran out, or a subscription + -- waits for its store to charge - which its statement then shows; ended after a move leaves the issued month running + (Nothing, _, _) | subscription /= Just SSEnded && maybe False ((> storedAt) . L.paidThrough) balance_ -> recordUnexpected "badge service issued no credential" + _ -> pure () + maybe (throwCmdError "badge ledger has no balance") (pure . Right . (,storedSubscription)) balance_ + J.Success BSPError {code, retryAfter} -> do + eToView $ ChatError $ CECommandError $ "badge service error: " <> T.unpack (badgeServiceErrorText code) + -- retryAfter only marks the failure as one that can clear: the retry waits a stall like any request that + -- issued nothing, since a shorter wait would let the service choose how often activations reach it + recordFailure BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter} + pure $ Left (code, retryAfter) + _ -> do + recordFailure BIFUnexpected {message = unexpectedResponse} + throwCmdError $ T.unpack unexpectedResponse where unexpectedResponse = "unexpected badge service response" 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. @@ -5900,15 +6281,19 @@ presentIssuedBadge user p@UserBadgePurchase {badgePurchaseId, shown} now presentUserBadgeToContacts user' where shownCred = shownBadgeCredential user p + shownType = (\(BadgeCredential _ _ _ BadgeInfo {badgeType}) -> badgeType) <$> shownCred -- Held back until the shown credential lapses, so the broadcast does not correlate with the -- request that produced it. Nothing shown at all is the state a lost profile write leaves. - presentDue cred = Just cred /= shownCred && maybe True ((<= now) . credentialExpiry) shownCred + -- A raised tier is presented at once, whichever request granted it: the subscriber raised it in + -- the store, so the broadcast tells it nothing new; a lower tier keeps the hold-back. + presentDue cred@(BadgeCredential _ _ _ BadgeInfo {badgeType}) = + Just cred /= shownCred && (maybe False (`raisesTier` badgeType) shownType || maybe True ((<= now) . credentialExpiry) shownCred) --- | The visible half of "the badge expired". -retireExpiredBadge :: User -> UserBadgePurchase -> UTCTime -> StatementEntry -> CM Bool -retireExpiredBadge user UserBadgePurchase {badgePurchaseId, shown} now balance - | not (shown && L.paidThrough balance <= now) = pure False - | otherwise = withUserProfileLock "retireExpiredBadge" $ do +-- | The visible half of "the badge ended". +retireBadge :: User -> UserBadgePurchase -> CM Bool +retireBadge user UserBadgePurchase {badgePurchaseId, shown} + | not shown = pure False + | otherwise = withUserProfileLock "retireBadge" $ do user' <- withStore $ \db -> do liftIO $ clearShownBadge db user badgePurchaseId setUserBadge db user Nothing @@ -5923,11 +6308,11 @@ stopBadgeWorkers workers = cancelBadgeWorker v = void $ forkIO $ atomically (badgeWorkerAsync <$> readTMVar (sessionVar v)) >>= uninterruptibleCancel --- | Verify the credential before writing anything; the purchase, the statement's rows, the --- issuance and the profile's badge go in one transaction. Answers the user to tell contacts about, +-- | Verify the credential before writing anything; the purchase, its subscription's state, the statement's +-- rows, the issuance and the profile's badge go in one transaction. Answers the user to tell contacts about, -- which the caller does once the badge lock is released. -storeRedeemedBadge :: User -> BadgeStash -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse) -storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement = +storeRedeemedBadge :: User -> BadgeStash -> BadgeCredential -> BadgeStatement -> Maybe SubscriptionState -> CM (Maybe User, ChatResponse) +storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement subscription_ = verifyOwnBadge cred >>= \case Nothing -> throwRedeemError BREUnknownKeyIndex Just False -> throwRedeemError BRECredentialNotVerified @@ -5941,6 +6326,7 @@ storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCr -- TODO [badges] retire a previously held badge (user', newBadge, applied) <- withStore $ \db -> do (purchaseId, newBadge) <- liftIO $ createStashBadgePurchase db user stash cred now + when newBadge $ forM_ subscription_ $ liftIO . setBadgeSubscriptionStatus db purchaseId applied <- liftIO $ applyBadgeStatement db g purchaseId badgeType statement (Just cred) now -- a replay must not put a superseded badge back, or tell every contact again user' <- if newBadge then setUserBadge db user (Just badge) else getUser db userId @@ -5960,6 +6346,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) -> @@ -6387,11 +6774,13 @@ 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 (== ' '))) <* 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), "/_badge ledger " *> (APIGetBadgeLedger <$> A.decimal <* A.space <*> A.decimal), "/_badge ack " *> (APIAckBadgeAlert <$> A.decimal <* A.space <*> A.decimal <* A.space <*> badgeAlertKindP <* A.space <*> onOffP <* A.space <*> textP), + "/_badge request " *> (APIRequestBadge <$> A.decimal), "/_service_response " *> (APISendServiceResponse <$> A.decimal <* A.space <*> strP <* A.space <*> jsonP), "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP), "/call " *> char_ '@' *> (SendCallInvitation <$> displayNameP <*> pure defaultCallType), @@ -6818,6 +7207,13 @@ chatCommandP = badgeAlertKindP = do t <- A.takeTill (== ' ') maybe (fail "bad badge alert kind") pure $ textDecode $ safeDecodeUtf8 t + subscriptionStateP = + A.takeTill (== ' ') >>= \case + "renewing" -> pure SSRenewing + "cancelled" -> pure SSCancelled + "billingRetry" -> pure SSBillingRetry + "ended" -> pure SSEnded + _ -> fail "bad subscription state" pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' ')) verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ') msgTextP = jsonP <|> textP diff --git a/src/Simplex/Chat/PaymentService.hs b/src/Simplex/Chat/PaymentService.hs index 91b7a9fde1..f117183356 100644 --- a/src/Simplex/Chat/PaymentService.hs +++ b/src/Simplex/Chat/PaymentService.hs @@ -1,19 +1,29 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Simplex.Chat.PaymentService ( ServiceInvoice (..), ServicePayment (..), - appleTransactionId, + AppleTransactionFacts (..), + applePayload, + appleTransactionRef, + applePayloadRef, + appleTransactionFacts, googlePurchaseRef, module Simplex.Chat.PaymentService.Types, ) where +import Control.Applicative ((<|>)) +import Control.Monad ((<=<)) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as JM import qualified Data.Aeson.TH as JQ +import qualified Data.Aeson.Types as JT import qualified Data.ByteString.Base64.URL as B64U +import Data.Int (Int64) +import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -44,14 +54,53 @@ data ServicePayment deriving (Show) -- | Read without verifying the signature: it names the transaction, and proves nothing about it. -appleTransactionId :: Text -> Maybe Text -appleTransactionId signed = case T.splitOn "." signed of +applePayload :: Text -> Maybe J.Object +applePayload signed = case T.splitOn "." signed of [_, payload, _] -> do J.Object o <- J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload) - J.String txId <- JM.lookup "transactionId" o - pure txId + Just o _ -> Nothing +appleTransactionRef :: Text -> Maybe Text +appleTransactionRef = applePayloadRef <=< applePayload + +-- | What an unverified payload says about its transaction, which decides only which payment a held record +-- 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, + autoRenewable :: Bool + } + deriving (Eq, Show) + +-- | A date or type that does not read is taken as absent rather than failing the whole payload. +appleTransactionFacts :: Text -> Maybe AppleTransactionFacts +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, 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. +applePayloadRef :: J.Object -> Maybe Text +applePayloadRef o = case JM.lookup "type" o of + Just (J.String "Auto-Renewable Subscription") -> field "originalTransactionId" + _ -> field "transactionId" + where + field k = case JM.lookup k o of + Just (J.String t) -> Just t + _ -> Nothing + -- | A purchase token is a bearer secret, so a purchase is named by its hash. googlePurchaseRef :: Text -> Text googlePurchaseRef = safeDecodeUtf8 . strEncode . C.sha256Hash . encodeUtf8 diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 12a914d35f..32978e3647 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -10,23 +10,40 @@ module Simplex.Chat.Store.Badges ( BadgeStash (..), BadgeStashRef (..), UserBadgePurchase (..), + UnrenewedRun (..), + PurchaseKind (..), getUserBadgePurchase, getBadgePurchase, + setBadgeSubscriptionStatus, userHasBadge, setBadgeAlertAcked, setBadgeIssueError, setBadgeNextWake, + setBadgeUnrenewedRun, clearShownBadge, getBadgeCodeRedemption, createBadgeCodeRedemption, BadgeReceiptRecord (..), BadgeReceiptStatus (..), + StoreHoldKind (..), holdStoreReceipt, + holdStoreTransfer, + purchaseUnreached, + purchaseMovedOut, + paymentMovedOut, + getReceiptRecord, createBadgeStoreReceipt, getOpenStorePurchases, + getPendingStoreReceipts, getNextHeldStoreReceipt, + getStoreReceiptFailures, + storeReceiptHeldFor, recordStoreReceiptFailure, refuseStoreReceipt, + clearStoreReceiptRefusal, + settleStoreReceipt, + reholdStoreReceipt, + showChargedPurchase, deleteUnfundedStoreReceipts, deleteBadgeCodeRedemption, createStashBadgePurchase, @@ -34,43 +51,51 @@ module Simplex.Chat.Store.Badges storeBadgeIssuance, getLatestIssuedCredential, storeBadgeStatement, + setBadgePurchaseType, getBadgeLedgerLastEntry, + getLastChargeCreditAt, getBadgeLedger, getBadgeLedgerEntryId, ) where import Control.Concurrent.STM (TVar, atomically) -import Control.Monad (forM, forM_, join) +import Control.Monad (forM, forM_, join, when) import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) +import Data.List (find) import Data.Maybe (isJust, mapMaybe) import Data.Text (Text) -import Data.Time.Clock (UTCTime) +import Data.Time.Clock (UTCTime, addUTCTime, nominalDay) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Simplex.Chat.Badges import Simplex.Chat.Badges.Ledger import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..)) -import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..), OpenStorePurchase (..)) -import Simplex.Chat.PaymentService (ServicePayment) +import Simplex.Chat.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 @@ -118,22 +143,66 @@ data BadgeReceiptRecord = BadgeReceiptRecord } data BadgeReceiptStatus - = RSHeld {stash :: BadgeStash, invoiceId :: Maybe Text, payment :: Text, nextAttemptAt :: UTCTime, retryDelay :: Maybe Int64} - | RSCredited {badgePurchaseId :: Int64} + = 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 -- it, whose keys the service may have credited; failing that it joins the record Buy created; and when no record -- can take it - the store echoed no invoice, or the one it echoed is already held by another transaction - the --- presenting profile gets a new one, nothing else saying who paid. -holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Maybe Text -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO (Maybe BadgeReceiptRecord) -holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now = +-- presenting profile gets a new one, nothing else saying who paid, unless the app found the transaction in the +-- store's list: then it may be another device's, and nothing is recorded. +holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> StoreReceiptOrigin -> Maybe Text -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO (Maybe BadgeReceiptRecord) +holdStoreReceipt db g User {userId} origin invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now = getReceiptRecord db txRef >>= \case - Just r@BadgeReceiptRecord {receiptId} -> do - -- a resolved record stays resolved, so a hand-over landing just after its credit cannot hold it again - DB.execute db "UPDATE badge_store_receipts SET payment = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL" (paymentJSON, receiptId) + Just r@BadgeReceiptRecord {receiptId, status} -> do + -- a resolved record stays resolved here, so a hand-over landing just after its credit cannot hold it again; + -- only a resume re-holds a credited one, which the hand-over decides + case status of + RSHeld {payment = held} + | laterAppleTransaction payment held -> + DB.execute + db + "UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, credit_error = NULL WHERE badge_store_receipt_id = ? AND payment = ?" + (paymentJSON, now, receiptId, held) + _ -> pure () + -- the Buy record the store echoed for this charge is never attached, as the charge continues this record's subscription; + -- this record takes its invoice id, so the credit names the charge the app keeps unfinished + forM_ invoiceId_ $ \invoiceId -> do + deleted <- + maybeFirstRow' False ((== (1 :: Int)) . fromOnly) $ + DB.query + db + [sql| + DELETE FROM badge_store_receipts + WHERE invoice_id = ? AND transaction_ref IS NULL AND payment IS NULL + AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id) + RETURNING 1 + |] + (Only invoiceId) + when deleted $ DB.execute db "UPDATE badge_store_receipts SET invoice_id = ? WHERE badge_store_receipt_id = ?" (invoiceId, receiptId) pure $ Just r Nothing -> do forM_ invoiceId_ $ \invoiceId -> @@ -143,12 +212,17 @@ holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provid (provider, transactionRef, paymentJSON, now, invoiceId) getReceiptRecord db txRef >>= \case Just r -> pure $ Just r - Nothing -> do - insertReceipt - getReceiptRecord db txRef + Nothing -> case origin of + SROPurchased -> do + 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 @@ -159,11 +233,87 @@ holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provid db [sql| INSERT INTO badge_store_receipts - (user_id, invoice_id, provider, transaction_ref, payment, next_attempt_at, purchase_key, purchase_priv_key, master_key, created_at) - VALUES (?,?,?,?,?,?,?,?,?,?) + (user_id, invoice_id, provider, transaction_ref, payment, 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)) + +-- | A hand-over of a transaction already recorded, by Restore or by a resubscription no resume reaches: a subscription +-- record that funds no purchase of this profile, only one its payment moved away from, or one neither shown nor its +-- owner's newest, is taken by this profile and held as a move of its payment to it; a one-time record never moves. +-- 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@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 + movesHere ownerId badgePurchaseId = + getBadgePurchase db badgePurchaseId >>= \case + -- a one-time purchase is never moved, as its months were issued when it was bought + Just UserBadgePurchase {purchaseKind = PKSubscription _} + | ownerId /= userId -> pure True + | otherwise -> (||) <$> purchaseMovedOut db badgePurchaseId <*> purchaseUnreached db user badgePurchaseId + _ -> pure 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) + +-- | A subscription neither shown nor its owner's newest, which no resume reaches. +purchaseUnreached :: DB.Connection -> User -> Int64 -> IO Bool +purchaseUnreached db owner badgePurchaseId = do + p_ <- getBadgePurchase db badgePurchaseId + newestId <- fmap (\UserBadgePurchase {badgePurchaseId = i} -> i) <$> getUserBadgePurchase db owner + pure $ case p_ of + Just UserBadgePurchase {shown = False, purchaseKind = PKSubscription _} -> newestId /= Just badgePurchaseId + _ -> False + +-- | The service answers a purchase whose payment moved away ended, so a resume of it never succeeds. +purchaseMovedOut :: DB.Connection -> Int64 -> IO Bool +purchaseMovedOut db badgePurchaseId = maybe False paymentMovedOut <$> getBadgeLedgerLastEntry db badgePurchaseId + +-- | A ledger tip that moved the purchase's payment to another key. +paymentMovedOut :: StatementEntry -> Bool +paymentMovedOut StatementEntry {entryType} = case entryType of + SEDebit SDTransferOut {} -> True + _ -> False + +-- | 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 +-- re-delivered or re-signed copy of the held transaction changes nothing, so it cannot cost another store check. +laterAppleTransaction :: ServicePayment -> Text -> Bool +laterAppleTransaction payment held = case (payment, decodeJSON held) of + (SPApple {jws}, Just SPApple {jws = heldJws}) -> case (appleTransactionFacts jws, appleTransactionFacts heldJws) of + ( Just AppleTransactionFacts {transactionId, purchaseDate = Just purchasedAt, revoked = False}, + Just AppleTransactionFacts {transactionId = heldId, purchaseDate = Just heldPurchasedAt} + ) -> transactionId /= heldId && purchasedAt > heldPurchasedAt + _ -> False + _ -> False getReceiptRecord :: DB.Connection -> StoreTransactionRef -> IO (Maybe BadgeReceiptRecord) getReceiptRecord db StoreTransactionRef {provider, transactionRef} = @@ -172,19 +322,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) RSCredited 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 () @@ -199,58 +353,149 @@ createBadgeStoreReceipt db g User {userId} invoiceId now = do |] (userId, invoiceId, purchaseKey, purchasePrivKey, Binary mk, now) --- | No receipt yet, or one held: a credited or refused record is resolved and not listed. -getOpenStorePurchases :: DB.Connection -> User -> IO [OpenStorePurchase] -getOpenStorePurchases db User {userId} = - map toOpenStorePurchase +-- | No receipt yet, or one held and not lapsed: a credited or refused record is resolved and not listed. +getOpenStorePurchases :: DB.Connection -> User -> UTCTime -> IO [OpenStorePurchase] +getOpenStorePurchases db User {userId} now = + mapMaybe toOpenStorePurchase <$> DB.query db [sql| - SELECT invoice_id, transaction_ref, credit_error + SELECT payment, invoice_id, transaction_ref, credit_error FROM badge_store_receipts WHERE user_id = ? AND (transaction_ref IS NULL OR payment IS NOT NULL) ORDER BY badge_store_receipt_id |] (Only userId) where - toOpenStorePurchase (invoiceId, transactionRef, creditError) = OpenStorePurchase {invoiceId, transactionRef, creditError} + toOpenStorePurchase (payment_, invoiceId, transactionRef, creditError) + | maybe False (appleChargeLapsed now) payment_ = Nothing + | otherwise = Just OpenStorePurchase {invoiceId, transactionRef, creditError} -getNextHeldStoreReceipt :: DB.Connection -> UserId -> IO (Either StoreError (Maybe BadgeReceiptRecord)) -getNextHeldStoreReceipt db userId = - fmap Right . maybeFirstRow toHeld $ +-- | Each held receipt's payment and its last attempt's failure, if any; a lapsed one is not pending. +getPendingStoreReceipts :: DB.Connection -> User -> UTCTime -> IO [(Text, Maybe BadgeIssueFailure)] +getPendingStoreReceipts db User {userId} now = + filter (not . appleChargeLapsed now . fst) + <$> 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. +-- A lapsed one is not attempted; a later charge handed over re-arms it. +getNextHeldStoreReceipt :: DB.Connection -> UserId -> UTCTime -> IO (Either StoreError (Maybe BadgeReceiptRecord)) +getNextHeldStoreReceipt db userId now = + fmap (Right . fmap toHeld . find (not . lapsed)) $ 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}} + lapsed (_ :. (_, payment, _, _, _)) = appleChargeLapsed now payment -recordStoreReceiptFailure :: DB.Connection -> Int64 -> Int64 -> UTCTime -> BadgeIssueFailure -> IO () -recordStoreReceiptFailure db receiptId retryDelay nextAttemptAt failure = +-- | A held Apple subscription charge whose paid period ended more than a day ago, as one refunded before it was credited: +-- it neither blocks a new badge nor shows as open nor is attempted, and its record stays, as a later charge under its original id continues it. +appleChargeLapsed :: UTCTime -> Text -> Bool +appleChargeLapsed now payment = case decodeJSON payment of + Just SPApple {jws} + | Just AppleTransactionFacts {expiresDate = Just expires, autoRenewable = True} <- appleTransactionFacts jws -> + nominalDay `addUTCTime` posixSecondsToUTCTime (fromIntegral expires / 1000) <= now + _ -> False + +storeReceiptHeldFor :: DB.Connection -> Int64 -> UserId -> StoreHoldKind -> IO Bool +storeReceiptHeldFor db receiptId userId holdKind = + maybeFirstRow' False ((== (1 :: Int)) . fromOnly) $ + DB.query db "SELECT 1 FROM badge_store_receipts WHERE badge_store_receipt_id = ? AND user_id = ? AND hold_kind = ? AND payment IS NOT NULL" (receiptId, userId, holdKind) + +-- | The attempts that failed since the record was last held: each hold resets the count. +getStoreReceiptFailures :: DB.Connection -> Int64 -> IO Int64 +getStoreReceiptFailures db receiptId = + maybeFirstRow' 0 fromOnly $ DB.query db "SELECT retry_count FROM badge_store_receipts WHERE badge_store_receipt_id = ?" (Only receiptId) + +-- | 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 () +recordStoreReceiptFailure db receiptId payment retryDelay nextAttemptAt failure = DB.execute db [sql| UPDATE badge_store_receipts SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ? - WHERE badge_store_receipt_id = ? AND payment IS NOT NULL + WHERE badge_store_receipt_id = ? AND payment = ? |] - (retryDelay, nextAttemptAt, failure, receiptId) + (retryDelay, nextAttemptAt, failure, receiptId, payment) -- | Kept rather than deleted, so that a later hand-over of the same transaction is answered from the record. -refuseStoreReceipt :: DB.Connection -> Int64 -> BadgeIssueFailure -> IO () -refuseStoreReceipt db receiptId refusal = +-- A refused move returns the record to the profile whose purchase it still funds. +-- Only while the record still holds the payment refused, which is when it answers True: one adopted meanwhile is due at once. +refuseStoreReceipt :: DB.Connection -> Int64 -> Text -> BadgeIssueFailure -> IO Bool +refuseStoreReceipt db receiptId payment refusal = + maybeFirstRow' False ((== (1 :: Int)) . fromOnly) $ + DB.query + db + [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 = ? AND payment = ? + RETURNING 1 + |] + (refusal, SHKPurchase, receiptId, receiptId, payment) + +-- | Only while the record is resolved: one held meanwhile keeps its hold. +clearStoreReceiptRefusal :: DB.Connection -> Int64 -> IO () +clearStoreReceiptRefusal db receiptId = + DB.execute db "UPDATE badge_store_receipts SET credit_error = NULL WHERE badge_store_receipt_id = ? AND payment IS NULL" (Only receiptId) + +-- | Every settle clears the failure, so one recorded on a credited record is a refused resume or tier change. +-- It returns the record to the profile whose purchase it funds, which a Restore may have taken it from meanwhile. +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 = ? 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 = NULL, 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 = ? + |] + (SHKPurchase, receiptId, receiptId) + +-- | Whether a later charge of a credited record's subscription is answered as held: its purchase must be its owner's newest +-- and a subscription. A tier change, of a shown purchase, is held whatever else is held, as the worker serves it while the +-- badge is shown. A resume, of a purchase not shown, is held only while no other receipt of the owner is held, which the +-- worker would credit first; until then the app keeps the charge unfinished and hands it over again. No other kind is held. +reholdStoreReceipt :: DB.Connection -> User -> Int64 -> Int64 -> StoreHoldKind -> ServicePayment -> UTCTime -> IO Bool +reholdStoreReceipt db owner receiptId badgePurchaseId holdKind payment now = do + newest_ <- getUserBadgePurchase db owner + case newest_ of + Just UserBadgePurchase {badgePurchaseId = newestId, shown, purchaseKind = PKSubscription _} + | newestId == badgePurchaseId -> case holdKind of + SHKTierChange | shown -> True <$ hold + SHKPurchase | not shown -> do + pending <- getPendingStoreReceipts db owner now + True <$ when (null pending) hold + _ -> pure False + _ -> pure False + where + hold = + DB.execute + db + "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) + +-- | A resume's or a tier change's credit: shows the purchase, again if a retire cleared it meanwhile, and keeps only the +-- state the answer stored, since the charge disproves an ended or a billing retry stored before. +showChargedPurchase :: DB.Connection -> User -> Int64 -> Int64 -> Maybe SubscriptionState -> IO () +showChargedPurchase db User {userId} receiptId badgePurchaseId state = do + settleStoreReceipt db receiptId + DB.execute db "UPDATE badge_purchases SET subscription_status = ? WHERE badge_purchase_id = ?" (state, badgePurchaseId) + DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (badgePurchaseId, userId) -- | A held record is paid for and a credited one is referenced by its purchase, so neither is deleted. deleteUnfundedStoreReceipts :: DB.Connection -> UTCTime -> IO () @@ -285,9 +530,13 @@ 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 - -- the credit settles a held receipt in the transaction that stores its purchase, a replay included - forM_ storeReceiptId_ $ \storeReceiptId -> DB.execute db "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0 WHERE badge_store_receipt_id = ?" (Only storeReceiptId) - getStashBadgePurchase db stash >>= \case + -- 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) + purchase <- getStashBadgePurchase db stash >>= \case Just purchaseId -> pure (purchaseId, False) Nothing -> do DB.execute @@ -302,6 +551,10 @@ createStashBadgePurchase db User {userId} stash credential now = do purchaseId <- insertedRowId db DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (purchaseId, userId) pure (purchaseId, True) + -- the credit settles a held receipt in the transaction that stores its purchase, a replay included, + -- once the purchase links it, so the record goes to the profile that purchase is of + forM_ storeReceiptId_ $ settleStoreReceipt db + pure purchase where BadgeStash {stashRef, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = stash BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential @@ -343,7 +596,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) @@ -390,9 +643,19 @@ data UserBadgePurchase = UserBadgePurchase alertAcked :: Maybe (BadgeAlertKind, Text), alertSnoozeUntil :: Maybe UTCTime, issueError :: Maybe BadgeIssueError, - nextWakeAt :: Maybe UTCTime + nextWakeAt :: Maybe UTCTime, + unrenewedRun :: Maybe UnrenewedRun, + purchaseKind :: PurchaseKind } +data UnrenewedRun = UnrenewedRun {unrenewedSince :: UTCTime, lastUnrenewedAt :: UTCTime} + deriving (Eq) + +-- | A subscription's months come from store charges, so reaching paidThrough does not end it: the +-- service says when it has. Derived from the replica, which holds a charge credit exactly for a subscription. +data PurchaseKind = PKPrepaid | PKSubscription BadgeSubscription + deriving (Eq) + -- | Newest, not the one shown_badge_id points at - retirement clears that, and the support ended -- alert is recomputed from this purchase after the badge stops being shown. getUserBadgePurchase :: DB.Connection -> User -> IO (Maybe UserBadgePurchase) @@ -420,14 +683,20 @@ getBadgePurchase db purchaseId = SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type, (CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END), p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until, - p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at + p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at, + (SELECT l.change_months FROM badge_ledger l + WHERE l.badge_purchase_id = p.badge_purchase_id AND l.entry_type = 'credit' AND l.entry_credit_type = 'charge' + ORDER BY l.entry_id DESC + LIMIT 1), + p.subscription_status, p.unrenewed_since, p.last_unrenewed_at, r.transaction_ref FROM badge_purchases p JOIN users u ON u.user_id = p.user_id + LEFT JOIN badge_store_receipts r ON r.badge_store_receipt_id = p.badge_store_receipt_id WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL |] (Only purchaseId) where - toPurchase ((badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) :. (failedSince_, lastAttemptAt_, reason_, nextWakeAt)) = + toPurchase ((badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) :. (failedSince_, lastAttemptAt_, reason_, nextWakeAt, planMonths_, status, since_, lastAt_, transactionRef)) = UserBadgePurchase { badgePurchaseId, purchaseKey, @@ -438,9 +707,15 @@ getBadgePurchase db purchaseId = alertAcked = (,) <$> ackedKind_ <*> ackedEpisode_, alertSnoozeUntil, issueError = BadgeIssueError <$> failedSince_ <*> lastAttemptAt_ <*> reason_, - nextWakeAt + nextWakeAt, + unrenewedRun = UnrenewedRun <$> since_ <*> lastAt_, + purchaseKind = maybe PKPrepaid (\planMonths -> PKSubscription BadgeSubscription {planMonths, status, transactionRef}) planMonths_ } +setBadgeSubscriptionStatus :: DB.Connection -> Int64 -> SubscriptionState -> IO () +setBadgeSubscriptionStatus db badgePurchaseId state = + DB.execute db "UPDATE badge_purchases SET subscription_status = ? WHERE badge_purchase_id = ?" (state, badgePurchaseId) + -- | Whether a badge is on the profile now: set when a redemption stores one, cleared when it is -- retired. Read as the id rather than as a comparison, which in Postgres would be a boolean. userHasBadge :: DB.Connection -> User -> IO Bool @@ -478,6 +753,13 @@ setBadgeNextWake :: DB.Connection -> Int64 -> Maybe UTCTime -> IO () setBadgeNextWake db badgePurchaseId at_ = DB.execute db "UPDATE badge_purchases SET next_wake_at = ? WHERE badge_purchase_id = ?" (at_, badgePurchaseId) +setBadgeUnrenewedRun :: DB.Connection -> Int64 -> Maybe UnrenewedRun -> IO () +setBadgeUnrenewedRun db badgePurchaseId run_ = + DB.execute + db + "UPDATE badge_purchases SET unrenewed_since = ?, last_unrenewed_at = ? WHERE badge_purchase_id = ?" + (unrenewedSince <$> run_, lastUnrenewedAt <$> run_, badgePurchaseId) + -- | Stop showing a badge that has expired unrenewed; the profile update is broadcast by the caller. clearShownBadge :: DB.Connection -> User -> Int64 -> IO () clearShownBadge db User {userId} badgePurchaseId = @@ -516,6 +798,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 = @@ -532,6 +818,20 @@ getBadgeLedgerLastEntry db badgePurchaseId = |] (Only badgePurchaseId) +-- | When the service wrote the purchase's last charge credit, which it dates no earlier than the charge's period start. +getLastChargeCreditAt :: DB.Connection -> Int64 -> IO (Maybe UTCTime) +getLastChargeCreditAt db badgePurchaseId = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT service_created_at FROM badge_ledger + WHERE badge_purchase_id = ? AND entry_type = 'credit' AND entry_credit_type = 'charge' + ORDER BY entry_id DESC + LIMIT 1 + |] + (Only badgePurchaseId) + -- | Oldest first. A row whose type this version cannot rebuild is left out, as it is from the tip. getBadgeLedger :: DB.Connection -> User -> Int64 -> IO [StatementEntry] getBadgeLedger db User {userId} badgePurchaseId = @@ -551,7 +851,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 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.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index 28d1ecbf53..2f54080a29 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -58,6 +58,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20261010_invite_member_via_group import Simplex.Chat.Store.Postgres.Migrations.M20261012_delivery_job_notification import Simplex.Chat.Store.Postgres.Migrations.M20261016_badge_store_receipts import Simplex.Chat.Store.Postgres.Migrations.M20261019_chat_layout +import Simplex.Chat.Store.Postgres.Migrations.M20261021_badge_subscriptions import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -115,7 +116,8 @@ schemaMigrations = ("20261010_invite_member_via_group", m20261010_invite_member_via_group, Just down_m20261010_invite_member_via_group), ("20261012_delivery_job_notification", m20261012_delivery_job_notification, Just down_m20261012_delivery_job_notification), ("20261016_badge_store_receipts", m20261016_badge_store_receipts, Just down_m20261016_badge_store_receipts), - ("20261019_chat_layout", m20261019_chat_layout, Just down_m20261019_chat_layout) + ("20261019_chat_layout", m20261019_chat_layout, Just down_m20261019_chat_layout), + ("20261021_badge_subscriptions", m20261021_badge_subscriptions, Just down_m20261021_badge_subscriptions) ] -- | The list of migrations in ascending order by date 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 20fc4fa99d..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,19 +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, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet. - -CREATE TABLE @subscription_charges( - charge_id TEXT NOT NULL PRIMARY KEY, - payment_id TEXT NOT NULL REFERENCES @payments ON DELETE CASCADE, - provider_charge_ref TEXT NOT NULL, - period_start TIMESTAMPTZ NOT NULL, - period_end TIMESTAMPTZ NOT NULL, - amount BIGINT NOT NULL, - currency TEXT NOT NULL, - charged_at TIMESTAMPTZ NOT NULL, - UNIQUE(payment_id, provider_charge_ref) -); +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, @@ -197,32 +185,13 @@ 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 charge_id TEXT REFERENCES @subscription_charges; - -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_charge ON @badge_ledger(charge_id); - -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_charge; -DROP INDEX @idx_badge_ledger_from_purchase; -DROP INDEX @idx_badge_ledger_to_purchase; -ALTER TABLE @badge_ledger DROP COLUMN charge_id; -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; DROP INDEX @idx_badge_invoices_offer; DROP INDEX @idx_badge_invoices_price; DROP TABLE @badge_invoices; -DROP TABLE @subscription_charges; -} m20260915_user_badges :: Text diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20261021_badge_subscriptions.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20261021_badge_subscriptions.hs new file mode 100644 index 0000000000..53fb345327 --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20261021_badge_subscriptions.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20261021_badge_subscriptions where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20261021_badge_subscriptions :: Text +m20261021_badge_subscriptions = + [r| +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_m20261021_badge_subscriptions :: Text +down_m20261021_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; + +ALTER TABLE badge_purchases DROP COLUMN unrenewed_since; + +ALTER TABLE badge_purchases DROP COLUMN subscription_status; +|] diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql index 1e68bb6206..b410ba4ca9 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql @@ -280,7 +280,10 @@ CREATE TABLE test_chat_schema.badge_purchases ( issue_error_at timestamp with time zone, issue_error text, next_wake_at timestamp with time zone, - badge_store_receipt_id bigint + badge_store_receipt_id bigint, + subscription_status text, + unrenewed_since timestamp with time zone, + last_unrenewed_at timestamp with time zone ); @@ -310,7 +313,8 @@ CREATE TABLE test_chat_schema.badge_store_receipts ( next_attempt_at timestamp with time zone, retry_delay bigint, retry_count bigint DEFAULT 0 NOT NULL, - credit_error text + credit_error text, + hold_kind text DEFAULT 'purchase'::text NOT NULL ); diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 061e572151..fcb74edbdf 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.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index 2b5a29633d..832cb8b862 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -182,6 +182,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20261012_delivery_job_notification import Simplex.Chat.Store.SQLite.Migrations.M20261016_badge_store_receipts import Simplex.Chat.Store.SQLite.Migrations.M20261018_autoincrement_ids import Simplex.Chat.Store.SQLite.Migrations.M20261019_chat_layout +import Simplex.Chat.Store.SQLite.Migrations.M20261021_badge_subscriptions import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -363,7 +364,8 @@ schemaMigrations = ("20261012_delivery_job_notification", m20261012_delivery_job_notification, Just down_m20261012_delivery_job_notification), ("20261016_badge_store_receipts", m20261016_badge_store_receipts, Just down_m20261016_badge_store_receipts), ("20261018_autoincrement_ids", m20261018_autoincrement_ids, Just down_m20261018_autoincrement_ids), - ("20261019_chat_layout", m20261019_chat_layout, Just down_m20261019_chat_layout) + ("20261019_chat_layout", m20261019_chat_layout, Just down_m20261019_chat_layout), + ("20261021_badge_subscriptions", m20261021_badge_subscriptions, Just down_m20261021_badge_subscriptions) ] -- | The list of migrations in ascending order by date 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 8646d8b29e..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,19 +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, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet. - -CREATE TABLE @subscription_charges( - charge_id TEXT NOT NULL PRIMARY KEY, - payment_id TEXT NOT NULL REFERENCES @payments ON DELETE CASCADE, - provider_charge_ref TEXT NOT NULL, - period_start TEXT NOT NULL, - period_end TEXT NOT NULL, - amount INTEGER NOT NULL, - currency TEXT NOT NULL, - charged_at TEXT NOT NULL, - UNIQUE(payment_id, provider_charge_ref) -) STRICT; +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, @@ -198,32 +186,13 @@ 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 charge_id TEXT REFERENCES @subscription_charges; - -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_charge ON @badge_ledger(charge_id); - -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_charge; -DROP INDEX @idx_badge_ledger_from_purchase; -DROP INDEX @idx_badge_ledger_to_purchase; -ALTER TABLE @badge_ledger DROP COLUMN charge_id; -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; DROP INDEX @idx_badge_invoices_offer; DROP INDEX @idx_badge_invoices_price; DROP TABLE @badge_invoices; -DROP TABLE @subscription_charges; -} m20260915_user_badges :: Query diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20261021_badge_subscriptions.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20261021_badge_subscriptions.hs new file mode 100644 index 0000000000..bef0ea356b --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20261021_badge_subscriptions.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20261021_badge_subscriptions where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20261021_badge_subscriptions :: Query +m20261021_badge_subscriptions = + [sql| +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_m20261021_badge_subscriptions :: Query +down_m20261021_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; + +ALTER TABLE badge_purchases DROP COLUMN unrenewed_since; + +ALTER TABLE badge_purchases DROP COLUMN subscription_status; +|] 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 fcfb9b9a64..1da3b2af85 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -78,6 +78,18 @@ Query: Plan: SEARCH groups USING INTEGER PRIMARY KEY (rowid=?) +Query: + DELETE FROM badge_store_receipts + WHERE invoice_id = ? AND transaction_ref IS NULL AND payment IS NULL + AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id) + RETURNING 1 + +Plan: +SEARCH badge_store_receipts USING INDEX sqlite_autoindex_badge_store_receipts_1 (invoice_id=?) +CORRELATED SCALAR SUBQUERY 1 +SEARCH p USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) +SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) + Query: INSERT INTO group_members ( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by, invited_by_group_member_id, @@ -1262,8 +1274,8 @@ Plan: Query: 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 Plan: @@ -3830,12 +3842,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 @@ -4087,15 +4098,6 @@ Query: Plan: SCAN group_members -Query: - SELECT invoice_id, transaction_ref, credit_error - FROM badge_store_receipts - WHERE user_id = ? AND (transaction_ref IS NULL OR payment IS NOT NULL) - ORDER BY badge_store_receipt_id - -Plan: -SEARCH badge_store_receipts USING INDEX idx_badge_store_receipts_user (user_id=?) - Query: SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type, l.was_paused_since, l.service_created_at, l.entry_type, l.entry_credit_type, l.entry_debit_type, l.entry_type_value @@ -4125,14 +4127,32 @@ Query: SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type, (CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END), p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until, - p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at + p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at, + (SELECT l.change_months FROM badge_ledger l + WHERE l.badge_purchase_id = p.badge_purchase_id AND l.entry_type = 'credit' AND l.entry_credit_type = 'charge' + ORDER BY l.entry_id DESC + LIMIT 1), + p.subscription_status, p.unrenewed_since, p.last_unrenewed_at, r.transaction_ref FROM badge_purchases p JOIN users u ON u.user_id = p.user_id + LEFT JOIN badge_store_receipts r ON r.badge_store_receipt_id = p.badge_store_receipt_id WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL Plan: SEARCH p USING INTEGER PRIMARY KEY (rowid=?) SEARCH u USING INTEGER PRIMARY KEY (rowid=?) +SEARCH r USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN +CORRELATED SCALAR SUBQUERY 1 +SEARCH l USING INDEX idx_badge_ledger_purchase (badge_purchase_id=?) + +Query: + SELECT payment, invoice_id, transaction_ref, credit_error + FROM badge_store_receipts + WHERE user_id = ? AND (transaction_ref IS NULL OR payment IS NOT NULL) + ORDER BY badge_store_receipt_id + +Plan: +SEARCH badge_store_receipts USING INDEX idx_badge_store_receipts_user (user_id=?) Query: SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures @@ -4155,21 +4175,23 @@ Plan: SEARCH file_badge_proofs USING INDEX idx_file_badge_proofs_file_id_kind (file_id=?) Query: - 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 Plan: SEARCH u USING INTEGER PRIMARY KEY (rowid=?) SEARCH r USING INDEX idx_badge_store_receipts_user (user_id=?) +SEARCH p USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) LEFT-JOIN USE TEMP B-TREE FOR ORDER BY Query: 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 = ? @@ -4283,6 +4305,15 @@ SEARCH c USING INTEGER PRIMARY KEY (rowid=?) SEARCH cs USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN +Query: + SELECT service_created_at FROM badge_ledger + WHERE badge_purchase_id = ? AND entry_type = 'credit' AND entry_credit_type = 'charge' + ORDER BY entry_id DESC + LIMIT 1 + +Plan: +SEARCH badge_ledger USING INDEX idx_badge_ledger_purchase (badge_purchase_id=?) + Query: SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled, role_storage, role_proxy, role_names @@ -4324,6 +4355,18 @@ Query: Plan: SEARCH user_contact_links USING INTEGER PRIMARY KEY (rowid=?) +Query: + 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 = ? AND payment = ? + RETURNING 1 + +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) +SCALAR SUBQUERY 1 +SEARCH p USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) + Query: UPDATE chat_items SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ? @@ -5272,11 +5315,36 @@ SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?) Query: UPDATE badge_store_receipts - SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ? - WHERE badge_store_receipt_id = ? AND payment IS NOT NULL + SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL, 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 = ? Plan: SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) +SCALAR SUBQUERY 1 +SEARCH p USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) + +Query: + UPDATE badge_store_receipts + SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ? + WHERE badge_store_receipt_id = ? AND payment = ? + +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + +Query: + 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 != ?) + +Plan: +SEARCH badge_store_receipts USING COVERING INDEX idx_badge_store_receipts_user (user_id=?) +CORRELATED SCALAR SUBQUERY 2 +SEARCH p USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) +CORRELATED SCALAR SUBQUERY 1 +SEARCH p USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) Query: UPDATE chat_items @@ -7461,10 +7529,18 @@ Plan: Query: INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?) Plan: +Query: SELECT 1 FROM badge_store_receipts WHERE badge_store_receipt_id = ? AND user_id = ? AND hold_kind = ? AND payment IS NOT NULL +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + Query: SELECT 1 FROM settings WHERE user_id = ? LIMIT 1 Plan: SEARCH settings USING COVERING INDEX idx_settings_user_id (user_id=?) +Query: SELECT COUNT(*) FROM badge_code_redemptions +Plan: +SCAN badge_code_redemptions USING COVERING INDEX idx_badge_code_redemptions_user + Query: SELECT COUNT(*) FROM badge_store_receipts Plan: SCAN badge_store_receipts USING COVERING INDEX idx_badge_store_receipts_user @@ -7584,10 +7660,31 @@ Query: SELECT badge_purchase_id FROM badge_purchases WHERE badge_store_receipt_i Plan: SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) +Query: SELECT badge_purchase_id, entry_id, period_end FROM badge_issuances ORDER BY entry_id +Plan: +SCAN badge_issuances USING INDEX idx_badge_issuances_entry + +Query: SELECT badge_store_receipt_id FROM badge_store_receipts +Plan: +SCAN badge_store_receipts USING COVERING INDEX idx_badge_store_receipts_user + Query: SELECT badge_store_receipt_id FROM badge_store_receipts WHERE invoice_id = ? Plan: SEARCH badge_store_receipts USING COVERING INDEX sqlite_autoindex_badge_store_receipts_1 (invoice_id=?) +Query: SELECT badge_store_receipt_id, badge_purchase_id FROM badge_purchases +Plan: +SCAN badge_purchases USING COVERING INDEX idx_badge_purchases_store_receipt + +Query: SELECT badge_type FROM badge_issuances ORDER BY period_end +Plan: +SCAN badge_issuances +USE TEMP B-TREE FOR ORDER BY + +Query: SELECT badge_type FROM contact_profiles WHERE badge_proof IS NOT NULL ORDER BY contact_profile_id +Plan: +SCAN contact_profiles + Query: SELECT balance_checked FROM badge_ledger ORDER BY entry_id Plan: SCAN badge_ledger @@ -7685,6 +7782,10 @@ Query: SELECT contact_id FROM contacts WHERE user_id = ? AND (chat_item_ttl > 0 Plan: SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?) +Query: SELECT contact_id FROM contacts WHERE user_id = ? AND (chat_item_ttl > 0) +Plan: +SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?) + Query: SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0 Plan: SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?) @@ -7733,10 +7834,26 @@ Query: SELECT count(1) FROM pending_group_messages Plan: SCAN pending_group_messages USING COVERING INDEX idx_pending_group_messages_group_member_id +Query: SELECT credential FROM badge_issuances WHERE entry_id = ? +Plan: +SEARCH badge_issuances USING INDEX idx_badge_issuances_entry (entry_id=?) + +Query: SELECT credit_error FROM badge_store_receipts WHERE badge_store_receipt_id = ? +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + +Query: SELECT credit_error FROM badge_store_receipts WHERE credit_error IS NOT NULL +Plan: +SCAN badge_store_receipts + Query: SELECT credit_error FROM badge_store_receipts WHERE payment IS NOT NULL AND credit_error IS NOT NULL Plan: SCAN badge_store_receipts +Query: SELECT current_badge_type FROM badge_purchases ORDER BY badge_purchase_id +Plan: +SCAN badge_purchases + Query: SELECT entry_id FROM badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ? Plan: SEARCH badge_ledger USING INDEX idx_badge_ledger_uuid (entry_uuid=?) @@ -7787,6 +7904,10 @@ Query: SELECT group_id FROM groups WHERE user_id = ? AND (chat_item_ttl > 0 OR c Plan: SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?) +Query: SELECT group_id FROM groups WHERE user_id = ? AND (chat_item_ttl > 0) +Plan: +SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?) + Query: SELECT group_id FROM groups WHERE user_id = ? AND creating_in_progress = 1 AND created_at <= ? Plan: SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?) @@ -7827,6 +7948,10 @@ Query: SELECT index_in_group, member_relations_vector FROM group_members WHERE l Plan: SCAN group_members +Query: SELECT issue_error_at FROM badge_purchases +Plan: +SCAN badge_purchases + Query: SELECT issue_failed_since, issue_error FROM badge_purchases Plan: SCAN badge_purchases @@ -7915,6 +8040,210 @@ Query: SELECT member_xcontact_id, member_welcome_shared_msg_id FROM group_member Plan: SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?) +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '32316A574B414A435165634A50792F53' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '34777371515341626273746F6A725531' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '364C745457626A726943454F5139666D' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '365431694F536951395477767543584B' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '392F42343435485A4D6C4A4A42784179' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '417A30336574747049655266542B536C' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '433045507738554A4F7579523533326F' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '44797166387A61574D33377351566A70' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '47416E6C397937475639655A4F6A4872' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '47662F48747469674A782F4B6C485865' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '486F6247596E317158426C6857656B58' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4B474E46695541693956467863556162' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4B66326D76554F74434C3653464A6934' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4B6A54346C556543442B70736A657343' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4C41445631472B445858565442547459' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4C424D4D41583853784C6A6769634C7A' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4E3530694B50794D6C6A386764364D36' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4F682F542F664E73554974746A646457' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4F6B396E4E486B7A4E7A2F505461306D' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4F6C47567330784972386E4B72496661' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '51504E3266467468397A5A6A555A5A59' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '516E6B70364443765466557A74576F51' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '52346F3844796156594651305A6E6A4E' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '525038584D53442F6863586C54706D70' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '52567950695555535955742B7A6B432B' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '53526370717345687454376566784A52' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '55455056465233397446394D36417837' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '55566967354649644E5644704E4E4578' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '562B3130557347544E67734559524C35' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '57344B6B584E514C4B30727A6A56394B' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '57625336465661464B567538756A6C56' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '57786C587171347577326B6E4B343430' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '58326263487A776B576F5A322B452F56' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '584F5873316B49463861366249744146' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '614C4637486D4C3141774D42754E6958' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '6164576959516B7051312F635174612F' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '62454B4B3074475654356464626C4331' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '684D6135384C78366B2B435771687870' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '68565070767234594F4F4F3777783743' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '6976634F5868363358575167476C5731' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '6D72486D5153563130647836586A784A' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '6F512B70507A763170634B2F77414D45' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '7138444F774A364F492B6D4B56712F53' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '71684C516E6E423172626C595546536D' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '72395A612F30424B732B41375061344D' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '7351307538344376486B4A79664E687A' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '7435356241497658594F334A42374767' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '75413371367563467650575265516A6A' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '79326A546878645A336346444D506B56' +Plan: +SCAN messages + +Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '794D423855453661496754424746484F' +Plan: +SCAN messages + +Query: SELECT next_wake_at FROM badge_purchases +Plan: +SCAN badge_purchases + Query: SELECT next_wake_at, badge_purchase_id FROM badge_purchases Plan: SCAN badge_purchases @@ -7936,6 +8265,14 @@ Plan: SCAN m SEARCH p USING INTEGER PRIMARY KEY (rowid=?) +Query: SELECT payment, credit_error FROM badge_store_receipts WHERE user_id = ? AND payment IS NOT NULL +Plan: +SEARCH badge_store_receipts USING INDEX idx_badge_store_receipts_user (user_id=?) + +Query: SELECT payment, next_attempt_at FROM badge_store_receipts WHERE payment IS NOT NULL +Plan: +SCAN badge_store_receipts + Query: SELECT purchase_key FROM badge_code_redemptions Plan: SCAN badge_code_redemptions @@ -7960,6 +8297,14 @@ Query: SELECT relay_status FROM group_relays WHERE group_relay_id = ? Plan: SEARCH group_relays USING INTEGER PRIMARY KEY (rowid=?) +Query: SELECT retry_count FROM badge_store_receipts +Plan: +SCAN badge_store_receipts + +Query: SELECT retry_count FROM badge_store_receipts WHERE badge_store_receipt_id = ? +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + Query: SELECT roster_blob FROM groups WHERE roster_blob IS NOT NULL Plan: SCAN groups @@ -8020,10 +8365,18 @@ Query: SELECT stored_roster_version FROM groups WHERE group_id = ? Plan: SEARCH groups USING INTEGER PRIMARY KEY (rowid=?) +Query: SELECT subscription_status FROM badge_purchases +Plan: +SCAN badge_purchases + Query: SELECT summary_current_members_count FROM groups WHERE group_id = ? Plan: SEARCH groups USING INTEGER PRIMARY KEY (rowid=?) +Query: SELECT unrenewed_since, last_unrenewed_at FROM badge_purchases +Plan: +SCAN badge_purchases + Query: SELECT user_contact_link_id FROM contact_requests WHERE contact_request_id = ? Plan: SEARCH contact_requests USING INTEGER PRIMARY KEY (rowid=?) @@ -8036,10 +8389,22 @@ Query: SELECT user_id FROM users WHERE local_display_name = ? Plan: SEARCH users USING COVERING INDEX sqlite_autoindex_users_2 (local_display_name=?) +Query: SELECT user_id, badge_store_receipt_id IS NOT NULL FROM badge_purchases ORDER BY badge_purchase_id +Plan: +SCAN badge_purchases + +Query: SELECT user_id, hold_kind FROM badge_store_receipts ORDER BY badge_store_receipt_id +Plan: +SCAN badge_store_receipts + Query: SELECT user_id, invoice_id, transaction_ref IS NOT NULL FROM badge_store_receipts ORDER BY badge_store_receipt_id Plan: SCAN badge_store_receipts +Query: SELECT user_id, shown_badge_id FROM users ORDER BY user_id +Plan: +SCAN users + Query: SELECT via_contact_uri, pres_header FROM connections WHERE connection_id = ? Plan: SEARCH connections USING INTEGER PRIMARY KEY (rowid=?) @@ -8052,31 +8417,57 @@ Query: SELECT xgrplinkmem_received FROM group_members WHERE group_member_id = ? Plan: SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?) +Query: UPDATE badge_issuances SET period_end = ? WHERE entry_id = ? +Plan: +SEARCH badge_issuances USING INDEX idx_badge_issuances_entry (entry_id=?) + Query: UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ? AND user_id = ? Plan: SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?) +Query: 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 = ?) +Plan: +SEARCH badge_purchases USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) +SCALAR SUBQUERY 1 +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + +Query: UPDATE badge_purchases SET current_badge_type = ?, updated_at = ? WHERE badge_purchase_id = ? +Plan: +SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?) + Query: UPDATE badge_purchases SET issue_failed_since = NULL, issue_error_at = NULL, issue_error = NULL WHERE badge_purchase_id = ? Plan: SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?) +Query: UPDATE badge_purchases SET next_wake_at = ? +Plan: +SCAN badge_purchases + Query: UPDATE badge_purchases SET next_wake_at = ? WHERE badge_purchase_id = ? Plan: SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?) +Query: UPDATE badge_purchases SET subscription_status = ? WHERE badge_purchase_id = ? +Plan: +SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?) + +Query: UPDATE badge_purchases SET unrenewed_since = ?, last_unrenewed_at = ? WHERE badge_purchase_id = ? +Plan: +SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?) + +Query: UPDATE badge_store_receipts SET credit_error = NULL WHERE badge_store_receipt_id = ? AND payment IS NULL +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + Query: UPDATE badge_store_receipts SET payment = ? Plan: SCAN badge_store_receipts -Query: UPDATE badge_store_receipts SET payment = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL +Query: UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, credit_error = NULL WHERE badge_store_receipt_id = ? AND payment = ? Plan: SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) -Query: UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0 WHERE badge_store_receipt_id = ? -Plan: -SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) - -Query: UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ? WHERE badge_store_receipt_id = ? +Query: 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 Plan: SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) @@ -8084,6 +8475,18 @@ Query: UPDATE badge_store_receipts SET provider = ?, transaction_ref = ?, paymen Plan: SEARCH badge_store_receipts USING INDEX sqlite_autoindex_badge_store_receipts_1 (invoice_id=?) +Query: UPDATE badge_store_receipts SET purchase_key = ?, purchase_priv_key = ?, master_key = ? WHERE badge_store_receipt_id = ? AND payment IS NULL +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + +Query: 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 = ? +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + +Query: 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 +Plan: +SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?) + Query: UPDATE chat_items SET item_content = ?, item_text = ?, updated_at = ? WHERE chat_item_id = ? Plan: SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?) diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index a11e986558..a17d7d7b38 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -946,6 +946,9 @@ CREATE TABLE badge_purchases( issue_error TEXT, next_wake_at TEXT, badge_store_receipt_id INTEGER REFERENCES badge_store_receipts, + subscription_status TEXT, + unrenewed_since TEXT, + last_unrenewed_at TEXT, UNIQUE(purchase_key) ) STRICT; CREATE TABLE badge_ledger( @@ -1015,6 +1018,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/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 81bebe7dfe..415faf1201 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -46,7 +46,7 @@ import Simplex.Chat.Markdown import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus) import Simplex.Chat.Badges.Ledger (creditTypeTag, debitTypeTag) import Simplex.Chat.Badges.Service (StatementEntry (..), StatementEntryType (..)) -import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..), OpenStorePurchase (..)) +import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..), BadgeSubscription (..), OpenStorePurchase (..)) import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Messages.CIContent import Simplex.Chat.Operators @@ -194,6 +194,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te -- the badge is only shown when it is the one now on the profile; a replayed code's badge may not be CRBadgeRedeemed u badge newBadge _ -> ttyUser u $ if newBadge then "badge redeemed" : viewContactBadge (Just badge) else ["badge already redeemed"] CRBadgeInvoice u invoiceId -> ttyUser u ["badge invoice: " <> plain invoiceId] + CRStoreReceiptNotRecorded u -> ttyUser u ["store purchase not recorded"] CRBadgeState u st storePurchases -> ttyUser u $ viewUserBadgeState st <> map viewOpenStorePurchase storePurchases CRBadgeLedger u entries -> ttyUser u $ viewBadgeLedger entries CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView @@ -1847,7 +1848,7 @@ viewContactBadge = maybe [] $ \lb -> viewUserBadgeState :: Maybe BadgeState -> [StyledString] viewUserBadgeState = maybe [] viewBadge where - viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert, issueError, nextWakeAt} = + viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert, issueError, nextWakeAt, subscription} = plain ( tshow badgePurchaseId <> ": " @@ -1856,10 +1857,12 @@ viewUserBadgeState = maybe [] viewBadge <> tshow monthsLeft <> " months left, paid through " <> day paidThrough + <> maybe "" viewSubscription subscription <> maybe "" ((", next check " <>) . dayTime) nextWakeAt ) : maybe [] viewBadgeIssueError issueError <> maybe [] viewBadgeAlert alert + viewSubscription BadgeSubscription {status} = ", subscription" <> maybe "" ((" " <>) . textEncode) status viewBadgeIssueError :: BadgeIssueError -> [StyledString] viewBadgeIssueError BadgeIssueError {failedSince, lastAttemptAt, reason} = @@ -2892,6 +2895,7 @@ viewChatError isCmd logLevel testView = \case BREInvalidReceipt -> "invalid store receipt" BREServiceNotConfigured -> "badge service not configured" BREBadgeActive -> "badge already active" + BREStorePurchaseOpen -> "store purchase open" BREServiceError code -> "badge service error: " <> T.unpack (badgeServiceErrorText code) BREInvalidResponse m -> "invalid service response: " <> m BREUnknownKeyIndex -> "credential names an unknown badge key index" diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index 45899ac26f..dd652372e1 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -9,15 +9,16 @@ module BadgeTests (badgeTests) where -import BadgeService.Service (badgeErrorRetryAfter, shownServiceRequest, survive) -import BadgeService.StoreReceipts (StoreReceipt (..), StoreRefusal (..), StoreVerifier (..), VerifiedStoreTransaction (..), toStoreReceipt) -import BadgeService.StoreReceipts.Mock (mockStoreVerifier) +import BadgeService.Service (NotGranted (..), badgeErrorRetryAfter, grantableCharge, shownServiceRequest, survive) +import BadgeService.StoreReceipts (StoreCharge (..), StoreChecks (..), StoreReceipt (..), StoreRefusal (..), StoreVerifier (..), SubscriptionCheck (..), VerifiedStoreTransaction (..), toStoreReceipt) +import BadgeService.StoreReceipts.Mock (newMockStoreVerifier) import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM (atomically) import Control.Exception (SomeAsyncException, SomeException, catch, fromException, throwIO) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Lazy as LB import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Text as T @@ -34,12 +35,15 @@ import Simplex.Chat.Badges import Simplex.Chat.Badges.Code import Simplex.Chat.Badges.Ledger import Simplex.Chat.Badges.Service -import Simplex.Chat.Badges.Types (BadgeIssueFailure (..)) +import Simplex.Chat.Badges.Types (BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeSubscription (..)) +import qualified Simplex.Chat.Badges.Types as BT import Simplex.Chat (defaultChatConfig) import Simplex.Chat.Controller (BadgeRedeemError (..), ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent) -import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, storeTransactionRef) -import Simplex.Chat.PaymentService (ServicePayment (..)) +import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRenewal, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, boundedSubscriptionState, derivedBadgeAlert, resumableCharge, resumeHoldEnded, storeTransactionRef) +import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts, appleTransactionRef) import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..), StoreTransactionRef (..)) +import qualified Simplex.Chat.Store.Badges as SB +import Simplex.Chat.Types (BoolDef (..)) import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay) import Simplex.Messaging.Crypto.BBS @@ -91,6 +95,9 @@ badgeTests = do it "leaves an entry ahead of the clock unjudged, and rejects one behind the entry it follows" testChecksTimestamps 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 @@ -105,10 +112,18 @@ badgeTests = do it "redeemBadgeCode request matches the schema" testRedeemRequestJSON it "purchaseBadge request matches the schema" testPurchaseRequestJSON it "badgeCredential response matches the schema" testCredentialResponseJSON + it "badgeCredential carries a subscription's state, and reads one it does not know as unknown" testCredentialSubscriptionJSON it "error response matches the schema" testErrorResponseJSON it "statement entries round-trip, unknown entry types verbatim" testStatementJSON + describe "badge state" $ do + it "carries a subscription's plan and last seen state, renewing only when it was seen renewing, and bounds a state it does not know" testBadgeSubscriptionJSON + it "derives one alert for a subscription in order of urgency, dated paidThrough, leaves prepaid alerts as they were, and derives none for a purchase Restore moved away" testSubscriptionAlertDerivation describe "store purchases" $ do it "keys a purchase by the store's transaction id, not by the evidence signed over it" testStoreTransactionRef + it "claims an Apple subscription by its original transaction id, and any other transaction by its own" testAppleTransactionRef + it "reads an Apple transaction's id, purchase and expiry dates, revocation and type from its unverified payload" testAppleTransactionFacts + it "resumes a retired subscription only with an Apple charge whose paid period runs, dated less than a day ahead" testResumableCharge + it "refuses a store charge once its period has ended, as a sandbox's five-minute one does" testChargePeriodOver it "shows a service request in the terminal as its type alone" testShownServiceRequest it "refuses for good a Play product id that could name another purchase, before any verifier" testGoogleProductIdPath it "does not send a Play token that could name another purchase, and leaves it retryable" testGoogleTokenPath @@ -357,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 "" @@ -662,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, @@ -683,6 +700,176 @@ testChecksUncheckedInvariants = do verdicts start (Just issued) [owing] `shouldBe` [Just False] 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 :: 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 badgeType months ownKey "ch1" ("", "", "", "") tip + +rowKind :: StatementEntry -> T.Text +rowKind StatementEntry {entryType} = case entryType of + SECredit c -> creditTypeTag c + SEDebit d -> debitTypeTag d + +rowAt :: StatementEntry -> UTCTime +rowAt StatementEntry {createdAt} = createdAt + +bAnchor :: StatementEntry -> UTCTime +bAnchor StatementEntry {balanceAnchorTs} = balanceAnchorTs + +-- the client checks a statement from the first row the service wrote, as a new purchase receives it +allVerify :: HasCallStack => [StatementEntry] -> Expectation +allVerify rows = verdicts (rowAt $ last rows) Nothing rows `shouldBe` map (const $ Just True) rows + +-- A grant dated to the store's period start is checked by re-running it at that start, after rows +-- written earlier and before the lapses and issue written at the request: each path a subscription +-- 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 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"] + allVerify firstCharge + -- 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 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 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 ownKey (addUTCTime offset $ bStart afterFirst) (days 4 $ bStart afterFirst) BTSupporter 1 afterFirst + map rowKind rows `shouldBe` ["charge", "badge"] + allVerify (firstCharge <> rows) + ) + [-60, 60] + -- 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 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 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 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 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 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 () @@ -742,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. @@ -816,17 +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 + -- 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) (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"))) - uncurry3 (entryTypeFromColumns (Just Nothing)) (entryTypeColumns storeCredit) `shouldSatisfy` sameEntryType storeCredit - uncurry3 (entryTypeFromColumns (Just (Just (InvoiceId "inv1")))) (entryTypeColumns invoiceCredit) `shouldSatisfy` sameEntryType invoiceCredit - -- a type that needs a reference column is not silently read back as something else - uncurry3 (entryTypeFromColumns Nothing) (entryTypeColumns storeCredit) `shouldSatisfy` isNothing - uncurry3 (entryTypeFromColumns Nothing) (entryTypeColumns (SECredit (SCCharge "ch1"))) `shouldSatisfy` isNothing + chargeCredit = SECredit (SCCharge "ch1") + 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 @@ -897,6 +1098,82 @@ testStoreTransactionRef = do google `shouldBe` storeTransactionRef SPGoogle {productId = "badge_supporter_01", token = "play-token"} storeTransactionRef SPInvoice {invoiceId = InvoiceId "inv"} `shouldBe` Nothing +-- every renewal of a subscription is a new transaction with a new id, and must still find the purchase its first charge made +testAppleTransactionRef :: IO () +testAppleTransactionRef = do + let jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"] + part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8 + ids = ["transactionId" J..= ("2000000900000002" :: T.Text), "originalTransactionId" J..= ("2000000900000001" :: T.Text)] + ofType t = ("type" J..= (t :: T.Text)) : ids + appleTransactionRef (jws $ ofType "Auto-Renewable Subscription") `shouldBe` Just "2000000900000001" + appleTransactionRef (jws $ ofType "Consumable") `shouldBe` Just "2000000900000002" + appleTransactionRef (jws ids) `shouldBe` Just "2000000900000002" + -- a subscription is never claimed by its own transaction id, which the next renewal would not share + appleTransactionRef (jws $ take 2 (ofType "Auto-Renewable Subscription")) `shouldBe` Nothing + +testAppleTransactionFacts :: IO () +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", 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 + appleTransactionFacts (jws $ ("revocationDate" J..= J.Null) : renewal) `shouldBe` facts Nothing False True + appleTransactionFacts (jws $ ("revocationDate" J..= (1770000000000 :: Int)) : renewal) `shouldBe` facts Nothing True True + -- a date that does not read is absent, and leaves the rest of the payload readable + appleTransactionFacts (jws $ ("purchaseDate" J..= ("yesterday" :: T.Text)) : renewal) `shouldBe` facts Nothing False True + appleTransactionFacts (jws $ take 1 renewal <> ["type" J..= ("Consumable" :: T.Text)]) `shouldBe` facts Nothing False False + appleTransactionFacts (jws $ drop 1 renewal) `shouldBe` Nothing + appleTransactionFacts "not.a-jws" `shouldBe` Nothing + +testResumableCharge :: IO () +testResumableCharge = do + let nowSeconds = 1770000000 :: Integer + now = posixSecondsToUTCTime $ fromInteger nowSeconds + secondsAhead s = addUTCTime (fromInteger s) now + epochMs s = (nowSeconds + s) * 1000 + oneDay = 86400 + oneMonth = 30 * oneDay + jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"] + part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8 + ofType t fields = SPApple {jws = jws $ ["transactionId" J..= ("2000000900000002" :: T.Text), "type" J..= (t :: T.Text)] <> fields} + renewalWith = ofType "Auto-Renewable Subscription" + dated bought expires = renewalWith ["purchaseDate" J..= epochMs bought, "expiresDate" J..= epochMs expires] + resumableCharge now (dated 0 oneMonth) `shouldBe` Just now + resumableCharge now (dated 60 oneMonth) `shouldBe` Just (secondsAhead 60) + resumableCharge now (dated (oneDay - 1) oneMonth) `shouldBe` Just (secondsAhead (oneDay - 1)) + -- dated as far ahead as the allowed skew or further, as a forged payload can be + resumableCharge now (dated oneDay oneMonth) `shouldBe` Nothing + resumableCharge now (dated (365 * oneDay) (400 * oneDay)) `shouldBe` Nothing + -- the paid period it bought has ended + resumableCharge now (dated (-oneMonth) 1) `shouldBe` Just (secondsAhead (-oneMonth)) + resumableCharge now (dated (-oneMonth) 0) `shouldBe` Nothing + resumableCharge now (renewalWith ["purchaseDate" J..= epochMs 0, "expiresDate" J..= epochMs oneMonth, "revocationDate" J..= epochMs 0]) `shouldBe` Nothing + resumableCharge now (ofType "Non-Renewing Subscription" ["purchaseDate" J..= epochMs 0, "expiresDate" J..= epochMs oneMonth]) `shouldBe` Nothing + resumableCharge now (renewalWith ["expiresDate" J..= epochMs oneMonth]) `shouldBe` Nothing + resumableCharge now (renewalWith ["purchaseDate" J..= epochMs 0]) `shouldBe` Nothing + resumableCharge now SPGoogle {productId = "subscr_badge_supporter_01", token = "fake-play-token"} `shouldBe` Nothing + resumeHoldEnded (secondsAhead oneDay) now `shouldBe` True + resumeHoldEnded (secondsAhead (oneDay - 1)) now `shouldBe` False + +testChargePeriodOver :: IO () +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 t SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = False, latestCharge = Just charge} + periodOver = \case + Left NGPeriodOver -> True + _ -> False + either (const Nothing) (Just . snd) (grantAt $ addUTCTime 240 startsAt) `shouldBe` Just (BTSupporter, 1) + grantAt endsAt `shouldSatisfy` periodOver + grantAt (addUTCTime 60 endsAt) `shouldSatisfy` periodOver + testShownServiceRequest :: IO () testShownServiceRequest = do drg <- C.newRandom @@ -908,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 @@ -927,13 +1205,14 @@ testGoogleTokenPath = do mapM_ (\t -> unsent t `shouldBe` True) ["a/b", "../x", "t?x", "t#x", "t x", ""] uncalledVerifier :: StoreVerifier -uncalledVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Just $ \_ _ -> error "verifier called", acknowledgeGoogle = Nothing, verifyTimeout = 500000} +uncalledVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Just $ \_ _ -> error "verifier called", acknowledgeGoogle = Nothing, acknowledgeGoogleSubscription = Nothing, checkSubscription = Nothing, verifyTimeout = 500000, storeChecks = ChecksAfterCoverage, creditTestPurchases = False} validPlayToken :: T.Text validPlayToken = "fake-play-token.AO-J1Oz9x2kqE7wYt3" testMockVouchesForClaim :: IO () testMockVouchesForClaim = do + mockStoreVerifier <- newMockStoreVerifier getCurrentTime let part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8 signed = T.intercalate "." [part "{\"alg\":\"ES256\"}", part "{\"transactionId\":\"2000000812345671\",\"productId\":\"BADGE_SUPPORTER_01\"}", "c2lnbmVk"] vouchesForClaim payment = case toStoreReceipt mockStoreVerifier payment of @@ -965,7 +1244,7 @@ testCredentialResponseJSON = do mk <- generateMasterKey drg let info = BadgeInfo {badgeType = BTSupporter, badgeExpiry = futureTime, badgeExtra = ""} Right cred <- issueBadge testKeyIdx sk (VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = info}) - let resp = BSPBadgeCredential {credential = Just cred, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}} + let resp = BSPBadgeCredential {credential = Just cred, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}, subscription = Nothing} J.toJSON resp `shouldBe` J.object [ "type" J..= ("badgeCredential" :: T.Text), @@ -974,6 +1253,116 @@ testCredentialResponseJSON = do ] roundTrips resp +testCredentialSubscriptionJSON :: IO () +testCredentialSubscriptionJSON = do + let states = [(SSRenewing, "renewing"), (SSCancelled, "cancelled"), (SSBillingRetry, "billingRetry"), (SSEnded, "ended")] + mapM_ (\(s, t) -> (J.toJSON s, J.fromJSON (J.String t)) `shouldBe` (J.String t, J.Success s)) states + let response subscription_ = J.object $ ["type" J..= ("badgeCredential" :: T.Text), "statement" J..= J.object ["entries" J..= ([] :: [J.Value])]] <> maybe [] (\s -> ["subscription" J..= (s :: T.Text)]) subscription_ + subscriptionOf v = case J.fromJSON v of + J.Success BSPBadgeCredential {subscription} -> Right subscription + J.Success _ -> Left "not a badgeCredential" + J.Error e -> Left e + subscriptionOf (response Nothing) `shouldBe` Right Nothing + subscriptionOf (response (Just "billingRetry")) `shouldBe` Right (Just SSBillingRetry) + -- a state added by a newer service does not fail the response, and is not read as ended + subscriptionOf (response (Just "paused")) `shouldBe` Right (Just (SSUnknown "paused")) + J.toJSON (SSUnknown "paused") `shouldBe` J.String "paused" + let resp = BSPBadgeCredential {credential = Nothing, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}, subscription = Just SSRenewing} + J.toJSON resp `shouldBe` response (Just "renewing") + roundTrips resp + +testBadgeSubscriptionJSON :: IO () +testBadgeSubscriptionJSON = do + drg <- C.newRandom + (k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519) + let badgeState subscription = + BT.BadgeState {badgePurchaseId = 1, purchaseKey = k, badgeType = BTSupporter, shown = BoolDef True, monthsLeft = 0, paidThrough = futureTime, renewsAt = Nothing, willRenew = False, alert = Nothing, issueError = Nothing, nextWakeAt = Nothing, subscription} + subscriptionField v = case J.toJSON v of + J.Object o -> KM.lookup "subscription" o + _ -> Nothing + subscriptionField (badgeState Nothing) `shouldBe` Nothing + subscriptionField (badgeState $ Just BadgeSubscription {planMonths = 12, status = Just SSCancelled, transactionRef = Nothing}) + `shouldBe` Just (J.object ["planMonths" J..= (12 :: Int), "status" J..= ("cancelled" :: T.Text)]) + -- not yet observed: the field is left out rather than sent as null + subscriptionField (badgeState $ Just BadgeSubscription {planMonths = 1, status = Nothing, transactionRef = Nothing}) + `shouldBe` Just (J.object ["planMonths" J..= (1 :: Int)]) + let withRef = BadgeSubscription {planMonths = 1, status = Just SSRenewing, transactionRef = Just "2000000812345680"} + subscriptionField (badgeState $ Just withRef) + `shouldBe` Just (J.object ["planMonths" J..= (1 :: Int), "status" J..= ("renewing" :: T.Text), "transactionRef" J..= ("2000000812345680" :: T.Text)]) + J.fromJSON (J.toJSON withRef) `shouldBe` J.Success withRef + -- as an older core sends it + J.fromJSON (J.object ["planMonths" J..= (1 :: Int)]) `shouldBe` J.Success BadgeSubscription {planMonths = 1, status = Nothing, transactionRef = Nothing} + let renewal status = badgeRenewal futureTime $ Just BadgeSubscription {planMonths = 1, status, transactionRef = Nothing} + renewal (Just SSRenewing) `shouldBe` (Just futureTime, True) + mapM_ (\s -> renewal s `shouldBe` (Nothing, False)) [Nothing, Just SSCancelled, Just SSBillingRetry, Just SSEnded, Just (SSUnknown "renewing soon")] + badgeRenewal futureTime Nothing `shouldBe` (Nothing, False) + boundedSubscriptionState SSBillingRetry `shouldBe` SSBillingRetry + boundedSubscriptionState (SSUnknown "onHold") `shouldBe` SSUnknown "onHold" + boundedSubscriptionState (SSUnknown "Visit evil.example.com!\ESC[2J") `shouldBe` SSUnknown "Visitevilexamplecom2J" + boundedSubscriptionState (SSUnknown (T.replicate 100 "a")) `shouldBe` SSUnknown (T.replicate 32 "a") + boundedSubscriptionState (SSUnknown "") `shouldBe` SSUnknown "unknown" + +testSubscriptionAlertDerivation :: IO () +testSubscriptionAlertDerivation = do + drg <- C.newRandom + (k, pk) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519) + mk <- generateMasterKey drg + let start = at 2026 3 10 + ends = addMonths 1 start + balance = grant start 1 (newBalance start) + failedAt = at 2026 3 20 + failure = BadgeIssueError {failedSince = failedAt, lastAttemptAt = failedAt, reason = BIFServiceError {code = BSEUnknownPurchaseKey, retryable = False}} + early = addUTCTime (-10 * nominalDay) ends + soon = addUTCTime (-nominalDay) ends + past = addUTCTime nominalDay ends + subscription months st = SB.PKSubscription BadgeSubscription {planMonths = months, status = st, transactionRef = Nothing} + alertOf = alertAfter balance + alertAfter tip t kind' isShown err = + let p = SB.UserBadgePurchase {badgePurchaseId = 1, purchaseKey = k, purchasePrivKey = pk, masterKey = mk, badgeType = BTSupporter, shown = isShown, alertAcked = Nothing, alertSnoozeUntil = Nothing, issueError = err, nextWakeAt = Nothing, unrenewedRun = Nothing, purchaseKind = kind'} + in (\BT.BadgeAlert {kind, date} -> (kind, date)) <$> derivedBadgeAlert t p Nothing tip + renewing = Just SSRenewing + cancelled = Just SSCancelled + billingRetry = Just SSBillingRetry + mapM_ + (\(t, kind', isShown, err, expected) -> alertOf t kind' isShown err `shouldBe` expected) + [ -- retired at or after paidThrough, whatever else holds + (past, subscription 1 renewing, False, Nothing, Just (BASubscriptionEnded, ends)), + (past, subscription 12 billingRetry, False, Just failure, Just (BASubscriptionEnded, ends)), + (past, subscription 1 cancelled, False, Nothing, Just (BASubscriptionEnded, ends)), + -- still shown past paidThrough: waiting for the store to charge + (past, subscription 1 renewing, True, Nothing, Nothing), + (past, subscription 12 Nothing, True, Nothing, Nothing), + (past, subscription 1 cancelled, True, Nothing, Nothing), + -- billing retry before and after paidThrough, over a renewal failure + (early, subscription 12 billingRetry, True, Nothing, Just (BAPaymentIssue, ends)), + (past, subscription 1 billingRetry, True, Just failure, Just (BAPaymentIssue, ends)), + -- a renewal failure over a cancellation and a reminder + (soon, subscription 1 cancelled, True, Just failure, Just (BAIssueFailed, failedAt)), + (soon, subscription 12 renewing, True, Just failure, Just (BAIssueFailed, failedAt)), + (early, subscription 1 cancelled, True, Nothing, Just (BASubscriptionCancelled, ends)), + (soon, subscription 12 cancelled, True, Nothing, Just (BASubscriptionCancelled, ends)), + -- reminded only for a renewing annual plan, and only in the last three days + (soon, subscription 12 renewing, True, Nothing, Just (BARenewalApproaching, ends)), + (early, subscription 12 renewing, True, Nothing, Nothing), + (soon, subscription 1 renewing, True, Nothing, Nothing), + (soon, subscription 12 Nothing, True, Nothing, Nothing), + (soon, subscription 12 (Just $ SSUnknown "paused"), True, Nothing, Nothing), + (soon, subscription 1 (Just SSEnded), True, Nothing, Nothing), + -- prepaid, as before + (past, SB.PKPrepaid, True, Nothing, Just (BASupportEnded, ends)), + (past, SB.PKPrepaid, False, Just failure, Just (BASupportEnded, ends)), + (soon, SB.PKPrepaid, True, Just failure, Just (BAIssueFailed, failedAt)), + (soon, SB.PKPrepaid, True, Nothing, Nothing) + ] + -- the reminder starts exactly three days before paidThrough + alertOf (addUTCTime (-3 * nominalDay) ends) (subscription 12 renewing) True Nothing `shouldBe` Just (BARenewalApproaching, ends) + alertOf (addUTCTime (-3 * nominalDay - 1) ends) (subscription 12 renewing) True Nothing `shouldBe` Nothing + -- a purchase whose payment Restore moved to another key derives none of them + let movedOut = debitEntry past "" (SDTransferOut k) balance + mapM_ + (\kind' -> alertAfter movedOut past kind' False (Just failure) `shouldBe` Nothing) + [subscription 1 renewing, subscription 12 billingRetry, subscription 1 cancelled, SB.PKPrepaid] + testErrorResponseJSON :: IO () testErrorResponseJSON = do let resp = BSPError {code = BSECodeInvalid, message = Nothing, retryAfter = Nothing} diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index dcc53d30b2..a3602cbc03 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -12,15 +12,20 @@ module Bots.BadgeService.BotTests where import BadgeService.Codes (issueOneCode) -import BadgeService.Config (BadgeIssuerKey (..), readServiceConfig) +import BadgeService.Config (AppleStoreConfig (..), BadgeIssuerKey (..), PlayStoreConfig (..), ServiceConfig (..), readServiceConfig) import BadgeService.Group (GroupEvent) +import BadgeService.StoreReceipts.Apple (appleSubscriptionChecker, verifyAppleTransaction) import Bots.BadgeService.ConfigTests (withIssuer) +import Bots.BadgeService.FakeAppStore (FakeAppStore (..), withFakeAppStore) +import Bots.BadgeService.FakePlay (FakePlay (..), PlayAnswer (..), answerPurchase, withFakePlay) import Bots.BadgeService.FakeStore +import Bots.BadgeService.StoreVerifierTests (TestChain (..), basePlan, lineItem, ourBundleId, purchaseRecord, signedBy, subscriptionPayload, subscriptionRecord, transactionPayload, trustedChain) import BadgeService.Options import BadgeService.Service import BadgeService.Store (IssuedCode (..), getBadgeCode) -import BadgeService.Store.Invoices (markCodePaid) -import BadgeService.StoreReceipts (StoreRefusal (..), StoreVerifier (..), noStoreVerifier) +import BadgeService.Store.Invoices (markCodePaid, truncateToSecond) +import BadgeService.StoreReceipts (StoreCharge (..), StoreChecks (..), StoreRefusal (..), StoreVerifier (..), SubscriptionCheck (..), SubscriptionRef (..), checkStoreSubscription, noStoreVerifier) +import BadgeService.StoreReceipts.Mock (newMockStoreVerifier) import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import ChatClient @@ -28,8 +33,9 @@ import ChatTests.DBUtils import ChatTests.Utils import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay) import Control.Concurrent.Async (async, cancel) -import Control.Concurrent.STM (TQueue, atomically, readTMVar, readTQueue) -import Control.Monad (forM_, void, when) +import Control.Concurrent.STM (TQueue, atomically, readTMVar, readTQueue, readTVarIO) +import Control.Monad (forM, forM_, replicateM, void, when) +import Control.Monad.Except (runExceptT) import Control.Exception (finally) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) @@ -39,29 +45,36 @@ import Data.Char (toLower) import Data.Either (isLeft, isRight) import Data.Int (Int64) import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) -import Data.List (isPrefixOf, stripPrefix) +import Data.List (isInfixOf, isPrefixOf, stripPrefix) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M import Data.Maybe (isJust, isNothing) import Data.String (fromString) import System.Timeout (timeout) import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDay) +import Data.Time.Calendar (addDays, fromGregorian, toGregorian) +import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay) +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 (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType (..), badgeGraceInterval, 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 qualified Simplex.Chat.Badges.Ledger as L import Simplex.Chat.Badges.Service import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) +import qualified Simplex.Chat.Badges.Types as BT import Simplex.Chat.Bot.Store (withDB') -import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError (..), ChatErrorType (..), ChatResponse (CRCustomChatResponse)) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError (..), ChatErrorType (..), ChatResponse (CRBadgeState, CRCustomChatResponse)) import Simplex.Chat.Core (sendChatCmdStr) +import Simplex.Chat.Library.Commands (heldChargeAttempts, resumeHoldLimit, subscriptionRecoveryWindow) import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Options.DB -import Simplex.Chat.PaymentService (ServicePayment (..)) -import Simplex.Chat.PaymentService.Types (InvoiceId (..)) -import Simplex.Chat.Store.Badges (getNextHeldStoreReceipt) +import Simplex.Chat.PaymentService (ServicePayment (..), googlePurchaseRef) +import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (PPGoogle), StoreTransactionRef (StoreTransactionRef)) +import Simplex.Chat.Store.Badges (StoreHoldKind (..), clearShownBadge, getLatestIssuedCredential, getNextHeldStoreReceipt, holdStoreReceipt, holdStoreTransfer, reholdStoreReceipt, storeReceiptHeldFor) +import Simplex.Chat.Store.Profiles (getUser, setUserBadge) import Simplex.Messaging.Agent (disposeAgentClient) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) @@ -72,7 +85,10 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (BBSSecretKey, bbsKeyGen) import Simplex.Messaging.Encoding.String (strDecode, strEncode, textEncode) import Simplex.Messaging.Util (safeDecodeUtf8, tshow) -import System.FilePath (()) +import Data.X509 (encodeSignedObject) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory, ()) +import UnliftIO.Temporary (withTempDirectory) #if defined(dbPostgres) import Database.PostgreSQL.Simple (Only (..)) #else @@ -110,6 +126,7 @@ badgeServiceTests = do it "should sign a renewal with the master key stored on the purchase" testRenewalSignsWithStoredMasterKey it "should leave the client holding the same ledger rows as the service" testClientReplicatesLedger it "should renew a badge whose credential is lapsing, with no command" testWorkerRenews + it "should take the newest issued credential by its ledger row, not by the period it ends" testLatestIssuedByRow it "should keep answering and renewing a holder after its partly used multi-use code is revoked" testRevokedMultiUseHolderRenews it "should return a multi-use holder's renewed credential on a repeat, apart from a later holder" testMultiUseHoldersRenewApart it "should request from the wake it set a day before the credential lapses" testRequestWakeFires @@ -133,6 +150,7 @@ badgeServiceTests = do it "should credit the months a store receipt paid for and issue the first" testStorePurchase it "should refuse a receipt another key was credited with" testStoreReceiptUsed it "should refuse a receipt the store does not vouch for, with no retry" testStoreReceiptInvalid + it "should credit a purchase the store calls a test only with credit_test_purchases on" testStoreTestPurchaseCredited it "should write nothing for a pending purchase, and credit it once when it settles" testStorePending it "should acknowledge a Play purchase before crediting it, and credit nothing when acknowledging fails" testStoreAcknowledgesBeforeCrediting it "should refuse a product that grants no badge" testStoreUnknownProduct @@ -157,6 +175,10 @@ badgeServiceTests = do it "should hold a Play token the service will not send to Play" testPurchaseUnsentPlayToken it "should credit a purchase first handed over under another profile to that profile" testPurchaseStrandedUnderOtherProfile it "should credit a purchase to a hidden profile without naming it" testPurchaseDeliveredToHiddenProfile + it "should record a listed transaction only into a record it already has, and a Restore hand-over as its own" testListedReceiptNotRecorded + it "should refuse a code or an invoice while a held receipt may be credited or is an Apple subscription, and not otherwise" testRedeemRefusedWhileReceiptHeld + it "should stop a held Apple subscription blocking an invoice or a code, or listing open, a day after its charge expired, keeping its record" testLapsedAppleChargeStopsBlocking + it "should refuse an invoice while a held receipt's first attempt has not answered" testInvoiceRefusedWhileFirstAttemptOpen describe "invoice first" $ do it "should credit a receipt to the profile that created its invoice however late it arrives, and answer as that profile" testInvoiceOtherProfile it "should credit a receipt naming an unknown invoice to the presenting profile" testInvoiceUnknown @@ -175,8 +197,124 @@ badgeServiceTests = do it "should delete a month-old record that will fund no badge, and keep held and credited ones" testStoreReceiptCleanup it "should keep a receipt whose attempt throws" testStoreReceiptAttemptThrows it "should credit a held receipt after the app restarts" testStoreReceiptAfterRestart - describe "the Play lane" $ do + describe "the store lane" $ do it "should answer other requests while a Play receipt is with the store, and credit it once Play answers" testPlayHoldsNoOtherRequest + it "should route each request to its lane, judging a minute ahead" testStoreRouting + it "should check the store at every request only with check_store_during_coverage beside the mock or credit_test_purchases, and credit test purchases only from a real store" testStoreChecksConfigured + 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, and grant that charge once" 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 + it "should answer a transfer of a one-time purchase credited to another key receipt_used, moving nothing" testTransferOneTimeRefused + describe "restore" $ do + it "should move a subscription to another device on Restore right after its purchase, retire it on the old one, and credit one credited nowhere" testRestoreOnNewDevice + it "should retire a subscription Restore moved away when the old device asks within its issued month, recording no issue failure" testRestoreMovedOutAskedInMonth + it "should hold a second Restore within the hour of the first without asking the store, and still ask once for a purchase presented in it" testRestoreHeldPerPurpose + 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 no longer find a held record held for its owner once a Restore on another profile takes it" testStoreReceiptHeldForAfterRestore + 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 + it "should move a subscription on Restore on the same profile when its purchase is neither shown nor the profile's newest" testRestoreOnSameProfile + 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, 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 fund exactly one month from each Play charge of a monthly plan anchored on the 31st, at most the grace behind Play's period end" testPlayMonthEndWalk + it "should fund each month of an annual Play plan anchored on the 31st and twelve from its renewal, at most the grace behind Play's period end" testPlayAnnualMonthEndWalk + 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 + it "should keep asking at zero months, and present the renewed credential when the old one expires" testSubscriptionRenews + it "should keep the badge and ask again a day later while the store has not charged, and send nothing in between, then issue from the period start" testSubscriptionAwaitsCharge + it "should send a due request at once when the stored wake is further than a stall away" testFarWakeHoldsNothing + it "should wait a day, not the hour the service answered, after a renewal whose store check failed" testStoreUnreachableWaitsStall + it "should keep a request's wait past a snooze that ends sooner, and raise the alert again without a request" testSnoozeKeepsRequestWait + it "should wait from a late request until the next daily moment of the shown credential's expiry, not a day after it" testStallRejoinsSharedMoment + it "should send no dev-interval request within the interval and one after it, and none for a retired purchase" testDevIntervalRequests + it "should send no request during coverage without a dev interval" testNoDevIntervalRequests + it "should retry a failed dev-interval request within the interval" testDevIntervalRetries + it "should retire a subscription badge after asking, once the window has passed since the first answer that renewed nothing, whatever the service answers" testSubscriptionRetiredAfterRecoveryWindow + it "should count the window from the first answer that renewed nothing, not from the coverage it held, and retire a store never reached" testUnrenewedRunStartsAtFirstAnswer + it "should end the run of answers that renewed nothing at a renewal, and start a new one at the next" testRenewalEndsUnrenewedRun + it "should start a new run at the first answer after the app was not opened for longer than the window" testAbsenceRestartsUnrenewedRun + it "should start a new run at the first answer after the service did not answer for longer than the window" testOutageRestartsUnrenewedRun + it "should keep a subscription badge whose ledger still holds months, past the recovery window from its shown credential" testBankedSubscriptionNotRetired + it "should ask about a subscription not opened for longer than the recovery window, and keep it when the store kept charging" testIdleSubscriptionKeptPastWindow + it "should keep a subscription badge past the recovery window while the service does not answer" testSubscriptionNotRetiredWithoutAnswer + it "should retire the badge and alert once the service says the subscription ended, and stop asking" testSubscriptionEnds + it "should refund the months not issued of a subscription found ended within the hour, without asking the store, retire its badge, and credit a new subscription after it" testSubscriptionEndsWhileCovered + it "should refund the months not issued of an annual App Store subscription revoked in its second month, and retire its badge as ended" testAppleRevokedWhileCovered + it "should refund the months not issued of an annual Play subscription that expired in its second month, and retire its badge as ended" testPlayExpiredWhileCovered + it "should refund an annual subscription whose granted charge the store revoked, and not for a revoked charge it was never granted" testRevokedChargeRefunded + it "should ask the store before each month of an annual plan, on the renewal lane, and issue it while the subscription renews" testAnnualAsksBeforeEachMonth + it "should issue a month of an annual plan whose store check fails, and ask the store again before the next one" testAnnualIssuesWhenStoreFails + it "should retire a subscription badge the device reports ended once its ledger stops covering, without asking, and credit a one-time purchase after it" testDeviceEndedRetires + it "should send a badge request at once only in a dev build, keep a covered badge, and retire one the answer says ended" testRequestBadgeNow + it "should keep a subscription badge when a due request's answer renews it, though the device reported it ended" testFreshAnswerOverridesDeviceEnded + it "should keep the state the service answered when it credited and when it renewed past paid coverage, and announce a change" testSubscriptionStateKept + it "should keep the state from the credit through an issuance the service answers from its stored state" testAnnualStateNotFromStoredAnswer + it "should keep the device store's view of a credited subscription, except renewing over billing retry, and nothing for any other transaction" testSubscriptionStateFromStore + it "should alert a cancelled subscription until acknowledged, and not remind a monthly plan of its renewal" testSubscriptionAlerts + it "should remind an annual plan three days before it renews, from a wake of its own, until acknowledged" testRenewalReminder + it "should resolve an Apple renewal to the subscription's record, and credit a held record that adopted it once the subscription's hourly check allows" testAppleRenewalResolvesToPurchase + it "should adopt into a held Apple record only another transaction bought later and not revoked" testAppleAdoptionRules + 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 by a refund, once its store charges it again" testAppleResubscribeResumesWithinCoverage + it "should resume a Play subscription retired past the recovery window when its token is handed over while Play charges it" testPlaySubscriptionResumes + it "should set aside without a refusal a Play resume after its held attempts, and hold it again at its next hand-over" testPlayResumeAttemptsEnd + it "should set aside after one answer a Play resume whose subscription Restore moved to another device" testMovedOutPlayResumeSetAside + it "should not hold a Play subscription moved to another device as a resume of the purchase it left" testMovedOutPlayNotResumed + it "should derive no alert for an Apple purchase Restore moved to another device, and not hold a later charge as a resume of it" testMovedOutAppleNoAlertNoResume + 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 tell the apps a granted Apple tier change and show it to a contact at once" testTierChangeReachesContacts + 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 transaction has expired" testAppleTierChangeExpiredSettles + it "should hold and grant an Apple tier change handed over two days after it was bought" testAppleTierChangeHandedOverLate + it "should set aside an Apple tier change after its held attempts, asking no more, and hold it again at its next hand-over" testAppleTierChangeAttemptsEnd + it "should show the purchase a tier change credits, though a retire cleared it while the change was with the service" testAppleTierChangeKeepsPurchaseShown + it "should refuse in silence an Apple tier change the store does not vouch for, keeping the badge shown, and answer it again from the record" testAppleTierChangeRefused + it "should hold and credit an Apple tier change while another receipt of the owner is held" testAppleTierChangeBesideHeldReceipt + it "should keep renewing a tier change's purchase that the device reported ended before the change" testAppleTierChangeClearsEnded + it "should clear the payment problem a device reported once a tier change is charged" testAppleTierChangeClearsBillingRetry + it "should record on the receipt, not the purchase, a tier change whose credential does not verify" testAppleTierChangeCredentialUnverified + it "should send nothing for an Apple charge of a lower tier while its badge is shown, and grant it at renewal, shown when the old credential expires" testAppleTierChangeLowerWaitsForRenewal + it "should settle with no request a tier change held for a lower tier, as a build that held every change held it" testAppleTierChangeHeldLowerSettles + 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 + it "should keep at most the maximum of purchase checks, asking without recording once full, and drop expired ones" testPurchaseChecksBounded + it "should allow the purchase path at most the maximum of Play reads in a minute, counted from its first read" testPlayReadsBounded + it "should answer a Play subscription rate_limited without asking Play once the minute's reads are used, and not hold it off" testPlayPurchaseReadsLimited + it "should refuse an App Store Sandbox subscription as a test purchase without asking Apple" testAppleSandboxSubscriptionNotAsked + it "should answer an App Store subscription provider_not_configured every time without an API key, and credit a one-time purchase" testAppleSubscriptionWithoutApiKey + it "should acknowledge a Play subscription as a subscription before crediting it, and credit nothing when acknowledging fails" testPlaySubscriptionAcknowledgedBeforeCrediting + it "should credit a Play subscription Play reports, beside a one-time purchase, and answer provider_not_configured without [google]" testPlaySubscriptionThroughPlay + it "should have the dev mock credit and renew the plan a subscription names, end one it does not know, and still vouch for a one-time purchase" testMockSubscriptions + it "should bank a charge the dev mock reports during coverage, issue it once coverage reaches it, and refund it, answering ended, after the mock restarts" testStoreChecksDuringCoverage + it "should not bank again during coverage a charge the ledger already granted" testStoreChecksDuringCoverageGrantedOnce + it "should announce a month a request banks during coverage, though it issues nothing" testBankedMonthAnnounced badgeBotName :: Text badgeBotName = "SimpleX Badges" @@ -235,7 +373,8 @@ data BadgeServiceEnv = BadgeServiceEnv bsAddress :: String, bsController :: ChatController, bsStore :: FakeStore, - bsVerifier :: StoreVerifier + bsVerifier :: StoreVerifier, + bsPurchaseChecks :: PurchaseChecks } -- | Stop the service for good: requests sent after it go unanswered until they time out. Stopping @@ -251,13 +390,18 @@ withBadgeServiceEnv :: HasCallStack => TestParams -> (BadgeServiceEnv -> IO ()) withBadgeServiceEnv ps = withBadgeServiceVerifier ps fakeVerifier withBadgeServiceVerifier :: HasCallStack => TestParams -> (FakeStore -> StoreVerifier) -> (BadgeServiceEnv -> IO ()) -> IO () -withBadgeServiceVerifier ps verifierOf test = do +withBadgeServiceVerifier ps verifierOf = withBadgeServiceVerifierIO ps (\_ store -> pure $ verifierOf store) + +-- | For a verifier that reads the service's clock, as the dev mock does. +withBadgeServiceVerifierIO :: HasCallStack => TestParams -> (TestClock -> FakeStore -> IO StoreVerifier) -> (BadgeServiceEnv -> IO ()) -> IO () +withBadgeServiceVerifierIO ps verifierOf test = do Right (pk, sk) <- bbsKeyGen clock <- newTestClock store <- newFakeStore + verifier <- verifierOf clock store + purchaseChecks <- newPurchaseChecks let opts = mkBadgeServiceOpts ps sk svcCfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk, badgeCurrentTime = testClockTime clock} - verifier = verifierOf store withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure () -- First start: badge service takes the CreateMyAddress branch. runBadgeService ps verifier svcCfg opts $ \_ -> pure () @@ -275,7 +419,7 @@ withBadgeServiceVerifier ps verifierOf test = do -- Second start: badge service takes the ShowMyAddress branch, then serves the test body. runBadgeService ps verifier svcCfg opts $ \env -> do cc <- atomically $ readTMVar $ serviceCC env - test BadgeServiceEnv {bsIssuerKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk}, bsClock = clock, bsClientCfg = clientCfg, bsAddress = bsLink, bsController = cc, bsStore = store, bsVerifier = verifier} + test BadgeServiceEnv {bsIssuerKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk}, bsClock = clock, bsClientCfg = clientCfg, bsAddress = bsLink, bsController = cc, bsStore = store, bsVerifier = verifier, bsPurchaseChecks = purchaseChecks} issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode issueCode cc badgeType months = issueCodeAs cc badgeType months "free" @@ -455,12 +599,13 @@ testRedeemSameCodeOtherProfile ps = showActiveUser alice "alice (Alice, * supporter)" serviceCmd :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse -serviceCmd BadgeServiceEnv {bsIssuerKey, bsController, bsVerifier} purchaseKey request = - badgeServiceResponse bsIssuerKey bsVerifier bsController Nothing (Just purchaseKey) (requestObject purchaseKey request) +serviceCmd BadgeServiceEnv {bsIssuerKey, bsController, bsVerifier, bsPurchaseChecks} purchaseKey request = + badgeServiceResponse bsIssuerKey bsVerifier bsPurchaseChecks bsController Nothing (Just purchaseKey) (requestObject purchaseKey request) serviceCmdWith :: HasCallStack => BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse -serviceCmdWith key cc trackerQ_ purchaseKey request = - badgeServiceResponse key noStoreVerifier cc trackerQ_ (Just purchaseKey) (requestObject purchaseKey request) +serviceCmdWith key cc trackerQ_ purchaseKey request = do + checks <- newPurchaseChecks + badgeServiceResponse key noStoreVerifier checks cc trackerQ_ (Just purchaseKey) (requestObject purchaseKey request) requestObject :: HasCallStack => C.PublicKeyEd25519 -> BadgeServiceCommand -> J.Object requestObject purchaseKey request = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of @@ -783,6 +928,11 @@ peerBadgeExpiry ChatController {chatStore} = do ((t, _) : _) -> t [] -> Nothing +peerBadgeTypes :: ChatController -> IO [Text] +peerBadgeTypes ChatController {chatStore} = + withTransaction chatStore $ \db -> + map fromOnly <$> DB.query_ db "SELECT badge_type FROM contact_profiles WHERE badge_proof IS NOT NULL ORDER BY contact_profile_id" + setBadgeExpiry :: ChatController -> String -> UTCTime -> IO () setBadgeExpiry ChatController {chatStore} whichBadge t = withTransaction chatStore $ \db -> @@ -916,6 +1066,27 @@ testWorkerRenews ps = alice <## "ok" waitShownIssued (chatController alice) +testLatestIssuedByRow :: HasCallStack => TestParams -> IO () +testLatestIssuedByRow ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + code <- issueCode cc BTSupporter 3 + redeemFirstBadge alice code + redeemed <- ledgerRows (chatController alice) "badge_ledger" + setClockAt bsClock $ fst $ renewalMoments redeemed + alice ##> "/_app activate" + alice <## "ok" + _ <- waitLedgerRows (chatController alice) 3 + alice <##. "1: supporter" + withTransaction (chatStore $ chatController alice) $ \db -> do + -- as a tier change leaves them: the newer issuance ends before the older one + [(purchaseId, olderId, olderEnd), (_, newerId, newerEnd)] :: [(Int64, Int64, UTCTime)] <- + DB.query_ db "SELECT badge_purchase_id, entry_id, period_end FROM badge_issuances ORDER BY entry_id" + DB.execute db "UPDATE badge_issuances SET period_end = ? WHERE entry_id = ?" (newerEnd, olderId) + DB.execute db "UPDATE badge_issuances SET period_end = ? WHERE entry_id = ?" (olderEnd, newerId) + [Only (Binary newest)] <- DB.query db "SELECT credential FROM badge_issuances WHERE entry_id = ?" (Only newerId) + getLatestIssuedCredential db purchaseId `shouldReturn` J.decodeStrict' newest + testRevokedMultiUseHolderRenews :: HasCallStack => TestParams -> IO () testRevokedMultiUseHolderRenews ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> @@ -1188,7 +1359,7 @@ testIssueFailedWaitsForExpiry ps = let cfg = failingServiceCfg bsClientCfg -- the request goes unanswered and times out, which is a failure that can clear on its own setClockAt bsClock requestAt - failedSince <- withTestChatCfg ps cfg "alice" $ \alice -> do + (failedSince, errorAt, wake) <- withTestChatCfg ps cfg "alice" $ \alice -> do alice <##. "1: supporter" -- the state carries no failure and no alert: /p prints only its own output alice ##> "/p" @@ -1196,7 +1367,14 @@ testIssueFailedWaitsForExpiry ps = alice <## "use /p [] to change it" (since, reason) <- issueErrorRow (chatController alice) reason `shouldBe` Just "service_timeout" - pure since + (since,,) <$> issueErrorAt (chatController alice) <*> nextWakes (chatController alice) + -- restarted before the wake that failure set, it waits for it: a request sent would fail after 2s and be recorded + setClockAt bsClock $ addUTCTime 1800 requestAt + withTestChatCfg ps cfg "alice" $ \alice -> do + threadDelay 3000000 + (alice do @@ -1227,27 +1405,35 @@ testIssueFailedAckAndNewRun ps = alice <##. "renewal failing since " alice <##. "badge alert: issue_failed " episode <- episodeOf . fst <$> issueErrorRow (chatController alice) + errorAt <- issueErrorAt (chatController alice) alice ##> ("/_badge ack 1 1 issue_failed off " <> T.unpack episode) -- the state still carries the error, and no alert with it alice <##. "1: supporter" alice <##. "renewal failing since " - -- the ack signalled the worker, and the pass it ran failed again and raised nothing - alice <## badgeServiceRefused + -- the ack signalled the worker, and the pass it ran waited for the wake the refusal set, sending nothing + threadDelay 2000000 + (alice "/_app activate" + alice <## "ok" + alice ##> "/_badge state 1" alice <##. "1: supporter" alice <##. "renewal failing since " - ackedEpisode (chatController alice) `shouldReturn` (Just "issue_failed", Just episode) - -- the service is back: the month it owes is issued, which ends the run + threadDelay 2000000 + (alice "/_app activate" alice <## "ok" renewed <- waitLedgerRows (chatController alice) 3 alice <##. "1: supporter" waitIssueErrorCleared (chatController alice) - -- the month issued is presented when the one on the profile lapses, and only then is the - -- next renewal asked for - so the run that fails next is a new one - setClockAt bsClock presentAt - alice ##> "/_app activate" - alice <## "ok" waitShownIssued (chatController alice) setServicePurchaseKey cc "not the purchase key" setClockAt bsClock $ fst $ renewalMoments renewed @@ -1279,6 +1465,8 @@ testNoCredentialMonthsRanOut ps = alice ##> "/_app activate" alice <## "ok" alice <##. "badge alert: support_ended " + alice <##. "1: supporter, 0 months left" + alice <##. "badge alert: support_ended " issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) -- the debit is the client's now, and the next pass retires the badge on it rows' <- ledgerRows (chatController alice) "badge_ledger" @@ -1369,6 +1557,10 @@ issueErrorRow ChatController {chatStore} = do [r] -> r _ -> error $ "expected one badge purchase, got " <> show (length rows) +issueErrorAt :: ChatController -> IO [Maybe UTCTime] +issueErrorAt ChatController {chatStore} = + withTransaction chatStore $ \db -> map fromOnly <$> DB.query_ db "SELECT issue_error_at FROM badge_purchases" + -- the clearing is written by the pass that stored the issuance, which the test waits for waitIssueErrorCleared :: HasCallStack => ChatController -> IO () waitIssueErrorCleared cc = loop (100 :: Int) @@ -1421,6 +1613,11 @@ testSnoozedAlertReturns ps = ] alice ##> ("/_badge ack 1 1 support_ended on " <> T.unpack (safeDecodeUtf8 $ strEncode endsAt)) alice <##. "1: supporter" + -- no request waits, so the snooze's end, a day after the ack, is the wake + let snoozeWake = \case + [Just w] -> w >= addUTCTime nominalDay endsAt && w < addUTCTime (nominalDay + 60) endsAt + _ -> False + (snoozeWake <$> nextWakes (chatController alice)) `shouldEventuallyReturn` True alice ##> "/p" alice <## "user profile: alice (Alice)" alice <## "use /p [] to change it" @@ -1731,6 +1928,28 @@ testStoreReceiptInvalid ps = refused SPApple {jws = appleSandboxJWS} `shouldReturn` (BSETestPurchase, Nothing) nothingPurchased cc +testStoreTestPurchaseCredited :: HasCallStack => TestParams -> IO () +testStoreTestPurchaseCredited ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSandboxJWS, appleSandboxSubscriptionJWS}} -> do + now <- serviceNow env + let crediting = env {bsVerifier = (fakeVerifier store) {creditTestPurchases = True}} + testToken = "fake-play-token-subscription-test.AO-J1Os2q5djX0pRm6" + testCheck planId = SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = True, latestCharge = Just $ storeCharge planId (addUTCTime (-3600) now) 1} + receipts = [SPApple {jws = appleSandboxJWS}, googlePayment "subscr_badge_supporter_01" testToken, SPApple {jws = appleSandboxSubscriptionJWS}] + purchaseUnderNewKey verifierEnv payment = do + (purchaseKey, masterKey) <- newPurchaseKeys + serviceCmd verifierEnv purchaseKey $ purchaseCmd masterKey payment + setSubscription store (SubscriptionGoogle testToken) $ testCheck "subscr-badge-supporter-month-02" + setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ testCheck "SUBSCR_BADGE_SUPPORTER_MONTH_01" + credited <- mapM (purchaseUnderNewKey crediting) receipts + map (map entryTag . fst . statementOf) credited `shouldBe` [["payment", "badge"], ["charge", "badge"], ["charge", "badge"]] + map badgeTypeOf credited `shouldBe` [Just BTLegend, Just BTSupporter, Just BTSupporter] + -- past the hour the Play claim is held for since it was credited, so Play is asked again + setClockAt bsClock $ addUTCTime 3700 now + refused <- mapM (purchaseUnderNewKey env) receipts + map refusalOf refused `shouldBe` replicate 3 (BSETestPurchase, Nothing) + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 3 + testStorePending :: HasCallStack => TestParams -> IO () testStorePending ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store} -> do @@ -1757,7 +1976,7 @@ testStoreAcknowledgesBeforeCrediting ps = do let purchase payment = serviceCmd env purchaseKey $ purchaseCmd masterKey payment unsettled <- purchase $ googlePayment "badge_supporter_01" googlePendingToken fst (refusalOf unsettled) `shouldBe` BSEPaymentPending - unpriced <- purchase $ googlePayment "subscr_badge_supporter_01" googleSubscriptionToken + unpriced <- purchase $ googlePayment "badge_unknown_01" googleUnknownProductToken refusalOf unpriced `shouldBe` (BSEProductUnavailable, Nothing) readIORef acknowledged `shouldReturn` [] writeIORef acknowledgement $ Left $ SRUnreachable "acknowledging: fake store is down" @@ -1779,9 +1998,9 @@ testStoreUnknownProduct :: HasCallStack => TestParams -> IO () testStoreUnknownProduct ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do (purchaseKey, masterKey) <- newPurchaseKeys - -- a real purchase of a subscription, whose renewals nothing adds to a badge yet - subscription <- serviceCmd env purchaseKey $ purchaseCmd masterKey $ googlePayment "subscr_badge_supporter_01" googleSubscriptionToken - refusalOf subscription `shouldBe` (BSEProductUnavailable, Nothing) + -- a real purchase the store vouches for, of a product this service does not price + unpriced <- serviceCmd env purchaseKey $ purchaseCmd masterKey $ googlePayment "badge_unknown_01" googleUnknownProductToken + refusalOf unpriced `shouldBe` (BSEProductUnavailable, Nothing) nothingPurchased cc testStoreUpgradeRefused :: HasCallStack => TestParams -> IO () @@ -1936,6 +2155,3208 @@ testStoreUnsentProductId ps = do verifications `shouldReturn` 0 nothingPurchased cc +subscriptionPlay :: ServicePayment +subscriptionPlay = googlePayment "subscr_badge_supporter_01" googleSubscriptionToken + +subscriptionCheck :: SubscriptionState -> Maybe StoreCharge -> SubscriptionCheck +subscriptionCheck subscriptionState latestCharge = SubscriptionCheck {subscriptionState, testSubscription = False, latestCharge} + +storeCharge :: Text -> UTCTime -> Integer -> StoreCharge +storeCharge planId periodStart months = + StoreCharge {chargeRef = "GPA.3301-1234-5678-90123", planId, periodStart, periodEnd = addMonths months periodStart, chargePaid = Nothing, revoked = False, offer = False} + +subscriptionOf :: HasCallStack => BadgeServiceResponse -> Maybe SubscriptionState +subscriptionOf = \case + BSPBadgeCredential {subscription} -> subscription + r -> error $ "expected badgeCredential, got " <> show (J.toJSON r) + +createdAtOf :: StatementEntry -> UTCTime +createdAtOf StatementEntry {createdAt} = createdAt + +-- | The ledger stores whole seconds. +serviceNow :: BadgeServiceEnv -> IO UTCTime +serviceNow BadgeServiceEnv {bsClock} = truncateToSecond <$> testClockTime bsClock + +subscriptionPayments :: ChatController -> IO [(Text, Text, Maybe Text, Maybe Text)] +subscriptionPayments ChatController {chatStore} = + withTransaction chatStore $ \db -> + DB.query_ db "SELECT provider, provider_ref, subscription_state, provider_token FROM sx_badge_service_payments ORDER BY provider" + +testSubscriptionPurchase :: HasCallStack => TestParams -> IO () +testSubscriptionPurchase ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleSandboxSubscriptionJWS}} -> do + now <- serviceNow env + let periodStart = addUTCTime (-3600) now + changes = map (\e -> let (c, m, _) = entryOf e in (c, m)) . fst . statementOf + setSubscription store (SubscriptionGoogle googleSubscriptionToken) $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" periodStart 1 + (purchaseKey, masterKey) <- newPurchaseKeys + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay + map entryTag (fst $ statementOf purchased) `shouldBe` ["charge", "badge"] + changes purchased `shouldBe` [(1, 1), (-1, 0)] + -- the month is granted at the store's period start, not when the receipt arrived + map createdAtOf (take 1 $ fst $ statementOf purchased) `shouldBe` [periodStart] + badgeTypeOf purchased `shouldBe` Just BTSupporter + subscriptionOf purchased `shouldBe` Just SSRenewing + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1 + rowCount cc "sx_badge_service_badge_ledger WHERE charge_id IS NOT NULL" `shouldReturn` 1 + subscriptionPayments cc `shouldReturn` [("google", googlePurchaseRef googleSubscriptionToken, Just "renewing", Just googleSubscriptionToken)] + checks <- subscriptionChecks store + replayed <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay + credentialOf replayed `shouldBe` credentialOf purchased + subscriptionOf replayed `shouldBe` Just SSRenewing + subscriptionChecks store `shouldReturn` checks + (otherKey, otherMasterKey) <- newPurchaseKeys + -- another key is told once Play is asked again, after the hour the token is held for + setClockAt bsClock $ addUTCTime 3700 now + refusalOf <$> serviceCmd env otherKey (purchaseCmd otherMasterKey subscriptionPlay) `shouldReturn` (BSEReceiptUsed, Nothing) + -- an annual Apple subscription is claimed by its original id, which the store is asked about + setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" periodStart 12 + (appleKey, appleMasterKey) <- newPurchaseKeys + apple <- serviceCmd env appleKey $ purchaseCmd appleMasterKey SPApple {jws = appleSubscriptionJWS} + changes apple `shouldBe` [(12, 12), (-1, 11)] + subscriptionOf apple `shouldBe` Just SSRenewing + take 1 <$> subscriptionPayments cc `shouldReturn` [("apple", appleSubscriptionOriginalId, Just "renewing", Nothing)] + -- a test purchase is named, on the store's word for Play, and before the store is asked for Apple + let testToken = "fake-play-token-subscription-test.AO-J1Os2q5djX0pRm6" + setSubscription store (SubscriptionGoogle testToken) SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = True, latestCharge = Just $ storeCharge "subscr-badge-supporter-month-02" periodStart 1} + (testKey, testMasterKey) <- newPurchaseKeys + refusalOf <$> serviceCmd env testKey (purchaseCmd testMasterKey $ googlePayment "subscr_badge_supporter_01" testToken) `shouldReturn` (BSETestPurchase, Nothing) + sandboxChecks <- subscriptionChecks store + refusalOf <$> serviceCmd env testKey (purchaseCmd testMasterKey SPApple {jws = appleSandboxSubscriptionJWS}) `shouldReturn` (BSETestPurchase, Nothing) + subscriptionChecks store `shouldReturn` sandboxChecks + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 2 + +testSubscriptionPurchaseNotGrantable :: HasCallStack => TestParams -> IO () +testSubscriptionPurchaseNotGrantable ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do + now <- serviceNow env + (purchaseKey, masterKey) <- newPurchaseKeys + let monthlyFrom start = storeCharge "subscr-badge-supporter-month-02" start 1 + monthly = monthlyFrom (addUTCTime (-3600) now) + -- one token presented again and again, so each presentation comes after the hour the one before holds it for + answer ref payment checked = do + setSubscription store ref checked + refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey payment) <* nextHour + nextHour = testClockTime bsClock >>= setClockAt bsClock . addUTCTime 3700 + play = answer (SubscriptionGoogle googleSubscriptionToken) subscriptionPlay + aDay = Just 86400 + play (subscriptionCheck SSRenewing $ Just $ monthlyFrom $ addUTCTime 3600 now) `shouldReturn` (BSEPaymentPending, Just 3600) + -- Play gives a subscription bought again a new token, so this one can never be credited + play (subscriptionCheck SSEnded $ Just monthly) `shouldReturn` (BSEReceiptInvalid, Nothing) + -- a later charge could still credit this receipt + play (subscriptionCheck SSRenewing $ Just monthly {revoked = True}) `shouldReturn` (BSEPaymentPending, aDay) + play (subscriptionCheck SSRenewing $ Just monthly {offer = True}) `shouldReturn` (BSEPaymentPending, aDay) + play (subscriptionCheck SSBillingRetry Nothing) `shouldReturn` (BSEPaymentPending, aDay) + play (subscriptionCheck SSBillingRetry $ Just $ monthlyFrom $ addMonths (-2) now) `shouldReturn` (BSEPaymentPending, aDay) + play (subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-99" (addUTCTime (-3600) now) 1) `shouldReturn` (BSEPaymentPending, aDay) + -- Play gives a plan it does not know no length, so its charge has an empty period, and is still only an unsold plan + let unsoldAt t = (storeCharge "subscr-badge-supporter-month-99" t 1) {periodEnd = t} + play (subscriptionCheck SSRenewing $ Just $ unsoldAt $ addMonths 1 now) `shouldReturn` (BSEPaymentPending, aDay) + -- an Apple resubscription keeps the original id, so an ended subscription may yet be credited + answer (SubscriptionApple appleSubscriptionOriginalId) SPApple {jws = appleSubscriptionJWS} (subscriptionCheck SSEnded $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1) + `shouldReturn` (BSEPaymentPending, aDay) + play (subscriptionCheck SSRenewing $ Just monthly {periodEnd = addUTCTime (-7200) now}) `shouldReturn` (BSEInternal, Nothing) + nothingPurchased cc + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 0 + +-- | A monthly Play subscription bought an hour into its first period: its key, that period's start and the statement it was answered. +subscribedMonthly :: HasCallStack => BadgeServiceEnv -> IO (C.PublicKeyEd25519, UTCTime, [StatementEntry]) +subscribedMonthly env = subscribedTo env "subscr-badge-supporter-month-02" 1 + +-- | The same for the Play plan given, of that many months. +subscribedTo :: HasCallStack => BadgeServiceEnv -> Text -> Integer -> IO (C.PublicKeyEd25519, UTCTime, [StatementEntry]) +subscribedTo env@BadgeServiceEnv {bsStore} planId months = do + firstStart <- addUTCTime (-3600) <$> serviceNow env + setSubscription bsStore (SubscriptionGoogle googleSubscriptionToken) $ subscriptionCheck SSRenewing $ Just $ storeCharge planId firstStart months + (purchaseKey, masterKey) <- newPurchaseKeys + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay + pure (purchaseKey, firstStart, fst $ statementOf purchased) + +-- | The store's charge n months after the first, for the plan given. +monthlyCharge :: Text -> UTCTime -> Integer -> StoreCharge +monthlyCharge planId firstStart n = (storeCharge planId (addMonths n firstStart) 1) {chargeRef = "GPA.renewal." <> tshow n} + +storeReports :: FakeStore -> SubscriptionCheck -> IO () +storeReports store = setSubscription store (SubscriptionGoogle googleSubscriptionToken) + +subscriptionCheckedAt :: ChatController -> IO [Maybe UTCTime] +subscriptionCheckedAt ChatController {chatStore} = + withTransaction chatStore $ \db -> + map fromOnly <$> DB.query_ db "SELECT subscription_checked_at FROM sx_badge_service_payments" + +testSubscriptionChargeGrantedOnce :: HasCallStack => TestParams -> IO () +testSubscriptionChargeGrantedOnce ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do + (purchaseKey, firstStart, purchased) <- subscribedMonthly env + let renewalStart = addMonths 1 firstStart + -- the store's period runs past the month granted, so the charge is still current once that month is spent + renewal = (monthlyCharge "subscr-badge-supporter-month-02" firstStart 1) {periodEnd = addUTCTime (10 * nominalDay) (addMonths 2 firstStart)} + storeReports store $ subscriptionCheck SSRenewing $ Just renewal + setClockAt bsClock $ addUTCTime (3 * nominalDay) renewalStart + renewed <- assertBalance env purchaseKey (last purchased) + map entryTag (fst $ statementOf renewed) `shouldBe` ["charge", "badge"] + map createdAtOf (take 1 $ fst $ statementOf renewed) `shouldBe` [renewalStart] + subscriptionOf renewed `shouldBe` Just SSRenewing + credentialOf renewed `shouldSatisfy` isJust + -- inside the issued month a repeat gets the same credential, and the store is not asked + checks <- subscriptionChecks store + repeated <- assertBalance env purchaseKey (last purchased) + credentialOf repeated `shouldBe` credentialOf renewed + subscriptionOf repeated `shouldBe` Just SSRenewing + subscriptionChecks store `shouldReturn` checks + -- the store still reports that charge once the month has run out, and it is not granted again + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + setClockAt bsClock $ addUTCTime (3 * nominalDay) (addMonths 2 firstStart) + reported <- assertBalance env purchaseKey (last $ fst $ statementOf renewed) + subscriptionChecks store `shouldReturn` (checks + 1) + map entryTag (fst $ statementOf reported) `shouldBe` [] + credentialOf reported `shouldBe` Nothing + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 2 + +testSubscriptionStoreChecksBounded :: HasCallStack => TestParams -> IO () +testSubscriptionStoreChecksBounded ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsStore = store} -> do + (purchaseKey, firstStart, purchased) <- subscribedMonthly env + let request = assertBalance env purchaseKey (last purchased) + ended = addUTCTime (3 * nominalDay) (addMonths 1 firstStart) + checks <- subscriptionChecks store + setClockAt bsClock $ addUTCTime (10 * nominalDay) firstStart + _ <- request + subscriptionChecks store `shouldReturn` checks + -- once the month has run out the store is asked, and not again within the hour + storeReports store $ subscriptionCheck SSBillingRetry Nothing + setClockAt bsClock ended + waiting <- request + subscriptionOf waiting `shouldBe` Just SSBillingRetry + credentialOf waiting `shouldBe` Nothing + setClockAt bsClock $ addUTCTime 1800 ended + subscriptionOf <$> request `shouldReturn` Just SSBillingRetry + subscriptionChecks store `shouldReturn` (checks + 1) + -- an hour on it is asked again, and a check that fails holds the next one off as long + setGoogleDown store True + setClockAt bsClock $ addUTCTime 3700 ended + refusalOf <$> request `shouldReturn` (BSEProviderUnavailable, Just 3600) + setGoogleDown store False + setClockAt bsClock $ addUTCTime (3700 + 1800) ended + subscriptionOf <$> request `shouldReturn` Just SSBillingRetry + subscriptionChecks store `shouldReturn` (checks + 2) + +testSubscriptionChargeNotGranted :: HasCallStack => TestParams -> IO () +testSubscriptionChargeNotGranted ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do + (purchaseKey, firstStart, purchased) <- subscribedMonthly env + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + let monthly = "subscr-badge-supporter-month-02" + checkedAt i = addUTCTime (3 * nominalDay + fromIntegral (i :: Int) * 3700) (addMonths 1 firstStart) + notGranted = + [ (monthlyCharge monthly firstStart 1) {revoked = True}, + (monthlyCharge monthly firstStart 1) {offer = True, chargeRef = "GPA.offer"}, + (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}, + -- an unsold Play plan, given an empty period + (monthlyCharge "subscr-badge-supporter-month-99" firstStart 6) {periodEnd = addMonths 6 firstStart} + ] + forM_ (zip [0 ..] notGranted) $ \(i, charge) -> do + storeReports store $ subscriptionCheck SSRenewing $ Just charge + setClockAt bsClock $ checkedAt i + answered <- assertBalance env purchaseKey (last purchased) + credentialOf answered `shouldBe` Nothing + map entryTag (fst $ statementOf answered) `shouldBe` [] + -- each charge is recorded, and none funds a month + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1 + length notGranted + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + +testClippedPlayPeriodNotGranted :: HasCallStack => TestParams -> IO () +testClippedPlayPeriodNotGranted ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do + (purchaseKey, firstStart, purchased) <- subscribedMonthly env + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + -- Play dates the period ending on 31 March from the last day of February, and the ledger's month from then ends before 31 March + let (year, _, _) = toGregorian (utctDay firstStart) + clippedEnd = UTCTime (fromGregorian (year + 1) 3 31) 43200 + clipped = (storeCharge "subscr-badge-supporter-month-02" (addMonths (-1) clippedEnd) 1) {periodEnd = clippedEnd, chargeRef = "GPA.clipped"} + storeReports store $ subscriptionCheck SSRenewing $ Just clipped + setClockAt bsClock $ addUTCTime (-nominalDay) clippedEnd + renewal <- assertBalance env purchaseKey (last purchased) + credentialOf renewal `shouldBe` Nothing + map entryTag (fst $ statementOf renewal) `shouldBe` [] + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 2 + (otherKey, otherMasterKey) <- newPurchaseKeys + let otherToken = "fake-play-token-clipped.AO-J1Op9n4cjW9qQl5" + setSubscription store (SubscriptionGoogle otherToken) $ subscriptionCheck SSRenewing $ Just clipped + refusalOf <$> serviceCmd env otherKey (purchaseCmd otherMasterKey $ googlePayment "subscr_badge_supporter_01" otherToken) `shouldReturn` (BSEPaymentPending, Just 86400) + +testPlayMonthEndWalk :: HasCallStack => TestParams -> IO () +testPlayMonthEndWalk ps = walkPlayMonthEnd ps "subscr-badge-supporter-month-02" 1 5 + +testPlayAnnualMonthEndWalk :: HasCallStack => TestParams -> IO () +testPlayAnnualMonthEndWalk ps = walkPlayMonthEnd ps "subscr-badge-supporter-year-01" 12 12 + +-- | A Play subscription bought an hour into a period starting on 31 January, through the service as deployed, and then +-- as many more months asked for at the device's moments. Play's periods end on the 31st clipped at month ends, and it +-- reports at each moment the period that moment is in. +walkPlayMonthEnd :: HasCallStack => TestParams -> Text -> Integer -> Int -> IO () +walkPlayMonthEnd ps planId planMonths months = + withFakePlay $ \fake@FakePlay {fpConfig} -> do + let ini = takeDirectory (gServiceAccountFile fpConfig) "badge_service.ini" + writeFile ini "[listener]\nstatic_dir = /srv/badges\n" + Right cfg <- readServiceConfig ini + ServiceState {storeVerifier} <- newServiceState >>= configureStoreVerifier (Just cfg {playStore = Just fpConfig}) + withBadgeServiceVerifier ps (const storeVerifier) $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + let anchor = UTCTime (fromGregorian 2027 1 31) 39600 + periodEnd k = addMonths ((k + 1) * planMonths) anchor + periodAt t = toInteger $ length $ takeWhile (<= t) $ map periodEnd [0 ..] + askAt t = do + let k = periodAt t + item = lineItem [("expiryTime", J.toJSON $ periodEnd k), ("latestSuccessfulOrderId", J.String $ "GPA.1234-5678-9012-34567.." <> tshow k), basePlan planId] [] + answerPurchase fake googleSubscriptionToken $ PlayRecord $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [item] + setClockAt bsClock t + monthIssued :: UTCTime -> Int -> BadgeServiceResponse -> IO (StatementEntry, UTCTime, UTCTime) + monthIssued t monthsHeld answer = do + let rows = fst $ statementOf answer + expected + | monthsHeld == 0 = [("charge", fromInteger planMonths), ("badge", -1)] + | otherwise = [("badge", -1)] + lag = diffUTCTime (periodEnd $ periodAt t) (L.paidThrough $ last rows) + map (\e -> let (change, _, _) = entryOf e in (entryTag e, change)) rows `shouldBe` expected + lag `shouldSatisfy` \l -> l >= 0 && l <= badgeGraceInterval + Just expiry <- pure $ expiryOf answer + pure (last rows, expiry, t) + renew (tip, expiry, _) = askFrom [addUTCTime (fromInteger d * nominalDay) expiry | d <- [-1 .. 8]] + where + (_, held, _) = entryOf tip + askFrom = \case + [] -> error $ "no month issued after the credential expiring " <> show expiry + t : ts -> do + askAt t + answer <- assertBalance env purchaseKey tip + if null (fst $ statementOf answer) then askFrom ts else monthIssued t held answer + walk :: Int -> (StatementEntry, UTCTime, UTCTime) -> IO UTCTime + walk 0 (_, _, t) = pure t + walk n issued = renew issued >>= walk (n - 1) + purchasedAt = addUTCTime 3600 anchor + askAt purchasedAt + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay + lastAskedAt <- monthIssued purchasedAt 0 purchased >>= walk months + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` fromInteger (periodAt lastAskedAt + 1) + rowCount cc "sx_badge_service_subscription_charges c WHERE NOT EXISTS (SELECT 1 FROM sx_badge_service_badge_ledger l WHERE l.charge_id = c.charge_id)" `shouldReturn` 0 + +testSubscriptionStoreUnreachable :: HasCallStack => TestParams -> IO () +testSubscriptionStoreUnreachable ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do + (purchaseKey, firstStart, purchased) <- subscribedMonthly env + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + let ended = addUTCTime (3 * nominalDay) (addMonths 1 firstStart) + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + setGoogleDown store True + setClockAt bsClock ended + refusalOf <$> assertBalance env purchaseKey (last purchased) `shouldReturn` (BSEProviderUnavailable, Just 3600) + subscriptionCheckedAt cc >>= (`shouldSatisfy` \case [Just t] -> abs (diffUTCTime t ended) < 60; _ -> False) + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1 + +testAppleSubscriptionRenews :: HasCallStack => TestParams -> IO () +testAppleSubscriptionRenews ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc@ChatController {chatStore}, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do + firstStart <- addUTCTime (-3600) <$> serviceNow env + let monthly = "SUBSCR_BADGE_SUPPORTER_MONTH_01" + appleReports = setSubscription store (SubscriptionApple appleSubscriptionOriginalId) . subscriptionCheck SSRenewing . Just + firstCheck = addUTCTime (3 * nominalDay) (addMonths 1 firstStart) + renewalStart = addUTCTime nominalDay firstCheck + renewal = (storeCharge monthly renewalStart 1) {chargeRef = "2000000812345690"} + recordedIds :: IO [Text] + recordedIds = withTransaction chatStore $ \db -> map fromOnly <$> DB.query db "SELECT charge_id FROM sx_badge_service_subscription_charges WHERE provider_charge_ref = ?" (Only ("2000000812345690" :: Text)) + grantsOf :: Text -> IO [Int] + grantsOf chargeId = withTransaction chatStore $ \db -> map fromOnly <$> DB.query db "SELECT COUNT(*) FROM sx_badge_service_badge_ledger WHERE charge_id = ?" (Only chargeId) + appleReports $ storeCharge monthly firstStart 1 + (purchaseKey, masterKey) <- newPurchaseKeys + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPApple {jws = appleSubscriptionJWS} + subscriptionOf purchased `shouldBe` Just SSRenewing + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + -- the next charge is reported before its period starts: recorded, and nothing granted or issued + appleReports renewal + setClockAt bsClock firstCheck + waiting <- assertBalance env purchaseKey (last $ fst $ statementOf purchased) + subscriptionOf waiting `shouldBe` Just SSRenewing + credentialOf waiting `shouldBe` Nothing + map entryTag (fst $ statementOf waiting) `shouldBe` [] + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + [recorded] <- recordedIds + grantsOf recorded `shouldReturn` [0] + -- once its period has started, a later check grants that charge under the id it was recorded with + setClockAt bsClock $ addUTCTime 3600 renewalStart + renewed <- assertBalance env purchaseKey (last $ fst $ statementOf purchased) + map entryTag (fst $ statementOf renewed) `shouldBe` ["charge", "badge"] + map createdAtOf (take 1 $ fst $ statementOf renewed) `shouldBe` [renewalStart] + subscriptionOf renewed `shouldBe` Just SSRenewing + expiryOf renewed `shouldSatisfy` (> expiryOf purchased) + recordedIds `shouldReturn` [recorded] + grantsOf recorded `shouldReturn` [1] + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 2 + +-- | The client buys a monthly Play subscription an hour into its first period: that period's start, and its ledger then. +clientSubscribedMonthly :: HasCallStack => BadgeServiceEnv -> TestCC -> IO (UTCTime, [ReplicatedRow]) +clientSubscribedMonthly env@BadgeServiceEnv {bsStore} alice = do + firstStart <- addUTCTime (-3600) <$> serviceNow env + storeReports bsStore $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1 + alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + rows <- ledgerRows (chatController alice) "badge_ledger" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) rows `shouldBe` [(1, 1, Just "charge"), (-1, 0, Just "badge")] + pure (firstStart, rows) + +-- | Waits for the worker to arm a wake no earlier than t, which is how a pass that issued nothing shows it has ended. +waitWakeFrom :: HasCallStack => ChatController -> UTCTime -> IO () +waitWakeFrom ChatController {chatStore} t = loop (100 :: Int) + where + loop i = do + rows :: [(Maybe UTCTime, Int64)] <- + withTransaction chatStore $ \db -> + DB.query_ db "SELECT next_wake_at, badge_purchase_id FROM badge_purchases" + case rows of + [(Just w, _)] | w >= t -> pure () + _ + | i == 0 -> error $ "expected a wake from " <> show t <> ", got " <> show rows + | otherwise -> threadDelay 50000 >> loop (i - 1) + +rowChanges :: [ReplicatedRow] -> [(Int, Int, UTCTime, Maybe Text)] +rowChanges = map (\(_, ch, m, start, _, t) -> (ch, m, start, t)) + +testSubscriptionRenews :: HasCallStack => TestParams -> IO () +testSubscriptionRenews ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + let (requestAt, presentAt) = renewalMoments rows + renewalStart = addMonths 1 firstStart + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + -- asked at zero months, past paidThrough, with the badge still shown + requestAt `shouldSatisfy` (> renewalStart) + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 4 + alice <##. "1: supporter" + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + balanceChecks (chatController alice) `shouldReturn` replicate 4 (Just True) + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + -- and the new credential replaces the old one at its expiry + shownAndIssuedExpiry (chatController alice) >>= \(shown, issued) -> shown `shouldNotBe` issued + setClockAt bsClock presentAt + alice ##> "/_app activate" + 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, _) = 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 + 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 <- 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"] + -- the raised tier is shown without waiting for the Supporter credential to expire + 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; + -- its period runs past the month the move funds, so the charge is still current once that month is spent + storeReports store $ subscriptionCheck SSRenewing $ Just (monthlyCharge "subscr-badge-supporter-month-02" firstStart 2) {periodEnd = addUTCTime (10 * nominalDay) (addMonths 1 chargeStart)} + 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 + -- the store still reports that charge once the month it funded has run out, and it is not granted again + checks <- subscriptionChecks store + setClockAt bsClock $ addUTCTime (3 * nominalDay) (addMonths 1 chargeStart) + reported <- assertBalance env newKey (last movedRows) + subscriptionChecks store `shouldReturn` checks + 1 + map entryTag (fst $ statementOf reported) `shouldBe` [] + credentialOf reported `shouldBe` Nothing + 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 + +-- | Restore presents every transaction it finds as a transfer, a one-time purchase bought on another device included. +testTransferOneTimeRefused :: HasCallStack => TestParams -> IO () +testTransferOneTimeRefused ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store@FakeStore {appleSupporterJWS}} -> do + let oneTime = [supporterPlay, SPApple {jws = appleSupporterJWS}] + owned <- forM oneTime $ \payment -> do + (ownerKey, ownerMasterKey) <- newPurchaseKeys + purchased <- serviceCmd env ownerKey $ purchaseCmd ownerMasterKey payment + pure (ownerKey, ownerMasterKey, payment, purchased) + checks <- subscriptionChecks store + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + forM_ oneTime $ \payment -> refusalOf . snd <$> transferWithNewKey env payment `shouldReturn` (BSEReceiptUsed, 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 + forM_ owned $ \(ownerKey, ownerMasterKey, payment, purchased) -> + credentialOf <$> serviceCmd env ownerKey (purchaseCmd ownerMasterKey payment) `shouldReturn` credentialOf purchased + +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" + -- within the hour of the purchase's store check, the Restore asks the store itself + checks <- subscriptionChecks store + bob `send` restoredCmd 1 subscriptionPlay + waitShownBadge (chatController bob) (Just 1) + ledgerTags (chatController bob) `shouldReturn` [Just "charge", Just "badge"] + reboundPayments cc `shouldReturn` 1 + subscriptionChecks store `shouldReturn` checks + 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] + +testRestoreMovedOutAskedInMonth :: HasCallStack => TestParams -> IO () +testRestoreMovedOutAskedInMonth ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg {badgeDevRequests = True} "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) + bob `send` restoredCmd 1 subscriptionPlay + waitShownBadge (chatController bob) (Just 1) + -- the answer is ended with no credential while the issued month still runs past now + alice `send` "/_badge request 1" + waitShownBadge (chatController alice) Nothing + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + mapM_ dropOutput [alice, bob] + +testRestoreHeldPerPurpose :: HasCallStack => TestParams -> IO () +testRestoreHeldPerPurpose ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsStore = store} -> do + let heldFor s (code, retryAfter) = code == BSEPaymentPending && maybe False (\t -> t > s - 60 && t <= s + 60) retryAfter + _ <- subscribedMonthly env + purchasedAt <- testClockTime bsClock + setClockAt bsClock $ addUTCTime 1800 purchasedAt + checks <- subscriptionChecks store + (_, moved) <- transferWithNewKey env subscriptionPlay + credentialOf moved `shouldSatisfy` isJust + subscriptionChecks store `shouldReturn` checks + 1 + -- past the purchase's hour and inside the Restore's + setClockAt bsClock $ addUTCTime 3700 purchasedAt + refusalOf . snd <$> transferWithNewKey env subscriptionPlay >>= (`shouldSatisfy` heldFor 1700) + subscriptionChecks store `shouldReturn` checks + 1 + (otherKey, otherMasterKey) <- newPurchaseKeys + let presented = refusalOf <$> serviceCmd env otherKey (purchaseCmd otherMasterKey subscriptionPlay) + presented `shouldReturn` (BSEReceiptUsed, Nothing) + subscriptionChecks store `shouldReturn` checks + 2 + presented >>= (`shouldSatisfy` heldFor 3600) + subscriptionChecks store `shouldReturn` checks + 2 + +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 + +-- | A Restore takes a held record without its owner's lock, so the owner's worker checks it again under the lock. +testStoreReceiptHeldForAfterRestore :: HasCallStack => TestParams -> IO () +testStoreReceiptHeldForAfterRestore ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + alice ##> "/create user alisa" + showActiveUser alice "alisa" + g <- C.newRandom + now <- serviceNow env + let token = restoreToken "held-for" + payment = googlePayment "subscr_badge_supporter_01" token + txRef = StoreTransactionRef PPGoogle (googlePurchaseRef token) + withTransaction (chatStore $ chatController alice) $ \db -> do + Right owner <- runExceptT $ getUser db 1 + Right restorer <- runExceptT $ getUser db 2 + void $ holdStoreReceipt db g owner BT.SROPurchased Nothing txRef payment now + [Only receiptId] <- DB.query_ db "SELECT badge_store_receipt_id FROM badge_store_receipts" + storeReceiptHeldFor db receiptId 1 SHKPurchase `shouldReturn` True + holdStoreTransfer db g restorer txRef payment now `shouldReturn` False + storeReceiptHeldFor db receiptId 1 SHKPurchase `shouldReturn` False + storeReceiptHeldFor db receiptId 2 SHKTransfer `shouldReturn` True + +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)] + -- with no charge to grant the move waits, held for the second profile + storeReports store $ subscriptionCheck SSRenewing Nothing + 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] + +testRestoreOnSameProfile :: HasCallStack => TestParams -> IO () +testRestoreOnSameProfile ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + let a = chatController alice + (_, rows) <- clientSubscribedMonthly env alice + -- the subscription lapses: retired once the recovery window passed while Play retried the payment + storeReports store $ subscriptionCheck SSBillingRetry Nothing + t0 <- firstUnrenewedAnswer alice bsClock rows [] + -- an answer within the window keeps the run going, so the one past it retires the badge + let beforeEnd = addUTCTime (subscriptionRecoveryWindow - 3600) t0 + activateAt alice bsClock beforeEnd + fst <$> answeredRun a beforeEnd `shouldReturn` t0 + [Just wake] <- nextWakes a + setClockAt bsClock $ max wake $ addUTCTime (subscriptionRecoveryWindow + 3600) t0 + activateAnswered alice ["badge alert: subscription_ended "] + waitShownBadge a Nothing + -- a code's badge, now the profile's newest purchase, which then ends too, as Restore is refused while a badge shows + code <- issueCode cc BTSupporter 1 + dropOutput alice + alice ##> ("/_redeem_badge_code 1 " <> codeArg code) + expectLinesWithin 30 alice ["badge redeemed", "supporter badge - active", "expires "] ["1: supporter", "2: supporter", "badge alert: "] + waitShownBadge a (Just 2) + codeEnds <- dueAtOf <$> ledgerRows a "badge_ledger" + setClockAt bsClock $ addUTCTime 3600 codeEnds + alice `send` "/_app activate" + waitShownBadge a Nothing + dropOutput alice + -- Play charges the subscription again, and Restore on the same profile moves it to fresh keys + resubscribedAt <- serviceNow env + storeReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-supporter-month-02" (addUTCTime (-3600) resubscribedAt) 1) {chargeRef = "GPA.resubscribed"} + alice `send` restoredCmd 1 subscriptionPlay + waitShownBadge a (Just 3) + storeReceiptCreditErrors a `shouldReturn` [] + purchaseReceiptLinks a `shouldReturn` [(1, False), (1, False), (1, True)] + dropOutput alice + +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} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let (requestAt, presentAt) = renewalMoments rows + recoveredAt = addUTCTime (nominalDay / 2) requestAt + storeReports store $ subscriptionCheck SSBillingRetry Nothing + checks <- subscriptionChecks store + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + paymentIssue, + Predicate (\l -> "1: supporter" `isPrefixOf` l && ", subscription billingRetry" `isInfixOf` l), + paymentIssue + ] + -- nothing issued and no failure: the badge stays, and the next request is a day on + waitWakeFrom (chatController alice) (addUTCTime (nominalDay - 60) requestAt) + subscriptionChecks store `shouldReturn` checks + 1 + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + ledgerRows (chatController alice) "badge_ledger" `shouldReturn` rows + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` rows + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + -- opening the app before that wake sends nothing, though the service would ask the store again after an hour + checkedAt <- subscriptionCheckedAt cc + wake <- nextWakes (chatController alice) + forM_ [2 * 3600, nominalDay / 2] $ \sinceRequest -> do + setClockAt bsClock $ addUTCTime sinceRequest requestAt + alice ##> "/_app activate" + alice <## "ok" + alice ##> "/_badge state 1" + alice <### [StartsWith "1: supporter", paymentIssue] + threadDelay 2000000 + subscriptionChecks store `shouldReturn` checks + 1 + subscriptionCheckedAt cc `shouldReturn` checkedAt + nextWakes (chatController alice) `shouldReturn` wake + -- the charge lands, its period starting when the store recovered it + storeReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-supporter-month-02" recoveredAt 1) {chargeRef = "GPA.recovered"} + setClockAt bsClock presentAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 4 + alice <##. "1: supporter" + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, recoveredAt, Just "charge"), (-1, 0, addMonths 1 recoveredAt, Just "badge")] + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + waitShownIssued (chatController alice) + +testFarWakeHoldsNothing :: HasCallStack => TestParams -> IO () +testFarWakeHoldsNothing ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let (requestAt, presentAt) = renewalMoments rows + storeReports store $ subscriptionCheck SSBillingRetry Nothing + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + paymentIssue, + Predicate (\l -> "1: supporter" `isPrefixOf` l && ", subscription billingRetry" `isInfixOf` l), + paymentIssue + ] + waitWakeFrom (chatController alice) (addUTCTime (nominalDay - 60) requestAt) + checks <- subscriptionChecks store + -- no pass stores a wake this far ahead while a request is due: a device clock set back since left it + setNextWake (chatController alice) $ addUTCTime (2 * nominalDay) requestAt + setClockAt bsClock $ addUTCTime 7200 requestAt + alice ##> "/_app activate" + alice <## "ok" + nextWakes (chatController alice) `shouldEventuallyReturn` [Just presentAt] + subscriptionChecks store `shouldReturn` checks + 1 + +testStoreUnreachableWaitsStall :: HasCallStack => TestParams -> IO () +testStoreUnreachableWaitsStall ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + let (requestAt, presentAt) = renewalMoments rows + renewalStart = addMonths 1 firstStart + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + setGoogleDown store True + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + "bad chat command: badge service error: provider_unavailable", + StartsWith "1: supporter" + ] + waitWakeFrom (chatController alice) (addUTCTime (nominalDay - 60) requestAt) + checkedAt <- subscriptionCheckedAt cc + errorAt <- issueErrorAt (chatController alice) + wake <- nextWakes (chatController alice) + forM_ [2 * 3600, nominalDay / 2] $ \sinceRequest -> do + setClockAt bsClock $ addUTCTime sinceRequest requestAt + alice ##> "/_app activate" + alice <## "ok" + alice ##> "/_badge state 1" + alice <##. "1: supporter" + threadDelay 2000000 + subscriptionCheckedAt cc `shouldReturn` checkedAt + issueErrorAt (chatController alice) `shouldReturn` errorAt + nextWakes (chatController alice) `shouldReturn` wake + setGoogleDown store False + setClockAt bsClock presentAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 4 + alice <##. "1: supporter" + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + waitShownIssued (chatController alice) + waitIssueErrorCleared (chatController alice) + +testSnoozeKeepsRequestWait :: HasCallStack => TestParams -> IO () +testSnoozeKeepsRequestWait ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + let (requestAt, presentAt) = renewalMoments rows + episode = safeDecodeUtf8 $ strEncode $ addMonths 1 firstStart + storeReports store $ subscriptionCheck SSBillingRetry Nothing + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + paymentIssue, + Predicate (\l -> "1: supporter" `isPrefixOf` l && ", subscription billingRetry" `isInfixOf` l), + paymentIssue + ] + waitWakeFrom (chatController alice) (addUTCTime (nominalDay - 60) requestAt) + setClockAt bsClock $ addUTCTime 7200 requestAt + alice ##> ("/_badge ack 1 1 payment_issue on " <> T.unpack episode) + alice <##. "1: supporter" + ackedEpisode (chatController alice) `shouldReturn` (Just "payment_issue", Just episode) + nextWakes (chatController alice) `shouldEventuallyReturn` [Just presentAt] + checks <- subscriptionChecks store + -- the second request, while the alert is snoozed until two hours after it + setClockAt bsClock presentAt + alice ##> "/_app activate" + alice <## "ok" + subscriptionChecks store `shouldEventuallyReturn` (checks + 1) + waitWakeFrom (chatController alice) (addUTCTime (nominalDay - 60) presentAt) + checkedAt <- subscriptionCheckedAt cc + wake <- nextWakes (chatController alice) + setClockAt bsClock $ addUTCTime (3 * 3600) presentAt + alice `send` "/_app activate" + alice <### ["/_app activate", "ok", paymentIssue] + threadDelay 2000000 + subscriptionChecks store `shouldReturn` checks + 1 + subscriptionCheckedAt cc `shouldReturn` checkedAt + nextWakes (chatController alice) `shouldReturn` wake + +testStallRejoinsSharedMoment :: HasCallStack => TestParams -> IO () +testStallRejoinsSharedMoment ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let (requestAt, presentAt) = renewalMoments rows + requestedAt t = do + checks <- subscriptionChecks store + setClockAt bsClock t + alice ##> "/_app activate" + alice <## "ok" + subscriptionChecks store `shouldEventuallyReturn` (checks + 1) + storeReports store $ subscriptionCheck SSBillingRetry Nothing + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + paymentIssue, + Predicate (\l -> "1: supporter" `isPrefixOf` l && ", subscription billingRetry" `isInfixOf` l), + paymentIssue + ] + waitWakeFrom (chatController alice) (addUTCTime (nominalDay - 60) requestAt) + -- the app is not running at the expiry, and an activation three hours later sends the request + requestedAt $ addUTCTime (3 * 3600) presentAt + nextWakes (chatController alice) `shouldEventuallyReturn` [Just $ addUTCTime nominalDay presentAt] + requestedAt $ addUTCTime nominalDay presentAt + nextWakes (chatController alice) `shouldEventuallyReturn` [Just $ addUTCTime (2 * nominalDay) presentAt] + +-- | A service that asks its store at every issue request, so the store's check count counts the client's requests. +withRequestCountingService :: HasCallStack => TestParams -> (BadgeServiceEnv -> IO ()) -> IO () +withRequestCountingService ps = withBadgeServiceVerifier ps $ \store -> (fakeVerifier store) {storeChecks = ChecksAtEveryRequest} + +-- | An hour past a midnight UTC three days before paidThrough: inside coverage, with the next daily moment of the +-- shown expiry 23 hours on and every ledger moment days away, so only the dev interval can bring a request. +devIntervalStart :: [ReplicatedRow] -> UTCTime +devIntervalStart rows = UTCTime (addDays (-3) (utctDay (dueAtOf rows))) 3600 + +activateAt :: HasCallStack => TestCC -> TestClock -> UTCTime -> IO () +activateAt cc clock t = do + setClockAt clock t + cc ##> "/_app activate" + cc <## "ok" + +testDevIntervalRequests :: HasCallStack => TestParams -> IO () +testDevIntervalRequests ps = + withRequestCountingService ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg {badgeDevRequestInterval = Just 600} "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let t1 = devIntervalStart rows + checks <- subscriptionChecks store + activateAt alice bsClock t1 + subscriptionChecks store `shouldEventuallyReturn` (checks + 1) + waitWakeFrom (chatController alice) (addUTCTime 600 t1) + [Just wake] <- nextWakes (chatController alice) + wake `shouldSatisfy` (< addUTCTime 610 t1) + activateAt alice bsClock $ addUTCTime 300 t1 + threadDelay 2000000 + subscriptionChecks store `shouldReturn` checks + 1 + nextWakes (chatController alice) `shouldReturn` [Just wake] + activateAt alice bsClock $ addUTCTime 620 t1 + subscriptionChecks store `shouldEventuallyReturn` (checks + 2) + -- a purchase the store ended is retired by the request's answer, and not asked about again + storeReports store $ subscriptionCheck SSEnded Nothing + setClockAt bsClock $ addUTCTime 1240 t1 + alice `send` "/_app activate" + waitShownBadge (chatController alice) Nothing + subscriptionChecks store `shouldReturn` checks + 3 + dropOutput alice + setClockAt bsClock $ addUTCTime 1860 t1 + alice `send` "/_app activate" + threadDelay 2000000 + subscriptionChecks store `shouldReturn` checks + 3 + dropOutput alice + +testNoDevIntervalRequests :: HasCallStack => TestParams -> IO () +testNoDevIntervalRequests ps = + withRequestCountingService ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let t1 = devIntervalStart rows + checks <- subscriptionChecks store + wake <- nextWakes (chatController alice) + forM_ [0, 300, 620] $ \sinceStart -> do + activateAt alice bsClock $ addUTCTime sinceStart t1 + threadDelay 2000000 + subscriptionChecks store `shouldReturn` checks + nextWakes (chatController alice) `shouldReturn` wake + +testDevIntervalRetries :: HasCallStack => TestParams -> IO () +testDevIntervalRetries ps = + withRequestCountingService ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> do + let hourly cfg = cfg {badgeDevRequestInterval = Just 3600} + rows <- withNewTestChatCfg ps (hourly bsClientCfg) "alice" aliceProfile $ \alice -> snd <$> clientSubscribedMonthly env alice + stopBadgeService cc + let t1 = devIntervalStart rows + -- the start's pass sends the request the interval made due, which times out and is retried + setClockAt bsClock t1 + withTestChatCfg ps (hourly $ fastRetryCfg $ failingServiceCfg bsClientCfg) "alice" $ \alice -> do + failedAt <- replicateM 2 $ alice <##. "1: supporter" >> issueErrorAt (chatController alice) + case failedAt of + [[Just first], [Just second]] -> do + second `shouldSatisfy` (> first) + [first, second] `shouldSatisfy` all (\t -> t >= t1 && t < addUTCTime 60 t1) + _ -> expectationFailure $ "expected two failed attempts, got " <> show failedAt + +testSubscriptionRetiredAfterRecoveryWindow :: HasCallStack => TestParams -> IO () +testSubscriptionRetiredAfterRecoveryWindow ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + setServicePurchaseKey cc "not the purchase key" + t0 <- firstUnrenewedAnswer alice bsClock rows [badgeServiceRefused] + let beforeEnd = addUTCTime (subscriptionRecoveryWindow - 3600) t0 + setClockAt bsClock beforeEnd + activateAnswered alice [badgeServiceRefused] + fst <$> answeredRun (chatController alice) beforeEnd `shouldReturn` t0 + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + errorAt <- issueErrorAt (chatController alice) + -- past the window, and at or after the wake the refusal stored, so the request is sent and answered + [Just wake] <- nextWakes (chatController alice) + setClockAt bsClock $ max wake $ addUTCTime (subscriptionRecoveryWindow + 3600) t0 + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + ConsoleString badgeServiceRefused, + StartsWith "badge alert: subscription_ended ", + StartsWith "1: supporter", + StartsWith "renewal failing since ", + StartsWith "badge alert: subscription_ended " + ] + waitShownBadge (chatController alice) Nothing + retiredErrorAt <- issueErrorAt (chatController alice) + retiredErrorAt `shouldNotBe` errorAt + testClockTime bsClock >>= setClockAt bsClock . addUTCTime 3600 + alice ##> "/_app activate" + alice <## "ok" + threadDelay 2000000 + issueErrorAt (chatController alice) `shouldReturn` retiredErrorAt + +testBankedSubscriptionNotRetired :: HasCallStack => TestParams -> IO () +testBankedSubscriptionNotRetired ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + firstStart <- addUTCTime (-3600) <$> serviceNow env + storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-year-01" firstStart 12 + alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + rows <- ledgerRows (chatController alice) "badge_ledger" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) rows `shouldBe` [(12, 12, Just "charge"), (-1, 11, Just "badge")] + setServicePurchaseKey cc "not the purchase key" + setClockAt bsClock $ addUTCTime (subscriptionRecoveryWindow + nominalDay) $ snd $ renewalMoments rows + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + ConsoleString badgeServiceRefused, + StartsWith "badge alert: issue_failed ", + StartsWith "1: supporter", + StartsWith "renewal failing since ", + StartsWith "badge alert: issue_failed " + ] + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + +testIdleSubscriptionKeptPastWindow :: HasCallStack => TestParams -> IO () +testIdleSubscriptionKeptPastWindow ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + -- the store kept charging while the app was not opened: its third renewal covers the day of the first activation + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 3 + setClockAt bsClock $ addUTCTime (subscriptionRecoveryWindow + nominalDay) $ dueAtOf rows + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 4 + alice <##. "1: supporter" + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, addMonths 3 firstStart, Just "charge"), (-1, 0, addMonths 4 firstStart, Just "badge")] + waitShownIssued (chatController alice) + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + unrenewedRuns (chatController alice) `shouldReturn` [(Nothing, Nothing)] + (alice TestParams -> IO () +testSubscriptionNotRetiredWithoutAnswer ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> do + t0 <- withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + setServicePurchaseKey cc "not the purchase key" + firstUnrenewedAnswer alice bsClock rows [badgeServiceRefused] + stopBadgeService cc + setClockAt bsClock $ addUTCTime (subscriptionRecoveryWindow + 3600) t0 + withTestChatCfg ps (failingServiceCfg bsClientCfg) "alice" $ \alice -> do + alice <##. "1: supporter" + alice <##. "renewal failing since " + alice <##. "badge alert: issue_failed " + (_, reason) <- issueErrorRow (chatController alice) + reason `shouldBe` Just "service_timeout" + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + unrenewedRuns (chatController alice) `shouldReturn` [(Just t0, Just t0)] + +testUnrenewedRunStartsAtFirstAnswer :: HasCallStack => TestParams -> IO () +testUnrenewedRunStartsAtFirstAnswer ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + setGoogleDown store True + -- not opened for longer than the window: the first answer, which grants nothing, starts the run + let firstAnswerAt = addUTCTime (subscriptionRecoveryWindow + nominalDay) $ dueAtOf rows + unreachable = "bad chat command: badge service error: provider_unavailable" + setClockAt bsClock firstAnswerAt + activateAnswered alice [unreachable] + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + (t1, t1') <- answeredRun (chatController alice) firstAnswerAt + t1' `shouldBe` t1 + let beforeEnd = addUTCTime (subscriptionRecoveryWindow - 3600) t1 + setClockAt bsClock beforeEnd + activateAnswered alice [unreachable] + fst <$> answeredRun (chatController alice) beforeEnd `shouldReturn` t1 + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + [Just wake] <- nextWakes (chatController alice) + setClockAt bsClock $ max wake $ addUTCTime (subscriptionRecoveryWindow + 3600) t1 + activateAnswered alice [unreachable, "badge alert: subscription_ended "] + waitShownBadge (chatController alice) Nothing + +testRenewalEndsUnrenewedRun :: HasCallStack => TestParams -> IO () +testRenewalEndsUnrenewedRun ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + storeReports store $ subscriptionCheck SSBillingRetry Nothing + t0 <- firstUnrenewedAnswer alice bsClock rows [] + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + [Just renewalWake] <- nextWakes (chatController alice) + setClockAt bsClock renewalWake + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 4 + alice <##. "1: supporter" + unrenewedRuns (chatController alice) `shouldEventuallyReturn` [(Nothing, Nothing)] + waitShownIssued (chatController alice) + storeReports store $ subscriptionCheck SSBillingRetry Nothing + t2 <- firstUnrenewedAnswer alice bsClock renewed [] + t2 `shouldSatisfy` (> t0) + [Just wake] <- nextWakes (chatController alice) + checks <- subscriptionChecks store + let pastFirstWindow = max wake $ addUTCTime (subscriptionRecoveryWindow + 3600) t0 + setClockAt bsClock pastFirstWindow + alice ##> "/_app activate" + alice <## "ok" + subscriptionChecks store `shouldEventuallyReturn` (checks + 1) + fst <$> answeredRun (chatController alice) pastFirstWindow `shouldReturn` t2 + waitWakeFrom (chatController alice) (addUTCTime 1 pastFirstWindow) + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + expectLinesWithin 5 alice [] ["1: supporter", "renewal failing since ", "badge alert: "] + +testAbsenceRestartsUnrenewedRun :: HasCallStack => TestParams -> IO () +testAbsenceRestartsUnrenewedRun ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + setServicePurchaseKey cc "not the purchase key" + t0 <- firstUnrenewedAnswer alice bsClock rows [badgeServiceRefused] + -- held by the wake the refusal stored, so nothing is sent and the run stays + setClockAt bsClock $ addUTCTime 3600 t0 + alice ##> "/_app activate" + alice <## "ok" + threadDelay 2000000 + unrenewedRuns (chatController alice) `shouldReturn` [(Just t0, Just t0)] + let returnAt = addUTCTime (subscriptionRecoveryWindow + 2 * nominalDay) t0 + setClockAt bsClock returnAt + activateAnswered alice [badgeServiceRefused] + (since, lastAt) <- answeredRun (chatController alice) returnAt + since `shouldBe` lastAt + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + +testOutageRestartsUnrenewedRun :: HasCallStack => TestParams -> IO () +testOutageRestartsUnrenewedRun ps = do + hook <- newIORef (pure ()) + withBadgeServiceVerifier ps (subscriptionCheckWithHook hook) $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> do + t0 <- withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + storeReports store $ subscriptionCheck SSBillingRetry Nothing + firstUnrenewedAnswer alice bsClock rows [] + -- the store answers after the client gives up, so the pass throws without an answer and leaves the run as it was + writeIORef hook $ threadDelay 5000000 + let outageAt = addUTCTime (subscriptionRecoveryWindow + 3600) t0 + setClockAt bsClock outageAt + withTestChatCfg ps (failingServiceCfg bsClientCfg) "alice" $ \alice -> do + expectLinesWithin 30 alice ["1: supporter", "renewal failing since "] ["badge alert: "] + (_, reason) <- issueErrorRow (chatController alice) + reason `shouldBe` Just "service_timeout" + unrenewedRuns (chatController alice) `shouldReturn` [(Just t0, Just t0)] + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + let answeredAt = addUTCTime (2 * nominalDay) outageAt + setClockAt bsClock answeredAt + withTestChatCfg ps bsClientCfg "alice" $ \alice -> do + (since, lastAt) <- answeredRun (chatController alice) answeredAt + since `shouldBe` lastAt + waitWakeFrom (chatController alice) (addUTCTime 1 answeredAt) + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + expectLinesWithin 5 alice [] ["1: supporter", "renewal failing since ", "badge alert: ", "subscribed "] + +setNextWake :: ChatController -> UTCTime -> IO () +setNextWake ChatController {chatStore} at = + withTransaction chatStore $ \db -> DB.execute db "UPDATE badge_purchases SET next_wake_at = ?" (Only at) + +testSubscriptionEnds :: HasCallStack => TestParams -> IO () +testSubscriptionEnds ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let (requestAt, _) = renewalMoments rows + storeReports store $ subscriptionCheck SSEnded Nothing + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: subscription_ended ", + StartsWith "1: supporter", + StartsWith "badge alert: subscription_ended " + ] + waitShownBadge (chatController alice) Nothing + -- a retired purchase is not asked about again + checks <- subscriptionChecks store + setClockAt bsClock $ addUTCTime (2 * nominalDay) requestAt + alice ##> "/_app activate" + alice <## "ok" + threadDelay 2000000 + subscriptionChecks store `shouldReturn` checks + -- the device's store still lists it as renewing, which does not undo the service's word that it ended + subscriptionStatuses (chatController alice) `shouldReturn` [Just "ended"] + alice ##> ("/_badge subscription renewing " <> paymentArg subscriptionPlay) + alice <## "ok" + subscriptionStatuses (chatController alice) `shouldReturn` [Just "ended"] + +testSubscriptionEndsWhileCovered :: HasCallStack => TestParams -> IO () +testSubscriptionEndsWhileCovered ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = ChatController {chatStore}, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + firstStart <- addUTCTime (-3600) <$> serviceNow env + storeReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-year-01" firstStart 12 + alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + rows <- ledgerRows (chatController alice) "badge_ledger" + let requestAt = fst $ renewalMoments rows + -- stands in for a check within the hour that found it ended, as an upgrade's check records one + withTransaction chatStore $ \db -> DB.execute db "UPDATE sx_badge_service_payments SET subscription_state = 'ended', subscription_checked_at = ?" (Only requestAt) + checks <- subscriptionChecks store + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: subscription_ended ", + Predicate (\l -> "1: supporter, 0 months left" `isPrefixOf` l && ", subscription ended" `isInfixOf` l), + StartsWith "badge alert: subscription_ended " + ] + waitShownBadge (chatController alice) Nothing + ledgerTags (chatController alice) `shouldReturn` [Just "charge", Just "badge", Just "refund"] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "ended"] + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + subscriptionChecks store `shouldReturn` checks + now <- serviceNow env + let resubscribedToken = "fake-play-token-resubscribed.AO-J1Or2p4bgV3sPn6" + setSubscription store (SubscriptionGoogle resubscribedToken) $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-supporter-month-02" (addUTCTime (-3600) now) 1) {chargeRef = "GPA.resubscribed"} + alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "subscr_badge_supporter_01" resubscribedToken)) + inAnyOrder alice [["1: supporter", "badge alert: subscription_ended ", openPurchase ""], ["2: supporter"]] + waitShownBadge (chatController alice) (Just 2) + alice ##> "/_badge state 1" + alice <##. "2: supporter" + +testAppleRevokedWhileCovered :: HasCallStack => TestParams -> IO () +testAppleRevokedWhileCovered ps = + -- Apple answers a refunded subscription as revoked, which its verifier maps to ended + endedInSecondMonth ps appleStoreReports (\FakeStore {appleSubscriptionJWS} -> SPApple {jws = appleSubscriptionJWS}) "SUBSCR_BADGE_SUPPORTER_YEAR_01" $ \charge -> + subscriptionCheck SSEnded $ Just charge {revoked = True} + +testPlayExpiredWhileCovered :: HasCallStack => TestParams -> IO () +testPlayExpiredWhileCovered ps = + endedInSecondMonth ps storeReports (const subscriptionPlay) "subscr-badge-supporter-year-01" $ subscriptionCheck SSEnded . Just + +-- | An annual subscription the client bought, whose store reports at the second month's request what endedWith makes of its charge. +endedInSecondMonth :: HasCallStack => TestParams -> (FakeStore -> SubscriptionCheck -> IO ()) -> (FakeStore -> ServicePayment) -> Text -> (StoreCharge -> SubscriptionCheck) -> IO () +endedInSecondMonth ps reports paymentOf planId endedWith = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + firstStart <- addUTCTime (-3600) <$> serviceNow env + let charge = storeCharge planId firstStart 12 + reports store $ subscriptionCheck SSRenewing $ Just charge + alice ##> ("/_badge purchase 1 " <> paymentArg (paymentOf store)) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + rows <- ledgerRows (chatController alice) "badge_ledger" + reports store $ endedWith charge + checks <- subscriptionChecks store + setClockAt bsClock $ fst $ renewalMoments rows + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: subscription_ended ", + Predicate (\l -> "1: supporter, 0 months left" `isPrefixOf` l && ", subscription ended" `isInfixOf` l), + StartsWith "badge alert: subscription_ended " + ] + waitShownBadge (chatController alice) Nothing + subscriptionChecks store `shouldReturn` checks + 1 + ledgerTags (chatController alice) `shouldReturn` [Just "charge", Just "badge", Just "refund"] + map (\(_, ch, m, _, _, t) -> (ch, m, t)) <$> ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` [(12, 12, Just "charge"), (-1, 11, Just "badge"), (-11, 0, Just "refund")] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "ended"] + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + +testRevokedChargeRefunded :: HasCallStack => TestParams -> IO () +testRevokedChargeRefunded ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsStore = store} -> do + (purchaseKey, firstStart, purchased) <- subscribedTo env "subscr-badge-supporter-year-01" 12 + let granted = storeCharge "subscr-badge-supporter-year-01" firstStart 12 + changes = map (\e -> let (c, m, _) = entryOf e in (c, m)) . fst . statementOf + storeReports store $ subscriptionCheck SSRenewing $ Just granted {chargeRef = "GPA.never-granted", revoked = True} + setClockAt bsClock $ addUTCTime 600 (addMonths 1 firstStart) + second <- assertBalance env purchaseKey (last purchased) + map entryTag (fst $ statementOf second) `shouldBe` ["badge"] + credentialOf second `shouldSatisfy` isJust + storeReports store $ subscriptionCheck SSRenewing $ Just granted {revoked = True} + setClockAt bsClock $ addUTCTime 600 (addMonths 2 firstStart) + refunded <- assertBalance env purchaseKey (last $ fst $ statementOf second) + map entryTag (fst $ statementOf refunded) `shouldBe` ["refund"] + changes refunded `shouldBe` [(-10, 0)] + (credentialOf refunded, subscriptionOf refunded) `shouldBe` (Nothing, Just SSEnded) + -- what follows within the hour is answered ended from the record + checks <- subscriptionChecks store + again <- assertBalance env purchaseKey (last $ fst $ statementOf refunded) + (credentialOf again, subscriptionOf again) `shouldBe` (Nothing, Just SSEnded) + subscriptionChecks store `shouldReturn` checks + +testAnnualAsksBeforeEachMonth :: HasCallStack => TestParams -> IO () +testAnnualAsksBeforeEachMonth ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do + (purchaseKey, firstStart, purchased) <- subscribedTo env "subscr-badge-supporter-year-01" 12 + let issue = BSCIssueBadge {balance = BadgeBalance {lastEntry = last purchased}} + routedAt t = setClockAt bsClock t >> requestLane ChecksAfterCoverage cc (Just purchaseKey) (requestObject purchaseKey issue) + checks <- subscriptionChecks store + -- inside the issued month no month is due, so the store is not asked + routedAt (addUTCTime (10 * nominalDay) firstStart) `shouldReturn` MainLane + credentialOf <$> assertBalance env purchaseKey (last purchased) >>= (`shouldSatisfy` isJust) + subscriptionChecks store `shouldReturn` checks + routedAt (addUTCTime 600 (addMonths 1 firstStart)) `shouldReturn` RenewalLane + second <- assertBalance env purchaseKey (last purchased) + map entryTag (fst $ statementOf second) `shouldBe` ["badge"] + (isJust $ credentialOf second, subscriptionOf second) `shouldBe` (True, Just SSRenewing) + subscriptionChecks store `shouldReturn` checks + 1 + repeated <- assertBalance env purchaseKey (last purchased) + credentialOf repeated `shouldBe` credentialOf second + subscriptionChecks store `shouldReturn` checks + 1 + +testAnnualIssuesWhenStoreFails :: HasCallStack => TestParams -> IO () +testAnnualIssuesWhenStoreFails ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsStore = store} -> do + (purchaseKey, firstStart, purchased) <- subscribedTo env "subscr-badge-supporter-year-01" 12 + setGoogleDown store True + checks <- subscriptionChecks store + setClockAt bsClock $ addUTCTime 600 (addMonths 1 firstStart) + second <- assertBalance env purchaseKey (last purchased) + map entryTag (fst $ statementOf second) `shouldBe` ["badge"] + (isJust $ credentialOf second, subscriptionOf second) `shouldBe` (True, Just SSRenewing) + subscriptionChecks store `shouldReturn` checks + 1 + setGoogleDown store False + setClockAt bsClock $ addUTCTime 600 (addMonths 2 firstStart) + third <- assertBalance env purchaseKey (last $ fst $ statementOf second) + map entryTag (fst $ statementOf third) `shouldBe` ["badge"] + subscriptionChecks store `shouldReturn` checks + 2 + +testDeviceEndedRetires :: HasCallStack => TestParams -> IO () +testDeviceEndedRetires ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + checks <- subscriptionChecks store + let ended = Predicate (\l -> "1: supporter, 0 months left" `isPrefixOf` l && ", subscription ended" `isInfixOf` l) + alice ##> ("/_badge subscription ended " <> paymentArg subscriptionPlay) + alice <### ["ok", ended] + threadDelay 2000000 + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + subscriptionStatuses (chatController alice) `shouldReturn` [Just "ended"] + -- past paidThrough, and before the shown credential's request moment, so nothing is asked + let endsAt = dueAtOf rows + (requestAt, _) = renewalMoments rows + setClockAt bsClock $ addUTCTime (diffUTCTime requestAt endsAt / 2) endsAt + alice `send` "/_app activate" + alice <### ["/_app activate", "ok", StartsWith "badge alert: subscription_ended ", ended, StartsWith "badge alert: subscription_ended "] + waitShownBadge (chatController alice) Nothing + subscriptionChecks store `shouldReturn` checks + invoiceId <- createInvoice alice 1 + alice ##> purchaseWithInvoice 1 invoiceId supporterPlay + inAnyOrder alice [["1: supporter", "badge alert: subscription_ended ", invoicePurchase "" invoiceId], creditedLines "" invoiceId "2: supporter"] + waitShownBadge (chatController alice) (Just 2) + +testRequestBadgeNow :: HasCallStack => TestParams -> IO () +testRequestBadgeNow ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsController = ChatController {chatStore}, bsStore = store} -> do + withNewTestChatCfg ps bsClientCfg {badgeDevRequests = True} "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let cc = chatController alice + ended = Predicate (\l -> "1: supporter, 0 months left" `isPrefixOf` l && ", subscription ended" `isInfixOf` l) + shown <- shownBadgeId cc + checks <- subscriptionChecks store + -- while covered the service answers with the credential already shown + alice ##> "/_badge request 1" + alice <##. "1: supporter" + ledgerRows cc "badge_ledger" `shouldReturn` rows + shownBadgeId cc `shouldReturn` shown + issueErrorRow cc `shouldReturn` (Nothing, Nothing) + subscriptionChecks store `shouldReturn` checks + -- stands in for a store check that found it ended: only this request can carry it to the client now + withTransaction chatStore $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET subscription_state = 'ended'" + alice ##> "/_badge request 1" + alice <### [ended] + waitShownBadge cc Nothing + subscriptionStatuses cc `shouldReturn` [Just "ended"] + subscriptionChecks store `shouldReturn` checks + alice ##> "/_badge request 1" + alice <## "bad chat command: no badge is shown" + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + bob ##> "/_badge request 1" + bob <## "bad chat command: /_badge request is only available in builds for a dev badge service" + +testFreshAnswerOverridesDeviceEnded :: HasCallStack => TestParams -> IO () +testFreshAnswerOverridesDeviceEnded ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + setClockAt bsClock $ fst $ renewalMoments rows + let stateLine st = Predicate (\l -> "1: supporter" `isPrefixOf` l && (", subscription " <> st) `isInfixOf` l) + alice ##> ("/_badge subscription ended " <> paymentArg subscriptionPlay) + alice <### ["ok", stateLine "ended", stateLine "renewing"] + _ <- waitLedgerRows (chatController alice) 4 + subscriptionStatuses (chatController alice) `shouldEventuallyReturn` [Just "renewing"] + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + +-- | Read from the API response, as the apps read it: the terminal view does not show it. +badgeSubscriptionRef :: HasCallStack => ChatController -> IO (Maybe Text) +badgeSubscriptionRef cc = + sendChatCmdStr cc "/_badge state 1" >>= \case + Right (CRBadgeState _ (Just BT.BadgeState {BT.subscription = Just BT.BadgeSubscription {BT.transactionRef = ref_}}) _) -> pure ref_ + r -> error $ "expected a subscription's badge state, got " <> show (() <$ r) + +subscriptionStatuses :: ChatController -> IO [Maybe Text] +subscriptionStatuses ChatController {chatStore} = + withTransaction chatStore $ \db -> map fromOnly <$> DB.query_ db "SELECT subscription_status FROM badge_purchases" + +unrenewedRuns :: ChatController -> IO [(Maybe UTCTime, Maybe UTCTime)] +unrenewedRuns ChatController {chatStore} = + withTransaction chatStore $ \db -> DB.query_ db "SELECT unrenewed_since, last_unrenewed_at FROM badge_purchases" + +-- | The run once the pass answered at t has stored it, the pass's clock having run on from t. +answeredRun :: HasCallStack => ChatController -> UTCTime -> IO (UTCTime, UTCTime) +answeredRun cc t = loop (600 :: Int) + where + loop i = + unrenewedRuns cc >>= \case + [(Just since, Just lastAt)] | diffUTCTime lastAt t >= -1 && diffUTCTime lastAt t < 30 -> pure (since, lastAt) + runs + | i == 0 -> error $ "expected a run answered at " <> show t <> ", got " <> show runs + | otherwise -> threadDelay 50000 >> loop (i - 1) + +-- | An activation whose request is answered: the answer's lines and the badge's, its alerts among them. +activateAnswered :: HasCallStack => TestCC -> [String] -> IO () +activateAnswered cc answer = do + cc `send` "/_app activate" + expectLinesWithin 30 cc (["/_app activate", "ok"] <> answer <> ["1: supporter"]) ["1: supporter", "renewal failing since ", "badge alert: "] + +-- | The first request after the coverage ends, answered without renewing, which starts a run: its time. +firstUnrenewedAnswer :: HasCallStack => TestCC -> TestClock -> [ReplicatedRow] -> [String] -> IO UTCTime +firstUnrenewedAnswer cc clock rows answer = do + -- the request moment can come before the coverage ends, and an answer while covered starts no run + let answerAt = max (fst $ renewalMoments rows) (addUTCTime 3600 $ dueAtOf rows) + setClockAt clock answerAt + activateAnswered cc answer + (since, lastAt) <- answeredRun (chatController cc) answerAt + lastAt `shouldBe` since + pure since + +testSubscriptionStateKept :: HasCallStack => TestParams -> IO () +testSubscriptionStateKept ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + subscriptionStatuses (chatController alice) `shouldReturn` [Just "renewing"] + badgeSubscriptionRef (chatController alice) `shouldReturn` Just (googlePurchaseRef googleSubscriptionToken) + alice ##> "/_badge state 1" + alice <### [Predicate (\l -> "1: supporter, 0 months left" `isPrefixOf` l && ", subscription renewing" `isInfixOf` l)] + -- the request asserts coverage that has ended, so the service asks the store for its answer + storeReports store $ subscriptionCheck SSBillingRetry Nothing + setClockAt bsClock $ fst $ renewalMoments rows + alice `send` "/_app activate" + alice <### ["/_app activate", "ok", Predicate (", subscription billingRetry" `isInfixOf`), paymentIssue, paymentIssue] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"] + +nextWakes :: ChatController -> IO [Maybe UTCTime] +nextWakes ChatController {chatStore} = + withTransaction chatStore $ \db -> map fromOnly <$> DB.query_ db "SELECT next_wake_at FROM badge_purchases" + +-- | A monthly plan is not reminded of its renewal; a cancellation is alerted until acknowledged. +testSubscriptionAlerts :: HasCallStack => TestParams -> IO () +testSubscriptionAlerts ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (firstStart, _) <- clientSubscribedMonthly env alice + let paidThrough = addMonths 1 firstStart + episode = T.unpack $ safeDecodeUtf8 $ strEncode paidThrough + armWakeAt alice bsClock $ addUTCTime (-3 * nominalDay) paidThrough + nextWakes (chatController alice) >>= (`shouldSatisfy` all (maybe False (>= paidThrough))) + threadDelay 2000000 + (alice ("/_badge subscription cancelled " <> paymentArg subscriptionPlay) + alice <### ["ok", StartsWith "1: supporter", subscriptionCancelled, subscriptionCancelled] + alice ##> ("/_badge ack 1 1 subscription_cancelled off " <> episode) + alice <##. "1: supporter" + ackedEpisode (chatController alice) `shouldReturn` (Just "subscription_cancelled", Just (T.pack episode)) + alice ##> "/_badge state 1" + alice <##. "1: supporter" + (alice TestParams -> IO () +testRenewalReminder ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store@FakeStore {appleSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + firstStart <- addUTCTime (-3600) <$> serviceNow env + setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" firstStart 12 + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + let paidThrough = addMonths 12 firstStart + remindAt = addUTCTime (-3 * nominalDay) paidThrough + episode = T.unpack $ safeDecodeUtf8 $ strEncode paidThrough + -- with the last month issued, the reminder is the next thing due + setClockAt bsClock $ addUTCTime (-20 * nominalDay) paidThrough + alice ##> "/_app activate" + alice <## "ok" + alice <##. "1: supporter, 0 months left" + waitWakeFrom (chatController alice) remindAt + nextWakes (chatController alice) `shouldReturn` [Just remindAt] + armWakeAt alice bsClock remindAt + alice <##. "badge alert: renewal_approaching " + alice ##> ("/_badge ack 1 1 renewal_approaching off " <> episode) + alice <##. "1: supporter" + alice ##> "/_badge state 1" + alice <##. "1: supporter" + (alice TestParams -> IO () +testAnnualStateNotFromStoredAnswer ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc@ChatController {chatStore}, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + firstStart <- addUTCTime (-3600) <$> serviceNow env + storeReports store $ subscriptionCheck SSCancelled $ Just $ storeCharge "subscr-badge-supporter-year-01" firstStart 12 + alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + inAnyOrder alice [[openPurchase ""], ["1: supporter", "badge alert: subscription_cancelled "], ["badge alert: subscription_cancelled "]] + waitWakeArmed (chatController alice) + rows <- ledgerRows (chatController alice) "badge_ledger" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) rows `shouldBe` [(12, 12, Just "charge"), (-1, 11, Just "badge")] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "cancelled"] + let requestAt = fst $ renewalMoments rows + withTransaction chatStore $ \db -> DB.execute db "UPDATE sx_badge_service_payments SET subscription_state = 'renewing', subscription_checked_at = ?" (Only requestAt) + checks <- subscriptionChecks store + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + _ <- waitLedgerRows (chatController alice) 3 + alice <### [Predicate (\l -> "1: supporter, 10 months left" `isPrefixOf` l && ", subscription cancelled" `isInfixOf` l), subscriptionCancelled] + subscriptionChecks store `shouldReturn` checks + subscriptionPayments cc `shouldReturn` [("google", googlePurchaseRef googleSubscriptionToken, Just "renewing", Just googleSubscriptionToken)] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "cancelled"] + +testSubscriptionStateFromStore :: HasCallStack => TestParams -> IO () +testSubscriptionStateFromStore ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let report state payment = alice ##> ("/_badge subscription " <> state <> " " <> paymentArg payment) + report "cancelled" subscriptionPlay + alice <### ["ok", Predicate (", subscription cancelled" `isInfixOf`), subscriptionCancelled, subscriptionCancelled] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "cancelled"] + report "cancelled" subscriptionPlay + alice <## "ok" + -- Play lists a subscription in its grace period as renewing, which does not replace the service's billing retry + storeReports store $ subscriptionCheck SSBillingRetry Nothing + setClockAt bsClock $ fst $ renewalMoments rows + alice `send` "/_app activate" + alice <### ["/_app activate", "ok", Predicate (", subscription billingRetry" `isInfixOf`), paymentIssue, paymentIssue] + checks <- subscriptionChecks store + report "renewing" subscriptionPlay + alice <## "ok" + subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"] + -- a held transaction, here a one-time purchase handed over while the badge is shown, and an unknown one change nothing + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + alice <##. "1: supporter" + alice <##. "badge alert: payment_issue " + alice <##. openPurchase "" + report "cancelled" supporterPlay + alice <## "ok" + report "cancelled" $ googlePayment "subscr_badge_supporter_01" "fake-play-token-unknown.AO-J1Os2q5djX0pRm6" + alice <## "ok" + subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"] + report "cancelled" SPApple {jws = "not.a-jws"} + alice <## "cannot get badge: invalid store receipt" + report "paused" subscriptionPlay + alice <##. "bad chat command: " + subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"] + subscriptionChecks store `shouldReturn` checks + +-- | The held record's payment and when it is next attempted. +heldStoreReceiptAttempt :: ChatController -> IO [(Text, UTCTime)] +heldStoreReceiptAttempt ChatController {chatStore} = + withTransaction chatStore $ \db -> DB.query_ db "SELECT payment, next_attempt_at FROM badge_store_receipts WHERE payment IS NOT NULL" + +testAppleAdoptionRules :: HasCallStack => TestParams -> IO () +testAppleAdoptionRules ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleSubscriptionJWS, appleRevokedSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + now <- serviceNow env + setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime 3600 now) 1 + let handOver jws = do + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws}) + storePurchaseOpen alice "" + handOver appleSubscriptionJWS + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"] + held <- heldStoreReceiptAttempt (chatController alice) + checks <- subscriptionChecks store + let resigned = T.intercalate "." $ take 2 (T.splitOn "." appleSubscriptionJWS) <> ["c2lnbmVkIGFnYWlu"] + earlier = subscriptionJWS appleSubscriptionOriginalId "2000000812345685" ["purchaseDate" J..= (1764547200000 :: Int64)] + undated = subscriptionJWS appleSubscriptionOriginalId "2000000812345686" [] + forM_ [appleSubscriptionJWS, resigned, earlier, undated, appleRevokedSubscriptionJWS] $ \jws -> do + handOver jws + heldStoreReceiptAttempt (chatController alice) `shouldReturn` held + subscriptionChecks store `shouldReturn` checks + +testAdoptedReceiptNotOverwritten :: HasCallStack => TestParams -> IO () +testAdoptedReceiptNotOverwritten ps = do + entered <- newEmptyMVar + release <- newEmptyMVar + hook <- newIORef (pure ()) + withBadgeServiceVerifier ps (subscriptionCheckWithHook hook) $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store@FakeStore {appleSubscriptionJWS, appleRenewalSubscriptionJWS}} -> do + now <- serviceNow env + checks <- subscriptionChecks store + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + -- the first check waits for the renewal's hand-over and finds no subscription; the next finds it charged + writeIORef hook $ do + putMVar entered () + takeMVar release + writeIORef hook $ setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1 + let handOver jws = do + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws}) + storePurchaseOpen alice "" + handOver appleSubscriptionJWS + timeout 30000000 (takeMVar entered) `shouldReturn` Just () + handOver appleRenewalSubscriptionJWS + putMVar release () + -- the failed attempt sent the first transaction, so the renewal adopted meanwhile is presented at once, + -- and held off for the rest of the hour since the subscription was asked about + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"] + subscriptionChecks store `shouldReturn` checks + 1 + setClockAt bsClock $ addUTCTime 3700 now + withTestChatCfg ps bsClientCfg "alice" $ \alice -> do + expectLinesWithin 60 alice ["1: supporter"] ["subscribed 1 connections on server localhost"] + storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)] + +testAppleRenewalResolvesToPurchase :: HasCallStack => TestParams -> IO () +testAppleRenewalResolvesToPurchase ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleRenewalSubscriptionJWS}} -> do + now <- serviceNow env + let appleReports start = setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" start 1 + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + let handOver jws = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws}) + -- the first attempt finds a period that has not started, and the record waits + appleReports $ addUTCTime 3600 now + handOver appleSubscriptionJWS + storePurchaseOpen alice "" + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"] + checks <- subscriptionChecks store + -- a later renewal joins that record, which presents it at once, inside the hour since the subscription was asked about; + -- joining clears the record's error, so the error read again is the answer to that presentation + appleReports $ addUTCTime (-3600) now + handOver appleRenewalSubscriptionJWS + storePurchaseOpen alice "" + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"] + subscriptionChecks store `shouldReturn` checks + setClockAt bsClock $ addUTCTime 3700 now + withTestChatCfg ps bsClientCfg "alice" $ \alice -> do + expectLinesWithin 60 alice ["1: supporter"] ["subscribed 1 connections on server localhost"] + storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)] + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + -- the first transaction handed over again resolves to the credited record, and creates nothing + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + alice <## "badge already redeemed" + storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)] + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + map (\(_, ch, m, _, _, t) -> (ch, m, t)) <$> ledgerRows (chatController alice) "badge_ledger" `shouldReturn` [(1, 1, Just "charge"), (-1, 0, Just "badge")] + +testAppleResubscribeResumes :: HasCallStack => TestParams -> IO () +testAppleResubscribeResumes ps = + -- retired past its coverage on the service's answer that it ended, then charged again for the same tier + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + requestAt <- appleSubscriptionRetired env alice + -- past the hour in which the service answers from the check that found it ended + let resubscribedAt = addUTCTime 7200 requestAt + setClockAt bsClock resubscribedAt + appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" resubscribedAt 1) {chargeRef = "apple.resubscribed"} + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleResubscription "2000000812345690" resubscribedAt}) + expectLinesWithin 30 alice ["1: supporter", openPurchase "", "1: supporter"] ["badge alert: subscription_ended ", "subscribed "] + waitShownBadge (chatController alice) (Just 1) + heldStoreReceipts (chatController alice) `shouldReturn` 0 + storeReceiptCreditErrors (chatController alice) `shouldReturn` [] + storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)] + map (\(_, _, _, _, _, t) -> t) <$> ledgerRows (chatController alice) "badge_ledger" `shouldReturn` [Just "charge", Just "badge", Just "charge", Just "badge"] + [retiredExpiry, resumedExpiry] <- issuedExpiries (chatController alice) + resumedExpiry `shouldSatisfy` (> retiredExpiry) + waitShownIssued (chatController alice) + subscriptionStatuses (chatController alice) `shouldReturn` [Just "renewing"] + +testAppleResubscribeResumesWithinCoverage :: HasCallStack => TestParams -> IO () +testAppleResubscribeResumesWithinCoverage ps = + -- retired within its coverage, its months not issued refunded, when the store reported it ended + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store@FakeStore {appleSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + firstStart <- addUTCTime (-3600) <$> serviceNow env + let yearly = storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" firstStart 12 + appleStoreReports store $ subscriptionCheck SSRenewing $ Just yearly + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + rows <- ledgerRows (chatController alice) "badge_ledger" + appleStoreReports store $ subscriptionCheck SSEnded $ Just yearly {revoked = True} + let requestAt = fst $ renewalMoments rows + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice <### ["/_app activate", "ok", StartsWith "badge alert: subscription_ended ", Predicate (\l -> "1: supporter" `isPrefixOf` l && ", subscription ended" `isInfixOf` l), StartsWith "badge alert: subscription_ended "] + waitShownBadge (chatController alice) Nothing + -- past the hour in which the service answers from the check that found it ended + let resubscribedAt = addUTCTime 7200 requestAt + setClockAt bsClock resubscribedAt + appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" resubscribedAt 1) {chargeRef = "apple.resubscribed"} + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleResubscription "2000000812345691" resubscribedAt}) + expectLinesWithin 30 alice ["1: supporter", openPurchase "", "1: supporter"] ["badge alert: subscription_ended ", "subscribed "] + waitShownBadge (chatController alice) (Just 1) + ledgerTags (chatController alice) `shouldReturn` [Just "charge", Just "badge", Just "refund", Just "charge", Just "badge"] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "renewing"] + alice ##> "/_app activate" + alice <## "ok" + threadDelay 2000000 + shownBadgeId (chatController alice) `shouldReturn` Just 1 + +testPlaySubscriptionResumes :: HasCallStack => TestParams -> IO () +testPlaySubscriptionResumes ps = + -- retired once the recovery window passed while Play retried the payment, then charged again on the same token + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + playSubscriptionRetired env alice + -- past the hour in which the service answers from the check that retired it + resumedAt <- addUTCTime 7200 <$> serviceNow env + setClockAt bsClock resumedAt + storeReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-supporter-month-02" (addUTCTime (-3600) resumedAt) 1) {chargeRef = "GPA.resumed"} + alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + expectLinesWithin 30 alice ["1: supporter", openPurchase "", "1: supporter"] ["badge alert: ", "renewal failing since ", "subscribed "] + waitShownBadge (chatController alice) (Just 1) + heldStoreReceipts (chatController alice) `shouldReturn` 0 + storeReceiptCreditErrors (chatController alice) `shouldReturn` [] + ledgerTags (chatController alice) `shouldReturn` [Just "charge", Just "badge", Just "charge", Just "badge"] + +-- | A monthly Play subscription the client bought, retired once the recovery window passed while Play retried the payment. +playSubscriptionRetired :: HasCallStack => BadgeServiceEnv -> TestCC -> IO () +playSubscriptionRetired env@BadgeServiceEnv {bsClock, bsStore = store} alice = do + (_, rows) <- clientSubscribedMonthly env alice + storeReports store $ subscriptionCheck SSBillingRetry Nothing + t0 <- firstUnrenewedAnswer alice bsClock rows [] + -- an answer within the window keeps the run going, so the one past it retires the badge + let beforeEnd = addUTCTime (subscriptionRecoveryWindow - 3600) t0 + activateAt alice bsClock beforeEnd + fst <$> answeredRun (chatController alice) beforeEnd `shouldReturn` t0 + [Just wake] <- nextWakes (chatController alice) + setClockAt bsClock $ max wake $ addUTCTime (subscriptionRecoveryWindow + 3600) t0 + activateAnswered alice ["badge alert: subscription_ended "] + waitShownBadge (chatController alice) Nothing + +testPlayResumeAttemptsEnd :: HasCallStack => TestParams -> IO () +testPlayResumeAttemptsEnd ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + playSubscriptionRetired env alice + let a = chatController alice + handOver = alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + -- Play still retries the payment, so each attempt, an hour apart, credits nothing + start <- addUTCTime 7200 <$> serviceNow env + setClockAt bsClock start + handOver + forM_ [1 .. heldChargeAttempts - 1] $ \i -> do + storeReceiptRetries a `shouldEventuallyReturn` [i] + setClockAt bsClock $ addUTCTime (fromIntegral i * 3700) start + alice `send` "/_app activate" + -- set aside with no refusal recorded, and the next hand-over holds it again and credits it once Play charges + heldStoreReceipts a `shouldEventuallyReturn` 0 + storeReceiptCreditErrors a `shouldReturn` [] + resumedAt <- addUTCTime 3700 <$> serviceNow env + setClockAt bsClock resumedAt + storeReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-supporter-month-02" (addUTCTime (-3600) resumedAt) 1) {chargeRef = "GPA.resumed"} + handOver + waitShownBadge a (Just 1) + heldStoreReceipts a `shouldEventuallyReturn` 0 + dropOutput alice + +testMovedOutPlayResumeSetAside :: HasCallStack => TestParams -> IO () +testMovedOutPlayResumeSetAside ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + playSubscriptionRetired env alice + -- Play charges again, and bob's Restore moves the subscription before the retired device hands its token over + resumedAt <- addUTCTime 7200 <$> serviceNow env + setClockAt bsClock resumedAt + storeReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-supporter-month-02" (addUTCTime (-3600) resumedAt) 1) {chargeRef = "GPA.resumed"} + bob `send` restoredCmd 1 subscriptionPlay + waitShownBadge (chatController bob) (Just 1) + alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + (last <$> ledgerTags (chatController alice)) `shouldEventuallyReturn` Just "transferOut" + heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0 + storeReceiptRetries (chatController alice) `shouldReturn` [0] + mapM_ dropOutput [alice, bob] + +testMovedOutPlayNotResumed :: HasCallStack => TestParams -> IO () +testMovedOutPlayNotResumed ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + (_, rows) <- clientSubscribedMonthly env alice + bob `send` restoredCmd 1 subscriptionPlay + waitShownBadge (chatController bob) (Just 1) + -- the old device's badge retires at its next request, which the service answers ended + setClockAt bsClock $ fst $ renewalMoments rows + alice `send` "/_app activate" + waitShownBadge (chatController alice) Nothing + last <$> ledgerTags (chatController alice) `shouldReturn` Just "transferOut" + dropOutput alice + checks <- subscriptionChecks store + alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + alice <## "badge already redeemed" + heldStoreReceipts (chatController alice) `shouldReturn` 0 + subscriptionChecks store `shouldReturn` checks + mapM_ dropOutput [alice, bob] + +testMovedOutAppleNoAlertNoResume :: HasCallStack => TestParams -> IO () +testMovedOutAppleNoAlertNoResume ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store@FakeStore {appleSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + firstStart <- addUTCTime (-3600) <$> serviceNow env + -- the status names the transaction presented as the latest, so Restore moves it + appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" firstStart 1) {chargeRef = "2000000812345681"} + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + aliceRows <- ledgerRows (chatController alice) "badge_ledger" + bob `send` restoredCmd 1 SPApple {jws = appleSubscriptionJWS} + waitShownBadge (chatController bob) (Just 1) + -- the source profile's badge retires at its next request, answered ended, and no alert says it ended there + let requestAt = fst $ renewalMoments aliceRows + setClockAt bsClock requestAt + alice `send` "/_app activate" + expectLinesWithin 30 alice ["/_app activate", "ok", "1: supporter"] ["1: supporter", "subscribed "] + waitShownBadge (chatController alice) Nothing + last <$> ledgerTags (chatController alice) `shouldReturn` Just "transferOut" + alice ##> "/_badge state 1" + alice <##. "1: supporter" + (alice ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleResubscription "2000000812345692" requestAt}) + alice <## "badge already redeemed" + heldStoreReceipts (chatController alice) `shouldReturn` 0 + subscriptionChecks store `shouldReturn` checks + dropOutput bob + +testAppleResubscribeBounded :: HasCallStack => TestParams -> IO () +testAppleResubscribeBounded ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + requestAt <- appleSubscriptionRetired env alice + let handOver jws = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws}) + answeredFromRecord jws = do + handOver jws + alice <## "badge already redeemed" + 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 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_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 + setClockAt bsClock $ addUTCTime 10800 resubscribedAt + alice ##> "/_app activate" + alice <## "ok" + heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0 + storeReceiptCreditErrors (chatController alice) `shouldReturn` ["service_error final receipt_invalid"] + 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 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 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 + alice ##> purchaseWithInvoice 1 invoiceId supporterPlay + let heldLines = expectLinesWithin 30 alice ["1: supporter", "badge alert: subscription_ended ", invoicePurchase "" invoiceId] ["subscribed "] + heldLines + now <- serviceNow env + handOver $ appleResubscription "2000000812345694" now + 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 env alice = appleSupporterBeforeLegendWith env alice Nothing + +-- | The same, handed over with the invoice given, if any. +appleSupporterBeforeLegendWith :: HasCallStack => BadgeServiceEnv -> TestCC -> Maybe String -> IO () +appleSupporterBeforeLegendWith BadgeServiceEnv {bsClock, bsStore = store@FakeStore {appleSubscriptionJWS}} alice invoiceId_ = do + let firstStart = addUTCTime (-5 * nominalDay) legendBoughtAt + supporter = SPApple {jws = appleSubscriptionJWS} + setClockAt bsClock $ addUTCTime 3600 firstStart + appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" firstStart 1 + case invoiceId_ of + Nothing -> do + alice ##> ("/_badge purchase 1 " <> paymentArg supporter) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + Just invoiceId -> do + alice ##> purchaseWithInvoice 1 invoiceId supporter + inAnyOrder alice [[invoicePurchase "" invoiceId], creditedLines "" invoiceId "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 + +testTierChangeReachesContacts :: HasCallStack => TestParams -> IO () +testTierChangeReachesContacts ps = do + legend <- legendInTwoHours + withBadgeServiceVerifier ps (vouchingFor legend fakeVerifier) $ \env@BadgeServiceEnv {bsClientCfg} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + raised <- supporterRaisedToLegend env alice bob + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = legend}) + expectLinesWithin 30 alice [raised] ["1: supporter", "store purchase open", "subscribed "] + heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0 + peerBadgeTypes (chatController bob) `shouldEventuallyReturn` ["legend"] + +-- | A Legend year of the fake Apple subscription bought two hours from now, which the fake store does not list. +-- Not appleLegendSubscriptionJWS: its date is fixed, and an own badge long expired by the real clock is never presented. +legendInTwoHours :: IO Text +legendInTwoHours = do + boughtAt <- addUTCTime 7200 <$> getCurrentTime + pure $ subscriptionJWS appleSubscriptionOriginalId "2000000812345699" ["purchaseDate" J..= (round (utcTimeToPOSIXSeconds boughtAt * 1000) :: Int64), "productId" J..= ("SUBSCR_BADGE_LEGEND_YEAR_01" :: Text)] + +-- | The verifier made of the fake store, vouching for jws as that store vouches for its own Legend year. +vouchingFor :: Text -> (FakeStore -> StoreVerifier) -> FakeStore -> StoreVerifier +vouchingFor jws verifierOf store@FakeStore {appleLegendSubscriptionJWS} = v {verifyApple = (\verify j -> verify $ if j == jws then appleLegendSubscriptionJWS else j) <$> verifyApple v} + where + v = verifierOf store + +-- | A monthly Apple Supporter subscription bought now and shown to bob, then the clock two hours on, past the hour the +-- purchase's store check holds an upgrade off, with the store reporting a Legend year from then: what the apps are told once it is granted. +supporterRaisedToLegend :: HasCallStack => BadgeServiceEnv -> TestCC -> TestCC -> IO String +supporterRaisedToLegend env@BadgeServiceEnv {bsClock, bsStore = store@FakeStore {appleSubscriptionJWS}} alice bob = do + connectUsers alice bob + boughtAt <- serviceNow env + appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) boughtAt) 1 + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + peerBadgeTypes (chatController bob) `shouldEventuallyReturn` ["supporter"] + let raisedAt = addUTCTime 7200 boughtAt + setClockAt bsClock raisedAt + appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_LEGEND_YEAR_01" raisedAt 12) {chargeRef = "2000000812345699"} + pure $ "1: legend, 11 months left, paid through " <> formatTime defaultTimeLocale "%Y-%m-%d" (addMonths 12 raisedAt) + +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"] + +testAppleTierChangeExpiredSettles :: HasCallStack => TestParams -> IO () +testAppleTierChangeExpiredSettles ps = + withBadgeServiceVerifier ps (vouchingFor legendForADay fakeVerifier) $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleSupporterBeforeLegend env alice + let handOver = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = legendForADay}) + 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 "] + -- once the transaction has expired 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 + where + legendForADay = subscriptionJWS appleSubscriptionOriginalId "2000000812345689" ["purchaseDate" J..= epochMs legendBoughtAt, "expiresDate" J..= epochMs (addUTCTime nominalDay legendBoughtAt), "productId" J..= ("SUBSCR_BADGE_LEGEND_YEAR_01" :: Text)] + epochMs t = round (utcTimeToPOSIXSeconds t * 1000) :: Int64 + +testAppleTierChangeHandedOverLate :: HasCallStack => TestParams -> IO () +testAppleTierChangeHandedOverLate ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleSupporterBeforeLegend env alice + appleReportsLegend store + setClockAt bsClock $ addUTCTime (2 * nominalDay) legendBoughtAt + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) + expectLinesWithin 30 alice ["1: legend"] ["1: supporter", "store purchase open", "subscribed "] + heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0 + purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["legend"] + +testAppleTierChangeAttemptsEnd :: HasCallStack => TestParams -> IO () +testAppleTierChangeAttemptsEnd ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleSupporterBeforeLegend env alice + let a = chatController alice + handOver = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) + answeredPending = expectLinesWithin 30 alice ["bad chat command: badge service error: payment_pending"] ["1: supporter", "store purchase open", "subscribed "] + attemptAt i = do + setClockAt bsClock $ addUTCTime (3600 + fromIntegral i * 3700) legendBoughtAt + alice ##> "/_app activate" + alice <## "ok" + -- the store keeps reporting Supporter, so each attempt, an hour apart, is answered payment_pending + handOver + answeredPending + forM_ [1 .. heldChargeAttempts - 1] $ \i -> do + storeReceiptRetries a `shouldEventuallyReturn` [i] + attemptAt i + answeredPending + -- set aside with no refusal recorded, and asked about no more + heldStoreReceipts a `shouldEventuallyReturn` 0 + storeReceiptCreditErrors a `shouldReturn` [] + checks <- subscriptionChecks store + attemptAt heldChargeAttempts + threadDelay 2000000 + subscriptionChecks store `shouldReturn` checks + -- the next hand-over holds it again, and it is granted once the store reports Legend + appleReportsLegend store + handOver + expectLinesWithin 30 alice ["1: legend"] ["1: supporter", "store purchase open", "subscribed "] + heldStoreReceipts a `shouldEventuallyReturn` 0 + purchaseBadgeTypes a "badge_purchases" `shouldReturn` ["legend"] + +storeReceiptRetries :: ChatController -> IO [Int64] +storeReceiptRetries ChatController {chatStore} = + withTransaction chatStore $ \db -> map fromOnly <$> DB.query_ db "SELECT retry_count FROM badge_store_receipts" + +testAppleTierChangeKeepsPurchaseShown :: HasCallStack => TestParams -> IO () +testAppleTierChangeKeepsPurchaseShown ps = do + hook <- newIORef (pure ()) + withBadgeServiceVerifier ps (subscriptionCheckWithHook hook) $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleSupporterBeforeLegend env alice + appleReportsLegend store + -- a retire, as retireBadge writes it, while the change is with the service + writeIORef hook $ withTransaction (chatStore $ chatController alice) $ \db -> do + Right user <- runExceptT $ getUser db 1 + clearShownBadge db user 1 + void $ runExceptT $ setUserBadge db user Nothing + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) + expectLinesWithin 30 alice ["1: legend"] ["1: supporter", "store purchase open", "subscribed "] + heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0 + shownBadgeId (chatController alice) `shouldReturn` Just 1 + waitShownIssued (chatController alice) + +testAppleTierChangeRefused :: HasCallStack => TestParams -> IO () +testAppleTierChangeRefused ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + invoiceId <- createInvoice alice 1 + appleSupporterBeforeLegendWith env alice (Just invoiceId) + let unvouched = subscriptionJWS appleSubscriptionOriginalId "2000000812345696" ["purchaseDate" J..= (1769904000000 :: Int64), "productId" J..= ("SUBSCR_BADGE_LEGEND_YEAR_01" :: Text)] + handOver = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = unvouched}) + checks <- subscriptionChecks store + handOver + expectLinesWithin 30 alice ["1: supporter", "bad chat command: badge service error: receipt_invalid"] ["store purchase open", "subscribed "] + heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0 + storeReceiptCreditErrors (chatController alice) `shouldReturn` ["service_error final receipt_invalid"] + (alice TestParams -> IO () +testAppleTierChangeBesideHeldReceipt ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleSupporterBeforeLegend env alice + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + expectLinesWithin 30 alice ["1: supporter", openPurchase ""] ["subscribed "] + heldStoreReceipts (chatController alice) `shouldReturn` 1 + appleReportsLegend store + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) + expectLinesWithin 30 alice ["1: legend"] ["1: supporter", "store purchase open", "subscribed "] + waitShownIssued (chatController alice) + heldStoreReceipts (chatController alice) `shouldReturn` 1 + +testAppleTierChangeClearsEnded :: HasCallStack => TestParams -> IO () +testAppleTierChangeClearsEnded ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleSupporterBeforeLegend env alice + alice ##> ("/_badge subscription ended " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + alice <### ["ok", Predicate (\l -> "1: supporter" `isPrefixOf` l && ", subscription ended" `isInfixOf` l)] + -- a monthly Legend charge, so the month it funds ends within the test + appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_LEGEND_MONTH_01" legendBoughtAt 1) {chargeRef = "apple.legend"} + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) + expectLinesWithin 30 alice ["1: legend"] ["1: supporter", "store purchase open", "subscribed "] + waitShownIssued (chatController alice) + paidThrough <- dueAtOf <$> ledgerRows (chatController alice) "badge_ledger" + (Just expiry, _) <- shownAndIssuedExpiry (chatController alice) + let pastPaidThrough = addUTCTime 3600 paidThrough + requestAt = addUTCTime (-nominalDay) expiry + pastPaidThrough `shouldSatisfy` (< requestAt) + setClockAt bsClock pastPaidThrough + alice ##> "/_app activate" + alice <## "ok" + waitWakeFrom (chatController alice) requestAt + shownBadgeId (chatController alice) `shouldReturn` Just 1 + subscriptionStatuses (chatController alice) `shouldReturn` [Nothing] + +testAppleTierChangeClearsBillingRetry :: HasCallStack => TestParams -> IO () +testAppleTierChangeClearsBillingRetry ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleSupporterBeforeLegend env alice + alice ##> ("/_badge subscription billingRetry " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + expectLinesWithin 30 alice ["ok", "1: supporter", "badge alert: payment_issue "] ["badge alert: payment_issue "] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"] + appleReportsLegend store + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) + expectLinesWithin 30 alice ["1: legend"] ["1: supporter", "store purchase open", "subscribed ", "badge alert: payment_issue "] + heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0 + subscriptionStatuses (chatController alice) `shouldReturn` [Nothing] + alice ##> "/_badge state 1" + alice <##. "1: legend" + (alice TestParams -> IO () +testAppleTierChangeCredentialUnverified ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} -> do + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> appleSupporterBeforeLegend env alice + appleReportsLegend store + -- trusting no issuer key, so the Legend credential the service issues does not verify + withTestChatCfg ps bsClientCfg {badgePublicKeys = M.empty} "alice" $ \alice -> do + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) + expectLinesWithin 30 alice ["1: supporter", "internal chat error: issued badge credential does not verify"] ["store purchase open", "subscribed "] + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["invalid_credential"] + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + shownBadgeId (chatController alice) `shouldReturn` Just 1 + +-- | A monthly Apple Legend subscription bought at legendBoughtAt, shown; the clock an hour into it. +appleLegendShown :: HasCallStack => BadgeServiceEnv -> TestCC -> IO () +appleLegendShown BadgeServiceEnv {bsClock, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} alice = do + setClockAt bsClock $ addUTCTime 3600 legendBoughtAt + appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_LEGEND_MONTH_01" legendBoughtAt 1 + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendSubscriptionJWS}) + inAnyOrder alice [[openPurchase ""], ["1: legend"]] + waitWakeArmed (chatController alice) + +testAppleTierChangeLowerWaitsForRenewal :: HasCallStack => TestParams -> IO () +testAppleTierChangeLowerWaitsForRenewal ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store@FakeStore {appleRenewalSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleLegendShown env alice + let a = chatController alice + checks <- subscriptionChecks store + -- a Supporter charge of the subscription within the window is answered from the record and sends nothing + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleRenewalSubscriptionJWS}) + alice <## "badge already redeemed" + (alice "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows a (length rows + 2) + alice <##. "1: supporter" + map (\(_, ch, m, start, tier, t) -> (ch, m, start, tier, t)) (drop (length rows) renewed) + `shouldBe` [(1, 1, supporterStart, "supporter", Just "charge"), (-1, 0, addMonths 1 supporterStart, "supporter", Just "badge")] + purchaseBadgeTypes a "badge_purchases" `shouldReturn` ["supporter"] + purchaseBadgeTypes cc "sx_badge_service_badge_purchases" `shouldReturn` ["supporter"] + issuedBadgeTypes a `shouldReturn` ["legend", "supporter"] + shownAndIssuedExpiry a >>= \(shown, issued) -> shown `shouldNotBe` issued + setClockAt bsClock presentAt + alice ##> "/_app activate" + alice <## "ok" + waitShownIssued a + +testAppleTierChangeHeldLowerSettles :: HasCallStack => TestParams -> IO () +testAppleTierChangeHeldLowerSettles ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleRenewalSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + appleLegendShown env alice + let a = chatController alice + now <- serviceNow env + -- held directly, as the hand-over no longer holds a lower tier + withTransaction (chatStore a) $ \db -> do + Right user <- runExceptT $ getUser db 1 + [(receiptId, purchaseId)] <- DB.query_ db "SELECT badge_store_receipt_id, badge_purchase_id FROM badge_purchases" + reholdStoreReceipt db user receiptId purchaseId SHKTierChange SPApple {jws = appleRenewalSubscriptionJWS} now `shouldReturn` True + checks <- subscriptionChecks store + alice ##> "/_app activate" + alice <## "ok" + heldStoreReceipts a `shouldEventuallyReturn` 0 + (alice BadgeServiceEnv -> TestCC -> IO UTCTime +appleSubscriptionRetired env@BadgeServiceEnv {bsClock, bsStore = store@FakeStore {appleSubscriptionJWS}} alice = do + firstStart <- addUTCTime (-3600) <$> serviceNow env + 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) + (requestAt, _) <- renewalMoments <$> ledgerRows (chatController alice) "badge_ledger" + appleStoreReports store $ subscriptionCheck SSEnded Nothing + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: subscription_ended ", + StartsWith "1: supporter", + StartsWith "badge alert: subscription_ended " + ] + waitShownBadge (chatController alice) Nothing + pure requestAt + +appleStoreReports :: FakeStore -> SubscriptionCheck -> IO () +appleStoreReports store = setSubscription store (SubscriptionApple appleSubscriptionOriginalId) + +-- | Another transaction of appleSubscriptionOriginalId's subscription, bought at the time given for a month. +appleResubscription :: Text -> UTCTime -> Text +appleResubscription txId bought = appleTransactionDated txId bought (addMonths 1 bought) + +appleTransactionDated :: Text -> UTCTime -> UTCTime -> Text +appleTransactionDated txId bought expires = + subscriptionJWS appleSubscriptionOriginalId txId ["purchaseDate" J..= epochMs bought, "expiresDate" J..= epochMs expires] + where + epochMs t = round (utcTimeToPOSIXSeconds t * 1000) :: Int64 + +storeReceiptCreditErrors :: ChatController -> IO [Text] +storeReceiptCreditErrors ChatController {chatStore} = + withTransaction chatStore $ \db -> map fromOnly <$> DB.query_ db "SELECT credit_error FROM badge_store_receipts WHERE credit_error IS NOT NULL" + +testApplePurchaseChecksBounded :: HasCallStack => TestParams -> IO () +testApplePurchaseChecksBounded ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleRenewalSubscriptionJWS, appleSecondSubscriptionJWS, appleThirdSubscriptionJWS}} -> do + now <- serviceNow env + let ended originalId = setSubscription store (SubscriptionApple originalId) $ subscriptionCheck SSEnded $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1 + present (purchaseKey, masterKey) jws = refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey SPApple {jws}) + heldOff (code, retryAfter) = code == BSEPaymentPending && maybe False (\t -> t > 3540 && t <= 3600) retryAfter + ended appleSubscriptionOriginalId + ended appleSecondSubscriptionOriginalId + keys <- newPurchaseKeys + otherKeys <- newPurchaseKeys + checks <- subscriptionChecks store + firstCheck <- testClockTime bsClock + present keys appleSubscriptionJWS `shouldReturn` (BSEPaymentPending, Just 86400) + subscriptionChecks store `shouldReturn` checks + 1 + present keys appleSubscriptionJWS >>= (`shouldSatisfy` heldOff) + present otherKeys appleSubscriptionJWS >>= (`shouldSatisfy` heldOff) + present keys appleRenewalSubscriptionJWS >>= (`shouldSatisfy` heldOff) + subscriptionChecks store `shouldReturn` checks + 1 + present keys appleSecondSubscriptionJWS `shouldReturn` (BSEPaymentPending, Just 86400) + subscriptionChecks store `shouldReturn` checks + 2 + -- an answer that would bring the client back sooner carries the hour its claim is held for + present keys appleThirdSubscriptionJWS `shouldReturn` (BSEProviderUnavailable, Just 3600) + subscriptionChecks store `shouldReturn` checks + 3 + setClockAt bsClock $ addUTCTime 3700 firstCheck + present otherKeys appleSubscriptionJWS `shouldReturn` (BSEPaymentPending, Just 86400) + subscriptionChecks store `shouldReturn` checks + 4 + nothingPurchased cc + +testPlayPurchaseChecksBounded :: HasCallStack => TestParams -> IO () +testPlayPurchaseChecksBounded ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do + let token n = "fake-play-token-bounded-" <> n <> ".AO-J1Om8l3biV8pPk4" + reports t = setSubscription store (SubscriptionGoogle t) + payment = googlePayment "subscr_badge_supporter_01" + present (purchaseKey, masterKey) t = refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey $ payment t) + heldOff (code, retryAfter) = code == BSEPaymentPending && maybe False (\s -> s > 3540 && s <= 3600) retryAfter + waiting = subscriptionCheck SSBillingRetry Nothing + now <- serviceNow env + reports (token "1") waiting + reports (token "2") waiting + reports (token "3") waiting + reports (token "4") $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" (addUTCTime 3600 now) 1 + keys <- newPurchaseKeys + otherKeys <- newPurchaseKeys + checks <- subscriptionChecks store + firstCheck <- testClockTime bsClock + present keys (token "1") `shouldReturn` (BSEPaymentPending, Just 86400) + subscriptionChecks store `shouldReturn` checks + 1 + present keys (token "1") >>= (`shouldSatisfy` heldOff) + present otherKeys (token "1") >>= (`shouldSatisfy` heldOff) + subscriptionChecks store `shouldReturn` checks + 1 + present keys (token "2") `shouldReturn` (BSEPaymentPending, Just 86400) + subscriptionChecks store `shouldReturn` checks + 2 + -- answers that would bring the client back sooner carry the hour the token is held for + setGoogleDown store True + present keys (token "3") `shouldReturn` (BSEProviderUnavailable, Just 3600) + setGoogleDown store False + present keys (token "4") `shouldReturn` (BSEPaymentPending, Just 3600) + subscriptionChecks store `shouldReturn` checks + 4 + setClockAt bsClock $ addUTCTime 3700 firstCheck + present otherKeys (token "1") `shouldReturn` (BSEPaymentPending, Just 86400) + subscriptionChecks store `shouldReturn` checks + 5 + nothingPurchased cc + -- a token credited to one key is held for another key too, and its own key is answered from the record + creditedAt <- serviceNow env + reports (token "5") $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" (addUTCTime (-3600) creditedAt) 1 + (creditKey, creditMasterKey) <- newPurchaseKeys + credited <- serviceCmd env creditKey (purchaseCmd creditMasterKey $ payment $ token "5") + credentialOf credited `shouldSatisfy` isJust + subscriptionChecks store `shouldReturn` checks + 6 + present otherKeys (token "5") >>= (`shouldSatisfy` heldOff) + credentialOf <$> serviceCmd env creditKey (purchaseCmd creditMasterKey $ payment $ token "5") `shouldReturn` credentialOf credited + subscriptionChecks store `shouldReturn` checks + 6 + setClockAt bsClock $ addUTCTime 3700 creditedAt + present otherKeys (token "5") `shouldReturn` (BSEReceiptUsed, Nothing) + subscriptionChecks store `shouldReturn` checks + 7 + +testPurchaseChecksBounded :: HasCallStack => TestParams -> IO () +testPurchaseChecksBounded _ = do + PurchaseChecks {appleChecks = checks, googleChecks} <- newPurchaseChecks + now <- getCurrentTime + let waitAt t ref = atomically $ purchaseCheckWait checks t (purchaseClaim ref) + purchaseClaim ref = ClaimKey {claimRef = ref, claimPurpose = ClaimPurchase} + size = M.size <$> readTVarIO checks + waitAt now "claim" `shouldReturn` Nothing + waitAt (addUTCTime 600 now) "claim" `shouldReturn` Just 3000 + forM_ [2 .. maxPurchaseChecks] $ \i -> waitAt now (tshow i) `shouldReturn` Nothing + size `shouldReturn` maxPurchaseChecks + waitAt now "new" `shouldReturn` Nothing + waitAt now "new" `shouldReturn` Nothing + size `shouldReturn` maxPurchaseChecks + atomically (purchaseCheckWait googleChecks now (purchaseClaim "play claim")) `shouldReturn` Nothing + atomically (purchaseCheckWait googleChecks now (purchaseClaim "play claim")) `shouldReturn` Just 3600 + -- a restore is not held off by the purchase's own check of the same subscription + atomically (purchaseCheckWait googleChecks now ClaimKey {claimRef = "play claim", claimPurpose = ClaimTransfer}) `shouldReturn` Nothing + M.size <$> readTVarIO googleChecks `shouldReturn` 2 + waitAt (addUTCTime 3600 now) "new" `shouldReturn` Nothing + size `shouldReturn` 1 + +testPlayReadsBounded :: HasCallStack => TestParams -> IO () +testPlayReadsBounded _ = do + PurchaseChecks {playReads = taken} <- newPurchaseChecks + now <- getCurrentTime + let readAt t = atomically $ playReadWait taken t + nextMinute = addUTCTime 60 now + forM_ [1 .. maxPlayPurchaseReads] $ \_ -> readAt now `shouldReturn` Nothing + readAt now `shouldReturn` Just 60 + readAt (addUTCTime 30 now) `shouldReturn` Just 30 + readAt nextMinute `shouldReturn` Nothing + forM_ [2 .. maxPlayPurchaseReads] $ \_ -> readAt nextMinute `shouldReturn` Nothing + readAt nextMinute `shouldReturn` Just 60 + +testPlayPurchaseReadsLimited :: HasCallStack => TestParams -> IO () +testPlayPurchaseReadsLimited ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsPurchaseChecks = PurchaseChecks {playReads = taken}, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do + let token n = "fake-play-token-reads-" <> n <> ".AO-J1Om8l3biV8pPk4" + play = googlePayment "subscr_badge_supporter_01" . token + present (purchaseKey, masterKey) payment = refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey payment) + heldOff (code, retryAfter) = code == BSEPaymentPending && maybe False (\s -> s > 3540 && s <= 3600) retryAfter + readRefused (code, retryAfter) = code == BSERateLimited && maybe False (\s -> s >= 1 && s <= 60) retryAfter + useUpReads = do + wait_ <- testClockTime bsClock >>= atomically . playReadWait taken + when (isNothing wait_) useUpReads + now <- serviceNow env + setSubscription store (SubscriptionGoogle $ token "A") $ subscriptionCheck SSBillingRetry Nothing + setSubscription store (SubscriptionGoogle $ token "B") $ subscriptionCheck SSBillingRetry Nothing + setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSEnded $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1 + keys <- newPurchaseKeys + checks <- subscriptionChecks store + present keys (play "A") `shouldReturn` (BSEPaymentPending, Just 86400) + firstReadAfter <- testClockTime bsClock + subscriptionChecks store `shouldReturn` checks + 1 + useUpReads + present keys (play "A") >>= (`shouldSatisfy` heldOff) + present keys (play "B") >>= (`shouldSatisfy` readRefused) + subscriptionChecks store `shouldReturn` checks + 1 + present keys SPApple {jws = appleSubscriptionJWS} `shouldReturn` (BSEPaymentPending, Just 86400) + subscriptionChecks store `shouldReturn` checks + 2 + setClockAt bsClock $ addUTCTime 61 firstReadAfter + present keys (play "B") `shouldReturn` (BSEPaymentPending, Just 86400) + subscriptionChecks store `shouldReturn` checks + 3 + nothingPurchased cc + +-- | Apple's production host answers 404 for a Sandbox transaction, so the offline check refuses it first. +testAppleSandboxSubscriptionNotAsked :: HasCallStack => TestParams -> IO () +testAppleSandboxSubscriptionNotAsked ps = do + chain <- trustedChain + withFakeAppStore ourBundleId $ \fake -> do + Right check <- appleSubscriptionChecker (rootCert chain :| []) ourBundleId (fasApi fake) + let checkApple ref _ = case ref of + SubscriptionApple originalId -> check originalId + SubscriptionGoogle _ -> pure $ Left SRNotConfigured + verifier = noStoreVerifier {verifyApple = Just (verifyAppleTransaction (rootCert chain :| []) ourBundleId), checkSubscription = Just checkApple} + withBadgeServiceVerifier ps (const verifier) $ \env@BadgeServiceEnv {bsController = cc} -> do + jws <- signedBy chain $ subscriptionPayload [("environment", "Sandbox")] [] + (purchaseKey, masterKey) <- newPurchaseKeys + refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey SPApple {jws}) `shouldReturn` (BSETestPurchase, Nothing) + readTVarIO (fasTokens fake) `shouldReturn` [] + nothingPurchased cc + +testAppleSubscriptionWithoutApiKey :: HasCallStack => TestParams -> IO () +testAppleSubscriptionWithoutApiKey ps = do + chain <- trustedChain + createDirectoryIfMissing True "tests/tmp" + withTempDirectory "tests/tmp" "apple-no-api-key" $ \d -> do + B.writeFile (d "root.cer") (encodeSignedObject $ rootCert chain) + writeFile (d "badge_service.ini") "[listener]\nstatic_dir = /srv/badges\n" + Right cfg <- readServiceConfig (d "badge_service.ini") + let apple = AppleStoreConfig {aBundleId = ourBundleId, aRootCertificates = (d "root.cer") :| [], aServerApi = Nothing} + ServiceState {storeVerifier} <- newServiceState >>= configureStoreVerifier (Just cfg {appleStore = Just apple}) + withBadgeServiceVerifier ps (const storeVerifier) $ \env@BadgeServiceEnv {bsController = cc} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + subscription <- signedBy chain $ subscriptionPayload [] [] + let presentSubscription = refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey SPApple {jws = subscription}) + presentSubscription `shouldReturn` (BSEProviderNotConfigured, Nothing) + presentSubscription `shouldReturn` (BSEProviderNotConfigured, Nothing) + nothingPurchased cc + oneTime <- signedBy chain $ transactionPayload [] [] + badgeTypeOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey SPApple {jws = oneTime}) `shouldReturn` Just BTSupporter + +testPlaySubscriptionAcknowledgedBeforeCrediting :: HasCallStack => TestParams -> IO () +testPlaySubscriptionAcknowledgedBeforeCrediting ps = do + oneTimeAcknowledged <- newIORef [] + acknowledged <- newIORef [] + acknowledgement <- newIORef $ Left $ SRUnreachable "acknowledging: fake store is down" + let acknowledging store = + (fakeVerifier store) + { acknowledgeGoogle = Just $ \_ token -> modifyIORef' oneTimeAcknowledged (token :) >> pure (Right ()), + acknowledgeGoogleSubscription = Just $ \productId token -> modifyIORef' acknowledged ((productId, token) :) >> readIORef acknowledgement + } + withBadgeServiceVerifier ps acknowledging $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore} -> do + now <- serviceNow env + (purchaseKey, masterKey) <- newPurchaseKeys + let purchase = serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay + chargedFrom start = setSubscription bsStore (SubscriptionGoogle googleSubscriptionToken) $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" start 1 + -- the token is held an hour after each attempt + nextHour = testClockTime bsClock >>= setClockAt bsClock . addUTCTime 3700 + -- only a charge about to be credited is acknowledged + chargedFrom $ addUTCTime 3600 now + fst . refusalOf <$> purchase `shouldReturn` BSEPaymentPending + readIORef acknowledged `shouldReturn` [] + chargedFrom $ addUTCTime (-3600) now + nextHour + refusalOf <$> purchase >>= (`shouldSatisfy` \(code, retryAfter) -> code == BSEProviderUnavailable && isJust retryAfter) + writeIORef acknowledgement $ Left $ SRVerifierFailed "acknowledging: the service account lacks the Play Console permission for this call" + nextHour + refusalOf <$> purchase `shouldReturn` (BSEInternal, Nothing) + nothingPurchased cc + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 0 + writeIORef acknowledgement $ Right () + nextHour + purchased <- purchase + subscriptionOf purchased `shouldBe` Just SSRenewing + replayed <- purchase + credentialOf replayed `shouldBe` credentialOf purchased + readIORef acknowledged `shouldReturn` replicate 3 ("subscr_badge_supporter_01", googleSubscriptionToken) + readIORef oneTimeAcknowledged `shouldReturn` [] + +-- | The service as deployed with [google], against a Play that answers as its documentation says. +testPlaySubscriptionThroughPlay :: HasCallStack => TestParams -> IO () +testPlaySubscriptionThroughPlay ps = + withFakePlay $ \fake@FakePlay {fpConfig} -> do + let ini = takeDirectory (gServiceAccountFile fpConfig) "badge_service.ini" + writeFile ini "[listener]\nstatic_dir = /srv/badges\n" + Right cfg <- readServiceConfig ini + ServiceState {storeVerifier = withoutPlay} <- newServiceState >>= configureStoreVerifier (Just cfg) + ServiceState {storeVerifier} <- newServiceState >>= configureStoreVerifier (Just cfg {playStore = Just fpConfig}) + withBadgeServiceVerifier ps (const storeVerifier) $ \env@BadgeServiceEnv {bsController = cc} -> do + periodEnd <- addMonths 1 . addUTCTime (-3600) <$> serviceNow env + answerPurchase fake googleSubscriptionToken $ PlayRecord $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [("expiryTime", J.toJSON periodEnd)] []] + (purchaseKey, masterKey) <- newPurchaseKeys + refusalOf <$> serviceCmd env {bsVerifier = withoutPlay} purchaseKey (purchaseCmd masterKey subscriptionPlay) `shouldReturn` (BSEProviderNotConfigured, Nothing) + nothingPurchased cc + readTVarIO (fpPurchasePaths fake) `shouldReturn` [] + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay + map entryTag (fst $ statementOf purchased) `shouldBe` ["charge", "badge"] + -- Play reports no period start, so the month is granted the plan's length before the period ends + map createdAtOf (take 1 $ fst $ statementOf purchased) `shouldBe` [addMonths (-1) periodEnd] + badgeTypeOf purchased `shouldBe` Just BTSupporter + subscriptionOf purchased `shouldBe` Just SSRenewing + subscriptionPayments cc `shouldReturn` [("google", googlePurchaseRef googleSubscriptionToken, Just "renewing", Just googleSubscriptionToken)] + readTVarIO (fpSubscriptionAcknowledged fake) `shouldReturn` [("subscr_badge_supporter_01", googleSubscriptionToken)] + answerPurchase fake googleSupporterToken $ PlayRecord $ purchaseRecord 0 [] + (oneTimeKey, oneTimeMasterKey) <- newPurchaseKeys + badgeTypeOf <$> serviceCmd env oneTimeKey (purchaseCmd oneTimeMasterKey supporterPlay) `shouldReturn` Just BTSupporter + readTVarIO (fpAcknowledged fake) `shouldReturn` [googleSupporterToken] + readTVarIO (fpSubscriptionAcknowledged fake) `shouldReturn` [("subscr_badge_supporter_01", googleSubscriptionToken)] + +testMockSubscriptions :: HasCallStack => TestParams -> IO () +testMockSubscriptions ps = + withBadgeServiceVerifierIO ps (\clock _ -> newMockStoreVerifier (testClockTime clock)) $ \env@BadgeServiceEnv {bsClock, bsVerifier} -> do + now <- serviceNow env + let purchase payment = newPurchaseKeys >>= \(purchaseKey, masterKey) -> (purchaseKey,) <$> serviceCmd env purchaseKey (purchaseCmd masterKey payment) + changes = map (\e -> let (c, m, _) = entryOf e in (c, m)) . fst . statementOf + chargedAMinuteAgo r = case fst (statementOf r) of + charge : _ -> abs (diffUTCTime (createdAtOf charge) (addUTCTime (-60) now)) < 2 + [] -> False + appleJWS fields = unsignedJWS $ LB.toStrict $ J.encode $ J.object fields + playSubscription = googlePayment "subscr_badge_supporter_01" + -- Apple: the plan the product names + (_, apple) <- purchase SPApple {jws = appleJWS ["transactionId" J..= ("2000000900000011" :: Text), "originalTransactionId" J..= ("2000000900000010" :: Text), "type" J..= ("Auto-Renewable Subscription" :: Text), "productId" J..= ("SUBSCR_BADGE_SUPPORTER_YEAR_01" :: Text)]} + changes apple `shouldBe` [(12, 12), (-1, 11)] + subscriptionOf apple `shouldBe` Just SSRenewing + chargedAMinuteAgo apple `shouldBe` True + -- Play: the base plan a test token names, else the product's monthly plan + (_, testToken) <- purchase $ playSubscription "test.subscr-badge-supporter-year-01.3f2c9a1e-7d4b-4c55-9a0e-6b1f2d3c4e5f" + changes testToken `shouldBe` [(12, 12), (-1, 11)] + (monthlyKey, monthly) <- purchase $ playSubscription googleSubscriptionToken + changes monthly `shouldBe` [(1, 1), (-1, 0)] + subscriptionOf monthly `shouldBe` Just SSRenewing + chargedAMinuteAgo monthly `shouldBe` True + (forgottenKey, forgotten) <- purchase $ playSubscription "fake-play-token-forgotten.AO-J1Oq1n0dkW9pRl5" + -- a renewal of one it credited is charged again; one a restarted mock never saw has ended + setClockAt bsClock $ addUTCTime nominalDay $ addMonths 1 now + renewed <- assertBalance env monthlyKey (last $ fst $ statementOf monthly) + map entryTag (fst $ statementOf renewed) `shouldBe` ["charge", "badge"] + subscriptionOf renewed `shouldBe` Just SSRenewing + restarted <- newMockStoreVerifier (testClockTime bsClock) + ended <- serviceCmd env {bsVerifier = restarted} forgottenKey BSCIssueBadge {balance = BadgeBalance {lastEntry = last $ fst $ statementOf forgotten}} + subscriptionOf ended `shouldBe` Just SSEnded + credentialOf ended `shouldBe` Nothing + -- a first purchase naming no plan it knows is not a verdict + checkStoreSubscription bsVerifier (SubscriptionApple "2000000900000020") (Just "BADGE_SUPPORTER_01") >>= (`shouldSatisfy` \case Left SRUnreachable {} -> True; _ -> False) + -- a one-time purchase, as before + (_, oneTime) <- purchase SPApple {jws = appleJWS ["transactionId" J..= ("2000000900000030" :: Text), "productId" J..= ("BADGE_SUPPORTER_01" :: Text)]} + badgeTypeOf oneTime `shouldBe` Just BTSupporter + +testStoreChecksDuringCoverage :: HasCallStack => TestParams -> IO () +testStoreChecksDuringCoverage ps = + withBadgeServiceVerifierIO ps (\clock _ -> checkingAtEveryRequest <$> newMockStoreVerifier (testClockTime clock)) $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do + now <- serviceNow env + (purchaseKey, masterKey) <- newPurchaseKeys + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey $ googlePayment "subscr_badge_supporter_01" googleSubscriptionToken + let entries = fst . statementOf + request r = assertBalance env purchaseKey (last $ entries r) + stampedSince t previous = do + [Just checkedAt] <- subscriptionCheckedAt cc + checkedAt `shouldSatisfy` \c -> c >= t && c > previous + pure checkedAt + bankedAt = addUTCTime 120 now + renewedAt = addUTCTime nominalDay $ addMonths 1 now + endedAt = addUTCTime 60 renewedAt + [Just purchaseStamp] <- subscriptionCheckedAt cc + -- over a minute on, as the mock dates its charge a minute back and the client fails a row dated before the tip + setClockAt bsClock bankedAt + banked <- request purchased + bankedStamp <- stampedSince bankedAt purchaseStamp + map entryTag (entries banked) `shouldBe` ["charge"] + -- a month granted on the running coverage: one left, paid through a month later + entryOf (last $ entries banked) `shouldBe` (1, 1, nextDue (entries purchased)) + credentialOf banked `shouldBe` credentialOf purchased + subscriptionOf banked `shouldBe` Just SSRenewing + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 2 + setClockAt bsClock renewedAt + renewed <- request banked + renewedStamp <- stampedSince renewedAt bankedStamp + map entryTag (entries renewed) `shouldBe` ["charge", "badge"] + -- the month banked earlier and the one this check banks, less the one issued + (\(c, m, _) -> (c, m)) (entryOf $ last $ entries renewed) `shouldBe` (-1, 1) + expiryOf renewed `shouldSatisfy` (> expiryOf purchased) + -- a restarted mock has forgotten the plan, so the subscription has ended though coverage runs, and the banked month is refunded + restarted <- checkingAtEveryRequest <$> newMockStoreVerifier (testClockTime bsClock) + setClockAt bsClock endedAt + ended <- serviceCmd env {bsVerifier = restarted} purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry = last $ entries renewed}} + void $ stampedSince endedAt renewedStamp + (credentialOf ended, subscriptionOf ended) `shouldBe` (Nothing, Just SSEnded) + map entryTag (entries ended) `shouldBe` ["refund"] + (\(c, m, _) -> (c, m)) (entryOf $ last $ entries ended) `shouldBe` (-1, 0) + -- with nothing left to refund, a later request that month writes no row + setClockAt bsClock $ addUTCTime 60 endedAt + again <- serviceCmd env {bsVerifier = restarted} purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry = last $ entries ended}} + (credentialOf again, subscriptionOf again) `shouldBe` (Nothing, Just SSEnded) + map entryTag (entries again) `shouldBe` [] + where + checkingAtEveryRequest v = v {storeChecks = ChecksAtEveryRequest} + +testStoreChecksDuringCoverageGrantedOnce :: HasCallStack => TestParams -> IO () +testStoreChecksDuringCoverageGrantedOnce ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store} -> do + (purchaseKey, _, purchased) <- subscribedMonthly env + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + checks <- subscriptionChecks store + answered <- serviceCmd env {bsVerifier = (fakeVerifier store) {storeChecks = ChecksAtEveryRequest}} purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry = last purchased}} + subscriptionChecks store `shouldReturn` checks + 1 + map entryTag (fst $ statementOf answered) `shouldBe` [] + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1 + +testBankedMonthAnnounced :: HasCallStack => TestParams -> IO () +testBankedMonthAnnounced ps = + withRequestCountingService ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg {badgeDevRequestInterval = Just 600} "alice" aliceProfile $ \alice -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + let t1 = devIntervalStart rows + paidThrough = addMonths 2 firstStart + storeReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-supporter-month-02" (addUTCTime (-60) t1) 1) {chargeRef = "GPA.banked"} + setClockAt bsClock t1 + alice `send` "/_app activate" + expectLinesWithin 30 alice ["/_app activate", "ok", "1: supporter, 1 months left, paid through " <> day paidThrough] ["subscribed "] + drop 2 . rowChanges <$> ledgerRows (chatController alice) "badge_ledger" `shouldReturn` [(1, 1, dueAtOf rows, Just "charge")] + where + day = formatTime defaultTimeLocale "%Y-%m-%d" + testPurchaseBadge :: HasCallStack => TestParams -> IO () testPurchaseBadge ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> @@ -2059,6 +5480,119 @@ testInvoiceOtherProfile ps = alice ##> "/user alice" showActiveUser alice "alice (Alice, * supporter)" +-- | The store lists an account's purchases on every device signed into it, so a listed one may be another device's. +testListedReceiptNotRecorded :: HasCallStack => TestParams -> IO () +testListedReceiptNotRecorded ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + let listed invoiceId_ payment = "/_badge purchase 1" <> maybe "" (" invoice=" <>) invoiceId_ <> " listed " <> paymentArg payment + alice ##> listed (Just "0b6a5e6c-4f3e-4d51-9f55-3a0f7c2f9e11") supporterPlay + alice <## "store purchase not recorded" + storeReceiptRows (chatController alice) `shouldReturn` [] + nothingPurchased cc + invoiceId <- createInvoice alice 1 + alice ##> listed (Just invoiceId) supporterPlay + inAnyOrder alice [[invoicePurchase "" invoiceId], creditedLines "" invoiceId "1: supporter"] + alice ##> listed Nothing supporterPlay + alice <## "badge already redeemed" + alice ##> listed Nothing subscriptionPlay + alice <## "store purchase not recorded" + storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack invoiceId), True)] + -- unmarked, as Restore sends it, the same transaction is recorded; held, as a badge is shown + alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + alice <##. "1: supporter" + storePurchaseOpen alice "" + storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack invoiceId), True), (1, Nothing, True)] + heldStoreReceipts (chatController alice) `shouldReturn` 1 + rowCount cc "sx_badge_service_payments" `shouldReturn` 1 + +-- | A badge redeemed over a held receipt would leave the receipt waiting behind it. With no subscription check +-- the service refuses a subscription for good, though not as a refused receipt, so the record stays held. +testRedeemRefusedWhileReceiptHeld :: HasCallStack => TestParams -> IO () +testRedeemRefusedWhileReceiptHeld ps = + withBadgeServiceVerifier ps (\store -> (fakeVerifier store) {checkSubscription = Nothing}) $ \BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = FakeStore {appleSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + let refused cmd = do + alice ##> cmd + alice <## "cannot get badge: store purchase open" + finalError = "service_error final provider_not_configured" + alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken)) + storePurchaseOpen alice "" + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"] + code <- issueCode cc BTSupporter 1 + refused $ "/_redeem_badge_code 1 " <> codeArg code + rowCount (chatController alice) "badge_code_redemptions" `shouldReturn` 0 + nothingPurchased cc + refused "/_badge invoice 1" + storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)] + -- a Play receipt that failed for good does not block + alice ##> "/create user alisa" + showActiveUser alice "alisa" + alice ##> ("/_badge purchase 2 " <> paymentArg subscriptionPlay) + storePurchaseOpen alice "" + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending", finalError] + alice ##> ("/_redeem_badge_code 2 " <> codeArg code) + alice <## "badge redeemed" + alice <## "supporter badge - active" + alice <##. "expires " + -- an Apple subscription that failed for good still blocks, as Apple keeps charging it + alice ##> "/create user alina" + showActiveUser alice "alina" + alice ##> ("/_badge purchase 3 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + storePurchaseOpen alice "" + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending", finalError, finalError] + issueCode cc BTSupporter 1 >>= \code' -> refused ("/_redeem_badge_code 3 " <> codeArg code') + refused "/_badge invoice 3" + +-- | A first Apple purchase refunded while the service could not credit it: Apple charges it no more after its expiry. +testLapsedAppleChargeStopsBlocking :: HasCallStack => TestParams -> IO () +testLapsedAppleChargeStopsBlocking ps = + withBadgeServiceVerifier ps (\store -> (fakeVerifier store) {verifyApple = Nothing}) $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + let a = chatController alice + openPurchases = + sendChatCmdStr a "/_badge state 1" >>= \case + Right (CRBadgeState _ _ open) -> pure $ length open + _ -> error "expected the badge state" + bought <- addUTCTime (-3600) <$> serviceNow env + let expires = addMonths 1 bought + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleTransactionDated "2000000812345690" bought expires}) + storePurchaseOpen alice "" + heldStoreReceiptErrors a `shouldEventuallyReturn` ["service_error final provider_not_configured"] + setClockAt bsClock $ addUTCTime (nominalDay - 60) expires + code <- issueCode cc BTSupporter 1 + forM_ ["/_redeem_badge_code 1 " <> codeArg code, "/_badge invoice 1"] $ \cmd -> do + alice ##> cmd + alice <## "cannot get badge: store purchase open" + openPurchases `shouldReturn` 1 + setClockAt bsClock $ addUTCTime (nominalDay + 60) expires + openPurchases `shouldReturn` 0 + heldStoreReceipts a `shouldReturn` 1 + void $ createInvoice alice 1 + alice ##> ("/_redeem_badge_code 1 " <> codeArg code) + alice <## "badge redeemed" + alice <## "supporter badge - active" + alice <##. "expires " + dropOutput alice + +testInvoiceRefusedWhileFirstAttemptOpen :: HasCallStack => TestParams -> IO () +testInvoiceRefusedWhileFirstAttemptOpen ps = do + entered <- newEmptyMVar + release <- newEmptyMVar + hook <- newIORef $ putMVar entered () >> takeMVar release + let holding store = (googleVerifierWithHook hook store) {verifyTimeout = 60000000} + withBadgeServiceVerifier ps holding $ \BadgeServiceEnv {bsClientCfg} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + storePurchaseOpen alice "" + timeout 30000000 (takeMVar entered) `shouldReturn` Just () + heldStoreReceipts (chatController alice) `shouldReturn` 1 + heldStoreReceiptErrors (chatController alice) `shouldReturn` [] + alice ##> "/_badge invoice 1" + alice <## "cannot get badge: store purchase open" + putMVar release () + expectLinesWithin 60 alice ["1: supporter"] [] + testInvoiceUnknown :: HasCallStack => TestParams -> IO () testInvoiceUnknown ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg} -> @@ -2174,9 +5708,11 @@ testStoreReceiptNotBlocked ps = alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) storePurchaseOpen alice "" heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry provider_unavailable"] - invoiceId <- createInvoice alice 1 - alice ##> purchaseWithInvoice 1 invoiceId SPApple {jws = appleSupporterJWS} - inAnyOrder alice [[openPurchase "", invoicePurchase "" invoiceId], creditedLines "" invoiceId "1: supporter"] + alice ##> "/_badge invoice 1" + alice <## "cannot get badge: store purchase open" + -- handed over with no invoice, as Restore sends it, so no settlement is announced + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS}) + inAnyOrder alice [[openPurchase "", openPurchase ""], ["1: supporter"]] heldStoreReceipts (chatController alice) `shouldReturn` 1 testStoreRefusalKept :: HasCallStack => TestParams -> IO () @@ -2342,6 +5878,180 @@ testPlayHoldsNoOtherRequest ps = do expectLinesWithin 60 alice ["1: supporter"] [] rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 3 +testStoreChecksConfigured :: HasCallStack => TestParams -> IO () +testStoreChecksConfigured _ = do + createDirectoryIfMissing True "tests/tmp" + withTempDirectory "tests/tmp" "store-checks" $ \d -> do + writeFile (d "badge_service.ini") "[listener]\nstatic_dir = /srv/badges\n" + Right cfg <- readServiceConfig (d "badge_service.ini") + let checksFor c = (\ServiceState {storeVerifier} -> storeChecks storeVerifier) <$> (newServiceState >>= configureStoreVerifier c) + creditsFor c = (\ServiceState {storeVerifier} -> creditTestPurchases storeVerifier) <$> (newServiceState >>= configureStoreVerifier c) + dev accept during credit = Just cfg {devAcceptUnverifiedStoreReceipts = accept, devCheckStoreDuringCoverage = during, devCreditTestPurchases = credit} + checksFor Nothing `shouldReturn` ChecksAfterCoverage + checksFor (dev False False False) `shouldReturn` ChecksAfterCoverage + checksFor (dev True False False) `shouldReturn` ChecksAfterCoverage + -- refused by the parser, and still not armed if set by hand + checksFor (dev False True False) `shouldReturn` ChecksAfterCoverage + checksFor (dev True True False) `shouldReturn` ChecksAtEveryRequest + checksFor (dev False False True) `shouldReturn` ChecksAfterCoverage + checksFor (dev False True True) `shouldReturn` ChecksAtEveryRequest + creditsFor Nothing `shouldReturn` False + creditsFor (dev False False False) `shouldReturn` False + creditsFor (dev False False True) `shouldReturn` True + -- the mock never reports a test purchase + creditsFor (dev True False True) `shouldReturn` False + +testStoreRouting :: HasCallStack => TestParams -> IO () +testStoreRouting ps = + 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 + let purchase payment = routed purchaseKey $ purchaseCmd masterKey payment + purchase supporterPlay `shouldReturn` PurchaseLane + 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 + let upgrade = BadgeUpgrade {fromPurchaseKey, receipt = "receipt", receiptSignature = C.sign' fromPriv "receipt", balance = BadgeBalance {lastEntry = emptyEntry now BTSupporter}} + routed purchaseKey BSCPurchaseBadge {masterKey, payment = supporterPlay, upgrade = Just upgrade} `shouldReturn` MainLane + code <- issueCode cc BTSupporter 1 + codeKeys@(codeKey, codeMasterKey) <- newPurchaseKeys + routed codeKey BSCRedeemBadgeCode {masterKey = codeMasterKey, code = badgeCodeText code} `shouldReturn` MainLane + redeemed <- redeemWithKeys env codeKeys code + routed codeKey BSCIssueBadge {balance = BadgeBalance {lastEntry = last $ fst $ statementOf redeemed}} `shouldReturn` MainLane + (subscriberKey, firstStart, purchased) <- subscribedMonthly env + let issue = BSCIssueBadge {balance = BadgeBalance {lastEntry = last purchased}} + coverageEnd = addMonths 1 firstStart + routedAt t = setClockAt bsClock t >> routed subscriberKey issue + answeredWithoutStore = do + checks <- subscriptionChecks store + _ <- assertBalance env subscriberKey (last purchased) + subscriptionChecks store `shouldReturn` checks + routedAt (addUTCTime (-90) coverageEnd) `shouldReturn` MainLane + routedAt (addUTCTime (-30) coverageEnd) `shouldReturn` RenewalLane + answeredWithoutStore + storeReports store $ subscriptionCheck SSBillingRetry Nothing + routedAt (addUTCTime 60 coverageEnd) `shouldReturn` RenewalLane + checks <- subscriptionChecks store + _ <- assertBalance env subscriberKey (last purchased) + subscriptionChecks store `shouldReturn` checks + 1 + [Just lastCheck] <- subscriptionCheckedAt cc + -- within the hour a due month still queues on the renewal lane, where it is answered from the record + routedAt (addUTCTime 3530 lastCheck) `shouldReturn` RenewalLane + 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 + entered <- newEmptyMVar + release <- newEmptyMVar + -- the purchase asks the store too, so the hold is armed once it is credited + hook <- newIORef (pure ()) + let holding store = (subscriptionCheckWithHook hook store) {verifyTimeout = 60000000} + withBadgeServiceVerifier ps holding $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store@FakeStore {appleSupporterJWS}} -> do + -- her request outlives the hold, so her pass does not give up and send it again + let patientCfg = bsClientCfg {agentConfig = (agentConfig bsClientCfg) {serviceRequestTimeout = 120}} + withNewTestChatCfg ps patientCfg "alice" aliceProfile $ \alice -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> + withNewTestChatCfg ps bsClientCfg "cath" cathProfile $ \cath -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + let (requestAt, _) = renewalMoments rows + renewalStart = addMonths 1 firstStart + writeIORef hook $ putMVar entered () >> takeMVar release + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + timeout 30000000 (takeMVar entered) `shouldReturn` Just () + code <- issueCode cc BTSupporter 1 + bob ##> ("/_redeem_badge_code 1 " <> codeArg code) + bob <## "badge redeemed" + bob <## "supporter badge - active" + bob <##. "expires " + cath ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS}) + cath <### [StartsWith (openPurchase ""), StartsWith "1: supporter"] + withNewTestChatCfg ps bsClientCfg "dan" danProfile $ \dan -> do + dan ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + dan <### [StartsWith (openPurchase ""), StartsWith "1: supporter"] + putMVar release () + alice <##. "1: supporter" + renewed <- waitLedgerRows (chatController alice) 4 + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + +testPurchaseHoldsNoRenewal :: HasCallStack => TestParams -> IO () +testPurchaseHoldsNoRenewal ps = do + entered <- newEmptyMVar + release <- newEmptyMVar + hook <- newIORef $ putMVar entered () >> takeMVar release + let holding store = (googleVerifierWithHook hook store) {verifyTimeout = 60000000} + withBadgeServiceVerifier ps holding $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + let (requestAt, _) = renewalMoments rows + renewalStart = addMonths 1 firstStart + bob ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + storePurchaseOpen bob "" + timeout 30000000 (takeMVar entered) `shouldReturn` Just () + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + alice <##. "1: supporter" + renewed <- waitLedgerRows (chatController alice) 4 + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + putMVar release () + expectLinesWithin 60 bob ["1: supporter"] [] + +testAppleSubscriptionHoldsNoOtherRequest :: HasCallStack => TestParams -> IO () +testAppleSubscriptionHoldsNoOtherRequest ps = do + entered <- newEmptyMVar + release <- newEmptyMVar + hook <- newIORef $ putMVar entered () >> takeMVar release + let holding store = (subscriptionCheckWithHook hook store) {verifyTimeout = 60000000} + withBadgeServiceVerifier ps holding $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "dan" danProfile $ \dan -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + now <- serviceNow env + setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1 + dan ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + storePurchaseOpen dan "" + timeout 30000000 (takeMVar entered) `shouldReturn` Just () + code <- issueCode cc BTSupporter 1 + bob ##> ("/_redeem_badge_code 1 " <> codeArg code) + bob <## "badge redeemed" + bob <## "supporter badge - active" + bob <##. "expires " + putMVar release () + expectLinesWithin 60 dan ["1: supporter"] [] + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 2 + createInvoice :: HasCallStack => TestCC -> Int -> IO String createInvoice cc userId = do cc ##> ("/_badge invoice " <> show userId) @@ -2362,7 +6072,7 @@ storeReceiptRows ChatController {chatStore} = storeReceiptDue :: ChatController -> Int64 -> IO Bool storeReceiptDue ChatController {chatStore} userId = withTransaction chatStore $ \db -> - getNextHeldStoreReceipt db userId >>= either (error . show) (pure . isJust) + getCurrentTime >>= getNextHeldStoreReceipt db userId >>= either (error . show) (pure . isJust) heldStoreReceipts :: ChatController -> IO Int heldStoreReceipts ChatController {chatStore} = diff --git a/tests/Bots/BadgeService/ConfigTests.hs b/tests/Bots/BadgeService/ConfigTests.hs index ce38929725..722dd453b3 100644 --- a/tests/Bots/BadgeService/ConfigTests.hs +++ b/tests/Bots/BadgeService/ConfigTests.hs @@ -5,6 +5,7 @@ module Bots.BadgeService.ConfigTests where import BadgeService.Config +import Control.Monad (forM_) import qualified Data.ByteString.Char8 as B import Data.Either (isLeft) import Data.Ini (readIniFile) @@ -53,10 +54,22 @@ badgeConfigTests = describe "badge service config" $ do it "reads accept_unverified_store_receipts = on" testDevUnverifiedReceiptsOn it "reads accept_unverified_store_receipts = off" testDevUnverifiedReceiptsOff it "refuses an accept_unverified_store_receipts that is not on or off" testDevUnverifiedReceiptsNotBoolean + it "defaults check_store_during_coverage to off" testDevStoreChecksDefault + it "reads check_store_during_coverage = on and off beside accept_unverified_store_receipts = on" testDevStoreChecksOnOff + it "refuses check_store_during_coverage = on without accept_unverified_store_receipts or credit_test_purchases on" testDevStoreChecksWithoutMock + it "defaults credit_test_purchases to off" testDevCreditTestPurchasesDefault + it "reads credit_test_purchases = on and off" testDevCreditTestPurchasesOnOff + it "refuses a credit_test_purchases that is not on or off" testDevCreditTestPurchasesNotBoolean + it "reads credit_test_purchases = on beside [google] and beside the App Store Sandbox, however its host is spelled" testDevCreditTestPurchasesBesideStores + it "refuses credit_test_purchases = on beside [apple] without the App Store Sandbox's server API, however production is spelled" testDevCreditTestPurchasesBesideApple + it "reads check_store_during_coverage = on beside credit_test_purchases = on, with no store, beside the App Store Sandbox or [google]" testDevStoreChecksWithCredit it "configures no store verifier when [apple] and [google] are absent" testStoresAbsent it "reads [apple] and [google], defaulting Google's endpoints" testStoresRead it "refuses an incomplete [apple] or [google], naming the key" testStoresIncomplete - it "refuses accept_unverified_store_receipts beside a real store verifier" testDevUnverifiedBesideVerifier + it "reads the App Store Server API key, defaulting to the production host, and a host in any case with a trailing slash" testAppleServerApi + it "refuses an App Store Server API key missing a setting, or an http host" testAppleServerApiIncomplete + it "refuses the App Store Sandbox or any other host but production with credit_test_purchases off" testAppleHostWithoutCredit + it "refuses accept_unverified_store_receipts beside a real store verifier, also with credit_test_purchases = on" testDevUnverifiedBesideVerifier groupConfigTests fullIni :: T.Text @@ -383,8 +396,71 @@ testDevUnverifiedReceiptsNotBoolean = withDev "accept_unverified_store_receipts Left e -> e `shouldContain` "accept_unverified_store_receipts" Right _ -> expectationFailure "only on and off are accepted, so a typo cannot silently arm the mock" +testDevStoreChecksDefault :: IO () +testDevStoreChecksDefault = do + withIni fullIni $ \p -> do + Right cfg <- readServiceConfig p + devCheckStoreDuringCoverage cfg `shouldBe` False + withDev "accept_unverified_store_receipts = on\n" $ \r -> devCheckStoreDuringCoverage <$> r `shouldBe` Right False + +testDevStoreChecksOnOff :: IO () +testDevStoreChecksOnOff = + forM_ [("on", True), ("off", False)] $ \(v, expected) -> + withDev ("accept_unverified_store_receipts = on\ncheck_store_during_coverage = " <> v <> "\n") $ \r -> + devCheckStoreDuringCoverage <$> r `shouldBe` Right expected + +testDevStoreChecksWithoutMock :: IO () +testDevStoreChecksWithoutMock = + forM_ ["", "accept_unverified_store_receipts = off\n", "accept_unverified_store_receipts = off\ncredit_test_purchases = off\n"] $ \devFlags -> + withDev (devFlags <> "check_store_during_coverage = on\n") $ \case + Left e -> e `shouldBe` "[dev] check_store_during_coverage needs accept_unverified_store_receipts or credit_test_purchases = on, as only a dev deployment may ask a store while coverage runs" + Right _ -> expectationFailure "only a dev deployment may ask a store while coverage runs" + +testDevCreditTestPurchasesDefault :: IO () +testDevCreditTestPurchasesDefault = do + withIni fullIni $ \p -> do + Right cfg <- readServiceConfig p + devCreditTestPurchases cfg `shouldBe` False + withDev "accept_unverified_store_receipts = on\n" $ \r -> devCreditTestPurchases <$> r `shouldBe` Right False + +testDevCreditTestPurchasesOnOff :: IO () +testDevCreditTestPurchasesOnOff = + forM_ [("on", True), ("off", False)] $ \(v, expected) -> + withDev ("credit_test_purchases = " <> v <> "\n") $ \r -> + devCreditTestPurchases <$> r `shouldBe` Right expected + +testDevCreditTestPurchasesNotBoolean :: IO () +testDevCreditTestPurchasesNotBoolean = withDev "credit_test_purchases = yes\n" $ \case + Left e -> e `shouldContain` "credit_test_purchases" + Right _ -> expectationFailure "only on and off are accepted, so a typo cannot silently credit test purchases" + +testDevCreditTestPurchasesBesideStores :: IO () +testDevCreditTestPurchasesBesideStores = + forM_ [googleIni, appleSandboxIni, appleApiHostIni "HTTPS://API.STOREKIT-SANDBOX.ITUNES.APPLE.COM/"] $ \stores -> + withDevBeside stores "credit_test_purchases = on\n" $ \r -> + devCreditTestPurchases <$> r `shouldBe` Right True + +testDevCreditTestPurchasesBesideApple :: IO () +testDevCreditTestPurchasesBesideApple = + forM_ (appleIni : appleIni <> appleApiIni : map appleApiHostIni notSandbox) $ \stores -> + forM_ ["", "check_store_during_coverage = on\n"] $ \storeChecks -> + withDevBeside stores ("credit_test_purchases = on\n" <> storeChecks) $ \case + Left e -> e `shouldContain` "[dev] credit_test_purchases = on needs [apple]'s server API key with api_host = https://api.storekit-sandbox.itunes.apple.com" + Right _ -> expectationFailure "test purchases must be credited only beside the App Store Sandbox" + where + notSandbox = ["https://api.storekit.itunes.apple.com", "HTTPS://API.STOREKIT.ITUNES.APPLE.COM", "https://api.storekit.itunes.apple.com/", "https://example.com"] + +testDevStoreChecksWithCredit :: IO () +testDevStoreChecksWithCredit = + forM_ ["", appleSandboxIni, googleIni] $ \stores -> + withDevBeside stores "credit_test_purchases = on\ncheck_store_during_coverage = on\n" $ \r -> + (\cfg -> (devCheckStoreDuringCoverage cfg, devCreditTestPurchases cfg)) <$> r `shouldBe` Right (True, True) + withDev :: T.Text -> (Either String ServiceConfig -> IO a) -> IO a -withDev keys act = withIni (fullIni <> "[dev]\n" <> keys) $ \p -> readServiceConfig p >>= act +withDev = withDevBeside "" + +withDevBeside :: T.Text -> T.Text -> (Either String ServiceConfig -> IO a) -> IO a +withDevBeside stores keys act = withIni (fullIni <> stores <> "[dev]\n" <> keys) $ \p -> readServiceConfig p >>= act appleIni, googleIni :: T.Text appleIni = "[apple]\nbundle_id = chat.simplex.app\nroot_certificates = /etc/badges/AppleRootCA-G3.cer ,/etc/badges/AppleRootCA-G4.cer,\n" @@ -399,7 +475,7 @@ testStoresAbsent = withIni fullIni $ \p -> do testStoresRead :: IO () testStoresRead = withIni (fullIni <> appleIni <> googleIni) $ \p -> do Right cfg <- readServiceConfig p - appleStore cfg `shouldBe` Just AppleStoreConfig {aBundleId = "chat.simplex.app", aRootCertificates = "/etc/badges/AppleRootCA-G3.cer" :| ["/etc/badges/AppleRootCA-G4.cer"]} + appleStore cfg `shouldBe` Just AppleStoreConfig {aBundleId = "chat.simplex.app", aRootCertificates = "/etc/badges/AppleRootCA-G3.cer" :| ["/etc/badges/AppleRootCA-G4.cer"], aServerApi = Nothing} playStore cfg `shouldBe` Just PlayStoreConfig @@ -421,15 +497,61 @@ testStoresIncomplete = do Left e -> e `shouldContain` key Right _ -> expectationFailure ("an incomplete section must fail at boot, naming " <> key) +appleApiIni :: T.Text +appleApiIni = "api_key_id = 2X9R4HXF34\napi_issuer_id = 57246542-96fe-1a63-e053-0824d011072a\napi_private_key_file = /etc/badges/AuthKey_2X9R4HXF34.p8\n" + +appleApiHostIni :: T.Text -> T.Text +appleApiHostIni host = appleIni <> appleApiIni <> "api_host = " <> host <> "\n" + +appleSandboxIni :: T.Text +appleSandboxIni = appleApiHostIni "https://api.storekit-sandbox.itunes.apple.com" + +testAppleServerApi :: IO () +testAppleServerApi = do + withIni (fullIni <> appleIni <> appleApiIni) $ \p -> do + Right cfg <- readServiceConfig p + (appleStore cfg >>= aServerApi) + `shouldBe` Just + AppleServerApi + { aKeyId = "2X9R4HXF34", + aIssuerId = "57246542-96fe-1a63-e053-0824d011072a", + aPrivateKeyFile = "/etc/badges/AuthKey_2X9R4HXF34.p8", + aApiHost = "https://api.storekit.itunes.apple.com" + } + withIni (fullIni <> appleApiHostIni "HTTPS://API.STOREKIT.ITUNES.APPLE.COM//") $ \p -> do + Right cfg <- readServiceConfig p + (aApiHost <$> (appleStore cfg >>= aServerApi)) `shouldBe` Just "https://api.storekit.itunes.apple.com" + forM_ [appleSandboxIni, appleApiHostIni "https://api.storekit-sandbox.itunes.apple.com/"] $ \stores -> + withDevBeside stores "credit_test_purchases = on\n" $ \r -> + (\cfg -> aApiHost <$> (appleStore cfg >>= aServerApi)) <$> r `shouldBe` Right (Just "https://api.storekit-sandbox.itunes.apple.com") + +-- | One or two of the key's settings would leave subscriptions unverified without a word, so they are refused. +testAppleServerApiIncomplete :: IO () +testAppleServerApiIncomplete = do + forM_ ["api_key_id", "api_issuer_id", "api_private_key_file"] $ \key -> + refused (T.unlines $ filter (not . (key `T.isPrefixOf`)) $ T.lines appleApiIni) "apple.api_key_id, apple.api_issuer_id and apple.api_private_key_file" + refused (appleApiIni <> "api_host = http://api.storekit.itunes.apple.com\n") "apple.api_host" + where + refused keys message = + withIni (fullIni <> appleIni <> keys) readServiceConfig >>= \case + Left e -> e `shouldContain` message + Right _ -> expectationFailure ("an incomplete API key must fail at boot, naming " <> message) + +testAppleHostWithoutCredit :: IO () +testAppleHostWithoutCredit = + forM_ ["https://api.storekit-sandbox.itunes.apple.com", "HTTPS://API.STOREKIT-SANDBOX.ITUNES.APPLE.COM/", "https://api.storekit.itunes.apple.com/inApps", "https://example.com"] $ \host -> + forM_ ["", "[dev]\ncredit_test_purchases = off\n"] $ \dev -> + withIni (fullIni <> appleApiHostIni host <> dev) readServiceConfig >>= \case + Left e -> e `shouldContain` "apple.api_host must be https://api.storekit.itunes.apple.com unless [dev] credit_test_purchases = on" + Right _ -> expectationFailure "a deployment that credits no test purchases must ask the production App Store" + testDevUnverifiedBesideVerifier :: IO () testDevUnverifiedBesideVerifier = - mapM_ - ( \stores -> - withIni (fullIni <> stores <> "[dev]\naccept_unverified_store_receipts = on\n") readServiceConfig >>= \case - Left e -> e `shouldContain` "accept_unverified_store_receipts" - Right _ -> expectationFailure "a service that verifies store receipts must not also accept unverified ones" - ) - [appleIni, googleIni] + forM_ [appleIni, googleIni] $ \stores -> + forM_ ["", "credit_test_purchases = on\n"] $ \credit -> + withDevBeside stores ("accept_unverified_store_receipts = on\n" <> credit) $ \case + Left e -> e `shouldContain` "accept_unverified_store_receipts" + Right _ -> expectationFailure "a service that verifies store receipts must not also accept unverified ones" parseIni :: T.Text -> IO (Either String ServiceConfig) parseIni t = withIni t readServiceConfig diff --git a/tests/Bots/BadgeService/FakeAppStore.hs b/tests/Bots/BadgeService/FakeAppStore.hs new file mode 100644 index 0000000000..01346d6666 --- /dev/null +++ b/tests/Bots/BadgeService/FakeAppStore.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Bots.BadgeService.FakeAppStore + ( FakeAppStore (..), + AppStoreAnswer (..), + withFakeAppStore, + answerStatus, + writeApiKey, + ) +where + +import BadgeService.Config (AppleServerApi (..)) +import Bots.BadgeService.FakePlay (der, pem) +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Monad (forever) +import Crypto.Hash.Algorithms (SHA256 (..)) +import Crypto.Number.Serialize (i2ospOf_, os2ip) +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Generate as ECC +import qualified Crypto.PubKey.ECC.Types as ECC +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import Network.HTTP.Types (Status, hAuthorization, hContentType, methodGet, mkStatus, notFound404, ok200, unauthorized401) +import Network.Wai (Application, Response, pathInfo, requestHeaders, requestMethod, responseLBS) +import qualified Network.Wai.Handler.Warp as Warp +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import UnliftIO.Temporary (withTempDirectory) + +data AppStoreAnswer = AppStoreBody J.Value | AppStoreStatus Int | AppStoreHang + +data FakeAppStore = FakeAppStore + { fasApi :: AppleServerApi, + fasAnswers :: TVar (M.Map Text AppStoreAnswer), + -- the bearer token of every request the fake accepted, in order + fasTokens :: TVar [B.ByteString] + } + +fakeKeyId, fakeIssuerId :: Text +fakeKeyId = "2X9R4HXF34" +fakeIssuerId = "57246542-96fe-1a63-e053-0824d011072a" + +-- | The App Store Server API for the bundle id given, accepting only tokens its own key signed. The key +-- is made per run, as Play's is, and written as the .p8 file App Store Connect hands out. +withFakeAppStore :: Text -> (FakeAppStore -> IO a) -> IO a +withFakeAppStore bundleId action = do + fasAnswers <- newTVarIO M.empty + fasTokens <- newTVarIO [] + createDirectoryIfMissing True "tests/tmp" + withTempDirectory "tests/tmp" "fake-app-store" $ \d -> do + let keyFile = d "AuthKey.p8" + publicKey <- writeApiKey keyFile + let fake base = + FakeAppStore + { fasApi = AppleServerApi {aKeyId = fakeKeyId, aIssuerId = fakeIssuerId, aPrivateKeyFile = keyFile, aApiHost = base}, + fasAnswers, + fasTokens + } + Warp.testWithApplication (pure $ fakeApp bundleId publicKey (fake "")) $ \prt -> + action $ fake $ "http://127.0.0.1:" <> T.pack (show prt) + +-- | A new P-256 key, as the PKCS#8 PEM of an App Store Connect .p8 file; answers its public half. +writeApiKey :: FilePath -> IO ECDSA.PublicKey +writeApiKey path = do + (publicKey@(ECDSA.PublicKey _ q), ECDSA.PrivateKey _ d) <- ECC.generate $ ECC.getCurveByName ECC.SEC_p256r1 + case q of + ECC.Point x y -> do + let ecPrivateKey = der 0x30 $ der 0x02 "\x01" <> der 0x04 (i2ospOf_ 32 d) <> der 0xa1 (der 0x03 $ "\x00\x04" <> i2ospOf_ 32 x <> i2ospOf_ 32 y) + algorithm = der 0x30 $ der 0x06 "\x2a\x86\x48\xce\x3d\x02\x01" <> der 0x06 "\x2a\x86\x48\xce\x3d\x03\x01\x07" + B.writeFile path $ pem "PRIVATE KEY" $ der 0x30 $ der 0x02 "\x00" <> algorithm <> der 0x04 ecPrivateKey + pure publicKey + ECC.PointO -> writeApiKey path + +answerStatus :: FakeAppStore -> Text -> AppStoreAnswer -> IO () +answerStatus FakeAppStore {fasAnswers} originalId answer = atomically $ modifyTVar' fasAnswers $ M.insert originalId answer + +fakeApp :: Text -> ECDSA.PublicKey -> FakeAppStore -> Application +fakeApp bundleId publicKey FakeAppStore {fasAnswers, fasTokens} req respond = + case (requestMethod req, pathInfo req) of + (m, ["inApps", "v1", "subscriptions", originalId]) | m == methodGet -> do + now <- round <$> getPOSIXTime + case lookup hAuthorization (requestHeaders req) >>= B.stripPrefix "Bearer " of + Just bearer | validToken now bearer -> do + atomically $ modifyTVar' fasTokens (<> [bearer]) + answer originalId + _ -> respond $ status unauthorized401 + _ -> respond $ status notFound404 + where + answer originalId = + M.lookup originalId <$> readTVarIO fasAnswers >>= \case + Just (AppStoreBody v) -> respond $ responseLBS ok200 [(hContentType, "application/json")] $ J.encode v + Just (AppStoreStatus code) -> respond $ status (mkStatus code "Answer") + Just AppStoreHang -> forever $ threadDelay 1000000 + Nothing -> respond $ status notFound404 + -- Apple's rules: ES256 with this key's id, and at most an hour between issue and expiry + validToken :: Integer -> B.ByteString -> Bool + validToken now token = case B8.split '.' token of + [header, claims, signature] + | Right sig <- B64U.decodeUnpadded signature, + B.length sig == 64, + (r, s) <- B.splitAt 32 sig, + ECDSA.verify SHA256 publicKey (ECDSA.Signature (os2ip r) (os2ip s)) (header <> "." <> claims), + Just h <- part header, + Just c <- part claims, + Just iat <- number "iat" c, + Just expiry <- number "exp" c -> + KM.lookup "alg" h == Just "ES256" + && KM.lookup "kid" h == Just (J.String fakeKeyId) + && KM.lookup "typ" h == Just "JWT" + && KM.lookup "iss" c == Just (J.String fakeIssuerId) + && KM.lookup "aud" c == Just "appstoreconnect-v1" + && KM.lookup "bid" c == Just (J.String bundleId) + && iat <= now + && now < expiry + && expiry - iat <= 3600 + _ -> False + part p = case J.decodeStrict' =<< either (const Nothing) Just (B64U.decodeUnpadded p) of + Just (J.Object o) -> Just o + _ -> Nothing + number k o = case KM.lookup k o of + Just v | J.Success n <- J.fromJSON v -> Just n + _ -> Nothing + +status :: Status -> Response +status st = responseLBS st [(hContentType, "application/json")] $ J.encode $ J.object ["errorMessage" J..= show st] diff --git a/tests/Bots/BadgeService/FakePlay.hs b/tests/Bots/BadgeService/FakePlay.hs index f5b346a5e3..07b36471de 100644 --- a/tests/Bots/BadgeService/FakePlay.hs +++ b/tests/Bots/BadgeService/FakePlay.hs @@ -11,6 +11,8 @@ module Bots.BadgeService.FakePlay answerTokenRequests, grantTokensFor, fakePackageName, + der, + pem, ) where @@ -33,6 +35,7 @@ import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) +import Data.Word (Word8) import Network.HTTP.Types (Status, badRequest400, hAuthorization, hContentType, methodGet, methodPost, mkStatus, notFound404, ok200, parseSimpleQuery, unauthorized401) import Network.Wai (Application, Response, pathInfo, requestHeaders, requestMethod, responseLBS, strictRequestBody) import qualified Network.Wai.Handler.Warp as Warp @@ -52,7 +55,9 @@ data FakePlay = FakePlay fpPurchasePaths :: TVar [[Text]], -- what the acknowledge endpoint answers instead of acknowledging fpAcknowledgeRefusal :: TVar (Maybe PlayAnswer), - fpAcknowledged :: TVar [Text] + fpAcknowledged :: TVar [Text], + -- the product id and the token + fpSubscriptionAcknowledged :: TVar [(Text, Text)] } fakePackageName :: Text @@ -73,6 +78,7 @@ withFakePlay action = do fpPurchasePaths <- newTVarIO [] fpAcknowledgeRefusal <- newTVarIO Nothing fpAcknowledged <- newTVarIO [] + fpSubscriptionAcknowledged <- newTVarIO [] createDirectoryIfMissing True "tests/tmp" withTempDirectory "tests/tmp" "fake-play" $ \d -> do let accountFile = d "service-account.json" @@ -85,7 +91,8 @@ withFakePlay action = do fpGrantedTokens, fpPurchasePaths, fpAcknowledgeRefusal, - fpAcknowledged + fpAcknowledged, + fpSubscriptionAcknowledged } LB.writeFile accountFile $ J.encode $ J.object ["client_email" J..= fakeClientEmail, "private_key" J..= decodeUtf8 (pkcs8Pem privateKey)] Warp.testWithApplication (pure $ \req respond -> fakeApp key (fake $ origin req) req respond) $ \prt -> @@ -96,8 +103,7 @@ withFakePlay action = do -- | The PKCS#8 PEM Google puts in a service account key, so the service's own parser reads it. pkcs8Pem :: RSA.PrivateKey -> B.ByteString -pkcs8Pem k = - "-----BEGIN PRIVATE KEY-----\n" <> B8.unlines (chunks $ B64.encode pkcs8) <> "-----END PRIVATE KEY-----\n" +pkcs8Pem k = pem "PRIVATE KEY" pkcs8 where RSA.PublicKey {RSA.public_n, RSA.public_e} = RSA.private_pub k pkcs8 = der 0x30 $ derInteger 0 <> der 0x30 (rsaEncryption <> "\x05\x00") <> der 0x04 pkcs1 @@ -106,10 +112,17 @@ pkcs8Pem k = derInteger n = der 0x02 $ case i2osp n of bs | B.null bs || B.head bs >= 0x80 -> B.cons 0 bs bs -> bs - der tag content = B.pack (tag : derLength (B.length content)) <> content + +der :: Word8 -> B.ByteString -> B.ByteString +der tag content = B.pack (tag : derLength (B.length content)) <> content + where derLength n | n < 0x80 = [fromIntegral n] | otherwise = let bs = B.unpack (i2osp $ toInteger n) in 0x80 + fromIntegral (length bs) : bs + +pem :: B.ByteString -> B.ByteString -> B.ByteString +pem label content = "-----BEGIN " <> label <> "-----\n" <> B8.unlines (chunks $ B64.encode content) <> "-----END " <> label <> "-----\n" + where chunks bs | B.null bs = [] | otherwise = let (line, rest) = B.splitAt 64 bs in line : chunks rest @@ -127,14 +140,21 @@ answerAcknowledgements :: FakePlay -> Maybe PlayAnswer -> IO () answerAcknowledgements FakePlay {fpAcknowledgeRefusal} = atomically . writeTVar fpAcknowledgeRefusal fakeApp :: RSA.PublicKey -> FakePlay -> Application -fakeApp key FakePlay {fpConfig = PlayStoreConfig {gTokenUrl}, fpAnswers, fpTokenRefusal, fpTokenSeconds, fpGrantedTokens, fpPurchasePaths, fpAcknowledgeRefusal, fpAcknowledged} req respond = +fakeApp key FakePlay {fpConfig = PlayStoreConfig {gTokenUrl}, fpAnswers, fpTokenRefusal, fpTokenSeconds, fpGrantedTokens, fpPurchasePaths, fpAcknowledgeRefusal, fpAcknowledged, fpSubscriptionAcknowledged} req respond = case (requestMethod req, pathInfo req) of (m, ["token"]) | m == methodPost -> strictRequestBody req >>= grant (m, path@["androidpublisher", "v3", "applications", pkg, "purchases", "products", _, "tokens", token]) | m == methodGet && pkg == fakePackageName -> authorized $ do atomically $ modifyTVar' fpPurchasePaths (<> [path]) purchase token - | m == methodPost && pkg == fakePackageName, Just acknowledgedToken <- T.stripSuffix ":acknowledge" token -> authorized $ acknowledge acknowledgedToken + | m == methodPost && pkg == fakePackageName, Just acknowledgedToken <- T.stripSuffix ":acknowledge" token -> authorized $ acknowledge $ modifyTVar' fpAcknowledged (<> [acknowledgedToken]) + (m, path@["androidpublisher", "v3", "applications", pkg, "purchases", "subscriptionsv2", "tokens", token]) + | m == methodGet && pkg == fakePackageName -> authorized $ do + atomically $ modifyTVar' fpPurchasePaths (<> [path]) + purchase token + (m, ["androidpublisher", "v3", "applications", pkg, "purchases", "subscriptions", productId, "tokens", token]) + | m == methodPost && pkg == fakePackageName, Just acknowledgedToken <- T.stripSuffix ":acknowledge" token -> + authorized $ acknowledge $ modifyTVar' fpSubscriptionAcknowledged (<> [(productId, acknowledgedToken)]) _ -> respond $ status notFound404 where authorized act = do @@ -142,11 +162,11 @@ fakeApp key FakePlay {fpConfig = PlayStoreConfig {gTokenUrl}, fpAnswers, fpToken case lookup hAuthorization (requestHeaders req) of Just auth | Just bearer <- B.stripPrefix "Bearer " auth, take 1 (reverse granted) == [bearer] -> act _ -> respond $ status unauthorized401 - acknowledge token = + acknowledge record = readTVarIO fpAcknowledgeRefusal >>= \case Just answer -> answerWith answer Nothing -> do - atomically $ modifyTVar' fpAcknowledged (<> [token]) + atomically (record :: STM ()) respond $ responseLBS ok200 [] "" grant body = readTVarIO fpTokenRefusal >>= \case diff --git a/tests/Bots/BadgeService/FakeStore.hs b/tests/Bots/BadgeService/FakeStore.hs index c8c7048a48..a8a29bfc57 100644 --- a/tests/Bots/BadgeService/FakeStore.hs +++ b/tests/Bots/BadgeService/FakeStore.hs @@ -8,6 +8,7 @@ module Bots.BadgeService.FakeStore ( FakeStore (..), newFakeStore, googleVerifierWithHook, + subscriptionCheckWithHook, settlePending, setGoogleDown, googleSupporterToken, @@ -16,7 +17,13 @@ module Bots.BadgeService.FakeStore googleThrowingToken, googleHangingToken, googleSubscriptionToken, + googleUnknownProductToken, + appleSubscriptionOriginalId, + appleSecondSubscriptionOriginalId, + setSubscription, + subscriptionChecks, googlePayment, + subscriptionJWS, unsignedJWS, ) where @@ -25,12 +32,16 @@ import BadgeService.StoreReceipts import Control.Concurrent (threadDelay) import Control.Monad (forever) import qualified Data.Aeson as J +import Data.Aeson.Types (Pair) import qualified Data.ByteString.Base64.URL as B64U import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB -import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Int (Int64) +import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) import Data.Text (Text) -import Simplex.Chat.PaymentService (ServicePayment (..), googlePurchaseRef) +import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef, googlePurchaseRef) import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) import Simplex.Messaging.Util (safeDecodeUtf8) import System.FilePath (()) @@ -47,8 +58,22 @@ data FakeStore = FakeStore appleThrowingJWS :: Text, appleMisnamedJWS :: Text, appleQuantityJWS :: Text, + -- two transactions of the subscription appleSubscriptionOriginalId names, the renewal bought later, one + -- from Apple's Sandbox, and a later one Apple revoked, which the fake does not vouch for + appleSubscriptionJWS :: Text, + 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, pendingSettled :: IORef Bool, googleDown :: IORef Bool, + -- what the store answers about each subscription: Apple's by original id, Google's by token + subscriptions :: IORef (M.Map (Either Text Text) SubscriptionCheck), + subscriptionCheckCount :: IORef Int, fakeVerifier :: StoreVerifier } @@ -60,20 +85,42 @@ newFakeStore = do let appleThrowingJWS = unsignedJWS "{\"transactionId\":\"2000000812345679\",\"productId\":\"BADGE_SUPPORTER_01\"}" appleMisnamedJWS = unsignedJWS "{\"transactionId\":\"2000000812345698\",\"productId\":\"BADGE_SUPPORTER_01\"}" appleQuantityJWS = unsignedJWS "{\"transactionId\":\"2000000812345697\",\"productId\":\"BADGE_SUPPORTER_01\"}" + appleSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345681" [purchasedAt 1767225600000] + 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 googleDown <- newIORef False + subscriptions <- newIORef M.empty + subscriptionCheckCount <- newIORef 0 let appleReceipts = [ (appleSupporterJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" False 700), (appleLegendJWS, appleTransaction "2000000812345672" "BADGE_LEGEND_01" False 7000), (appleSandboxJWS, appleTransaction "2000000812345673" "BADGE_LEGEND_01" True 7000), -- a verifier vouching for another transaction than the one the evidence names (appleMisnamedJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" False 700), - (appleQuantityJWS, (appleTransaction "2000000812345697" "BADGE_SUPPORTER_01" False 1400) {quantity = 2}) + (appleQuantityJWS, (appleTransaction "2000000812345697" "BADGE_SUPPORTER_01" False 1400) {quantity = 2}), + -- vouched by the ref the claim reads, the subscription's original id + (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) ] verifyApple jws | jws == appleThrowingJWS = error "fake verifier bug" | otherwise = maybe (Left $ SRInvalid "not a fake receipt") Right $ lookup jws appleReceipts verifyGoogle = googleVerdict pendingSettled googleDown + checkSubscription ref _ = do + modifyIORef' subscriptionCheckCount (+ 1) + down <- readIORef googleDown + case ref of + SubscriptionGoogle _ | down -> pure $ Left $ SRUnreachable "fake store is down" + _ -> maybe (Left $ SRUnreachable "the fake store knows no such subscription") Right . M.lookup (subscriptionKey ref) <$> readIORef subscriptions pure FakeStore { appleSupporterJWS, @@ -82,14 +129,51 @@ newFakeStore = do appleThrowingJWS, appleMisnamedJWS, appleQuantityJWS, + appleSubscriptionJWS, + appleRenewalSubscriptionJWS, + appleSandboxSubscriptionJWS, + appleRevokedSubscriptionJWS, + appleLegendSubscriptionJWS, + appleSecondSubscriptionJWS, + appleThirdSubscriptionJWS, pendingSettled, googleDown, - fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, acknowledgeGoogle = Nothing, verifyTimeout = 500000} + subscriptions, + subscriptionCheckCount, + fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, acknowledgeGoogle = Nothing, acknowledgeGoogleSubscription = Nothing, checkSubscription = Just checkSubscription, verifyTimeout = 500000, storeChecks = ChecksAfterCoverage, creditTestPurchases = False} } where fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir name) appleTransaction transactionRef productId testPurchase cents = VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD"), alreadyAcknowledged = False} + purchasedAt ms = "purchaseDate" J..= (ms :: Int64) + appleSubscription jws testPurchase = + VerifiedStoreTransaction {transactionRef = fromMaybe "" (appleTransactionRef jws), productId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", quantity = 1, testPurchase, paid = Just (CurrencyAmount 700, "USD"), alreadyAcknowledged = False} + +-- | A transaction of the subscription the original id names, with the payload fields given. +subscriptionJWS :: Text -> Text -> [Pair] -> Text +subscriptionJWS originalId transactionId fields = + unsignedJWS $ + LB.toStrict $ + J.encode $ + J.object $ + [ "transactionId" J..= transactionId, + "originalTransactionId" J..= originalId, + "type" J..= ("Auto-Renewable Subscription" :: Text), + "productId" J..= ("SUBSCR_BADGE_SUPPORTER_MONTH_01" :: Text) + ] + <> fields + +subscriptionKey :: SubscriptionRef -> Either Text Text +subscriptionKey = \case + SubscriptionApple originalId -> Left originalId + SubscriptionGoogle token -> Right token + +setSubscription :: FakeStore -> SubscriptionRef -> SubscriptionCheck -> IO () +setSubscription FakeStore {subscriptions} ref checked = modifyIORef' subscriptions $ M.insert (subscriptionKey ref) checked + +subscriptionChecks :: FakeStore -> IO Int +subscriptionChecks FakeStore {subscriptionCheckCount} = readIORef subscriptionCheckCount googleVerdict :: IORef Bool -> IORef Bool -> Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction) googleVerdict pendingSettled googleDown productId token = @@ -97,7 +181,7 @@ googleVerdict pendingSettled googleDown productId token = True -> pure $ Left $ SRUnreachable "fake store is down" False | (productId, token) == ("badge_supporter_01", googleSupporterToken) -> pure $ Right purchased - | (productId, token) == ("subscr_badge_supporter_01", googleSubscriptionToken) -> pure $ Right purchased + | (productId, token) == ("badge_unknown_01", googleUnknownProductToken) -> pure $ Right purchased | (productId, token) == ("badge_supporter_01", googlePendingToken) -> do settled <- readIORef pendingSettled pure $ if settled then Right purchased else Left SRPending @@ -118,19 +202,34 @@ googleVerifierWithHook hook FakeStore {fakeVerifier = v@StoreVerifier {verifyGoo action verify productId token +-- | The fake store, running the hook's action once, inside the first subscription check, before it answers. +subscriptionCheckWithHook :: IORef (IO ()) -> FakeStore -> StoreVerifier +subscriptionCheckWithHook hook FakeStore {fakeVerifier = v@StoreVerifier {checkSubscription}} = + v {checkSubscription = hooked <$> checkSubscription, verifyTimeout = 10000000} + where + hooked check ref product_ = do + action <- atomicModifyIORef' hook (pure (),) + action + check ref product_ + settlePending :: FakeStore -> IO () settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True setGoogleDown :: FakeStore -> Bool -> IO () setGoogleDown FakeStore {googleDown} = writeIORef googleDown -googleSupporterToken, googlePendingToken, googleUnreachableToken, googleThrowingToken, googleHangingToken, googleSubscriptionToken :: Text +googleSupporterToken, googlePendingToken, googleUnreachableToken, googleThrowingToken, googleHangingToken, googleSubscriptionToken, googleUnknownProductToken :: Text googleSupporterToken = "fake-play-token-supporter.AO-J1Oz9x2kqE7wYt3" googlePendingToken = "fake-play-token-pending.AO-J1Oy8w1jpD6vXs2" googleUnreachableToken = "fake-play-token-unreachable.AO-J1Ox7v0ioC5uWr1" googleThrowingToken = "fake-play-token-throwing.AO-J1Ov5t8gmA3sUp9" googleHangingToken = "fake-play-token-hanging.AO-J1Ou4s7flZ2rTo8" googleSubscriptionToken = "fake-play-token-subscription.AO-J1Ow6u9hnB4tVq0" +googleUnknownProductToken = "fake-play-token-unknown-product.AO-J1Ot3r6ekY1qSn7" + +appleSubscriptionOriginalId, appleSecondSubscriptionOriginalId :: Text +appleSubscriptionOriginalId = "2000000812345680" +appleSecondSubscriptionOriginalId = "2000000812345700" googlePayment :: Text -> Text -> ServicePayment googlePayment productId token = SPGoogle {productId, token} diff --git a/tests/Bots/BadgeService/StoreVerifierTests.hs b/tests/Bots/BadgeService/StoreVerifierTests.hs index 27e73c7154..e210389f0f 100644 --- a/tests/Bots/BadgeService/StoreVerifierTests.hs +++ b/tests/Bots/BadgeService/StoreVerifierTests.hs @@ -3,15 +3,30 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module Bots.BadgeService.StoreVerifierTests (badgeStoreVerifierTests) where +module Bots.BadgeService.StoreVerifierTests + ( badgeStoreVerifierTests, + TestChain (..), + trustedChain, + signedBy, + subscriptionPayload, + transactionPayload, + ourBundleId, + purchaseRecord, + subscriptionRecord, + lineItem, + basePlan, + ) +where -import BadgeService.Config (PlayStoreConfig (..), ServiceConfig (..), readServiceConfig) +import BadgeService.Config (AppleServerApi (..), AppleStoreConfig (..), PlayStoreConfig (..), ServiceConfig (..), readServiceConfig) import BadgeService.Service (ServiceState (..), configureStoreVerifier, newServiceState) import BadgeService.StoreReceipts -import BadgeService.StoreReceipts.Apple (readAppleRoot, verifyAppleTransaction) -import BadgeService.StoreReceipts.Google (playStoreVerifier) +import BadgeService.StoreReceipts.Apple (appleSubscriptionChecker, readAppleRoot, verifyAppleTransaction) +import BadgeService.StoreReceipts.Google (PlayVerifier (..), playStoreVerifier) +import Bots.BadgeService.FakeAppStore import Bots.BadgeService.FakePlay import Control.Concurrent.STM (readTVarIO) +import Control.Exception (throwIO) import Control.Monad (forM_) import Crypto.Hash.Algorithms (SHA256 (..)) import Crypto.Number.Serialize (i2osp, i2ospOf_) @@ -27,13 +42,17 @@ import qualified Data.ByteString.Base64.URL as B64U import qualified Data.ByteString.Lazy as LB import Data.Either (isRight) import Data.Hourglass (Date (..), DateTime (..), Month (..), TimeOfDay (..)) -import Data.List (isInfixOf) +import Data.List (isInfixOf, nub) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..)) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.X509 -import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef) +import Simplex.Chat.Badges.Service (SubscriptionState (..)) +import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef, googlePurchaseRef) import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory, ()) @@ -44,6 +63,7 @@ badgeStoreVerifierTests :: Spec badgeStoreVerifierTests = describe "badge store verifiers" $ do describe "App Store signed transactions" $ do it "vouches for a transaction a chain to the trusted root signed, naming the transaction it was claimed by" testAppleVerdict + it "vouches for a subscription renewal by its original transaction id, the ref it is claimed by" testAppleRenewalVerdict it "verifies a transaction under any of the trusted roots" testAppleAnyTrustedRoot it "fails, rather than refuses, an intermediate the trusted root did not sign, since the root may be misconfigured" testAppleRootNotTrusted it "refuses a leaf the intermediate did not sign, though the intermediate is genuine" testAppleForgedLeaf @@ -60,6 +80,16 @@ badgeStoreVerifierTests = describe "badge store verifiers" $ do it "records the price in the currency's minor units, or not at all" testApplePrice it "reads the trusted root from a DER file, and reports one it cannot read or that is not a root" testReadAppleRoot it "has nothing to acknowledge" testAppleNoAcknowledgement + describe "App Store subscriptions" $ do + it "maps each status, renewing or cancelled by autoRenewStatus, and the charge to the latest transaction, with one token reused" testAppleSubscriptionStatuses + it "reads the subscription asked about from an answer that lists another one first" testAppleSubscriptionAmongOthers + it "reports a revoked charge and one in an offer, refuses a family-shared one, and names a Sandbox one a test purchase" testAppleSubscriptionCharges + it "fails, rather than refuses, a status Apple did not sign or that was changed after signing" testAppleSubscriptionUnsigned + it "fails on a verifier that cannot place what the store signed, and is unreachable on any other throw" testSubscriptionCheckThrows + it "refuses a check the store marks as a test, and passes it through only with credit_test_purchases on" testSubscriptionCheckCreditsTest + it "fails on 401 and 403, and is unreachable on 404, 429, 5xx, no answer and an answer naming no such subscription" testAppleSubscriptionHttp + it "fails on a key Apple refuses, and at boot on a key file it cannot read" testAppleSubscriptionKey + it "checks subscriptions only where [apple] sets the API key, and one-time purchases either way" testAppleConfiguredSubscriptions describe "Google Play purchases" $ do it "vouches for a purchased token, asking Play about that token in this app" testPlayPurchased it "reports a license tester's purchase as a test purchase, and a promo code's as paid" testPlayTestAndPromo @@ -77,6 +107,16 @@ badgeStoreVerifierTests = describe "badge store verifiers" $ do it "reads a purchase once to verify and acknowledge it, and acknowledges only what that read found unacknowledged" testPlayReadsPurchaseOnce it "reports an acknowledgement Play refuses or does not answer" testPlayAcknowledgementFails it "acknowledges through the verifier a [google] section configures" testPlayConfiguredAcknowledges + describe "Google Play subscriptions" $ do + it "maps each state, renewing or cancelled by autoRenewEnabled, asking Play by the token alone" testPlaySubscriptionStates + it "answers a pending subscription as pending, and a license tester's as a test purchase" testPlaySubscriptionPendingOrTest + it "reads the charge from the line item, its period starting the plan's length before it ends" testPlaySubscriptionCharge + it "flags a charge in a free trial or an introductory price, and not one bought on an offer now at its base price" testPlaySubscriptionOffer + it "fails on a record it cannot read, an unknown state, or a charge without its period or plan" testPlaySubscriptionUnreadable + it "fails on 401 and 403, is unreachable on 404, 429, 5xx and no answer, and ended on 410" testPlaySubscriptionHttp + it "acknowledges a subscription once, through the subscriptions endpoint, unless Play reports it acknowledged" testPlaySubscriptionAcknowledges + it "reports a subscription acknowledgement Play refuses or does not answer" testPlaySubscriptionAcknowledgementFails + it "checks Play subscriptions only where [google] is configured, beside the App Store's" testPlayConfiguredSubscriptions -- * App Store @@ -178,7 +218,6 @@ certifyWith alg issuerKey issuerName subjectName subjectKey markers = } sign tbs = (\(ECDSA.Signature r s) -> (derSignature r s, alg)) <$> ECDSA.sign issuerKey SHA256 tbs derSignature r s = der 0x30 (der 0x02 (unsigned r) <> der 0x02 (unsigned s)) - der tag content = B.pack [tag, fromIntegral (B.length content)] <> content unsigned n = let bs = i2osp n in if B.head bs >= 0x80 then B.cons 0 bs else bs transactionPayload :: [(J.Key, J.Value)] -> [J.Key] -> J.Value @@ -227,7 +266,19 @@ testAppleVerdict = do jws <- signedBy chain $ transactionPayload [] [] appleVerdict (rootCert chain) jws `shouldReturn` Right VerifiedStoreTransaction {transactionRef = "2000000900000001", productId = "BADGE_SUPPORTER_01", quantity = 1, testPurchase = False, paid = Just (CurrencyAmount 700, "USD"), alreadyAcknowledged = False} - appleTransactionId jws `shouldBe` Just "2000000900000001" + appleTransactionRef jws `shouldBe` Just "2000000900000001" + +-- the service answers internal when the verified ref is not the claimed one, so a renewal must be vouched for by the claim's own ref +testAppleRenewalVerdict :: IO () +testAppleRenewalVerdict = do + chain <- trustedChain + jws <- signedBy chain $ transactionPayload [("transactionId", "2000000900000002"), ("type", "Auto-Renewable Subscription"), ("productId", "SUBSCR_BADGE_SUPPORTER_MONTH_01")] [] + r <- appleVerdict (rootCert chain) jws + fmap transactionRef r `shouldBe` Right "2000000900000001" + appleTransactionRef jws `shouldBe` Just "2000000900000001" + -- an auto-renewable transaction without its original id names no subscription + noOriginal <- signedBy chain $ transactionPayload [("type", "Auto-Renewable Subscription")] ["originalTransactionId"] + outcome <$> appleVerdict (rootCert chain) noOriginal `shouldReturn` Invalid testAppleAnyTrustedRoot :: IO () testAppleAnyTrustedRoot = do @@ -379,20 +430,265 @@ testAppleNoAcknowledgement = do verifier <- playVerifier fake acknowledgement verifier {verifyApple = Just (verifyAppleTransaction (rootCert chain :| []) ourBundleId)} SPApple {jws} `shouldReturn` Nothing +-- * App Store subscriptions + +subscriptionId :: Text +subscriptionId = "2000000900000001" + +periodStartMs, periodEndMs :: Int +periodStartMs = 1790000000000 +periodEndMs = periodStartMs + 30 * 86400000 + +-- | A renewal of the subscription subscriptionId names: a transaction of its own, under the original one. +subscriptionPayload :: [(J.Key, J.Value)] -> [J.Key] -> J.Value +subscriptionPayload overrides = + transactionPayload $ + [ ("transactionId", "2000000900000002"), + ("type", "Auto-Renewable Subscription"), + ("productId", "SUBSCR_BADGE_SUPPORTER_MONTH_01"), + ("purchaseDate", J.toJSON periodStartMs), + ("expiresDate", J.toJSON periodEndMs), + ("transactionReason", "RENEWAL") + ] + <> overrides + +renewalPayload :: [(J.Key, J.Value)] -> J.Value +renewalPayload overrides = + J.Object $ + KM.fromList $ + [ ("originalTransactionId", J.String subscriptionId), + ("autoRenewStatus", J.toJSON (1 :: Int)), + ("autoRenewProductId", "SUBSCR_BADGE_SUPPORTER_MONTH_01"), + ("productId", "SUBSCR_BADGE_SUPPORTER_MONTH_01"), + ("environment", "Production"), + ("signedDate", J.toJSON (1790000001000 :: Int)) + ] + <> overrides + +-- | Get All Subscription Statuses as Apple answers it, with the subscription's latest transaction. +statusBody :: Int -> Text -> Text -> J.Value +statusBody status signedTx signedRenewal = statusListing [lastTransaction subscriptionId status signedTx signedRenewal] + +-- | Get All Subscription Statuses listing these subscriptions, all in one subscription group. +statusListing :: [J.Value] -> J.Value +statusListing lastTransactions = + J.object + [ "environment" J..= ("Production" :: Text), + "bundleId" J..= ourBundleId, + "data" + J..= [ J.object + [ "subscriptionGroupIdentifier" J..= ("21000000" :: Text), + "lastTransactions" J..= lastTransactions + ] + ] + ] + +lastTransaction :: Text -> Int -> Text -> Text -> J.Value +lastTransaction originalId status signedTx signedRenewal = + J.object ["originalTransactionId" J..= originalId, "status" J..= status, "signedTransactionInfo" J..= signedTx, "signedRenewalInfo" J..= signedRenewal] + +-- | The check the service runs, through the same runner as a purchase and a renewal. +withAppleChecker :: TestChain -> (FakeAppStore -> (Text -> IO (Either StoreRefusal SubscriptionCheck)) -> IO a) -> IO a +withAppleChecker chain action = withFakeAppStore ourBundleId $ \fake -> do + check <- appleChecker chain (fasApi fake) + action fake $ \originalId -> checkStoreSubscription noStoreVerifier {checkSubscription = Just (\ref _ -> check ref), verifyTimeout = 2000000} (SubscriptionApple originalId) Nothing + +appleChecker :: TestChain -> AppleServerApi -> IO (SubscriptionRef -> IO (Either StoreRefusal SubscriptionCheck)) +appleChecker chain serverApi = + appleSubscriptionChecker (rootCert chain :| []) ourBundleId serverApi >>= \case + Right check -> pure $ \case + SubscriptionApple originalId -> check originalId + SubscriptionGoogle _ -> pure $ Left SRNotConfigured + Left e -> expectationFailure e >> undefined + +-- | Signs the transaction and the renewal info with the given chain, and serves them as the subscription's status. +serveStatus :: FakeAppStore -> TestChain -> Int -> J.Value -> J.Value -> IO () +serveStatus fake chain status transaction renewal = do + signedTx <- signedBy chain transaction + signedRenewal <- signedBy chain renewal + answerStatus fake subscriptionId $ AppStoreBody $ statusBody status signedTx signedRenewal + +stateOf :: Either StoreRefusal SubscriptionCheck -> Either StoreRefusal SubscriptionState +stateOf = fmap $ \SubscriptionCheck {subscriptionState} -> subscriptionState + +chargeOf :: Either StoreRefusal SubscriptionCheck -> Either StoreRefusal (Maybe (Text, Text, UTCTime, UTCTime, Maybe (CurrencyAmount, Text), Bool, Bool)) +chargeOf = fmap $ \SubscriptionCheck {latestCharge} -> + (\StoreCharge {chargeRef, planId, periodStart, periodEnd, chargePaid, revoked, offer} -> (chargeRef, planId, periodStart, periodEnd, chargePaid, revoked, offer)) <$> latestCharge + +testAppleSubscriptionStatuses :: IO () +testAppleSubscriptionStatuses = do + chain <- trustedChain + withAppleChecker chain $ \fake check -> do + let stateFor status autoRenew = do + serveStatus fake chain status (subscriptionPayload [] []) (renewalPayload [("autoRenewStatus", J.toJSON (autoRenew :: Int))]) + stateOf <$> check subscriptionId + stateFor 1 1 `shouldReturn` Right SSRenewing + stateFor 1 0 `shouldReturn` Right SSCancelled + stateFor 3 1 `shouldReturn` Right SSBillingRetry + stateFor 4 1 `shouldReturn` Right SSBillingRetry + stateFor 2 0 `shouldReturn` Right SSEnded + stateFor 5 0 `shouldReturn` Right SSEnded + outcome <$> stateFor 6 1 `shouldReturn` Failed + -- the charge is the latest transaction: its own id, its product as the plan, and its period + serveStatus fake chain 1 (subscriptionPayload [] []) (renewalPayload []) + chargeOf <$> check subscriptionId + `shouldReturn` Right (Just ("2000000900000002", "SUBSCR_BADGE_SUPPORTER_MONTH_01", millis periodStartMs, millis periodEndMs, Just (CurrencyAmount 700, "USD"), False, False)) + -- each call carried a token the fake accepted, signed once and reused + tokens <- readTVarIO (fasTokens fake) + length tokens `shouldBe` 8 + length (nub tokens) `shouldBe` 1 + where + millis ms = posixSecondsToUTCTime $ fromIntegral ms / 1000 + +-- | Apple lists every subscription the customer holds in the app, a family member's shared one included. +testAppleSubscriptionAmongOthers :: IO () +testAppleSubscriptionAmongOthers = do + chain <- trustedChain + withAppleChecker chain $ \fake check -> do + let sharedId = "2000000900000011" + sharedTx <- signedBy chain $ subscriptionPayload [("originalTransactionId", J.String sharedId), ("transactionId", "2000000900000012"), ("inAppOwnershipType", "FAMILY_SHARED")] [] + sharedRenewal <- signedBy chain $ renewalPayload [("originalTransactionId", J.String sharedId)] + ownTx <- signedBy chain $ subscriptionPayload [] [] + ownRenewal <- signedBy chain $ renewalPayload [] + answerStatus fake subscriptionId $ AppStoreBody $ statusListing [lastTransaction sharedId 1 sharedTx sharedRenewal, lastTransaction subscriptionId 1 ownTx ownRenewal] + stateOf <$> check subscriptionId `shouldReturn` Right SSRenewing + +testAppleSubscriptionCharges :: IO () +testAppleSubscriptionCharges = do + chain <- trustedChain + withAppleChecker chain $ \fake check -> do + let answerFor transaction = serveStatus fake chain 1 transaction (renewalPayload []) >> check subscriptionId + flags = fmap (fmap (\(_, _, _, _, _, revoked, offer) -> (revoked, offer))) . chargeOf + flags <$> answerFor (subscriptionPayload [("revocationDate", J.toJSON (1790000500000 :: Int))] []) `shouldReturn` Right (Just (True, False)) + flags <$> answerFor (subscriptionPayload [("offerType", J.toJSON (1 :: Int))] []) `shouldReturn` Right (Just (False, True)) + -- family sharing is off, so a family-shared transaction is no purchase of this badge + outcome <$> answerFor (subscriptionPayload [("inAppOwnershipType", "FAMILY_SHARED")] []) `shouldReturn` Invalid + -- a defence: the production host never answers about a Sandbox transaction + outcome <$> answerFor (subscriptionPayload [("environment", "Sandbox")] []) `shouldReturn` TestPurchase + outcome <$> answerFor (subscriptionPayload [("bundleId", "com.example.other")] []) `shouldReturn` Failed + outcome <$> answerFor (subscriptionPayload [("originalTransactionId", "2000000900000009")] []) `shouldReturn` Failed + outcome <$> answerFor (subscriptionPayload [] ["expiresDate"]) `shouldReturn` Failed + +-- | Apple answered, and no client presented any of it, so a status that fails the chain check is this +-- service's failure: never a refusal, which would drop a buyer's keys. +testAppleSubscriptionUnsigned :: IO () +testAppleSubscriptionUnsigned = do + chain@TestChain {rootCert, intermediateCert} <- trustedChain + withAppleChecker chain $ \fake check -> do + let failsOn transaction renewal = do + answerStatus fake subscriptionId $ AppStoreBody $ statusBody 1 transaction renewal + outcome <$> check subscriptionId `shouldReturn` Failed + signedRenewal <- signedBy chain $ renewalPayload [] + signedTx <- signedBy chain $ subscriptionPayload [] [] + untrusted <- newChain otherRootName [intermediateMarker] [receiptLeafMarker] + signedBy untrusted (subscriptionPayload [] []) >>= \tx -> failsOn tx signedRenewal + (forgedKey, forgedPub) <- newKeyPair + forgedLeaf <- certify forgedKey intermediateName leafName forgedPub [receiptLeafMarker] + signedTransaction chain {leafKey = forgedKey} [forgedLeaf, intermediateCert, rootCert] es256 (subscriptionPayload [] []) >>= \tx -> failsOn tx signedRenewal + failsOn (tampered signedTx $ subscriptionPayload [("productId", "SUBSCR_BADGE_LEGEND_YEAR_01")] []) signedRenewal + failsOn signedTx (tampered signedRenewal $ renewalPayload [("autoRenewStatus", J.toJSON (0 :: Int))]) + where + tampered jws payload = case T.splitOn "." jws of + [header, _, signature] -> T.intercalate "." [header, decodeUtf8 $ segment payload, signature] + _ -> jws + +-- | A verifier that cannot place what the store signed throws StoreVerifierFailure, which is its own +-- failure; any other throw is the network's, as for Play. +testSubscriptionCheckThrows :: IO () +testSubscriptionCheckThrows = do + let throwing act = checkStoreSubscription noStoreVerifier {checkSubscription = Just (\_ _ -> act), verifyTimeout = 2000000} (SubscriptionApple subscriptionId) Nothing + outcome <$> throwing (throwIO $ StoreVerifierFailure "apple verifier: a chain it cannot place") `shouldReturn` Failed + outcome <$> throwing (ioError $ userError "connection reset") `shouldReturn` Unreachable + +testSubscriptionCheckCreditsTest :: IO () +testSubscriptionCheckCreditsTest = do + let testCheck = SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = True, latestCharge = Nothing} + checkCrediting credit = checkStoreSubscription noStoreVerifier {checkSubscription = Just (\_ _ -> pure (Right testCheck)), creditTestPurchases = credit} (SubscriptionApple subscriptionId) Nothing + outcome <$> checkCrediting False `shouldReturn` TestPurchase + fmap (\SubscriptionCheck {subscriptionState, testSubscription} -> (subscriptionState, testSubscription)) <$> checkCrediting True `shouldReturn` Right (SSRenewing, True) + +testAppleSubscriptionHttp :: IO () +testAppleSubscriptionHttp = do + chain <- trustedChain + withAppleChecker chain $ \fake check -> do + let answeredWith answer = answerStatus fake subscriptionId answer >> (outcome <$> check subscriptionId) + answeredWith (AppStoreStatus 401) `shouldReturn` Failed + answeredWith (AppStoreStatus 403) `shouldReturn` Failed + forM_ [404, 429, 500, 503] $ \code -> answeredWith (AppStoreStatus code) `shouldReturn` Unreachable + answeredWith AppStoreHang `shouldReturn` Unreachable + answeredWith (AppStoreBody $ J.object ["data" J..= ([] :: [J.Value])]) `shouldReturn` Unreachable + -- an id that is not one names no App Store transaction, and is not sent + tokens <- length <$> readTVarIO (fasTokens fake) + outcome <$> check "2000000900000001/../x" `shouldReturn` Failed + length <$> readTVarIO (fasTokens fake) `shouldReturn` tokens + +testAppleSubscriptionKey :: IO () +testAppleSubscriptionKey = do + chain <- trustedChain + withFakeAppStore ourBundleId $ \fake@FakeAppStore {fasApi = api@AppleServerApi {aPrivateKeyFile}} -> do + serveStatus fake chain 1 (subscriptionPayload [] []) (renewalPayload []) + -- a key App Store Connect did not issue for this account is refused, and is this service's failure + let otherKeyFile = takeDirectory aPrivateKeyFile "OtherKey.p8" + _ <- writeApiKey otherKeyFile + otherKey <- appleChecker chain api {aPrivateKeyFile = otherKeyFile} + outcome <$> otherKey (SubscriptionApple subscriptionId) `shouldReturn` Failed + readTVarIO (fasTokens fake) `shouldReturn` [] + appleSubscriptionChecker (rootCert chain :| []) ourBundleId api {aPrivateKeyFile = takeDirectory aPrivateKeyFile "absent.p8"} + >>= either (`shouldContain` "could not be read") (const $ expectationFailure "an absent key file must fail at boot") + B.writeFile otherKeyFile "-----BEGIN PRIVATE KEY-----\n-----END PRIVATE KEY-----\n" + appleSubscriptionChecker (rootCert chain :| []) ourBundleId api {aPrivateKeyFile = otherKeyFile} + >>= either (`shouldContain` "P-256") (const $ expectationFailure "a file holding no key must fail at boot") + +-- | Without the API key [apple] verifies one-time purchases as before, and no subscription. +testAppleConfiguredSubscriptions :: IO () +testAppleConfiguredSubscriptions = do + chain <- trustedChain + withFakeAppStore ourBundleId $ \fake@FakeAppStore {fasApi} -> do + let dir = takeDirectory (aPrivateKeyFile fasApi) + rootFile = dir "root.cer" + ini = dir "badge_service.ini" + apple serverApi = Just AppleStoreConfig {aBundleId = ourBundleId, aRootCertificates = rootFile :| [], aServerApi = serverApi} + B.writeFile rootFile (encodeSignedObject $ rootCert chain) + writeFile ini "[listener]\nstatic_dir = /srv/badges\n" + Right cfg <- readServiceConfig ini + ServiceState {storeVerifier = withKey} <- newServiceState >>= configureStoreVerifier (Just cfg {appleStore = apple (Just fasApi)}) + ServiceState {storeVerifier = withoutKey} <- newServiceState >>= configureStoreVerifier (Just cfg {appleStore = apple Nothing}) + serveStatus fake chain 1 (subscriptionPayload [] []) (renewalPayload []) + stateOf <$> checkStoreSubscription withKey (SubscriptionApple subscriptionId) Nothing `shouldReturn` Right SSRenewing + outcome <$> checkStoreSubscription withoutKey (SubscriptionApple subscriptionId) Nothing `shouldReturn` NotConfigured + jws <- signedBy chain $ transactionPayload [] [] + outcome <$> seamVerdict withoutKey SPApple {jws} `shouldReturn` Verdict + -- * Google Play playVerifier :: FakePlay -> IO StoreVerifier playVerifier fake = playStoreVerifier (fpConfig fake) >>= \case - Right (verify, acknowledge) -> pure noStoreVerifier {verifyGoogle = Just verify, acknowledgeGoogle = Just acknowledge, verifyTimeout = 2000000} + Right PlayVerifier {verifyPlayPurchase, acknowledgePlayPurchase, checkPlaySubscription, acknowledgePlaySubscription} -> + pure + noStoreVerifier + { verifyGoogle = Just verifyPlayPurchase, + acknowledgeGoogle = Just acknowledgePlayPurchase, + acknowledgeGoogleSubscription = Just acknowledgePlaySubscription, + checkSubscription = Just $ \ref _ -> case ref of + SubscriptionGoogle token -> checkPlaySubscription token + SubscriptionApple _ -> pure $ Left SRNotConfigured, + verifyTimeout = 2000000 + } Left e -> expectationFailure e >> undefined acknowledgement :: StoreVerifier -> ServicePayment -> IO (Maybe (Either StoreRefusal ())) -acknowledgement verifier payment = case toStoreReceipt verifier payment of - Just (Right StoreReceipt {verifyReceipt, acknowledgeReceipt}) -> - verifyReceipt >>= \case - Right tx -> traverse ($ tx) acknowledgeReceipt - Left refusal -> expectationFailure ("not verified: " <> show refusal) >> undefined +acknowledgement = acknowledgementBy $ \StoreReceipt {verifyReceipt, acknowledgeReceipt} -> + verifyReceipt >>= \case + Right tx -> traverse ($ tx) acknowledgeReceipt + Left refusal -> expectationFailure ("not verified: " <> show refusal) >> undefined + +subscriptionAcknowledgement :: StoreVerifier -> ServicePayment -> IO (Maybe (Either StoreRefusal ())) +subscriptionAcknowledgement = acknowledgementBy $ \StoreReceipt {acknowledgeSubscription} -> sequence acknowledgeSubscription + +acknowledgementBy :: (StoreReceipt -> IO (Maybe (Either StoreRefusal ()))) -> StoreVerifier -> ServicePayment -> IO (Maybe (Either StoreRefusal ())) +acknowledgementBy acknowledge verifier payment = case toStoreReceipt verifier payment of + Just (Right receipt) -> acknowledge receipt _ -> expectationFailure "not a store receipt" >> undefined playVerdict :: StoreVerifier -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction) @@ -590,3 +886,208 @@ testPlayConfiguredAcknowledges = withFakePlay $ \fake@FakePlay {fpConfig} -> do acknowledgement storeVerifier SPGoogle {productId = "badge_supporter_01", token = testToken} `shouldReturn` Just (Right ()) readTVarIO (fpAcknowledged fake) `shouldReturn` [testToken] +-- * Google Play subscriptions + +subscriptionToken :: Text +subscriptionToken = "fake-play-subscription-token.AO-J1Oz9x2kqE7wYt4" + +subscriptionProductId :: Text +subscriptionProductId = "subscr_badge_supporter_01" + +-- | purchases.subscriptionsv2 as Play answers it, unacknowledged. +subscriptionRecord :: Text -> [(J.Key, J.Value)] -> [J.Value] -> J.Value +subscriptionRecord state overrides items = + J.Object $ + KM.fromList overrides + `KM.union` KM.fromList + [ ("kind", "androidpublisher#subscriptionPurchaseV2"), + ("regionCode", "US"), + ("startTime", "2026-09-14T10:00:00.123456789Z"), + ("subscriptionState", J.String state), + ("latestOrderId", "GPA.3312-4521-8899-01234..1"), + ("acknowledgementState", "ACKNOWLEDGEMENT_STATE_PENDING"), + ("lineItems", J.toJSON items) + ] + +-- | A monthly supporter plan's line item, renewing at the base price. +lineItem :: [(J.Key, J.Value)] -> [J.Key] -> J.Value +lineItem overrides removed = + J.Object $ foldr KM.delete (KM.fromList overrides `KM.union` base) removed + where + base = + KM.fromList + [ ("productId", J.String subscriptionProductId), + ("expiryTime", "2026-11-14T10:00:00.123456789Z"), + ("autoRenewingPlan", J.object ["autoRenewEnabled" J..= True]), + ("offerDetails", J.object ["basePlanId" J..= ("subscr-badge-supporter-month-02" :: Text)]), + ("latestSuccessfulOrderId", "GPA.3312-4521-8899-01234..1"), + ("offerPhase", J.object ["basePrice" J..= J.object []]) + ] + +basePlan :: Text -> (J.Key, J.Value) +basePlan planId = ("offerDetails", J.object ["basePlanId" J..= planId]) + +answerSubscription :: FakePlay -> J.Value -> IO () +answerSubscription fake = answerPurchase fake subscriptionToken . PlayRecord + +-- | Through the same runner as a purchase and a renewal; every reason reaches the service's log, which must never hold the token. +playCheck :: StoreVerifier -> IO (Either StoreRefusal SubscriptionCheck) +playCheck verifier = do + r <- checkStoreSubscription verifier (SubscriptionGoogle subscriptionToken) Nothing + reason r `shouldNotSatisfy` (subscriptionToken `T.isInfixOf`) + pure r + +testPlaySubscriptionStates :: IO () +testPlaySubscriptionStates = withFakePlay $ \fake -> do + verifier <- playVerifier fake + let stateFor state autoRenew = do + answerSubscription fake $ subscriptionRecord state [] [lineItem [("autoRenewingPlan", J.object ["autoRenewEnabled" J..= autoRenew])] []] + stateOf <$> playCheck verifier + stateFor "SUBSCRIPTION_STATE_ACTIVE" True `shouldReturn` Right SSRenewing + stateFor "SUBSCRIPTION_STATE_ACTIVE" False `shouldReturn` Right SSCancelled + stateFor "SUBSCRIPTION_STATE_PAUSED" True `shouldReturn` Right SSRenewing + stateFor "SUBSCRIPTION_STATE_PAUSED" False `shouldReturn` Right SSCancelled + stateFor "SUBSCRIPTION_STATE_IN_GRACE_PERIOD" True `shouldReturn` Right SSBillingRetry + stateFor "SUBSCRIPTION_STATE_ON_HOLD" True `shouldReturn` Right SSBillingRetry + stateFor "SUBSCRIPTION_STATE_CANCELED" False `shouldReturn` Right SSCancelled + stateFor "SUBSCRIPTION_STATE_EXPIRED" False `shouldReturn` Right SSEnded + stateFor "SUBSCRIPTION_STATE_PENDING_PURCHASE_CANCELED" False `shouldReturn` Right SSEnded + -- a plan that does not renew itself, as a prepaid one + answerSubscription fake $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [] ["autoRenewingPlan"]] + stateOf <$> playCheck verifier `shouldReturn` Right SSCancelled + paths <- readTVarIO (fpPurchasePaths fake) + length paths `shouldBe` 10 + nub paths `shouldBe` [["androidpublisher", "v3", "applications", fakePackageName, "purchases", "subscriptionsv2", "tokens", subscriptionToken]] + +testPlaySubscriptionPendingOrTest :: IO () +testPlaySubscriptionPendingOrTest = withFakePlay $ \fake -> do + verifier <- playVerifier fake + answerSubscription fake $ subscriptionRecord "SUBSCRIPTION_STATE_PENDING" [] [lineItem [] []] + outcome <$> playCheck verifier `shouldReturn` Pending + answerSubscription fake $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [("testPurchase", J.object [])] [lineItem [] []] + outcome <$> playCheck verifier `shouldReturn` TestPurchase + +testPlaySubscriptionCharge :: IO () +testPlaySubscriptionCharge = withFakePlay $ \fake -> do + verifier <- playVerifier fake + let chargeFor item = answerSubscription fake (subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [item]) >> (chargeOf <$> playCheck verifier) + at y m d = UTCTime (fromGregorian y m d) + orderRef = googlePurchaseRef "GPA.3312-4521-8899-01234..1" + chargeFor (lineItem [] []) + `shouldReturn` Right (Just (orderRef, "subscr-badge-supporter-month-02", at 2026 10 14 36000.123456789, at 2026 11 14 36000.123456789, Nothing, False, False)) + chargeFor (lineItem [("productId", "subscr_badge_legend_01"), basePlan "subscr-badge-legend-year-01", ("expiryTime", "2027-10-14T10:00:00Z")] []) + `shouldReturn` Right (Just (orderRef, "subscr-badge-legend-year-01", at 2026 10 14 36000, at 2027 10 14 36000, Nothing, False, False)) + -- a plan this service does not sell has no length, so its charge is given no period, and is never granted + chargeFor (lineItem [basePlan "subscr-badge-supporter-month-99"] []) + `shouldReturn` Right (Just (orderRef, "subscr-badge-supporter-month-99", at 2026 11 14 36000.123456789, at 2026 11 14 36000.123456789, Nothing, False, False)) + chargeFor (lineItem [] ["latestSuccessfulOrderId"]) `shouldReturn` Right Nothing + +testPlaySubscriptionOffer :: IO () +testPlaySubscriptionOffer = withFakePlay $ \fake -> do + verifier <- playVerifier fake + let offerFor item = do + answerSubscription fake $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [item] + fmap (fmap (\(_, _, _, _, _, _, offer) -> offer)) . chargeOf <$> playCheck verifier + offerIn phase = offerFor $ lineItem [offerDetails, ("offerPhase", J.object [phase J..= J.object []])] [] + offerDetails = ("offerDetails", J.object ["basePlanId" J..= ("subscr-badge-supporter-month-02" :: Text), "offerId" J..= ("intro-3-months" :: Text)]) + offerIn "freeTrial" `shouldReturn` Right (Just True) + offerIn "introductoryPrice" `shouldReturn` Right (Just True) + -- offerDetails names the offer it was bought with for its whole life, so a full-price renewal still carries it + offerIn "basePrice" `shouldReturn` Right (Just False) + offerIn "prorationPeriod" `shouldReturn` Right (Just False) + offerFor (lineItem [] ["offerPhase"]) `shouldReturn` Right (Just False) + +testPlaySubscriptionUnreadable :: IO () +testPlaySubscriptionUnreadable = withFakePlay $ \fake -> do + verifier <- playVerifier fake + forM_ + [ PlayBody "not json", + PlayRecord $ J.object ["lineItems" J..= [lineItem [] []]], + PlayRecord $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [], + PlayRecord $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [] [], lineItem [] []], + PlayRecord $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [] ["expiryTime"]], + PlayRecord $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [] ["offerDetails"]], + PlayRecord $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [("expiryTime", "next month")] []], + PlayBody $ J.encode (subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [] []]) <> LB.replicate (1024 * 1024) 32 + ] + $ \answer -> do + answerPurchase fake subscriptionToken answer + outcome <$> playCheck verifier `shouldReturn` Failed + -- a state Play may yet add is this service's to learn, and its name is not logged + answerSubscription fake $ subscriptionRecord "SUBSCRIPTION_STATE_PAUSED_FOREVER" [] [lineItem [] []] + r <- playCheck verifier + outcome r `shouldBe` Failed + reason r `shouldNotSatisfy` ("PAUSED_FOREVER" `T.isInfixOf`) + +testPlaySubscriptionHttp :: IO () +testPlaySubscriptionHttp = withFakePlay $ \fake -> do + verifier <- playVerifier fake + let answeredWith answer = answerPurchase fake subscriptionToken answer >> (outcome <$> playCheck verifier) + answeredWith (PlayStatus 401) `shouldReturn` Failed + answeredWith (PlayStatus 403) `shouldReturn` Failed + forM_ [400, 404, 429, 500, 503] $ \code -> answeredWith (PlayStatus code) `shouldReturn` Unreachable + -- Play no longer answers about a subscription that expired long ago + answerPurchase fake subscriptionToken (PlayStatus 410) + ended <- playCheck verifier + (stateOf ended, chargeOf ended) `shouldBe` (Right SSEnded, Right Nothing) + answerPurchase fake subscriptionToken PlayHang + r <- playCheck verifier + (outcome r, reason r) `shouldBe` (Unreachable, "subscription check timed out") + +testPlaySubscriptionAcknowledges :: IO () +testPlaySubscriptionAcknowledges = withFakePlay $ \fake -> do + verifier <- playVerifier fake + let acknowledging = subscriptionAcknowledgement verifier SPGoogle {productId = subscriptionProductId, token = subscriptionToken} + answerSubscription fake $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [] []] + acknowledging `shouldReturn` Just (Right ()) + readTVarIO (fpSubscriptionAcknowledged fake) `shouldReturn` [(subscriptionProductId, subscriptionToken)] + answerSubscription fake $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [("acknowledgementState", "ACKNOWLEDGEMENT_STATE_ACKNOWLEDGED")] [lineItem [] []] + acknowledging `shouldReturn` Just (Right ()) + readTVarIO (fpSubscriptionAcknowledged fake) `shouldReturn` [(subscriptionProductId, subscriptionToken)] + readTVarIO (fpAcknowledged fake) `shouldReturn` [] + +testPlaySubscriptionAcknowledgementFails :: IO () +testPlaySubscriptionAcknowledgementFails = withFakePlay $ \fake -> do + verifier <- playVerifier fake + let acknowledgedAs expected = do + r <- subscriptionAcknowledgement verifier SPGoogle {productId = subscriptionProductId, token = subscriptionToken} + outcome <$> r `shouldBe` Just expected + maybe "" reason r `shouldSatisfy` ("acknowledging: " `T.isPrefixOf`) + maybe "" reason r `shouldNotSatisfy` (subscriptionToken `T.isInfixOf`) + answerSubscription fake $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [] []] + answerAcknowledgements fake $ Just $ PlayStatus 403 + acknowledgedAs Failed + answerAcknowledgements fake $ Just $ PlayStatus 503 + acknowledgedAs Unreachable + answerAcknowledgements fake Nothing + answerPurchase fake subscriptionToken PlayHang + acknowledgedAs Unreachable + readTVarIO (fpSubscriptionAcknowledged fake) `shouldReturn` [] + +-- | Without [google] a Play subscription is not configured, whether or not [apple] checks the App Store's. +testPlayConfiguredSubscriptions :: IO () +testPlayConfiguredSubscriptions = do + chain <- trustedChain + withFakePlay $ \play@FakePlay {fpConfig} -> withFakeAppStore ourBundleId $ \appStore@FakeAppStore {fasApi} -> do + let dir = takeDirectory (gServiceAccountFile fpConfig) + rootFile = dir "root.cer" + ini = dir "badge_service.ini" + apple = Just AppleStoreConfig {aBundleId = ourBundleId, aRootCertificates = rootFile :| [], aServerApi = Just fasApi} + configured c = (\ServiceState {storeVerifier} -> storeVerifier) <$> (newServiceState >>= configureStoreVerifier (Just c)) + outcomes v = (,) <$> (outcome <$> checkStoreSubscription v (SubscriptionGoogle subscriptionToken) Nothing) <*> (outcome <$> checkStoreSubscription v (SubscriptionApple subscriptionId) Nothing) + acknowledging v = subscriptionAcknowledgement v SPGoogle {productId = subscriptionProductId, token = subscriptionToken} + B.writeFile rootFile (encodeSignedObject $ rootCert chain) + writeFile ini "[listener]\nstatic_dir = /srv/badges\n" + Right cfg <- readServiceConfig ini + both <- configured cfg {appleStore = apple, playStore = Just fpConfig} + playOnly <- configured cfg {playStore = Just fpConfig} + appleOnly <- configured cfg {appleStore = apple} + answerSubscription play $ subscriptionRecord "SUBSCRIPTION_STATE_ACTIVE" [] [lineItem [] []] + serveStatus appStore chain 1 (subscriptionPayload [] []) (renewalPayload []) + outcomes both `shouldReturn` (Verdict, Verdict) + outcomes playOnly `shouldReturn` (Verdict, NotConfigured) + outcomes appleOnly `shouldReturn` (NotConfigured, Verdict) + acknowledging appleOnly `shouldReturn` Nothing + acknowledging playOnly `shouldReturn` Just (Right ()) + readTVarIO (fpSubscriptionAcknowledged play) `shouldReturn` [(subscriptionProductId, subscriptionToken)] + diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index 0421151050..52d4b5ace9 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/tests/Bots/BadgeService/WebTests.hs @@ -14,7 +14,8 @@ 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 (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, getManagedGroup, insertBadgeCode, insertManagedGroup, 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) import BadgeService.Web.Server @@ -40,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) @@ -61,7 +63,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.Service (BadgeOffer (..), BadgePrice (..)) +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) @@ -139,12 +142,13 @@ columnsOf st table = withConnection st $ \db -> badgeWebTests :: Spec badgeWebTests = do describe "badge service schema" $ do - it "carries the five service-only columns" testServiceColumns + it "carries the service-only columns, and none of the subscription columns it never wrote" testServiceColumns it "refuses a duplicate provider_ref" testProviderRefUnique it "M20260918 adds the multi-use columns and the group table" testGroupOpsColumns it "M20260918 defaults a fresh code to one use with none spent" testGroupOpsRedeemCounts it "migrates all the way down and up again" testSchemaDownUpCycle it "rolls back only the group migration and re-applies it, keeping a code redeemed twice spent" testGroupOpsDownUp + it "rolls back only the subscription migration, restoring the columns it dropped, and re-applies it" testSubscriptionsDownUp describe "badge service store" $ do it "writes the invoice, its code and their link atomically" testCreationIsAtomic it "newInvoiceId is 128 CSPRNG bits, base64url, and two calls differ" testNewInvoiceIdRandom @@ -157,6 +161,12 @@ badgeWebTests = do it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther 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 @@ -320,6 +330,16 @@ testServiceColumns = withServiceStore $ \st -> do columnsOf st "sx_badge_service_payments" >>= (`shouldSatisfy` elem "crypto_paid") columnsOf st "sx_badge_service_badge_codes" >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["expires_at", "revoked_at"]) + assertSubscriptionColumns st + +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` \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", "rebound_at"] + payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"]) testGroupOpsColumns :: IO () testGroupOpsColumns = withServiceStore assertGroupOpsColumns @@ -345,8 +365,23 @@ testSchemaDownUpCycle = withServiceStore $ \st -> do runMigrations st $ MTRDown downMigrations columnsOf st "sx_badge_service_badge_codes" `shouldReturn` [] columnsOf st "sx_badge_service_group" `shouldReturn` [] + columnsOf st "sx_badge_service_subscription_charges" `shouldReturn` [] runMigrations st $ MTRUp badgeServiceSchemaMigrations assertGroupOpsColumns st + assertSubscriptionColumns st + +testSubscriptionsDownUp :: IO () +testSubscriptionsDownUp = withServiceStore $ \st -> do + let subscriptions = [m | m@Migration {name = "20261012_badge_subscriptions"} <- badgeServiceSchemaMigrations] + 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` \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", "rebound_at"]) + runMigrations st $ MTRUp subscriptions + assertSubscriptionColumns st testGroupOpsDownUp :: IO () testGroupOpsDownUp = withServiceStore $ \st -> do @@ -698,6 +733,144 @@ testTimestampRoundTrip = withServiceStore $ \st -> do irExpiresAt row `shouldBe` truncated irCreatedAt row `shouldBe` truncated +testChargeCreditRoundTrip :: IO () +testChargeCreditRoundTrip = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + (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) + 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 @@ -984,7 +1157,9 @@ testServiceConfig staticDir trustForwarded = playStore = Nothing, issuer = Nothing, group = Nothing, - devAcceptUnverifiedStoreReceipts = False + devAcceptUnverifiedStoreReceipts = False, + devCheckStoreDuringCoverage = False, + devCreditTestPurchases = False } testServeWebappOff :: IO ()