core: scope client badge shown-purchase to its user

plans/badges-codes/2026-08-21-badges-web-checkout.md

@@ -641,8 +641,8 @@ Phase C ends with a chat client that can redeem a code minted by B8 and show the
 - `createCodePayment` writes the `payments` row with `provider = 'code'`, `invoice_id` NULL and `status = 'settled'`, and returns its id. `payments.payment_id` and `badge_issuances.issuance_id` are both `TEXT NOT NULL PRIMARY KEY` with no default (`M20260731_user_badges.hs:43,167`), so each caller mints a UUID with `Data.UUID.V4.nextRandom`; `uuid` is already a library dependency (`simplex-chat.cabal:376`). `badge_ledger.entry_uuid` is different: it is authored by the service and copied verbatim (core §1), never minted here. As on the service side, `payments` has no `price_id` or `offer_id` columns (`M20260731_user_badges.hs:42-56`), so core §5's "`price_id` and `offer_id` NULL" does not apply.
 - `createPurchase` writes the purchase row with the purchase keypair, the badge master key, that `payment_id`, status `issued`, and `initial_badge_type` and `current_badge_type` both set to the badge type the service stated. Both columns are `NOT NULL` with no default (`M20260731_user_badges.hs:97-98`), and a code redemption does not know its badge type until the response arrives, so the row is written **on success only**, as core §5 requires for the code payment. Nothing is persisted before the send; a response lost in flight is recovered with H2's `codes unredeem`, not by reusing a stored key. Core §5 calls this row *the badge row*; this plan calls it the purchase row throughout (§3).
 - `createIssuance` writes the `badge_issuances` row carrying the verified credential and its period, which C3's worker writes again for each new period.
-- `supersedePurchases` moves every other purchase of the same slot for that user from `issued` to `superseded`, and `setShownPurchase` points `users.shown_badge_id` at the new row. The column exists (`M20260731_user_badges.hs:220`) and has no writer in the repo yet, so this is new code; it is separate from `setUserBadge` (`Store/Profiles.hs:375`), which writes the profile's badge columns and is what C3 calls for presentation.
-- `getShownPurchase` reads the purchase `users.shown_badge_id` points at, returning the row with its purchase keypair and badge master key, which is what C2 renders and what C3 signs `issueBadge` with. It is new code: `shown_badge_id` has no reader in the repo either.
+- `supersedePurchases` moves every other purchase of the same slot for that user from `issued` to `superseded`, and `setShownPurchase` points `users.shown_badge_id` at the new row. The column exists (`M20260731_user_badges.hs:220`) and has no writer in the repo yet, so this is new code; it is separate from `setUserBadge` (`Store/Profiles.hs:375`), which writes the profile's badge columns and is what C3 calls for presentation. `supersedePurchases` derives the slot from the kept purchase's own `current_badge_type` rather than from a badge type the caller states, so a mismatched pair cannot clear the wrong slot.
+- `getShownPurchase` reads the purchase `users.shown_badge_id` points at, returning the row with its purchase keypair and badge master key, which is what C2 renders and what C3 signs `issueBadge` with. It is new code: `shown_badge_id` has no reader in the repo either. **Both ends scope the purchase to the user.** `shown_badge_id` is a bare foreign key to `badge_purchases` with nothing tying it to the pointing profile, and the row it reaches carries a private key the worker signs with, so `setShownPurchase` refuses a purchase that is not this user's and `getShownPurchase` joins on `p.user_id = u.user_id`.
 - `getLastBadgeLedgerEntry` reads the purchase's last `badge_ledger` row, which is what the worker compares a statement against.
 - `insertLedgerEntries` writes a statement's entries into `badge_ledger` verbatim. The client is never the author (core §1). An `opening` entry restates the balance absolutely, regardless of what preceded it. It takes the wire `BadgeStatement` whole, because `previousEntryId` is what decides how the entries attach and a caller must not have to reimplement that: **present** it names an entry the client already holds and the entries append after it; **absent with entries present** the entries "attach to nothing" (`badges-rpc.md:56`) and the statement *is* the ledger, so rows the client holds that the statement does not carry are stale and are deleted — appending on an absent cursor would duplicate the ledger. An empty `entries` changes nothing either way. Insertion is `ON CONFLICT (entry_uuid) DO NOTHING` against `@idx_badge_ledger_uuid`: `purchaseBadge` and `getBadgeCatalog` return the complete history every time, so re-delivery is the normal case and must be a no-op, not merely non-crashing. Array position is the only thing that orders the entries — every entry of one command shares a `createdAt` and `serviceCreatedAt` is not on the wire — so they are inserted in the order given and never sorted.
 - Unknown credit and debit tags go to `entry_type_unknown` and `entry_type_value`, for re-decoding after an app upgrade. Known tags keep `BadgeService/Store.hs`'s spellings exactly. `credit(charge)`, `credit(transferIn)`, `debit(upgrade)` and `debit(transferOut)` are refused rather than coerced, matching `BadgeService/Service.hs`'s `statementEntryType`, which refuses to put any of them on the wire in the first place.

src/Simplex/Chat/Store/Badges.hs

@@ -50,8 +50,8 @@ module Simplex.Chat.Store.Badges
   )
 where
 
-import Control.Monad (forM_, unless)
-import Control.Monad.Except (ExceptT, liftEither)
+import Control.Monad (forM_, unless, when)
+import Control.Monad.Except (ExceptT, liftEither, throwError)
 import Control.Monad.IO.Class (liftIO)
 import qualified Data.Aeson as J
 import Data.ByteString (ByteString)
@@ -202,31 +202,66 @@ createPurchase db userId purchaseKey purchasePrivKey masterKey@(BadgeMasterKey m
 -- the slot has exactly one issued purchase again. The superseded row keeps its unconsumed
 -- months: purchases are unlinkable, so the service cannot move a balance between them.
 --
+-- The slot comes from the KEPT ROW's own @current_badge_type@, read here, not from a badge type
+-- the caller states: a caller that paired a purchase id with the wrong badge type would
+-- otherwise clear the wrong slot and leave two issued purchases in the right one. That read also
+-- scopes the purchase to the user, so a purchase id belonging to another profile cannot decide
+-- which of this profile's badges is superseded.
+--
 -- The slot filter is applied in Haskell rather than as a SQL @IN@ over the slot's badge types:
 -- @IN ?@ with a list is postgresql-simple's 'Database.PostgreSQL.Simple.In', which
 -- sqlite-simple has no counterpart for, and a user holds at most a handful of purchases.
-supersedePurchases :: DB.Connection -> UserId -> Int64 -> BadgeType -> UTCTime -> IO ()
-supersedePurchases db userId keepPurchaseId badgeType now = do
+supersedePurchases :: DB.Connection -> UserId -> Int64 -> UTCTime -> ExceptT StoreError IO ()
+supersedePurchases db userId keepPurchaseId now = do
+  kept <-
+    liftIO $
+      DB.query
+        db
+        "SELECT current_badge_type FROM badge_purchases WHERE badge_purchase_id = ? AND user_id = ?"
+        (keepPurchaseId, userId)
+  slot <- case kept of
+    (Only badgeType : _) -> pure $ badgeSlot badgeType
+    [] -> throwError $ notThisUsersPurchase keepPurchaseId userId
   rows <-
-    DB.query
-      db
-      "SELECT badge_purchase_id, current_badge_type FROM badge_purchases WHERE user_id = ? AND status = ? AND badge_purchase_id <> ?"
-      (userId, PSIssued, keepPurchaseId)
-  let slot = badgeSlot badgeType
-      superseded = [pId | (pId :: Int64, bt) <- rows, badgeSlot bt == slot]
-  forM_ superseded $ \pId ->
+    liftIO $
+      DB.query
+        db
+        "SELECT badge_purchase_id, current_badge_type FROM badge_purchases WHERE user_id = ? AND status = ? AND badge_purchase_id <> ?"
+        (userId, PSIssued, keepPurchaseId)
+  liftIO $ forM_ [pId | (pId :: Int64, bt) <- rows, badgeSlot bt == slot] $ \pId ->
     DB.execute
       db
       "UPDATE badge_purchases SET status = ?, updated_at = ? WHERE badge_purchase_id = ?"
       (PSSuperseded, now, pId)
 
+notThisUsersPurchase :: Int64 -> UserId -> StoreError
+notThisUsersPurchase badgePurchaseId userId =
+  SEInternalError $ "badge purchase " <> show badgePurchaseId <> " does not belong to user " <> show userId
+
 -- | Points @users.shown_badge_id@ at a purchase. Separate from
 -- 'Simplex.Chat.Store.Profiles.setUserBadge', which writes the profile's badge columns: this
 -- one records WHICH purchase the profile's badge came from, which is what
 -- 'getShownPurchase' reads back to sign the next @issueBadge@.
-setShownPurchase :: DB.Connection -> UserId -> Int64 -> IO ()
-setShownPurchase db userId badgePurchaseId =
-  DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (badgePurchaseId, userId)
+--
+-- The purchase must be this user's. The column is a bare foreign key to @badge_purchases@ with
+-- nothing scoping it to the row's owner, so without this guard one profile could be pointed at
+-- another profile's purchase — and 'getShownPurchase' would then hand back the OTHER profile's
+-- private key for the worker to sign @issueBadge@ with. The write is the cheapest place to
+-- enforce it; 'getShownPurchase' enforces it again on read.
+setShownPurchase :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO ()
+setShownPurchase db userId badgePurchaseId = do
+  updated <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          UPDATE users SET shown_badge_id = ?
+          WHERE user_id = ?
+            AND EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_purchase_id = ? AND p.user_id = ?)
+          RETURNING user_id
+        |]
+        (badgePurchaseId, userId, badgePurchaseId, userId)
+  when (null (updated :: [Only UserId])) $ throwError $ notThisUsersPurchase badgePurchaseId userId
 
 purchaseSelectColumns :: Query
 purchaseSelectColumns =
@@ -267,6 +302,13 @@ rowToPurchase ((badgePurchaseId, userId_, purchaseKey, purchasePrivKey_, Binary
 -- | The purchase @users.shown_badge_id@ points at, with its keypair and badge master key —
 -- what the badge screen renders and what the worker signs @issueBadge@ with. 'Nothing' when the
 -- user has no badge, which is the ordinary case.
+--
+-- The join carries @AND p.user_id = u.user_id@: this row is read to obtain a PRIVATE KEY, and
+-- @shown_badge_id@ is a bare foreign key to @badge_purchases@ that the schema does not scope to
+-- the pointing user. A pointer that ever crossed profiles — through a restored database, a
+-- future writer, or a bug in one — would otherwise hand this profile another profile's key to
+-- sign with. It also makes 'rowToPurchase'\'s NULL @user_id@ check reachable rather than
+-- vestigial, since the join now depends on that column.
 getShownPurchase :: DB.Connection -> UserId -> ExceptT StoreError IO (Maybe UserBadgePurchase)
 getShownPurchase db userId = do
   rows <-
@@ -275,7 +317,7 @@ getShownPurchase db userId = do
         db
         ( "SELECT "
             <> purchaseSelectColumns
-            <> " FROM badge_purchases p JOIN users u ON u.shown_badge_id = p.badge_purchase_id WHERE u.user_id = ?"
+            <> " FROM badge_purchases p JOIN users u ON u.shown_badge_id = p.badge_purchase_id AND p.user_id = u.user_id WHERE u.user_id = ?"
         )
         (Only userId)
   liftEither $ mapM rowToPurchase (listToMaybe rows)
@@ -371,7 +413,7 @@ storedEntryType = \case
     SCSupport -> Right CTSupport
     SCOpening -> Right CTOpening
     SCUnknown {tag, json} -> Right CTUnknown {tag, json}
-    SCCharge {} -> unsupported "credit(charge)" "chargeId is Int64 against the charge_id TEXT column; subscriptions are out of scope"
+    SCCharge {} -> unsupported "credit(charge)" "the stored LedgerCreditType.CTCharge types chargeId as Int64 while the wire and the charge_id column are both TEXT; subscriptions are out of scope"
     SCTransferIn {} -> unsupported "credit(transferIn)" "carries a purchase key where from_purchase_id holds a purchase id; transfers are out of scope"
   SEDebit debitType -> LEDebit <$> case debitType of
     SDRefund -> Right DTRefund

tests/Bots/BadgeStoreTests.hs

@@ -76,6 +76,7 @@ badgeStoreTests = do
     it "preserves the statement's array order when every entry shares one createdAt" testEntryOrderFromArrayPosition
     it "re-delivering the same complete statement writes nothing and changes nothing" testStatementRedeliveryIsIdempotent
     it "a statement with no previousEntryId replaces the ledger, dropping entries the service no longer holds" testStatementWithoutCursorReplaces
+    it "a replacement that reorders the entries it re-sends drops the held rows rather than leaving them out of order" testReorderedReplacementDropsHeldRows
     it "appends after previousEntryId without touching the entries already held" testStatementWithCursorAppends
     it "stores an unrecognised entry tag verbatim and hands it back unchanged" testUnknownEntryTypeRoundTrip
     it "refuses a charge credit rather than coercing its id into the charge_id TEXT column" testChargeCreditRefused
@@ -83,6 +84,7 @@ badgeStoreTests = do
     it "createCodePayment and createPurchase leave one issued purchase paid for by a settled code payment" testCodePaymentAndPurchase
     it "supersedePurchases clears the paid slot only, and setShownPurchase points at the new purchase" testSupersedeAndShownBadge
     it "getShownPurchase returns the purchase with its private key intact" testGetShownPurchaseKeepsPrivateKey
+    it "neither shown-badge function will cross profiles, so one user cannot be handed another's private key" testShownPurchaseIsScopedToItsUser
   describe "client badge issuances" $
     it "createIssuance writes one row per period" testIssuancePerPeriod
 
@@ -164,10 +166,13 @@ newCodePurchase st User {userId} badgeType = do
 purchaseId :: UserBadgePurchase -> Int64
 purchaseId UserBadgePurchase {badgePurchaseId} = badgePurchaseId
 
-purchaseStatuses :: DBStore -> IO [(Int64, Text, Text)]
+-- | @(badge_purchase_id, initial_badge_type, current_badge_type, status)@, read from the table
+-- rather than from the record 'createPurchase' returns: both badge-type columns must be asserted
+-- against the DATABASE, or swapping the two arguments that write them would go unnoticed.
+purchaseStatuses :: DBStore -> IO [(Int64, Text, Text, Text)]
 purchaseStatuses st =
   storeIO st $ \db ->
-    DB.query_ db "SELECT badge_purchase_id, current_badge_type, status FROM badge_purchases ORDER BY badge_purchase_id ASC"
+    DB.query_ db "SELECT badge_purchase_id, initial_badge_type, current_badge_type, status FROM badge_purchases ORDER BY badge_purchase_id ASC"
 
 ledgerUuids :: DBStore -> Int64 -> IO [Text]
 ledgerUuids st pId =
@@ -281,6 +286,35 @@ testStatementWithoutCursorReplaces ps = withBadgeStore ps $ \st user -> do
   storeE st $ \db -> insertLedgerEntries db pId (fullStatement []) now
   ledgerUuids st pId `shouldReturn` ["rep-1", "rep-2"]
 
+-- | The REPLACE path keeps rows the statement re-sends, so they hold their local @entry_id@ and
+-- an issuance can reference them -- but that is only safe while the rows it keeps sit in the same
+-- order the statement puts them in. A service that REWROTE its ledger rather than extending it
+-- can re-send the same uuids in a different order, and then keeping them would leave the client
+-- reading a last entry that is not the statement's last entry. The held rows are dropped and
+-- re-inserted instead.
+--
+-- This is the branch behind everything else the step does, and no other example reaches it:
+-- every other REPLACE test starts from an empty ledger, or keeps a genuine prefix, or re-delivers
+-- an identical statement.
+testReorderedReplacementDropsHeldRows :: HasCallStack => TestParams -> IO ()
+testReorderedReplacementDropsHeldRows ps = withBadgeStore ps $ \st user -> do
+  pId <- purchaseId <$> newCodePurchase st user BTSupporter
+  now <- getCurrentTime
+  let entryA = entry "reo-a" 3 3 (SECredit SCPayment {invoiceId = Nothing})
+      entryB = entry "reo-b" (-1) 2 (SEDebit SDBadge)
+      -- same two uuids, opposite order, and the balances swapped with them
+      entryA' = entry "reo-a" (-1) 2 (SEDebit SDBadge)
+      entryB' = entry "reo-b" 3 3 (SECredit SCPayment {invoiceId = Nothing})
+  storeE st $ \db -> insertLedgerEntries db pId (fullStatement [entryA, entryB]) now
+  ledgerUuids st pId `shouldReturn` ["reo-a", "reo-b"]
+  storeE st $ \db -> insertLedgerEntries db pId (fullStatement [entryB', entryA']) now
+  ledgerUuids st pId `shouldReturn` ["reo-b", "reo-a"]
+  -- and the last entry is the statement's last entry, not whichever row happened to survive
+  Just BadgeLedgerEntry {entryUuid, balanceMonths, entryType} <- storeE st (`getLastBadgeLedgerEntry` pId)
+  entryUuid `shouldBe` "reo-a"
+  balanceMonths `shouldBe` 2
+  entryType `shouldBe` LEDebit DTBadge
+
 -- | A present @previousEntryId@ names an entry the client already holds: the entries attach
 -- after it and nothing is removed.
 testStatementWithCursorAppends :: HasCallStack => TestParams -> IO ()
@@ -340,7 +374,7 @@ testCodePaymentAndPurchase ps = withBadgeStore ps $ \st user -> do
   status `shouldBe` PSIssued
   initialBadgeType `shouldBe` BTLegend
   currentBadgeType `shouldBe` BTLegend
-  purchaseStatuses st `shouldReturn` [(pId, "legend", "issued")]
+  purchaseStatuses st `shouldReturn` [(pId, "legend", "legend", "issued")]
   Just pmtId <- pure paymentId
   payments <- storeIO st $ \db -> DB.query db "SELECT provider, status, invoice_id FROM payments WHERE payment_id = ?" (Only pmtId)
   (payments :: [(Text, Text, Maybe Text)]) `shouldBe` [("code", "settled", Nothing)]
@@ -360,21 +394,21 @@ testSupersedeAndShownBadge :: HasCallStack => TestParams -> IO ()
 testSupersedeAndShownBadge ps = withBadgeStore ps $ \st user@User {userId} -> do
   supporterId <- purchaseId <$> newCodePurchase st user BTSupporter
   investorId <- purchaseId <$> newCodePurchase st user BTInvestor
-  storeIO st $ \db -> setShownPurchase db userId supporterId
+  storeE st $ \db -> setShownPurchase db userId supporterId
   legendId <- purchaseId <$> newCodePurchase st user BTLegend
   now <- getCurrentTime
-  storeIO st $ \db -> do
-    supersedePurchases db userId legendId BTLegend now
+  storeE st $ \db -> do
+    supersedePurchases db userId legendId now
     setShownPurchase db userId legendId
   purchaseStatuses st
-    `shouldReturn` [ (supporterId, "supporter", "superseded"),
-                     (investorId, "investor", "issued"),
-                     (legendId, "legend", "issued")
+    `shouldReturn` [ (supporterId, "supporter", "supporter", "superseded"),
+                     (investorId, "investor", "investor", "issued"),
+                     (legendId, "legend", "legend", "issued")
                    ]
   shown <- storeIO st $ \db -> DB.query db "SELECT shown_badge_id FROM users WHERE user_id = ?" (Only userId)
   (shown :: [Only (Maybe Int64)]) `shouldBe` [Only (Just legendId)]
   -- exactly one issued purchase in the paid slot
-  issuedPaid <- filter (\(_, bt, s) -> s == "issued" && badgeSlot (readBadgeType bt) == BSPaid) <$> purchaseStatuses st
+  issuedPaid <- filter (\(_, _, bt, s) -> s == "issued" && badgeSlot (readBadgeType bt) == BSPaid) <$> purchaseStatuses st
   length issuedPaid `shouldBe` 1
   where
     readBadgeType = \case
@@ -388,7 +422,7 @@ testGetShownPurchaseKeepsPrivateKey ps = withBadgeStore ps $ \st user@User {user
   noBadge <- storeE st (`getShownPurchase` userId)
   noBadge `shouldSatisfy` isNothing
   UserBadgePurchase {badgePurchaseId = pId, purchaseKey, purchasePrivKey, masterKey} <- newCodePurchase st user BTSupporter
-  storeIO st $ \db -> setShownPurchase db userId pId
+  storeE st $ \db -> setShownPurchase db userId pId
   Just UserBadgePurchase {badgePurchaseId = shownId, userId = shownUserId, purchaseKey = shownPub, purchasePrivKey = shownPriv, masterKey = shownMk} <-
     storeE st (`getShownPurchase` userId)
   shownId `shouldBe` pId
@@ -397,6 +431,42 @@ testGetShownPurchaseKeepsPrivateKey ps = withBadgeStore ps $ \st user@User {user
   shownPriv `shouldBe` purchasePrivKey
   shownMk `shouldBe` masterKey
 
+-- | @users.shown_badge_id@ is a bare foreign key to @badge_purchases@: nothing in the schema
+-- stops it pointing at a purchase that belongs to a different profile, and the row it reaches
+-- carries a PRIVATE KEY the worker signs @issueBadge@ with. Both ends refuse to cross profiles --
+-- the write outright, and the read even when the pointer is already wrong, which is simulated
+-- here with raw SQL because the writer will no longer produce it.
+testShownPurchaseIsScopedToItsUser :: HasCallStack => TestParams -> IO ()
+testShownPurchaseIsScopedToItsUser ps = withBadgeStore ps $ \st alice -> do
+  bob <- addSecondUser st
+  let User {userId = aliceId} = alice
+      User {userId = bobId} = bob
+  alicePurchase <- purchaseId <$> newCodePurchase st alice BTSupporter
+  bobPurchase <- purchaseId <$> newCodePurchase st bob BTLegend
+  -- bob cannot point his profile at alice's purchase
+  err <- storeErr st $ \db -> setShownPurchase db bobId alicePurchase
+  show err `shouldContain` "does not belong to user"
+  -- ... and his own purchase is fine
+  storeE st $ \db -> setShownPurchase db bobId bobPurchase
+  Just UserBadgePurchase {badgePurchaseId = shownForBob} <- storeE st (`getShownPurchase` bobId)
+  shownForBob `shouldBe` bobPurchase
+  -- a pointer that crossed profiles anyway resolves to nothing, rather than to alice's key
+  storeIO st $ \db -> DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (alicePurchase, bobId)
+  crossed <- storeE st (`getShownPurchase` bobId)
+  crossed `shouldSatisfy` isNothing
+  -- alice still reads her own
+  storeE st $ \db -> setShownPurchase db aliceId alicePurchase
+  Just UserBadgePurchase {badgePurchaseId = shownForAlice} <- storeE st (`getShownPurchase` aliceId)
+  shownForAlice `shouldBe` alicePurchase
+
+addSecondUser :: DBStore -> IO User
+addSecondUser st = do
+  ts <- getCurrentTime
+  Right user <-
+    withTransaction st $ \db ->
+      runExceptT $ createUserRecordAt db (AgentUserId 2) False False bobProfile {preferences = Nothing} False ts
+  pure user
+
 -- Issuances -------------------------------------------------------------------
 
 testIssuancePerPeriod :: HasCallStack => TestParams -> IO ()