From 0ef7baa0b118dc83672064ea342ee4f6c06d27a1 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 26 Aug 2026 00:12:35 +0000 Subject: [PATCH] core: client badge store, plan: tick C1 --- .../2026-08-21-badges-web-checkout.md | 15 +- simplex-chat.cabal | 2 + src/Simplex/Chat/Store/Badges.hs | 529 ++++++++++++++++++ tests/Bots/BadgeStoreTests.hs | 443 +++++++++++++++ tests/Test.hs | 2 + 5 files changed, 986 insertions(+), 5 deletions(-) create mode 100644 src/Simplex/Chat/Store/Badges.hs create mode 100644 tests/Bots/BadgeStoreTests.hs 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 4ba082938d..86dbe87690 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -144,7 +144,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | B8 | `codes` operator subcommand | A4, B1, B3 | ☑ | | B9 | Service address publication | A6, B5 | ☑ | | B10 | Service integration tests | B7, B8 | ☑ | -| C1 | `Store/Badges.hs`: client badge store | A1, A2 | ☐ | +| C1 | `Store/Badges.hs`: client badge store | A1, A2 | ☑ | | C2 | Commands, responses, events, parsers, View | A2, B2, C1 | ☐ | | C3 | `BadgeManager` worker | C1, C2 | ☐ | | C4 | Redeem path wired end to end | B6, B7, B9, C3 | ☐ | @@ -633,7 +633,7 @@ Phase C ends with a chat client that can redeem a code minted by B8 and show the #### C1 — `Store/Badges.hs`: client badge store -**Files:** `src/Simplex/Chat/Store/Badges.hs`, `simplex-chat.cabal` (add `Simplex.Chat.Store.Badges` to the library `exposed-modules`), `tests/BadgeTests.hs` +**Files:** `src/Simplex/Chat/Store/Badges.hs`, `simplex-chat.cabal` (add `Simplex.Chat.Store.Badges` to the library `exposed-modules` and `Bots.BadgeStoreTests` to the test stanza's `other-modules`), `tests/Bots/BadgeStoreTests.hs`, `tests/Test.hs` **Do:** @@ -644,10 +644,10 @@ Phase C ends with a chat client that can redeem a code minted by B8 and show the - `supersedePurchases` moves every other purchase of the same slot for that user from `issued` to `superseded`, and `setShownPurchase` points `users.shown_badge_id` at the new row. The column exists (`M20260731_user_badges.hs:220`) and has no writer in the repo yet, so this is new code; it is separate from `setUserBadge` (`Store/Profiles.hs:375`), which writes the profile's badge columns and is what C3 calls for presentation. - `getShownPurchase` reads the purchase `users.shown_badge_id` points at, returning the row with its purchase keypair and badge master key, which is what C2 renders and what C3 signs `issueBadge` with. It is new code: `shown_badge_id` has no reader in the repo either. - `getLastBadgeLedgerEntry` reads the purchase's last `badge_ledger` row, which is what the worker compares a statement against. -- `insertLedgerEntries` writes a statement's entries into `badge_ledger` verbatim. The client is never the author (core §1). An `opening` entry restates the balance absolutely, regardless of what preceded it. -- Unknown credit and debit tags go to `entry_type_unknown` and `entry_type_value`, for re-decoding after an app upgrade. +- `insertLedgerEntries` writes a statement's entries into `badge_ledger` verbatim. The client is never the author (core §1). An `opening` entry restates the balance absolutely, regardless of what preceded it. It takes the wire `BadgeStatement` whole, because `previousEntryId` is what decides how the entries attach and a caller must not have to reimplement that: **present** it names an entry the client already holds and the entries append after it; **absent with entries present** the entries "attach to nothing" (`badges-rpc.md:56`) and the statement *is* the ledger, so rows the client holds that the statement does not carry are stale and are deleted — appending on an absent cursor would duplicate the ledger. An empty `entries` changes nothing either way. Insertion is `ON CONFLICT (entry_uuid) DO NOTHING` against `@idx_badge_ledger_uuid`: `purchaseBadge` and `getBadgeCatalog` return the complete history every time, so re-delivery is the normal case and must be a no-op, not merely non-crashing. Array position is the only thing that orders the entries — every entry of one command shares a `createdAt` and `serviceCreatedAt` is not on the wire — so they are inserted in the order given and never sorted. +- Unknown credit and debit tags go to `entry_type_unknown` and `entry_type_value`, for re-decoding after an app upgrade. Known tags keep `BadgeService/Store.hs`'s spellings exactly. `credit(charge)`, `credit(transferIn)`, `debit(upgrade)` and `debit(transferOut)` are refused rather than coerced, matching `BadgeService/Service.hs`'s `statementEntryType`, which refuses to put any of them on the wire in the first place. -**Verify:** In `tests/BadgeTests.hs`: insert a statement, read back the last entry, and assert an `opening` entry resets the balance regardless of what preceded it; `createCodePayment` then `createPurchase` leaves one purchase row with status `issued`, both badge-type columns set and its `payment_id` pointing at a `settled` payment; a second `createPurchase` followed by `supersedePurchases` and `setShownPurchase` leaves exactly one `issued` row in the `paid` slot and one `superseded`, with `users.shown_badge_id` on the `issued` one; `createIssuance` writes one `badge_issuances` row with the credential and its period, and a second call for the following period leaves two rows; `getShownPurchase` returns the row `setShownPurchase` pointed at, with its private key intact. +**Verify:** In `tests/Bots/BadgeStoreTests.hs`, registered in the test stanza's `other-modules` and in `tests/Test.hs` under the **`Supporter badges store`** path inside the `testBracket` bracket, so CI runs it (§4 rules 7 and 8): insert a statement, read back the last entry, and assert an `opening` entry resets the balance regardless of what preceded it; `createCodePayment` then `createPurchase` leaves one purchase row with status `issued`, both badge-type columns set and its `payment_id` pointing at a `settled` payment; a second `createPurchase` followed by `supersedePurchases` and `setShownPurchase` leaves exactly one `issued` row in the `paid` slot and one `superseded`, with `users.shown_badge_id` on the `issued` one; `createIssuance` writes one `badge_issuances` row with the credential and its period, and a second call for the following period leaves two rows; `getShownPurchase` returns the row `setShownPurchase` pointed at, with its private key intact. #### C2 — Commands, responses, events, parsers, View @@ -1389,6 +1389,11 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **B10 — a signed RPC from an unknown purchase key is unthrottled and costs a database round trip.** `checkSignerRecord` runs `getPurchaseByKey` before any bucket is consulted, and §5 rules H1's per-IP limits inapplicable to the RPC path — so nothing is scheduled to close this. Availability only: the answer is `unknown_purchase_key` and leaks nothing, but a minted keypair buys an unbounded number of indexed lookups. **For H1**, and it needs a decision, since the per-signer bucket cannot bound a key that has never failed anything. - **B10 — B9's address file can go stale after all, in the one case its §9 entry does not cover.** That entry documents three *write* failure modes; this is a *read* failure. If `ShowMyAddress` fails transiently at startup, `publishServiceAddress` logs and returns without touching the file, so the previous contents survive — which is exactly the "never silently stale" property the entry claims. Rare and non-fatal (the address is also on stdout), but the claim is stated unconditionally. **For H5**, when the operator procedure is documented. - **B10 — §7's unlinkability does not hold against a TIMING adversary, and that is a disclosed limit, not a bug.** `codes.created_at` for a web order is within seconds of that order's `web_orders.settled_at`, and its `batch` is the literal `'web'`, so an adversary with the service database can correlate an order to the code row it produced — and thence, once redeemed, to `redeemed_purchase_id` — **with no `codeSecret` needed**. The cryptographic claim (an order id cannot be turned into a code without the secret) is unaffected; the correlational one is what breaks. Mitigations belong to E3/H5: coarsen `codes.created_at`, or drop the `'web'` batch label, or both. §7 should say "no *stored reference* links an order to a purchase" rather than claiming unlinkability outright. +- **C1 — the client store's tests are `tests/Bots/BadgeStoreTests.hs`, not `tests/BadgeTests.hs`.** The step's Files and Verify both named `BadgeTests.hs`, which is a plain `Spec` with no `TestParams` (A2); these tests need a migrated chat database with a `users` row, which that module has no way to provide. Registered instead under the `Supporter badges store` path *inside* `testBracket`, which is precisely the case §4 rule 8 already provides for ("a spec that needs `testBracket`'s controller but not the service goes under `Supporter badges` in its own module registered inside that bracket"), and which C3's brief anticipates for the same reason. No chat controller is started; only `createDatabase`/`createUserRecordAt` are used. Files and Verify corrected above. +- **C1 — the client purchase row is a new `UserBadgePurchase`, not `Types.BadgePurchase`.** `BadgePurchase` (`Badges/Types.hs:124`, still marked *to review*) declares `priceId`, `offerId` and `credential`, and none of the three is a column of the client's `badge_purchases`: price and offer live on `badge_invoices` rows (one per invoice, so not a function of the purchase) and the credential lives on `badge_issuances` rows (one per period). Returning it would mean inventing three fields the database does not hold. `Store/Badges.hs` therefore declares `UserBadgePurchase` with exactly the table's columns, the same decision `BadgeService.Store.BadgePurchaseRow` made on the service side. **C2 must build `UserBadgeState.badges` from that row plus its own joins**, or change `BadgePurchase` — either is fine, but it is C2's call, not a rename C1 could make blind. +- **C1 — `badge_purchases.user_id` and `purchase_priv_key` are nullable and read as `Maybe`.** `20260731_user_badges` adds both with `ALTER TABLE`, which cannot add a NOT NULL column without a default, so the schema cannot express the invariant that `createPurchase` (the only writer) always sets them. `getShownPurchase` names a NULL as `SEInternalError` rather than returning a purchase whose private key is missing — the key is the whole reason the row is read back. +- **C1 — deleting a stale ledger row could in principle violate `badge_issuances.entry_id`'s foreign key.** The REPLACE path deletes `badge_ledger` rows the service no longer holds, and `badge_issuances.entry_id REFERENCES badge_ledger` has no `ON DELETE` clause. Unreachable today, because nothing in this plan writes a non-NULL `entry_id` on the client (`NewBadgeIssuance.ledgerEntryId` exists to mirror the service's record and C3 passes `Nothing`), and it can only arise if the service both drops an already-issued entry and the client had linked an issuance to it. **For C3**, which decides whether to link issuances to local ledger rows at all: if it does, the REPLACE path must null those references before deleting. +- **C1 — `payments.provider` is still written as a bare `'code'` literal on both sides.** `PaymentProvider` (`PaymentService/Types.hs:36`) has no `TextEncoding`, so `Store/Badges.hs` repeats `BadgeService/Store.hs`'s `codePaymentProviderText`. Two literals, one spelling, in two different databases that are never compared. **For D0/E2/F1**, as that entry already says: the instance should be added when a second provider needs writing. ## 10. End-to-end verification diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 6711aa15fa..880a583b1b 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -80,6 +80,7 @@ library Simplex.Chat.Stats Simplex.Chat.Store Simplex.Chat.Store.AppSettings + Simplex.Chat.Store.Badges Simplex.Chat.Store.Connections Simplex.Chat.Store.ContactRequest Simplex.Chat.Store.Delivery @@ -714,6 +715,7 @@ test-suite simplex-chat-test Bots.BadgeCodeTests Bots.BadgeLedgerTests Bots.BadgeServiceTests + Bots.BadgeStoreTests Broadcast.Bot Broadcast.Options Directory.BlockedWords diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs new file mode 100644 index 0000000000..91bd2b4cbd --- /dev/null +++ b/src/Simplex/Chat/Store/Badges.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | The CLIENT's badge store: the user's purchases, the payment row a code redemption writes, +-- the issuances the worker collects and the ledger replica the service sends. +-- +-- The tables are the ones @badgeSchema@ creates +-- ("Simplex.Chat.Store.SQLite.Migrations.M20260731_user_badges"), unprefixed, plus the +-- client-only columns that migration ALTERs in: @badge_purchases.user_id@\/@purchase_priv_key@, +-- @badge_ledger.entry_type_unknown@\/@entry_type_value@ and @users.shown_badge_id@. The service +-- has the same tables under its own prefix, so "BadgeService.Store" is the mirror of this module +-- and the column spellings of every status and entry type are deliberately identical to its +-- 'BadgeService.Store.encodeLedgerEntryType'\/'BadgeService.Store.decodeLedgerEntryType'; a second +-- spelling of @credit@\/@support@\/@opening@\/@lapse@ would be a defect, not a style choice. +-- +-- Two things this module is NOT: +-- +-- * It is not an author of ledger entries. The service writes the ledger (docs\/protocol +-- \/badges-rpc.md, "The ledger is written by the service alone"); the client keeps a verbatim +-- replica, so 'insertLedgerEntries' copies what it is given and mints nothing. @entry_uuid@ in +-- particular is the service's, never generated here. +-- +-- * It opens no transaction. Every function takes a 'DB.Connection', as the rest of +-- "Simplex.Chat.Store" does, so a caller composes a payment row, a purchase row, the ledger +-- rows, an issuance and the shown-badge pointer into one @withStore@ transaction. +module Simplex.Chat.Store.Badges + ( -- * Purchases and payments + UserBadgePurchase (..), + BadgeSlot (..), + badgeSlot, + createCodePayment, + createPurchase, + supersedePurchases, + setShownPurchase, + getShownPurchase, + + -- * Issuances + NewBadgeIssuance (..), + createIssuance, + + -- * Ledger + getLastBadgeLedgerEntry, + insertLedgerEntries, + ) +where + +import Control.Monad (forM_, unless) +import Control.Monad.Except (ExceptT, liftEither) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as J +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Int (Int64) +import Data.List (isPrefixOf) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time.Clock (UTCTime) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID +import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType (..)) +import Simplex.Chat.Badges.Service + ( BadgeStatement (..), + StatementCreditType (..), + StatementDebitType (..), + StatementEntry (..), + StatementEntryType (..), + ) +import Simplex.Chat.Badges.Types + ( BadgeIssuance (..), + BadgeLedgerEntry (..), + BadgePurchaseStatus (..), + LedgerCreditType (..), + LedgerDebitType (..), + LedgerEntryType (..), + ) +import Simplex.Chat.PaymentService.Types (PaymentStatus (..)) +import Simplex.Chat.Store.Shared (StoreError (..)) +import Simplex.Messaging.Agent.Protocol (UserId) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import qualified Simplex.Messaging.Crypto as C +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..)) +import Database.PostgreSQL.Simple.SqlQQ (sql) +#else +import Database.SQLite.Simple (Only (..), Query, (:.) (..)) +import Database.SQLite.Simple.QQ (sql) +#endif + +-- Purchases and payments ------------------------------------------------------ + +-- | The client's own projection of a @badge_purchases@ row: exactly its columns, with the +-- client-only @user_id@ and @purchase_priv_key@ that the service's table does not have. +-- +-- This is deliberately NOT 'Simplex.Chat.Badges.Types.BadgePurchase'. That record declares +-- @priceId@, @offerId@ and @credential@, none of which is a column of this table: the price and +-- offer of a purchase live on its @badge_invoices@ rows (one per invoice, so not a function of +-- the purchase), and the credential lives on its @badge_issuances@ rows (one per period). A row +-- type that had to invent three fields to be constructed would report a purchase the database +-- does not hold. 'BadgeService.Store.BadgePurchaseRow' is the same decision on the service side. +data UserBadgePurchase = UserBadgePurchase + { badgePurchaseId :: Int64, + userId :: UserId, + purchaseKey :: C.PublicKeyEd25519, + purchasePrivKey :: C.PrivateKeyEd25519, + masterKey :: BadgeMasterKey, + initialBadgeType :: BadgeType, + currentBadgeType :: BadgeType, + paymentId :: Maybe Text, + status :: BadgePurchaseStatus, + createdAt :: UTCTime, + updatedAt :: UTCTime + } + deriving (Show) + +-- | The badge a purchase occupies on a profile (plan §3): @paid@ for @supporter@ and @legend@, +-- @investor@ for @investor@. It is derived from @current_badge_type@; no column stores it. At +-- most one purchase per slot is 'PSIssued' at a time, which is what 'supersedePurchases' +-- maintains. A badge type this build does not know keeps its own slot rather than joining +-- @paid@: superseding a purchase because of a tag we cannot interpret would remove a badge the +-- user paid for. +data BadgeSlot = BSPaid | BSInvestor | BSOther Text + deriving (Eq, Show) + +badgeSlot :: BadgeType -> BadgeSlot +badgeSlot = \case + BTSupporter -> BSPaid + BTLegend -> BSPaid + BTInvestor -> BSInvestor + BTUnknown tag -> BSOther tag + +-- | @payments.provider@ has no column codec yet: 'Simplex.Chat.PaymentService.Types.PaymentProvider' +-- has no 'TextEncoding' instance, and adding one is D0\/E2\/F1's, once a second provider needs +-- writing. Until then this literal is the client twin of +-- 'BadgeService.Store.codePaymentProviderText' and must keep the same spelling. +codePaymentProviderText :: Text +codePaymentProviderText = "code" + +-- | The @payments@ row of a code redemption: a caller-minted UUID (the column is +-- @TEXT NOT NULL PRIMARY KEY@ with no default), @provider = 'code'@, no invoice — a code +-- payment never has one — and @settled@, because a redeemed code is paid for by definition. +-- Returns the id, which 'createPurchase' takes. +-- +-- This row is the CLIENT's and is unrelated to the service's own @payments@ row for the same +-- redemption: the two databases share only the ledger entries, and even there the client's +-- @payment_id@ is NULL (see 'insertLedgerEntries'). +createCodePayment :: DB.Connection -> UTCTime -> IO Text +createCodePayment db now = do + paymentId <- UUID.toText <$> UUID.nextRandom + DB.execute + db + [sql| + INSERT INTO payments (payment_id, invoice_id, provider, status, created_at, updated_at) + VALUES (?,?,?,?,?,?) + |] + (paymentId, Nothing :: Maybe Text, codePaymentProviderText, PSSettled, now, now) + pure paymentId + +-- | The purchase row of a code redemption, written on success only: a code redemption does not +-- learn its badge type until the response arrives, and @initial_badge_type@\/@current_badge_type@ +-- are both NOT NULL with no default. Nothing is persisted before the send; a response lost in +-- flight is recovered with @codes unredeem@, not by reusing a stored key. +-- +-- The status is 'PSIssued' directly, not 'PSAcquiring': the credential is in hand by the time +-- this runs. +createPurchase :: DB.Connection -> UserId -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> BadgeMasterKey -> BadgeType -> Text -> UTCTime -> IO UserBadgePurchase +createPurchase db userId purchaseKey purchasePrivKey masterKey@(BadgeMasterKey mk) badgeType paymentId now = do + [Only badgePurchaseId] <- + DB.query + db + [sql| + INSERT INTO badge_purchases + (user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, payment_id, status, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?) + RETURNING badge_purchase_id + |] + ((userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType, paymentId) :. (PSIssued, now, now)) + pure + UserBadgePurchase + { badgePurchaseId, + userId, + purchaseKey, + purchasePrivKey, + masterKey, + initialBadgeType = badgeType, + currentBadgeType = badgeType, + paymentId = Just paymentId, + status = PSIssued, + createdAt = now, + updatedAt = now + } + +-- | Moves every OTHER 'PSIssued' purchase of the same slot for this user to 'PSSuperseded', so +-- the slot has exactly one issued purchase again. The superseded row keeps its unconsumed +-- months: purchases are unlinkable, so the service cannot move a balance between them. +-- +-- The slot filter is applied in Haskell rather than as a SQL @IN@ over the slot's badge types: +-- @IN ?@ with a list is postgresql-simple's 'Database.PostgreSQL.Simple.In', which +-- sqlite-simple has no counterpart for, and a user holds at most a handful of purchases. +supersedePurchases :: DB.Connection -> UserId -> Int64 -> BadgeType -> UTCTime -> IO () +supersedePurchases db userId keepPurchaseId badgeType now = do + rows <- + DB.query + db + "SELECT badge_purchase_id, current_badge_type FROM badge_purchases WHERE user_id = ? AND status = ? AND badge_purchase_id <> ?" + (userId, PSIssued, keepPurchaseId) + let slot = badgeSlot badgeType + superseded = [pId | (pId :: Int64, bt) <- rows, badgeSlot bt == slot] + forM_ superseded $ \pId -> + DB.execute + db + "UPDATE badge_purchases SET status = ?, updated_at = ? WHERE badge_purchase_id = ?" + (PSSuperseded, now, pId) + +-- | Points @users.shown_badge_id@ at a purchase. Separate from +-- 'Simplex.Chat.Store.Profiles.setUserBadge', which writes the profile's badge columns: this +-- one records WHICH purchase the profile's badge came from, which is what +-- 'getShownPurchase' reads back to sign the next @issueBadge@. +setShownPurchase :: DB.Connection -> UserId -> Int64 -> IO () +setShownPurchase db userId badgePurchaseId = + DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (badgePurchaseId, userId) + +purchaseSelectColumns :: Query +purchaseSelectColumns = + "p.badge_purchase_id, p.user_id, p.purchase_key, p.purchase_priv_key, p.master_key, " + <> "p.initial_badge_type, p.current_badge_type, p.payment_id, p.status, p.created_at, p.updated_at" + +type PurchaseRow = + (Int64, Maybe UserId, C.PublicKeyEd25519, Maybe C.PrivateKeyEd25519, Binary ByteString) + :. (BadgeType, BadgeType, Maybe Text, BadgePurchaseStatus, UTCTime, UTCTime) + +-- | @user_id@ and @purchase_priv_key@ are nullable only because @20260731_user_badges@ adds them +-- with @ALTER TABLE@, which cannot add a NOT NULL column without a default. 'createPurchase' is +-- the only writer and always sets both, so a NULL is a corrupt row and is named as one rather +-- than being turned into a purchase whose key is missing — the private key is the whole point of +-- reading this row back. +rowToPurchase :: PurchaseRow -> Either StoreError UserBadgePurchase +rowToPurchase ((badgePurchaseId, userId_, purchaseKey, purchasePrivKey_, Binary mk) :. (initialBadgeType, currentBadgeType, paymentId, status, createdAt, updatedAt)) = + case (userId_, purchasePrivKey_) of + (Just userId, Just purchasePrivKey) -> + Right + UserBadgePurchase + { badgePurchaseId, + userId, + purchaseKey, + purchasePrivKey, + masterKey = BadgeMasterKey mk, + initialBadgeType, + currentBadgeType, + paymentId, + status, + createdAt, + updatedAt + } + _ -> + Left . SEInternalError $ + "badge purchase " <> show badgePurchaseId <> " has no user_id or purchase_priv_key" + +-- | The purchase @users.shown_badge_id@ points at, with its keypair and badge master key — +-- what the badge screen renders and what the worker signs @issueBadge@ with. 'Nothing' when the +-- user has no badge, which is the ordinary case. +getShownPurchase :: DB.Connection -> UserId -> ExceptT StoreError IO (Maybe UserBadgePurchase) +getShownPurchase db userId = do + rows <- + liftIO $ + DB.query + db + ( "SELECT " + <> purchaseSelectColumns + <> " FROM badge_purchases p JOIN users u ON u.shown_badge_id = p.badge_purchase_id WHERE u.user_id = ?" + ) + (Only userId) + liftEither $ mapM rowToPurchase (listToMaybe rows) + +-- Issuances ------------------------------------------------------------------- + +-- | Fields for one @badge_issuances@ row. As on the service side, the period and expiry are +-- definite here, matching the NOT NULL columns; 'BadgeIssuance' declares them 'Maybe' only +-- because it is also a wire shape. +data NewBadgeIssuance = NewBadgeIssuance + { badgePurchaseId :: Int64, + badgeType :: BadgeType, + periodStart :: UTCTime, + periodEnd :: UTCTime, + expiry :: UTCTime, + -- | The @badge_ledger.entry_id@ this issuance was debited by, when the caller has it. + -- Named apart from 'BadgeIssuance'\'s @entryId@ (the same column) so the two do not collide + -- as bare selectors under @DuplicateRecordFields@. + ledgerEntryId :: Maybe Int64, + credential :: BadgeCredential + } + +-- | Writes one issuance, minting its @issuance_id@ (the column is @TEXT NOT NULL PRIMARY KEY@ +-- with no default). One row per period: the worker calls this again for each new period, so a +-- purchase accumulates issuances rather than replacing one. +-- +-- The credential is stored as its own JSON encoding, the same one it crosses the wire in, so +-- there is no second, database-only codec for it to drift from. +createIssuance :: DB.Connection -> NewBadgeIssuance -> UTCTime -> IO BadgeIssuance +createIssuance db NewBadgeIssuance {badgePurchaseId, badgeType, periodStart, periodEnd, expiry, ledgerEntryId, credential} now = do + issuanceId <- UUID.toText <$> UUID.nextRandom + DB.execute + db + [sql| + INSERT INTO badge_issuances + (issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at) + VALUES (?,?,?,?,?,?,?,?,?) + |] + (issuanceId, badgePurchaseId, ledgerEntryId, badgeType, periodStart, periodEnd, expiry, Binary (LB.toStrict (J.encode credential)), now) + pure + BadgeIssuance + { issuanceId, + badgePurchaseId, + badgeType, + periodStart = Just periodStart, + periodEnd = Just periodEnd, + expiry = Just expiry, + entryId = ledgerEntryId, + credential, + createdAt = now + } + +-- Ledger ---------------------------------------------------------------------- + +-- | @entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id, from_purchase_id, +-- to_purchase_id, entry_type_unknown, entry_type_value@. +-- +-- The first seven are 'BadgeService.Store.LedgerTypeRow' exactly, spelling for spelling. The +-- last two are the client-only fallback columns @20260731_user_badges@ adds: a service ahead of +-- this build can send an entry type this build has no constructor for, and the client stores it +-- as received so a later version can decode it (docs\/protocol\/badges-rpc.md: "An unknown type +-- is stored as received and decoded after an app upgrade"). The service, authoring every entry +-- it writes, never needs them and its table does not have them. +type LedgerTypeRow = (Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe Int64, Maybe Int64, BoolInt, Maybe Text) + +type LedgerCoreRow = (Int64, Text, Int64, Int, Int, UTCTime, BadgeType, Maybe UTCTime, UTCTime, UTCTime) + +ledgerSelectColumns :: Query +ledgerSelectColumns = + "entry_id, entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_badge_type, was_paused_since, service_created_at, created_at, " + <> "entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id, from_purchase_id, to_purchase_id, entry_type_unknown, entry_type_value" + +-- | The wire entry type as the client stores it: the inverse of +-- 'BadgeService.Service.statementEntryType'. +-- +-- @payment@ becomes @'CTPayment' 'Nothing'@ and the wire's @invoiceId@ is DROPPED, which is not +-- a loss of information the client can hold: @badge_ledger.payment_id@ references @payments@, +-- and a code redemption writes no client @payments@ row for the SERVICE's payment — that row +-- exists only in the service database, and the wire carries no id for it. Inventing one would +-- make the column a dangling reference (plan §9, and §10's cross-database invariant, which +-- excludes @payment_id@ for exactly this reason). +-- +-- @charge@, @transferIn@, @upgrade@ and @transferOut@ are refused, matching +-- 'BadgeService.Service.statementEntryType', which refuses to put any of them on the wire in the +-- first place, so nothing can send one. @charge@'s @chargeId@ is 'Int64' against a TEXT column +-- (an unresolved type mismatch, plan §9) and the other three carry a purchase KEY where the +-- column holds a purchase id; both would need a coercion this plan has not decided, and +-- subscriptions, upgrades and transfers are out of scope (§6). +storedEntryType :: StatementEntryType -> Either StoreError LedgerEntryType +storedEntryType = \case + SECredit creditType -> LECredit <$> case creditType of + SCPayment {} -> Right CTPayment {paymentId = Nothing} + SCSupport -> Right CTSupport + SCOpening -> Right CTOpening + SCUnknown {tag, json} -> Right CTUnknown {tag, json} + SCCharge {} -> unsupported "credit(charge)" "chargeId is Int64 against the charge_id TEXT column; subscriptions are out of scope" + SCTransferIn {} -> unsupported "credit(transferIn)" "carries a purchase key where from_purchase_id holds a purchase id; transfers are out of scope" + SEDebit debitType -> LEDebit <$> case debitType of + SDRefund -> Right DTRefund + SDSupport -> Right DTSupport + SDBadge -> Right DTBadge + SDLapse -> Right DTLapse + SDUnknown {tag, json} -> Right DTUnknown {tag, json} + SDUpgrade {} -> unsupported "debit(upgrade)" "carries a purchase key where to_purchase_id holds a purchase id; upgrades are out of scope" + SDTransferOut {} -> unsupported "debit(transferOut)" "carries a purchase key where to_purchase_id holds a purchase id; transfers are out of scope" + where + unsupported what why = Left . SEInternalError $ "cannot store badge ledger " <> what <> ": " <> why + +-- | Known tags are spelled exactly as 'BadgeService.Store.encodeLedgerEntryType' spells them — +-- the two stores write the same columns of the same schema, and the service reads back what it +-- wrote. An unknown tag keeps its own spelling in @entry_credit_type@\/@entry_debit_type@ and +-- its whole object in @entry_type_value@, flagged by @entry_type_unknown@, which is what makes +-- 'decodeLedgerEntryType' able to hand it back unchanged after an upgrade. +encodeLedgerEntryType :: LedgerEntryType -> Either StoreError LedgerTypeRow +encodeLedgerEntryType = \case + LECredit creditType -> case creditType of + CTPayment {paymentId} -> Right ("credit", Just "payment", Nothing, paymentId, Nothing, Nothing, Nothing, BI False, Nothing) + CTSupport -> Right ("credit", Just "support", Nothing, Nothing, Nothing, Nothing, Nothing, BI False, Nothing) + CTTransferIn {fromPurchaseId} -> Right ("credit", Just "transfer_in", Nothing, Nothing, Nothing, fromPurchaseId, Nothing, BI False, Nothing) + CTOpening -> Right ("credit", Just "opening", Nothing, Nothing, Nothing, Nothing, Nothing, BI False, Nothing) + CTUnknown {tag, json} -> Right ("credit", Just tag, Nothing, Nothing, Nothing, Nothing, Nothing, BI True, Just (encodeUnknown json)) + CTCharge {} -> Left $ SEInternalError "cannot store badge ledger credit(charge): chargeId is Int64 against the charge_id TEXT column" + LEDebit debitType -> case debitType of + DTRefund -> Right ("debit", Nothing, Just "refund", Nothing, Nothing, Nothing, Nothing, BI False, Nothing) + DTUpgrade {toPurchaseId} -> Right ("debit", Nothing, Just "upgrade", Nothing, Nothing, Nothing, Just toPurchaseId, BI False, Nothing) + DTTransferOut {toPurchaseId} -> Right ("debit", Nothing, Just "transfer_out", Nothing, Nothing, Nothing, Just toPurchaseId, BI False, Nothing) + DTSupport -> Right ("debit", Nothing, Just "support", Nothing, Nothing, Nothing, Nothing, BI False, Nothing) + DTBadge -> Right ("debit", Nothing, Just "badge", Nothing, Nothing, Nothing, Nothing, BI False, Nothing) + DTLapse -> Right ("debit", Nothing, Just "lapse", Nothing, Nothing, Nothing, Nothing, BI False, Nothing) + DTUnknown {tag, json} -> Right ("debit", Nothing, Just tag, Nothing, Nothing, Nothing, Nothing, BI True, Just (encodeUnknown json)) + +-- | @entry_type_value@ holds the entry type's whole JSON object, including its own @type@ key, +-- because that object is what 'Simplex.Chat.Badges.Service.SCUnknown' re-encodes verbatim. The +-- column is TEXT and aeson emits UTF-8, so it round-trips through 'decodeUnknown'. +encodeUnknown :: J.Object -> Text +encodeUnknown = decodeUtf8 . LB.toStrict . J.encode . J.Object + +decodeUnknown :: Text -> Maybe J.Object +decodeUnknown = J.decodeStrict . encodeUtf8 + +-- | Reads back what 'encodeLedgerEntryType' wrote. The unknown flag is checked FIRST: a service +-- ahead of this build could use a tag this build later learns, and the flag records what this +-- row actually was when it was stored. +decodeLedgerEntryType :: LedgerTypeRow -> Either StoreError LedgerEntryType +decodeLedgerEntryType row = case row of + ("credit", Just tag, _, _, _, _, _, BI True, Just v) -> unknownCredit tag v + ("debit", _, Just tag, _, _, _, _, BI True, Just v) -> unknownDebit tag v + -- payment_id is read whether or not it is there: a client-written entry always holds NULL. + ("credit", Just "payment", _, paymentId, _, _, _, _, _) -> Right $ LECredit CTPayment {paymentId} + ("credit", Just "support", _, _, _, _, _, _, _) -> Right $ LECredit CTSupport + ("credit", Just "transfer_in", _, _, _, fromPurchaseId, _, _, _) -> Right $ LECredit CTTransferIn {fromPurchaseId} + ("credit", Just "opening", _, _, _, _, _, _, _) -> Right $ LECredit CTOpening + ("debit", _, Just "refund", _, _, _, _, _, _) -> Right $ LEDebit DTRefund + ("debit", _, Just "upgrade", _, _, _, Just toPurchaseId, _, _) -> Right $ LEDebit DTUpgrade {toPurchaseId} + ("debit", _, Just "transfer_out", _, _, _, Just toPurchaseId, _, _) -> Right $ LEDebit DTTransferOut {toPurchaseId} + ("debit", _, Just "support", _, _, _, _, _, _) -> Right $ LEDebit DTSupport + ("debit", _, Just "badge", _, _, _, _, _, _) -> Right $ LEDebit DTBadge + ("debit", _, Just "lapse", _, _, _, _, _, _) -> Right $ LEDebit DTLapse + (entryType, creditType, debitType, _, _, _, _, BI unknown, _) -> + Left . SEInternalError $ + "malformed badge ledger entry type row: " <> show (entryType, creditType, debitType, unknown) + where + unknownCredit tag v = maybe (badValue tag) (\json -> Right $ LECredit CTUnknown {tag, json}) (decodeUnknown v) + unknownDebit tag v = maybe (badValue tag) (\json -> Right $ LEDebit DTUnknown {tag, json}) (decodeUnknown v) + badValue tag = Left . SEInternalError $ "badge ledger entry_type_value is not a JSON object, tag: " <> T.unpack tag + +rowToLedgerEntry :: (LedgerCoreRow :. LedgerTypeRow) -> Either StoreError BadgeLedgerEntry +rowToLedgerEntry ((entryId, entryUuid, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, createdAt) :. typeRow) = do + entryType <- decodeLedgerEntryType typeRow + Right BadgeLedgerEntry {entryId, entryUuid, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, createdAt, entryType} + +-- | The purchase's last entry: its @balanceMonths@ and @balanceStartTs@ are the balance the +-- client believes it holds, which is what the worker asserts to the service and what the badge +-- screen's paid-through date is computed from. Ordered by @entry_id@, which is the order +-- 'insertLedgerEntries' wrote the statement in. +getLastBadgeLedgerEntry :: DB.Connection -> Int64 -> ExceptT StoreError IO (Maybe BadgeLedgerEntry) +getLastBadgeLedgerEntry db badgePurchaseId = do + rows <- + liftIO $ + DB.query + db + ("SELECT " <> ledgerSelectColumns <> " FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id DESC LIMIT 1") + (Only badgePurchaseId) + liftEither $ mapM rowToLedgerEntry (listToMaybe rows) + +-- | Copies a statement's entries into the client's replica of the service's ledger. +-- +-- __Order is carried only by array position.__ Every entry the service writes for one command +-- gets an identical @createdAt@, and @serviceCreatedAt@ is not on the wire at all, so +-- @statement.entries@ is inserted in the order given and @entry_id@ (the local autoincrement) is +-- the only thing that records it. Sorting by any timestamp would silently scramble the ledger. +-- +-- __@previousEntryId@ decides REPLACE against APPEND.__ Present, it names an entry the client +-- already holds and the entries attach after it; absent with entries present, the entries +-- "attach to nothing" (docs\/protocol\/badges-rpc.md) — they are the COMPLETE ledger for this +-- purchase, and anything the client holds that the statement does not carry is stale and is +-- deleted. Appending on an absent @previousEntryId@ would leave a client that had healed or +-- reset holding rows the service no longer has. A statement with no entries at all changes +-- nothing either way: it attaches nothing and is not a claim that the ledger is empty. +-- +-- REPLACE is expressed as "delete what the statement does not carry, then insert what it does", +-- not as a wipe-and-rewrite, so rows the service is merely re-sending keep their local +-- @entry_id@ — @badge_issuances.entry_id@ references them. When the surviving rows are not a +-- prefix of the delivered entries (a ledger the service rewrote rather than extended) they are +-- all dropped instead, so the re-inserted entries cannot end up out of order. +-- +-- __Re-delivery is normal, not exceptional.__ @purchaseBadge@ and @getBadgeCatalog@ return the +-- complete history every time; only @issueBadge@ honours a cursor. Insertion is therefore +-- @ON CONFLICT (entry_uuid) DO NOTHING@ against @idx_badge_ledger_uuid@ — a second delivery of +-- the same statement writes nothing and changes nothing, rather than merely not crashing. +insertLedgerEntries :: DB.Connection -> Int64 -> BadgeStatement -> UTCTime -> ExceptT StoreError IO () +insertLedgerEntries db badgePurchaseId BadgeStatement {entries, previousEntryId} now = do + rows <- liftEither $ mapM entryRow entries + liftIO $ do + case previousEntryId of + Just _ -> pure () + Nothing -> unless (null entries) $ dropStaleEntries (map statementEntryId entries) + forM_ rows $ \row -> + DB.execute + db + [sql| + INSERT INTO badge_ledger + (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_badge_type, was_paused_since, service_created_at, created_at, + entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id, from_purchase_id, to_purchase_id, entry_type_unknown, entry_type_value) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + ON CONFLICT (entry_uuid) DO NOTHING + |] + row + where + statementEntryId StatementEntry {entryId} = entryId + -- service_created_at is the service's own clock, which the wire reports as the entry's + -- createdAt; created_at is this client's, i.e. when the row was replicated. Keeping them + -- apart is what lets the two databases be compared on the service's timestamp. + entryRow StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, createdAt, entryType} = do + typeRow <- encodeLedgerEntryType =<< storedEntryType entryType + Right $ + (entryId, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, createdAt, now) + :. typeRow + dropStaleEntries uuids = do + held <- + map fromOnly + <$> DB.query + db + "SELECT entry_uuid FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id ASC" + (Only badgePurchaseId) + let kept = filter (`elem` uuids) held + stale + | kept `isPrefixOf` uuids = filter (`notElem` uuids) held + | otherwise = held + forM_ stale $ \entryUuid -> + DB.execute db "DELETE FROM badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?" (badgePurchaseId, entryUuid) diff --git a/tests/Bots/BadgeStoreTests.hs b/tests/Bots/BadgeStoreTests.hs new file mode 100644 index 0000000000..75dbfa7907 --- /dev/null +++ b/tests/Bots/BadgeStoreTests.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for the CLIENT badge store ("Simplex.Chat.Store.Badges"): the purchase and payment +-- rows a code redemption writes, the issuances the worker collects, and the replica of the +-- service's ledger. +-- +-- Registered under the "Supporter badges" hspec path so CI runs it (plan §4 rule 8), but inside +-- 'testBracket': unlike the other two client-side badge modules these tests need a real chat +-- database with a @users@ row, which the plain 'Spec' in "BadgeTests" has no way to provide. +-- No chat controller is started and no service is involved -- the store is exercised directly +-- over a migrated chat database. +-- +-- Field selectors are used through record PATTERNS throughout rather than as bare functions: +-- 'StatementEntry' (the wire entry) and 'BadgeLedgerEntry' (the stored one) share almost every +-- field name, and both must be imported with @(..)@ for record construction to resolve, which +-- makes every bare selector ambiguous. +module Bots.BadgeStoreTests (badgeStoreTests) where + +import ChatClient +import ChatTests.DBUtils +import ChatTests.Utils +import Control.Concurrent.STM (atomically) +import Control.Exception (finally) +import Control.Monad.Except (ExceptT, runExceptT) +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as JM +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Maybe (isNothing) +import Data.Text (Text) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), addUTCTime, getCurrentTime, nominalDay, secondsToDiffTime) +import Simplex.Chat.Badges (BadgeCredential, BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment) +import Simplex.Chat.Badges.Service + ( BadgeStatement (..), + StatementCreditType (..), + StatementDebitType (..), + StatementEntry (..), + StatementEntryType (..), + ) +import Simplex.Chat.Badges.Types + ( BadgeIssuance (..), + BadgeLedgerEntry (..), + BadgePurchaseStatus (..), + LedgerCreditType (..), + LedgerDebitType (..), + LedgerEntryType (..), + ) +import Simplex.Chat.Controller (ChatDatabase (..)) +import Simplex.Chat.Store.Badges +import Simplex.Chat.Store.Profiles (createUserRecordAt) +import Simplex.Chat.Store.Shared (StoreError) +import Simplex.Chat.Types (AgentUserId (..), Profile (..), User (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import Simplex.Messaging.Agent.Store.DB (Binary (..)) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Agent.Store.Interface (closeDBStore) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (bbsKeyGen) +import Test.Hspec hiding (it) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..)) +#else +import Database.SQLite.Simple (Only (..)) +#endif + +badgeStoreTests :: SpecWith TestParams +badgeStoreTests = do + describe "client badge ledger" $ do + it "reads back the last entry of a statement, and an opening entry restates the balance absolutely" testOpeningRestatesBalance + it "preserves the statement's array order when every entry shares one createdAt" testEntryOrderFromArrayPosition + it "re-delivering the same complete statement writes nothing and changes nothing" testStatementRedeliveryIsIdempotent + it "a statement with no previousEntryId replaces the ledger, dropping entries the service no longer holds" testStatementWithoutCursorReplaces + it "appends after previousEntryId without touching the entries already held" testStatementWithCursorAppends + it "stores an unrecognised entry tag verbatim and hands it back unchanged" testUnknownEntryTypeRoundTrip + it "refuses a charge credit rather than coercing its id into the charge_id TEXT column" testChargeCreditRefused + describe "client badge purchases" $ do + it "createCodePayment and createPurchase leave one issued purchase paid for by a settled code payment" testCodePaymentAndPurchase + it "supersedePurchases clears the paid slot only, and setShownPurchase points at the new purchase" testSupersedeAndShownBadge + it "getShownPurchase returns the purchase with its private key intact" testGetShownPurchaseKeepsPrivateKey + describe "client badge issuances" $ + it "createIssuance writes one row per period" testIssuancePerPeriod + +-- Fixtures -------------------------------------------------------------------- + +-- | A migrated chat database with one user, and nothing else: no controller, no agent, no SMP. +withBadgeStore :: TestParams -> (DBStore -> User -> IO a) -> IO a +withBadgeStore ps action = do + Right ChatDatabase {chatStore, agentStore} <- createDatabase ps testCoreOpts "badge_store" + insertUser agentStore + ts <- getCurrentTime + Right user <- + withTransaction chatStore $ \db -> + runExceptT $ createUserRecordAt db (AgentUserId 1) False False aliceProfile {preferences = Nothing} True ts + action chatStore user `finally` (closeDBStore chatStore >> closeDBStore agentStore) + +storeIO :: DBStore -> (DB.Connection -> IO a) -> IO a +storeIO = withTransaction + +storeE :: DBStore -> (DB.Connection -> ExceptT StoreError IO a) -> IO a +storeE st action = withTransaction st (runExceptT . action) >>= either (fail . show) pure + +storeErr :: DBStore -> (DB.Connection -> ExceptT StoreError IO a) -> IO StoreError +storeErr st action = + withTransaction st (runExceptT . action) >>= \case + Left e -> pure e + Right _ -> fail "expected the store to refuse this write" + +epoch :: UTCTime +epoch = UTCTime (fromGregorian 2026 1 4) (secondsToDiffTime 0) + +-- | Stands in for the client's own clock where a test asserts @created_at@ back. A whole-second +-- time, not 'getCurrentTime': Postgres @TIMESTAMPTZ@ keeps microseconds and 'getCurrentTime' has +-- nanosecond resolution on Linux, so a wall-clock instant does not survive the round trip on +-- one of the two backends. +replicatedAt :: UTCTime +replicatedAt = UTCTime (fromGregorian 2026 1 5) (secondsToDiffTime 3600) + +-- | One statement entry. @createdAt@ is the SERVICE's clock and is deliberately the same for +-- every entry of a statement, which is what the service writes (plan §9): order lives in the +-- array, not in the timestamps. +entry :: Text -> Int -> Int -> StatementEntryType -> StatementEntry +entry entryId changeMonths balanceMonths entryType = + StatementEntry + { entryId, + changeMonths, + balanceMonths, + balanceStartTs = epoch, + balanceBadgeType = BTSupporter, + wasPausedSince = Nothing, + createdAt = epoch, + entryType + } + +fullStatement :: [StatementEntry] -> BadgeStatement +fullStatement entries = BadgeStatement {entries, previousEntryId = Nothing} + +testCredential :: BadgeType -> UTCTime -> IO BadgeCredential +testCredential badgeType expiry = do + Right (_pk, sk) <- bbsKeyGen + drg <- C.newRandom + mk <- generateMasterKey drg + let req = BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType, badgeExpiry = Just expiry, badgeExtra = ""}} + Just vreq <- verifyPayment (BPRedeemCode "TEST") req + Right cred <- issueBadge 1 sk vreq + pure cred + +-- | A purchase row with its payment, as a code redemption writes them. +newCodePurchase :: DBStore -> User -> BadgeType -> IO UserBadgePurchase +newCodePurchase st User {userId} badgeType = do + drg <- C.newRandom + (pubKey, privKey) <- atomically $ C.generateKeyPair drg + mk <- generateMasterKey drg + now <- getCurrentTime + storeIO st $ \db -> do + paymentId <- createCodePayment db now + createPurchase db userId pubKey privKey mk badgeType paymentId now + +purchaseId :: UserBadgePurchase -> Int64 +purchaseId UserBadgePurchase {badgePurchaseId} = badgePurchaseId + +purchaseStatuses :: DBStore -> IO [(Int64, Text, Text)] +purchaseStatuses st = + storeIO st $ \db -> + DB.query_ db "SELECT badge_purchase_id, current_badge_type, status FROM badge_purchases ORDER BY badge_purchase_id ASC" + +ledgerUuids :: DBStore -> Int64 -> IO [Text] +ledgerUuids st pId = + map fromOnly + <$> storeIO + st + (\db -> DB.query db "SELECT entry_uuid FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id ASC" (Only pId)) + +ledgerRows :: DBStore -> Int64 -> IO [(Int64, Text, Int, Int)] +ledgerRows st pId = + storeIO + st + ( \db -> + DB.query + db + "SELECT entry_id, entry_uuid, change_months, balance_months FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id ASC" + (Only pId) + ) + +-- Ledger ---------------------------------------------------------------------- + +-- | The statement's balances are the SERVICE's and are stored as stated. The @opening@ entry +-- here restates the balance as 12 after a history that ran it down to 2 -- and its own +-- @changeMonths@ is 0, so a store that derived the balance from the entries instead of copying +-- what each one states would land on 2, not 12. +testOpeningRestatesBalance :: HasCallStack => TestParams -> IO () +testOpeningRestatesBalance ps = withBadgeStore ps $ \st user -> do + pId <- purchaseId <$> newCodePurchase st user BTSupporter + let now = replicatedAt + statement = + fullStatement + [ entry "uuid-1" 3 3 (SECredit SCPayment {invoiceId = Nothing}), + entry "uuid-2" (-1) 2 (SEDebit SDBadge), + entry "uuid-3" 0 12 (SECredit SCOpening) + ] + storeE st $ \db -> insertLedgerEntries db pId statement now + Just BadgeLedgerEntry {entryUuid, balanceMonths, changeMonths, entryType, serviceCreatedAt, createdAt} <- + storeE st (`getLastBadgeLedgerEntry` pId) + entryUuid `shouldBe` "uuid-3" + balanceMonths `shouldBe` 12 + changeMonths `shouldBe` 0 + entryType `shouldBe` LECredit CTOpening + -- the service's clock is kept apart from the client's: service_created_at is what the wire + -- reported, created_at is when this client replicated the row + serviceCreatedAt `shouldBe` epoch + createdAt `shouldBe` now + -- ... and a later opening restates it again, downwards, from an unrelated balance + let reopened = BadgeStatement {entries = [entry "uuid-4" 0 1 (SECredit SCOpening)], previousEntryId = Just "uuid-3"} + storeE st $ \db -> insertLedgerEntries db pId reopened now + Just BadgeLedgerEntry {entryUuid = uuid2, balanceMonths = balance2} <- storeE st (`getLastBadgeLedgerEntry` pId) + uuid2 `shouldBe` "uuid-4" + balance2 `shouldBe` 1 + +-- | Every entry of one statement carries an identical @createdAt@ and the wire has no +-- @serviceCreatedAt@ at all, so array position is the only thing that orders them. +testEntryOrderFromArrayPosition :: HasCallStack => TestParams -> IO () +testEntryOrderFromArrayPosition ps = withBadgeStore ps $ \st user -> do + pId <- purchaseId <$> newCodePurchase st user BTSupporter + now <- getCurrentTime + let statement = + fullStatement + [ entry "ord-1" 12 12 (SECredit SCPayment {invoiceId = Nothing}), + entry "ord-2" (-1) 11 (SEDebit SDBadge), + entry "ord-3" (-1) 10 (SEDebit SDBadge), + entry "ord-4" (-1) 9 (SEDebit SDLapse) + ] + storeE st $ \db -> insertLedgerEntries db pId statement now + ledgerUuids st pId `shouldReturn` ["ord-1", "ord-2", "ord-3", "ord-4"] + Just BadgeLedgerEntry {entryUuid, balanceMonths} <- storeE st (`getLastBadgeLedgerEntry` pId) + entryUuid `shouldBe` "ord-4" + balanceMonths `shouldBe` 9 + +-- | @purchaseBadge@ and @getBadgeCatalog@ return the complete history every time, so a retry +-- re-delivers rows the client already holds. The second insert must be a no-op, not merely +-- non-crashing: same uuids, same local ids, same count. +testStatementRedeliveryIsIdempotent :: HasCallStack => TestParams -> IO () +testStatementRedeliveryIsIdempotent ps = withBadgeStore ps $ \st user -> do + pId <- purchaseId <$> newCodePurchase st user BTSupporter + now <- getCurrentTime + let statement = + fullStatement + [ entry "dup-1" 3 3 (SECredit SCPayment {invoiceId = Nothing}), + entry "dup-2" (-1) 2 (SEDebit SDBadge) + ] + storeE st $ \db -> insertLedgerEntries db pId statement now + rowsBefore <- ledgerRows st pId + storeE st $ \db -> insertLedgerEntries db pId statement (addUTCTime nominalDay now) + rowsAfter <- ledgerRows st pId + length rowsBefore `shouldBe` 2 + rowsAfter `shouldBe` rowsBefore + +-- | An absent @previousEntryId@ with entries present marks entries that attach to nothing +-- (docs/protocol/badges-rpc.md): the statement IS the ledger, so a row the client holds that the +-- statement does not carry is stale and goes. Appending instead would leave the client holding +-- an entry the service has dropped. +testStatementWithoutCursorReplaces :: HasCallStack => TestParams -> IO () +testStatementWithoutCursorReplaces ps = withBadgeStore ps $ \st user -> do + pId <- purchaseId <$> newCodePurchase st user BTSupporter + now <- getCurrentTime + let paymentEntry = entry "rep-1" 3 3 (SECredit SCPayment {invoiceId = Nothing}) + first = fullStatement [paymentEntry, entry "rep-stale" (-1) 2 (SEDebit SDLapse)] + -- the service healed its own ledger: rep-stale never happened, and rep-2 took its place + replacement = fullStatement [paymentEntry, entry "rep-2" (-1) 2 (SEDebit SDBadge)] + storeE st $ \db -> insertLedgerEntries db pId first now + ledgerUuids st pId `shouldReturn` ["rep-1", "rep-stale"] + storeE st $ \db -> insertLedgerEntries db pId replacement now + ledgerUuids st pId `shouldReturn` ["rep-1", "rep-2"] + Just BadgeLedgerEntry {entryType} <- storeE st (`getLastBadgeLedgerEntry` pId) + entryType `shouldBe` LEDebit DTBadge + -- an empty statement attaches nothing and is not a claim that the ledger is empty + storeE st $ \db -> insertLedgerEntries db pId (fullStatement []) now + ledgerUuids st pId `shouldReturn` ["rep-1", "rep-2"] + +-- | A present @previousEntryId@ names an entry the client already holds: the entries attach +-- after it and nothing is removed. +testStatementWithCursorAppends :: HasCallStack => TestParams -> IO () +testStatementWithCursorAppends ps = withBadgeStore ps $ \st user -> do + pId <- purchaseId <$> newCodePurchase st user BTSupporter + now <- getCurrentTime + storeE st $ \db -> insertLedgerEntries db pId (fullStatement [entry "app-1" 3 3 (SECredit SCPayment {invoiceId = Nothing})]) now + storeE st $ \db -> + insertLedgerEntries db pId BadgeStatement {entries = [entry "app-2" (-1) 2 (SEDebit SDBadge)], previousEntryId = Just "app-1"} now + ledgerUuids st pId `shouldReturn` ["app-1", "app-2"] + +-- | A service ahead of this build can name an entry type this build has no constructor for. +-- It is stored as received, tag and object both, and handed back unchanged. +testUnknownEntryTypeRoundTrip :: HasCallStack => TestParams -> IO () +testUnknownEntryTypeRoundTrip ps = withBadgeStore ps $ \st user -> do + pId <- purchaseId <$> newCodePurchase st user BTSupporter + now <- getCurrentTime + let creditObj = JM.fromList [("type", J.String "grant"), ("grantId", J.String "g-1")] + debitObj = JM.fromList [("type", J.String "clawback"), ("reason", J.String "chargeback")] + statement = + fullStatement + [ entry "unk-1" 6 6 (SECredit SCUnknown {tag = "grant", json = creditObj}), + entry "unk-2" (-6) 0 (SEDebit SDUnknown {tag = "clawback", json = debitObj}) + ] + storeE st $ \db -> insertLedgerEntries db pId statement now + Just BadgeLedgerEntry {entryType} <- storeE st (`getLastBadgeLedgerEntry` pId) + entryType `shouldBe` LEDebit DTUnknown {tag = "clawback", json = debitObj} + -- the tag is also readable as SQL, so the fallback columns are inspectable without decoding + tags <- + storeIO st $ \db -> + DB.query + db + "SELECT entry_type, entry_credit_type, entry_debit_type, entry_type_unknown FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id ASC" + (Only pId) + (tags :: [(Text, Maybe Text, Maybe Text, Int)]) + `shouldBe` [("credit", Just "grant", Nothing, 1), ("debit", Nothing, Just "clawback", 1)] + +-- | @charge@'s id is 'Int64' in Haskell and the column it would go in is @subscription_charges@' +-- TEXT primary key. The service's codec refuses it rather than inventing a coercion, and so does +-- this one; subscriptions are out of scope, so nothing produces one. +testChargeCreditRefused :: HasCallStack => TestParams -> IO () +testChargeCreditRefused ps = withBadgeStore ps $ \st user -> do + pId <- purchaseId <$> newCodePurchase st user BTSupporter + now <- getCurrentTime + let statement = fullStatement [entry "chg-1" 1 1 (SECredit SCCharge {chargeId = "charge-1"})] + err <- storeErr st $ \db -> insertLedgerEntries db pId statement now + show err `shouldContain` "credit(charge)" + -- the refusal is total: no partial row was written + ledgerUuids st pId `shouldReturn` [] + +-- Purchases ------------------------------------------------------------------- + +testCodePaymentAndPurchase :: HasCallStack => TestParams -> IO () +testCodePaymentAndPurchase ps = withBadgeStore ps $ \st user -> do + UserBadgePurchase {badgePurchaseId = pId, paymentId, status, initialBadgeType, currentBadgeType} <- + newCodePurchase st user BTLegend + status `shouldBe` PSIssued + initialBadgeType `shouldBe` BTLegend + currentBadgeType `shouldBe` BTLegend + purchaseStatuses st `shouldReturn` [(pId, "legend", "issued")] + Just pmtId <- pure paymentId + payments <- storeIO st $ \db -> DB.query db "SELECT provider, status, invoice_id FROM payments WHERE payment_id = ?" (Only pmtId) + (payments :: [(Text, Text, Maybe Text)]) `shouldBe` [("code", "settled", Nothing)] + linked <- storeIO st $ \db -> DB.query db "SELECT payment_id FROM badge_purchases WHERE badge_purchase_id = ?" (Only pId) + (linked :: [Only (Maybe Text)]) `shouldBe` [Only (Just pmtId)] + -- the ledger's payment_id stays NULL: the client has no payments row for the SERVICE's + -- payment, and the wire carries no id for it (plan §9) + now <- getCurrentTime + storeE st $ \db -> insertLedgerEntries db pId (fullStatement [entry "pay-1" 12 12 (SECredit SCPayment {invoiceId = Nothing})]) now + ledgerPaymentIds <- storeIO st $ \db -> DB.query db "SELECT payment_id FROM badge_ledger WHERE badge_purchase_id = ?" (Only pId) + (ledgerPaymentIds :: [Only (Maybe Text)]) `shouldBe` [Only Nothing] + +-- | A second purchase takes the paid slot: the first moves to @superseded@ and +-- @users.shown_badge_id@ follows the new one. An investor purchase is a different slot and must +-- be left alone. +testSupersedeAndShownBadge :: HasCallStack => TestParams -> IO () +testSupersedeAndShownBadge ps = withBadgeStore ps $ \st user@User {userId} -> do + supporterId <- purchaseId <$> newCodePurchase st user BTSupporter + investorId <- purchaseId <$> newCodePurchase st user BTInvestor + storeIO st $ \db -> setShownPurchase db userId supporterId + legendId <- purchaseId <$> newCodePurchase st user BTLegend + now <- getCurrentTime + storeIO st $ \db -> do + supersedePurchases db userId legendId BTLegend now + setShownPurchase db userId legendId + purchaseStatuses st + `shouldReturn` [ (supporterId, "supporter", "superseded"), + (investorId, "investor", "issued"), + (legendId, "legend", "issued") + ] + shown <- storeIO st $ \db -> DB.query db "SELECT shown_badge_id FROM users WHERE user_id = ?" (Only userId) + (shown :: [Only (Maybe Int64)]) `shouldBe` [Only (Just legendId)] + -- exactly one issued purchase in the paid slot + issuedPaid <- filter (\(_, bt, s) -> s == "issued" && badgeSlot (readBadgeType bt) == BSPaid) <$> purchaseStatuses st + length issuedPaid `shouldBe` 1 + where + readBadgeType = \case + "supporter" -> BTSupporter + "legend" -> BTLegend + "investor" -> BTInvestor + t -> BTUnknown t + +testGetShownPurchaseKeepsPrivateKey :: HasCallStack => TestParams -> IO () +testGetShownPurchaseKeepsPrivateKey ps = withBadgeStore ps $ \st user@User {userId} -> do + noBadge <- storeE st (`getShownPurchase` userId) + noBadge `shouldSatisfy` isNothing + UserBadgePurchase {badgePurchaseId = pId, purchaseKey, purchasePrivKey, masterKey} <- newCodePurchase st user BTSupporter + storeIO st $ \db -> setShownPurchase db userId pId + Just UserBadgePurchase {badgePurchaseId = shownId, userId = shownUserId, purchaseKey = shownPub, purchasePrivKey = shownPriv, masterKey = shownMk} <- + storeE st (`getShownPurchase` userId) + shownId `shouldBe` pId + shownUserId `shouldBe` userId + shownPub `shouldBe` purchaseKey + shownPriv `shouldBe` purchasePrivKey + shownMk `shouldBe` masterKey + +-- Issuances ------------------------------------------------------------------- + +testIssuancePerPeriod :: HasCallStack => TestParams -> IO () +testIssuancePerPeriod ps = withBadgeStore ps $ \st user -> do + pId <- purchaseId <$> newCodePurchase st user BTSupporter + now <- getCurrentTime + let periodStart1 = epoch + periodEnd1 = addUTCTime (30 * nominalDay) epoch + expiry1 = addUTCTime (37 * nominalDay) epoch + cred1 <- testCredential BTSupporter expiry1 + BadgeIssuance {credential, periodStart, periodEnd, entryId} <- + storeIO st $ \db -> createIssuance db (newIssuance pId periodStart1 periodEnd1 expiry1 cred1) now + credential `shouldBe` cred1 + periodStart `shouldBe` Just periodStart1 + periodEnd `shouldBe` Just periodEnd1 + entryId `shouldBe` Nothing + stored1 <- storedIssuances st pId + length stored1 `shouldBe` 1 + -- the stored credential is its own JSON encoding, so the row round-trips + [(_, Binary credBytes)] <- pure stored1 + J.eitherDecodeStrict credBytes `shouldBe` Right cred1 + -- the next period writes a second row rather than replacing the first + let periodStart2 = periodEnd1 + periodEnd2 = addUTCTime (60 * nominalDay) epoch + expiry2 = addUTCTime (67 * nominalDay) epoch + cred2 <- testCredential BTSupporter expiry2 + _ <- storeIO st $ \db -> createIssuance db (newIssuance pId periodStart2 periodEnd2 expiry2 cred2) now + stored2 <- storedIssuances st pId + length stored2 `shouldBe` 2 + map fst stored2 `shouldBe` [periodStart1, periodStart2] + where + newIssuance pId periodStart periodEnd expiry credential = + NewBadgeIssuance {badgePurchaseId = pId, badgeType = BTSupporter, periodStart, periodEnd, expiry, ledgerEntryId = Nothing, credential} + +storedIssuances :: DBStore -> Int64 -> IO [(UTCTime, Binary ByteString)] +storedIssuances st pId = + storeIO + st + ( \db -> + DB.query + db + "SELECT period_start, credential FROM badge_issuances WHERE badge_purchase_id = ? ORDER BY period_start ASC" + (Only pId) + ) diff --git a/tests/Test.hs b/tests/Test.hs index fc08d1575b..75bb618266 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -6,6 +6,7 @@ import Bots.BadgeCodeTests import Bots.BadgeLedgerTests import Bots.BadgeServiceTests +import Bots.BadgeStoreTests import Bots.BroadcastTests import Bots.DirectoryTests import ChatClient @@ -88,6 +89,7 @@ main = do #if !defined(dbPostgres) describe "Mobile API Tests" mobileTests #endif + describe "Supporter badges store" badgeStoreTests describe "SimpleX chat client" chatTests xdescribe'' "SimpleX Broadcast bot" broadcastBotTests xdescribe'' "SimpleX Directory service bot" directoryServiceTests