core: let a held App Store subscription adopt its later transactions

A held Apple subscription record is keyed by its original transaction id,
so every renewal resolves to it. It kept the payment's back-off when a new
transaction arrived, and adopted any payment handed over, including a
revoked renewal, which the service refuses as receipt_invalid and so would
refuse the whole subscription.

A held Apple record now adopts a JWS only for another transaction with a
later purchaseDate and no revocationDate, read from the unverified payload,
and is then due at once with its retry delay and credit error cleared. A
re-delivered or re-signed copy changes nothing. A failed attempt writes its
back-off only if the record still holds the payment it sent.

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

src/Simplex/Chat/Library/Commands.hs

@@ -5577,7 +5577,7 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
             -- a buyer is waiting, so unlike a renewal a failure that can clear on its own never waits the day
             | badgeFailureTransient failure = (fromIntegral delay / 1000000, SRORetry)
             | otherwise = (badgeStalledInterval, SRODeferred)
-      withStore' $ \db -> recordStoreReceiptFailure db receiptId (nextRetryDelay 0 delay ri) (retryIn `addUTCTime` now) failure
+      withStore' $ \db -> recordStoreReceiptFailure db receiptId payment (nextRetryDelay 0 delay ri) (retryIn `addUTCTime` now) failure
       pure outcome
 
 -- | Retire what has ended, renew what is due, then report the next wake. Waking early, late or not

src/Simplex/Chat/PaymentService.hs

@@ -1,20 +1,29 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.PaymentService
   ( ServiceInvoice (..),
     ServicePayment (..),
+    AppleTransactionFacts (..),
+    applePayload,
     appleTransactionRef,
     applePayloadRef,
+    appleTransactionFacts,
     googlePurchaseRef,
     module Simplex.Chat.PaymentService.Types,
   ) where
 
+import Control.Applicative ((<|>))
+import Control.Monad ((<=<))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as JM
 import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
 import qualified Data.ByteString.Base64.URL as B64U
+import Data.Int (Int64)
+import Data.Maybe (isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
@@ -45,13 +54,38 @@ data ServicePayment
   deriving (Show)
 
 -- | Read without verifying the signature: it names the transaction, and proves nothing about it.
-appleTransactionRef :: Text -> Maybe Text
-appleTransactionRef signed = case T.splitOn "." signed of
+applePayload :: Text -> Maybe J.Object
+applePayload signed = case T.splitOn "." signed of
   [_, payload, _] -> do
     J.Object o <- J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload)
-    applePayloadRef o
+    Just o
   _ -> Nothing
 
+appleTransactionRef :: Text -> Maybe Text
+appleTransactionRef = applePayloadRef <=< applePayload
+
+-- | What an unverified payload says about its transaction, which decides only which payment a held record
+-- presents next: the service verifies whatever it is sent.
+data AppleTransactionFacts = AppleTransactionFacts
+  { transactionId :: Text,
+    purchaseDate :: Maybe Int64, -- epoch milliseconds
+    revoked :: Bool,
+    autoRenewable :: Bool
+  }
+  deriving (Eq, Show)
+
+-- | A purchaseDate or type that does not read is taken as absent rather than failing the whole payload.
+appleTransactionFacts :: Text -> Maybe AppleTransactionFacts
+appleTransactionFacts = JT.parseMaybe facts <=< applePayload
+  where
+    facts o = do
+      transactionId <- o J..: "transactionId"
+      purchaseDate <- o J..:? "purchaseDate" <|> pure Nothing
+      -- as the service reads it: null is not revoked
+      revoked <- isJust <$> (o J..:? "revocationDate" :: JT.Parser (Maybe J.Value))
+      type_ <- o J..:? "type" <|> pure Nothing
+      pure AppleTransactionFacts {transactionId, purchaseDate, revoked, autoRenewable = type_ == Just ("Auto-Renewable Subscription" :: Text)}
+
 -- | A subscription is named by its original transaction id, which every renewal keeps, so all its
 -- charges claim one purchase; any other transaction by its own id.
 applePayloadRef :: J.Object -> Maybe Text

src/Simplex/Chat/Store/Badges.hs

@@ -57,7 +57,7 @@ import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
 import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..), BadgeSubscription (..), OpenStorePurchase (..), StoreReceiptOrigin (..), SubscriptionState)
-import Simplex.Chat.PaymentService (ServicePayment)
+import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts)
 import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..))
 import Simplex.Chat.Store.Shared (StoreError, insertedRowId)
 import Simplex.Chat.Types
@@ -135,9 +135,16 @@ data BadgeReceiptStatus
 holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> StoreReceiptOrigin -> Maybe Text -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO (Maybe BadgeReceiptRecord)
 holdStoreReceipt db g User {userId} origin invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now =
   getReceiptRecord db txRef >>= \case
-    Just r@BadgeReceiptRecord {receiptId} -> do
+    Just r@BadgeReceiptRecord {receiptId, status} -> do
       -- a resolved record stays resolved, so a hand-over landing just after its credit cannot hold it again
-      DB.execute db "UPDATE badge_store_receipts SET payment = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL" (paymentJSON, receiptId)
+      case status of
+        RSHeld {payment = held}
+          | laterAppleTransaction payment held ->
+              DB.execute
+                db
+                "UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, credit_error = NULL WHERE badge_store_receipt_id = ? AND payment = ?"
+                (paymentJSON, now, receiptId, held)
+        _ -> pure ()
       pure $ Just r
     Nothing -> do
       forM_ invoiceId_ $ \invoiceId ->
@@ -171,6 +178,18 @@ holdStoreReceipt db g User {userId} origin invoiceId_ txRef@StoreTransactionRef
         |]
         ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, now))
 
+-- | Whether a held Apple record presents this payment next: another transaction of its subscription, bought
+-- later and not revoked. The core decides which is newest, since the app's store listener races its sweep, and a
+-- re-delivered or re-signed copy of the held transaction changes nothing, so it cannot cost another store check.
+laterAppleTransaction :: ServicePayment -> Text -> Bool
+laterAppleTransaction payment held = case (payment, decodeJSON held) of
+  (SPApple {jws}, Just SPApple {jws = heldJws}) -> case (appleTransactionFacts jws, appleTransactionFacts heldJws) of
+    ( Just AppleTransactionFacts {transactionId, purchaseDate = Just purchasedAt, revoked = False},
+      Just AppleTransactionFacts {transactionId = heldId, purchaseDate = Just heldPurchasedAt}
+      ) -> transactionId /= heldId && purchasedAt > heldPurchasedAt
+    _ -> False
+  _ -> False
+
 getReceiptRecord :: DB.Connection -> StoreTransactionRef -> IO (Maybe BadgeReceiptRecord)
 getReceiptRecord db StoreTransactionRef {provider, transactionRef} =
   maybeFirstRow toReceiptRecord $
@@ -239,16 +258,17 @@ getNextHeldStoreReceipt db userId =
     toHeld (stashRow@(receiptId, _, _, _) :. (invoiceId, payment, nextAttemptAt, retryDelay)) =
       BadgeReceiptRecord {receiptId, ownerId = userId, status = RSHeld {stash = toBadgeStash BSRStoreReceipt stashRow, invoiceId, payment, nextAttemptAt, retryDelay}}
 
-recordStoreReceiptFailure :: DB.Connection -> Int64 -> Int64 -> UTCTime -> BadgeIssueFailure -> IO ()
-recordStoreReceiptFailure db receiptId retryDelay nextAttemptAt failure =
+-- | Only while the record still holds the payment that failed: one adopted meanwhile is due at once.
+recordStoreReceiptFailure :: DB.Connection -> Int64 -> Text -> Int64 -> UTCTime -> BadgeIssueFailure -> IO ()
+recordStoreReceiptFailure db receiptId payment retryDelay nextAttemptAt failure =
   DB.execute
     db
     [sql|
       UPDATE badge_store_receipts
       SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ?
-      WHERE badge_store_receipt_id = ? AND payment IS NOT NULL
+      WHERE badge_store_receipt_id = ? AND payment = ?
     |]
-    (retryDelay, nextAttemptAt, failure, receiptId)
+    (retryDelay, nextAttemptAt, failure, receiptId, payment)
 
 -- | Kept rather than deleted, so that a later hand-over of the same transaction is answered from the record.
 refuseStoreReceipt :: DB.Connection -> Int64 -> BadgeIssueFailure -> IO ()