From 664e5388ff34778bc8d7c69db8fd5a3687aadaeb Mon Sep 17 00:00:00 2001 From: spacedandy-agents-simplex <342056592+spacedandy-agents-simplex@users.noreply.github.com> Date: Thu, 15 Oct 2026 03:42:23 +0000 Subject: [PATCH] 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 | 2 +- src/Simplex/Chat/PaymentService.hs | 40 +++++++++++++++++-- src/Simplex/Chat/Store/Badges.hs | 34 +++++++++++++---- tests/BadgeTests.hs | 19 +++++++++- tests/Bots/BadgeService/BotTests.hs | 57 +++++++++++++++++++++++++--- tests/Bots/BadgeService/FakeStore.hs | 51 ++++++++++++++++++------- 6 files changed, 172 insertions(+), 31 deletions(-) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 01a5931a0e..5aa9a79fd3 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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 diff --git a/src/Simplex/Chat/PaymentService.hs b/src/Simplex/Chat/PaymentService.hs index 52f4ae12fc..d66c71cb98 100644 --- a/src/Simplex/Chat/PaymentService.hs +++ b/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 diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 9693e5c3e5..8fccf7b580 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/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 () diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index 3d81ba2dae..99c17d0e83 100644 --- a/tests/BadgeTests.hs +++ b/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 diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 48168bb5dc..27b764ed47 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/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)] diff --git a/tests/Bots/BadgeService/FakeStore.hs b/tests/Bots/BadgeService/FakeStore.hs index 9dd3548812..35b5ef5e45 100644 --- a/tests/Bots/BadgeService/FakeStore.hs +++ b/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