diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md index 75fbabdbfc..72ece2b1bf 100644 --- a/apps/simplex-badge-service/README.md +++ b/apps/simplex-badge-service/README.md @@ -260,9 +260,10 @@ service_account_file = /etc/simplex-badge-service/play-service-account.json error naming the acknowledgement, and the app presents it again once the permission is granted, which must be within three days, before Play refunds it. The key signs in for an access token, so keep the file readable by this service alone. - Play purchases are verified on a lane of their own, so a slow or unreachable Play delays only - other Play purchases, not code redemptions or App Store purchases. A subscription's renewal check - still asks its store from the main lane, at most once an hour per subscription. + Every request that may ask a store waits on a lane of its own: Play purchases, App Store + subscription purchases, and issue requests for a subscription due its hourly store check. A slow + or unreachable store therefore delays only those, not code redemptions, App Store one-time + purchases or other renewals. Which answers are terminal for a purchase and which leave it to be presented again is listed per store in [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md#commands). diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 74e21dde23..b7826651c1 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -13,6 +13,7 @@ module BadgeService.Service badgeService, badgeServiceCLI, badgeServiceResponse, + mayAskStore, badgeErrorRetryAfter, shownServiceRequest, survive, @@ -54,7 +55,7 @@ import Data.Int (Int64) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, maybeToList) import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) import Data.Word (Word32) import Simplex.Chat.Badges import Simplex.Chat.Badges.Code @@ -66,7 +67,7 @@ import Simplex.Chat.Bot.Store (withDB, withDB') import Simplex.Chat.Controller import Simplex.Chat.Core (sendChatCmd, simplexChatCore) import Simplex.Chat.Options (printDbOpts) -import Simplex.Chat.PaymentService (ServicePayment (..)) +import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts) import Simplex.Chat.PaymentService.Types (PaymentProvider (..), StoreTransactionRef (..)) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') @@ -301,22 +302,38 @@ issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = processQueuedRequests :: BadgeIssuerKey -> Maybe (TQueue GroupEvent) -> ServiceState -> IO () processQueuedRequests key trackerQ_ env = do cc <- atomically $ readTMVar $ serviceCC env - -- a Play hand-over can wait two verifyTimeouts on Play, so it waits on a lane of its own - playQ <- newTQueueIO + -- a store call can take verifyTimeout, and a Play hand-over two, so every request that may make one waits on a lane of its own + storeQ <- newTQueueIO let answer (u, reqId, sigKey, reqData) = handleServiceRequest key (storeVerifier env) cc trackerQ_ u reqId sigKey reqData - route req@(_, _, _, reqData) - | presentsPlayReceipt reqData = atomically $ writeTQueue playQ req - | otherwise = answer req + route req@(_, _, sigKey, reqData) = + mayAskStore cc sigKey reqData >>= \case + True -> atomically $ writeTQueue storeQ req + False -> answer req lane q act = forever $ do req@(_, reqId, _, _) <- atomically $ readTQueue q survive ("request " <> safeDecodeUtf8 (strEncode reqId)) $ act req - raceAny_ [lane (serviceRequestQ env) route, lane playQ answer] + raceAny_ [lane (serviceRequestQ env) route, lane storeQ answer] --- | Only what creates a purchase leaves the main lane: an append to an existing ledger is guarded by nothing but that lane being serial. -presentsPlayReceipt :: J.Object -> Bool -presentsPlayReceipt reqData = case J.fromJSON (J.Object reqData) of - J.Success BadgeServiceRequest {request = BSCPurchaseBadge {payment = SPGoogle {}, upgrade = Nothing}} -> True - _ -> False +-- | Store calls wait on the store lane, so appends to one ledger come from both lanes: each write's tip +-- re-read guards them while transactions run one at a time (SQLite; Postgres at --pool-size 1). +mayAskStore :: ChatController -> Maybe C.PublicKeyEd25519 -> J.Object -> IO Bool +mayAskStore cc sigKey reqData = case J.fromJSON (J.Object reqData) of + J.Success BadgeServiceRequest {request = BSCPurchaseBadge {payment = SPGoogle {}, upgrade = Nothing}} -> pure True + J.Success BadgeServiceRequest {request = BSCPurchaseBadge {payment = SPApple {jws}, upgrade = Nothing}} -> + pure $ maybe False autoRenewable (appleTransactionFacts jws) + J.Success BadgeServiceRequest {purchaseKey = Just k, request = BSCIssueBadge {}} + | sigKey == Just k -> do + now <- badgeNow cc + withDB' "mayAskStore" cc (\db -> getIssuePurchase db k) <&> \case + Right (Just (_, Just tip, Just subscription)) -> subscriptionCheckDue (addUTCTime routeLookahead now) tip subscription + Right _ -> False + -- a read that failed may hide a due check, and the main lane is what must not wait on a store + Left _ -> True + _ -> pure False + +-- | The router judges a minute ahead, so a handler reading the clock moments later finds due only what the router routed to the store lane. +routeLookahead :: NominalDiffTime +routeLookahead = 60 -- | Cancellation is rethrown, since that is how the race stops this thread. The -- exception itself is not logged: it can quote the request, which carries codes and store receipts. diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs index 23074e8f58..2f2ab8a5ff 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs @@ -63,8 +63,8 @@ data StoreRefusal | SRNotConfigured -- no verifier for this store is deployed; the purchase may be real deriving (Eq, Show) --- | Apple signs its receipt and ships the certificate chain in it, so it is verified with no network --- call; a Play token is opaque and must be asked about, which is why only the Play fields are in IO. +-- | Apple's one-time receipt is verified offline, from the certificate chain it ships; a Play token is opaque +-- and must be asked about, and a subscription's charges are known only to its store, so those fields are in IO. data StoreVerifier = StoreVerifier { -- the JWS verifyApple :: Maybe (Text -> Either StoreRefusal VerifiedStoreTransaction), diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 070a01c123..f4bff10cd2 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -186,8 +186,11 @@ badgeServiceTests = do it "should delete a month-old record that will fund no badge, and keep held and credited ones" testStoreReceiptCleanup it "should keep a receipt whose attempt throws" testStoreReceiptAttemptThrows it "should credit a held receipt after the app restarts" testStoreReceiptAfterRestart - describe "the Play lane" $ do + describe "the store lane" $ do it "should answer other requests while a Play receipt is with the store, and credit it once Play answers" testPlayHoldsNoOtherRequest + it "should route exactly the requests that may ask a store to the store lane, judging a minute ahead" testStoreRouting + it "should answer other requests while a renewal check is with the store, and the renewal once the store answers" testRenewalHoldsNoOtherRequest + it "should answer other requests while an App Store subscription is with the store, and credit it once the store answers" testAppleSubscriptionHoldsNoOtherRequest describe "subscriptions" $ do it "should credit a subscription's charge from the store's period start, and answer replays from the record" testSubscriptionPurchase it "should credit nothing for a subscription with no charge it can grant, retrying as the charge may still come" testSubscriptionPurchaseNotGrantable @@ -3172,6 +3175,109 @@ testPlayHoldsNoOtherRequest ps = do expectLinesWithin 60 alice ["1: supporter"] [] rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 3 +testStoreRouting :: HasCallStack => TestParams -> IO () +testStoreRouting ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleSupporterJWS}} -> do + let routedAs signer key cmd = mayAskStore cc (Just signer) (requestObject key cmd) + routed key = routedAs key key + (purchaseKey, masterKey) <- newPurchaseKeys + let purchase payment = routed purchaseKey $ purchaseCmd masterKey payment + purchase supporterPlay `shouldReturn` True + purchase subscriptionPlay `shouldReturn` True + purchase SPApple {jws = appleSubscriptionJWS} `shouldReturn` True + purchase SPApple {jws = appleSupporterJWS} `shouldReturn` False + g <- C.newRandom + (fromPurchaseKey, fromPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519) + now <- getCurrentTime + let upgrade = BadgeUpgrade {fromPurchaseKey, receipt = "receipt", receiptSignature = C.sign' fromPriv "receipt", balance = BadgeBalance {lastEntry = emptyEntry now BTSupporter}} + routed purchaseKey BSCPurchaseBadge {masterKey, payment = supporterPlay, upgrade = Just upgrade} `shouldReturn` False + code <- issueCode cc BTSupporter 1 + codeKeys@(codeKey, codeMasterKey) <- newPurchaseKeys + routed codeKey BSCRedeemBadgeCode {masterKey = codeMasterKey, code = badgeCodeText code} `shouldReturn` False + redeemed <- redeemWithKeys env codeKeys code + routed codeKey BSCIssueBadge {balance = BadgeBalance {lastEntry = last $ fst $ statementOf redeemed}} `shouldReturn` False + (subscriberKey, firstStart, purchased) <- subscribedMonthly env + let issue = BSCIssueBadge {balance = BadgeBalance {lastEntry = last purchased}} + coverageEnd = addMonths 1 firstStart + routedAt t = setClockAt bsClock t >> routed subscriberKey issue + answeredWithoutStore = do + checks <- subscriptionChecks store + _ <- assertBalance env subscriberKey (last purchased) + subscriptionChecks store `shouldReturn` checks + routedAt (addUTCTime (-90) coverageEnd) `shouldReturn` False + routedAt (addUTCTime (-30) coverageEnd) `shouldReturn` True + answeredWithoutStore + storeReports store $ subscriptionCheck SSBillingRetry Nothing + routedAt (addUTCTime 60 coverageEnd) `shouldReturn` True + checks <- subscriptionChecks store + _ <- assertBalance env subscriberKey (last purchased) + subscriptionChecks store `shouldReturn` checks + 1 + [Just lastCheck] <- subscriptionCheckedAt cc + routedAt (addUTCTime 3530 lastCheck) `shouldReturn` False + routedAt (addUTCTime 3550 lastCheck) `shouldReturn` True + answeredWithoutStore + routedAt (addUTCTime 3700 lastCheck) `shouldReturn` True + routedAs purchaseKey subscriberKey issue `shouldReturn` False + (unknownKey, _) <- newPurchaseKeys + routed unknownKey issue `shouldReturn` False + +testRenewalHoldsNoOtherRequest :: HasCallStack => TestParams -> IO () +testRenewalHoldsNoOtherRequest ps = do + entered <- newEmptyMVar + release <- newEmptyMVar + -- the purchase asks the store too, so the hold is armed once it is credited + hook <- newIORef (pure ()) + let holding store = (subscriptionCheckWithHook hook store) {verifyTimeout = 60000000} + withBadgeServiceVerifier ps holding $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store@FakeStore {appleSupporterJWS}} -> do + -- her request outlives the hold, so her pass does not give up and send it again + let patientCfg = bsClientCfg {agentConfig = (agentConfig bsClientCfg) {serviceRequestTimeout = 120}} + withNewTestChatCfg ps patientCfg "alice" aliceProfile $ \alice -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> + withNewTestChatCfg ps bsClientCfg "cath" cathProfile $ \cath -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + let (requestAt, _) = renewalMoments rows + renewalStart = addMonths 1 firstStart + writeIORef hook $ putMVar entered () >> takeMVar release + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + timeout 30000000 (takeMVar entered) `shouldReturn` Just () + code <- issueCode cc BTSupporter 1 + bob ##> ("/_redeem_badge_code 1 " <> codeArg code) + bob <## "badge redeemed" + bob <## "supporter badge - active" + bob <##. "expires " + cath ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS}) + cath <### [StartsWith (openPurchase ""), StartsWith "1: supporter"] + putMVar release () + alice <##. "1: supporter" + renewed <- waitLedgerRows (chatController alice) 4 + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + +testAppleSubscriptionHoldsNoOtherRequest :: HasCallStack => TestParams -> IO () +testAppleSubscriptionHoldsNoOtherRequest ps = do + entered <- newEmptyMVar + release <- newEmptyMVar + hook <- newIORef $ putMVar entered () >> takeMVar release + let holding store = (subscriptionCheckWithHook hook store) {verifyTimeout = 60000000} + withBadgeServiceVerifier ps holding $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "dan" danProfile $ \dan -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + now <- serviceNow env + setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1 + dan ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) + storePurchaseOpen dan "" + timeout 30000000 (takeMVar entered) `shouldReturn` Just () + code <- issueCode cc BTSupporter 1 + bob ##> ("/_redeem_badge_code 1 " <> codeArg code) + bob <## "badge redeemed" + bob <## "supporter badge - active" + bob <##. "expires " + putMVar release () + expectLinesWithin 60 dan ["1: supporter"] [] + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 2 + createInvoice :: HasCallStack => TestCC -> Int -> IO String createInvoice cc userId = do cc ##> ("/_badge invoice " <> show userId)