core: refuse a badge code or invoice while a store receipt is pending

A code redeemed while a store receipt is held put the code's badge on the
profile, and the held receipt then waited behind it; for a subscription the
store kept charging every period meanwhile. Code redemption and invoice
creation now answer "store purchase open" while the profile holds an App
Store subscription receipt, or another receipt whose last failure can clear
on its own. A receipt that failed for good does not block, except an Apple
subscription, which Apple keeps charging; an uncredited Play subscription is
refunded by Play.

Run: 003-badge-subscriptions-ui, slice 6

bots/api/TYPES.md

@@ -450,6 +450,9 @@ ServiceNotConfigured:
 BadgeActive:
 - type: "badgeActive"
 
+StorePurchaseOpen:
+- type: "storePurchaseOpen"
+
 ServiceError:
 - type: "serviceError"
 - serviceError: [BadgeServiceErrorCode](#badgeserviceerrorcode)

packages/simplex-chat-client/types/typescript/src/types.ts

@@ -252,6 +252,7 @@ export type BadgeRedeemError =
   | BadgeRedeemError.InvalidReceipt
   | BadgeRedeemError.ServiceNotConfigured
   | BadgeRedeemError.BadgeActive
+  | BadgeRedeemError.StorePurchaseOpen
   | BadgeRedeemError.ServiceError
   | BadgeRedeemError.InvalidResponse
   | BadgeRedeemError.UnknownKeyIndex
@@ -263,6 +264,7 @@ export namespace BadgeRedeemError {
     | "invalidReceipt"
     | "serviceNotConfigured"
     | "badgeActive"
+    | "storePurchaseOpen"
     | "serviceError"
     | "invalidResponse"
     | "unknownKeyIndex"
@@ -288,6 +290,10 @@ export namespace BadgeRedeemError {
     type: "badgeActive"
   }
 
+  export interface StorePurchaseOpen extends Interface {
+    type: "storePurchaseOpen"
+  }
+
   export interface ServiceError extends Interface {
     type: "serviceError"
     serviceError: BadgeServiceErrorCode

packages/simplex-chat-python/src/simplex_chat/types/_types.py

@@ -197,6 +197,9 @@ class BadgeRedeemError_serviceNotConfigured(TypedDict):
 class BadgeRedeemError_badgeActive(TypedDict):
     type: Literal["badgeActive"]
 
+class BadgeRedeemError_storePurchaseOpen(TypedDict):
+    type: Literal["storePurchaseOpen"]
+
 class BadgeRedeemError_serviceError(TypedDict):
     type: Literal["serviceError"]
     serviceError: "BadgeServiceErrorCode"
@@ -216,13 +219,14 @@ BadgeRedeemError = (
     | BadgeRedeemError_invalidReceipt
     | BadgeRedeemError_serviceNotConfigured
     | BadgeRedeemError_badgeActive
+    | BadgeRedeemError_storePurchaseOpen
     | BadgeRedeemError_serviceError
     | BadgeRedeemError_invalidResponse
     | BadgeRedeemError_unknownKeyIndex
     | BadgeRedeemError_credentialNotVerified
 )
 
-BadgeRedeemError_Tag = Literal["invalidCode", "invalidReceipt", "serviceNotConfigured", "badgeActive", "serviceError", "invalidResponse", "unknownKeyIndex", "credentialNotVerified"]
+BadgeRedeemError_Tag = Literal["invalidCode", "invalidReceipt", "serviceNotConfigured", "badgeActive", "storePurchaseOpen", "serviceError", "invalidResponse", "unknownKeyIndex", "credentialNotVerified"]
 
 BadgeServiceErrorCode = Literal["bad_request", "unsupported_version", "unknown_purchase_key", "unknown_offer_id", "offer_disabled", "offer_mismatch", "product_unavailable", "payment_not_entitled", "payment_pending", "provider_unavailable", "provider_not_configured", "rate_limited", "code_invalid", "code_used", "code_expired", "receipt_invalid", "receipt_used", "test_purchase", "internal"]
 

src/Simplex/Chat/Controller.hs

@@ -1498,6 +1498,7 @@ data BadgeRedeemError
   | BREInvalidReceipt -- names no transaction, or is not a store payment
   | BREServiceNotConfigured
   | BREBadgeActive
+  | BREStorePurchaseOpen -- a store receipt held for this profile may still be credited
   | BREServiceError {serviceError :: BadgeServiceErrorCode}
   | BREInvalidResponse {message :: String}
   | BREUnknownKeyIndex

src/Simplex/Chat/Library/Commands.hs

@@ -76,7 +76,7 @@ import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Messages.CIContent.Events
 import Simplex.Chat.Operators
 import Simplex.Chat.Options
-import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef, googlePurchaseRef)
+import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts, appleTransactionRef, googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (PaymentProvider (..), StoreTransactionRef (..))
 import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
@@ -3586,6 +3586,7 @@ processChatCommand cxt nm = \case
   APICreateBadgeInvoice userId -> withUserId userId $ \user -> do
     void requireBadgeService
     refuseWhileBadgeHeld user
+    refuseWhileStoreReceiptPending user
     g <- asks random
     now <- badgeNow
     invoiceId <- UUID.toText <$> liftIO V4.nextRandom
@@ -5351,7 +5352,7 @@ storeTransactionRef = \case
 stashBadgeKeys :: User -> Maybe BadgeStash -> (DB.Connection -> IO BadgeStash) -> CM BadgeStash
 stashBadgeKeys user stash_ createStash = do
   replaying <- maybe (pure False) (\s -> withStore' $ \db -> isJust <$> getStashBadgePurchase db s) stash_
-  unless replaying $ refuseWhileBadgeHeld user
+  unless replaying $ refuseWhileBadgeHeld user >> refuseWhileStoreReceiptPending user
   maybe (withStore' createStash) pure stash_
 
 requireBadgeService :: CM (ConnectTarget 'CMContact)
@@ -5360,6 +5361,18 @@ 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.
+refuseWhileStoreReceiptPending :: User -> CM ()
+refuseWhileStoreReceiptPending user = do
+  pending <- withStore' (`getPendingStoreReceipts` user)
+  when (any blocks pending) $ throwRedeemError BREStorePurchaseOpen
+  where
+    blocks (payment, failure_) = appleSubscription payment || maybe True badgeFailureTransient failure_
+    appleSubscription payment = case decodeJSON payment of
+      Just SPApple {jws} | Just AppleTransactionFacts {autoRenewable} <- appleTransactionFacts jws -> autoRenewable
+      _ -> False
+
 -- | One attempt to turn a stash into a badge. A refusal is answered rather than thrown, with the
 -- service's retryAfter.
 requestBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (Maybe User, ChatResponse))

src/Simplex/Chat/Store/Badges.hs

@@ -27,6 +27,7 @@ module Simplex.Chat.Store.Badges
     getReceiptRecord,
     createBadgeStoreReceipt,
     getOpenStorePurchases,
+    getPendingStoreReceipts,
     getNextHeldStoreReceipt,
     recordStoreReceiptFailure,
     refuseStoreReceipt,
@@ -240,6 +241,11 @@ getOpenStorePurchases db User {userId} =
   where
     toOpenStorePurchase (invoiceId, transactionRef, creditError) = 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)
+
 getNextHeldStoreReceipt :: DB.Connection -> UserId -> IO (Either StoreError (Maybe BadgeReceiptRecord))
 getNextHeldStoreReceipt db userId =
   fmap Right . maybeFirstRow toHeld $

src/Simplex/Chat/View.hs

@@ -2885,6 +2885,7 @@ viewChatError isCmd logLevel testView = \case
             BREInvalidReceipt -> "invalid store receipt"
             BREServiceNotConfigured -> "badge service not configured"
             BREBadgeActive -> "badge already active"
+            BREStorePurchaseOpen -> "store purchase open"
             BREServiceError code -> "badge service error: " <> T.unpack (badgeServiceErrorText code)
             BREInvalidResponse m -> "invalid service response: " <> m
             BREUnknownKeyIndex -> "credential names an unknown badge key index"

tests/Bots/BadgeService/BotTests.hs

@@ -166,6 +166,7 @@ badgeServiceTests = do
       it "should credit a purchase first handed over under another profile to that profile" testPurchaseStrandedUnderOtherProfile
       it "should credit a purchase to a hidden profile without naming it" testPurchaseDeliveredToHiddenProfile
       it "should record a listed transaction only into a record it already has, and a Restore hand-over as its own" testListedReceiptNotRecorded
+      it "should refuse a code or an invoice while a held receipt may be credited or is an Apple subscription, and not otherwise" testRedeemRefusedWhileReceiptHeld
     describe "invoice first" $ do
       it "should credit a receipt to the profile that created its invoice however late it arrives, and answer as that profile" testInvoiceOtherProfile
       it "should credit a receipt naming an unknown invoice to the presenting profile" testInvoiceUnknown
@@ -2735,6 +2736,44 @@ testListedReceiptNotRecorded ps =
       heldStoreReceipts (chatController alice) `shouldReturn` 1
       rowCount cc "sx_badge_service_payments" `shouldReturn` 1
 
+-- | A badge redeemed over a held receipt would leave the receipt waiting behind it. With no subscription check
+-- the service refuses a subscription for good, though not as a refused receipt, so the record stays held.
+testRedeemRefusedWhileReceiptHeld :: HasCallStack => TestParams -> IO ()
+testRedeemRefusedWhileReceiptHeld ps =
+  withBadgeServiceVerifier ps (\store -> (fakeVerifier store) {checkSubscription = Nothing}) $ \BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = FakeStore {appleSubscriptionJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      let refused cmd = do
+            alice ##> cmd
+            alice <## "cannot get badge: store purchase open"
+          finalError = "service_error final provider_not_configured"
+      alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken))
+      storePurchaseOpen alice ""
+      heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      code <- issueCode cc BTSupporter 1
+      refused $ "/_redeem_badge_code 1 " <> codeArg code
+      rowCount (chatController alice) "badge_code_redemptions" `shouldReturn` 0
+      nothingPurchased cc
+      refused "/_badge invoice 1"
+      storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)]
+      -- a Play receipt that failed for good does not block
+      alice ##> "/create user alisa"
+      showActiveUser alice "alisa"
+      alice ##> ("/_badge purchase 2 " <> paymentArg subscriptionPlay)
+      storePurchaseOpen alice ""
+      heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending", finalError]
+      alice ##> ("/_redeem_badge_code 2 " <> codeArg code)
+      alice <## "badge redeemed"
+      alice <## "supporter badge - active"
+      alice <##. "expires "
+      -- an Apple subscription that failed for good still blocks, as Apple keeps charging it
+      alice ##> "/create user alina"
+      showActiveUser alice "alina"
+      alice ##> ("/_badge purchase 3 " <> paymentArg SPApple {jws = appleSubscriptionJWS})
+      storePurchaseOpen alice ""
+      heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending", finalError, finalError]
+      issueCode cc BTSupporter 1 >>= \code' -> refused ("/_redeem_badge_code 3 " <> codeArg code')
+      refused "/_badge invoice 3"
+
 testInvoiceUnknown :: HasCallStack => TestParams -> IO ()
 testInvoiceUnknown ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg} ->
@@ -2850,9 +2889,11 @@ testStoreReceiptNotBlocked ps =
       alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
       storePurchaseOpen alice ""
       heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry provider_unavailable"]
-      invoiceId <- createInvoice alice 1
-      alice ##> purchaseWithInvoice 1 invoiceId SPApple {jws = appleSupporterJWS}
-      inAnyOrder alice [[openPurchase "", invoicePurchase "" invoiceId], creditedLines "" invoiceId "1: supporter"]
+      alice ##> "/_badge invoice 1"
+      alice <## "cannot get badge: store purchase open"
+      -- handed over with no invoice, as Restore sends it, so no settlement is announced
+      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS})
+      inAnyOrder alice [[openPurchase "", openPurchase ""], ["1: supporter"]]
       heldStoreReceipts (chatController alice) `shouldReturn` 1
 
 testStoreRefusalKept :: HasCallStack => TestParams -> IO ()