mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-27 17:58:47 +00:00
core: client badge store, plan: tick C1
This commit is contained in:
shum
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
@@ -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)
|
||||
)
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user