core: badge catalog rpc handler

apps/simplex-badge-service/src/BadgeService/Catalog.hs

@@ -128,28 +128,32 @@ defaultCatalog createdAt =
 -- 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 -> CurrencyAmount
+offerTotal :: BadgePrice -> Maybe BadgeOffer -> Maybe CurrencyAmount
 offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} Nothing =
-  CurrencyAmount monthPriceMinor
-offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} (Just offer@BadgeOffer {months, discount}) =
-  CurrencyAmount $ case discount of
-    ODFreeMonths freeMonths -> fromIntegral (chargeableMonths offer months freeMonths) * monthPriceMinor
-    ODDiscount percent -> (fromIntegral months * monthPriceMinor * fromIntegral (100 - percent)) `div` 100
+  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 -> Just ((fromIntegral months * monthPriceMinor * fromIntegral (100 - percent)) `div` 100)
 
 -- | months - freeMonths, but only once it's known safe: a bare 'Word8' subtraction is
--- unsigned and unguarded, so an offer seeded with freeMonths >= months (a typo, a future
+-- unsigned and unguarded, so an offer with freeMonths >= months (a typo, a future
 -- repricing, operator tooling) would silently wrap (3 - 12 :: Word8 == 247) and this
 -- money-computing module would hand out a wildly wrong charge without any sign anything
 -- went wrong. freeMonths >= months isn't a value to compute a (wrong) answer for at all —
--- it charges for zero or a negative number of months, which isn't an offer — so this fails
--- loudly and by name instead of ever reaching the subtraction.
-chargeableMonths :: BadgeOffer -> Word8 -> Word8 -> Word8
-chargeableMonths BadgeOffer {offerId = BadgeOfferId oid} months freeMonths
-  | freeMonths >= months =
-      error $
-        "offerTotal: offer " <> T.unpack oid <> " has freeMonths (" <> show freeMonths
-          <> ") >= months (" <> show months <> "), which is not a chargeable offer"
-  | otherwise = months - freeMonths
+-- it charges for zero or a negative number of months, which isn't an offer.
+--
+-- It used to say so with 'error'. That was safe while 'seedCatalog' was the only caller and
+-- forced it at startup, and stopped being safe the moment B6 ran totals over rows read from
+-- the database inside a request: the bot's request loop is single-threaded, so one bad row
+-- would have taken the service down for every user (§9). 'Nothing' instead — which A2
+-- already defines on the wire as "this offer is unavailable, do not compute a price for it"
+-- — keeps the blast radius to the one offer, and 'seedCatalog' still fails the process at
+-- startup, by name, for a bad *default* catalog.
+chargeableMonths :: Word8 -> Word8 -> Maybe Word8
+chargeableMonths months freeMonths
+  | freeMonths >= months = Nothing
+  | otherwise = Just (months - freeMonths)
 
 -- | 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
@@ -161,7 +165,7 @@ catalogTotals BadgeCatalog {prices, offers} =
   BadgeCatalog {prices, offers = map fillTotal offers}
   where
     fillTotal offer@BadgeOffer {priceId} =
-      offer {total = offerTotal <$> pricedBy priceId <*> pure (Just offer)}
+      offer {total = pricedBy priceId >>= \price -> offerTotal price (Just offer)}
     pricedBy Nothing = Nothing
     pricedBy (Just pid) = find (\BadgePrice {priceId = pid'} -> pid' == pid) prices
 
@@ -179,13 +183,22 @@ seedCatalog st = do
   createdAt <- getCurrentTime
   let catalog@BadgeCatalog {prices, offers} = defaultCatalog createdAt
       BadgeCatalog {offers = pricedOffers} = catalogTotals catalog
-  mapM_ forceTotal pricedOffers
+  mapM_ requireTotal pricedOffers
   withTransaction st $ \db -> do
     mapM_ (insertPrice db) prices
     mapM_ (insertOffer db) offers
   where
-    forceTotal BadgeOffer {total = Just (CurrencyAmount amount)} = void $ evaluate amount
-    forceTotal BadgeOffer {total = Nothing} = pure ()
+    -- 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.
+    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
 
 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

@@ -22,6 +22,7 @@ module BadgeService.Config
     BadgeServiceEnv (..),
     newBadgeServiceEnv,
     checkFailureBuckets,
+    takeCatalogBucket,
     debitFailureBuckets,
     sweepSignerBuckets,
     sweepSignerBucketsIO,
@@ -35,6 +36,7 @@ import Data.ByteString (ByteString)
 import Data.Ini (Ini, keys, lookupValue, readIniFile, sections)
 import qualified Data.Map.Strict as M
 import Data.Maybe (isJust)
+import Data.Functor (($>))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
@@ -595,6 +597,22 @@ checkFailureBuckets BadgeServiceEnv {now, signerFailureBucket, globalFailureBuck
       Left _ -> signerResult
       Right () -> globalResult
 
+-- | The gate for an UNSIGNED 'getBadgeCatalog' (B5 decision 5). Unlike the failure buckets,
+-- this one is spent by every request, not only by failures: an unsigned catalog request has
+-- no signer to key on and no notion of "failing", so the only thing that can bound it is the
+-- request itself. Peek and debit are one STM transaction so two concurrent requests cannot
+-- both see the last token. A signed request never reaches here -- it is bounded by having a
+-- purchase row at all, which 'checkSignerRecord' already requires.
+takeCatalogBucket :: BadgeServiceEnv -> IO (Either Word32 ())
+takeCatalogBucket BadgeServiceEnv {now, catalogBucket} = do
+  now' <- now
+  atomically $ do
+    tb <- readTVar catalogBucket
+    let (ok, retryAfter, tb') = bucketStatus now' tb
+    if ok
+      then writeTVar catalogBucket (debitBucket tb') $> Right ()
+      else writeTVar catalogBucket tb' $> Left retryAfter
+
 -- | Debits one token from both failure buckets after a failed 'purchaseBadge{code}'
 -- redemption (code_invalid / code_used / code_expired, including a checksum rejection that
 -- never reached the database). Not called from B5: no code classifier exists yet, so no

apps/simplex-badge-service/src/BadgeService/Service.hs

@@ -15,28 +15,59 @@ module BadgeService.Service
   )
 where
 
-import BadgeService.Catalog (seedCatalog)
-import BadgeService.Config (BadgeServiceEnv (..), checkFailureBuckets, newBadgeServiceEnv, readBadgeServiceConfig)
+import BadgeService.Catalog (catalogTotals, seedCatalog)
+import BadgeService.Config (BadgeServiceEnv (..), checkFailureBuckets, newBadgeServiceEnv, readBadgeServiceConfig, takeCatalogBucket)
+import BadgeService.Ledger (LedgerState (..), advance)
 import BadgeService.Options
-import BadgeService.Store (getPurchaseByKey, withServiceTransaction)
+import BadgeService.Store
+  ( BadgePurchaseRow (..),
+    ServiceError (..),
+    appendLedgerEntry,
+    getActiveCatalog,
+    getLastLedgerEntry,
+    getLedgerSince,
+    getPurchaseByKey,
+    withServiceTransaction,
+  )
 import BadgeService.Store.Migrate (runBadgeServiceMigrations)
 import Control.Concurrent.STM
 import Control.Exception (SomeException, catch, evaluate)
+import Control.Monad.Except (ExceptT, throwError)
+import Control.Monad.IO.Class (liftIO)
 import Control.Logger.Simple
 import Control.Monad
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import qualified Data.ByteString.Lazy as LBS
+import Data.Int (Int64)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
 import Data.Word (Word32)
 import Simplex.Chat.Badges.Service
-  ( BadgeServiceCommand (..),
+  ( BadgeCatalog (..),
+    BadgeOffer (..),
+    BadgePrice (..),
+    BadgeServiceCommand (..),
     BadgeServiceErrorCode (..),
     BadgeServiceRequest (..),
     BadgeServiceResponse (..),
+    BadgeStatement (..),
+    StatementCreditType (..),
+    StatementDebitType (..),
+    StatementEntry (..),
+    StatementEntryType (..),
     minSupportedBadgeVersion,
   )
+import Simplex.Chat.Badges.Types
+  ( BadgeLedgerEntry (..),
+    BadgeOfferId (..),
+    LedgerCreditType (..),
+    LedgerDebitType (..),
+    LedgerEntryType (..),
+  )
 import Simplex.Chat.Bot (initializeBotAddress')
 import Simplex.Chat.Controller
 import Simplex.Chat.Core (sendChatCmd, simplexChatCore)
@@ -45,6 +76,7 @@ import Simplex.Chat.PaymentService (ServicePayment (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
 import Simplex.Chat.Types (AgentInvId (..), User (..))
+import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (strEncode)
 import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow)
@@ -250,7 +282,7 @@ dispatchCommand :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> BadgeServiceCo
 dispatchCommand _ _ (BSCGetBadgeInvoice {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
 dispatchCommand _ _ (BSCUpgradeBadgeSubscription {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
 dispatchCommand _ _ BSCPauseBadge = pure $ errorResponse BSEBadRequest Nothing Nothing
-dispatchCommand _ _ BSCGetBadgeCatalog = pure notImplemented
+dispatchCommand bsEnv purchaseKey BSCGetBadgeCatalog = handleGetBadgeCatalog bsEnv purchaseKey
 dispatchCommand _ _ (BSCIssueBadge {}) = pure notImplemented
 dispatchCommand bsEnv purchaseKey (BSCPurchaseBadge {payment}) = dispatchPurchase bsEnv purchaseKey payment
 
@@ -275,3 +307,161 @@ dispatchPurchase _ _ (SPApple {}) = pure $ errorResponse BSEBadRequest Nothing N
 dispatchPurchase _ _ (SPGoogle {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
 dispatchPurchase _ _ (SPInvoice {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
 dispatchPurchase _ _ (SPReceipt {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
+
+-- getBadgeCatalog (B6) --------------------------------------------------------
+
+-- | Answers the catalog, and for a signed request the signer's statement as well.
+--
+-- 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.
+--
+-- 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
+  Nothing ->
+    takeCatalogBucket bsEnv >>= \case
+      Left retryAfter -> pure $ errorResponse BSERateLimited Nothing (Just retryAfter)
+      Right () -> respond Nothing
+  Just key -> respond (Just key)
+  where
+    respond key = do
+      now' <- now
+      withServiceTransaction store (catalogTxn now' key) >>= \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
+      -- 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
+      pure (catalog, statement)
+
+-- | An offer that is pinned to a price the catalog also returned, yet still has no total,
+-- is a malformed offer (@freeMonths >= months@): the client will render it as unavailable,
+-- and nothing else in the system would ever say why. 'chargeableMonths' stopped saying so
+-- with 'error' precisely so a request thread survives it (§9), so this is the only place it
+-- gets named.
+logUnpricedOffers :: BadgeCatalog -> IO ()
+logUnpricedOffers BadgeCatalog {prices, offers} =
+  forM_ offers $ \BadgeOffer {offerId = BadgeOfferId oid, priceId, total} ->
+    case (priceId, total) of
+      (Just pid, Nothing)
+        | any (\BadgePrice {priceId = pid'} -> pid' == pid) prices ->
+            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.
+--
+-- @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).
+-- A purchase with no ledger at all has nothing to heal and nothing to lapse -- there is no
+-- 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}
+  where
+    liftEither' = either throwError pure
+
+healLedger :: UTCTime -> DB.Connection -> Int64 -> ExceptT ServiceError IO ()
+healLedger now' db badgePurchaseId =
+  getLastLedgerEntry db badgePurchaseId >>= \case
+    Nothing -> pure ()
+    Just BadgeLedgerEntry {balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince} ->
+      case advance now' LedgerState {balanceMonths, balanceStartTs, balanceBadgeType} of
+        Nothing -> pure ()
+        Just (k, LedgerState {balanceMonths = balanceMonths', balanceStartTs = balanceStartTs'}) -> do
+          entryUuid <- liftIO (UUID.toText <$> UUID.nextRandom)
+          void $
+            appendLedgerEntry
+              db
+              BadgeLedgerEntry
+                { entryId = 0, -- assigned by the database
+                  entryUuid,
+                  badgePurchaseId,
+                  changeMonths = negate k,
+                  balanceMonths = balanceMonths',
+                  -- the entry's balance_start_ts is the state advance left, NOT the time the
+                  -- row was created; created_at/service_created_at carry that (B2)
+                  balanceStartTs = balanceStartTs',
+                  balanceBadgeType,
+                  wasPausedSince,
+                  serviceCreatedAt = now',
+                  createdAt = now',
+                  entryType = LEDebit DTLapse
+                }
+
+-- | The stored ledger row as the client sees it. 'entryId' on the wire is the row's
+-- @entry_uuid@, not its @entry_id@: the uuid is what the service authors and the client
+-- copies verbatim (core §1), while @entry_id@ is a per-database IDENTITY that means nothing
+-- outside this one service.
+--
+-- Four entry types are refused rather than converted, and none of them can be reached by
+-- anything in this milestone:
+--
+--   * @CTPayment@ and @CTCharge@ carry 'Int64' ids against @TEXT@ columns -- the unresolved
+--     mismatch §9 records as needing a decision before C1. 'BadgeService.Store' already
+--     refuses to read or write them, so a row of either type cannot exist; inventing a
+--     numeric-to-text coercion here is exactly what that refusal exists to prevent.
+--   * @CTTransferIn@, @DTUpgrade@ and @DTTransferOut@ store a purchase *id* while the wire
+--     types carry a purchase *key*. Converting needs an id-to-key lookup the store does not
+--     expose, and transfers and upgrades are out of scope (§6), so nothing writes them.
+--
+-- A refusal fails the whole response with 'internal' rather than dropping the entry: a
+-- statement that silently omits a ledger row is a wrong balance, which is worse than no
+-- answer.
+toStatementEntry :: BadgeLedgerEntry -> Either ServiceError StatementEntry
+toStatementEntry BadgeLedgerEntry {entryUuid, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, createdAt, entryType} = do
+  entryType' <- statementEntryType entryType
+  Right
+    StatementEntry
+      { entryId = entryUuid,
+        changeMonths,
+        balanceMonths,
+        balanceStartTs,
+        balanceBadgeType,
+        wasPausedSince,
+        createdAt,
+        entryType = entryType'
+      }
+
+statementEntryType :: LedgerEntryType -> Either ServiceError StatementEntryType
+statementEntryType = \case
+  LECredit creditType -> SECredit <$> case creditType of
+    CTSupport -> Right SCSupport
+    CTOpening -> Right SCOpening
+    CTUnknown {tag, json} -> Right SCUnknown {tag, json}
+    CTPayment {} -> unresolved "credit(payment)" "invoiceId is Int64 against a TEXT column (§9, open before C1)"
+    CTCharge {} -> unresolved "credit(charge)" "chargeId is Int64 against a TEXT column (§9, open before C1)"
+    CTTransferIn {} -> unresolved "credit(transfer_in)" "stores a purchase id, the wire carries a purchase key; transfers are out of scope (§6)"
+  LEDebit debitType -> SEDebit <$> case debitType of
+    DTRefund -> Right SDRefund
+    DTSupport -> Right SDSupport
+    DTBadge -> Right SDBadge
+    DTLapse -> Right SDLapse
+    DTUnknown {tag, json} -> Right SDUnknown {tag, json}
+    DTUpgrade {} -> unresolved "debit(upgrade)" "stores a purchase id, the wire carries a purchase key; upgrades are out of scope (§6)"
+    DTTransferOut {} -> unresolved "debit(transfer_out)" "stores a purchase id, the wire carries a purchase key; transfers are out of scope (§6)"
+  where
+    unresolved what why = Left $ SEDecodeError ("cannot put " <> what <> " in a statement: " <> why)

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

@@ -139,7 +139,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat
 | B3 | `Codes.hs`: derive, encode, hash, classify | A5, A6, B1 | ☑ |
 | B4 | Issuer key loading and credential signing | A5, A6, B2 | ☑ |
 | B5 | RPC dispatcher: envelope, version, signer, throttle | A2, A6, B1 | ☑ |
-| B6 | `getBadgeCatalog` | A4, B1, B2, B5 | ☐ |
+| B6 | `getBadgeCatalog` | A4, B1, B2, B5 | ☑ |
 | B7 | `purchaseBadge{code}` and `issueBadge` | B1, B2, B3, B4, B5 | ☐ |
 | B8 | `codes` operator subcommand | A4, B1, B3 | ☑ |
 | B9 | Service address publication | A6, B5 | ☐ |
@@ -1344,6 +1344,7 @@ 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.
 - **§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

@@ -35,14 +35,16 @@ import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
 import Control.Concurrent.STM (atomically, readTVarIO)
-import Control.Exception (SomeException, evaluate, finally, try)
+import Control.Exception (SomeException, finally, try)
 import Control.Monad (replicateM, void)
 import Crypto.Random (getRandomBytes)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
+import qualified Data.Aeson.Types as JT
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy.Char8 as LBC
+import Data.IORef (newIORef, readIORef, writeIORef)
 import Data.List (find, isInfixOf)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromJust, isJust)
@@ -54,12 +56,15 @@ import Data.Time.Calendar.WeekDate (toWeekDate)
 import Data.Time.Clock (DiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay, secondsToDiffTime)
 import Data.Word (Word32)
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeRequest (..), BadgeType (..), verifyCredential)
+import Simplex.Chat.Badges.Months (addMonths)
 import Simplex.Chat.Badges.Service
   ( -- 'BadgeBalance', 'StatementEntry' and 'StatementEntryType' import only their
     -- constructors, not '(..)': their field names (entryId, changeMonths, balanceMonths,
     -- createdAt, ...) duplicate 'BadgeLedgerEntry''s (Badges.Types), which the existing B1
     -- ledger tests below already use as bare selectors -- importing the field selectors here
-    -- too would make those pre-existing, untouched uses ambiguous.
+    -- too would make those pre-existing, untouched uses ambiguous. 'BadgeStatement' is safe
+    -- to import with '(..)': 'entries'/'previousEntryId' are unique names nothing else here
+    -- uses.
     BadgeBalance (BadgeBalance),
     BadgeCatalog (..),
     BadgeOffer (..),
@@ -68,9 +73,11 @@ import Simplex.Chat.Badges.Service
     BadgeServiceErrorCode (..),
     BadgeServiceRequest (..),
     BadgeServiceResponse (..),
+    BadgeStatement (..),
     StatementCreditType (SCOpening),
+    StatementDebitType (SDLapse),
     StatementEntry (StatementEntry),
-    StatementEntryType (SECredit),
+    StatementEntryType (SECredit, SEDebit),
     pattern VersionBadgeService,
   )
 import Simplex.Chat.Badges.Types
@@ -140,6 +147,10 @@ badgeServiceTests = do
   it "should fail to start when a provider is configured without [web]" testBadgeServiceConfigProviderRequiresWeb
   it "should start with just [issuer] and [codes], no provider section" testBadgeServiceConfigMinimalStarts
   it "should start the service from a complete config with web and both providers" testBadgeServiceCompleteConfigStarts
+  it "should omit a disabled price and its offers from getBadgeCatalog, and keep a deprecated one" testBadgeServiceGetCatalogDisabledDeprecated
+  it "should respond unknown_purchase_key to a signed getBadgeCatalog from an unknown key" testBadgeServiceGetCatalogUnknownSignerKey
+  it "should heal the ledger on a signed getBadgeCatalog, appending exactly one debit(lapse), and heal nothing on a repeat" testBadgeServiceGetCatalogHealsLedger
+  it "should rate_limit a third unsigned getBadgeCatalog once the catalog bucket is drained, without affecting a signed one" testBadgeServiceGetCatalogBucketThrottle
   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
@@ -281,6 +292,17 @@ getServiceResponseObject client = do
     Just json | Just (J.Object o) <- J.decode (LBC.pack (T.unpack json)) -> pure o
     _ -> expectationFailure ("expected a service response line, got: " <> line) >> error "unreachable"
 
+-- Decodes a service response object into 'BadgeServiceResponse' (B6): used by every B6 test
+-- that inspects the catalog or the statement, rather than digging through the raw JSON object
+-- the way B5's throttle tests do (those only ever need 'code'/'retryAfter', which never
+-- justified the extra decode step).
+getServiceResponse :: HasCallStack => TestCC -> IO BadgeServiceResponse
+getServiceResponse client = do
+  obj <- getServiceResponseObject client
+  case JT.parseEither J.parseJSON (J.Object obj) :: Either String BadgeServiceResponse of
+    Right resp -> pure resp
+    Left err -> expectationFailure ("failed to decode service response: " <> err) >> error "unreachable"
+
 testBadgeRequestCommand :: BadgeMasterKey -> ServicePayment -> BadgeServiceCommand
 testBadgeRequestCommand masterKey payment =
   BSCPurchaseBadge {badgeRequest = testBadgeRequest masterKey, payment, upgrade = Nothing}
@@ -587,9 +609,10 @@ testBadgeCatalogOfferTotal _ps = do
   where
     assertOfferTotal priceFor offer@BadgeOffer {months, priceId = Just pid} = do
       let BadgePrice {monthPrice = CurrencyAmount monthly} = priceFor pid
-          CurrencyAmount total = offerTotal (priceFor pid) (Just offer)
           multiplier = if months == 3 then 2 else 6 :: Word32
-      total `shouldBe` monthly * multiplier
+      case offerTotal (priceFor pid) (Just offer) of
+        Just (CurrencyAmount total) -> total `shouldBe` monthly * multiplier
+        Nothing -> expectationFailure "seeded offer must have a chargeable total"
     assertOfferTotal _ BadgeOffer {priceId = Nothing} =
       expectationFailure "seeded offer must be pinned to a price"
 
@@ -603,8 +626,9 @@ testBadgeCatalogTotalsFillsSeededOffers _ps = do
 
 -- A Word8 subtraction of freeMonths from months is unsigned and unguarded: an offer with
 -- freeMonths >= months (a typo, a future repricing) would wrap silently
--- (3 - 12 :: Word8 == 247) and hand out a wildly wrong charge. offerTotal must instead fail
--- loudly, naming the offer, before it ever reaches that subtraction.
+-- (3 - 12 :: Word8 == 247) and hand out a wildly wrong charge. offerTotal must instead
+-- answer Nothing -- a typed absence, not an 'error' -- so one malformed row read inside a
+-- request (B6) can never take down the single-threaded request loop (§9).
 testBadgeCatalogOfferTotalRejectsBadFreeMonths :: HasCallStack => TestParams -> IO ()
 testBadgeCatalogOfferTotalRejectsBadFreeMonths _ps = do
   now <- getCurrentTime
@@ -620,11 +644,7 @@ testBadgeCatalogOfferTotalRejectsBadFreeMonths _ps = do
             createdAt = now,
             total = Nothing
           }
-  result <- try (evaluate (offerTotal price (Just badOffer))) :: IO (Either SomeException CurrencyAmount)
-  case result of
-    Left _ -> pure ()
-    Right (CurrencyAmount total) ->
-      expectationFailure $ "offerTotal should reject freeMonths >= months, got: " <> show total
+  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
@@ -806,6 +826,173 @@ testBadgeServiceCompleteConfigStarts ps@TestParams {tmpPath} =
                  "webhook_secret_file = " <> stripeWebhookFile
                ]
 
+-- B6 getBadgeCatalog -----------------------------------------------------------
+
+-- 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.
+testBadgeServiceGetCatalogDisabledDeprecated :: HasCallStack => TestParams -> IO ()
+testBadgeServiceGetCatalogDisabledDeprecated ps = do
+  priceIdsRef <- newIORef Nothing
+  let seedStatuses =
+        withTestChat ps serviceDbPrefix $ \bs -> do
+          bs <## "subscribed 1 connections on server localhost"
+          priceIds <- expectRight $ withServiceTransaction (chatStore (chatController bs)) $ \db -> do
+            BadgeCatalog {prices} <- getActiveCatalog db
+            case prices of
+              [BadgePrice {priceId = pid1}, BadgePrice {priceId = pid2}] -> do
+                setPriceStatus db pid1 BISDisabled
+                setPriceStatus db pid2 BISDeprecated
+                pure (pid1, pid2)
+              _ -> error "expected exactly the two default seeded prices"
+          writeIORef priceIdsRef (Just priceIds)
+  withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps) seedStatuses $ \client bsLink -> do
+    Just (disabledId, deprecatedId) <- readIORef priceIdsRef
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Nothing, request = BSCGetBadgeCatalog}
+    sendServiceRequest client bsLink req
+    resp <- getServiceResponse client
+    case resp of
+      BSPBadgeCatalog {catalog = BadgeCatalog {prices, offers}} -> do
+        any (\BadgePrice {priceId} -> priceId == disabledId) prices `shouldBe` False
+        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
+      other -> expectationFailure $ "expected BSPBadgeCatalog, got: " <> show other
+
+-- getBadgeCatalog applies checkSignerRecord like every other signed command (B5): a signed
+-- request from a key with no purchase row must fail the identity check before
+-- handleGetBadgeCatalog ever runs, the same way B5 already proved for issueBadge/pauseBadge.
+testBadgeServiceGetCatalogUnknownSignerKey :: HasCallStack => TestParams -> IO ()
+testBadgeServiceGetCatalogUnknownSignerKey ps =
+  withBadgeService ps $ \client bsLink -> do
+    (pub, priv) <- mkTestKeyPair
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = BSCGetBadgeCatalog}
+    sendSignedServiceRequest client bsLink priv req
+    client <## "service response: {\"code\":\"unknown_purchase_key\",\"type\":\"error\"}"
+
+-- StatementEntry is constructed/matched positionally (see the import list's Haddock): field
+-- order entryId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType,
+-- wasPausedSince, createdAt, entryType. Used to compare two statements for equality without
+-- needing an Eq instance on StatementEntry itself (there isn't one).
+statementEntryKey :: StatementEntry -> (Text, Int, Int)
+statementEntryKey (StatementEntry entryId changeMonths balanceMonths _ _ _ _ _) = (entryId, changeMonths, balanceMonths)
+
+-- A signed getBadgeCatalog heals the purchase's ledger to `now` (B2's `advance`) in the SAME
+-- transaction that reads the statement back (RPC "Statement and balance"), so the balance the
+-- client is told is the balance the database holds. With balance_start_ts backdated two
+-- months on a balance of 3, healing appends exactly one debit(lapse) of -2, leaving a balance
+-- of 1; an identical second request must append nothing further, since the ledger is already
+-- healed to (approximately) now.
+testBadgeServiceGetCatalogHealsLedger :: HasCallStack => TestParams -> IO ()
+testBadgeServiceGetCatalogHealsLedger ps = do
+  (pub, priv) <- mkTestKeyPair
+  masterKey <- BadgeMasterKey <$> getRandomBytes 32
+  purchaseIdRef <- newIORef Nothing
+  let seedBackdatedLedger =
+        withTestChat ps serviceDbPrefix $ \bs -> do
+          bs <## "subscribed 1 connections on server localhost"
+          now <- getCurrentTime
+          let backdated = addMonths (-2) now
+          badgePurchaseId <- expectRight $ withServiceTransaction (chatStore (chatController bs)) $ \db -> do
+            BadgePurchaseRow {badgePurchaseId} <- createPurchase db pub masterKey BTSupporter now
+            _ <-
+              appendLedgerEntry
+                db
+                BadgeLedgerEntry
+                  { entryId = 0,
+                    entryUuid = "test-opening-entry",
+                    badgePurchaseId,
+                    changeMonths = 3,
+                    balanceMonths = 3,
+                    balanceStartTs = backdated,
+                    balanceBadgeType = BTSupporter,
+                    wasPausedSince = Nothing,
+                    serviceCreatedAt = now,
+                    createdAt = now,
+                    entryType = LECredit CTOpening
+                  }
+            pure badgePurchaseId
+          writeIORef purchaseIdRef (Just badgePurchaseId)
+  statement1Ref <- newIORef Nothing
+  statement2Ref <- newIORef Nothing
+  withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps) seedBackdatedLedger $ \client bsLink -> do
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = BSCGetBadgeCatalog}
+    sendSignedServiceRequest client bsLink priv req
+    resp1 <- getServiceResponse client
+    case resp1 of
+      BSPBadgeCatalog {badgeStatement = Just stmt} -> writeIORef statement1Ref (Just stmt)
+      other -> expectationFailure $ "expected a statement on the first request, got: " <> show other
+    sendSignedServiceRequest client bsLink priv req
+    resp2 <- getServiceResponse client
+    case resp2 of
+      BSPBadgeCatalog {badgeStatement = Just stmt} -> writeIORef statement2Ref (Just stmt)
+      other -> expectationFailure $ "expected a statement on the second request, got: " <> show other
+  Just badgePurchaseId <- readIORef purchaseIdRef
+  Just BadgeStatement {entries = entries1} <- readIORef statement1Ref
+  Just BadgeStatement {entries = entries2} <- readIORef statement2Ref
+  case entries1 of
+    [_opening, StatementEntry _ changeMonths balanceMonths _ _ _ _ (SEDebit SDLapse)] -> do
+      changeMonths `shouldBe` (-2)
+      balanceMonths `shouldBe` 1
+    other -> expectationFailure $ "expected exactly [opening, lapse(-2)], got " <> show (length other) <> " entries"
+  map statementEntryKey entries2 `shouldBe` map statementEntryKey entries1 -- second request heals nothing further
+  -- the balance the RPC reported must match a freshly read getLastLedgerEntry -- reopened
+  -- only after the service (and its exclusive hold on the sqlite file) has been killed, same
+  -- as withBadgeServiceConfig's own between-phases reopen.
+  lastEntry <-
+    withTestChat ps serviceDbPrefix $ \bs -> do
+      bs <## "subscribed 1 connections on server localhost"
+      expectRight $ withServiceTransaction (chatStore (chatController bs)) $ \db -> getLastLedgerEntry db badgePurchaseId
+  case (lastEntry, entries1) of
+    (Just BadgeLedgerEntry {balanceMonths = storedBalance}, [_, StatementEntry _ _ wireBalance _ _ _ _ _]) ->
+      storedBalance `shouldBe` wireBalance
+    _ -> expectationFailure "expected a stored last ledger entry matching the wire statement's balance"
+
+-- The catalog bucket (B5 decision 5) is spent by every UNSIGNED getBadgeCatalog, success or
+-- not; a signed request never touches it (bounded instead by requiring a purchase row).
+-- Overriding the bucket to capacity 2 via A6's [throttle] harness: the first two unsigned
+-- requests in the window succeed, a third gives rate_limited with a positive retryAfter, and
+-- a signed request (from a key with a real purchase row) is unaffected by the drained bucket.
+testBadgeServiceGetCatalogBucketThrottle :: HasCallStack => TestParams -> IO ()
+testBadgeServiceGetCatalogBucketThrottle ps = do
+  (issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets (tmpPath ps)
+  (pub, priv) <- mkTestKeyPair
+  masterKey <- BadgeMasterKey <$> getRandomBytes 32
+  let writeConfig =
+        writeFile (badgeServiceConfigPath (tmpPath ps)) $
+          unlines $
+            issuerCodesIniLines issuerKeyFile codeSecretFile
+              ++ ["", "[throttle]", "catalog_capacity = 2", "catalog_start_tokens = 2"]
+      seedPurchase =
+        withTestChat ps serviceDbPrefix $ \bs -> do
+          bs <## "subscribed 1 connections on server localhost"
+          now <- getCurrentTime
+          void $ expectRight $ withServiceTransaction (chatStore (chatController bs)) $ \db -> createPurchase db pub masterKey BTSupporter now
+  withBadgeServiceConfig ps writeConfig seedPurchase $ \client bsLink -> do
+    let unsignedReq = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Nothing, request = BSCGetBadgeCatalog}
+        signedReq = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = BSCGetBadgeCatalog}
+        expectCatalog label client' = do
+          resp <- getServiceResponse client'
+          case resp of
+            BSPBadgeCatalog {} -> pure ()
+            other -> expectationFailure $ label <> " expected BSPBadgeCatalog, got: " <> show other
+    -- drain the 2-token catalog bucket
+    sendServiceRequest client bsLink unsignedReq
+    expectCatalog "first unsigned request" client
+    sendServiceRequest client bsLink unsignedReq
+    expectCatalog "second unsigned request" client
+    -- a third request in the same window is rejected before processing
+    sendServiceRequest client bsLink unsignedReq
+    respObj <- getServiceResponseObject client
+    KM.lookup "code" respObj `shouldBe` Just (J.String "rate_limited")
+    case KM.lookup "retryAfter" respObj of
+      Just (J.Number n) -> n `shouldSatisfy` (> 0)
+      other -> expectationFailure $ "expected a positive retryAfter, got: " <> show other
+    -- a signed request bypasses the catalog bucket entirely, even fully drained
+    sendSignedServiceRequest client bsLink priv signedReq
+    expectCatalog "signed request" client
+
 -- B1 store layer -------------------------------------------------------------
 
 -- A fresh, migrated badge-service database, independent of any running bot: these tests