core: fix badge catalog overcharge and double-fetch

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} =

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
   }
 

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
 

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.

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