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

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` []