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 ()

tests/BadgeTests.hs

@@ -40,7 +40,7 @@ import qualified Simplex.Chat.Badges.Types as BT
 import Simplex.Chat (defaultChatConfig)
 import Simplex.Chat.Controller (BadgeRedeemError (..), ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent)
 import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRenewal, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, boundedSubscriptionState, storeTransactionRef)
-import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef)
+import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts, appleTransactionRef)
 import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..), StoreTransactionRef (..))
 import Simplex.Chat.Types (BoolDef (..))
 import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..))
@@ -116,6 +116,7 @@ badgeTests = do
   describe "store purchases" $ do
     it "keys a purchase by the store's transaction id, not by the evidence signed over it" testStoreTransactionRef
     it "claims an Apple subscription by its original transaction id, and any other transaction by its own" testAppleTransactionRef
+    it "reads an Apple transaction's id, purchase date, revocation and type from its unverified payload" testAppleTransactionFacts
     it "shows a service request in the terminal as its type alone" testShownServiceRequest
     it "refuses for good a Play product id that could name another purchase, before any verifier" testGoogleProductIdPath
     it "does not send a Play token that could name another purchase, and leaves it retryable" testGoogleTokenPath
@@ -982,6 +983,22 @@ testAppleTransactionRef = do
   -- a subscription is never claimed by its own transaction id, which the next renewal would not share
   appleTransactionRef (jws $ take 2 (ofType "Auto-Renewable Subscription")) `shouldBe` Nothing
 
+testAppleTransactionFacts :: IO ()
+testAppleTransactionFacts = do
+  let jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"]
+      part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
+      renewal = ["transactionId" J..= ("2000000900000002" :: T.Text), "type" J..= ("Auto-Renewable Subscription" :: T.Text)]
+      facts purchaseDate revoked autoRenewable = Just AppleTransactionFacts {transactionId = "2000000900000002", purchaseDate, revoked, autoRenewable}
+  appleTransactionFacts (jws $ ("purchaseDate" J..= (1769904000000 :: Int)) : renewal) `shouldBe` facts (Just 1769904000000) False True
+  -- the service reads a null revocationDate as not revoked, and so does the client
+  appleTransactionFacts (jws $ ("revocationDate" J..= J.Null) : renewal) `shouldBe` facts Nothing False True
+  appleTransactionFacts (jws $ ("revocationDate" J..= (1770000000000 :: Int)) : renewal) `shouldBe` facts Nothing True True
+  -- a date that does not read is absent, and leaves the rest of the payload readable
+  appleTransactionFacts (jws $ ("purchaseDate" J..= ("yesterday" :: T.Text)) : renewal) `shouldBe` facts Nothing False True
+  appleTransactionFacts (jws $ take 1 renewal <> ["type" J..= ("Consumable" :: T.Text)]) `shouldBe` facts Nothing False False
+  appleTransactionFacts (jws $ drop 1 renewal) `shouldBe` Nothing
+  appleTransactionFacts "not.a-jws" `shouldBe` Nothing
+
 testShownServiceRequest :: IO ()
 testShownServiceRequest = do
   drg <- C.newRandom

tests/Bots/BadgeService/BotTests.hs

@@ -201,6 +201,8 @@ badgeServiceTests = do
     it "should keep the state from the credit through an issuance the service answers from its stored state" testAnnualStateNotFromStoredAnswer
     it "should keep the device store's view of a credited subscription, except renewing over billing retry, and nothing for any other transaction" testSubscriptionStateFromStore
     it "should resolve an Apple renewal to the subscription's record, and credit a held record that adopted it" testAppleRenewalResolvesToPurchase
+    it "should adopt into a held Apple record only another transaction bought later and not revoked" testAppleAdoptionRules
+    it "should credit an adopted Apple transaction at once though the attempt with the one before it failed" testAdoptedReceiptNotOverwritten
     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
     it "should acknowledge a Play subscription as a subscription before crediting it, and credit nothing when acknowledging fails" testPlaySubscriptionAcknowledgedBeforeCrediting
@@ -2411,9 +2413,55 @@ testSubscriptionStateFromStore ps =
       subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"]
       subscriptionChecks store `shouldReturn` checks
 
-setStoreReceiptDue :: ChatController -> UTCTime -> IO ()
-setStoreReceiptDue ChatController {chatStore} t =
-  withTransaction chatStore $ \db -> DB.execute db "UPDATE badge_store_receipts SET next_attempt_at = ?" (Only t)
+-- | The held record's payment and when it is next attempted.
+heldStoreReceiptAttempt :: ChatController -> IO [(Text, UTCTime)]
+heldStoreReceiptAttempt ChatController {chatStore} =
+  withTransaction chatStore $ \db -> DB.query_ db "SELECT payment, next_attempt_at FROM badge_store_receipts WHERE payment IS NOT NULL"
+
+testAppleAdoptionRules :: HasCallStack => TestParams -> IO ()
+testAppleAdoptionRules ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleSubscriptionJWS, appleRevokedSubscriptionJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      now <- serviceNow env
+      setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime 3600 now) 1
+      let handOver jws = do
+            alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws})
+            storePurchaseOpen alice ""
+      handOver appleSubscriptionJWS
+      heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      held <- heldStoreReceiptAttempt (chatController alice)
+      checks <- subscriptionChecks store
+      let resigned = T.intercalate "." $ take 2 (T.splitOn "." appleSubscriptionJWS) <> ["c2lnbmVkIGFnYWlu"]
+          earlier = subscriptionJWS "2000000812345685" ["purchaseDate" J..= (1764547200000 :: Int64)]
+          undated = subscriptionJWS "2000000812345686" []
+      forM_ [appleSubscriptionJWS, resigned, earlier, undated, appleRevokedSubscriptionJWS] $ \jws -> do
+        handOver jws
+        heldStoreReceiptAttempt (chatController alice) `shouldReturn` held
+      subscriptionChecks store `shouldReturn` checks
+
+testAdoptedReceiptNotOverwritten :: HasCallStack => TestParams -> IO ()
+testAdoptedReceiptNotOverwritten ps = do
+  entered <- newEmptyMVar
+  release <- newEmptyMVar
+  hook <- newIORef (pure ())
+  withBadgeServiceVerifier ps (subscriptionCheckWithHook hook) $ \env@BadgeServiceEnv {bsClientCfg, bsStore = store@FakeStore {appleSubscriptionJWS, appleRenewalSubscriptionJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      now <- serviceNow env
+      -- the first check waits for the renewal's hand-over and finds no subscription; the next finds it charged
+      writeIORef hook $ do
+        putMVar entered ()
+        takeMVar release
+        writeIORef hook $ setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1
+      let handOver jws = do
+            alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws})
+            storePurchaseOpen alice ""
+      handOver appleSubscriptionJWS
+      timeout 30000000 (takeMVar entered) `shouldReturn` Just ()
+      handOver appleRenewalSubscriptionJWS
+      putMVar release ()
+      -- the failed attempt sent the first transaction, so it does not put off the renewal adopted meanwhile
+      alice <##. "1: supporter"
+      storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)]
 
 testAppleRenewalResolvesToPurchase :: HasCallStack => TestParams -> IO ()
 testAppleRenewalResolvesToPurchase ps =
@@ -2427,9 +2475,8 @@ testAppleRenewalResolvesToPurchase ps =
       handOver appleSubscriptionJWS
       storePurchaseOpen alice ""
       heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"]
-      -- a renewal with another transaction id joins that record, and is credited at its next attempt
+      -- a later renewal joins that record, which presents it at once
       appleReports $ addUTCTime (-3600) now
-      setStoreReceiptDue (chatController alice) now
       handOver appleRenewalSubscriptionJWS
       inAnyOrder alice [[openPurchase ""], ["1: supporter"]]
       storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)]

tests/Bots/BadgeService/FakeStore.hs

@@ -8,6 +8,7 @@ module Bots.BadgeService.FakeStore
   ( FakeStore (..),
     newFakeStore,
     googleVerifierWithHook,
+    subscriptionCheckWithHook,
     settlePending,
     setGoogleDown,
     googleSupporterToken,
@@ -21,6 +22,7 @@ module Bots.BadgeService.FakeStore
     setSubscription,
     subscriptionChecks,
     googlePayment,
+    subscriptionJWS,
     unsignedJWS,
   )
 where
@@ -29,9 +31,11 @@ import BadgeService.StoreReceipts
 import Control.Concurrent (threadDelay)
 import Control.Monad (forever)
 import qualified Data.Aeson as J
+import Data.Aeson.Types (Pair)
 import qualified Data.ByteString.Base64.URL as B64U
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
+import Data.Int (Int64)
 import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
@@ -53,10 +57,12 @@ data FakeStore = FakeStore
     appleThrowingJWS :: Text,
     appleMisnamedJWS :: Text,
     appleQuantityJWS :: Text,
-    -- two transactions of the subscription appleSubscriptionOriginalId names, and one from Apple's Sandbox
+    -- two transactions of the subscription appleSubscriptionOriginalId names, the renewal bought later, one
+    -- from Apple's Sandbox, and a later one Apple revoked, which the fake does not vouch for
     appleSubscriptionJWS :: Text,
     appleRenewalSubscriptionJWS :: Text,
     appleSandboxSubscriptionJWS :: Text,
+    appleRevokedSubscriptionJWS :: Text,
     pendingSettled :: IORef Bool,
     googleDown :: IORef Bool,
     -- what the store answers about each subscription: Apple's by original id, Google's by token
@@ -73,9 +79,10 @@ newFakeStore = do
   let appleThrowingJWS = unsignedJWS "{\"transactionId\":\"2000000812345679\",\"productId\":\"BADGE_SUPPORTER_01\"}"
       appleMisnamedJWS = unsignedJWS "{\"transactionId\":\"2000000812345698\",\"productId\":\"BADGE_SUPPORTER_01\"}"
       appleQuantityJWS = unsignedJWS "{\"transactionId\":\"2000000812345697\",\"productId\":\"BADGE_SUPPORTER_01\"}"
-      appleSubscriptionJWS = subscriptionJWS "2000000812345681"
-      appleRenewalSubscriptionJWS = subscriptionJWS "2000000812345683"
-      appleSandboxSubscriptionJWS = subscriptionJWS "2000000812345682"
+      appleSubscriptionJWS = subscriptionJWS "2000000812345681" [purchasedAt 1767225600000]
+      appleRenewalSubscriptionJWS = subscriptionJWS "2000000812345683" [purchasedAt 1769904000000]
+      appleSandboxSubscriptionJWS = subscriptionJWS "2000000812345682" [purchasedAt 1767225600000]
+      appleRevokedSubscriptionJWS = subscriptionJWS "2000000812345684" [purchasedAt 1769904000000, "revocationDate" J..= (1770000000000 :: Int64)]
   pendingSettled <- newIORef False
   googleDown <- newIORef False
   subscriptions <- newIORef M.empty
@@ -113,6 +120,7 @@ newFakeStore = do
         appleSubscriptionJWS,
         appleRenewalSubscriptionJWS,
         appleSandboxSubscriptionJWS,
+        appleRevokedSubscriptionJWS,
         pendingSettled,
         googleDown,
         subscriptions,
@@ -123,19 +131,24 @@ newFakeStore = do
     fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir </> name)
     appleTransaction transactionRef productId testPurchase cents =
       VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD"), alreadyAcknowledged = False}
-    subscriptionJWS transactionId =
-      unsignedJWS $
-        LB.toStrict $
-          J.encode $
-            J.object
-              [ "transactionId" J..= (transactionId :: Text),
-                "originalTransactionId" J..= appleSubscriptionOriginalId,
-                "type" J..= ("Auto-Renewable Subscription" :: Text),
-                "productId" J..= ("SUBSCR_BADGE_SUPPORTER_MONTH_01" :: Text)
-              ]
+    purchasedAt ms = "purchaseDate" J..= (ms :: Int64)
     appleSubscription jws testPurchase =
       VerifiedStoreTransaction {transactionRef = fromMaybe "" (appleTransactionRef jws), productId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", quantity = 1, testPurchase, paid = Just (CurrencyAmount 700, "USD"), alreadyAcknowledged = False}
 
+-- | A transaction of the subscription appleSubscriptionOriginalId names, with the payload fields given.
+subscriptionJWS :: Text -> [Pair] -> Text
+subscriptionJWS transactionId fields =
+  unsignedJWS $
+    LB.toStrict $
+      J.encode $
+        J.object $
+          [ "transactionId" J..= transactionId,
+            "originalTransactionId" J..= appleSubscriptionOriginalId,
+            "type" J..= ("Auto-Renewable Subscription" :: Text),
+            "productId" J..= ("SUBSCR_BADGE_SUPPORTER_MONTH_01" :: Text)
+          ]
+            <> fields
+
 subscriptionKey :: SubscriptionRef -> Either Text Text
 subscriptionKey = \case
   SubscriptionApple originalId -> Left originalId
@@ -174,6 +187,16 @@ googleVerifierWithHook hook FakeStore {fakeVerifier = v@StoreVerifier {verifyGoo
       action
       verify productId token
 
+-- | The fake store, running the hook's action once, inside the first subscription check, before it answers.
+subscriptionCheckWithHook :: IORef (IO ()) -> FakeStore -> StoreVerifier
+subscriptionCheckWithHook hook FakeStore {fakeVerifier = v@StoreVerifier {checkSubscription}} =
+  v {checkSubscription = hooked <$> checkSubscription, verifyTimeout = 10000000}
+  where
+    hooked check ref = do
+      action <- atomicModifyIORef' hook (pure (),)
+      action
+      check ref
+
 settlePending :: FakeStore -> IO ()
 settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True