diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs index 1e41452f93..7dccdd333a 100644 --- a/apps/simplex-badge-service/src/BadgeService/Catalog.hs +++ b/apps/simplex-badge-service/src/BadgeService/Catalog.hs @@ -18,7 +18,7 @@ where import Data.List (find) import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Word (Word8) +import Data.Word (Word8, Word32, Word64) import Simplex.Chat.Badges (BadgeType (..)) import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..)) import Simplex.Chat.Badges.Types (BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..)) @@ -120,19 +120,35 @@ defaultCatalog createdAt = total = Nothing } --- | The only place a total is computed. 'CurrencyAmount' has no 'Num' instance, so every --- step unwraps to 'Word32', computes, and re-wraps. 'Nothing' means exactly one month --- (there is no unpriced multi-month path: a longer duration is only ever expressed as an --- offer). A 'freeMonths' offer charges for the months that aren't free; an 'ODDiscount' --- offer floors the discounted total, computed over integers so no floating point appears --- anywhere in the pricing path. +-- | The only place a total is computed. 'CurrencyAmount' has no 'Num' instance, so every step +-- unwraps to 'Word32', computes in 'Word64' and re-wraps through 'minorUnits', which refuses a +-- product that no longer fits. 'Nothing' for the offer means exactly one month (there is no +-- unpriced multi-month path: a longer duration is only ever expressed as an offer). A +-- 'freeMonths' offer charges for the months that aren't free; an 'ODDiscount' offer floors the +-- discounted total, computed over integers so no floating point appears anywhere in the pricing +-- path. offerTotal :: BadgePrice -> Maybe BadgeOffer -> Maybe CurrencyAmount offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} Nothing = Just (CurrencyAmount monthPriceMinor) offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} (Just BadgeOffer {months, discount}) = - CurrencyAmount <$> case discount of - ODFreeMonths freeMonths -> (\m -> fromIntegral m * monthPriceMinor) <$> chargeableMonths months freeMonths - ODDiscount percent -> (\pct -> (fromIntegral months * monthPriceMinor * fromIntegral (100 - pct)) `div` 100) <$> discountedPercent percent + fmap CurrencyAmount . minorUnits =<< case discount of + ODFreeMonths freeMonths -> (\m -> fromIntegral m * monthPrice64) <$> chargeableMonths months freeMonths + ODDiscount percent -> (\pct -> (fromIntegral months * monthPrice64 * fromIntegral (100 - pct)) `div` 100) <$> discountedPercent percent + where + monthPrice64 = fromIntegral monthPriceMinor :: Word64 + +-- | Brings a total computed in 'Word64' back into the 'Word32' a 'CurrencyAmount' holds, or +-- refuses. Both arms above multiply a price by a month count, and at 12 months a 'Word32' +-- multiplication wraps above a monthly price of about 35,791 currency units -- a wrapped product +-- is a WRONG CHARGE, which is the one outcome this module must never produce. It is unreachable +-- at any plausible price, exactly like the two subtraction wraps B6 closed by name +-- ('chargeableMonths', 'discountedPercent'), and it is refused for the same reason and in the +-- same way: one malformed or absurd row costs one unpriced offer, never a wrong total. The whole +-- computation stays in integers -- no floating point appears anywhere in the pricing path. +minorUnits :: Word64 -> Maybe Word32 +minorUnits total + | total <= fromIntegral (maxBound :: Word32) = Just (fromIntegral total) + | otherwise = Nothing -- | months - freeMonths, but only once it's known safe: a bare 'Word8' subtraction is -- unsigned and unguarded, so an offer with freeMonths >= months (a typo, a future diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 9a2cb8650f..b1321a99cf 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -995,7 +995,9 @@ handlePurchaseCode bsEnv@BadgeServiceEnv {store, now} signerKey badgeRequest pre let st0 = maybe (initialLedgerState now' badgeType) ledgerStateOf lastEntry pure $ Right (Just row, planLedger now' creditWith (lastEntry >>= entryWasPausedSince) st0) where - creditWith = Just (months, CTPayment paymentUuid) + -- the service always has its payments row to name; the client's copy of this entry + -- carries NULL, which is why the field is a 'Maybe' (plan \'9) + creditWith = Just (months, CTPayment (Just paymentUuid)) writeTxn now' badgeType paymentUuid row_ plan db = do row <- maybe (createPurchase db signerKey (requestMasterKey badgeRequest) badgeType now') pure row_ let pid = rowPurchaseId row @@ -1005,7 +1007,11 @@ handlePurchaseCode bsEnv@BadgeServiceEnv {store, now} signerKey badgeRequest pre -- leaves the purchase's pointer at the first one rather than repointing it when (isNothing (rowPaymentId row)) $ attachPurchasePayment db pid paymentUuid now' writeLedgerPlan db now' pid badgeType plan - -- last, so a code claimed in between rolls back everything above with it + -- the last WRITE, so a code claimed or revoked in between rolls back everything above with + -- it. 'purchaseStatement' runs after it and can append a debit(lapse) of its own, but never + -- here: this transaction has just issued or cached a period, so the state it leaves has + -- balanceStartTs at or past now and 'advance' inside 'healLedger' returns Nothing. That is + -- an argument about this call site, not a property of 'purchaseStatement'. markCodeRedeemed db hash pid now' purchaseStatement now' db Nothing pid diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index 9f652a9b02..cfd15558c6 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -281,12 +281,15 @@ ledgerSelectColumns = -- would persist through (@charge_id@) is @subscription_charges@\' TEXT primary key. Both -- directions reject that constructor explicitly rather than inventing a silent, possibly -- wrong, numeric<->text coercion; subscriptions are out of scope (plan \'6), so nothing writes --- one. @'CTPayment' {paymentId}@ had the same defect and is now 'Text', matching --- @badge_ledger.payment_id TEXT REFERENCES payments@ (B7, plan \'9). +-- one. @'CTPayment' {paymentId}@ had the same defect and is now @'Maybe' 'Text'@, matching +-- @badge_ledger.payment_id TEXT REFERENCES payments@, which is NULLABLE (B7, widened in B10, +-- plan \'9). The service always names its payment row; the CLIENT, copying the same entries into +-- its own ledger, has no payments row for a code redemption and writes NULL -- so both directions +-- here carry the 'Maybe' through rather than requiring an id the client cannot have. encodeLedgerEntryType :: LedgerEntryType -> ExceptT ServiceError IO LedgerTypeRow encodeLedgerEntryType = \case LECredit creditType -> case creditType of - CTPayment {paymentId} -> pure ("credit", Just "payment", Nothing, Just paymentId, Nothing, Nothing, Nothing) + CTPayment {paymentId} -> pure ("credit", Just "payment", Nothing, paymentId, Nothing, Nothing, Nothing) CTCharge {} -> throwError $ SEDecodeError "CTCharge.chargeId (Int64) does not fit the charge_id TEXT column; unresolved type mismatch, see SDD progress log" CTSupport -> pure ("credit", Just "support", Nothing, Nothing, Nothing, Nothing, Nothing) CTTransferIn {fromPurchaseId} -> pure ("credit", Just "transfer_in", Nothing, Nothing, Nothing, fromPurchaseId, Nothing) @@ -303,7 +306,8 @@ encodeLedgerEntryType = \case decodeLedgerEntryType :: LedgerTypeRow -> Either ServiceError LedgerEntryType decodeLedgerEntryType row = case row of - ("credit", Just "payment", _, Just paymentId, _, _, _) -> Right $ LECredit (CTPayment paymentId) + -- payment_id is read whether or not it is there: a NULL is what a client-written entry holds. + ("credit", Just "payment", _, paymentId, _, _, _) -> Right $ LECredit (CTPayment paymentId) ("credit", Just "support", _, _, _, _, _) -> Right $ LECredit CTSupport ("credit", Just "transfer_in", _, _, _, fromPurchaseId, _) -> Right $ LECredit (CTTransferIn fromPurchaseId) ("credit", Just "opening", _, _, _, _, _) -> Right $ LECredit CTOpening @@ -551,16 +555,21 @@ getCodeByHash db codeHash = do code <- liftEither $ rowToCode codeRow pure $ Just (code, redeemerKey) --- | Claims an unredeemed code for a purchase. Guarded by @redeemed_purchase_id IS NULL@ so an --- existing redemption is never overwritten: on no rows affected, a follow-up existence check --- distinguishes an unknown code ('SECodeNotFound') from one already claimed ('SECodeConflict'), --- which the caller answers by re-classifying. +-- | Claims an unredeemed, unrevoked code for a purchase. Guarded by +-- @redeemed_purchase_id IS NULL AND revoked_at IS NULL@ so neither an existing redemption nor a +-- revocation is overwritten: on no rows affected, a follow-up existence check distinguishes an +-- unknown code ('SECodeNotFound') from one already claimed or revoked ('SECodeConflict'), which +-- the caller answers by re-classifying — a revoked code then classifies as 'RedeemRevoked' and is +-- answered @code_invalid@, which is the right answer. -- --- The badge service's own request loop is single-threaded, so two redemptions of one code --- cannot overlap there and this guard is not what makes B7 correct (see --- @BadgeService.Service.redemptionRetries@, which also records the ledger's lack of an --- equivalent). It is kept because it costs nothing and because this row is also written out of --- band, by B8's operator tooling. +-- __The revocation half of the guard is load-bearing, unlike the redemption half.__ B8's +-- @codes revoke@ runs in a SECOND PROCESS against the same database, and this service separates +-- classification from this write by the signing IO — so a revocation issued in that window would +-- otherwise be silently overwritten and the code redeemed anyway. That is the whole point of +-- being able to revoke a code that is being abused. The redemption half cannot fire today (the +-- request loop is single-threaded, see @BadgeService.Service.redemptionRetries@, which also +-- records the ledger's lack of an equivalent guard); it is kept because it costs nothing and +-- because 'unredeemCode' also writes this row out of band. markCodeRedeemed :: DB.Connection -> ByteString -> Int64 -> UTCTime -> ExceptT ServiceError IO () markCodeRedeemed db codeHash badgePurchaseId now = do rows <- @@ -570,7 +579,7 @@ markCodeRedeemed db codeHash badgePurchaseId now = do [sql| UPDATE sx_badge_service_codes SET redeemed_purchase_id = ?, redeemed_at = ? - WHERE code_hash = ? AND redeemed_purchase_id IS NULL + WHERE code_hash = ? AND redeemed_purchase_id IS NULL AND revoked_at IS NULL RETURNING code_hash |] (badgePurchaseId, now, Binary codeHash) diff --git a/plans/badges-codes/2026-08-21-badges-web-checkout.md b/plans/badges-codes/2026-08-21-badges-web-checkout.md index c091768dfd..a633dbba80 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -1342,7 +1342,7 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - `relay_request_execute_at`'s default, which the dump renders in the server's timezone: `'1970-01-01 01:00:00+01'` in the committed file versus `'1970-01-01 00:00:00+00'` here. The same instant; the committed rendering was kept to avoid a spurious flip. - **The Postgres schema-dump spec cannot pass on Linux as written. Pre-existing, unrelated to badges.** Two independent causes, and together they explain why this dump had drifted. First, `tests/PostgresSchemaDump.hs:71` selects `sed -i ''` — BSD/macOS syntax — unless `envCI` is true, and `envCI` is `lookupEnv "CI" == Just "true"` (`tests/ChatTests/Utils.hs:117`). A developer on Linux running locally, without `CI=true`, gets the macOS branch and the spec dies on `sed: can't read /^--/d`. The flag conflates "running in CI" with "has GNU sed". Second, even with `CI=true`, the spec compares a freshly dumped schema against the committed file without stripping `\restrict`/`\unrestrict`, so any patched `pg_dump` fails the comparison non-deterministically. Fixing either is outside this plan; note both before relying on that spec. - **A2 — three more `Int64` id fields need the same correction the step already mandates.** The step lists `BadgePurchase.paymentId`, `BadgePayment.paymentId` and `BadgeIssuance.issuanceId`. An audit of `badges-rpc.schema.json` against all four modules found the same defect in three further places, all `TEXT` columns typed as `Int64`: `StatementCreditType.SCCharge {chargeId}` (`Badges/Service.hs:163`, against `subscription_charges.charge_id TEXT NOT NULL PRIMARY KEY`), and `BadgeCharge.chargeId` and `BadgeCharge.paymentId` (`Badges/Types.hs:163-164`). `SCCharge` is the load-bearing one: it is a wire type whose `taggedObjectJSON` instance A2 writes, the schema declares `chargeId` as `string` (`badges-rpc.schema.json:230`), and Aeson would encode an `Int64` as a JSON number — so leaving it ships a payload that fails its own schema. Its sibling `SCPayment` already carries `Maybe InvoiceId`, a newtype over `Text`. A2 corrects all six. -- **`LedgerCreditType.CTPayment {invoiceId :: Int64}` and `CTCharge {chargeId :: Int64}` are wrong against their columns but are marked `-- confirmed`. `CTPayment` RESOLVED by B7 below; `CTCharge` still OPEN — needs a decision, not a mechanical fix.** `invoices.invoice_id` and `subscription_charges.charge_id` are both `TEXT`. These are the DB-side twins of the wire types above, and `CTTransferIn {fromPurchaseId :: Maybe Int64}` beside them is correct because `from_purchase_id` really is `INTEGER`. A2 does not touch them: they sit outside its tagged-sum list, and altering a type someone marked confirmed is above a mechanical step. C1's `insertLedgerEntries` is the first code that would persist them, so this must be settled before C1. +- **`LedgerCreditType.CTPayment {invoiceId :: Int64}` and `CTCharge {chargeId :: Int64}` are wrong against their columns but are marked `-- confirmed`. `CTPayment` resolved in two steps — B7 made it `Text` (right for the service, wrong for the client), B10 made it `Maybe Text` (right for both), see below; `CTCharge` still OPEN — needs a decision, not a mechanical fix.** `invoices.invoice_id` and `subscription_charges.charge_id` are both `TEXT`. These are the DB-side twins of the wire types above, and `CTTransferIn {fromPurchaseId :: Maybe Int64}` beside them is correct because `from_purchase_id` really is `INTEGER`. A2 does not touch them: they sit outside its tagged-sum list, and altering a type someone marked confirmed is above a mechanical step. C1's `insertLedgerEntries` is the first code that would persist them, so this must be settled before C1. - **A4 — `offerTotal` calls `error` on an impossible offer, which B6 and D4 must not let reach a request thread.** `chargeableMonths` (`BadgeService/Catalog.hs`) rejects `freeMonths >= months` with `error` rather than wrapping a `Word8` subtraction, and `seedCatalog` forces it at startup so a bad catalog kills the process before the service accepts traffic. That fences it for Phase A, where `seedCatalog` is the only writer. It stops being fenced the moment `offerTotal`/`catalogTotals` run inside request handling over rows read from the database, which is B6 (`getBadgeCatalog`) and D4 (`/api/catalog`). The bot's `processQueuedRequests` is a single-threaded `forever` loop (`BadgeService/Service.hs:96-99`), so an uncaught `error` there would take the whole service down for every user rather than failing one request — strictly worse than the mispricing the guard prevents. Before B6, either give `BadgeOffer` a smart constructor so `freeMonths >= months` is unrepresentable, or catch at the request boundary so the blast radius is one response. - **B6 — resolves the A4 `offerTotal`/`error` hazard above with a third option: a typed absence, not either option this plan named.** Neither a smart constructor (would change `BadgeOffer`'s shape and every construction site, including the seeded defaults) nor a request-boundary catch (relies on `runHandler`'s catch-all reaching every caller, including D4's future HTTP path, which does not share that catch-all) was taken. Instead `chargeableMonths :: Word8 -> Word8 -> Maybe Word8` and `offerTotal :: BadgePrice -> Maybe BadgeOffer -> Maybe CurrencyAmount` (`BadgeService/Catalog.hs`): `freeMonths >= months` now answers `Nothing`, which A2 already defines on the wire as "no computed total, render unavailable" — so the blast radius of one bad row is one offer, not one response and not one process, and the fix is shared by every caller of `offerTotal`, present or future, not just ones inside a `catch`. `seedCatalog` still fails the process at startup, by name (`requireTotal`), for a bad *default* catalog, so the Phase A guarantee is unchanged. `handleGetBadgeCatalog` additionally logs (`logUnpricedOffers`) when a *database* row reaches this state, since nothing else would ever say why a live offer reads as unavailable. **Fix round 1** found the same hazard on `ODDiscount`'s sibling arm, which the original pass missed: `100 - percent` on a bare `Word8` wraps for `percent > 100` (a `Store.decodeDiscount` value is not range-checked on the way in), producing a 2.55x *overcharge* rather than a crash — worse than the `freeMonths` case, since it inflates the price instead of merely reading as unavailable. `discountedPercent :: Word8 -> Maybe Word8` closes it the same way, `percent > 100 -> Nothing`. - **B6 fix round 1 — `seedCatalog`'s `requireTotal` is stricter than the `forceTotal` it replaced: an unpinned offer's `total = Nothing` is now also rejected at startup, not just an unchargeable one.** The predecessor (`forceTotal`, pre-B6) accepted `total = Nothing` unconditionally — its Haddock read "an offer whose price isn't found... gets `total = Nothing` rather than a crash, same as an unpinned offer" — because at the time nothing distinguished "unpinned" from "not chargeable" and neither was thought worth failing startup over. B6's `requireTotal` rejects `total = Nothing` for either reason: correct for today's `defaultCatalog` (every seeded offer is pinned, so only "not chargeable" is reachable), but a real behaviour change per §4 rule 6 — a future unpinned *default* offer would now fail the service at startup rather than silently seed with no total. Recorded rather than re-litigated, since the stricter behaviour is the one actually wanted (an unpinned default offer is exactly the kind of bad row `seedCatalog` should catch by name, not seed silently). @@ -1363,7 +1363,7 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **B7 — `purchaseBadge` carrying an `upgrade` is `bad_request`, before the payment is looked at.** `BSCPurchaseBadge.upgrade` is the store one-time upgrade (RPC "Upgrades"), which needs store evidence, and tier upgrades are out of scope (§6). Ignoring the field would consume the code while silently dropping what the client asked for. - **B7 — `issueBadge` honours the asserted cursor, closing B6's "`previousEntryId` cannot be populated" gap.** `issueBadge` is the only implemented command carrying `balance.lastEntry.entryId`. A new store function, `getLedgerEntryIdByUuid`, resolves that wire uuid to the local `entry_id`, scoped to the purchase so an asserted uuid cannot probe another purchase's ledger; `purchaseStatement` now takes a `Maybe StatementCursor` carrying both halves, so `previousEntryId` always echoes the value the client actually sent and is never spelled independently of the id the query runs on. An assertion naming nothing yields the complete history, which is the RPC's other permitted answer; its third — one `opening` credit restating the balance — needs opening entries, which nothing in this milestone writes. `purchaseStatement` also takes the `badge_purchase_id` rather than the whole `BadgePurchaseRow`, since the replay path has only the id. `getBadgeCatalog` and `purchaseBadge` carry no cursor and pass `Nothing`. - **B7 — the same-key replay path does heal the ledger, which step 2's "writes nothing" reads as forbidding.** "Writes nothing" is kept for everything the redemption would record — no second purchase, payment, credit, debit, issuance or redemption — but the statement is still read through `purchaseStatement`, which appends one `debit(lapse)` when months have genuinely lapsed since. The RPC has the service heal its own ledger before answering any statement ("Statement and balance"), B6's read-only `getBadgeCatalog` already does exactly this, and the alternative is telling the client a balance the database does not hold. A replay immediately after a timeout — the case §Idempotency is about — lapses nothing and so writes nothing. -- **B7 — two transactions per command, not one.** "One transaction per command" is kept for *writing*: the classification and the plan are read in a transaction that writes nothing, signing happens with no transaction open (which the step requires), and one further transaction does every write and reads the statement back inside it. `IssueCached` adds a third, read-only, to fetch the cached credential. A command with nothing to write opens exactly one, and writes nothing in it. +- **B7 — three transactions per successful `purchaseBadge{code}`, not one (this entry said "two" until B10 counted them).** "One transaction per command" is kept for *writing*, which is the invariant that matters, but the count is three: `classifyRedemption`'s `lookupCode` opens one read transaction, `planTxn` opens a second, and after signing (with none open, which the step requires) `writeTxn` opens the third, which does every write and reads the statement back inside it. `IssueCached` adds a fourth, read-only, to fetch the cached credential. A command with nothing to write still opens one and writes nothing in it. The behaviour is right; only the arithmetic in this entry was wrong. - **B7 — an existing B5 test's expected code changed.** `testBadgeServicePurchaseBadgeUnknownKeyIsNotUnknownPurchaseKey` asserted `internal` because `purchaseBadge` was unimplemented; `"UNKNOWN-CODE"` now reaches the classifier, normalizes to 11 characters and fails the check character, so it is `code_invalid`. Its load-bearing assertion — never `unknown_purchase_key` — is unchanged. B10 replaces the surrounding suite. - **A1 — `chat_lint.sql` gains 5 fkey-index advisories, left unfixed by design.** The badge migration introduces unindexed foreign keys: `badge_invoices.offer_id`, `badge_invoices.price_id`, `badge_offers.price_id`, `badge_issuances.entry_id`, `users.shown_badge_id`. The lint output is committed literally rather than adding indexes, since index design is outside A1's scope and the repo has precedent for this (`9e000d6bc`). The first three point at rarely-mutated reference tables. The last two are the ones likely to matter under load — `badge_issuances.entry_id` for issuance lookup by ledger entry, and `users.shown_badge_id` for per-user badge display (C1's `getShownPurchase`). Decide on indexes for those two before release. - **B9 — the step's Verify line said "Manual"; an automated test was added instead, and a genuinely standalone manual run (two separate OS processes, hand-typed `/c`) could not be completed in this environment.** A real two-process run needs a live SMP server: this sandbox has no network egress (a direct connection to a public relay times out), and building `simplexmq`'s own `smp-server` executable from the checked-out dependency source fails independently of this step — `apps/common/Web/Embedded.hs`'s `embedDir "apps/common/Web/static/.well-known/"` Template Haskell splice reports the directory missing at compile time even though it is present on disk in the checkout, an environment-specific defect unrelated to the badge service. In its place, `testBadgeServicePublishesAddressFile` calls the real, unmodified `badgeService` entry point (not a stand-in) twice via the existing harness's `withBadgeServiceConfig`/`runBadgeService`, against the harness's own local in-memory SMP server, and adds a real second client issuing `/c` against the file's own contents — proving both halves of the original Verify line (same address across two starts; the file's link is accepted, not rejected as malformed) end to end, just not via two hand-launched OS processes. `initializeBotAddress'`'s `doAutoAccept = False` for the badge service means the client-side assertion stops at "connection request sent!" rather than a full connection, which is as far as `/c` accepting the address goes for this bot. Whoever next has real network access in this environment should still do one standalone two-process run before H5 documents the operator procedure, to catch anything this substitution cannot (e.g. a real terminal's stdout formatting of the printed address). @@ -1380,6 +1380,16 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **B10 — what the §3 Linkage guard does and does not cover, in full.** It enumerates every table in the service database and flags one as holding an order (purchase) reference if it declares a foreign key to `@web_orders` (`@badge_purchases`) **or names a column after it** — `web_order_id TEXT` with no `REFERENCES` clause is invisible to `pragma_foreign_key_list`, and D0, the next step, is what adds order tables. Three anti-vacuity controls: both tables are seen by name, `@codes`'s real declared foreign key to `@badge_purchases` is seen, and a probe table carrying both columns with **no** foreign keys is created, caught and dropped before the real scan. Residual limits, all disclosed: **(a)** it is SQLite-only (`#if !defined(dbPostgres)`), and `Store/Postgres/Migrations.hs` is a separately hand-maintained file, so a linkage column added *only* there is invisible to this guard forever — a twin over `information_schema.table_constraints`/`key_column_usage` is the fix, and it is a follow-up, not done here; **(b)** the name half matches substrings, so an innocent `sort_order` column would raise a false alarm — deliberate, since the cost is one reader's minute against the privacy claim the whole web checkout rests on; **(c)** it sees only *columns*, so a join built some other way (a view, a lookup table keyed by a hash of both, an out-of-band file) passes. B8's no-plaintext-at-rest scan is guarded for the same file-reading reason and now carries a positive control (the batch label, which IS stored in the clear, must be found in the same bytes), so it can no longer pass because it read the wrong or an empty file. - **B10 — B8's `codes` assertions run through `runAdminCmd` with stdout captured, and inspect the database only through `codes status`.** `runAdminCmd` opens its own store and creates a chat database with no user profile, which the test harness's `withTestChat` reopen cannot read (it requires an active user) — so the row-level checks are made by asking the tool itself: each of the ten printed codes resolves to an unredeemed row, and `codes revoke` reports exactly ten in the batch. The plaintext-at-rest check reads the SQLite file directly and is `#if !defined(dbPostgres)`-guarded, as is the §3 Linkage schema assertion. +- **B10 — `CTPayment` is now `{paymentId :: Maybe Text}`, and the "RESOLVED by B7" line above was misleading.** B7's ruling (`Text`) was right for the service and wrong for the client, which is the half that had not been checked. The wire carries no payment id at all — the statement's `SCPayment` carries the *invoice's* id, and a code payment has no invoice — and the client has **no `@payments` row** for a code redemption: that row is written by `createCodePayment` in the service database only. So C1, copying the service's ledger entries into the client's `badge_ledger`, must write `payment_id` as NULL, which `Text` cannot hold and which `decodeLedgerEntryType`'s `Just paymentId` pattern rejected outright — C1 would have hit this on its first write. The field is now `Maybe Text`, `encodeLedgerEntryType` passes it straight into the nullable column, `decodeLedgerEntryType` accepts a NULL on a `credit/payment` row, and the service write site says `Just paymentUuid`. **C1 writes `Nothing` and must not invent an id.** +- **B10 — the unlinkability claim has a two-hop join that the schema guard structurally cannot see, and it is now asserted directly.** `web_orders.invoice_id → @invoices ← payments.invoice_id`, then `payments.payment_id ← badge_purchases.payment_id`, is a complete order→purchase join. Nothing in the schema prevents it: it is empty only because `createCodePayment` hardcodes `invoice_id = NULL` for a code payment (`Store.hs`). `testBadgeServiceNoTableLinksOrdersToPurchases` now plants a settled web order, its invoice, a code payment and a purchase, asserts the join returns **0**, and — as a positive control — that setting `payments.invoice_id` to that order's invoice makes it return 1. **D0 and E3: setting `payments.invoice_id` to a web order's invoice breaks §7's unlinkability claim outright.** The same shape exists through `@badge_invoices` (`invoice_id` + `badge_purchase_id` in one row); nothing in this milestone writes that table, and whoever first does must not point it at a web order's invoice. +- **B10 — `markCodeRedeemed` now also guards on `revoked_at IS NULL`, and this one is load-bearing today.** The redemption half of the guard cannot fire while dispatch is single-threaded, but B8's `codes revoke` runs in a **second process** against the same database, and the service separates classification from the write by the signing IO — so a revocation issued in that window was silently overwritten and the code redeemed anyway, defeating the point of revoking a code that is being abused. With the guard, that write returns `SECodeConflict`, the existing one-retry path re-classifies, and the answer is `RedeemRevoked` → `code_invalid`. Store-level test added (`testBadgeStoreMarkCodeRedeemedRefusesRevoked`): the refusal also leaves the row untouched. Fixed in B10 rather than deferred to H2. +- **B10 — `offerTotal`'s multiplication is computed in `Word64` and range-checked back to `Word32`.** Both arms multiply a monthly price by a month count, and at 12 months a `Word32` product wraps above a monthly price of about 35,791 currency units. Unreachable at any plausible price — and so were the two *subtraction* wraps B6 closed by name, on exactly the principle that applies here: one malformed or absurd row must cost one unpriced offer, never a wrong charge. `minorUnits` refuses instead of wrapping, `Catalog.hs` remains the only place a total is computed, and no floating point enters the pricing path. +- **B10 — `badgeRequest.masterKey` is never checked against `badge_purchases.master_key`, and the concrete consequence is a recovery-flow bug for C3.** `createPurchase` stores the master key of the FIRST redemption and nothing revisits it. A second code redeemed under the same purchase key with a *rotated* master key takes the `IssueCached` path, which returns the stored issuance's credential — bound to the **old** master key, which the client cannot use, with no error anywhere. Every path that signs afresh signs the key that was sent, so the two disagree silently. C3/C4 either keep the master key stable per purchase key or the service must refuse a changed one; this is not decided anywhere yet. +- **B10 — `wasPausedSince` is copied from the last stored entry onto every row a plan appends, including a healed `debit(lapse)`.** Harmless while pausing is out of scope (nothing ever sets it), and wrong the moment pausing lands: a healed row would carry a stale pause marker. `writeLedgerPlan` and `healLedger` must be fixed **together** — they are one writer today precisely so this cannot drift, and whoever implements pause owns both. +- **B10 — a signed RPC from an unknown purchase key is unthrottled and costs a database round trip.** `checkSignerRecord` runs `getPurchaseByKey` before any bucket is consulted, and §5 rules H1's per-IP limits inapplicable to the RPC path — so nothing is scheduled to close this. Availability only: the answer is `unknown_purchase_key` and leaks nothing, but a minted keypair buys an unbounded number of indexed lookups. **For H1**, and it needs a decision, since the per-signer bucket cannot bound a key that has never failed anything. +- **B10 — B9's address file can go stale after all, in the one case its §9 entry does not cover.** That entry documents three *write* failure modes; this is a *read* failure. If `ShowMyAddress` fails transiently at startup, `publishServiceAddress` logs and returns without touching the file, so the previous contents survive — which is exactly the "never silently stale" property the entry claims. Rare and non-fatal (the address is also on stdout), but the claim is stated unconditionally. **For H5**, when the operator procedure is documented. +- **B10 — §7's unlinkability does not hold against a TIMING adversary, and that is a disclosed limit, not a bug.** `codes.created_at` for a web order is within seconds of that order's `web_orders.settled_at`, and its `batch` is the literal `'web'`, so an adversary with the service database can correlate an order to the code row it produced — and thence, once redeemed, to `redeemed_purchase_id` — **with no `codeSecret` needed**. The cryptographic claim (an order id cannot be turned into a code without the secret) is unaffected; the correlational one is what breaks. Mitigations belong to E3/H5: coarsen `codes.created_at`, or drop the `'web'` batch label, or both. §7 should say "no *stored reference* links an order to a purchase" rather than claiming unlinkability outright. + ## 10. End-to-end verification After F5: @@ -1451,7 +1461,7 @@ curl -X POST localhost:9000/_settle/ # delivers a signed webhook Invariants that must hold: -- the client's `badge_ledger` rows are identical to the service's for the same purchase +- for the same purchase, the client's and the service's `badge_ledger` rows agree on `entry_uuid`, `change_months`, `balance_months`, `balance_start_ts`, `balance_badge_type` and the entry type — **not** on every column: `entry_id` is a per-database IDENTITY that means nothing across databases, and `payment_id` is a service-minted UUID on the service side and NULL on the client's, which has no `@payments` row for a code redemption (B10, §9). Comparing whole rows will fail; compare those six columns. - re-sending the same `purchaseBadge` writes nothing and returns the same credential - the same code from a second purchase key returns `code_used` - a replayed webhook creates no second code, and an unprocessed one is reprocessed diff --git a/src/Simplex/Chat/Badges/Types.hs b/src/Simplex/Chat/Badges/Types.hs index 1653095392..913007bebc 100644 --- a/src/Simplex/Chat/Badges/Types.hs +++ b/src/Simplex/Chat/Badges/Types.hs @@ -83,7 +83,15 @@ data LedgerCreditType = -- | badge_ledger.payment_id TEXT REFERENCES payments -- the payment's own id, not the -- invoice's: a code payment has no invoice at all, and an invoice-funded payment reaches -- its invoice through payments.invoice_id. - CTPayment {paymentId :: Text} + -- + -- 'Maybe' because the SERVICE and the CLIENT hold different halves of the same ledger. The + -- service mints the payment row and names it here; the client copies the same entries into + -- its own badge_ledger and has no payments row at all for a code redemption -- that row + -- exists only in the service database, and the wire carries no payment id (the statement's + -- SCPayment carries the INVOICE's id, which a code payment does not have). So the client + -- writes NULL, and this field must be able to hold it. It was 'Text' between B7 and B10, + -- which would have blocked C1 on its first write (plan §9). + CTPayment {paymentId :: Maybe Text} | CTCharge {chargeId :: Int64} | CTSupport | CTTransferIn {fromPurchaseId :: Maybe Int64} diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 03e9661c96..bd41ff184f 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -159,6 +159,7 @@ badgeServiceTests = do it "should fill total for every seeded offer" testBadgeCatalogTotalsFillsSeededOffers it "should reject an offer with freeMonths >= months instead of wrapping" testBadgeCatalogOfferTotalRejectsBadFreeMonths it "should reject an offer with discount > 100 instead of wrapping into an overcharge" testBadgeCatalogOfferTotalRejectsBadDiscount + it "should reject a total that overflows Word32 instead of wrapping into a wrong charge" testBadgeCatalogOfferTotalRejectsOverflow it "should encode BadgeItemStatus on the wire as active/deprecated/disabled" testBadgeItemStatusJsonWireFormat it "should fail to start on a missing config file, naming the file" testBadgeServiceConfigMissingFile it "should fail to start on an unparsable value, naming the key" testBadgeServiceConfigUnparsableValue @@ -178,6 +179,7 @@ badgeServiceTests = do it "should create a purchase and append ledger entries readable back in order" testBadgeStorePurchaseAndLedger it "should disable a price out of the active catalog while both stay reachable by id" testBadgeStoreSetPriceStatusDisabled it "should return the redeeming purchase key from getCodeByHash" testBadgeStoreGetCodeByHashRedeemer + it "should refuse to redeem a revoked code, leaving the row untouched" testBadgeStoreMarkCodeRedeemedRefusesRevoked it "should clear both redemption columns and set unredeemed_at" testBadgeStoreUnredeemCode it "should redeem a valid code into a verifiable credential, with a credit(payment) then debit(badge) ledger" testBadgeServiceRedeemCodeIssuesCredential it "should return the same credential and write no new row when the identical request is repeated" testBadgeServiceRedeemCodeIdempotent @@ -735,6 +737,34 @@ testBadgeCatalogOfferTotalRejectsBadDiscount _ps = do } offerTotal price (Just badOffer) `shouldBe` Nothing +-- The third wrap in this money-computing module, after the two subtractions above: both arms of +-- offerTotal multiply a price by a month count, and a Word32 product wraps at 12 months above a +-- monthly price of ~35,791 currency units. A wrapped product is a WRONG CHARGE -- worse than the +-- freeMonths wrap, which only reads as unavailable -- so the intermediate is Word64 and the +-- result is range-checked back into the Word32 a CurrencyAmount holds. Unreachable at any +-- plausible price, and refused rather than trusted, exactly like its two siblings. +testBadgeCatalogOfferTotalRejectsOverflow :: HasCallStack => TestParams -> IO () +testBadgeCatalogOfferTotalRejectsOverflow _ps = do + now <- getCurrentTime + let BadgeCatalog {prices} = defaultCatalog now + price@BadgePrice {priceId} = fromJust $ find (\BadgePrice {badgeType} -> badgeType == BTSupporter) prices + absurdPrice = price {monthPrice = CurrencyAmount (maxBound :: Word32)} + offerWith discount = + BadgeOffer + { offerId = BadgeOfferId "test-overflow-offer", + priceId = Just priceId, + months = 12, + discount, + status = BISActive, + createdAt = now, + total = Nothing + } + -- 12 * maxBound overflows both ways round + offerTotal absurdPrice (Just (offerWith (ODDiscount 0))) `shouldBe` Nothing + offerTotal absurdPrice (Just (offerWith (ODFreeMonths 1))) `shouldBe` Nothing + -- but the same absurd price for exactly one month still fits, and is still priced + offerTotal absurdPrice Nothing `shouldBe` Just (CurrencyAmount maxBound) + -- BadgeItemStatus's JSON crosses the wire (BadgePrice/BadgeOffer.status), so pinning finding -- 2's TextEncoding-derived encoding to what the earlier TH-derived instance produced proves -- the change is invisible on the wire, not just asserted to be. @@ -1970,6 +2000,32 @@ testBadgeServiceNoTableLinksOrdersToPurchases ps = references <- forM tableNames refsOf map refTable (filter holdsOrderRef references) `shouldBe` ["sx_badge_service_web_orders"] map refTable (filter (\refs -> holdsOrderRef refs && holdsPurchaseRef refs) references) `shouldBe` [] + -- The column scan above is per-table and cannot see a join built out of two hops. This one + -- exists and is complete: @web_orders.invoice_id -> @invoices <- @payments.invoice_id, then + -- @payments.payment_id <- @badge_purchases.payment_id. It is empty only because + -- 'createCodePayment' hardcodes invoice_id NULL for a code payment -- nothing in the schema + -- enforces that, so it is asserted here, over rows shaped exactly as a settled web order and + -- a code redemption leave them. + withConnection st $ \db -> do + DB.execute_ db "INSERT INTO sx_badge_service_invoices (invoice_id, provider, price, amount, currency, expires_at, status, created_at, updated_at) VALUES ('b10-invoice','btcpay',1000,1000,'USD','2026-03-10','paid','2026-03-10','2026-03-10')" + DB.execute_ db "INSERT INTO sx_badge_service_web_orders (order_id, invoice_id, method, short_ref, badge_type, months, status, created_at, updated_at) VALUES ('b10-order','b10-invoice','btc','B10RF','supporter',3,'paid','2026-03-10','2026-03-10')" + DB.execute_ db "INSERT INTO sx_badge_service_payments (payment_id, invoice_id, provider, status, created_at, updated_at) VALUES ('b10-payment', NULL, 'code', 'settled', '2026-03-10', '2026-03-10')" + DB.execute_ db "INSERT INTO sx_badge_service_badge_purchases (purchase_key, master_key, initial_badge_type, current_badge_type, payment_id, status, created_at, updated_at) VALUES (x'0102', x'0304', 'supporter', 'supporter', 'b10-payment', 'issued', '2026-03-10', '2026-03-10')" + -- one long line each: this module is compiled with CPP, which eats a backslash-newline string + -- gap as a line continuation before GHC ever lexes the literal + let joinedOrdersToPurchases = do + [Only n] <- + withConnection st $ \db -> + DB.query_ db "SELECT count(*) FROM sx_badge_service_web_orders o JOIN sx_badge_service_payments p ON p.invoice_id = o.invoice_id JOIN sx_badge_service_badge_purchases bp ON bp.payment_id = p.payment_id" + pure (n :: Int) + -- positive control: the join is written correctly and DOES resolve an order to a purchase the + -- moment a payment carries the order's invoice. Without this, "0 rows" could mean a typo. + withConnection st $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET invoice_id = 'b10-invoice'" + joinedOrdersToPurchases `shouldReturn` 1 + withConnection st $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET invoice_id = NULL" + -- and with the payment shaped as this milestone writes it, there is no path from the order to + -- the purchase at all (docs/protocol/badges-web.md §7) + joinedOrdersToPurchases `shouldReturn` 0 #endif -- B8's Verify line, formally owed by B10: @codes issue@ mints the requested number of codes, @@ -2171,6 +2227,34 @@ testBadgeStoreGetCodeByHashRedeemer ps = redeemer `shouldBe` Just purchaseKey Nothing -> expectationFailure "code should exist after redemption" +-- markCodeRedeemed refuses a REVOKED code, not only an already-redeemed one. B8's `codes revoke` +-- runs in a second process against the same database, and the service separates classification +-- from this write by the signing IO, so a revocation issued in that window must not be silently +-- overwritten -- which is the whole point of being able to revoke a code that is being abused. +-- SECodeConflict is what the handler re-classifies on, and a revoked code then answers +-- code_invalid. +testBadgeStoreMarkCodeRedeemedRefusesRevoked :: HasCallStack => TestParams -> IO () +testBadgeStoreMarkCodeRedeemedRefusesRevoked ps = + withFreshBadgeStore ps $ \st -> do + (purchaseKey, _) <- mkTestKeyPair + masterKey <- BadgeMasterKey <$> getRandomBytes 32 + now <- getCurrentTime + BadgePurchaseRow {badgePurchaseId} <- + expectRight $ withServiceTransaction st $ \db -> createPurchase db purchaseKey masterKey BTSupporter now + codeHash <- getRandomBytes 32 + let newCode = NewBadgeCode {codeHash, badgeType = BTSupporter, months = 3, batch = "test-batch", expiresAt = addUTCTime (30 * nominalDay) now} + _ <- expectRight $ withServiceTransaction st $ \db -> insertCodes db [newCode] now + _ <- expectRight $ withServiceTransaction st $ \db -> revokeCode db codeHash now + conflicted <- withServiceTransaction st $ \db -> markCodeRedeemed db codeHash badgePurchaseId now + conflicted `shouldBe` Left SECodeConflict + -- and the refusal left the row alone: still revoked, still unredeemed + Just (BadgeCode {redeemedPurchaseId, redeemedAt, revokedAt}, redeemer) <- + expectRight $ withServiceTransaction st $ \db -> getCodeByHash db codeHash + redeemedPurchaseId `shouldBe` Nothing + redeemedAt `shouldBe` Nothing + isJust revokedAt `shouldBe` True + redeemer `shouldBe` Nothing + -- unredeemCode clears redeemed_purchase_id and redeemed_at and sets unredeemed_at, re-opening -- the code for another redemption. testBadgeStoreUnredeemCode :: HasCallStack => TestParams -> IO ()