From 599abb58d771c2bc6e3af3a0edb012b34526df69 Mon Sep 17 00:00:00 2001 From: shum Date: Tue, 25 Aug 2026 12:38:44 +0000 Subject: [PATCH] core: badge catalog rpc handler --- .../src/BadgeService/Catalog.hs | 53 +++-- .../src/BadgeService/Config.hs | 18 ++ .../src/BadgeService/Service.hs | 200 ++++++++++++++++- .../2026-08-21-badges-web-checkout.md | 3 +- tests/Bots/BadgeServiceTests.hs | 211 +++++++++++++++++- 5 files changed, 447 insertions(+), 38 deletions(-) diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs index 60def2a9e1..cba91fa662 100644 --- a/apps/simplex-badge-service/src/BadgeService/Catalog.hs +++ b/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} = diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index db3ae40b11..103285222e 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/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 diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index f3734d1524..cc0da04689 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/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) 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 f008af84f9..d953eba203 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/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. diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 7ffe186978..23517bc5f3 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/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