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 24f0fe1f09..25ab5ccc00 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -147,7 +147,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | 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 | ☐ | +| 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 | ☐ | | D1 | Web project skeleton and tsc build | — | ☐ | @@ -696,7 +696,7 @@ badgeWorkers :: TMap UserId Worker -- a ChatController field: agent Worker, d - Initialise `badgeWorkers` where `deliveryTaskWorkers` and `relayRequestWorkers` are initialised (`src/Simplex/Chat.hs:196-198,242-244`). `stopChatController` (`Library/Commands.hs:348`) cancels no worker map today, so this step adds the badge-worker cancellation there with `cancelWorker`; that is new code, not a pattern to copy. - 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. +- The worker calls `sendBadgeRequest`, the single send path C4 implements in `Library/Commands.hs` (C4 gave it the request mode and the `User` as well, §9). 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 — 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; a credential that fails verification is discarded and nothing is written. **Every user gets a worker (below), so the profile a pass just wrote need not be the active one** — write the `User` it returns to the `currentUser` TVar only when that profile IS the active one, on the read-then-compare-then-write idiom already used at `Commands.hs:576,1647,4373` (§9). 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: @@ -715,12 +715,13 @@ badgeWorkers :: TMap UserId Worker -- a ChatController field: agent Worker, d **Do:** `sendBadgeRequest`, the single send path C3's worker also calls, plus `APIPurchaseBadge` with a code, under the per-user badge lock, and `APIGetBadgeCatalog`: - Generate the purchase keypair (Ed25519, per core §5) and the badge master key in memory, and hold them for the duration of the call. Nothing is written before the response, because the purchase row's two badge-type columns are `NOT NULL` and the badge type is not known until the service states it (C1). A fresh key per redemption is the rule (§3). -- `sendBadgeRequest :: Maybe C.PrivateKeyEd25519 -> BadgeServiceRequest -> CM BadgeServiceResponse` connects to `ChatConfig.badgeServiceAddress` if no connection to it exists, waits for it to be ready, and sends signed with the given key or unsigned when it is `Nothing` (B5's identity rules). It runs in `CM`, so it has the controller; the connection is established lazily on first use, not at profile creation, so a user who never buys a badge never contacts the service. It replaces C3's stub. -- Send `purchaseBadge`. -- On success, call C2's `verifyUserBadge` first: a credential that fails verification surfaces as `CEBadgeServiceError` and writes nothing. Its `Left` becomes `CEBadgeServiceError` with `badgeError = BSEInternal` and the `Left` text as `message`: the failure is local, and no `BadgeServiceErrorCode` denotes one. Then, in one transaction, call C1's `createCodePayment`, `createPurchase` with the response's badge type and the held keys, `insertLedgerEntries` for the statement verbatim, `createIssuance` for the credential, `supersedePurchases` for that slot, `setShownPurchase` and `setUserBadge`. Write the `User` `setUserBadge` returns to the `currentUser` TVar, or the in-memory user keeps the old badge. Release the per-user badge lock, then call C2's `presentUserBadgeToContacts` with that `User`, which takes `chatLock` and broadcasts the updated profile. The badge type, and with it the slot, is stated in the response (core §5). These are the **client's** tables; B7 writes the service's own `badge_purchases` row independently, and the two databases share only the ledger rows. +- `sendBadgeRequest :: NetworkRequestMode -> User -> Maybe C.PrivateKeyEd25519 -> BadgeServiceRequest -> CM BadgeServiceResponse` sends one RPC to `ChatConfig.badgeServiceAddress`, signed with the given key or unsigned when it is `Nothing` (B5's identity rules). The agent's service request is its own connection — it joins the address, takes the one reply and deletes the connection again — so nothing is contacted until a badge command sends something and a profile that never buys a badge never reaches the service. It takes the profile's `User` and the request mode rather than reading the active user (§9), and returns its transport failures as `BSPError internal` rather than throwing them (§9). It replaces C3's stub. +- Send `purchaseBadge`, once per tier a code can fund: the client cannot know a code's tier and B7 refuses a `badgeRequest` naming another one, so the code is presented under `supporter` then `legend` until the service stops answering `bad_request` (§9). +- On success, call C2's `verifyUserBadge` first: a credential that fails verification surfaces as `CEBadgeServiceError` and writes nothing. Its `Left` becomes `CEBadgeServiceError` with `badgeError = BSEInternal` and the `Left` text as `message`: the failure is local, and no `BadgeServiceErrorCode` denotes one. Then, in one transaction, call C1's `createCodePayment`, `createPurchase` with the response's badge type and the held keys, `insertLedgerEntries` for the statement verbatim, `createIssuance` for the credential, `supersedePurchases` for that slot, `setShownPurchase` and `setUserBadge`. Write the `User` `setUserBadge` returns to the `currentUser` TVar when that profile is the active one, on the read-then-compare-then-write idiom C3's pass uses (§9), or the in-memory user keeps the old badge. Release the per-user badge lock, then call C2's `presentUserBadgeToContacts` with that `User`, which takes `chatLock` and broadcasts the updated profile. The badge type, and with it the slot, is stated in the response (core §5). These are the **client's** tables; B7 writes the service's own `badge_purchases` row independently, and the two databases share only the ledger rows. - Do not signal the worker: C4 has already presented the badge, and the current month is issued, so a pass would find nothing to do. The next pass comes from C3's timer or the next `APIGetBadgeState`. - On timeout, surface the error to the user. A code consumed by a lost response is recovered with H2's `codes unredeem`. -- `APIGetBadgeCatalog` calls `sendBadgeRequest Nothing` and returns `CRBadgeCatalog`, offers included with their server-computed totals (A2, B6). It takes no user lock, stores nothing and computes nothing. A failure surfaces as `CEBadgeServiceError`, which G4 and G5 render as an unavailable price. +- `APIPurchaseBadge` answers `CRBadgeState` for the profile it has just changed and emits no event (§9); its store payment cases are refused (§9). +- `APIGetBadgeCatalog` calls `sendBadgeRequest` unsigned and returns `CRBadgeCatalog`, offers included with their server-computed totals (A2, B6). It takes no user lock, stores nothing and computes nothing. A failure surfaces as `CEBadgeServiceError`, which G4 and G5 render as an unavailable price. **Verify:** covered by C5. @@ -1414,6 +1415,16 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **C3 review round — the lock ordering that is this step's central risk has no regression test.** `badgeManagerPass` reads the user row, then takes the badge lock and runs `issueDueBadgePeriod`, then releases it before `presentBadgeChange`. This is guaranteed by source shape alone — nothing tests that a concurrent operation on the same profile cannot interleave between the lock's release and `presentUserBadgeToContacts`. `BadgeGate`'s doc comment in `BadgeManagerTests.hs` was also corrected: the gated clock parks a pass after `badgeManagerPass`'s own `getUser` but before `issueDueBadgePeriod` reads the purchase or ledger, not "before it reads any state". - **C3 review round — `APIGetBadgeState` racing `stopChatController`'s worker-map swap can re-insert an uncancelled worker. Recorded, not fixed.** `getAgentWorker` can create and insert a fresh entry into `badgeWorkers` between the map being swapped to empty and the old workers being cancelled; that entry is then never cancelled. Same shape as a pattern already present in the agent's own worker bookkeeping elsewhere in the codebase, not introduced by this step. Left as a known gap: `stopChatController` runs once per process shutdown, and the window is one `getAgentWorker` call wide. +- **C4 — `sendBadgeRequest` also takes the `NetworkRequestMode` and the `User`.** The step's signature is `Maybe C.PrivateKeyEd25519 -> BadgeServiceRequest -> CM BadgeServiceResponse`, but the agent's service request is created under an agent user (`aUserId`) and resolves a short link or a SimpleX name under a request mode. Reading the ACTIVE user inside the send would put C3's per-profile pass on whichever profile happens to be active — the same defect class as the `currentUser` write the C3 review round fixed — so the caller states the profile instead: the two commands pass `withUserId`'s user and `processChatCommand`'s `nm`, the worker passes its own pass's user and `NRMBackground`. It is still one send path with three call sites, not a second one. +- **C4 — a redemption code is presented once per tier, because the client cannot know which tier it funds.** The step, core §5 and UX 2.8 all have the RESPONSE state the badge type — and the client does need it stated, since `badge_purchases.initial_badge_type`/`current_badge_type` are `NOT NULL` and a code carries no tier (B3: 20 opaque characters). But B7 added, beyond its own step and for good reason (§9 above), a check that refuses a `purchaseBadge` whose `badgeRequest` names a tier other than the code's with `bad_request`, because `issueSignedBadge` signs the badge info it is handed. The two cannot both hold for a client that does not already know the tier, and no client does: G2's and G3's redeem views are a code field and a paste button, and a code may also come from `codes issue` (B8) or an order the app never opened. C4 therefore presents the code under `supporter`, then under `legend` — `codeBadgeTypes`, the two tiers `codes.badge_type` admits. The probe is bounded and costs nothing but a second round trip on a legend code: the tier check runs before anything is planned, so a refusal writes nothing, leaves the code unredeemed and debits neither throttle bucket (B10 [7.4]), and the service can only ever issue the tier the code funds, so no wrong-tier credential is reachable. **The clean fix is a service one and was not taken here:** `handlePurchaseCode` could sign the CODE's tier, overriding what the request named exactly as it already overrides `badgeExpiry`, which keeps B7's security property (a credential can never exceed its funding) and makes the redemption one request again. That is a change to another step's code and to a mutation-proved security assertion (B10 item 6), so it is recorded for the plan owner rather than made by C4. +- **C4 — `sendBadgeRequest` returns its failures as `BSPError internal` and never throws.** An unconfigured `badgeServiceAddress`, a timeout, an agent failure and a response that does not decode are all answers to the request. Both callers already handle a service error — the worker reports it and keeps its state, the commands raise it as `CEBadgeServiceError` — and raising here would hand the worker's pass a chat error of a different shape for the transport half of the same operation. This is also what C3's report asked for ("a timeout must surface as a `BSPError`, not an exception"). +- **C4 — nothing is written when the response cannot be recorded in full.** A credential that fails verification, one carrying no expiry, a statement with no issued period, and a `badgeCredential` with no credential at all each raise `CEBadgeServiceError` and write NOTHING — the payment, purchase, ledger, issuance and shown-badge rows are one transaction and none of them lands. This extends C3's rule for a failed verification to the redeem path's other three malformed shapes: a response we cannot record completely is not one to record partially. The code is consumed in those cases, and the recovery is the same one a lost response has, `codes unredeem` (H2). +- **C4 — `APIPurchaseBadge` answers `CRBadgeState` and emits no event.** Nothing in the plan states its response. `CEvtBadgeChanged` is documented as the worker's ("emitted whenever the badge worker changes a profile's badge state"), and the redeeming client gets the new state in the response, so emitting both would report the same change twice to the one caller that asked for it. +- **C4 — the store payment cases of `APIPurchaseBadge` are refused, not ignored.** `BPPApple` and `BPPGoogle` carry the `payments.payment_id` of a row the app's store purchase flow created, and neither that flow nor a writer for that row exists in this plan (§6). Both answer `CEBadgeServiceError internal "badge store payments are not supported"` rather than falling through to a code redemption they are not. +- **C4 — `resolveServiceTarget` is now a top-level function.** It was a `where` clause of `APISendServiceRequest`, and `sendBadgeRequest` needs the same resolution, because a badge service address may be published as a full contact request, a short link or a SimpleX name (B9). One function, two callers, no second resolution. +- **C4 — two `BadgeManagerTests` expectations changed.** They asserted C3's stub answer, `badge service error: internal, not implemented`; with the real send path a test controller, which configures no `badgeServiceAddress`, fails before contacting anything and reports `badge service error: internal, badge service address is not configured`. Same assertion, same shape, new message; no test was weakened or removed. +- **C4 — the Postgres cross-check was not run for this step.** SQLite-only, `CI` unset: `cabal test --test-options='-m "Supporter badges" -m "Badge service"'`. Nothing in this step is guarded `#if !defined(dbPostgres)` and it adds no SQL of its own — every write goes through C1's store functions — so there is no reason to expect a backend-specific gap, but it has not been exercised against Postgres. + ## 10. End-to-end verification After F5: diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 3a192d08d0..d0c83cb73e 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -56,10 +56,11 @@ 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 (..), BadgeInfo (..), BadgeRequest (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeRequest (..), BadgeType (..), LocalBadge (..), generateMasterKey, maxXFTPFileSize, mkBadgeStatus, verifyCredential) import Simplex.Chat.Badges.Months (addMonths) import Simplex.Chat.Badges.Service ( BadgeBalance (..), + BadgeCatalog (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), @@ -71,7 +72,7 @@ import Simplex.Chat.Badges.Service StatementEntryType (..), currentBadgeVersion, ) -import Simplex.Chat.Badges.Types (BadgeLedgerEntry (..), LedgerCreditType (..), LedgerDebitType (..), LedgerEntryType (..), UserBadge (..), UserBadgeState (..)) +import Simplex.Chat.Badges.Types (BadgeLedgerEntry (..), BadgePurchasePayment (..), LedgerCreditType (..), LedgerDebitType (..), LedgerEntryType (..), UserBadge (..), UserBadgeState (..)) import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim) import Simplex.Chat.Call import Simplex.Chat.Controller @@ -84,6 +85,7 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.Operators import Simplex.Chat.Options +import Simplex.Chat.PaymentService (ServicePayment (..)) import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol import Simplex.Chat.Remote @@ -92,7 +94,7 @@ import Simplex.Chat.Library.Internal import Simplex.Chat.Stats import Simplex.Chat.Store import Simplex.Chat.Store.AppSettings -import Simplex.Chat.Store.Badges (NewBadgeIssuance (..), UserBadgePurchase (..), createIssuance, getLastBadgeLedgerEntry, getShownPurchase, hasIssuanceForPeriod, insertLedgerEntries) +import Simplex.Chat.Store.Badges (NewBadgeIssuance (..), UserBadgePurchase (..), createCodePayment, createIssuance, createPurchase, getLastBadgeLedgerEntry, getShownPurchase, hasIssuanceForPeriod, insertLedgerEntries, setShownPurchase, supersedePurchases) import Simplex.Chat.Store.ContactRequest import Simplex.Chat.Store.Connections import Simplex.Chat.Store.Delivery @@ -1487,25 +1489,10 @@ processChatCommand cxt nm = \case pure ct_ pure $ CRContactRequestRejected user cReq ct_ APISendServiceRequest userId sendTarget requestTimeout signKey request -> withUserId userId $ \user -> do - cReq <- resolveServiceTarget user sendTarget + cReq <- resolveServiceTarget nm user sendTarget respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout (C.unStored <$> signKey) (LB.toStrict $ J.encode request) resp <- either (const $ throwCmdError "invalid service response") pure $ J.eitherDecodeStrict' respData pure $ CRServiceResponse user resp - where - resolveServiceTarget user = \case - CTFullContact cReq -> pure cReq - CTShortContact (CTLink sLnk) -> resolveShortLink sLnk - CTShortContact (CTName SimplexNameInfo {nameType, nameDomain}) -> case nameType of - NTContact -> resolveDomain nameDomain - _ -> throwCmdError "service request target must be a contact" - CTDomain d -> resolveDomain d - where - resolveDomain d = do - nr <- withAgent $ \a -> resolveSimplexName a nm (aUserId user) d - case firstNameLink CCTContact (nrSimplexContact nr) of - Just sLnk -> resolveShortLink sLnk - Nothing -> throwChatError $ CESimplexDomainNotReady d SDENoValidLink - resolveShortLink sLnk = (\(_, _, cReq) -> cReq) <$> getShortLinkConnReq nm user sLnk APISendServiceResponse userId requestId responseData -> withUserId userId $ \user -> do let AgentInvId invId = requestId connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId (LB.toStrict $ J.encode responseData) @@ -3581,8 +3568,19 @@ processChatCommand cxt nm = \case -- 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 + -- unsigned and unlocked: it names no purchase, writes nothing and computes no price -- the + -- offers' totals are the service's (decision 8) + APIGetBadgeCatalog userId -> withUserId userId $ \user -> + sendBadgeRequest nm user Nothing catalogRequest >>= \case + BSPBadgeCatalog {catalog = BadgeCatalog {prices, offers}} -> pure CRBadgeCatalog {user, prices, offers} + BSPError {code, message, retryAfter} -> throwChatError CEBadgeServiceError {badgeError = code, badgeErrorMessage = message, retryAfter} + r -> throwChatError $ unexpectedBadgeResponse "getBadgeCatalog" r + APIPurchaseBadge {userId, payment} -> withUserId userId $ \user -> case payment of + BPPCode {code} -> redeemBadgeCode nm user code + -- the store payment flows are out of scope (plan §6): they present the evidence of a + -- payments row the app's purchase flow created, and neither that row nor its writer exists + BPPApple {} -> throwChatError $ localBadgeError storePaymentsUnsupported + BPPGoogle {} -> throwChatError $ localBadgeError storePaymentsUnsupported SetBotCommands commands -> withUser $ \user@User {profile} -> do let LocalProfile {preferences} = profile prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands} @@ -5204,14 +5202,14 @@ badgePaidThrough BadgeLedgerEntry {balanceMonths, balanceStartTs} = addMonths ba 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 = localBadgeError notImplementedMessage +-- | A response of a shape the command it answers cannot have, reported as a local failure with +-- the response in the message: the alternative is a silent no-op on a service that is speaking +-- a protocol this build does not know. +unexpectedBadgeResponse :: Text -> BadgeServiceResponse -> ChatErrorType +unexpectedBadgeResponse cmd r = localBadgeError $ "unexpected badge service response to " <> cmd <> ": " <> tshow r -notImplementedMessage :: Text -notImplementedMessage = "not implemented" +storePaymentsUnsupported :: Text +storePaymentsUnsupported = "badge store payments are not supported" -- | Checks that a credential was signed by a configured issuer key. -- @@ -5319,7 +5317,8 @@ issueDueBadgePeriod user@User {userId} = do Just (purchase@UserBadgePurchase {purchasePrivKey}, Just lastEntry) | badgePeriodDue now lastEntry -> do balance <- assertedBadgeBalance lastEntry - resp <- sendBadgeRequest (Just purchasePrivKey) (badgeIssueRequest purchase balance) + -- the pass is the timer's, not a user's action, so its request is a background one + resp <- sendBadgeRequest NRMBackground user (Just purchasePrivKey) (badgeIssueRequest purchase balance) storeBadgeIssueResponse now user purchase (Just lastEntry) resp | otherwise -> pure BadgeUnchanged -- unreachable via C1's createPurchase, which always inserts an opening credit, but a shown @@ -5412,11 +5411,176 @@ badgeIssueRequest UserBadgePurchase {purchaseKey, masterKey, currentBadgeType} b } } --- | 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} +-- | The contact address of a service request's target, resolving a short link or a SimpleX name +-- to the connection request the agent joins. +-- +-- It is shared by @APISendServiceRequest@, which resolves whatever target the caller states, and +-- by 'sendBadgeRequest', which resolves the one in 'ChatConfig.badgeServiceAddress': a badge +-- service address may be published in any of these forms, so both need the same resolution. +resolveServiceTarget :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> CM (ConnectionRequestUri 'CMContact) +resolveServiceTarget nm user = \case + CTFullContact cReq -> pure cReq + CTShortContact (CTLink sLnk) -> resolveShortLink sLnk + CTShortContact (CTName SimplexNameInfo {nameType, nameDomain}) -> case nameType of + NTContact -> resolveDomain nameDomain + _ -> throwCmdError "service request target must be a contact" + CTDomain d -> resolveDomain d + where + resolveDomain d = do + nr <- withAgent $ \a -> resolveSimplexName a nm (aUserId user) d + case firstNameLink CCTContact (nrSimplexContact nr) of + Just sLnk -> resolveShortLink sLnk + Nothing -> throwChatError $ CESimplexDomainNotReady d SDENoValidLink + resolveShortLink sLnk = (\(_, _, cReq) -> cReq) <$> getShortLinkConnReq nm user sLnk + +-- | The single send path to the badge service: one RPC to 'ChatConfig.badgeServiceAddress', +-- signed with the purchase key it is given or unsigned when it is 'Nothing' (RPC "Identity"). +-- +-- The connection is the service request's own: 'sendServiceRequestAsync' joins the service's +-- contact address, waits for the one reply, and deletes the connection again, so nothing is +-- contacted until a badge command actually sends something and a profile that never buys a +-- badge never reaches the service at all. +-- +-- __It returns its failures as 'BSPError' rather than throwing them.__ An unconfigured address, +-- a timeout, an agent failure and a response that does not decode are all answers to the +-- request, and both callers already handle a service error: the worker reports it and keeps its +-- state, the commands raise it as 'CEBadgeServiceError'. Raising here instead would give the +-- worker's pass a chat error of a different shape for the transport half of the same operation. +-- 'BSEInternal' is the code for all four, on 'localBadgeError''s terms — no +-- 'BadgeServiceErrorCode' denotes a failure of the client's own. +-- +-- It takes the 'User' whose profile the request belongs to, rather than reading the active one: +-- C3's worker runs a pass per profile and the profile it runs for need not be active, and the +-- agent user of the connection must be that profile's (plan §9). +sendBadgeRequest :: NetworkRequestMode -> User -> Maybe C.PrivateKeyEd25519 -> BadgeServiceRequest -> CM BadgeServiceResponse +sendBadgeRequest nm user signKey req = + asks (badgeServiceAddress . config) >>= \case + Nothing -> pure $ badgeRequestFailed "badge service address is not configured" + Just target -> either (badgeRequestFailed . ("badge service request failed: " <>) . tshow) id <$> tryAllErrors (sendRequest target) + where + sendRequest target = do + cReq <- resolveServiceTarget nm user target + respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq Nothing signKey (LB.toStrict $ J.encode req) + pure $ either (badgeRequestFailed . ("invalid badge service response: " <>) . T.pack) id $ J.eitherDecodeStrict' respData + badgeRequestFailed e = BSPError {code = BSEInternal, message = Just e, retryAfter = Nothing} + +-- | The badge tiers a redemption code can fund, in the order a code is presented under. +-- +-- __The client cannot know which tier a code funds before it is redeemed.__ A code is 20 opaque +-- characters (B3) and carries no tier, the response is what states it (core §5), and no command +-- reports a code's tier without redeeming it — yet @purchaseBadge@ refuses a @badgeRequest@ +-- naming a tier other than the code's with @bad_request@ (B7, plan §9), because the service +-- signs the badge info it is sent. So the code is presented once per tier until the service +-- stops refusing it. +-- +-- The probe is safe and cheap by construction: the tier check runs before anything is planned, +-- so a refused presentation writes nothing, leaves the code unredeemed and debits neither +-- throttle bucket (B10), and the service can only ever issue the tier the code funds. It costs +-- one extra round trip for a legend code and none for a supporter one. These are the two tiers +-- @badge_codes.badge_type@ admits (@CHECK (badge_type IN ('supporter','legend'))@); lifetime +-- codes are out of scope (plan §6). +codeBadgeTypes :: NonEmpty BadgeType +codeBadgeTypes = BTSupporter :| [BTLegend] + +-- | Redeems a code: the keys are minted in memory, the badge lock is held across the send and +-- the writes, and the presentation happens after it is released. +-- +-- Nothing is written before the response: the purchase row's two badge-type columns are NOT +-- NULL and the tier is not known until the service states it (C1). A response lost in flight +-- therefore consumes the code with nothing stored, and is recovered with the operator's +-- @codes unredeem@ (H2) — never by re-presenting a key that was kept for a purchase that does +-- not exist. +redeemBadgeCode :: NetworkRequestMode -> User -> Text -> CM ChatResponse +redeemBadgeCode nm user@User {userId} code = do + g <- asks random + (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g + -- one master key per redemption, held for the whole call and written with the purchase row it + -- belongs to: the service does not check the master key of a later issueBadge against the one + -- it recorded, so a rotated key would be answered with a credential bound to the old one + -- (plan §9). A fresh purchase key per redemption is the unlinkability rule (plan §3). + masterKey <- liftIO $ generateMasterKey g + user' <- withBadgeLock "purchaseBadge" userId $ do + (cred, statement) <- purchaseWithCode purchaseKey purchasePrivKey masterKey + now <- liftIO =<< asks (badgeCurrentTime . config) + storeRedeemedBadge now purchaseKey purchasePrivKey masterKey cred statement + -- outside the lock: 'presentUserBadgeToContacts' takes 'chatLock', which the badge lock waits + -- on, so broadcasting under it would invert the two lock orders + presentUserBadgeToContacts user' + badgeState <- getUserBadgeState user' + ChatConfig {badgeWebBaseUrl} <- asks config + pure CRBadgeState {user = user', badgeState, badgeWebBaseUrl} + where + purchaseWithCode purchaseKey purchasePrivKey masterKey = presentCode codeBadgeTypes + where + presentCode (badgeType :| tiers) = + sendBadgeRequest nm user (Just purchasePrivKey) (badgeCodeRequest purchaseKey masterKey badgeType code) >>= \case + BSPBadgeCredential {credential = Just cred, statement} -> pure (cred, statement) + -- the exhausted balance of an issueBadge, which a redemption cannot be: a code + -- credits the months it funds in the same transaction that issues them (B7) + BSPBadgeCredential {credential = Nothing} -> + throwChatError $ localBadgeError "badge service redeemed the code without issuing a credential" + -- the one refusal that is a question about the code rather than an answer about it + BSPError {code = BSEBadRequest} | tier : tiers' <- tiers -> presentCode (tier :| tiers') + BSPError {code = errCode, message, retryAfter} -> + throwChatError CEBadgeServiceError {badgeError = errCode, badgeErrorMessage = message, retryAfter} + r -> throwChatError $ unexpectedBadgeResponse "purchaseBadge" r + -- one transaction: the payment row, the purchase row with the held keys, the statement's + -- ledger rows, the issuance, the slot's supersession, the shown-badge pointer and the + -- profile's own badge columns either all land or none of them do + storeRedeemedBadge now purchaseKey purchasePrivKey masterKey cred statement = do + -- a credential that is not ours is discarded and nothing at all is written, the statement + -- included: a response we cannot verify is not a response to trust the rest of. The + -- failure is the client's own, so it is 'BSEInternal' with the reason (C2, plan §9). + verifyUserBadge cred >>= either (throwChatError . localBadgeError) pure + (periodStart, periodEnd) <- + maybe (throwChatError $ localBadgeError "badge service issued no period for the redeemed code") pure $ + issuedBadgePeriod Nothing statement + case cred of + BadgeCredential {badgeInfo = info@BadgeInfo {badgeType, badgeExpiry = Just expiry}} -> do + user' <- withStore $ \db -> do + paymentId <- liftIO $ createCodePayment db now + UserBadgePurchase {badgePurchaseId} <- liftIO $ createPurchase db userId purchaseKey purchasePrivKey masterKey badgeType paymentId now + insertLedgerEntries db badgePurchaseId statement now + liftIO . void $ + createIssuance db NewBadgeIssuance {badgePurchaseId, badgeType, periodStart, periodEnd, expiry, ledgerEntryId = Nothing, credential = cred} now + -- the slot is the new purchase's own (C1 reads it from the row), so the badge this + -- redemption replaces is superseded and this one becomes the profile's shown badge + supersedePurchases db userId badgePurchaseId now + setShownPurchase db userId badgePurchaseId + liftIO $ setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info))) + -- the command runs for the active profile ('withUserId'), but the active user is read + -- and compared rather than assumed, as C3's pass does: this TVar is the whole app's + -- current profile and nothing here may repoint it (plan §9) + activeUserId <- fmap (\User {userId = uId} -> uId) <$> chatReadVar currentUser + when (activeUserId == Just userId) $ chatWriteVar currentUser $ Just user' + pure 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 + _ -> throwChatError $ localBadgeError "issued badge credential carries no expiry" + +-- | The @purchaseBadge@ request redeeming a code, signed by the purchase key it mints. +-- +-- 'badgeExpiry' is absent and 'badgeExtra' empty on the same terms as 'badgeIssueRequest': the +-- service sets the expiry itself and refuses a non-empty extra. +badgeCodeRequest :: C.PublicKeyEd25519 -> BadgeMasterKey -> BadgeType -> Text -> BadgeServiceRequest +badgeCodeRequest purchaseKey masterKey badgeType code = + BadgeServiceRequest + { version = currentBadgeVersion, + purchaseKey = Just purchaseKey, + request = + BSCPurchaseBadge + { badgeRequest = BadgeRequest {masterKey, badgeInfo = BadgeInfo {badgeType, badgeExpiry = Nothing, badgeExtra = ""}}, + payment = SPCode {code}, + -- upgrades need store evidence or a receipt, both out of scope (plan §6), and a + -- purchase carrying one is refused before its payment is looked at (B7) + upgrade = Nothing + } + } + +-- | The unsigned @getBadgeCatalog@ request: it names no purchase, so it discloses nothing about +-- the profile asking (RPC "Identity"). +catalogRequest :: BadgeServiceRequest +catalogRequest = BadgeServiceRequest {version = currentBadgeVersion, purchaseKey = Nothing, request = BSCGetBadgeCatalog} -- | What one applied badge response changed, which is what decides what happens once the badge -- lock is released. @@ -5471,7 +5635,7 @@ storeBadgeIssueResponse now user@User {userId} UserBadgePurchase {badgePurchaseI _ -> 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 + r -> BadgeUnchanged <$ eToView (ChatError $ unexpectedBadgeResponse "issueBadge" 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 diff --git a/tests/Bots/BadgeManagerTests.hs b/tests/Bots/BadgeManagerTests.hs index 16051004f4..3bf6ec7a59 100644 --- a/tests/Bots/BadgeManagerTests.hs +++ b/tests/Bots/BadgeManagerTests.hs @@ -11,8 +11,9 @@ -- -- 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 +-- and no RPC is sent: the test controllers configure no 'badgeServiceAddress', so +-- 'sendBadgeRequest' fails locally without contacting anything, and 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. -- @@ -324,12 +325,13 @@ testSignalsDuringPassRunOnePass ps = do 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 + -- released, it finds the month due and reports what its send path answers: this controller + -- has no 'badgeServiceAddress', so the request fails locally before anything is sent (C4) allowPass gate - alice <## "badge service error: internal, not implemented" + alice <## "badge service error: internal, badge service address is not configured" waitPasses gate 2 allowPass gate - alice <## "badge service error: internal, not implemented" + alice <## "badge service error: internal, badge service address is not configured" -- and that is the only pass the three signals bought, however many they were reportsNothing alice readTVarIO (passes gate) `shouldReturn` 2