core: deliver a store purchase to the profile it was bought under; verify store receipts safely

src/Simplex/Chat/Library/Commands.hs

@@ -26,12 +26,10 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import qualified Data.Aeson as J
-import qualified Data.Aeson.KeyMap as JM
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.Attoparsec.Combinator as A
 import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Base64.URL as B64U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -78,7 +76,7 @@ import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Messages.CIContent.Events
 import Simplex.Chat.Operators
 import Simplex.Chat.Options
-import Simplex.Chat.PaymentService (ServicePayment (..))
+import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef)
 import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
 import Simplex.Chat.Remote
@@ -5244,14 +5242,15 @@ redeemBadgeCode nm user@User {userId} codeText = do
       BSECodeExpired -> True
       _ -> False
 
--- | The app presents a purchase until this returns its badge. The stash is keyed by the store's own
--- id for the transaction, so every retry reaches the service as the signer it first credited.
+-- | The app presents a purchase until this returns its badge, under whichever profile is active; the
+-- stash stays with the profile it was first presented under, so every retry is the signer first credited.
 purchaseBadge :: NetworkRequestMode -> User -> ServicePayment -> CM ChatResponse
-purchaseBadge nm user@User {userId} payment = do
+purchaseBadge nm presentingUser payment = do
   txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment
   sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwRedeemError BREServiceNotConfigured) pure
   g <- asks random
   now <- liftIO getCurrentTime
+  user@User {userId} <- withStore $ \db -> liftIO (getBadgeStoreReceiptUserId db txRef) >>= maybe (pure presentingUser) (getUser db)
   (present_, purchased) <- withEntityLock "badgePurchase" (CLBadgeUser userId) $ do
     stash_ <- withStore' $ \db -> getBadgeStoreReceipt db user txRef
     stash@BadgeStash {masterKey} <- stashBadgeKeys user stash_ $ \db -> createBadgeStoreReceipt db g user txRef now
@@ -5266,21 +5265,13 @@ purchaseBadge nm user@User {userId} payment = do
       BSEReceiptUsed -> True
       _ -> False
 
--- | Read without verifying anything: the id only keys the stash on this device, and the service
--- verifies the evidence itself. A Google token is a bearer secret, so only its hash is kept.
+-- | The same reference the service claims a transaction by, read without verifying anything.
 storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef
 storeTransactionRef = \case
   SPApple {jws} -> StoreTransactionRef "apple" <$> appleTransactionId jws
-  SPGoogle {token} -> Just $ StoreTransactionRef "google" $ safeDecodeUtf8 $ strEncode $ C.sha256Hash $ encodeUtf8 token
+  SPGoogle {token} -> Just $ StoreTransactionRef "google" $ googlePurchaseRef token
   SPInvoice {} -> Nothing
   SPReceipt {} -> Nothing
-  where
-    appleTransactionId signed = case T.splitOn "." signed of
-      [_, payload, _] -> do
-        J.Object o <- J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload)
-        J.String txId <- JM.lookup "transactionId" o
-        pure txId
-      _ -> Nothing
 
 -- | A stash that already bought a badge here passes, as re-sending it adds nothing; any other is
 -- refused while a badge is held, before its keys are stashed or sent, so the funding stays unspent.

src/Simplex/Chat/PaymentService.hs

@@ -1,17 +1,28 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.PaymentService
   ( ServiceInvoice (..),
     ServicePayment (..),
+    appleTransactionId,
+    googlePurchaseRef,
     module Simplex.Chat.PaymentService.Types,
   ) where
 
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as JM
 import qualified Data.Aeson.TH as JQ
+import qualified Data.ByteString.Base64.URL as B64U
 import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.PaymentService.Types
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String (strEncode)
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
+import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
 
 data ServiceInvoice = ServiceInvoice
   { invoiceId :: InvoiceId,
@@ -32,6 +43,19 @@ data ServicePayment
   | SPReceipt {receipt :: Text} -- transfer of unissued months
   deriving (Show)
 
+-- | Read without verifying the signature: it names the transaction, and proves nothing about it.
+appleTransactionId :: Text -> Maybe Text
+appleTransactionId signed = case T.splitOn "." signed of
+  [_, payload, _] -> do
+    J.Object o <- J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload)
+    J.String txId <- JM.lookup "transactionId" o
+    pure txId
+  _ -> Nothing
+
+-- | A purchase token is a bearer secret, so a purchase is named by its hash.
+googlePurchaseRef :: Text -> Text
+googlePurchaseRef = safeDecodeUtf8 . strEncode . C.sha256Hash . encodeUtf8
+
 $(JQ.deriveJSON defaultJSON ''ServiceInvoice)
 
 $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SP") ''ServicePayment)

src/Simplex/Chat/Store/Badges.hs

@@ -20,6 +20,7 @@ module Simplex.Chat.Store.Badges
     clearShownBadge,
     getBadgeCodeRedemption,
     createBadgeCodeRedemption,
+    getBadgeStoreReceiptUserId,
     getBadgeStoreReceipt,
     createBadgeStoreReceipt,
     deleteBadgeStash,
@@ -49,6 +50,7 @@ import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType
 import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..))
 import Simplex.Chat.Store.Shared (insertedRowId)
 import Simplex.Chat.Types
+import Simplex.Messaging.Agent.Protocol (UserId)
 import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
@@ -105,6 +107,13 @@ createBadgeCodeRedemption db g User {userId} code now = do
   redemptionId <- insertedRowId db
   pure BadgeStash {stashRef = BSRCodeRedemption redemptionId, purchaseKey, purchasePrivKey, masterKey}
 
+-- | A store transaction belongs to the store account, not to a profile, so its stash is looked up
+-- across profiles: presented under another, it still reaches the service as the key it was credited to.
+getBadgeStoreReceiptUserId :: DB.Connection -> StoreTransactionRef -> IO (Maybe UserId)
+getBadgeStoreReceiptUserId db StoreTransactionRef {provider, transactionRef} =
+  maybeFirstRow fromOnly $
+    DB.query db "SELECT user_id FROM badge_store_receipts WHERE provider = ? AND transaction_ref = ?" (provider, transactionRef)
+
 getBadgeStoreReceipt :: DB.Connection -> User -> StoreTransactionRef -> IO (Maybe BadgeStash)
 getBadgeStoreReceipt db User {userId} StoreTransactionRef {provider, transactionRef} =
   maybeFirstRow (toBadgeStash BSRStoreReceipt) $

src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs

@@ -152,6 +152,7 @@ DROP TABLE @badge_prices;
 |]
 
 {- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
+The service alone already has @badge_purchases.payment_id and @badge_ledger.payment_id (its 20260925_badge_store_receipts).
 
 CREATE TABLE @subscription_charges(
   charge_id TEXT NOT NULL PRIMARY KEY,

src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs

@@ -18,7 +18,7 @@ CREATE TABLE badge_store_receipts(
   purchase_priv_key BYTEA NOT NULL,
   master_key BYTEA NOT NULL,
   created_at TIMESTAMPTZ NOT NULL,
-  UNIQUE(user_id, provider, transaction_ref)
+  UNIQUE(provider, transaction_ref)
 );
 
 CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id);

src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs

@@ -153,6 +153,7 @@ DROP TABLE @badge_prices;
 |]
 
 {- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
+The service alone already has @badge_purchases.payment_id and @badge_ledger.payment_id (its 20260925_badge_store_receipts).
 
 CREATE TABLE @subscription_charges(
   charge_id TEXT NOT NULL PRIMARY KEY,

src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs

@@ -17,7 +17,7 @@ CREATE TABLE badge_store_receipts(
   purchase_priv_key BLOB NOT NULL,
   master_key BLOB NOT NULL,
   created_at TEXT NOT NULL,
-  UNIQUE(user_id, provider, transaction_ref)
+  UNIQUE(provider, transaction_ref)
 ) STRICT;
 
 CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id);