badge-service: ask Play about a subscription purchase at most once an hour per token

The purchase path's hourly bound covered only App Store claims, so a re-presented Play subscription token, uncredited or credited to another key, spent a subscriptionsv2.get call each time, from the quota bucket Play renewal checks use. The bound now lives in purchaseSubscription, which both stores' purchase paths call, with one map per store: Play's keyed by the token's hash, so made-up Play tokens cannot fill the App Store's. Distinct made-up tokens are still one call each.

Run: 005-subscriptions-load-timing, slice 6

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

@@ -14,7 +14,8 @@ module BadgeService.Service
     badgeServiceCLI,
     badgeServiceResponse,
     mayAskStore,
-    PurchaseChecks,
+    PurchaseChecks (..),
+    ClaimChecks,
     newPurchaseChecks,
     purchaseCheckWait,
     maxPurchaseChecks,
@@ -518,15 +519,7 @@ purchaseWithReceipt key cc verifier checks purchaseKey masterKey StoreReceipt {t
     newPurchase tx@VerifiedStoreTransaction {productId, paid} = case storeProduct provider productId of
       Nothing -> pure $ errorResponse BSEProductUnavailable
       -- an Apple subscription, whose JWS was verified offline
-      Just StoreSubscription -> do
-        now <- badgeNow cc
-        atomically (purchaseCheckWait checks now providerRef) >>= \case
-          Nothing ->
-            purchaseSubscription (Just productId) Uncredited >>= \case
-              -- no store was asked, so the claim is not held off
-              resp@BSPError {code = BSEProviderNotConfigured} -> resp <$ atomically (modifyTVar' checks $ M.delete providerRef)
-              resp -> pure $ atLeastCheckInterval resp
-          Just remaining -> pure BSPError {code = BSEPaymentPending, message = Nothing, retryAfter = Just (ceiling remaining)}
+      Just StoreSubscription -> purchaseSubscription (Just productId) Uncredited
       Just StoreOneTime {badgeType, months} ->
         acknowledged (($ tx) <$> acknowledgeReceipt) $ do
           now <- badgeNow cc
@@ -535,13 +528,23 @@ purchaseWithReceipt key cc verifier checks purchaseKey masterKey StoreReceipt {t
             Right firstMonth ->
               claimPurchase now (\paymentId -> NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType, subscriptionState = Nothing, providerToken = Nothing}) $
                 \db purchaseId paymentId -> firstMonthResponse db purchaseId (Just paymentId) Nothing firstMonth
-    -- another key's credit is told only once the store vouched for the subscription, as for a one-time purchase
-    purchaseSubscription product_ credit =
-      checkStoreSubscription verifier subscriptionRef product_ >>= \case
-        Left refusal -> storeRefusalResponse refusal
-        Right checked -> case credit of
-          Uncredited -> newSubscription checked
-          _ -> answerCredit credit
+    -- another key's credit is told only once the store vouched for the subscription, as for a one-time purchase;
+    -- the store is asked about a claim at most once an interval on this path, whoever presents it
+    purchaseSubscription product_ credit = do
+      now <- badgeNow cc
+      atomically (purchaseCheckWait claimChecks now providerRef) >>= \case
+        Just remaining -> pure BSPError {code = BSEPaymentPending, message = Nothing, retryAfter = Just (ceiling remaining)}
+        Nothing ->
+          checkStoreSubscription verifier subscriptionRef product_ >>= \case
+            -- no store was asked, so the claim is not held off
+            Left SRNotConfigured -> atomically (modifyTVar' claimChecks $ M.delete providerRef) >> storeRefusalResponse SRNotConfigured
+            Left refusal -> atLeastCheckInterval <$> storeRefusalResponse refusal
+            Right checked -> atLeastCheckInterval <$> case credit of
+              Uncredited -> newSubscription checked
+              _ -> answerCredit credit
+    claimChecks = case subscriptionRef of
+      SubscriptionApple _ -> appleChecks checks
+      SubscriptionGoogle _ -> googleChecks checks
     newSubscription checked@SubscriptionCheck {subscriptionState} = do
       now <- badgeNow cc
       case grantableCharge provider Nothing now checked >>= fundsMonthNow now Nothing of
@@ -618,7 +621,7 @@ fundsMonthNow now tip_ grant@(StoreCharge {periodStart}, (badgeType, months))
   where
     tip = fromMaybe (emptyEntry periodStart badgeType) tip_
 
--- | No payment row exists yet to stamp, so an App Store claim's checks are bounded by the purchase checks, a Play one's by each answer's retryAfter.
+-- | No payment row exists yet to stamp, so a first purchase's checks are bounded by the purchase checks.
 firstChargeNotGranted :: PaymentProvider -> NotGranted -> IO BadgeServiceResponse
 firstChargeNotGranted provider = \case
   NGMalformedPeriod -> storeRefusalResponse $ SRVerifierFailed "a charge whose period does not end after its start"
@@ -785,15 +788,18 @@ atLeastCheckInterval = \case
   BSPError {code, message, retryAfter = Just t} -> BSPError {code, message, retryAfter = Just $ max t $ round subscriptionCheckInterval}
   resp -> resp
 
--- | The App Store subscription claims the purchase path asked its store about, by original transaction id.
-type PurchaseChecks = TVar (M.Map T.Text UTCTime)
+-- | The subscription claims the purchase path asked a store about, one map per store: the App Store's by original
+-- transaction id, Play's by the token's hash, so Play tokens, which cost nothing to make up, cannot fill the App Store's.
+data PurchaseChecks = PurchaseChecks {appleChecks :: ClaimChecks, googleChecks :: ClaimChecks}
+
+type ClaimChecks = TVar (M.Map T.Text UTCTime)
 
 newPurchaseChecks :: IO PurchaseChecks
-newPurchaseChecks = newTVarIO M.empty
+newPurchaseChecks = PurchaseChecks <$> newTVarIO M.empty <*> newTVarIO M.empty
 
 -- | How long a claim waits before its store is asked again; Nothing records a check at now. A claim that finds
 -- the table full of checks inside the interval is asked without being recorded, so a full table refuses no one.
-purchaseCheckWait :: PurchaseChecks -> UTCTime -> T.Text -> STM (Maybe NominalDiffTime)
+purchaseCheckWait :: ClaimChecks -> UTCTime -> T.Text -> STM (Maybe NominalDiffTime)
 purchaseCheckWait checks now ref = stateTVar checks $ \m ->
   let live = M.filter (\t -> diffUTCTime now t < subscriptionCheckInterval) m
    in case M.lookup ref live of
@@ -802,6 +808,7 @@ purchaseCheckWait checks now ref = stateTVar checks $ \m ->
           | M.size live >= maxPurchaseChecks -> (Nothing, live)
           | otherwise -> (Nothing, M.insert ref now live)
 
--- | Far above an hour of genuine App Store subscription purchases: every key is one Apple signed for this app.
+-- | Per store, far above an hour of genuine purchases: every App Store key is one Apple signed for this app,
+-- while Play keys cost nothing to make up, so a full Play map only stops recording Play claims.
 maxPurchaseChecks :: Int
 maxPurchaseChecks = 10000

docs/protocol/badges-rpc.md

@@ -34,7 +34,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 an App Store subscription is asked about at most once an hour per original transaction id on this path: presented again inside that hour, by any key and 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. A Play subscription's checks are bounded by `retryAfter` alone. The answers: `payment_pending` with the usual 300 seconds (an hour for an App Store subscription) 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: 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. 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; `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.

tests/Bots/BadgeService/BotTests.hs

@@ -218,6 +218,7 @@ 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 ask the App Store about a subscription claim at most once an hour, whoever presents it and as any of its transactions" testApplePurchaseChecksBounded
+    it "should ask Play about a subscription token at most once an hour, whoever presents it, credited to another key or not" testPlayPurchaseChecksBounded
     it "should keep at most the maximum of purchase checks, asking without recording once full, and drop expired ones" testPurchaseChecksBounded
     it "should refuse an App Store Sandbox subscription as a test purchase without asking Apple" testAppleSandboxSubscriptionNotAsked
     it "should answer an App Store subscription provider_not_configured without an API key, and credit a one-time purchase" testAppleSubscriptionWithoutApiKey
@@ -2044,7 +2045,7 @@ subscriptionPayments ChatController {chatStore} =
 
 testSubscriptionPurchase :: HasCallStack => TestParams -> IO ()
 testSubscriptionPurchase ps =
-  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleSandboxSubscriptionJWS}} -> do
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleSandboxSubscriptionJWS}} -> do
     now <- serviceNow env
     let periodStart = addUTCTime (-3600) now
         changes = map (\e -> let (c, m, _) = entryOf e in (c, m)) . fst . statementOf
@@ -2066,6 +2067,8 @@ testSubscriptionPurchase ps =
     subscriptionOf replayed `shouldBe` Just SSRenewing
     subscriptionChecks store `shouldReturn` checks
     (otherKey, otherMasterKey) <- newPurchaseKeys
+    -- another key is told once Play is asked again, after the hour the token is held for
+    setClockAt bsClock $ addUTCTime 3700 now
     refusalOf <$> serviceCmd env otherKey (purchaseCmd otherMasterKey subscriptionPlay) `shouldReturn` (BSEReceiptUsed, Nothing)
     -- an annual Apple subscription is claimed by its original id, which the store is asked about
     setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" periodStart 12
@@ -2086,17 +2089,19 @@ testSubscriptionPurchase ps =
 
 testSubscriptionPurchaseNotGrantable :: HasCallStack => TestParams -> IO ()
 testSubscriptionPurchaseNotGrantable ps =
-  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do
     now <- serviceNow env
     (purchaseKey, masterKey) <- newPurchaseKeys
     let monthlyFrom start = storeCharge "subscr-badge-supporter-month-02" start 1
         monthly = monthlyFrom (addUTCTime (-3600) now)
+        -- one token presented again and again, so each presentation comes after the hour the one before holds it for
         answer ref payment checked = do
           setSubscription store ref checked
-          refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey payment)
+          refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey payment) <* nextHour
+        nextHour = testClockTime bsClock >>= setClockAt bsClock . addUTCTime 3700
         play = answer (SubscriptionGoogle googleSubscriptionToken) subscriptionPlay
         aDay = Just 86400
-    play (subscriptionCheck SSRenewing $ Just $ monthlyFrom $ addUTCTime 3600 now) `shouldReturn` (BSEPaymentPending, Just 300)
+    play (subscriptionCheck SSRenewing $ Just $ monthlyFrom $ addUTCTime 3600 now) `shouldReturn` (BSEPaymentPending, Just 3600)
     -- Play gives a subscription bought again a new token, so this one can never be credited
     play (subscriptionCheck SSEnded $ Just monthly) `shouldReturn` (BSEReceiptInvalid, Nothing)
     -- a later charge could still credit this receipt
@@ -2824,9 +2829,58 @@ testApplePurchaseChecksBounded ps =
     subscriptionChecks store `shouldReturn` checks + 4
     nothingPurchased cc
 
+testPlayPurchaseChecksBounded :: HasCallStack => TestParams -> IO ()
+testPlayPurchaseChecksBounded ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do
+    let token n = "fake-play-token-bounded-" <> n <> ".AO-J1Om8l3biV8pPk4"
+        reports t = setSubscription store (SubscriptionGoogle t)
+        payment = googlePayment "subscr_badge_supporter_01"
+        present (purchaseKey, masterKey) t = refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey $ payment t)
+        heldOff (code, retryAfter) = code == BSEPaymentPending && maybe False (\s -> s > 3540 && s <= 3600) retryAfter
+        waiting = subscriptionCheck SSBillingRetry Nothing
+    now <- serviceNow env
+    reports (token "1") waiting
+    reports (token "2") waiting
+    reports (token "3") waiting
+    reports (token "4") $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" (addUTCTime 3600 now) 1
+    keys <- newPurchaseKeys
+    otherKeys <- newPurchaseKeys
+    checks <- subscriptionChecks store
+    firstCheck <- testClockTime bsClock
+    present keys (token "1") `shouldReturn` (BSEPaymentPending, Just 86400)
+    subscriptionChecks store `shouldReturn` checks + 1
+    present keys (token "1") >>= (`shouldSatisfy` heldOff)
+    present otherKeys (token "1") >>= (`shouldSatisfy` heldOff)
+    subscriptionChecks store `shouldReturn` checks + 1
+    present keys (token "2") `shouldReturn` (BSEPaymentPending, Just 86400)
+    subscriptionChecks store `shouldReturn` checks + 2
+    -- answers that would bring the client back sooner carry the hour the token is held for
+    setGoogleDown store True
+    present keys (token "3") `shouldReturn` (BSEProviderUnavailable, Just 3600)
+    setGoogleDown store False
+    present keys (token "4") `shouldReturn` (BSEPaymentPending, Just 3600)
+    subscriptionChecks store `shouldReturn` checks + 4
+    setClockAt bsClock $ addUTCTime 3700 firstCheck
+    present otherKeys (token "1") `shouldReturn` (BSEPaymentPending, Just 86400)
+    subscriptionChecks store `shouldReturn` checks + 5
+    nothingPurchased cc
+    -- a token credited to one key is held for another key too, and its own key is answered from the record
+    creditedAt <- serviceNow env
+    reports (token "5") $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" (addUTCTime (-3600) creditedAt) 1
+    (creditKey, creditMasterKey) <- newPurchaseKeys
+    credited <- serviceCmd env creditKey (purchaseCmd creditMasterKey $ payment $ token "5")
+    credentialOf credited `shouldSatisfy` isJust
+    subscriptionChecks store `shouldReturn` checks + 6
+    present otherKeys (token "5") >>= (`shouldSatisfy` heldOff)
+    credentialOf <$> serviceCmd env creditKey (purchaseCmd creditMasterKey $ payment $ token "5") `shouldReturn` credentialOf credited
+    subscriptionChecks store `shouldReturn` checks + 6
+    setClockAt bsClock $ addUTCTime 3700 creditedAt
+    present otherKeys (token "5") `shouldReturn` (BSEReceiptUsed, Nothing)
+    subscriptionChecks store `shouldReturn` checks + 7
+
 testPurchaseChecksBounded :: HasCallStack => TestParams -> IO ()
 testPurchaseChecksBounded _ = do
-  checks <- newPurchaseChecks
+  PurchaseChecks {appleChecks = checks, googleChecks} <- newPurchaseChecks
   now <- getCurrentTime
   let waitAt t ref = atomically $ purchaseCheckWait checks t ref
       size = M.size <$> readTVarIO checks
@@ -2837,6 +2891,9 @@ testPurchaseChecksBounded _ = do
   waitAt now "new" `shouldReturn` Nothing
   waitAt now "new" `shouldReturn` Nothing
   size `shouldReturn` maxPurchaseChecks
+  atomically (purchaseCheckWait googleChecks now "play claim") `shouldReturn` Nothing
+  atomically (purchaseCheckWait googleChecks now "play claim") `shouldReturn` Just 3600
+  M.size <$> readTVarIO googleChecks `shouldReturn` 1
   waitAt (addUTCTime 3600 now) "new" `shouldReturn` Nothing
   size `shouldReturn` 1
 
@@ -2898,22 +2955,27 @@ testPlaySubscriptionAcknowledgedBeforeCrediting ps = do
           { acknowledgeGoogle = Just $ \_ token -> modifyIORef' oneTimeAcknowledged (token :) >> pure (Right ()),
             acknowledgeGoogleSubscription = Just $ \productId token -> modifyIORef' acknowledged ((productId, token) :) >> readIORef acknowledgement
           }
-  withBadgeServiceVerifier ps acknowledging $ \env@BadgeServiceEnv {bsController = cc, bsStore} -> do
+  withBadgeServiceVerifier ps acknowledging $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore} -> do
     now <- serviceNow env
     (purchaseKey, masterKey) <- newPurchaseKeys
     let purchase = serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay
         chargedFrom start = setSubscription bsStore (SubscriptionGoogle googleSubscriptionToken) $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" start 1
+        -- the token is held an hour after each attempt
+        nextHour = testClockTime bsClock >>= setClockAt bsClock . addUTCTime 3700
     -- only a charge about to be credited is acknowledged
     chargedFrom $ addUTCTime 3600 now
     fst . refusalOf <$> purchase `shouldReturn` BSEPaymentPending
     readIORef acknowledged `shouldReturn` []
     chargedFrom $ addUTCTime (-3600) now
+    nextHour
     refusalOf <$> purchase >>= (`shouldSatisfy` \(code, retryAfter) -> code == BSEProviderUnavailable && isJust retryAfter)
     writeIORef acknowledgement $ Left $ SRVerifierFailed "acknowledging: the service account lacks the Play Console permission for this call"
+    nextHour
     refusalOf <$> purchase `shouldReturn` (BSEInternal, Nothing)
     nothingPurchased cc
     rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 0
     writeIORef acknowledgement $ Right ()
+    nextHour
     purchased <- purchase
     subscriptionOf purchased `shouldBe` Just SSRenewing
     replayed <- purchase