From 05d4724d41abc5dfad2eae559394717cf5bbc887 Mon Sep 17 00:00:00 2001 From: shum Date: Tue, 25 Aug 2026 13:10:23 +0000 Subject: [PATCH] core: fix badge catalog overcharge and double-fetch --- .../src/BadgeService/Catalog.hs | 39 ++++-- .../src/BadgeService/Config.hs | 3 +- .../src/BadgeService/Service.hs | 118 +++++++++++------- .../2026-08-21-badges-web-checkout.md | 4 +- tests/Bots/BadgeServiceTests.hs | 30 ++++- 5 files changed, 133 insertions(+), 61 deletions(-) diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs index cba91fa662..1e41452f93 100644 --- a/apps/simplex-badge-service/src/BadgeService/Catalog.hs +++ b/apps/simplex-badge-service/src/BadgeService/Catalog.hs @@ -15,8 +15,6 @@ module BadgeService.Catalog ) where -import Control.Exception (evaluate) -import Control.Monad (void) import Data.List (find) import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) @@ -134,7 +132,7 @@ offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} Nothing = offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} (Just BadgeOffer {months, discount}) = CurrencyAmount <$> case discount of ODFreeMonths freeMonths -> (\m -> fromIntegral m * monthPriceMinor) <$> chargeableMonths months freeMonths - ODDiscount percent -> Just ((fromIntegral months * monthPriceMinor * fromIntegral (100 - percent)) `div` 100) + ODDiscount percent -> (\pct -> (fromIntegral months * monthPriceMinor * fromIntegral (100 - pct)) `div` 100) <$> discountedPercent percent -- | 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 @@ -155,6 +153,21 @@ chargeableMonths months freeMonths | freeMonths >= months = Nothing | otherwise = Just (months - freeMonths) +-- | @100 - percent@, but only once it's known safe: the sibling of 'chargeableMonths', same +-- hazard. A bare 'Word8' subtraction is unsigned and unguarded, so an offer with @percent > +-- 100@ (a typo, a future repricing) would wrap (@100 - 101 :: Word8 == 255@) and this +-- money-computing module would hand out a 2.55x overcharge instead of a crash or a refusal — +-- worse than 'chargeableMonths'' hazard, since a wrap on the discount side inflates the +-- price rather than reading as merely "unavailable". 'Store.decodeDiscount' does not range- +-- check @percent@ on the way in, so a malformed row can reach this. @percent > 100@ isn't a +-- value to compute a (wrong) discount for at all, so this answers 'Nothing' the same way +-- 'chargeableMonths' does, for the same reason (§9): one bad row must cost one unpriced +-- offer, never a request thread and never a wrong charge. +discountedPercent :: Word8 -> Maybe Word8 +discountedPercent percent + | percent > 100 = Nothing + | otherwise = Just percent + -- | Fills every offer's 'total' (A2) with 'offerTotal' applied to that offer's pinned -- price. Overwrites unconditionally, so it is idempotent to call again. It is a total -- function: an offer whose price isn't found in the given catalog (which shouldn't happen, @@ -188,17 +201,21 @@ seedCatalog st = do mapM_ (insertPrice db) prices mapM_ (insertOffer db) offers where - -- Every seeded offer is pinned to a price (see 'defaultCatalog'), so a 'Nothing' total - -- here cannot mean "unpinned" -- it can only mean the offer is not chargeable at all - -- (freeMonths >= months). 'chargeableMonths' no longer says so with 'error', because a - -- request thread must not die of it (§9), so startup has to make the check itself or - -- nothing would: a bad default catalog would seed silently and every client would see - -- that offer as unavailable forever. + -- Rejects 'total = Nothing' unconditionally, whatever the reason: not chargeable + -- (freeMonths >= months, discount > 100) or genuinely unpinned. Every seeded offer is + -- pinned to a price today (see 'defaultCatalog'), so only the first reason is reachable + -- right now -- but this is stricter than the predecessor this replaced, which accepted + -- an unpinned offer's 'Nothing' unconditionally (§9: a real behaviour change, recorded + -- there since a future unpinned *default* offer would now fail startup rather than seed + -- with no total). 'chargeableMonths'/'discountedPercent' no longer say "impossible offer" + -- with 'error', because a request thread must not die of it (§9), so startup has to make + -- the check itself or nothing would: a bad default catalog would seed silently and every + -- client would see that offer as unavailable forever. requireTotal BadgeOffer {offerId = BadgeOfferId oid, total = Nothing} = ioError . userError $ "seedCatalog: offer " <> T.unpack oid - <> " has no chargeable total (freeMonths >= months, or no pinned price)" - requireTotal BadgeOffer {total = Just (CurrencyAmount amount)} = void $ evaluate amount + <> " has no chargeable total (freeMonths >= months, discount > 100, or no pinned price)" + requireTotal BadgeOffer {total = Just _} = pure () insertPrice :: DB.Connection -> BadgePrice -> IO () insertPrice db BadgePrice {priceId = BadgePriceId pid, badgeType, monthPrice = CurrencyAmount amt, currency, status, createdAt} = diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index 103285222e..309648b3e5 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -568,7 +568,8 @@ data BadgeServiceEnv = BadgeServiceEnv -- control against a distributed guesser -- see 'signerFailureBucket''s Haddock. globalFailureBucket :: TVar TokenBucket, -- | B5 decision 5: bounds unsigned 'getBadgeCatalog' (no signer to key on), 600/hour, - -- burst 600, service-wide. Unused until B6 wires 'getBadgeCatalog' itself. + -- burst 600, service-wide. Spent by 'BadgeService.Service.handleGetBadgeCatalog' (B6) via + -- 'takeCatalogBucket', on every unsigned request. catalogBucket :: TVar TokenBucket } diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index cc0da04689..c24c512262 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -195,11 +195,16 @@ handleServiceRequest bsEnv cc User {userId} reqId signerKey reqData = do -- (encoding it and demanding the whole encoded length) before returning, all still inside the -- 'catch' below. Laziness would otherwise let an exception escape uncaught: 'action' finishing -- and returning a lazily-built 'BadgeServiceResponse' does not itself throw, even if a field --- deep inside is an unevaluated 'error' thunk (as 'BadgeService.Catalog.chargeableMonths' --- produces for a malformed offer, once B6\/B7 wire catalog totals into request handling) -- --- that thunk would only be forced later, by 'sendChatCmd''s own JSON encoding, OUTSIDE this --- function, where nothing would catch it. Forcing the encoding here, inside the 'catch', --- is what makes this a genuine catch-all rather than one that only covers IO exceptions. +-- deep inside is an unevaluated 'error' thunk -- that thunk would only be forced later, by +-- 'sendChatCmd''s own JSON encoding, OUTSIDE this function, where nothing would catch it. +-- Forcing the encoding here, inside the 'catch', is what makes this a genuine catch-all +-- rather than one that only covers IO exceptions. Nothing in the currently implemented +-- commands is known to build such a thunk -- B6 closed the one concrete hazard this used to +-- cite by name, 'BadgeService.Catalog.chargeableMonths', which now returns 'Maybe' instead of +-- calling 'error' -- so this guards against a partial function in some future response field, +-- not a specific one today; 'testBadgeServiceCatchAllContainsPureException' proves the +-- mechanism directly against a constructed thunk, since no real one currently exists to test +-- against. -- -- 'processQueuedRequests' is a single-threaded 'forever' loop: an exception that got out of -- here would kill the service for every user, not just fail the one request that caused it. @@ -246,45 +251,52 @@ dispatchRequest bsEnv signerKey reqData = | otherwise -> checkSignerRecord bsEnv request purchaseKey >>= \case Left err -> pure $ errorResponse err Nothing Nothing - Right () -> dispatchCommand bsEnv purchaseKey request + Right purchaseRow -> dispatchCommand bsEnv purchaseKey purchaseRow request decodeRequest :: J.Object -> Either String BadgeServiceRequest decodeRequest = JT.parseEither J.parseJSON . J.Object --- | The signer\/record precondition, applied to every command before dispatch: --- * 'getBadgeCatalog' may be unsigned (no key at all); nothing further is required of it. +-- | The signer\/record precondition, applied to every command before dispatch. Returns the +-- looked-up row on success ('Nothing' when none was required), so a handler that needs it +-- (B6's 'handleGetBadgeCatalog'; B7's future 'issueBadge') reads it once here rather than +-- looking it up again itself in a second transaction: +-- * 'getBadgeCatalog' may be unsigned (no key at all); nothing further is required of it, +-- and there is no row to return. -- * 'purchaseBadge' requires a signature but NOT a pre-existing record -- an unknown key is -- the normal first-purchase case, because B7 is what creates the purchase row. Getting --- this inverted would make first purchases impossible. +-- this inverted would make first purchases impossible. No row is looked up, so none is +-- returned even though the request is signed. -- * every other command, including a *signed* 'getBadgeCatalog', requires both a signature -- and an existing purchase row: no key at all is 'bad_request' (nothing was signed), an --- unknown key is 'unknown_purchase_key'. -checkSignerRecord :: BadgeServiceEnv -> BadgeServiceCommand -> Maybe C.PublicKeyEd25519 -> IO (Either BadgeServiceErrorCode ()) -checkSignerRecord _ BSCGetBadgeCatalog Nothing = pure $ Right () +-- unknown key is 'unknown_purchase_key'; found, the row is returned. +checkSignerRecord :: BadgeServiceEnv -> BadgeServiceCommand -> Maybe C.PublicKeyEd25519 -> IO (Either BadgeServiceErrorCode (Maybe BadgePurchaseRow)) +checkSignerRecord _ BSCGetBadgeCatalog Nothing = pure $ Right Nothing checkSignerRecord bsEnv BSCGetBadgeCatalog (Just key) = requirePurchaseRecord bsEnv key checkSignerRecord _ (BSCPurchaseBadge {}) Nothing = pure $ Left BSEBadRequest -checkSignerRecord _ (BSCPurchaseBadge {}) (Just _) = pure $ Right () +checkSignerRecord _ (BSCPurchaseBadge {}) (Just _) = pure $ Right Nothing checkSignerRecord _ _ Nothing = pure $ Left BSEBadRequest checkSignerRecord bsEnv _ (Just key) = requirePurchaseRecord bsEnv key -requirePurchaseRecord :: BadgeServiceEnv -> C.PublicKeyEd25519 -> IO (Either BadgeServiceErrorCode ()) +requirePurchaseRecord :: BadgeServiceEnv -> C.PublicKeyEd25519 -> IO (Either BadgeServiceErrorCode (Maybe BadgePurchaseRow)) requirePurchaseRecord BadgeServiceEnv {store} key = withServiceTransaction store (\db -> getPurchaseByKey db key) >>= \case - Right (Just _) -> pure $ Right () + Right (Just row) -> pure $ Right (Just row) Right Nothing -> pure $ Left BSEUnknownPurchaseKey Left _ -> pure $ Left BSEInternal -- | Dispatch on the command, once the signer\/record precondition already passed. -- 'getBadgeInvoice', 'upgradeBadgeSubscription' and 'pauseBadge' are out of scope (decision 5 --- \/ §6) and always 'bad_request'; 'getBadgeCatalog' and 'issueBadge' are B6\/B7's commands and --- answer 'internal' \"not implemented\" until those steps land. -dispatchCommand :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse -dispatchCommand _ _ (BSCGetBadgeInvoice {}) = pure $ errorResponse BSEBadRequest Nothing Nothing -dispatchCommand _ _ (BSCUpgradeBadgeSubscription {}) = pure $ errorResponse BSEBadRequest Nothing Nothing -dispatchCommand _ _ BSCPauseBadge = pure $ errorResponse BSEBadRequest Nothing Nothing -dispatchCommand bsEnv purchaseKey BSCGetBadgeCatalog = handleGetBadgeCatalog bsEnv purchaseKey -dispatchCommand _ _ (BSCIssueBadge {}) = pure notImplemented -dispatchCommand bsEnv purchaseKey (BSCPurchaseBadge {payment}) = dispatchPurchase bsEnv purchaseKey payment +-- \/ §6) and always 'bad_request'; 'issueBadge' is B7's command and answers 'internal' +-- \"not implemented\" until that step lands. 'getBadgeCatalog' (B6) and, later, 'issueBadge' +-- are the two commands that use the 'Maybe' 'BadgePurchaseRow' 'checkSignerRecord' already +-- looked up; every other clause below ignores it. +dispatchCommand :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> Maybe BadgePurchaseRow -> BadgeServiceCommand -> IO BadgeServiceResponse +dispatchCommand _ _ _ (BSCGetBadgeInvoice {}) = pure $ errorResponse BSEBadRequest Nothing Nothing +dispatchCommand _ _ _ (BSCUpgradeBadgeSubscription {}) = pure $ errorResponse BSEBadRequest Nothing Nothing +dispatchCommand _ _ _ BSCPauseBadge = pure $ errorResponse BSEBadRequest Nothing Nothing +dispatchCommand bsEnv _ purchaseRow BSCGetBadgeCatalog = handleGetBadgeCatalog bsEnv purchaseRow +dispatchCommand _ _ _ (BSCIssueBadge {}) = pure notImplemented +dispatchCommand bsEnv purchaseKey _ (BSCPurchaseBadge {payment}) = dispatchPurchase bsEnv purchaseKey payment -- | 'checkSignerRecord' already requires a signature for every 'purchaseBadge', so -- 'purchaseKey' is 'Just' here in every reachable case; the 'Nothing' clause only keeps this @@ -312,38 +324,44 @@ dispatchPurchase _ _ (SPReceipt {}) = pure $ errorResponse BSEBadRequest Nothing -- | Answers the catalog, and for a signed request the signer's statement as well. -- +-- Takes the 'Maybe' 'BadgePurchaseRow' 'checkSignerRecord' already looked up ('Nothing' for +-- an unsigned request, 'Just' the row for a signed one -- an unknown signed key never reaches +-- here, 'checkSignerRecord' already answered 'unknown_purchase_key'), rather than a key: a +-- second lookup by key here would open a second transaction reading the same row. +-- -- Unsigned requests spend a token from the service-wide catalog bucket first (B5 decision 5): -- there is no signer to key on and no failure to count, so the request itself is the only --- thing that can be bounded. A signed request is not subject to it -- 'checkSignerRecord' --- has already required an existing purchase row, which is the bound. +-- thing that can be bounded. A signed request is not subject to it -- the row already in hand +-- is the bound. -- -- Both halves are read in ONE transaction, and it is a writing one: healing the ledger -- (@advance now@) persists its @debit(lapse)@ row in the same transaction that then reads the -- statement back, so the balance a client is told is the balance the database holds. This is -- the only read command that writes (RPC "Statement and balance"). -handleGetBadgeCatalog :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> IO BadgeServiceResponse -handleGetBadgeCatalog bsEnv@BadgeServiceEnv {store, now} signerKey = case signerKey of +handleGetBadgeCatalog :: BadgeServiceEnv -> Maybe BadgePurchaseRow -> IO BadgeServiceResponse +handleGetBadgeCatalog bsEnv@BadgeServiceEnv {store, now} purchaseRow = case purchaseRow of Nothing -> takeCatalogBucket bsEnv >>= \case Left retryAfter -> pure $ errorResponse BSERateLimited Nothing (Just retryAfter) Right () -> respond Nothing - Just key -> respond (Just key) + Just row -> respond (Just row) where - respond key = do + respond row = do now' <- now - withServiceTransaction store (catalogTxn now' key) >>= \case + withServiceTransaction store (catalogTxn now' row) >>= \case Left e -> do logError $ "getBadgeCatalog failed: " <> tshow e pure $ errorResponse BSEInternal Nothing Nothing Right (catalog, badgeStatement) -> do logUnpricedOffers catalog pure BSPBadgeCatalog {catalog, badgeStatement} - catalogTxn now' key db = do + catalogTxn now' row db = do -- catalogTotals is applied to what the DATABASE holds, never to Catalog.hs's defaults, -- so a price the operator deprecated or disabled is reflected without a rebuild -- (decision 8): the site, the RPC catalog and the charge all read this one result. catalog <- catalogTotals <$> getActiveCatalog db - statement <- mapM (purchaseStatement now' db) key + -- getBadgeCatalog carries no cursor, so this is always the full ledger (Nothing). + statement <- mapM (purchaseStatement now' db Nothing) row pure (catalog, statement) -- | An offer that is pinned to a price the catalog also returned, yet still has no total, @@ -360,7 +378,9 @@ logUnpricedOffers BadgeCatalog {prices, offers} = logWarn $ "catalog offer " <> oid <> " has a pinned price but no chargeable total" _ -> pure () --- | Heals the purchase's ledger to @now@, then reads the whole of it back as a statement. +-- | Heals the purchase's ledger to @now@, then reads it back as a statement -- the whole +-- ledger when @sinceEntryId@ is 'Nothing', or only entries strictly after it otherwise +-- (matches 'getLedgerSince'\'s own semantics). -- -- @advance@ is run against the last stored entry's state and, when it yields months, ONE -- @debit(lapse)@ row is written for them (B2's calling convention: one row, whatever @k@ is). @@ -368,19 +388,23 @@ logUnpricedOffers BadgeCatalog {prices, offers} = -- balance to lapse from -- so it returns an empty statement rather than inventing an opening -- entry. -- --- 'previousEntryId' is 'Nothing': 'getBadgeCatalog' carries no cursor, so this is always the --- full ledger, which is what that field's absence means. -purchaseStatement :: UTCTime -> DB.Connection -> C.PublicKeyEd25519 -> ExceptT ServiceError IO BadgeStatement -purchaseStatement now' db key = do - purchase <- getPurchaseByKey db key - case purchase of - -- unreachable: checkSignerRecord already required the row for a signed request. Refused - -- rather than answered with an empty statement, which would look like a real ledger. - Nothing -> throwError $ SEDecodeError "getBadgeCatalog: signer has no purchase row" - Just BadgePurchaseRow {badgePurchaseId} -> do - healLedger now' db badgePurchaseId - entries <- mapM (liftEither' . toStatementEntry) =<< getLedgerSince db badgePurchaseId Nothing - pure BadgeStatement {entries, previousEntryId = Nothing} +-- Takes the purchase row directly rather than a key: every caller has already looked it up +-- once (B6's 'handleGetBadgeCatalog' via 'checkSignerRecord'; B7's future 'issueBadge' the +-- same way), and looking it up again here would open a second transaction reading the same +-- row -- so there is no "signer has no purchase row" case to handle any more. +-- +-- @sinceEntryId@ is also threaded through rather than hardcoded, so a future cursor-carrying +-- caller (B7) can reuse this function instead of duplicating it. 'getBadgeCatalog' (B6) +-- always passes 'Nothing' -- it carries no cursor -- for which 'previousEntryId' being +-- 'Nothing' below is exactly correct (RPC: "absent for the full ledger"). 'previousEntryId' +-- is meant to echo the client's *asserted* (wire, 'Text') entryId, which this function is +-- never given, only the resolved 'Int64' to query on -- a real cursor caller needs to carry +-- that wire value through separately to fill it in for real; nothing today constructs one. +purchaseStatement :: UTCTime -> DB.Connection -> Maybe Int64 -> BadgePurchaseRow -> ExceptT ServiceError IO BadgeStatement +purchaseStatement now' db sinceEntryId BadgePurchaseRow {badgePurchaseId} = do + healLedger now' db badgePurchaseId + entries <- mapM (liftEither' . toStatementEntry) =<< getLedgerSince db badgePurchaseId sinceEntryId + pure BadgeStatement {entries, previousEntryId = Nothing} where liftEither' = either throwError pure 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 d953eba203..927c30e890 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -1344,7 +1344,9 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **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`. 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. +- **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). +- **B6 — `BadgeService/Config.hs` is touched, outside the step's stated file list (`Service.hs`, `tests/Bots/BadgeServiceTests.hs`).** `takeCatalogBucket` (the peek-and-debit STM action for the unsigned-`getBadgeCatalog` bucket B5 added but never wired) had to be added there to satisfy the Verify line's throttle case — B5 built the bucket itself but not a way to spend from it, and that action belongs beside `checkFailureBuckets`/`debitFailureBuckets`, the other bucket operations, not in `Service.hs`. §4 rule 6 was applied to the `Catalog.hs` deviation (the two entries above) but missed this one in the original pass; recorded here on the same rule. - **§4 — the stated build command did not work; corrected in place.** `cabal build simplex-chat simplex-badge-service` fails with `Ambiguous target 'simplex-chat'`, because `simplex-chat` names both a library and an executable component. It is now `cabal build lib:simplex-chat exe:simplex-chat simplex-badge-service`, which was run and succeeds. The test command beside it was correct as written and passes: 41 examples, 0 failures across both `Supporter badges` and `Badge service`. - **B1 — two vocabularies are now spelled only in `BadgeService/Store.hs`, with nothing tying them to a future codec.** The ledger's `entry_credit_type`/`entry_debit_type` values (`support`, `opening`, `transfer_in`, …) and the payment provider literal `code` are written as bare strings, because no `ToField`/`FromField` instance exists for `LedgerCreditType`, `LedgerDebitType` or `PaymentProvider` anywhere in the repo. Neither is a *duplicate* spelling today, so neither is a defect. Both become one the moment a later step adds a codec: D0, E2 and F1 need a real `PaymentProvider` encoding, and whoever resolves the `LedgerCreditType` question above will need the entry-type spellings to match what B1 already wrote. Reuse these spellings rather than inventing a second set, and prefer deriving both directions from one instance, as `BadgePurchaseStatus` and `BadgeItemStatus` do. - **B5 — the per-signer bucket sweeper is built and tested but nothing schedules it. B7 must wire it to a timer. OPEN.** The original hazard is closed: `peekSignerBucket` no longer creates an entry for an unseen key, so a freshly minted keypair costs nothing, and an entry is created only by a classified failure — which also spends a token from the single shared global bucket, capping new entries per window at that bucket's capacity however many keys an attacker mints. `sweepSignerBuckets` evicts recovered entries and `sweepSignerBucketsIO` takes the injectable clock so eviction is provable without sleeping. What is missing is a caller: nothing runs the sweep on an interval, so the map only shrinks when something asks it to. This costs nothing during B5, where `debitFailureBuckets` has no caller at all and the map is provably empty on every reachable path. **B7 is the first step that makes a redemption fail, so B7 owns wiring the sweep onto a timer** — a third arm of the service's `raceAny_` alongside the bot and the reconciliation pass is the natural place. diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 23517bc5f3..2a9050c8b7 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -136,6 +136,7 @@ badgeServiceTests = do it "should price 3 months at 2x and 12 months at 6x the monthly price" testBadgeCatalogOfferTotal 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 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 @@ -646,6 +647,28 @@ testBadgeCatalogOfferTotalRejectsBadFreeMonths _ps = do } offerTotal price (Just badOffer) `shouldBe` Nothing +-- The sibling hazard, on the ODDiscount side: a Word8 subtraction of percent from 100 is +-- unsigned and unguarded, so an offer with percent > 100 (a typo, a future repricing) would +-- wrap silently (100 - 101 :: Word8 == 255) and hand out a 2.55x OVERCHARGE, worse than the +-- freeMonths hazard above since it inflates the price instead of merely reading as +-- unavailable. offerTotal must instead answer Nothing, the same way, for the same reason. +testBadgeCatalogOfferTotalRejectsBadDiscount :: HasCallStack => TestParams -> IO () +testBadgeCatalogOfferTotalRejectsBadDiscount _ps = do + now <- getCurrentTime + let BadgeCatalog {prices} = defaultCatalog now + price@BadgePrice {priceId} = fromJust $ find (\BadgePrice {badgeType} -> badgeType == BTSupporter) prices + badOffer = + BadgeOffer + { offerId = BadgeOfferId "test-bad-offer-discount-gt-100", + priceId = Just priceId, + months = 3, + discount = ODDiscount 101, + status = BISActive, + createdAt = now, + total = Nothing + } + offerTotal price (Just badOffer) `shouldBe` Nothing + -- 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. @@ -831,7 +854,11 @@ testBadgeServiceCompleteConfigStarts ps@TestParams {tmpPath} = -- A disabled price (and every offer pinned to it) must be absent from the RPC catalog, while -- a deprecated price (and its offers) must still be present -- getActiveCatalog's own -- invariant (already proved at the store level by testBadgeStoreSetPriceStatusDisabled), --- surfaced here through the live RPC path handleGetBadgeCatalog actually calls. +-- surfaced here through the live RPC path handleGetBadgeCatalog actually calls. Also asserts +-- decision 8 at the wire boundary: every remaining offer's total is populated, so a client +-- never has to (and can't, since it doesn't have the prices) compute one itself -- deleting +-- the handler's catalogTotals call would still pass every other assertion in this test file +-- without this one. testBadgeServiceGetCatalogDisabledDeprecated :: HasCallStack => TestParams -> IO () testBadgeServiceGetCatalogDisabledDeprecated ps = do priceIdsRef <- newIORef Nothing @@ -858,6 +885,7 @@ testBadgeServiceGetCatalogDisabledDeprecated ps = do any (\BadgePrice {priceId} -> priceId == deprecatedId) prices `shouldBe` True any (\BadgeOffer {priceId} -> priceId == Just disabledId) offers `shouldBe` False any (\BadgeOffer {priceId} -> priceId == Just deprecatedId) offers `shouldBe` True + all (\BadgeOffer {total} -> isJust total) offers `shouldBe` True other -> expectationFailure $ "expected BSPBadgeCatalog, got: " <> show other -- getBadgeCatalog applies checkSignerRecord like every other signed command (B5): a signed