diff --git a/apps/ios/Shared/Model/SimpleXAPI.swift b/apps/ios/Shared/Model/SimpleXAPI.swift index c322400800..5160d49857 100644 --- a/apps/ios/Shared/Model/SimpleXAPI.swift +++ b/apps/ios/Shared/Model/SimpleXAPI.swift @@ -2257,7 +2257,7 @@ func redeemErrorText(_ error: Error, purchase: Bool) -> String { } } if case .subscribedBefore? = error as? BadgeStoreError { - return NSLocalizedString("This Apple ID subscribed before. In the app, it can subscribe again only to continue this profile's last purchase, when that was a subscription to this badge.", comment: "alert message") + return NSLocalizedString("This Apple ID already has a badge subscription. Only the profile that bought it can continue it.", comment: "alert message") } return String.localizedStringWithFormat(NSLocalizedString("Error: %@", comment: "alert message"), responseError(error)) } diff --git a/apps/ios/Shared/Views/Badges/BadgesCheckOrderView.swift b/apps/ios/Shared/Views/Badges/BadgesCheckOrderView.swift index 392af670e9..fa178799df 100644 --- a/apps/ios/Shared/Views/Badges/BadgesCheckOrderView.swift +++ b/apps/ios/Shared/Views/Badges/BadgesCheckOrderView.swift @@ -57,7 +57,7 @@ struct BadgesCheckOrderView: View { } if !store.forSale(level, period) && store.subscribedBefore { - footnote("This Apple ID subscribed before. In the app, it can subscribe again only to continue this profile's last purchase, when that was a subscription to this badge.") + footnote("This Apple ID already has a badge subscription. Only the profile that bought it can continue it.") } Spacer(minLength: 20) @@ -72,9 +72,9 @@ struct BadgesCheckOrderView: View { Button("Privacy policy") { privacyPolicyActive = true } NavigationLink(isActive: $privacyPolicyActive) { ConditionsTextView() - .padding(.horizontal, 25) + .padding() .navigationTitle("Privacy policy") - .modifier(ThemedBackground()) + .modifier(ThemedBackground(grouped: true)) } label: { EmptyView() } diff --git a/apps/ios/Shared/Views/Badges/BadgesHowLongView.swift b/apps/ios/Shared/Views/Badges/BadgesHowLongView.swift index a308e05e92..d6530e3973 100644 --- a/apps/ios/Shared/Views/Badges/BadgesHowLongView.swift +++ b/apps/ios/Shared/Views/Badges/BadgesHowLongView.swift @@ -112,7 +112,7 @@ struct BadgesHowLongView: View { .fixedSize(horizontal: false, vertical: true) if !store.forSale(level, .monthly) && store.subscribedBefore { - Text("This Apple ID subscribed before. In the app, it can subscribe again only to continue this profile's last purchase, when that was a subscription to this badge.") + 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) diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md index c11413387f..53f2bebdd1 100644 --- a/apps/simplex-badge-service/README.md +++ b/apps/simplex-badge-service/README.md @@ -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 @@ -247,7 +248,10 @@ service_account_file = /etc/simplex-badge-service/play-service-account.json 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 sets `https://api.storekit-sandbox.itunes.apple.com`. A 401 or 403 + 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 @@ -268,9 +272,26 @@ service_account_file = /etc/simplex-badge-service/play-service-account.json 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. + ### Accepting store receipts unverified, for local testing ```ini @@ -293,14 +314,16 @@ length of its plan: test products sign their tokens so), or else the product's monthly base plan, so a licence tester's purchase is credited too; - a renewal: a new charge for the plan it first charged. It keeps that plan in memory only, so after - a restart it answers a renewal of a subscription it credited before as ended. + 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] @@ -309,16 +332,17 @@ 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, while its paid -coverage runs too, rather than once coverage has ended and at most once an hour. 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. 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. The mock charges anew at every +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 for `, which tells a banked month +`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 @@ -336,9 +360,14 @@ buy in) or a Play licence tester's, is refused `test_purchase` by default, which 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. Off by default, and only -`on`/`off` parse. A Sandbox subscription is read only through the sandbox host, so `[apple]` also -sets `api_host = https://api.storekit-sandbox.itunes.apple.com`. +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] @@ -349,9 +378,10 @@ 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. -No setting marks a production deployment, so the service cannot refuse this flag there: never turn -it on where released apps trust the issuer key, or anyone with a TestFlight build or a licence -tester's account gets a badge without paying. +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 2a086ab019..4403a98bd9 100644 --- a/apps/simplex-badge-service/badge_service.ini.example +++ b/apps/simplex-badge-service/badge_service.ini.example @@ -47,8 +47,10 @@ idle_seconds = 60 ; 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; -; a test deployment sets https://api.storekit-sandbox.itunes.apple.com. Keep the key file readable by this service alone. +; 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 @@ -90,11 +92,13 @@ 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, the base ; plan a Play test token test.. names, or the Play product's monthly one. The -; plans are kept in memory, so a restart answers later renewals as ended. Nothing is acknowledged, -; so Play refunds a licence tester's subscription once its acknowledgement window lapses. +; 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 @@ -105,6 +109,10 @@ 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. -; The service refuses to start with this on while apple.api_host is the production App Store, since a -; sandbox receipt verifies like any other and would then be credited as a real purchase. +; 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/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index dd8a10778f..8bd240ee56 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -170,6 +170,9 @@ defaultPlayApiHost = "https://androidpublisher.googleapis.com" 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" @@ -188,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 @@ -253,11 +266,7 @@ parseConfig ini = do 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 - -- A sandbox receipt verifies like any other and says so only in a field, so crediting test purchases - -- against production Apple would mint badges for anyone holding a sandbox account. A deployment that - -- means it points api_host at the sandbox; nothing else here distinguishes production. - when (devCreditTestPurchases && maybe False ((== defaultAppleApiHost) . aApiHost) (apple >>= aServerApi)) $ - Left "[dev] credit_test_purchases must be off where apple.api_host is the production App Store, as a sandbox receipt would be credited as a real purchase" + 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 @@ -379,7 +388,7 @@ parseConfig ini = do 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 <- optional "apple" "api_host" defaultAppleApiHost + 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" diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index ae9ab11a5e..301c3cd835 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -141,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 = @@ -339,8 +339,8 @@ processQueuedRequests key trackerQ_ env = do 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 write's tip --- re-read guards them while transactions run one at a time (SQLite; Postgres at --pool-size 1). +-- | 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 @@ -353,8 +353,9 @@ requestLane checks cc sigKey reqData = case J.fromJSON (J.Object reqData) of | sigKey == Just k -> do now <- badgeNow cc withDB' "requestLane" cc (\db -> getIssuePurchase db k) <&> \case - Right (Just (_, Just tip, Just subscription)) - | subscriptionCheckDue checks (addUTCTime routeLookahead now) tip subscription -> RenewalLane + -- 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 @@ -427,7 +428,7 @@ badgeServiceResponse key verifier checks cc trackerQ_ sigKey reqData = case J.fr J.Success BadgeServiceRequest {version, purchaseKey, request} | not (version `isCompatible` supportedBadgeServiceVRange) -> pure $ errorResponse BSEUnsupportedVersion | purchaseKey /= sigKey -> pure $ errorResponse BSEBadRequest - | otherwise -> logInfo ("badge request: " <> commandName request <> maybe "" ((" from " <>) . purchaseKeyPart) purchaseKey) >> 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 @@ -578,11 +579,12 @@ purchaseWithReceipt key cc verifier checks use purchaseKey masterKey StoreReceip 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 -- an Apple subscription, whose JWS was verified offline Just StoreSubscription -> purchaseSubscription (Just productId) Uncredited - Just StoreOneTime {badgeType, months} -> + 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 @@ -639,7 +641,7 @@ purchaseWithReceipt key cc verifier checks use purchaseKey masterKey StoreReceip \db purchaseId paymentId -> do insertSubscriptionCharge db paymentId chargeId charge now firstMonthResponse db purchaseId Nothing (Just subscriptionState) firstMonth - moveSubscription presented CreditedPurchase {badgePurchaseId = fromPurchaseId, purchaseKey = fromKey} checked@SubscriptionCheck {subscriptionState, latestCharge} + 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) = @@ -678,7 +680,7 @@ purchaseWithReceipt key cc verifier checks use purchaseKey masterKey StoreReceip setSubscriptionState db paymentId subscriptionState now Just <$> firstMonthResponse db purchaseId Nothing (Just subscriptionState) firstMonth case r of - Right (Just resp) -> logInfo ("store subscription moved from " <> purchaseKeyPart fromKey <> " to " <> purchaseKeyPart purchaseKey) $> resp + Right (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 @@ -696,7 +698,7 @@ purchaseWithReceipt key cc verifier checks use purchaseKey masterKey StoreReceip 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 + 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 @@ -739,6 +741,13 @@ fundsMonthNow purchaseKey now tip_ grant@(StoreCharge {periodStart}, (badgeType, 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 @@ -749,12 +758,6 @@ firstChargeNotGranted provider = \case -- 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} --- | Enough of the purchase key to follow one purchase through a log. It is a public key the request --- is signed by and the service stores, so a part of it tells an operator nothing new. Taken from the --- end, past the padding: every Ed25519 key shares the first 16 characters of this encoding. -purchaseKeyPart :: C.PublicKeyEd25519 -> T.Text -purchaseKeyPart = T.takeEnd 8 . T.dropWhileEnd (== '=') . safeDecodeUtf8 . strEncode - -- | 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 @@ -864,6 +867,7 @@ issueBadgeCmd key cc verifier purchaseKey upgrade_ BadgeBalance {lastEntry} = do -- 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) @@ -884,7 +888,7 @@ issueBadgeCmd key cc verifier purchaseKey upgrade_ BadgeBalance {lastEntry} = do -- Write only if the tip has not moved, since another request may have advanced it. 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 state_ pure $ fromRight (errorResponse BSEInternal) r @@ -926,7 +930,7 @@ issueBadgeCmd key cc verifier purchaseKey upgrade_ BadgeBalance {lastEntry} = do Left resp -> pure resp Right (rows, issuance) -> do r <- withDB "renewSubscription" cc $ \db -> liftIO $ do - tip' <- getLedgerTip db badgePurchaseId + tip' <- lockedLedgerTip db badgePurchaseId now if fmap entryId tip' /= Just (entryId tip) then pure Nothing else do @@ -961,9 +965,10 @@ issueBadgeCmd key cc verifier purchaseKey upgrade_ BadgeBalance {lastEntry} = do newChargeId <- randomId cc entryIds <- (,,,) <$> randomId cc <*> randomId cc <*> randomId cc <*> randomId cc r <- withDB' "checkStoreDuringCoverage" cc $ \db -> do - tip' <- getLedgerTip db badgePurchaseId + tip' <- lockedLedgerTip db badgePurchaseId now + ended <- coverageEnded db paymentId checked banked <- - if fmap entryId tip' == Just (entryId tip) + 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)) -> @@ -979,17 +984,60 @@ issueBadgeCmd key cc verifier purchaseKey upgrade_ BadgeBalance {lastEntry} = do setSubscriptionState db paymentId subscriptionState now pure bankedMonths else pure Nothing - (banked,) <$> getLedgerTip db badgePurchaseId + (ended, banked,) <$> getLedgerTip db badgePurchaseId case r of Left _ -> pure $ errorResponse BSEInternal - Right (banked, tip_) -> do + 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 for " <> purchaseKeyPart purchaseKey + 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 subscription = do let StatementEntry {entryId = assertedUuid} = lastEntry @@ -1005,10 +1053,11 @@ 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 = - paidThrough tip <= now && isNothing (checkWait now 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 diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index af560a1836..cec4de216a 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -26,6 +26,7 @@ module BadgeService.Store purchaseKeyExists, getPurchaseByKey, setPurchaseBadgeType, + lockedLedgerTip, getLedgerTip, getLedgerEntryId, getLedgerEntries, @@ -263,6 +264,13 @@ 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 $ @@ -453,7 +461,7 @@ data PaymentRebind = PaymentRebind -- moved the payment or the old purchase's ledger since fromTipId was read. rebindStorePayment :: DB.Connection -> PaymentRebind -> UTCTime -> IO (Maybe Int64) rebindStorePayment db PaymentRebind {paymentId, fromPurchaseId, fromTipId, fromRows, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do - tip <- getLedgerTip db fromPurchaseId + tip <- lockedLedgerTip db fromPurchaseId now if fmap entryId tip /= Just fromTipId then pure Nothing else do diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs index 3d49dbcd89..76f143e317 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs @@ -22,10 +22,11 @@ module BadgeService.StoreReceipts ) where -import BadgeService.Log (logInfo) +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) @@ -184,11 +185,12 @@ toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, ackn 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 -> (>>= notTest) <$> askStore verifyTimeout "subscription check" (check ref product_) + Just check -> askStore verifyTimeout "subscription check" (check ref product_) >>= either (pure . Left) notTest where - notTest = \case - SubscriptionCheck {testSubscription = True} | not creditTestPurchases -> Left SRTestPurchase - checked -> Right checked + 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 diff --git a/docs/protocol/badges-overview.md b/docs/protocol/badges-overview.md index 0cefe92408..cb3b4e0673 100644 --- a/docs/protocol/badges-overview.md +++ b/docs/protocol/badges-overview.md @@ -149,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. The months of an app store subscription are added as the store charges for them: the service asks the store whether it charged again once the paid months have run out, or at once when the app reports a higher tier, which it does for an App Store raise the device sees within a day of its charge. Any other App Store change of tier, a raise seen later included, is granted at the first check after the old plan's paid months run out, though Apple bills a raise at once. A Play plan change is 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. +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 whether it charged again once the paid months have run out, or 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. A Play plan change is 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. @@ -204,7 +204,7 @@ Service requests are protected by the double ratchet of the [SimpleX agent](http 1. A proof discloses no value that links it to another proof or to the purchase. 2. A proof used in one context, whether a session, a conversation or a file, cannot be used in another context. -3. The timing of presentations does not identify the holder: all credentials expiring in the same week share the same expiry, and the renewal request and the profile update are made on different days. A new badge or tier (after a purchase, a redemption, a Restore, a store subscription resumed after it lapsed, or a higher App Store tier the app reports within a day of its charge) is shown as soon as its credential is issued, so for these the request and the profile update are made together; a tier changed at a renewal check is shown when the current credential expires, as a renewal is. +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 or tier (after a purchase, a redemption, a Restore, a store subscription resumed after it lapsed, or a higher App Store tier the app reports) is shown as soon as its credential is issued, so for these the request and the profile update are made together; a tier changed 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. diff --git a/docs/protocol/badges-rpc.md b/docs/protocol/badges-rpc.md index d0515e4054..6eebc5ae0b 100644 --- a/docs/protocol/badges-rpc.md +++ b/docs/protocol/badges-rpc.md @@ -35,7 +35,7 @@ The client never states what is signed. The tier is that of whatever funded the - `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. 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 in a free trial or introductory price, 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: presented 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`. + - **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 in a free trial or introductory price, 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. - **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. @@ -59,10 +59,10 @@ The client never states what is signed. The tier is that of whatever funded the - `product_unavailable` and `provider_not_configured` as for the App Store, the latter without a `[google]` section. - Before crediting a purchase of a product it prices, the service acknowledges it, unless Play already reports it acknowledged or consumed; a subscription is acknowledged with `purchases.subscriptions.acknowledge` before its first charge is credited. It acknowledges and never consumes, so the app's purchase query still lists the purchase. The app may not be honest, and only acknowledgement stops Play refunding the purchase after three days, so nothing is credited unacknowledged. A failed acknowledgement credits nothing and is answered like a failed read — `provider_unavailable` when Play does not answer, `internal` when it refuses this service, both logged with "acknowledging" in the reason — and the app presents the purchase again. A deployment whose service account lacks the permission to acknowledge therefore answers `internal` to every Play purchase the app has not already acknowledged itself. - Funding by `receipt` is a transfer (post-MVP): the unissued months of the purchase that receipt belongs to move to the signing key, recorded as `debit(transferOut)` on the source and `credit(transferIn)` on the new purchase, and the presented receipt is retired for a fresh one. The transferred period's issuance debits a month like any other. Lifetime badges hold no receipt, so support handles them. -- `upgradeBadgeSubscription` → `badgeCredential` — 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 within a day of the device's clock (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 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`, and 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. +- `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.** While a store subscription's paid coverage runs, `issueBadge` is answered as above, without asking the store. Once it has ended, the service asks the store, at most once an hour per subscription whether or not the store answers, and answers requests in between from what it last read. A charge it can grant, by the rule `purchaseBadge` applies to a first charge but never twice, is granted at the store's period start, or at the ledger's last row when that is later, so rows are never dated before the row they follow, after a lapse of what ran out before it, and the month due is issued. A charge of another badge type is granted as that type: what remains of the old run is debited as `upgrade` naming the purchase's own key, the new run starts at that date, and the purchase's badge type follows it. Otherwise no ledger row is written: the charge, if any, and the state are recorded, and the answer carries no new `credential` and the `subscription` the store reported. A store that does not answer is answered `provider_unavailable` with a `retryAfter` of the hour. Every answer for a subscription purchase carries `subscription`. A development deployment may ask its store at every request, during coverage too, and bank the months of a charge it can grant, issued once coverage reaches them; a real store is asked during coverage only by a development deployment that also credits test purchases. + - **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 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 @@ -71,7 +71,7 @@ Always a new purchase under a new key, except App Store subscriptions, where the - 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 within a day of its purchase date, and is granted as soon as the store reports the charge. Every other change — every lower tier, which Apple charges from the next renewal, a change of plan length, and a higher tier the device sees later — 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. +- 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. One made in Play's own pages 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 diff --git a/scripts/badge-service/badge_service.ini.example b/scripts/badge-service/badge_service.ini.example index 538727d779..d6bd216818 100644 --- a/scripts/badge-service/badge_service.ini.example +++ b/scripts/badge-service/badge_service.ini.example @@ -42,7 +42,8 @@ idle_seconds = 60 ; 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. +; 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 @@ -78,11 +79,13 @@ 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, the base ; plan a Play test token test.. names, or the Play product's monthly one. The -; plans are kept in memory, so a restart answers later renewals as ended. Nothing is acknowledged, -; so Play refunds a licence tester's subscription once its acknowledgement window lapses. +; 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 = on: every issue request for a subscription asks the diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 6d3164ff05..ec8704579c 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -5384,12 +5384,17 @@ handOverStoreReceipt presentingUser echoedInvoiceId origin payment = do RSHeld {} -> lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner RSCredited {badgePurchaseId, refusalRecorded} -> do let rehold kind = withStore' $ \db -> reholdStoreReceipt db owner receiptId badgePurchaseId kind payment now - answeredHeld <- case resumableCharge now payment of + 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 purchasedAt | not (refusalRecorded && resumeHoldEnded now purchasedAt) -> rehold SHKPurchase + Just (RHPurchasedAt purchasedAt) | not (refusalRecorded && resumeHoldEnded now purchasedAt) -> rehold SHKPurchase + -- 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, or every sweep would hold it and send it again - tierChangeHeld <- case tierChangeCharge now payment of + tierChangeHeld <- case tierChangeCharge now lastChargeAt_ payment of Just tier | not (answeredHeld || refusalRecorded) -> withStore' (`getBadgePurchase` badgePurchaseId) >>= \case @@ -5464,21 +5469,36 @@ resumableCharge now = \case resumeHoldEnded :: UTCTime -> UTCTime -> Bool resumeHoldEnded now purchasedAt = resumeHoldLimit `addUTCTime` purchasedAt <= now --- | How far a tier change's purchase date may be from this device's clock, either way, for it to be asked of the service --- at once; past it, the service grants the change at its next renewal check. -tierChangeWindow :: NominalDiffTime -tierChangeWindow = nominalDay +-- | 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 --- | The tier of an Apple subscription charge that may change the tier of a shown purchase: not revoked, and bought --- within the window. Read from the unverified payload, which decides only what to ask the service and wait for. -tierChangeCharge :: UTCTime -> ServicePayment -> Maybe BadgeType -tierChangeCharge now = \case +-- | 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, revoked = False, autoRenewable = True} <- appleTransactionFacts jws, + | Just AppleTransactionFacts {productId = Just planId, purchaseDate = Just purchased, expiresDate, revoked = False, autoRenewable = True} <- appleTransactionFacts jws, Just (tier, _) <- storePlan PPApple planId, - abs (diffUTCTime (posixSecondsToUTCTime $ fromIntegral purchased / 1000) now) < tierChangeWindow -> + 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 @@ -5507,11 +5527,12 @@ 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 always blocks, as Apple keeps --- charging it; any other only while its last failure, if any, can clear, since one that failed for good waits anyway. +-- | 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. refuseWhileStoreReceiptPending :: User -> CM () refuseWhileStoreReceiptPending user = do - pending <- withStore' (`getPendingStoreReceipts` user) + now <- badgeNow + pending <- withStore' $ \db -> getPendingStoreReceipts db user now when (any blocks pending) $ throwRedeemError BREStorePurchaseOpen where blocks (payment, failure_) = appleSubscription payment || maybe True badgeFailureTransient failure_ @@ -5666,7 +5687,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' () @@ -5684,10 +5706,10 @@ runStoreReceiptWorker a userId Worker {doWork} = do 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) @@ -5713,15 +5735,17 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa 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) $ - 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 + -- 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 @@ -5737,12 +5761,15 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa _ -> pure () where credit ri delay cmd = - tryAllErrors (attempt cmd) >>= \case - Right (Right (present_, _)) -> pure $ SROCredited present_ - Right (Left (code, retryAfter)) - | storeReceiptRefused code -> refuse $ serviceFailure code retryAfter - | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter - Left e -> failed ri delay (badgeIssueFailure e) Nothing + 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 @@ -5756,46 +5783,48 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa 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 purchasedAt <- resumableCharge now =<< decodeJSON payment -> resumeIssue ri delay user p purchasedAt now + | isNewest, Just hold <- resumeHold now =<< decodeJSON payment -> resumeIssue ri delay user p hold now _ -> refuse receiptInvalid - resumeIssue ri delay user p@UserBadgePurchase {badgePurchaseId} purchasedAt now = do + 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 holding - | resumeHoldEnded answeredAt purchasedAt = refuse receiptInvalid - | otherwise = holding - case answer of - Left e -> failed ri delay (badgeIssueFailure e) Nothing - Right (Left (code, retryAfter)) - | storeReceiptRefused code -> refuse $ serviceFailure code retryAfter - | otherwise -> notCredited $ failed ri delay (serviceFailure code retryAfter) retryAfter - Right (Right (balance, stored)) -> - withStore' (`getLatestIssuedCredential` badgePurchaseId) >>= \case - Just cred@(BadgeCredential _ _ _ info) - | L.paidThrough balance > answeredAt && credentialExpiry cred > answeredAt && stored /= Just SSEnded -> do - user' <- withStore $ \db -> do - liftIO $ showResumedPurchase 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 $ failed ri delay BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600) - -- Settles with nothing to announce: past the window, 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. + 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 payment', raisesTier badgeType tier -> upgradeIssue ri delay user p payment' tier now - _ -> SRODeferred <$ withStore' (`settleStoreReceipt` receiptId) + | 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 @@ -5803,22 +5832,27 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa answer <- tryAllErrors $ requireBadgeService >>= \sendTarget -> sendBadgeIssue sendTarget userId p upgradeCmd (atomically . writeTVar failure_ . Just) now answeredAt <- badgeNow recorded_ <- readTVarIO failure_ - case answer of - Left e -> failed ri delay (badgeIssueFailure e) Nothing - Right (Left (code, retryAfter)) - | storeReceiptRefused code -> SRODeferred <$ withStore' (\db -> refuseStoreReceipt db receiptId $ serviceFailure code retryAfter) - | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter - Right (Right _) | Just failure <- recorded_ -> failed ri delay failure Nothing - Right (Right (_, stored)) -> + let refusedInSilence failure = SRODeferred <$ withStore' (\db -> refuseStoreReceipt db receiptId 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 $ showTierChangedPurchase db user receiptId badgePurchaseId + 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') - _ -> failed ri delay BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600) + _ -> 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} refuse failure = SRORefused failure <$ withStore' (\db -> refuseStoreReceipt db receiptId failure) serviceFailure code retryAfter = BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter} @@ -5853,7 +5887,7 @@ updateUserBadge userId emitted now = do _ -> pure False latest <- withStore' (`getLatestIssuedCredential` badgePurchaseId) devRequestInterval <- asks $ badgeDevRequestInterval . config - let due = not retiredBefore && (isJust devRequestInterval || badgeRequestDue now purchaseKind (shownBadgeCredential user p) latest balance) + 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. @@ -5917,6 +5951,8 @@ updateUserBadge userId emitted now = do -- | 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 +-- 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 @@ -5970,7 +6006,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} @@ -6169,8 +6206,8 @@ sendBadgeIssue sendTarget userId UserBadgePurchase {badgePurchaseId, badgeType, (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 - (Nothing, _, _) | maybe False ((> storedAt) . L.paidThrough) balance_ -> recordUnexpected "badge service issued no credential" + -- 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 diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 1ce177805d..44defe75b3 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -28,17 +28,20 @@ module Simplex.Chat.Store.Badges StoreHoldKind (..), holdStoreReceipt, holdStoreTransfer, + purchaseMovedOut, + paymentMovedOut, getReceiptRecord, createBadgeStoreReceipt, getOpenStorePurchases, getPendingStoreReceipts, getNextHeldStoreReceipt, + getStoreReceiptFailures, + storeReceiptHeldFor, recordStoreReceiptFailure, refuseStoreReceipt, settleStoreReceipt, reholdStoreReceipt, - showResumedPurchase, - showTierChangedPurchase, + showChargedPurchase, deleteUnfundedStoreReceipts, deleteBadgeCodeRedemption, createStashBadgePurchase, @@ -48,6 +51,7 @@ module Simplex.Chat.Store.Badges storeBadgeStatement, setBadgePurchaseType, getBadgeLedgerLastEntry, + getLastChargeCreditAt, getBadgeLedger, getBadgeLedgerEntryId, ) @@ -60,9 +64,11 @@ 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 (..)) @@ -216,10 +222,11 @@ holdStoreReceipt db g User {userId} origin invoiceId_ txRef@StoreTransactionRef |] ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, holdKind, now)) --- | Restore's hand-over of a transaction already recorded: a record that funds no purchase of this profile, or only one --- its payment moved away from, is taken by this profile and held as a move of its payment to it. True when its last refusal was transfer_limited, which the hand-over answers. +-- | Restore's hand-over of a transaction already recorded: a record that funds no purchase of this profile, only one +-- its payment moved away from, or one neither shown nor this profile's newest, which no resume reaches, is taken by +-- this profile and held as a move of its payment to it. True when its last refusal was transfer_limited, which the hand-over answers. holdStoreTransfer :: DB.Connection -> TVar ChaChaDRG -> User -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO Bool -holdStoreTransfer db g User {userId} txRef payment now = +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 @@ -246,19 +253,33 @@ holdStoreTransfer db g User {userId} txRef payment now = _ -> False _ -> pure False where - -- the service answers a purchase whose payment moved away ended, so a resume of it never succeeds movesHere ownerId badgePurchaseId | ownerId /= userId = pure True - | otherwise = maybe False movedOut <$> getBadgeLedgerLastEntry db badgePurchaseId - movedOut StatementEntry {entryType} = case entryType of - SEDebit SDTransferOut {} -> True - _ -> False + | otherwise = do + movedOut <- purchaseMovedOut db badgePurchaseId + p_ <- getBadgePurchase db badgePurchaseId + newestId <- fmap (\UserBadgePurchase {badgePurchaseId = i} -> i) <$> getUserBadgePurchase db user + let unreached = case p_ of + -- a one-time purchase is never moved, as its months were issued when it was bought + Just UserBadgePurchase {shown = False, purchaseKind = PKSubscription _} -> newestId /= Just badgePurchaseId + _ -> False + pure $ movedOut || unreached 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) +-- | 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. @@ -309,31 +330,35 @@ 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} --- | Each held receipt's payment and its last attempt's failure, if any. -getPendingStoreReceipts :: DB.Connection -> User -> IO [(Text, Maybe BadgeIssueFailure)] -getPendingStoreReceipts db User {userId} = - DB.query db "SELECT payment, credit_error FROM badge_store_receipts WHERE user_id = ? AND payment IS NOT NULL" (Only userId) +-- | 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. -getNextHeldStoreReceipt :: DB.Connection -> UserId -> IO (Either StoreError (Maybe BadgeReceiptRecord)) -getNextHeldStoreReceipt db userId = - fmap Right . maybeFirstRow toHeld $ +-- 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| @@ -344,12 +369,31 @@ getNextHeldStoreReceipt db userId = 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 |] (userId, SHKTierChange) where 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 + +-- | 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 () @@ -397,7 +441,7 @@ reholdStoreReceipt db owner receiptId badgePurchaseId holdKind payment now = do | newestId == badgePurchaseId -> case holdKind of SHKTierChange | shown -> True <$ hold SHKPurchase | not shown -> do - pending <- getPendingStoreReceipts db owner + pending <- getPendingStoreReceipts db owner now True <$ when (null pending) hold _ -> pure False _ -> pure False @@ -408,21 +452,14 @@ reholdStoreReceipt db owner receiptId badgePurchaseId holdKind payment now = do "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 credit. The purchase keeps only the state the answer stored, so an ended state from before does not --- retire it again. -showResumedPurchase :: DB.Connection -> User -> Int64 -> Int64 -> Maybe SubscriptionState -> IO () -showResumedPurchase db User {userId} receiptId badgePurchaseId state = do +-- | 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 tier change's credit: shows the purchase again if a retire cleared it meanwhile, and drops an ended its grant disproves. -showTierChangedPurchase :: DB.Connection -> User -> Int64 -> Int64 -> IO () -showTierChangedPurchase db User {userId} receiptId badgePurchaseId = do - settleStoreReceipt db receiptId - DB.execute db "UPDATE badge_purchases SET subscription_status = NULL WHERE badge_purchase_id = ? AND subscription_status = ?" (badgePurchaseId, SSEnded) - 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 () deleteUnfundedStoreReceipts db createdBefore = @@ -742,6 +779,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 = diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index 6d5cdda74a..dd652372e1 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -117,7 +117,7 @@ badgeTests = do 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, and leaves prepaid alerts as they were" testSubscriptionAlertDerivation + 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 @@ -1316,9 +1316,10 @@ testSubscriptionAlertDerivation = do soon = addUTCTime (-nominalDay) ends past = addUTCTime nominalDay ends subscription months st = SB.PKSubscription BadgeSubscription {planMonths = months, status = st, transactionRef = Nothing} - alertOf t kind' isShown err = + 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 balance + in (\BT.BadgeAlert {kind, date} -> (kind, date)) <$> derivedBadgeAlert t p Nothing tip renewing = Just SSRenewing cancelled = Just SSCancelled billingRetry = Just SSBillingRetry @@ -1356,6 +1357,11 @@ testSubscriptionAlertDerivation = do -- 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 diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index d450b54b04..33ac486708 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -68,12 +68,12 @@ import qualified Simplex.Chat.Badges.Types as BT import Simplex.Chat.Bot.Store (withDB') import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError (..), ChatErrorType (..), ChatResponse (CRBadgeState, CRCustomChatResponse)) import Simplex.Chat.Core (sendChatCmdStr) -import Simplex.Chat.Library.Commands (resumeHoldLimit, subscriptionRecoveryWindow) +import Simplex.Chat.Library.Commands (heldChargeAttempts, resumeHoldLimit, subscriptionRecoveryWindow) import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Chat.PaymentService (ServicePayment (..), googlePurchaseRef) -import Simplex.Chat.PaymentService.Types (InvoiceId (..)) -import Simplex.Chat.Store.Badges (StoreHoldKind (..), clearShownBadge, getLatestIssuedCredential, getNextHeldStoreReceipt, reholdStoreReceipt) +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 (..)) @@ -177,6 +177,7 @@ badgeServiceTests = do 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 @@ -214,16 +215,20 @@ badgeServiceTests = do 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, retire it on the old one, and credit one credited nowhere" testRestoreOnNewDevice + 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 @@ -246,7 +251,7 @@ badgeServiceTests = do 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" testDevIntervalRequests + 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 @@ -258,7 +263,12 @@ badgeServiceTests = do 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 retire a subscription badge the service answers ended while its ledger still covers, and credit a new subscription after it" testSubscriptionEndsWhileCovered + 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 @@ -271,14 +281,23 @@ badgeServiceTests = do 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, with the state the service ended it with cleared" testAppleResubscribeResumesWithinCoverage + 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 window has passed" testAppleTierChangeWindowEnds + 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 @@ -293,7 +312,7 @@ badgeServiceTests = do 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 answer ended after the mock restarts" testStoreChecksDuringCoverage + 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 @@ -909,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 -> @@ -2237,9 +2261,13 @@ testSubscriptionPurchaseNotGrantable ps = -- | 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@BadgeServiceEnv {bsStore} = do +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 "subscr-badge-supporter-month-02" firstStart 1 + 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) @@ -2997,11 +3025,13 @@ testRestoreOnNewDevice ps = alice `send` ("/_badge purchase 1 " <> paymentArg subscriptionPlay) waitShownBadge (chatController alice) (Just 1) aliceRows <- ledgerRows (chatController alice) "badge_ledger" - nextClaimCheck env + -- 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" @@ -3015,6 +3045,45 @@ testRestoreOnNewDevice ps = 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} -> @@ -3131,6 +3200,28 @@ testRestoreLeavesTierChangeHold ps = 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} -> @@ -3208,6 +3299,43 @@ testRestoreTakesHeldPurchase ps = 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} -> @@ -3477,6 +3605,18 @@ testDevIntervalRequests ps = 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 = @@ -3751,25 +3891,133 @@ testSubscriptionEndsWhileCovered ps = inAnyOrder alice [[openPurchase ""], ["1: supporter"]] waitWakeArmed (chatController alice) rows <- ledgerRows (chatController alice) "badge_ledger" - -- stands in for an ended answer while the client's ledger still covers, as clocks that disagree give; - -- month 2 is issued only because of the stand-in, as a store check that finds ended grants nothing - withTransaction chatStore $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET subscription_state = 'ended'" + 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 $ fst $ renewalMoments rows + setClockAt bsClock requestAt alice `send` "/_app activate" - alice <### ["/_app activate", "ok", Predicate (\l -> "1: supporter, 10 months left" `isPrefixOf` l && ", subscription ended" `isInfixOf` l)] + 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", openPurchase ""], ["2: supporter"]] + 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} -> @@ -3956,7 +4204,8 @@ paymentIssue = StartsWith "badge alert: payment_issue " subscriptionCancelled :: ConsoleResponse subscriptionCancelled = StartsWith "badge alert: subscription_cancelled " --- | The service answers a request made while coverage runs from the state it stored, which for an annual plan is up to a year old. +-- | The service answers a request made within the hour of its last check from the state it stored, which a client +-- does not take while coverage runs. testAnnualStateNotFromStoredAnswer :: HasCallStack => TestParams -> IO () testAnnualStateNotFromStoredAnswer ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc@ChatController {chatStore}, bsStore = store} -> @@ -3969,9 +4218,10 @@ testAnnualStateNotFromStoredAnswer ps = 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"] - withTransaction chatStore $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET subscription_state = 'renewing'" + 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 $ fst $ renewalMoments rows + setClockAt bsClock requestAt alice ##> "/_app activate" alice <## "ok" _ <- waitLedgerRows (chatController alice) 3 @@ -4129,32 +4379,165 @@ testAppleResubscribeResumes ps = testAppleResubscribeResumesWithinCoverage :: HasCallStack => TestParams -> IO () testAppleResubscribeResumesWithinCoverage ps = - -- retired within its coverage on an ended answer, as clocks that disagree give - withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = ChatController {chatStore}, bsStore = store@FakeStore {appleSubscriptionJWS}} -> + -- 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 - appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" firstStart 12 + 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" - withTransaction chatStore $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET subscription_state = 'ended'" - setClockAt bsClock $ fst $ renewalMoments rows + appleStoreReports store $ subscriptionCheck SSEnded $ Just yearly {revoked = True} + let requestAt = fst $ renewalMoments rows + setClockAt bsClock requestAt alice `send` "/_app activate" - alice <### ["/_app activate", "ok", Predicate (\l -> "1: supporter" `isPrefixOf` l && ", subscription ended" `isInfixOf` l)] + 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 - -- stands in for the service's check finding the new charge - withTransaction chatStore $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET subscription_state = 'renewing'" - now <- serviceNow env - alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleResubscription "2000000812345691" now}) - expectLinesWithin 30 alice ["1: supporter", openPurchase "", "1: supporter"] ["subscribed "] + -- 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) - subscriptionStatuses (chatController alice) `shouldReturn` [Nothing] + 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} -> @@ -4262,6 +4645,47 @@ testAppleTierChangeHandOver ps = 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}} -> @@ -4282,16 +4706,16 @@ testAppleTierChangeStoreLags ps = heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0 purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["legend"] -testAppleTierChangeWindowEnds :: HasCallStack => TestParams -> IO () -testAppleTierChangeWindowEnds ps = - withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store@FakeStore {appleLegendSubscriptionJWS}} -> +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 = appleLegendSubscriptionJWS}) + 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 "] - -- past the window the record settles with no change and no request, and the renewal check is left to grant it + -- 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 @@ -4305,6 +4729,58 @@ testAppleTierChangeWindowEnds ps = 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 @@ -4384,6 +4860,23 @@ testAppleTierChangeClearsEnded ps = 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 @@ -4823,13 +5316,19 @@ testStoreChecksDuringCoverage ps = -- 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 + -- 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 - subscriptionOf ended `shouldBe` Just SSEnded - map entryTag (entries ended) `shouldBe` [] + (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} @@ -5047,6 +5546,37 @@ testRedeemRefusedWhileReceiptHeld ps = 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 @@ -5414,8 +5944,8 @@ testStoreRouting ps = _ <- assertBalance env subscriberKey (last purchased) subscriptionChecks store `shouldReturn` checks + 1 [Just lastCheck] <- subscriptionCheckedAt cc - routedAt (addUTCTime 3530 lastCheck) `shouldReturn` MainLane - routedAt (addUTCTime 3550 lastCheck) `shouldReturn` RenewalLane + -- 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 @@ -5544,7 +6074,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 4b9aa6771a..722dd453b3 100644 --- a/tests/Bots/BadgeService/ConfigTests.hs +++ b/tests/Bots/BadgeService/ConfigTests.hs @@ -60,13 +60,15 @@ badgeConfigTests = describe "badge service config" $ do 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 [apple] and [google]" testDevCreditTestPurchasesBesideStores - it "reads check_store_during_coverage = on beside credit_test_purchases = on, with no store and beside [apple] or [google]" testDevStoreChecksWithCredit + 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 "reads the App Store Server API key, defaulting to the production host" testAppleServerApi + 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 @@ -434,13 +436,23 @@ testDevCreditTestPurchasesNotBoolean = withDev "credit_test_purchases = yes\n" $ testDevCreditTestPurchasesBesideStores :: IO () testDevCreditTestPurchasesBesideStores = - forM_ [appleIni, googleIni] $ \stores -> + 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_ ["", appleIni, googleIni] $ \stores -> + 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) @@ -488,6 +500,12 @@ testStoresIncomplete = do 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 @@ -500,9 +518,12 @@ testAppleServerApi = do aPrivateKeyFile = "/etc/badges/AuthKey_2X9R4HXF34.p8", aApiHost = "https://api.storekit.itunes.apple.com" } - withIni (fullIni <> appleIni <> appleApiIni <> "api_host = https://api.storekit-sandbox.itunes.apple.com\n") $ \p -> do + withIni (fullIni <> appleApiHostIni "HTTPS://API.STOREKIT.ITUNES.APPLE.COM//") $ \p -> do Right cfg <- readServiceConfig p - (aApiHost <$> (appleStore cfg >>= aServerApi)) `shouldBe` Just "https://api.storekit-sandbox.itunes.apple.com" + (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 () @@ -516,6 +537,14 @@ testAppleServerApiIncomplete = do 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 = forM_ [appleIni, googleIni] $ \stores ->