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 7d2ae42648..d0d97d0630 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -146,7 +146,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | B10 | Service integration tests | B7, B8 | ☑ | | C1 | `Store/Badges.hs`: client badge store | A1, A2 | ☑ | | C2 | Commands, responses, events, parsers, View | A2, B2, C1 | ☑ | -| C3 | `BadgeManager` worker | C1, C2 | ☐ | +| C3 | `BadgeManager` worker | C1, C2 | ☑ | | C4 | Redeem path wired end to end | B6, B7, B9, C3 | ☐ | | C5 | Client and service integration tests | B10, C4 | ☐ | | D0 | Store layer: orders, invoices, provider events | A3, A5, B1 | ☐ | @@ -689,9 +689,7 @@ Phase C ends with a chat client that can redeem a code minted by B8 and show the **Do:** Reduced from core §6 to this scope. ```haskell -newtype BadgeManager = BadgeManager - { badgeWorkers :: TMap UserId Worker -- agent Worker: doWork TMVar, restart on crash - } +badgeWorkers :: TMap UserId Worker -- a ChatController field: agent Worker, doWork TMVar, restart on crash ``` - Reuse the agent `Worker` framework from simplexmq's `Simplex.Messaging.Agent.Client`. `getAgentWorker` is used at `Library/Subscriber.hs:4024,4091,4331` (imported at `:82`); `hasWorkToDo'` and `cancelWorker` are exported by the same module but have no in-repo caller yet. The `TMap … Worker` controller fields follow `deliveryTaskWorkers` and `relayRequestWorkers` (`Controller.hs:307-309`). @@ -699,7 +697,7 @@ newtype BadgeManager = BadgeManager - Add a `CLBadge UserId` constructor to `ChatLockEntity` (`Store/Shared.hs:68`), whose derived `Eq` and `Ord` still hold, and give it a branch in `enityLockString` (`Library/Commands.hs:3639-3646`): `CLBadge userId -> "Badge " <> tshow userId`. That case is exhaustive with no wildcard and the build uses `-Werror=incomplete-patterns` (`simplex-chat.cabal:338`), so the new constructor breaks the build until the branch exists. - Define `withBadgeLock :: Text -> UserId -> CM a -> CM a`, `withEntityLock name . CLBadge`, with an `INLINE` pragma, beside the existing wrappers at `Library/Internal.hs:133-139`, and lock every signed badge operation with it. There is no separate lock map: the badge lock is an ordinary entity lock over the shared `entityLocks` map (`Controller.hs:295`), so the `chatLock`-first order is inherited rather than reimplemented, and no new lock order is introduced. - The worker calls `sendBadgeRequest :: Maybe C.PrivateKeyEd25519 -> BadgeServiceRequest -> CM BadgeServiceResponse`, the single send path C4 implements in `Library/Commands.hs`. At this step it is a stub with that signature returning `BSPError` with code `internal` and the message `not implemented`, so the worker compiles and its mechanics are testable; C4 gives it the lazy connection and the signing. -- Per pass, for the shown purchase: re-issue when the balance is positive and the month is unissued, by calling `issueBadge`. Apply the response with C1's writers, in one transaction: `insertLedgerEntries` for the statement verbatim, then `createIssuance` for the new period. The purchase row itself does not change on a re-issue, since it is already `issued`; only a new issuance row is written. Verify it with C2's `verifyUserBadge` before the transaction and call `setUserBadge` inside it, writing the `User` it returns to the `currentUser` TVar; a credential that fails verification is discarded and nothing is written. Release the badge lock, then call C2's `presentUserBadgeToContacts` with that `User`, which takes `chatLock`, so the monthly pass never broadcasts while holding a lock. Emit `CEvtBadgeChanged` on change. +- Per pass, for the shown purchase: re-issue when the balance is positive and the month is unissued — the last ledger entry's `balanceMonths > 0` and `balanceStartTs <= now`, which is `issue`'s own guard and never the balance alone (B2) — by calling `issueBadge`, signed with the purchase's own key and carrying the purchase row's master key unchanged (§9). Apply the response with C1's writers, in one transaction: `insertLedgerEntries` for the statement verbatim, then `createIssuance` for the period the statement's last `debit(badge)` entry implies, with `ledgerEntryId = Nothing` (§9). The purchase row itself does not change on a re-issue, since it is already `issued`; only a new issuance row is written. Verify it with C2's `verifyUserBadge` before the transaction and call `setUserBadge` inside it, writing the `User` it returns to the `currentUser` TVar; a credential that fails verification is discarded and nothing is written. Release the badge lock, then call C2's `presentUserBadgeToContacts` with that `User`, which takes `chatLock`, so the monthly pass never broadcasts while holding a lock. Emit `CEvtBadgeChanged` on change. - A response with `credential = Nothing` is not an error: it is the exhausted balance B7 defines. Store the statement's ledger rows, write no issuance, leave the profile's badge as it is, and emit `CEvtBadgeChanged` only if the stored state changed. The pass is not suppressed afterwards: a pass on a zero balance reads the last ledger entry and stops, which is cheap, and suppressing it would need a re-arming signal that nothing sends. - Three things trigger a pass, and nothing else does: - the chat controller start signals every user's worker, beside the other worker starts in `startChatController`'s `start` block (`Library/Commands.hs:250-252`, `startDeliveryWorkers`, `startRelayRequestWorker_`, `startCleanupManager`), which has `users` in hand and so suits a per-user worker. `src/Simplex/Chat.hs:196-198,242-244` is `newChatController` and only initialises the maps; @@ -708,7 +706,7 @@ newtype BadgeManager = BadgeManager - `hasWorkToDo'` signals the `doWork` TMVar in all three cases, and the timer is the badge worker's own loop rather than a shared scheduler. Tests drive a pass with `APIGetBadgeState` rather than the timer, so no test waits on wall-clock time. - Out of scope here: invoice reconciliation, store evidence, the alert timer, `CEvtBadgeAlert`, and Monday presentation. Those stay deferred in §6. -**Verify:** In `tests/Bots/BadgeManagerTests.hs`, registered in the test stanza's `other-modules` and in `tests/Test.hs` under the **`Supporter badges`** path inside the `testBracket` bracket, so CI runs it (§4 rules 7 and 8): with a purchase row inserted by C1, calling the pass's apply-response function with a `BSPBadgeCredential` whose credential was signed by a test key through `Simplex.Chat.Badges.issueBadge`, against a controller started with `testCfg {badgePublicKeys = testBadgeKeys pk}` (`tests/ChatTests/Profiles.hs:295`), writes the issuance row and the statement's ledger rows and emits `CEvtBadgeChanged`; a credential signed by a different key is rejected and writes nothing; a response with `credential = Nothing` writes the ledger rows and no issuance; a second signal arriving during a pass does not run concurrently. No service is started, and no RPC is sent, so the test needs no stub point. `tests/BadgeTests.hs` cannot host this test, being a plain `Spec` (A2). The month-boundary re-issue against the live service is asserted in C5. +**Verify:** In `tests/Bots/BadgeManagerTests.hs`, registered in the test stanza's `other-modules` and in `tests/Test.hs` under the **`Supporter badges`** path inside the `testBracket` bracket, so CI runs it (§4 rules 7 and 8): with a purchase row inserted by C1, composing the pass's two halves — `storeBadgeIssueResponse`, which the pass runs under the badge lock, and `presentBadgeChange`, which it runs with the lock released (§9) — over a `BSPBadgeCredential` whose credential was signed by a test key through `Simplex.Chat.Badges.issueBadge`, against a controller started with `testCfg {badgePublicKeys = testBadgeKeys pk}` (`tests/ChatTests/Profiles.hs:295`), writes the issuance row and the statement's ledger rows and emits `CEvtBadgeChanged`; a credential signed by a different key is rejected and writes nothing; a response with `credential = Nothing` writes the ledger rows and no issuance; a second signal arriving during a pass does not run concurrently. No service is started, and no RPC is sent, so the test needs no stub point. `tests/BadgeTests.hs` cannot host this test, being a plain `Spec` (A2). The month-boundary re-issue against the live service is asserted in C5. #### C4 — Redeem path wired end to end @@ -1399,6 +1397,16 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **C2 — the new commands go in `undocumentedCommands`, not `cliCommands`, and neither list documents anything.** The step said to add them to `cliCommands` "so they reach `bots/api/COMMANDS.md` and both generated clients". Both lists are exemptions from `tests/APIDocs.hs:76`'s completeness check; a command reaches `COMMANDS.md` and the clients only through `chatCommandsDocs`. `cliCommands` holds the terminal-syntax commands and `undocumentedCommands` the `API*` ones, so the three `API*` commands go in the latter. The only regenerated files are therefore `bots/api/TYPES.md`, `types.ts` and `_types.py`, all three changed by `CEBadgeServiceError`/`BadgeServiceErrorCode` alone; `COMMANDS.md` and `EVENTS.md` are unchanged, and the step's Files line is corrected accordingly. Documenting the three commands properly belongs with C4, when they do something. - **C2 — the step's last manual check contradicts the step.** "`/_badge catalog 1` reaching the service at the overridden address" cannot hold while the same step stubs `APIGetBadgeCatalog` with `not implemented`. What was checked instead: `--badge-service-address` parses a contact link and is rejected when it is not one, `/_badge catalog 1` and `/_badge purchase 1 ` both return the stub `CEBadgeServiceError`, and the issuer-key override is exercised end to end through `/badge add` — a credential signed by a locally generated key at index 1 verifies with `--badge-issuer-key 1:KEY` and fails without it ("does not verify against configured key"), while a credential at index 2 fails with "unknown badge key index" when only index 1 is overridden, which is what proves REPLACE rather than merge. Verify corrected above. **C4 owns the reaching-the-service check.** - **C2 — `addUserBadge` reads `badgeCurrentTime`, not `getCurrentTime`.** The step introduces the field for C3 and C4 only. Wiring the one existing client-side badge clock read through it too costs nothing (the default is `getCurrentTime`, so `AddBadge` is unchanged) and means the field is load-bearing from the step that adds it rather than from the step that first needs to override it. **It has no behavioural test yet** — nothing in this step can observe a different clock — so C5 is the first place the override is proved to work. +- **C3 — `badgeWorkers` is a `ChatController` field, not a `BadgeManager` record.** The step's code block wraps one `TMap UserId Worker` in a newtype, from core §6's five-field record; the other four fields (`badgeLocks`, `badgeReads`, `badgeBoundaries`, `badgeTimerAsync`) are all out of this step's scope — the lock is an ordinary entity lock over `entityLocks`, the timer is the worker's own loop, and the other two serve steps §6 defers — so the wrapper would wrap exactly one field and add an indirection at every use. The field sits beside `deliveryTaskWorkers` and `relayRequestWorkers`, which the same bullet says to follow. +- **C3 — `badgeReads` is not added and `APIGetBadgeState` records nothing.** Core §6 has the command record its request time there; the only thing that reads that map is the lapsed-balance signed `getBadgeCatalog`, which this step does not send. The command signals the worker and stores nothing. +- **C3 — the issued period is read from the statement's last `debit(badge)`, and no issuance is written without one.** The step says "`createIssuance` for the new period" without saying where the period comes from, and the wire carries neither end of it: the credential's expiry is `sundayAfter periodEnd`, which is not invertible, and `addMonths` is not additive under clamping, so stepping a month back from a balance start does not name the period either (the same trap `BadgeService.Service.resolveIssue` documents). `issue` sets `balanceStartTs` to the period's END and the service writes the `debit(badge)` last, so the statement's last entry gives `periodEnd` and the `balanceStartTs` in force immediately before it gives `periodStart` — from the entry before it in the statement, or from the last entry the client held. A statement carrying no `debit(badge)` still puts its credential on the profile, because a month the user paid for is never lost (B10), but writes no issuance row. +- **C3 — `NewBadgeIssuance.ledgerEntryId` stays `Nothing`.** C1's entry above left this to C3. `badge_issuances.entry_id REFERENCES badge_ledger` has no `ON DELETE`, so linking issuances to local ledger rows would oblige every REPLACE to null those references before deleting — for a join nothing in this plan reads. The client's issuances therefore carry no ledger reference; the service's own rows still do. +- **C3 — the master key of `issueBadge` is the purchase row's, never a freshly generated one.** The service does not check `badgeRequest.masterKey` against `badge_purchases.master_key` (§9, above), so a second redemption under the same purchase key with a rotated master key takes the cached-issuance path and is answered with a credential bound to the OLD key — unusable, and with no error raised anywhere. Keeping the key stable per purchase closes that from the client side, without a service change. +- **C3 — the pass is two functions, split at the lock.** The step's Verify line names one "apply-response function", but the presentation must happen with the badge lock RELEASED (C2's `presentUserBadgeToContacts` takes `chatLock`), so the pass is `withBadgeLock … (… storeBadgeIssueResponse …) >>= presentBadgeChange`. Both halves are production functions and the tests compose them exactly as the pass does; only the stubbed send sits between them. C4's redeem path has the same obligation. +- **C3 — the worker's timer is `race_` against `threadDelay'`, not `timeout`.** `badgePassInterval` is a `NominalDiffTime` (following `cleanupManagerInterval`) and its default of a day is 86,400,000,000 microseconds, which does not fit an `Int` on 32-bit builds; `threadDelay'` takes an `Int64` and chunks it, as the delivery and relay-request workers already use it. The loop waits on `takeTMVar doWork` racing that delay, so the signal is CONSUMED before the pass reads any state and a signal arriving during a pass runs one more pass rather than being swallowed by it. +- **C3 — a badge request that fails is reported to the app.** Neither the step nor core §6 says what to do with a `BSPError` from a pass. It is surfaced with `eToView` as `CEBadgeServiceError`, as the delivery worker surfaces its failures, which is also what makes a pass observable to a test while `sendBadgeRequest` is a stub. +- **C3 — `badgeCurrentTime` is proved by C3, not by C5.** C2's entry above says C5 is the first place the override is proved to work. It is proved here: `Bots.BadgeManagerTests` injects a clock that counts and gates the passes, which is what lets the worker tests be deterministic without waiting on `badgePassInterval` or on wall-clock time at all. +- **C3 — the Postgres cross-check was not run for this step.** SQLite-only: `cabal test --test-options='-m "Supporter badges" -m "Badge service"'`, `CI` unset. The `--flags=client_postgres` cross-check B10 established is optional per-step and was skipped here rather than run; nothing in this step is guarded `#if !defined(dbPostgres)`, so there is no reason to expect a backend-specific gap, but it has not been exercised against Postgres and that remains open until it is. ## 10. End-to-end verification diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 880a583b1b..0dd30f5299 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -714,6 +714,7 @@ test-suite simplex-chat-test BadgeService.Store.Migrate Bots.BadgeCodeTests Bots.BadgeLedgerTests + Bots.BadgeManagerTests Bots.BadgeServiceTests Bots.BadgeStoreTests Broadcast.Bot diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 39ea28aa6b..751c789470 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -82,6 +82,7 @@ defaultChatConfig = badgeServiceAddress = Nothing, badgeWebBaseUrl = "", badgeCurrentTime = getCurrentTime, + badgePassInterval = nominalDay, confirmMigrations = MCConsole, -- this property should NOT use operator = Nothing -- non-operator servers can be passed via options @@ -202,6 +203,7 @@ newChatController deliveryTaskWorkers <- TM.emptyIO deliveryJobWorkers <- TM.emptyIO relayRequestWorkers <- TM.emptyIO + badgeWorkers <- TM.emptyIO relayGroupLinkChecksAsync <- newTVarIO Nothing webPreviewState <- forM webPreviewConfig $ \_ -> newWebPreviewState chatRelayTests <- TM.emptyIO @@ -248,6 +250,7 @@ newChatController deliveryTaskWorkers, deliveryJobWorkers, relayRequestWorkers, + badgeWorkers, relayGroupLinkChecksAsync, webPreviewState, chatRelayTests, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 8f54a99515..ae79c61180 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -160,6 +160,10 @@ data ChatConfig = ChatConfig -- sleeping. Defaults to 'getCurrentTime'; nothing but a test ever replaces it. This is the -- client twin of @BadgeServiceOpts.serviceClock@. badgeCurrentTime :: IO UTCTime, + -- | How long a badge worker waits for a signal before running a pass anyway. A month + -- boundary is the only event the pass waits for, so a daily wake is frequent enough; a pass + -- with the current month already issued reads one ledger row and stops. + badgePassInterval :: NominalDiffTime, confirmMigrations :: MigrationConfirmation, presetServers :: PresetServers, shortLinkPresetServers :: NonEmpty SMPServer, @@ -325,6 +329,10 @@ data ChatController = ChatController deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker, deliveryJobWorkers :: TMap DeliveryWorkerKey Worker, relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework + -- | The 'BadgeManager': one worker per user, because badge state is per profile. The worker + -- holds no queue — a trigger only signals its @doWork@, and each pass derives its work from + -- the stored purchase and ledger, so lost and duplicated signals are harmless. + badgeWorkers :: TMap UserId Worker, relayGroupLinkChecksAsync :: TVar (Maybe (Async ())), webPreviewState :: Maybe WebPreviewState, chatRelayTests :: TMap ConnId RelayTest, diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index cd63de70b2..cfe66771a1 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -56,10 +56,22 @@ import Data.Type.Equality import qualified Data.UUID as UUID import qualified Data.UUID.V4 as V4 import Simplex.Chat.Library.Subscriber -import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeRequest (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential) import Simplex.Chat.Badges.Months (addMonths) -import Simplex.Chat.Badges.Service (BadgeServiceErrorCode (..)) -import Simplex.Chat.Badges.Types (BadgeLedgerEntry (..), UserBadge (..), UserBadgeState (..)) +import Simplex.Chat.Badges.Service + ( BadgeBalance (..), + BadgeServiceCommand (..), + BadgeServiceErrorCode (..), + BadgeServiceRequest (..), + BadgeServiceResponse (..), + BadgeStatement (..), + StatementCreditType (..), + StatementDebitType (..), + StatementEntry (..), + StatementEntryType (..), + currentBadgeVersion, + ) +import Simplex.Chat.Badges.Types (BadgeLedgerEntry (..), LedgerCreditType (..), LedgerDebitType (..), LedgerEntryType (..), UserBadge (..), UserBadgeState (..)) import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim) import Simplex.Chat.Call import Simplex.Chat.Controller @@ -80,7 +92,7 @@ import Simplex.Chat.Library.Internal import Simplex.Chat.Stats import Simplex.Chat.Store import Simplex.Chat.Store.AppSettings -import Simplex.Chat.Store.Badges (UserBadgePurchase (..), getLastBadgeLedgerEntry, getShownPurchase) +import Simplex.Chat.Store.Badges (NewBadgeIssuance (..), UserBadgePurchase (..), createIssuance, getLastBadgeLedgerEntry, getShownPurchase, insertLedgerEntries) import Simplex.Chat.Store.ContactRequest import Simplex.Chat.Store.Connections import Simplex.Chat.Store.Delivery @@ -99,7 +111,8 @@ import qualified Simplex.Chat.Util as U import Simplex.Chat.Web (webPreviewWorker) import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSizeHard) import Simplex.Messaging.Agent -import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles) +import Simplex.Messaging.Agent.Client (cancelWorker, getAgentWorker) +import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), Worker (..), allRoles) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.Entity import Simplex.Messaging.Agent.Store.Interface (execSQL) @@ -254,6 +267,7 @@ startChatController mainApp enableSndFiles serviceRequests = do startDeliveryWorkers startRelayRequestWorker_ startCleanupManager + startBadgeWorkers users void $ forkIO $ mapM_ startExpireCIs users startRelayChecks users startWebPreview users @@ -350,7 +364,11 @@ restoreCalls = do atomically $ writeTVar calls callsMap stopChatController :: ChatController -> IO () -stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do +stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, badgeWorkers} = do + -- the map is swapped out BEFORE the workers are cancelled: 'cancelWorker' leaves a worker's + -- action TMVar empty, so one left in the map would make the next 'getBadgeWorker' for that + -- user block on it forever + atomically (swapTVar badgeWorkers M.empty) >>= mapM_ cancelWorker readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd) atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd) disconnectAgentClient smpAgent @@ -3559,6 +3577,9 @@ processChatCommand cxt nm = \case APIGetBadgeState userId -> withUserId userId $ \user -> do badgeState <- getUserBadgeState user ChatConfig {badgeWebBaseUrl} <- asks config + -- the badge screen opening or regaining focus is one of the three triggers of a pass, so a + -- profile that has just crossed a month boundary re-issues without waiting for the timer + lift $ void $ getBadgeWorker True userId pure CRBadgeState {user, badgeState, badgeWebBaseUrl} APIGetBadgeCatalog _ -> throwChatError badgeNotImplemented APIPurchaseBadge {} -> throwChatError badgeNotImplemented @@ -3664,6 +3685,7 @@ processChatCommand cxt nm = \case CLUserContact ucId -> "UserContact " <> tshow ucId CLContactRequest crId -> "ContactRequest " <> tshow crId CLFile fId -> "File " <> tshow fId + CLBadge uId -> "Badge " <> tshow uId DebugEvent event -> toView event >> ok_ GetAgentSubsTotal userId -> withUserId userId $ \user -> do users <- withStore' $ \db -> getUsers db @@ -5176,11 +5198,20 @@ getUserBadgeState User {userId} = withFastStore $ \db -> badgePaidThrough :: BadgeLedgerEntry -> UTCTime badgePaidThrough BadgeLedgerEntry {balanceMonths, balanceStartTs} = addMonths balanceMonths balanceStartTs +-- | A badge failure that is the CLIENT's own, reported in the shape a service failure is +-- reported in: no 'BadgeServiceErrorCode' denotes a local failure, so it is 'BSEInternal' with +-- the reason as the message. +localBadgeError :: Text -> ChatErrorType +localBadgeError t = CEBadgeServiceError {badgeError = BSEInternal, badgeErrorMessage = Just t, retryAfter = Nothing} + -- | The placeholder failure of the badge commands C4 implements. It is a 'CEBadgeServiceError' -- rather than a command error because that is the error C4 raises from them, so the stub does -- not train a client to expect a different shape from the one it will get. badgeNotImplemented :: ChatErrorType -badgeNotImplemented = CEBadgeServiceError {badgeError = BSEInternal, badgeErrorMessage = Just "not implemented", retryAfter = Nothing} +badgeNotImplemented = localBadgeError notImplementedMessage + +notImplementedMessage :: Text +notImplementedMessage = "not implemented" -- | Checks that a credential was signed by a configured issuer key. -- @@ -5224,6 +5255,247 @@ addUserBadge user cred@(BadgeCredential _ _ _ info) = do asks currentUser >>= atomically . (`writeTVar` Just user') presentUserBadgeToContacts user' +-- BadgeManager ---------------------------------------------------------------- +-- +-- One worker per user (badge state is per profile), over the agent 'Worker' framework the +-- controller already uses for delivery and relay requests. The worker holds no queue: a trigger +-- only signals its @doWork@, and each pass derives its work from the stored purchase and its +-- ledger, so lost and duplicated signals are harmless. + +-- | The badge worker of one user, creating it if it has none; @hasWork@ signals a pass. +-- +-- Two of the three triggers signal through this call — chat start ('startBadgeWorkers') and +-- @APIGetBadgeState@ — and nothing else does. The third is the worker's own timer, which is +-- inside 'runBadgeWorker' rather than a signal. +getBadgeWorker :: Bool -> UserId -> CM' Worker +getBadgeWorker hasWork userId = do + ws <- asks badgeWorkers + a <- asks smpAgent + getAgentWorker "badge" hasWork a userId ws $ runBadgeWorker userId + +-- | Signals every user's badge worker at chat start, beside the other worker starts: a profile +-- that crossed a month boundary while the app was closed re-issues without waiting for the timer. +startBadgeWorkers :: [User] -> CM' () +startBadgeWorkers = mapM_ $ \User {userId} -> void $ getBadgeWorker True userId + +-- | The worker loop: wait for a signal or for 'badgePassInterval' to elapse, then run one pass. +-- +-- The signal is TAKEN rather than read, and taken before the pass reads any state, so a signal +-- arriving while a pass runs is not consumed by it and runs one more pass afterwards. Two +-- passes for one user therefore never overlap: the framework runs one thread per worker, and +-- that thread is here. +-- +-- The timer is this loop's own wait rather than a shared scheduler, and it is 'threadDelay'' +-- rather than 'timeout' because a day in microseconds does not fit an 'Int' on 32-bit builds. +runBadgeWorker :: UserId -> Worker -> CM () +runBadgeWorker userId Worker {doWork} = do + interval <- asks $ badgePassInterval . config + forever $ do + liftIO $ race_ (atomically $ takeTMVar doWork) (threadDelay' $ diffToMicroseconds interval) + badgeManagerPass userId `catchAllErrors` eToView + +-- | One pass for one user: the signed half under the per-user badge lock, then its presentation +-- and event OUTSIDE that lock, since 'presentUserBadgeToContacts' takes 'chatLock'. +badgeManagerPass :: UserId -> CM () +badgeManagerPass userId = do + user <- withFastStore (`getUser` userId) + withBadgeLock "badgeManagerPass" userId (issueDueBadgePeriod user) >>= presentBadgeChange + +-- | Re-issues the shown purchase's current month when its balance funds one and the month is +-- unissued. Everything it does — the state it reads, the request it sends and the rows it +-- writes — happens under the per-user badge lock, so it cannot interleave with a command that +-- sends a signed badge request for the same profile. +issueDueBadgePeriod :: User -> CM BadgeChange +issueDueBadgePeriod user@User {userId} = do + now <- liftIO =<< asks (badgeCurrentTime . config) + -- the purchase and its last entry are read in ONE transaction, so the balance asserted to the + -- service cannot be from a ledger that changed between the two reads + due_ <- withFastStore $ \db -> + getShownPurchase db userId >>= \case + Nothing -> pure Nothing + Just p@UserBadgePurchase {badgePurchaseId = pId} -> Just . (p,) <$> getLastBadgeLedgerEntry db pId + case due_ of + Just (purchase@UserBadgePurchase {purchasePrivKey}, Just lastEntry) + | badgePeriodDue now lastEntry -> do + balance <- assertedBadgeBalance lastEntry + resp <- sendBadgeRequest (Just purchasePrivKey) (badgeIssueRequest purchase balance) + storeBadgeIssueResponse now user purchase (Just lastEntry) resp + _ -> pure BadgeUnchanged + +-- | Whether the month the balance would fund is unissued: a positive balance whose coverage +-- window has already started. +-- +-- This is @BadgeService.Ledger.issue@'s own guard, applied to the last entry the client holds. +-- A previous issue moved 'balanceStartTs' to the END of the period it issued, so +-- @balanceStartTs > now@ means the current month is already issued — and that is why the two +-- reasons not to issue must be told apart by 'balanceStartTs' and never by the balance alone: +-- once the last funded month has been issued both hold at once. +badgePeriodDue :: UTCTime -> BadgeLedgerEntry -> Bool +badgePeriodDue now BadgeLedgerEntry {balanceMonths, balanceStartTs} = balanceMonths > 0 && balanceStartTs <= now + +-- | The balance assertion of @issueBadge@: the last entry the client holds, back in the shape it +-- arrived in. The service matches it by @entryId@ and returns what follows it; a mismatch is +-- healed on the service side and answered with the complete history or an @opening@ credit. +-- +-- The three entry types that cannot be put back on the wire are refused rather than coerced: +-- they carry a purchase KEY where the stored columns hold a purchase id, or an @Int64@ charge id +-- against a TEXT one, exactly as 'Simplex.Chat.Store.Badges' refuses them in the other +-- direction. Nothing can write such a row today, so this raises a chat error rather than +-- branching the pass. +assertedBadgeBalance :: BadgeLedgerEntry -> CM BadgeBalance +assertedBadgeBalance BadgeLedgerEntry {entryUuid, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, entryType} = do + entryType' <- either (throwChatError . localBadgeError) pure $ wireEntryType entryType + pure . BadgeBalance $ + StatementEntry + { entryId = entryUuid, + changeMonths, + balanceMonths, + balanceStartTs, + balanceBadgeType, + wasPausedSince, + -- the wire's createdAt is the SERVICE's clock, which is the column the replica keeps it + -- in; created_at is when this client replicated the row and is not the service's to read + createdAt = serviceCreatedAt, + entryType = entryType' + } + +-- | The inverse of 'Simplex.Chat.Store.Badges.storedEntryType', for the one entry the client +-- asserts back to the service. @credit(payment)@ loses nothing on the way out: the stored +-- @payment_id@ is a CLIENT payments id and the wire field is the SERVICE's @invoiceId@, which a +-- replicated entry never carries. +wireEntryType :: LedgerEntryType -> Either Text StatementEntryType +wireEntryType = \case + LECredit creditType -> SECredit <$> case creditType of + CTPayment {} -> Right SCPayment {invoiceId = Nothing} + CTSupport -> Right SCSupport + CTOpening -> Right SCOpening + CTUnknown {tag, json} -> Right SCUnknown {tag, json} + CTCharge {} -> unsupported "credit(charge)" + CTTransferIn {} -> unsupported "credit(transferIn)" + LEDebit debitType -> SEDebit <$> case debitType of + DTRefund -> Right SDRefund + DTSupport -> Right SDSupport + DTBadge -> Right SDBadge + DTLapse -> Right SDLapse + DTUnknown {tag, json} -> Right SDUnknown {tag, json} + DTUpgrade {} -> unsupported "debit(upgrade)" + DTTransferOut {} -> unsupported "debit(transferOut)" + where + unsupported what = Left $ "cannot assert badge ledger " <> what <> " to the badge service" + +-- | The @issueBadge@ request for a purchase, signed by that purchase's key. +-- +-- __The master key is the purchase row's, never a freshly generated one.__ The service does not +-- check the master key of an @issueBadge@ against the one it recorded for the purchase, and a +-- request that rotated it would take the service's cached-issuance path and be answered with a +-- credential bound to the OLD key — unusable, with no error raised anywhere. Keeping it stable +-- per purchase key closes that from this side. +-- +-- 'badgeExpiry' is left absent and 'badgeExtra' empty: the service overrides the expiry with its +-- own (the Sunday after the period it issues) and refuses a non-empty extra. +badgeIssueRequest :: UserBadgePurchase -> BadgeBalance -> BadgeServiceRequest +badgeIssueRequest UserBadgePurchase {purchaseKey, masterKey, currentBadgeType} balance = + BadgeServiceRequest + { version = currentBadgeVersion, + purchaseKey = Just purchaseKey, + request = + BSCIssueBadge + { badgeRequest = BadgeRequest {masterKey, badgeInfo = BadgeInfo {badgeType = currentBadgeType, badgeExpiry = Nothing, badgeExtra = ""}}, + balance + } + } + +-- | The single send path to the badge service, which C4 replaces with the lazy connection and +-- the signing. Until then every badge request fails locally, which is what the two stub command +-- handlers already report. +sendBadgeRequest :: Maybe C.PrivateKeyEd25519 -> BadgeServiceRequest -> CM BadgeServiceResponse +sendBadgeRequest _signKey _request = pure BSPError {code = BSEInternal, message = Just notImplementedMessage, retryAfter = Nothing} + +-- | What one applied badge response changed, which is what decides what happens once the badge +-- lock is released. +data BadgeChange + = -- | Nothing was written: no work, a service error, or a credential that failed verification. + BadgeUnchanged + | -- | Ledger rows were stored and the profile's own badge is untouched — the exhausted + -- balance, which is not an error. + BadgeLedgerChanged User + | -- | A new credential is on the profile, so it is presented to contacts as well as reported. + BadgeIssued User + +-- | Applies one @issueBadge@ response, in ONE transaction, and reports what it changed. +-- +-- The caller must hold the per-user badge lock and must NOT hold it while passing the result to +-- 'presentBadgeChange'. +-- +-- A credential that fails verification is discarded and NOTHING is written, the statement +-- included: a response whose credential is not ours is not a response to trust the rest of. An +-- absent credential is the opposite — the exhausted balance the service defines, whose statement +-- is stored like any other. +storeBadgeIssueResponse :: UTCTime -> User -> UserBadgePurchase -> Maybe BadgeLedgerEntry -> BadgeServiceResponse -> CM BadgeChange +storeBadgeIssueResponse now user UserBadgePurchase {badgePurchaseId = pId} heldEntry_ = \case + BSPBadgeCredential {credential = Nothing, statement} -> do + withStore $ \db -> insertLedgerEntries db pId statement now + ledgerChange + BSPBadgeCredential {credential = Just cred, statement} -> + verifyUserBadge cred >>= \case + Left e -> badgeFailed e + Right () -> case cred of + BadgeCredential {badgeInfo = info@BadgeInfo {badgeType, badgeExpiry = Just expiry}} -> do + user' <- withStore $ \db -> do + insertLedgerEntries db pId statement now + -- the issuance is written only for a statement that carries the period it issued; + -- ledgerEntryId stays absent (see 'issuedBadgePeriod' and plan §9) + forM_ (issuedBadgePeriod heldEntry_ statement) $ \(periodStart, periodEnd) -> + liftIO . void $ + createIssuance db NewBadgeIssuance {badgePurchaseId = pId, badgeType, periodStart, periodEnd, expiry, ledgerEntryId = Nothing, credential = cred} now + liftIO $ setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info))) + asks currentUser >>= atomically . (`writeTVar` Just user') + pure $ BadgeIssued user' + -- 'issueSignedBadge' always sets the expiry, so this is a malformed response rather than + -- a lifetime credential, and a lifetime badge has no issuance row to write anyway + _ -> badgeFailed "issued badge credential carries no expiry" + BSPError {code, message, retryAfter} -> + BadgeUnchanged <$ eToView (ChatError CEBadgeServiceError {badgeError = code, badgeErrorMessage = message, retryAfter}) + r -> badgeFailed $ "unexpected badge service response to issueBadge: " <> tshow r + where + badgeFailed e = BadgeUnchanged <$ eToView (ChatError $ localBadgeError e) + -- the ledger the statement left, against the one that was held: nothing else the badge state + -- reports comes from the ledger, so an unchanged last entry is an unchanged state + ledgerChange = do + lastEntry_ <- withFastStore $ \db -> getLastBadgeLedgerEntry db pId + pure $ if ledgerPosition lastEntry_ == ledgerPosition heldEntry_ then BadgeUnchanged else BadgeLedgerChanged user + ledgerPosition = fmap $ \BadgeLedgerEntry {entryUuid, balanceMonths, balanceStartTs} -> (entryUuid, balanceMonths, balanceStartTs) + +-- | The period a statement issued, when it carries one. +-- +-- The service writes the @debit(badge)@ LAST, after any lapse and credit, and @issue@ sets +-- 'balanceStartTs' to the period's END, so the last entry's 'balanceStartTs' is the period end +-- and the one in force immediately before it is the period start. That predecessor is the entry +-- before it in the statement, or, for a statement that appends, the last entry the client +-- already held. A complete history that contains a @debit(badge)@ always contains it: a balance +-- can only have become positive through a credit entry. +-- +-- The period is NOT derived from the credential: its expiry is the Sunday after the period end, +-- and that is not invertible. +issuedBadgePeriod :: Maybe BadgeLedgerEntry -> BadgeStatement -> Maybe (UTCTime, UTCTime) +issuedBadgePeriod heldEntry_ BadgeStatement {entries} = case reverse entries of + StatementEntry {entryType = SEDebit SDBadge, balanceStartTs = periodEnd} : earlier -> (,periodEnd) <$> periodStart earlier + _ -> Nothing + where + periodStart (StatementEntry {balanceStartTs} : _) = Just balanceStartTs + periodStart [] = (\BadgeLedgerEntry {balanceStartTs} -> balanceStartTs) <$> heldEntry_ + +-- | The pass's unlocked half: a new credential is presented to contacts, and any change at all +-- is reported to the app. It must be called with the per-user badge lock RELEASED, because +-- 'presentUserBadgeToContacts' takes 'chatLock'. +presentBadgeChange :: BadgeChange -> CM () +presentBadgeChange = \case + BadgeUnchanged -> pure () + BadgeLedgerChanged user -> badgeChanged user + BadgeIssued user -> presentUserBadgeToContacts user >> badgeChanged user + where + badgeChanged user = toView . CEvtBadgeChanged user =<< getUserBadgeState user + assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM () assertDirectAllowed user dir ct event = unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 165371c1a3..1b404692c4 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -159,6 +159,18 @@ withFileLock :: Text -> Int64 -> CM a -> CM a withFileLock name = withEntityLock name . CLFile {-# INLINE withFileLock #-} +-- | Serializes the signed badge operations of one profile: the 'BadgeManager' pass and every +-- command that sends a signed badge request take it, so one such operation per user is in +-- flight and no two of them interleave their reads and writes of that profile's badge rows. +-- +-- It is an ordinary entity lock over the shared 'entityLocks' map, so it inherits the +-- @chatLock@-first order rather than introducing one. A holder must RELEASE it before calling +-- anything that takes @chatLock@ itself — 'Simplex.Chat.Library.Commands.presentUserBadgeToContacts' +-- in particular. +withBadgeLock :: Text -> UserId -> CM a -> CM a +withBadgeLock name = withEntityLock name . CLBadge +{-# INLINE withBadgeLock #-} + useServerCfgs :: forall p. UserProtocol p => SProtocolType p -> RandomAgentServers -> [(Text, ServerOperator)] -> [UserServer p] -> NonEmpty (ServerCfg p) useServerCfgs p RandomAgentServers {smpServers, xftpServers} opDomains = fromMaybe (rndAgentServers p) . L.nonEmpty . agentServerCfgs p opDomains diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index ceaf905df0..26a96af6ac 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -73,6 +73,10 @@ data ChatLockEntity | CLUserContact Int64 | CLContactRequest Int64 | CLFile Int64 + | -- | One signed badge operation per profile at a time: the monthly issuance pass and the + -- commands that send signed badge requests all take it, so they cannot interleave their + -- reads and writes of that profile's purchase, ledger and badge rows. + CLBadge UserId deriving (Eq, Ord) -- These error type constructors must be added to mobile apps diff --git a/tests/Bots/BadgeManagerTests.hs b/tests/Bots/BadgeManagerTests.hs new file mode 100644 index 0000000000..7919d5bf54 --- /dev/null +++ b/tests/Bots/BadgeManagerTests.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | Tests for the @BadgeManager@ worker: what one pass writes when a response is applied, and +-- that the signals arriving during a pass run one more pass rather than a concurrent one. +-- +-- Registered under the "Supporter badges" hspec path so CI runs it (plan §4 rule 8), inside +-- 'testBracket', which is what gives these tests a chat controller. No badge service is started +-- and no RPC is sent: 'sendBadgeRequest' is C3's stub, so the tests apply a response to the pass +-- directly, composing the pass's two production halves ('storeBadgeIssueResponse' under the +-- badge lock in production, then 'presentBadgeChange' outside it) exactly as +-- 'issueDueBadgePeriod' and 'badgeManagerPass' compose them. +-- +-- __No test waits on 'badgePassInterval'.__ A pass is driven by @\/_badge state@ (which signals +-- the worker) and paced by the injected 'badgeCurrentTime', which every pass reads exactly once +-- before it reads any state — so the test can count passes and hold one open without sleeping. +module Bots.BadgeManagerTests (badgeManagerTests) where + +import ChatClient +import ChatTests.DBUtils +import ChatTests.Profiles (testBadgeKeys) +import ChatTests.Utils +import Control.Concurrent.STM (retry) +import Control.Monad (forM_, unless) +import Control.Monad.Except (runExceptT) +import Control.Monad.Reader (runReaderT) +import qualified Data.Aeson as J +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), secondsToDiffTime) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeRequest (..), BadgeType (..), VerifiedBadgeRequest (..), generateMasterKey, issueBadge) +import Simplex.Chat.Badges.Months (addMonths, sundayAfter) +import Simplex.Chat.Badges.Service + ( BadgeServiceResponse (..), + BadgeStatement (..), + StatementCreditType (..), + StatementDebitType (..), + StatementEntry (..), + StatementEntryType (..), + ) +import Simplex.Chat.Badges.Types (BadgeLedgerEntry (..)) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), CM) +import Simplex.Chat.Library.Commands (presentBadgeChange, storeBadgeIssueResponse) +import Simplex.Chat.Store.Badges (UserBadgePurchase (..), createCodePayment, createPurchase, getLastBadgeLedgerEntry, insertLedgerEntries, setShownPurchase) +import Simplex.Chat.Types (User (..)) +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Agent.Store.DB (Binary (..)) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen) +import Test.Hspec hiding (it) +import System.Timeout (timeout) +import UnliftIO.STM +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..)) +#else +import Database.SQLite.Simple (Only (..)) +#endif + +badgeManagerTests :: SpecWith TestParams +badgeManagerTests = do + describe "applying an issueBadge response" $ do + it "stores the statement, writes the issuance, sets the profile badge and reports the change" testIssuedCredentialApplied + it "discards a credential signed by another key and writes nothing at all" testForeignCredentialRejected + it "an exhausted balance stores the statement, writes no issuance and keeps the badge" testExhaustedBalanceApplied + describe "the badge worker" $ + it "collapses the signals that arrive during a pass into one more pass, never a concurrent one" testSignalsDuringPassRunOnePass + +-- Fixtures -------------------------------------------------------------------- + +-- | The instant the fixture's balance starts running, and the start of the period the pass +-- issues. Whole seconds: Postgres @TIMESTAMPTZ@ keeps microseconds while 'getCurrentTime' has +-- nanosecond resolution on Linux, so only a rounded instant survives both backends. +periodStart :: UTCTime +periodStart = UTCTime (fromGregorian 2026 3 1) (secondsToDiffTime 0) + +-- | The end of that period, which is where @issue@ leaves @balanceStartTs@. +periodEnd :: UTCTime +periodEnd = addMonths 1 periodStart + +-- | Inside the period, so the fixture's balance funds an unissued month at this instant. +passNow :: UTCTime +passNow = UTCTime (fromGregorian 2026 3 15) (secondsToDiffTime 0) + +heldEntryUuid :: Text +heldEntryUuid = "held-credit" + +-- | The purchase's ledger before the pass: two months credited, running from 'periodStart'. +creditEntry :: StatementEntry +creditEntry = fixtureEntry heldEntryUuid 2 2 periodStart (SECredit SCPayment {invoiceId = Nothing}) + +-- | The @debit(badge)@ an issue writes, and the only thing the client can read the issued period +-- back from: one month spent, and @balanceStartTs@ moved to the END of the period issued. +issuedDebitEntry :: StatementEntry +issuedDebitEntry = fixtureEntry "issued-debit" (-1) 1 periodEnd (SEDebit SDBadge) + +fixtureEntry :: Text -> Int -> Int -> UTCTime -> StatementEntryType -> StatementEntry +fixtureEntry entryId changeMonths balanceMonths balanceStartTs entryType = + StatementEntry + { entryId, + changeMonths, + balanceMonths, + balanceStartTs, + balanceBadgeType = BTSupporter, + wasPausedSince = Nothing, + -- the service's clock, identical for every entry of one statement + createdAt = passNow, + entryType + } + +-- | Counts and paces the badge passes of a controller. Every pass reads 'badgeCurrentTime' +-- exactly once, before it reads any state, so 'passes' is the number of passes that have STARTED +-- and a pass gets no further until the test grants a permit. +-- +-- Tests that apply a response themselves grant none: that parks the pass chat start signals +-- before it can read the store, so it can never race their fixtures. +data BadgeGate = BadgeGate {passes :: TVar Int, permits :: TVar Int} + +gatedClock :: BadgeGate -> IO UTCTime +gatedClock BadgeGate {passes, permits} = do + atomically $ modifyTVar' passes (+ 1) + atomically $ readTVar permits >>= \n -> if n > 0 then writeTVar permits (n - 1) else retry + pure passNow + +allowPass :: BadgeGate -> IO () +allowPass BadgeGate {permits} = atomically $ modifyTVar' permits (+ 1) + +-- | Waits for @n@ passes to have started. Bounded, so a worker that never runs fails the example +-- instead of hanging it; it is not a wait on badge time. +waitPasses :: HasCallStack => BadgeGate -> Int -> Expectation +waitPasses BadgeGate {passes} n = + timeout 10000000 (atomically $ readTVar passes >>= \m -> unless (m >= n) retry) >>= \case + Just () -> pure () + Nothing -> expectationFailure $ "timed out waiting for badge pass " <> show n + +-- | Nothing more is reported: the assertion that a pass emitted no event and raised no error. +reportsNothing :: HasCallStack => TestCC -> Expectation +reportsNothing cc = cc TestParams -> BBSPublicKey -> (BadgeGate -> TestCC -> IO ()) -> IO () +withBadgeChat ps pk test = do + gate <- BadgeGate <$> newTVarIO 0 <*> newTVarIO 0 + let cfg = testCfg {badgePublicKeys = testBadgeKeys pk, badgeCurrentTime = gatedClock gate} + withNewTestChatCfg ps cfg "alice" aliceProfile $ test gate + +-- | A shown, issued purchase with two months credited, and the last ledger entry a pass would +-- assert to the service. +setupShownPurchase :: TestCC -> IO (UserBadgePurchase, BadgeLedgerEntry) +setupShownPurchase cc = do + User {userId} <- testUser cc + drg <- C.newRandom + (pubKey, privKey) <- atomically $ C.generateKeyPair drg + mk <- generateMasterKey drg + r <- withChatStore cc $ \db -> do + paymentId <- createCodePayment db periodStart + p@UserBadgePurchase {badgePurchaseId = pId} <- createPurchase db userId pubKey privKey mk BTSupporter paymentId periodStart + runExceptT $ do + setShownPurchase db userId pId + insertLedgerEntries db pId BadgeStatement {entries = [creditEntry], previousEntryId = Nothing} periodStart + (p,) <$> getLastBadgeLedgerEntry db pId + case r of + Right (p, Just e) -> pure (p, e) + _ -> fail "badge fixture: the purchase or its credit entry was not stored" + +testUser :: TestCC -> IO User +testUser TestCC {chatController = ChatController {currentUser}} = + readTVarIO currentUser >>= maybe (fail "no current user") pure + +withChatStore :: TestCC -> (DB.Connection -> IO a) -> IO a +withChatStore TestCC {chatController = ChatController {chatStore}} = withTransaction chatStore + +runCM :: TestCC -> CM a -> IO a +runCM TestCC {chatController} action = runReaderT (runExceptT action) chatController >>= either (fail . show) pure + +-- | The pass's second half, composed exactly as 'badgeManagerPass' composes it: the response is +-- stored (in production under the per-user badge lock) and the change it made is then presented +-- and reported (in production with that lock released). +applyIssueResponse :: TestCC -> UserBadgePurchase -> Maybe BadgeLedgerEntry -> BadgeServiceResponse -> IO () +applyIssueResponse cc purchase heldEntry_ resp = do + user <- testUser cc + runCM cc $ storeBadgeIssueResponse passNow user purchase heldEntry_ resp >>= presentBadgeChange + +-- | A credential for the fixture's period, signed by the given issuer key. The master key is the +-- PURCHASE's, as the request the worker sends carries it. +issuedCredential :: BBSSecretKey -> UserBadgePurchase -> IO BadgeCredential +issuedCredential sk UserBadgePurchase {masterKey} = do + let badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Just (sundayAfter periodEnd), badgeExtra = ""} + issueBadge 1 sk (VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo}) >>= either fail pure + +badgeCredentialResponse :: Maybe BadgeCredential -> BadgeStatement -> BadgeServiceResponse +badgeCredentialResponse credential statement = BSPBadgeCredential {credential, receipt = Nothing, statement} + +-- Assertions ------------------------------------------------------------------ + +lastLedgerEntry :: TestCC -> Int64 -> IO (Maybe BadgeLedgerEntry) +lastLedgerEntry cc pId = + withChatStore cc (\db -> runExceptT $ getLastBadgeLedgerEntry db pId) >>= either (fail . show) pure + +ledgerUuids :: TestCC -> Int64 -> IO [Text] +ledgerUuids cc pId = + map fromOnly + <$> withChatStore cc (\db -> DB.query db "SELECT entry_uuid FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id ASC" (Only pId)) + +-- | @(badge_purchase_id, badge_type, period_start, period_end, expiry, entry_id)@ of every +-- issuance, read from the table rather than from what 'createIssuance' returned. +issuanceRows :: TestCC -> IO [(Int64, Text, UTCTime, UTCTime, UTCTime, Maybe Int64)] +issuanceRows cc = + withChatStore cc $ \db -> + DB.query_ db "SELECT badge_purchase_id, badge_type, period_start, period_end, expiry, entry_id FROM badge_issuances ORDER BY period_start ASC" + +-- | The credential stored with the only issuance, decoded from the JSON it is stored as. +storedCredential :: TestCC -> IO BadgeCredential +storedCredential cc = do + rows <- withChatStore cc $ \db -> DB.query_ db "SELECT credential FROM badge_issuances" + case rows of + [Only (Binary bs)] -> maybe (fail "stored badge credential does not decode") pure (J.decodeStrict (bs :: ByteString)) + _ -> fail $ "expected exactly one badge issuance, got " <> show (length rows) + +hasNoBadge :: HasCallStack => TestCC -> Expectation +hasNoBadge cc = do + cc ##> "/p" + cc <## "user profile: alice (Alice)" + cc <## "use /p [] to change it" + +hasSupporterBadge :: HasCallStack => TestCC -> Expectation +hasSupporterBadge cc = do + cc ##> "/p" + cc <## "user profile: alice (Alice, * supporter)" + cc <## "use /p [] to change it" + +-- Tests ----------------------------------------------------------------------- + +-- | The whole write set of one issued period, in one place: the statement's rows, the issuance +-- naming the period the @debit(badge)@ implies, the credential on the profile, and the event. +testIssuedCredentialApplied :: HasCallStack => TestParams -> IO () +testIssuedCredentialApplied ps = do + Right (pk, sk) <- bbsKeyGen + withBadgeChat ps pk $ \_gate alice -> do + (purchase@UserBadgePurchase {badgePurchaseId = pId}, heldEntry) <- setupShownPurchase alice + cred <- issuedCredential sk purchase + let statement = BadgeStatement {entries = [issuedDebitEntry], previousEntryId = Just heldEntryUuid} + applyIssueResponse alice purchase (Just heldEntry) (badgeCredentialResponse (Just cred) statement) + -- the balance left, and the date it is paid through: one month from the END of the period + -- just issued, never the credential's expiry + alice <## "supporter badge 1 (shown): issued, 1 month(s) left, paid through 2026-05-01" + ledgerUuids alice pId `shouldReturn` [heldEntryUuid, "issued-debit"] + -- period_start is the balanceStartTs in force before the debit(badge) and period_end is the + -- one the debit left; entry_id stays NULL (plan §9) + issuanceRows alice `shouldReturn` [(pId, "supporter", periodStart, periodEnd, sundayAfter periodEnd, Nothing)] + storedCredential alice `shouldReturn` cred + hasSupporterBadge alice + +-- | The credential verifies against a key the controller is not configured with, so the whole +-- response is discarded — the statement included, since a response whose credential is not ours +-- is not one to trust the rest of. +testForeignCredentialRejected :: HasCallStack => TestParams -> IO () +testForeignCredentialRejected ps = do + Right (pk, _sk) <- bbsKeyGen + Right (_otherPk, otherSk) <- bbsKeyGen + withBadgeChat ps pk $ \_gate alice -> do + (purchase@UserBadgePurchase {badgePurchaseId = pId}, heldEntry) <- setupShownPurchase alice + cred <- issuedCredential otherSk purchase + let statement = BadgeStatement {entries = [issuedDebitEntry], previousEntryId = Just heldEntryUuid} + applyIssueResponse alice purchase (Just heldEntry) (badgeCredentialResponse (Just cred) statement) + alice <## "badge service error: internal, badge credential does not verify against configured key" + ledgerUuids alice pId `shouldReturn` [heldEntryUuid] + issuanceRows alice `shouldReturn` [] + hasNoBadge alice + reportsNothing alice + +-- | @credential = Nothing@ is the exhausted balance, not an error: the statement is stored, no +-- issuance is written, the profile's badge is left alone, and the event is emitted only because +-- the stored state actually changed — re-delivering the same statement emits nothing. +testExhaustedBalanceApplied :: HasCallStack => TestParams -> IO () +testExhaustedBalanceApplied ps = do + Right (pk, _sk) <- bbsKeyGen + withBadgeChat ps pk $ \_gate alice -> do + (purchase@UserBadgePurchase {badgePurchaseId = pId}, heldEntry) <- setupShownPurchase alice + let lapsed = fixtureEntry "lapse-1" (-2) 0 (addMonths 2 periodStart) (SEDebit SDLapse) + statement = BadgeStatement {entries = [lapsed], previousEntryId = Just heldEntryUuid} + applyIssueResponse alice purchase (Just heldEntry) (badgeCredentialResponse Nothing statement) + alice <## "supporter badge 1 (shown): issued, 0 month(s) left, paid through 2026-05-01" + ledgerUuids alice pId `shouldReturn` [heldEntryUuid, "lapse-1"] + issuanceRows alice `shouldReturn` [] + hasNoBadge alice + -- the same statement again changes nothing, so nothing is reported + heldEntry' <- lastLedgerEntry alice pId + applyIssueResponse alice purchase heldEntry' (badgeCredentialResponse Nothing statement) + ledgerUuids alice pId `shouldReturn` [heldEntryUuid, "lapse-1"] + reportsNothing alice + +-- | Three signals arriving while a pass runs leave the worker with ONE more pass to run, not +-- three and not a concurrent one. The gated clock is what makes this deterministic: the pass +-- chat start signalled is parked at its first line, so every signal below provably arrives +-- while it is still running. +testSignalsDuringPassRunOnePass :: HasCallStack => TestParams -> IO () +testSignalsDuringPassRunOnePass ps = do + Right (pk, _sk) <- bbsKeyGen + withBadgeChat ps pk $ \gate alice -> do + waitPasses gate 1 + _ <- setupShownPurchase alice + forM_ [1 :: Int .. 3] $ \_ -> do + alice ##> "/_badge state 1" + alice <## "supporter badge 1 (shown): issued, 2 month(s) left, paid through 2026-05-01" + alice <## "badge site: not configured" + -- the three signals did not start a pass of their own: the first one is still running + readTVarIO (passes gate) `shouldReturn` 1 + -- released, it finds the month due and reports what C3's stub send path answers + allowPass gate + alice <## "badge service error: internal, not implemented" + waitPasses gate 2 + allowPass gate + alice <## "badge service error: internal, not implemented" + -- and that is the only pass the three signals bought, however many they were + reportsNothing alice + readTVarIO (passes gate) `shouldReturn` 2 diff --git a/tests/Test.hs b/tests/Test.hs index 75bb618266..2d6f1dd604 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -5,6 +5,7 @@ import Bots.BadgeCodeTests import Bots.BadgeLedgerTests +import Bots.BadgeManagerTests import Bots.BadgeServiceTests import Bots.BadgeStoreTests import Bots.BroadcastTests @@ -90,6 +91,7 @@ main = do describe "Mobile API Tests" mobileTests #endif describe "Supporter badges store" badgeStoreTests + describe "Supporter badges manager" badgeManagerTests describe "SimpleX chat client" chatTests xdescribe'' "SimpleX Broadcast bot" broadcastBotTests xdescribe'' "SimpleX Directory service bot" directoryServiceTests