tests: credit a store purchase that loses the claim race, and drop the client's keys on receipt_used

tests/Bots/BadgeService/BotTests.hs

@@ -129,6 +129,7 @@ badgeServiceTests = do
     it "should replay a receipt to its own key while the store is down, and to no other" testStoreReplayWhileStoreDown
     it "should answer a throwing Apple verifier as internal, and a failing or hanging Google one as retryable" testStoreVerifierFailures
     it "should credit a transaction claimed twice at once only once" testStoreClaimRace
+    it "should answer a request that lost the claim race with the credential the winner was given" testStorePurchaseRace
     it "should refuse a store with no verifier with no retry, and the client should keep its keys" testPurchaseWithNoVerifier
     it "should credit nothing when the verified transaction is not the one the evidence names" testStoreVerifiedOtherTransaction
     it "should refuse a verified quantity other than one as internal, and the client should keep its keys" testStoreQuantityRefused
@@ -136,6 +137,7 @@ badgeServiceTests = do
     it "should redeem a Play purchase into a badge, and replay it as the same badge" testPurchaseBadge
     it "should redeem an App Store purchase by its JWS" testPurchaseBadgeAppStore
     it "should drop the keys of a receipt refused for good, and keep them while it is pending" testPurchaseStash
+    it "should drop the keys of a receipt credited to another key" testPurchaseStashReceiptUsed
     it "should keep the keys of a Play token the service will not send to Play" testPurchaseUnsentPlayToken
     it "should refuse a store purchase while a badge is held, before anything is sent" testPurchaseWhileBadgeHeld
     it "should answer a receipt presented under a second profile as the profile that bought it" testPurchaseSameReceiptOtherProfile
@@ -1618,6 +1620,21 @@ testStoreClaimRace ps =
     rowCount cc "sx_badge_service_payments" `shouldReturn` 1
     rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
 
+testStorePurchaseRace :: HasCallStack => TestParams -> IO ()
+testStorePurchaseRace ps = do
+  hook <- newIORef (pure ())
+  withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \env@BadgeServiceEnv {bsController = cc} -> do
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    winner <- newIORef Nothing
+    -- the same purchase is presented again while the first is with the store, and credited first
+    writeIORef hook $ serviceCmd env purchaseKey (purchaseCmd masterKey supporterPlay) >>= writeIORef winner . Just
+    raced <- serviceCmd env purchaseKey $ purchaseCmd masterKey supporterPlay
+    Just credited <- readIORef winner
+    credentialOf credited `shouldSatisfy` isJust
+    credentialOf raced `shouldBe` credentialOf credited
+    storePayments cc `shouldReturn` [("google", Nothing, Nothing, 1)]
+    rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
+
 testStorePurchaseKeyMismatch :: HasCallStack => TestParams -> IO ()
 testStorePurchaseKeyMismatch ps =
   withBadgeService ps $ \clientCfg bsLink cc ->
@@ -1690,6 +1707,22 @@ testPurchaseStash ps =
       stashes `shouldReturn` 1
       rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
 
+testPurchaseStashReceiptUsed :: HasCallStack => TestParams -> IO ()
+testPurchaseStashReceiptUsed ps =
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
+      withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do
+        let purchase = "/_badge purchase 1 " <> paymentArg supporterPlay
+        alice ##> purchase
+        alice <## "badge redeemed"
+        alice <## "supporter badge - active"
+        alice <##. "expires "
+        bob ##> purchase
+        bob <## "cannot get badge: badge service error: receipt_used"
+        rowCount (chatController bob) "badge_store_receipts" `shouldReturn` 0
+        rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1
+        rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
+
 testPurchaseUnsentPlayToken :: HasCallStack => TestParams -> IO ()
 testPurchaseUnsentPlayToken ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->

tests/Bots/BadgeService/FakeStore.hs

@@ -2,10 +2,12 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
 module Bots.BadgeService.FakeStore
   ( FakeStore (..),
     newFakeStore,
+    googleVerifierWithHook,
     settlePending,
     setGoogleDown,
     googleSupporterToken,
@@ -26,7 +28,7 @@ import qualified Data.Aeson as J
 import qualified Data.ByteString.Base64.URL as B64U
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
-import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
 import Data.Text (Text)
 import Simplex.Chat.PaymentService (ServicePayment (..), googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (CurrencyAmount (..))
@@ -106,6 +108,16 @@ googleVerdict pendingSettled googleDown productId token =
   where
     purchased = VerifiedStoreTransaction {transactionRef = googlePurchaseRef token, productId, quantity = 1, testPurchase = False, paid = Nothing}
 
+-- | The fake store, running the hook's action once, inside the first Google verification, before it answers.
+googleVerifierWithHook :: IORef (IO ()) -> FakeStore -> StoreVerifier
+googleVerifierWithHook hook FakeStore {fakeVerifier = v@StoreVerifier {verifyGoogle}} =
+  v {verifyGoogle = hooked <$> verifyGoogle, verifyTimeout = 10000000}
+  where
+    hooked verify productId token = do
+      action <- atomicModifyIORef' hook (pure (),)
+      action
+      verify productId token
+
 settlePending :: FakeStore -> IO ()
 settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True