badge-service: check renewals on a lane no purchase waits on

Renewal checks shared the store lane with every purchase, so made-up Play tokens, which anyone can send, and the weekly burst of genuine purchases delayed them. Renewal checks now wait on a lane of their own, which only a request signed by the purchase key it names, and due its hourly store check, can reach.

Run: 007-subscriptions-retirement-lane, slice 2

apps/simplex-badge-service/README.md

@@ -260,10 +260,11 @@ 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.
-  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.
+  A request that may ask a store waits on a lane of its own: Play purchases and App Store
+  subscription purchases on one, and issue requests for a subscription due its hourly store check
+  on another. A slow or unreachable store therefore delays only those, not code redemptions,
+  App Store one-time purchases or other renewals; and no purchase, genuine or made up, delays a
+  renewal check.
 
 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

@@ -308,18 +308,20 @@ issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} =
 processQueuedRequests :: BadgeIssuerKey -> Maybe (TQueue GroupEvent) -> ServiceState -> IO ()
 processQueuedRequests key trackerQ_ env = do
   cc <- atomically $ readTMVar $ serviceCC env
-  -- 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
+  -- a store call can take verifyTimeout, and a Play hand-over two, so a request that may make one waits on a lane of its own, and renewal checks on one no purchase can fill
+  purchaseQ <- newTQueueIO
+  renewalQ <- newTQueueIO
   checks <- newPurchaseChecks
   let answer (u, reqId, sigKey, reqData) = handleServiceRequest key (storeVerifier env) checks cc trackerQ_ u reqId sigKey reqData
       route req@(_, _, sigKey, reqData) =
         requestLane cc sigKey reqData >>= \case
           MainLane -> answer req
-          _ -> atomically $ writeTQueue storeQ req
+          PurchaseLane -> atomically $ writeTQueue purchaseQ req
+          RenewalLane -> atomically $ writeTQueue renewalQ req
       lane q act = forever $ do
         req@(_, reqId, _, _) <- atomically $ readTQueue q
         survive ("request " <> safeDecodeUtf8 (strEncode reqId)) $ act req
-  raceAny_ [lane (serviceRequestQ env) route, lane storeQ answer]
+  raceAny_ [lane (serviceRequestQ env) route, lane purchaseQ answer, lane renewalQ answer]
 
 -- | A store call can take verifyTimeout, so a request that may make one waits on a lane of its own.
 data RequestLane = MainLane | PurchaseLane | RenewalLane

tests/Bots/BadgeService/BotTests.hs

@@ -193,6 +193,7 @@ badgeServiceTests = do
       it "should answer other requests while a Play receipt is with the store, and credit it once Play answers" testPlayHoldsNoOtherRequest
       it "should route each request to its 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 a renewal check while a Play purchase is with the store" testPurchaseHoldsNoRenewal
       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
@@ -3720,11 +3721,39 @@ testRenewalHoldsNoOtherRequest ps = do
           bob <##. "expires "
           cath ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS})
           cath <### [StartsWith (openPurchase ""), StartsWith "1: supporter"]
+          withNewTestChatCfg ps bsClientCfg "dan" danProfile $ \dan -> do
+            dan ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
+            dan <### [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")]
 
+testPurchaseHoldsNoRenewal :: HasCallStack => TestParams -> IO ()
+testPurchaseHoldsNoRenewal ps = do
+  entered <- newEmptyMVar
+  release <- newEmptyMVar
+  hook <- newIORef $ putMVar entered () >> takeMVar release
+  let holding store = (googleVerifierWithHook hook store) {verifyTimeout = 60000000}
+  withBadgeServiceVerifier ps holding $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
+      withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do
+        (firstStart, rows) <- clientSubscribedMonthly env alice
+        let (requestAt, _) = renewalMoments rows
+            renewalStart = addMonths 1 firstStart
+        bob ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
+        storePurchaseOpen bob ""
+        timeout 30000000 (takeMVar entered) `shouldReturn` Just ()
+        storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1
+        setClockAt bsClock requestAt
+        alice ##> "/_app activate"
+        alice <## "ok"
+        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")]
+        putMVar release ()
+        expectLinesWithin 60 bob ["1: supporter"] []
+
 testAppleSubscriptionHoldsNoOtherRequest :: HasCallStack => TestParams -> IO ()
 testAppleSubscriptionHoldsNoOtherRequest ps = do
   entered <- newEmptyMVar