badge service: credit a store receipt only when the verified transaction is the one claimed; answer internal when a request throws

tests/BadgeTests.hs

@@ -10,11 +10,11 @@
 module BadgeTests (badgeTests) where
 
 import BadgeService.Service (badgeErrorRetryAfter, shownServiceRequest, survive)
+import BadgeService.StoreReceipts (StoreReceipt (..), StoreRefusal (..), StoreVerifier (..), storeReceipt)
 import Control.Concurrent (forkIO, killThread, threadDelay)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
-import Control.Exception (SomeAsyncException, SomeException, catch, fromException, throwIO)
-import BadgeService.StoreReceipts (StoreReceipt (..), StoreRefusal (..), StoreVerifier (..), storeReceipt)
 import Control.Concurrent.STM (atomically)
+import Control.Exception (SomeAsyncException, SomeException, catch, fromException, throwIO)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Base64.URL as B64U
 import Data.Map.Strict (Map)

tests/Bots/BadgeService/BotTests.hs

@@ -129,6 +129,7 @@ badgeServiceTests = do
     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 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 store purchase whose purchaseKey is not the verified signer" testStorePurchaseKeyMismatch
     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
@@ -1559,6 +1560,13 @@ testStoreVerifierFailures ps =
     answer (googlePayment "badge_supporter_01" googleHangingToken) >>= (`shouldSatisfy` \(code, retryAfter) -> code == BSEProviderUnavailable && isJust retryAfter)
     nothingPurchased cc
 
+testStoreVerifiedOtherTransaction :: HasCallStack => TestParams -> IO ()
+testStoreVerifiedOtherTransaction ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = FakeStore {appleMisnamedJWS}} -> do
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey SPApple {jws = appleMisnamedJWS}) `shouldReturn` (BSEInternal, Nothing)
+    nothingPurchased cc
+
 testPurchaseWithNoVerifier :: HasCallStack => TestParams -> IO ()
 testPurchaseWithNoVerifier ps =
   withBadgeServiceVerifier ps (const noStoreVerifier) $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc} -> do
@@ -1580,7 +1588,7 @@ testStoreClaimRace ps =
     let claim paymentId purchaseKey masterKey =
           withDB' "claim" cc $ \db ->
             createStorePurchase db NewStorePurchase {paymentId, provider = PPGoogle, providerRef = "ref", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter} now
-    -- both past the read before either wrote, as two requests signing at once are
+    -- the second insert meets the first's claim, as a request that read before the first wrote would
     claim "p1" firstKey firstMasterKey >>= (`shouldSatisfy` either (const False) isJust)
     claim "p2" otherKey otherMasterKey `shouldReturn` Right Nothing
     rowCount cc "sx_badge_service_payments" `shouldReturn` 1

tests/Bots/BadgeService/FakeStore.hs

@@ -28,7 +28,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Text (Text)
-import Simplex.Chat.PaymentService (ServicePayment (..))
+import Simplex.Chat.PaymentService (ServicePayment (..), googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (CurrencyAmount (..))
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.FilePath ((</>))
@@ -43,6 +43,7 @@ data FakeStore = FakeStore
     appleLegendJWS :: Text,
     appleSandboxJWS :: Text,
     appleThrowingJWS :: Text,
+    appleMisnamedJWS :: Text,
     pendingSettled :: IORef Bool,
     googleDown :: IORef Bool,
     fakeVerifier :: StoreVerifier
@@ -54,12 +55,15 @@ newFakeStore = do
   appleLegendJWS <- fixtureJWS "transaction-legend.json"
   appleSandboxJWS <- fixtureJWS "transaction-sandbox.json"
   let appleThrowingJWS = unsignedJWS "{\"transactionId\":\"2000000812345679\",\"productId\":\"BADGE_SUPPORTER_01\"}"
+      appleMisnamedJWS = unsignedJWS "{\"transactionId\":\"2000000812345698\",\"productId\":\"BADGE_SUPPORTER_01\"}"
   pendingSettled <- newIORef False
   googleDown <- newIORef False
   let appleReceipts =
-        [ (appleSupporterJWS, appleTransaction "BADGE_SUPPORTER_01" SEProduction 700),
-          (appleLegendJWS, appleTransaction "BADGE_LEGEND_01" SEProduction 7000),
-          (appleSandboxJWS, appleTransaction "BADGE_LEGEND_01" SETest 7000)
+        [ (appleSupporterJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" SEProduction 700),
+          (appleLegendJWS, appleTransaction "2000000812345672" "BADGE_LEGEND_01" SEProduction 7000),
+          (appleSandboxJWS, appleTransaction "2000000812345673" "BADGE_LEGEND_01" SETest 7000),
+          -- a verifier vouching for another transaction than the one the evidence names
+          (appleMisnamedJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" SEProduction 700)
         ]
       verifyApple jws
         | jws == appleThrowingJWS = error "fake verifier bug"
@@ -71,14 +75,15 @@ newFakeStore = do
         appleLegendJWS,
         appleSandboxJWS,
         appleThrowingJWS,
+        appleMisnamedJWS,
         pendingSettled,
         googleDown,
         fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, verifyTimeout = 500000}
       }
   where
     fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir </> name)
-    appleTransaction productId environment cents =
-      StoreTransaction {productId, quantity = 1, environment, paid = Just (CurrencyAmount cents, "USD")}
+    appleTransaction transactionRef productId environment cents =
+      StoreTransaction {transactionRef, productId, quantity = 1, environment, paid = Just (CurrencyAmount cents, "USD")}
 
 googleVerdict :: IORef Bool -> IORef Bool -> Text -> Text -> IO (Either StoreRefusal StoreTransaction)
 googleVerdict pendingSettled googleDown productId token =
@@ -95,7 +100,7 @@ googleVerdict pendingSettled googleDown productId token =
       | token == googleHangingToken -> forever $ threadDelay 1000000
       | otherwise -> pure $ Left $ SRInvalid "not a fake purchase"
   where
-    purchased = StoreTransaction {productId, quantity = 1, environment = SEProduction, paid = Nothing}
+    purchased = StoreTransaction {transactionRef = googlePurchaseRef token, productId, quantity = 1, environment = SEProduction, paid = Nothing}
 
 settlePending :: FakeStore -> IO ()
 settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True