badge-service: answer every request that may ask a store on the store lane

App Store subscription purchases and subscription renewal checks called
their store from the main lane, so one slow or repeated store call held up
code redemptions and every other renewal. The router now reads the
purchase the way the issue path does and sends to the store lane every
request that may ask a store: Play purchases, App Store auto-renewable
purchases, and issue requests for a subscription due its store check,
judged a minute ahead so the handler never finds one due on the main lane.

Run: 005-subscriptions-load-timing, slice 2

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

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.

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

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)