badge-service: answer Play purchases on a lane of their own (#7712)

apps/simplex-badge-service/README.md

@@ -242,6 +242,8 @@ 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, renewals or App Store purchases.
 
 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

@@ -66,6 +66,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.Types (StoreTransactionRef (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
@@ -288,9 +289,22 @@ issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} =
 processQueuedRequests :: BadgeIssuerKey -> Maybe (TQueue GroupEvent) -> ServiceState -> IO ()
 processQueuedRequests key trackerQ_ env = do
   cc <- atomically $ readTMVar $ serviceCC env
-  forever $ do
-    (u, reqId, sigKey, reqData) <- atomically $ readTQueue $ serviceRequestQ env
-    survive ("request " <> safeDecodeUtf8 (strEncode reqId)) $ handleServiceRequest key (storeVerifier env) cc trackerQ_ u reqId sigKey reqData
+  -- a Play hand-over can wait two verifyTimeouts on Play, so it waits on a lane of its own
+  playQ <- 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
+      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]
+
+-- | 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
 
 -- | 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.
@@ -465,10 +479,10 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran
         Right (Left resp) -> resp
         _ -> errorResponse BSEInternal
     -- the product is read only for a receipt not yet credited, so retiring it leaves its replays answered
-    newPurchase VerifiedStoreTransaction {productId, paid} = case storeProduct provider productId of
+    newPurchase tx@VerifiedStoreTransaction {productId, paid} = case storeProduct provider productId of
       Nothing -> pure $ errorResponse BSEProductUnavailable
       Just StoreProduct {badgeType, months} ->
-        fromMaybe (pure $ Right ()) acknowledgeReceipt >>= \case
+        maybe (pure $ Right ()) ($ tx) acknowledgeReceipt >>= \case
           Left refusal -> storeRefusalResponse refusal
           Right () -> do
             now <- badgeNow cc

apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs

@@ -32,7 +32,8 @@ data VerifiedStoreTransaction = VerifiedStoreTransaction
     quantity :: Int, -- as the store reported it; the service refuses any but 1, as the apps never buy more
     -- costs the buyer nothing: Apple's Sandbox, which a public TestFlight build buys in, and Google's license testers
     testPurchase :: Bool,
-    paid :: Maybe (CurrencyAmount, Text) -- in minor units; Google's purchase record carries no price
+    paid :: Maybe (CurrencyAmount, Text), -- in minor units; Google's purchase record carries no price
+    alreadyAcknowledged :: Bool -- Play's record says acknowledged or consumed; other stores have nothing to acknowledge
   }
   deriving (Eq, Show)
 
@@ -55,7 +56,7 @@ data StoreVerifier = StoreVerifier
     verifyApple :: Maybe (Text -> Either StoreRefusal VerifiedStoreTransaction),
     verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)), -- the product id and the token
     acknowledgeGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal ())),
-    -- microseconds; requests are answered one at a time, so a verifier that does not finish holds up every other one
+    -- microseconds; a lane answers one request at a time, so a verifier that does not finish holds up the rest of its lane
     verifyTimeout :: Int
   }
 
@@ -63,7 +64,7 @@ data StoreVerifier = StoreVerifier
 data StoreReceipt = StoreReceipt
   { txRef :: StoreTransactionRef,
     verifyReceipt :: IO (Either StoreRefusal VerifiedStoreTransaction),
-    acknowledgeReceipt :: Maybe (IO (Either StoreRefusal ()))
+    acknowledgeReceipt :: Maybe (VerifiedStoreTransaction -> IO (Either StoreRefusal ()))
   }
 
 noStoreVerifier :: StoreVerifier
@@ -87,7 +88,7 @@ toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, veri
           StoreReceipt
             (StoreTransactionRef PPGoogle (googlePurchaseRef token))
             (maybe unconfigured (\verify -> online "google verifier" $ verify productId token) verifyGoogle)
-            ((\acknowledge -> online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle)
+            ((\acknowledge VerifiedStoreTransaction {alreadyAcknowledged} -> if alreadyAcknowledged then pure (Right ()) else online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle)
   SPInvoice {} -> Nothing
   SPReceipt {} -> Nothing
   where

apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs

@@ -143,7 +143,8 @@ transaction ourBundleId AppleTransaction {transactionId, productId, bundleId, en
             productId,
             quantity,
             testPurchase,
-            paid = paidOf price currency
+            paid = paidOf price currency,
+            alreadyAcknowledged = False
           }
 
 -- | Apple's price is in milliunits of the currency, whatever its minor unit.

apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -85,10 +86,7 @@ verifyPurchase env productId token = (>>= purchaseVerdict productId token) <$> r
 -- which is how the app finds a purchase it has not yet settled.
 acknowledgePurchase :: PlayEnv -> Text -> Text -> IO (Either StoreRefusal ())
 acknowledgePurchase env productId token =
-  readPurchase env productId token >>= \case
-    Left refusal -> pure $ Left $ acknowledging refusal
-    Right ProductPurchase {alreadyAcknowledged = True} -> pure $ Right ()
-    Right _ -> bimap acknowledging (const ()) <$> playCall env (\req -> req {method = methodPost}) (purchaseUrl env productId token <> ":acknowledge")
+  bimap acknowledging (const ()) <$> playCall env (\req -> req {method = methodPost}) (purchaseUrl env productId token <> ":acknowledge")
   where
     acknowledging = \case
       SRUnreachable reason -> SRUnreachable $ "acknowledging: " <> reason
@@ -118,7 +116,7 @@ playCall env@PlayEnv {accessToken} prepare url =
         Right (code, _) -> pure $ Left $ SRUnreachable $ "Play answered HTTP " <> tshow code
 
 purchaseVerdict :: Text -> Text -> ProductPurchase -> Either StoreRefusal VerifiedStoreTransaction
-purchaseVerdict productId token ProductPurchase {purchaseState, purchaseType, purchaseQuantity, purchaseProductId}
+purchaseVerdict productId token ProductPurchase {purchaseState, purchaseType, purchaseQuantity, purchaseProductId, alreadyAcknowledged}
   | maybe False (/= productId) purchaseProductId = Left $ SRVerifierFailed "Play answered about another product"
   | otherwise = case purchaseState of
       0 -> purchased <$> testPurchaseOf purchaseType
@@ -133,7 +131,8 @@ purchaseVerdict productId token ProductPurchase {purchaseState, purchaseType, pu
           productId,
           quantity = fromMaybe 1 purchaseQuantity,
           testPurchase,
-          paid = Nothing
+          paid = Nothing,
+          alreadyAcknowledged
         }
     testPurchaseOf = \case
       Nothing -> Right False

apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs

@@ -38,4 +38,4 @@ vouched :: Text -> Text -> VerifiedStoreTransaction
 vouched transactionRef productId =
   -- not a test purchase, though nothing was paid: a test purchase is refused as test_purchase, which is
   -- terminal and drops the client's keys, so every dev purchase would fail for good
-  VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase = False, paid = Nothing}
+  VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase = False, paid = Nothing, alreadyAcknowledged = False}

tests/Bots/BadgeService/BotTests.hs

@@ -26,7 +26,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
 import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
-import Control.Concurrent (threadDelay)
+import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay)
 import Control.Concurrent.Async (async, cancel)
 import Control.Concurrent.STM (TQueue, atomically, readTMVar, readTQueue)
 import Control.Monad (forM_, void, when)
@@ -175,6 +175,8 @@ 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
+      it "should answer other requests while a Play receipt is with the store, and credit it once Play answers" testPlayHoldsNoOtherRequest
 
 badgeBotName :: Text
 badgeBotName = "SimpleX Badges"
@@ -2306,6 +2308,40 @@ testStoreReceiptAfterRestart ps = do
       expectLinesWithin 60 alice (creditedLines "" invoiceId "1: supporter") ["subscribed 1 connections on server localhost"]
       heldStoreReceipts (chatController alice) `shouldReturn` 0
 
+testPlayHoldsNoOtherRequest :: HasCallStack => TestParams -> IO ()
+testPlayHoldsNoOtherRequest ps = do
+  entered <- newEmptyMVar
+  release <- newEmptyMVar
+  hook <- newIORef $ putMVar entered () >> takeMVar release
+  -- past the 20s line wait, so a request queued behind the held call cannot be answered in time
+  let holding store = (googleVerifierWithHook hook store) {verifyTimeout = 60000000}
+  withBadgeServiceVerifier ps holding $ \BadgeServiceEnv {bsClientCfg, bsAddress, bsController = cc, bsStore = FakeStore {appleSupporterJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
+      withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob ->
+        withNewTestChatCfg ps bsClientCfg "cath" cathProfile $ \cath -> do
+          alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
+          storePurchaseOpen alice ""
+          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"]
+          g <- C.newRandom
+          (upgradeKey, upgradePriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
+          (fromPurchaseKey, fromPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
+          masterKey <- generateMasterKey g
+          now <- getCurrentTime
+          let upgrade = BadgeUpgrade {fromPurchaseKey, receipt = "receipt", receiptSignature = C.sign' fromPriv "receipt", balance = BadgeBalance {lastEntry = emptyEntry now BTSupporter}}
+              upgradeReq = LB.unpack $ J.encode $ requestObject upgradeKey BSCPurchaseBadge {masterKey, payment = supporterPlay, upgrade = Just upgrade}
+          bob ##> ("/_service_request 1 " <> bsAddress <> " sign_key=" <> B.unpack (strEncode $ C.StoredPrivateKey upgradePriv) <> " " <> upgradeReq)
+          bob <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
+          putMVar release ()
+          expectLinesWithin 60 alice ["1: supporter"] []
+          rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 3
+
 createInvoice :: HasCallStack => TestCC -> Int -> IO String
 createInvoice cc userId = do
   cc ##> ("/_badge invoice " <> show userId)

tests/Bots/BadgeService/FakePlay.hs

@@ -50,7 +50,8 @@ data FakePlay = FakePlay
     fpTokenSeconds :: TVar Int,
     fpGrantedTokens :: TVar [B.ByteString],
     fpPurchasePaths :: TVar [[Text]],
-    fpAcknowledgeRefusal :: TVar (Maybe Int),
+    -- what the acknowledge endpoint answers instead of acknowledging
+    fpAcknowledgeRefusal :: TVar (Maybe PlayAnswer),
     fpAcknowledged :: TVar [Text]
   }
 
@@ -122,7 +123,7 @@ answerTokenRequests FakePlay {fpTokenRefusal} = atomically . writeTVar fpTokenRe
 grantTokensFor :: FakePlay -> Int -> IO ()
 grantTokensFor FakePlay {fpTokenSeconds} = atomically . writeTVar fpTokenSeconds
 
-answerAcknowledgements :: FakePlay -> Maybe Int -> IO ()
+answerAcknowledgements :: FakePlay -> Maybe PlayAnswer -> IO ()
 answerAcknowledgements FakePlay {fpAcknowledgeRefusal} = atomically . writeTVar fpAcknowledgeRefusal
 
 fakeApp :: RSA.PublicKey -> FakePlay -> Application
@@ -143,7 +144,7 @@ fakeApp key FakePlay {fpConfig = PlayStoreConfig {gTokenUrl}, fpAnswers, fpToken
         _ -> respond $ status unauthorized401
     acknowledge token =
       readTVarIO fpAcknowledgeRefusal >>= \case
-        Just code -> respond $ status (mkStatus code "Refused")
+        Just answer -> answerWith answer
         Nothing -> do
           atomically $ modifyTVar' fpAcknowledged (<> [token])
           respond $ responseLBS ok200 [] ""
@@ -168,11 +169,13 @@ fakeApp key FakePlay {fpConfig = PlayStoreConfig {gTokenUrl}, fpAnswers, fpToken
       _ -> False
     purchase token =
       M.lookup token <$> readTVarIO fpAnswers >>= \case
-        Just (PlayRecord v) -> respond $ json ok200 v
-        Just (PlayBody b) -> respond $ responseLBS ok200 [(hContentType, "application/json")] b
-        Just (PlayStatus code) -> respond $ status (mkStatus code "Answer")
-        Just PlayHang -> forever $ threadDelay 1000000
+        Just answer -> answerWith answer
         Nothing -> respond $ status notFound404
+    answerWith = \case
+      PlayRecord v -> respond $ json ok200 v
+      PlayBody b -> respond $ responseLBS ok200 [(hContentType, "application/json")] b
+      PlayStatus code -> respond $ status (mkStatus code "Answer")
+      PlayHang -> forever $ threadDelay 1000000
 
 json :: Status -> J.Value -> Response
 json st = responseLBS st [(hContentType, "application/json")] . J.encode

tests/Bots/BadgeService/FakeStore.hs

@@ -89,7 +89,7 @@ newFakeStore = do
   where
     fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir </> name)
     appleTransaction transactionRef productId testPurchase cents =
-      VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD")}
+      VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD"), alreadyAcknowledged = False}
 
 googleVerdict :: IORef Bool -> IORef Bool -> Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
 googleVerdict pendingSettled googleDown productId token =
@@ -106,7 +106,7 @@ googleVerdict pendingSettled googleDown productId token =
       | token == googleHangingToken -> forever $ threadDelay 1000000
       | otherwise -> pure $ Left $ SRInvalid "not a fake purchase"
   where
-    purchased = VerifiedStoreTransaction {transactionRef = googlePurchaseRef token, productId, quantity = 1, testPurchase = False, paid = Nothing}
+    purchased = VerifiedStoreTransaction {transactionRef = googlePurchaseRef token, productId, quantity = 1, testPurchase = False, paid = Nothing, alreadyAcknowledged = False}
 
 -- | The fake store, running the hook's action once, inside the first Google verification, before it answers.
 googleVerifierWithHook :: IORef (IO ()) -> FakeStore -> StoreVerifier

tests/Bots/BadgeService/StoreVerifierTests.hs

@@ -71,6 +71,7 @@ badgeStoreVerifierTests = describe "badge store verifiers" $ do
     it "asks for a new access token once the one it holds is about to expire" testPlayTokenExpires
     it "sends no token that is only dots, and describes a token outside the grammar without quoting it" testPlayTokensNotSent
     it "acknowledges a purchase, unless it is acknowledged or consumed already" testPlayAcknowledges
+    it "reads a purchase once to verify and acknowledge it, and acknowledges only what that read found unacknowledged" testPlayReadsPurchaseOnce
     it "reports an acknowledgement Play refuses or does not answer" testPlayAcknowledgementFails
     it "acknowledges through the verifier a [google] section configures" testPlayConfiguredAcknowledges
 
@@ -219,7 +220,7 @@ testAppleVerdict = do
   chain <- trustedChain
   jws <- signedBy chain $ transactionPayload [] []
   appleVerdict (rootCert chain) jws
-    `shouldReturn` Right VerifiedStoreTransaction {transactionRef = "2000000900000001", productId = "BADGE_SUPPORTER_01", quantity = 1, testPurchase = False, paid = Just (CurrencyAmount 700, "USD")}
+    `shouldReturn` Right VerifiedStoreTransaction {transactionRef = "2000000900000001", productId = "BADGE_SUPPORTER_01", quantity = 1, testPurchase = False, paid = Just (CurrencyAmount 700, "USD"), alreadyAcknowledged = False}
   appleTransactionId jws `shouldBe` Just "2000000900000001"
 
 testAppleRootNotTrusted :: IO ()
@@ -371,7 +372,10 @@ playVerifier fake =
 
 acknowledgement :: StoreVerifier -> ServicePayment -> IO (Maybe (Either StoreRefusal ()))
 acknowledgement verifier payment = case toStoreReceipt verifier payment of
-  Just (Right StoreReceipt {acknowledgeReceipt}) -> sequence acknowledgeReceipt
+  Just (Right StoreReceipt {verifyReceipt, acknowledgeReceipt}) ->
+    verifyReceipt >>= \case
+      Right tx -> traverse ($ tx) acknowledgeReceipt
+      Left refusal -> expectationFailure ("not verified: " <> show refusal) >> undefined
   _ -> expectationFailure "not a store receipt" >> undefined
 
 playVerdict :: StoreVerifier -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
@@ -406,7 +410,7 @@ testPlayPurchased = withFakePlay $ \fake -> do
   verifier <- playVerifier fake
   answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
   playVerdict verifier testToken
-    `shouldReturn` Right VerifiedStoreTransaction {transactionRef = googlePurchaseRef testToken, productId = "badge_supporter_01", quantity = 1, testPurchase = False, paid = Nothing}
+    `shouldReturn` Right VerifiedStoreTransaction {transactionRef = googlePurchaseRef testToken, productId = "badge_supporter_01", quantity = 1, testPurchase = False, paid = Nothing, alreadyAcknowledged = False}
   readTVarIO (fpPurchasePaths fake)
     `shouldReturn` [["androidpublisher", "v3", "applications", fakePackageName, "purchases", "products", "badge_supporter_01", "tokens", testToken]]
   answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 [("quantity", J.toJSON (2 :: Int)), ("productId", "badge_supporter_01")]
@@ -530,6 +534,18 @@ testPlayAcknowledges = withFakePlay $ \fake -> do
     acknowledging `shouldReturn` Just (Right ())
   readTVarIO (fpAcknowledged fake) `shouldReturn` [testToken]
 
+testPlayReadsPurchaseOnce :: IO ()
+testPlayReadsPurchaseOnce = do
+  requestsFor [] `shouldReturn` (1, [testToken])
+  forM_ ["acknowledgementState", "consumptionState"] $ \state ->
+    requestsFor [(state, J.toJSON (1 :: Int))] `shouldReturn` (1, [])
+  where
+    requestsFor fields = withFakePlay $ \fake -> do
+      verifier <- playVerifier fake
+      answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 fields
+      acknowledgement verifier SPGoogle {productId = "badge_supporter_01", token = testToken} `shouldReturn` Just (Right ())
+      (,) <$> (length <$> readTVarIO (fpPurchasePaths fake)) <*> readTVarIO (fpAcknowledged fake)
+
 testPlayAcknowledgementFails :: IO ()
 testPlayAcknowledgementFails = withFakePlay $ \fake -> do
   verifier <- playVerifier fake
@@ -539,12 +555,11 @@ testPlayAcknowledgementFails = withFakePlay $ \fake -> do
         maybe "" reason r `shouldSatisfy` ("acknowledging: " `T.isPrefixOf`)
         maybe "" reason r `shouldNotSatisfy` (testToken `T.isInfixOf`)
   answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
-  answerAcknowledgements fake $ Just 403
+  answerAcknowledgements fake $ Just $ PlayStatus 403
   acknowledgedAs Failed
-  answerAcknowledgements fake $ Just 503
+  answerAcknowledgements fake $ Just $ PlayStatus 503
   acknowledgedAs Unreachable
-  answerAcknowledgements fake Nothing
-  answerPurchase fake testToken PlayHang
+  answerAcknowledgements fake $ Just PlayHang
   acknowledgedAs Unreachable
   readTVarIO (fpAcknowledged fake) `shouldReturn` []