From 074731640141d52c6f65b94b6fb0f32dd5586618 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 26 Aug 2026 13:58:11 +0000 Subject: [PATCH] tests, plan: badge client and service integration --- .../2026-08-21-badges-web-checkout.md | 15 +- tests/Bots/BadgeManagerTests.hs | 22 +- tests/Bots/BadgeServiceTests.hs | 905 +++++++++++++++++- tests/ChatTests/Utils.hs | 38 +- 4 files changed, 955 insertions(+), 25 deletions(-) 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 052282f9df..baa5191b25 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -148,7 +148,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | 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 | ☑ | -| C5 | Client and service integration tests | B10, C4 | ☐ | +| 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 | — | ☐ | | D2 | Design system and site wizard shell | D1 | ☐ | @@ -1430,6 +1430,19 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **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. +- **C5 — the badge-service suite's echo assertion is drained, not compared, and that is a change to the WHOLE test tree.** `##>` asserted that the first line the virtual terminal produced after a command was typed equalled that command; on the badge-service suite it failed about one run in three, in untouched B10 examples, on the long `/_service_request` lines — a different example each time, each passing on rerun (C4's report, its fifth concern). `ChatTests.Utils` now DRAINS that echo instead: `drainEcho` consumes lines until they have spelled the command out, tolerating a leading `"> "` input-prompt prefix and fragments delivered in order, and reports the same mismatch as before for anything else (a line that is not a prefix of what was sent). The echo carries no information the test did not itself write, which is what makes draining it legitimate rather than a weakened assertion; no other assertion in the tree changed. **The mechanism was not reproduced**: seven consecutive runs in this step's session were clean — three of the badge-service suite before the change and four of the full covering suite after it — so the fix is a tolerance justified by C4's evidence rather than by a diagnosis of `readTerminalOutput`'s window diffing. If it recurs, the failure will now name the accumulated fragments. +- **C5 — `withBadgeServiceClock` is a projection of a new `withBadgeServiceAddress`.** Two of C5's cases cannot be written against a harness that owns the second service phase: one runs a client with the service NOT started (the transport-failure case), and one stops the service mid-example, clears a code's redemption in its database and starts it again with the SAME client still running (the `codes unredeem` case) — the service's SQLite file cannot be opened while the service holds it. `withBadgeServiceAddress` performs the first startup phase, reads BOTH published forms of the address, and hands the body the second phase as `withService :: IO () -> IO ()`. `withBadgeServiceClock` is now one call to it and every B10 call site is unchanged. +- **C5 — the full contact request URI is exercised, `CTName` and `CTDomain` are not.** `resolveServiceTarget` accepts four target forms; the short link is what every other example configures and the full URI now has its own redemption. The two name forms need a resolvable SimpleX name published in the test environment, which this harness cannot do — **recorded as untested rather than skipped silently.** +- **C5 — C3's `BadgeGate` is exported and reused, not copied.** The redeem path reads `badgeCurrentTime` at the same point a worker pass does — after the request has been answered and before the first row is written — so gating that clock parks a redemption in exactly the window `redeemBadgeCode`'s `activeUserId == Just userId` guard covers. `Bots.BadgeManagerTests` now exports `BadgeGate`, `newBadgeGate`, `gatedClockAt`, `allowPass` and `waitPasses`; `gatedClock` is `gatedClockAt passNow` and C3's own tests are unchanged. That example also runs the redemption OFF the terminal input loop (`execChatCommand'` on an `async`), because that loop is single-threaded and a `/create user` typed at it would queue behind the parked redemption instead of racing it. +- **C5 — six malformed-response cases needed a stub responder, and it was built.** A live service cannot answer with a null credential, a statement carrying no issued period, a credential with no expiry, a statement carrying an entry type this build cannot store, a response of the wrong shape for the command, or a body that is not a `BadgeServiceResponse` at all — and each of those is a branch of `redeemBadgeCode` whose whole purpose is to write nothing. `withBadgeStub` is a chat client with `clientService` set and `processServiceRequests` on, holding a DR contact address the client is pointed at; the test answers each `CEvtServiceRequest` with a canned body through `/_service_response`. Its credentials are really signed, with a `bbsKeyGen` key the client is configured with, so verification passes and the branch under test is the one that fails. +- **C5 — `codes unredeem` (H2) does not exist yet, so B1's `unredeemCode` is driven directly.** `BadgeService.Admin` has `issue`, `revoke` and `status` only. The recovery case — the same code redeeming again into a NEW purchase that supersedes the old one — calls the store function the H2 command will call, in the window where the service is stopped. When H2 lands it should re-point this example at the command. +- **C5 — codes are seeded with `seedTestCodes`, not through `runAdminCmd`.** B10's helper mints them with B3's generator and stores their hashes exactly as `codes issue` does; `codes issue` itself opens its own store and cannot run while the service holds the database, and it already has its own example (`testBadgeServiceCodesIssueRevokeStatus`). +- **C5 — the transport-failure case shortens the agent's `serviceRequestTimeout` to two seconds.** Its default is thirty, which is longer than any terminal assertion waits. What is pinned is what the client does AFTER the timeout, not what the default is. +- **C5 — `GADTs` is enabled in `Bots.BadgeServiceTests`.** `ConnectTarget` is a GADT and matching one without `MonoLocalBinds` raises `-Wgadt-mono-local-binds`; `Simplex.Chat.Library.Commands`, which matches the same type, enables it for the same reason. The module compiles clean with it. +- **C5 — `badgeCurrentTime` is now exercised on the CLIENT COMMAND path.** C2's entry above said C5 would be the first place the override is proved to work and C3's entry corrected that to C3, for the worker. C5 adds the other half: most examples drive the service clock and `badgeCurrentTime` from ONE `IORef`, so a redemption's stored badge status, its issuance period and the profile's paid-through date are all literal dates, and the worker example crosses a month boundary by moving that one ref. +- **C5 — five production mutations were run to prove the load-bearing assertions can fail.** Appending a suffix to `entry_uuid` in `insertLedgerEntries` fails the ledger parity comparison; deleting `verifyUserBadge` from `storeRedeemedBadge`, and deleting the pre-transaction `checkStatementEntries`, each turn their "writes nothing" example into a redemption that succeeds or raises the wrong error; rotating the master key in `issueDueBadgePeriod`'s request fails the master-key stability assertion with the two keys printed; and reverting the `activeUserId == Just userId` guard to an unconditional `chatWriteVar` fails the profile-switch example with `("active profile", 1)` where 2 was expected. A sixth, writing the `payments` row before the request is sent, fails the row counts of all three "writes nothing" examples with their error messages unchanged — which is what proves the counts themselves are load-bearing and not decoration on a message assertion. All reverted. +- **C5 — what remains untested.** The lock discipline (C3's and C4's own gap: the read-send-write scope and the release before `presentUserBadgeToContacts` still hold by source shape alone); `CTName`/`CTDomain` address forms, above; and the Postgres cross-check, which was not run for this step — it adds no SQL of its own, every write goes through C1's and B1's store functions, and the two `#if !defined(dbPostgres)` guards in the module are B10's, untouched. + ## 10. End-to-end verification After F5: diff --git a/tests/Bots/BadgeManagerTests.hs b/tests/Bots/BadgeManagerTests.hs index 3bf6ec7a59..bcf7e2131c 100644 --- a/tests/Bots/BadgeManagerTests.hs +++ b/tests/Bots/BadgeManagerTests.hs @@ -21,7 +21,11 @@ -- the worker) and paced by the injected 'badgeCurrentTime', which every pass reads exactly once, -- before it reads the purchase or ledger it would act on (though 'badgeManagerPass' has already -- read the user row by then) — so the test can count passes and hold one open without sleeping. -module Bots.BadgeManagerTests (badgeManagerTests) where +-- The gate ('BadgeGate' and friends) is exported because C5 drives a REDEMPTION with it — the +-- redeem path reads 'badgeCurrentTime' at the same point a pass does, after the request is sent +-- and before any row is written — and a second copy of it in another test module would be the +-- same fixture with a second set of defects. +module Bots.BadgeManagerTests (badgeManagerTests, BadgeGate (..), newBadgeGate, gatedClockAt, allowPass, waitPasses) where import ChatClient import ChatTests.DBUtils @@ -128,11 +132,19 @@ fixtureEntry entryId changeMonths balanceMonths balanceStartTs entryType = -- before it can read the purchase or ledger, 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 +newBadgeGate :: IO BadgeGate +newBadgeGate = BadgeGate <$> newTVarIO 0 <*> newTVarIO 0 + +-- | The gated clock, reporting @now@ once a permit is granted. C5 needs a different instant from +-- these tests, and nothing else about the gate differs, so the instant is the argument. +gatedClockAt :: UTCTime -> BadgeGate -> IO UTCTime +gatedClockAt now BadgeGate {passes, permits} = do atomically $ modifyTVar' passes (+ 1) atomically $ readTVar permits >>= \n -> if n > 0 then writeTVar permits (n - 1) else retry - pure passNow + pure now + +gatedClock :: BadgeGate -> IO UTCTime +gatedClock = gatedClockAt passNow allowPass :: BadgeGate -> IO () allowPass BadgeGate {permits} = atomically $ modifyTVar' permits (+ 1) @@ -152,7 +164,7 @@ reportsNothing cc = cc TestParams -> BBSPublicKey -> (BadgeGate -> TestCC -> IO ()) -> IO () withBadgeChat ps pk test = do - gate <- BadgeGate <$> newTVarIO 0 <*> newTVarIO 0 + gate <- newBadgeGate let cfg = testCfg {badgePublicKeys = testBadgeKeys pk, badgeCurrentTime = gatedClock gate} withNewTestChatCfg ps cfg "alice" aliceProfile $ test gate diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 9677c33f59..538fca4985 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -35,15 +37,19 @@ import BadgeService.Credentials (issueSignedBadge, loadIssuerKey) import BadgeService.Options import BadgeService.Service import BadgeService.Store +import Bots.BadgeManagerTests (allowPass, gatedClockAt, newBadgeGate, waitPasses) import ChatClient import ChatTests.DBUtils +import ChatTests.Profiles (testBadgeKeys) import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) -import Control.Concurrent.STM (atomically, readTVarIO) +import Control.Concurrent.Async (async, wait) +import Control.Concurrent.STM (atomically, readTVarIO, writeTVar) import Control.Exception (SomeException, finally, try) -import Control.Monad (forM_, replicateM, void) +import Control.Monad (forM_, replicateM, unless, void) import Control.Monad.Except (ExceptT) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (runReaderT) import Crypto.Random (getRandomBytes) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM @@ -52,7 +58,8 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as LBC import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) -import Data.List (find, isInfixOf, nub) +import Data.Int (Int64) +import Data.List (find, isInfixOf, isPrefixOf, nub, sort, stripPrefix) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, isJust, mapMaybe) import Data.String (fromString) @@ -66,7 +73,7 @@ import Data.Word (Word8, Word32) import GHC.IO.Handle (hDuplicate, hDuplicateTo) -- qualified: 'defaultPrefs' collides with ChatTests.Utils' own (chat preferences, unrelated) import qualified Options.Applicative as O -import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeRequest (..), BadgeType (..), verifyCredential) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeRequest (..), BadgeType (..), VerifiedBadgeRequest (..), generateMasterKey, issueBadge, verifyCredential) import Simplex.Chat.Badges.Months (addMonths) import Simplex.Chat.Badges.Service ( -- 'BadgeBalance', 'StatementEntry' and 'StatementEntryType' import only their @@ -88,7 +95,7 @@ import Simplex.Chat.Badges.Service -- 'BadgeUpgrade' imports only its constructor: its 'receipt' and 'balance' fields collide -- with 'BSPBadgeCredential''s and 'BSCIssueBadge''s, both imported with '(..)' above. BadgeUpgrade (BadgeUpgrade), - StatementCreditType (SCOpening, SCPayment), + StatementCreditType (SCCharge, SCOpening, SCPayment), StatementDebitType (SDBadge, SDLapse), StatementEntry (StatementEntry), StatementEntryType (SECredit, SEDebit), @@ -98,19 +105,24 @@ import Simplex.Chat.Badges.Types ( BadgeItemStatus (..), BadgeLedgerEntry (..), BadgeOfferId (..), + BadgePurchasePayment (BPPCode), BadgePurchaseStatus (..), LedgerCreditType (..), LedgerDebitType (..), LedgerEntryType (..), OfferDiscount (..), ) -import Simplex.Chat.Controller (ChatConfig, ChatController (chatStore)) +import Simplex.Chat.Controller (ChatCommand (APIPurchaseBadge), ChatConfig (..), ChatController (ChatController, chatStore, currentUser, processServiceRequests)) +import Simplex.Chat.Library.Commands (execChatCommand') import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Chat.PaymentService (ServicePayment (..)) import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) -import Simplex.Chat.Types (ChatPeerType (..), Profile (..)) -import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection) +import Simplex.Chat.Types (ChatPeerType (..), ConnectTarget (..), Profile (..), User (User, userId)) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (serviceRequestTimeout)) +import Simplex.Messaging.Agent.Protocol (ConnectionMode (CMContact)) +import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection, withTransaction) +import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface (closeDBStore, createDBStore) import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) @@ -210,6 +222,23 @@ badgeServiceTests = do it "should fail fast on a missing issuer key file" testBadgeIssuerKeyMissingFile it "should fail fast on an issuer key file without a 'secret' line" testBadgeIssuerKeyMalformedFile it "should fail fast on a non-positive key_idx" testBadgeIssuerKeyNonPositiveIdx + -- C5: the client against the live service + it "should redeem a code from a profile with no prior connection and show the badge, with the client ledger matching the service's" testC5RedeemCodeShowsBadge + it "should present the redeemed badge to a contact connected before the redemption" testC5ContactSeesBadgeAfterRedeem + it "should write a legend badge for a legend code redeemed through the tier-less command" testC5RedeemLegendCodeGivesLegendBadge + it "should write nothing for an unknown, an already redeemed and an expired code" testC5RefusedCodesWriteNothing + it "should write nothing when the issued credential does not verify against the configured key" testC5UnverifiableCredentialWritesNothing + it "should answer internal and write nothing when no badge service address is configured" testC5NoServiceAddressConfigured + it "should answer internal and write nothing for apple and google payments" testC5StorePaymentsUnsupported + it "should answer internal and write nothing for both commands with the service stopped" testC5ServiceStoppedIsInternal + it "should supersede the first purchase on a second redemption, leaving its ledger and months alone" testC5SecondCodeSupersedesFirst + it "should return the four seeded offers and both prices to a profile with no prior connection, writing nothing" testC5CatalogFromFreshProfile + it "should issue the second period in one worker pass signalled by the badge state command, keeping the master key" testC5WorkerIssuesSecondPeriod + it "should not repoint the active profile from a redemption that finishes after a profile switch" testC5RedeemAfterProfileSwitchKeepsActiveUser + it "should answer code_used to the same code again, and redeem it into a new purchase once unredeemed" testC5SameCodeAgainThenUnredeemed + it "should redeem through a badge service address given as a full contact request URI" testC5FullContactUriRedeems + it "should write nothing for a redemption response it cannot record in full" testC5UnrecordableResponsesWriteNothing + it "should report a response of the wrong shape and one it cannot read, on both commands" testC5UnreadableResponsesAreReported badgeProfile :: Profile badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} @@ -309,24 +338,41 @@ withBadgeServiceConfig ps = withBadgeServiceClock ps getCurrentTime -- continuous across the between-phases window. This is what lets B10 cross a month boundary or a -- throttle bucket's refill window without any test sleeping -- see 'newTestClock'. withBadgeServiceClock :: HasCallStack => TestParams -> IO UTCTime -> IO () -> IO () -> (TestCC -> String -> IO ()) -> IO () -withBadgeServiceClock ps clock writeConfig betweenPhases test = do +withBadgeServiceClock ps clock writeConfig betweenPhases test = + withBadgeServiceAddress ps clock writeConfig betweenPhases $ \(sLink, _fullLink) withService -> + -- Second start: badge service takes the ShowMyAddress branch, then serves the test body. + withService $ + withNewTestChatCfg ps testCfg "client" bobProfile $ \client -> + test client sLink + +-- | The same first phase, with the SECOND phase handed to the body as @withService@ instead of +-- wrapped around it, and with the service's contact address in both published forms. +-- +-- Two things C5 needs and 'withBadgeServiceClock' cannot give: a chat client that OUTLIVES a +-- service restart (the code is redeemed, the service is stopped, its @codes@ row is unredeemed +-- and the service is started again, all with one client running), and a client running with the +-- service NOT started at all. A body that just wants the service up for its whole length calls +-- @withService@ once, which is what 'withBadgeServiceClock' does above. +-- +-- The full contact request URI is the second element: it is one of the four target forms +-- 'Simplex.Chat.Library.Commands.resolveServiceTarget' accepts and, without it, only the short +-- link would ever be exercised. +withBadgeServiceAddress :: HasCallStack => TestParams -> IO UTCTime -> IO () -> IO () -> ((String, String) -> (IO () -> IO ()) -> IO ()) -> IO () +withBadgeServiceAddress ps clock writeConfig betweenPhases test = do let opts = (mkBadgeServiceOpts ps) {serviceClock = clock} writeConfig withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure () -- First start: badge service takes the CreateMyAddress branch. runBadgeService testCfg opts (pure ()) - -- Reopen the DB to read the link the service created. - bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do + -- Reopen the DB to read the links the service created. + links <- withTestChat ps serviceDbPrefix $ \bs -> do bs <## "subscribed 1 connections on server localhost" bs ##> "/sa" - (sLink, _) <- getContactLinks bs False + links <- getContactLinks bs False bs <## "auto_accept off" - pure sLink + pure links betweenPhases - -- Second start: badge service takes the ShowMyAddress branch, then serves the test body. - runBadgeService testCfg opts $ - withNewTestChatCfg ps testCfg "client" bobProfile $ \client -> - test client bsLink + test links (runBadgeService testCfg opts) runBadgeService :: ChatConfig -> BadgeServiceOpts -> IO () -> IO () runBadgeService cfg opts action = do @@ -2416,3 +2462,828 @@ runMigrationsToRun st = Migrations.run st Nothing runMigrationsToRun :: DBStore -> MigrationsToRun -> IO () runMigrationsToRun st = Migrations.run st Nothing True #endif + +-- C5 -- the client against the live badge service ----------------------------- +-- +-- C4's redeem path, C2's commands and C3's worker, driven through the app's own API against the +-- REAL service rather than a stub. C4's Verify line is "covered by C5", so everything below is +-- the only check that step has, and the rules B10 works to hold here too: +-- * time is injected on BOTH sides -- the service's clock (A6, 'withBadgeServiceAddress') and +-- the client's 'badgeCurrentTime' (C2) -- so no test sleeps and no test waits on +-- 'badgePassInterval'; +-- * expected values are literal (fixed dates, fixed row shapes), never recomputed the way +-- production computes them; +-- * "wrote nothing" is a row count on BOTH databases, never "the error read the same". + +badgeClientDbPrefix :: FilePath +badgeClientDbPrefix = "badge_client" + +badgeSecondClientDbPrefix :: FilePath +badgeSecondClientDbPrefix = "badge_client2" + +badgeStubDbPrefix :: FilePath +badgeStubDbPrefix = "badge_stub" + +-- | The client config that reaches the badge service: the address it published and the issuer key +-- it actually loaded, so a credential it signs verifies here and one signed by anything else does +-- not. +badgeClientCfg :: String -> BBSPublicKey -> ChatConfig +badgeClientCfg address pk = + testCfg {badgeServiceAddress = Just (badgeServiceTarget address), badgePublicKeys = testBadgeKeys pk} + +-- | Parses a published address into the 'ConnectTarget' 'badgeServiceAddress' holds. Both forms +-- the harness reads back decode through this: the short link and the full contact request URI. +badgeServiceTarget :: HasCallStack => String -> ConnectTarget 'CMContact +badgeServiceTarget address = case strDecode (BC.pack address) of + Right target -> target + Left e -> error $ "badge service address " <> address <> " is not a connect target: " <> e + +-- | The C5 harness: B10's badge service on the given clock, and the client that reaches it. +-- +-- The client's config is the body's, because the cases differ in one field each: the issuer key +-- (the unverifiable-credential case configures the WRONG one), the address (the resolution case +-- uses the full URI), the badge clock (the worker case shares the service's, the profile-switch +-- case gates it) and the agent's service request timeout (the stopped-service case has nothing +-- listening). Both published forms of the address are handed to the config builder and to the +-- body, which needs them to configure a SECOND client against the same service. +withBadgeClientCfg :: HasCallStack => TestParams -> IO UTCTime -> IO () -> ((String, String) -> BBSPublicKey -> ChatConfig) -> (TestCC -> (String, String) -> IO ()) -> IO () +withBadgeClientCfg ps serviceClock seedCodes mkCfg test = + withBadgeServiceAddress ps serviceClock (writeTestBadgeServiceConfig ps) seedCodes $ \links withService -> do + pk <- readTestIssuerPublicKey (tmpPath ps) + withService $ + withNewTestChatCfg ps (mkCfg links pk) badgeClientDbPrefix aliceProfile $ \alice -> + test alice links + +-- | The common shape: ONE clock driving the service and the client's badge time alike, so every +-- date below is a literal on both sides and a month is crossed by moving one 'IORef'. +withBadgeClient :: HasCallStack => TestParams -> IORef UTCTime -> IO () -> (TestCC -> IO ()) -> IO () +withBadgeClient ps clock seedCodes test = + withBadgeClientCfg ps (readIORef clock) seedCodes (sharedClockCfg clock) (\alice _ -> test alice) + +sharedClockCfg :: IORef UTCTime -> (String, String) -> BBSPublicKey -> ChatConfig +sharedClockCfg clock (sLink, _fullLink) pk = (badgeClientCfg sLink pk) {badgeCurrentTime = readIORef clock} + +-- | The same, on the REAL clock on both sides: for the example whose assertion depends on the +-- credential still being unexpired when something OTHER than the badge clock reads it -- a +-- CONTACT's copy of the profile, whose badge status is computed against wall-clock time +-- ('Simplex.Chat.Types.toLocalProfile') and would read as expired for a period issued in a fixed +-- past month. +withBadgeClientNow :: HasCallStack => TestParams -> IO () -> (TestCC -> (String, String) -> IO ()) -> IO () +withBadgeClientNow ps seedCodes = withBadgeClientCfg ps getCurrentTime seedCodes (\(sLink, _) pk -> badgeClientCfg sLink pk) + +-- | Runs an action against the CLIENT's store, the way 'withServiceDB' runs one against the +-- service's. +withClientStore :: TestCC -> (DB.Connection -> IO a) -> IO a +withClientStore TestCC {chatController = ChatController {chatStore}} = withTransaction chatStore + +clientUser :: HasCallStack => TestCC -> IO User +clientUser TestCC {chatController = ChatController {currentUser}} = + readTVarIO currentUser >>= maybe (expectationFailure "no active user" >> error "unreachable") pure + +-- | The rows one redemption writes on the CLIENT, counted together: payments, purchases, ledger +-- entries, issuances, and profiles pointing at a shown badge. Every "writes nothing" assertion +-- below pins this tuple, because an unchanged error message is not evidence that nothing was +-- written. +clientBadgeRowCounts :: TestCC -> IO (Int, Int, Int, Int, Int) +clientBadgeRowCounts cc = + withClientStore cc $ \db -> do + payments <- countRows db "payments" + purchases <- countRows db "badge_purchases" + entries <- countRows db "badge_ledger" + issuances <- countRows db "badge_issuances" + [Only shown] <- DB.query_ db "SELECT count(*) FROM users WHERE shown_badge_id IS NOT NULL" + pure (payments, purchases, entries, issuances, shown) + where + countRows db table = do + [Only n] <- DB.query_ db (fromString ("SELECT count(*) FROM " <> table)) + pure n + +noClientBadgeRows :: HasCallStack => String -> TestCC -> Expectation +noClientBadgeRows label cc = do + counts <- clientBadgeRowCounts cc + (label, counts) `shouldBe` (label, (0, 0, 0, 0, 0)) + +-- | The client's ledger replica as the database holds it, in append order. +type ClientLedgerRow = (Text, Int, Int, UTCTime, Text, Text, Maybe Text, Maybe Text, Maybe Text) + +clientLedgerRows :: TestCC -> IO [ClientLedgerRow] +clientLedgerRows cc = + withClientStore cc $ \db -> + DB.query_ db "SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, entry_type, entry_credit_type, entry_debit_type, payment_id FROM badge_ledger ORDER BY entry_id" + +-- | The same columns from the SERVICE's own ledger, which is what the replica is compared to. +type ServiceLedgerParityRow = (Text, Int, Int, UTCTime, Text, Text, Maybe Text, Maybe Text) + +serviceLedgerParityRows :: DB.Connection -> IO [ServiceLedgerParityRow] +serviceLedgerParityRows db = + DB.query_ db "SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, entry_type, entry_credit_type, entry_debit_type FROM sx_badge_service_badge_ledger ORDER BY entry_id" + +-- | §10's row-for-row comparison of the two ledgers: @entry_uuid@, @change_months@, +-- @balance_months@, @balance_start_ts@, @balance_badge_type@ and the entry type must agree +-- exactly, and the client's @payment_id@ must be NULL -- the wire field is the SERVICE's invoice +-- id and the client column holds a CLIENT payments id, so carrying it across would tie the two +-- databases together (C1). +-- +-- Compared entry by entry rather than list against list, so a failure names the entry. +shouldMatchServiceLedger :: HasCallStack => [ClientLedgerRow] -> [ServiceLedgerParityRow] -> Expectation +shouldMatchServiceLedger clientRows serviceRows = do + ("ledger entry count" :: String, length clientRows) `shouldBe` ("ledger entry count", length serviceRows) + forM_ (zip3 [1 :: Int ..] clientRows serviceRows) $ \(n, c, s) -> do + let (cUuid, cChange, cBalance, cTs, cBadgeType, cType, cCredit, cDebit, cPayment) = c + (sUuid, sChange, sBalance, sTs, sBadgeType, sType, sCredit, sDebit) = s + label = "ledger entry " <> show n + (label, (cUuid, cChange, cBalance, cBadgeType, cType, cCredit, cDebit)) + `shouldBe` (label, (sUuid, sChange, sBalance, sBadgeType, sType, sCredit, sDebit)) + cTs `shouldBeStoredAt` sTs + (label <> " client payment_id", cPayment) `shouldBe` (label <> " client payment_id", Nothing) + +-- | The two lines 'CRBadgeState' prints -- the badge and the web base url, which no test config +-- sets. +expectBadgeState :: HasCallStack => TestCC -> String -> Expectation +expectBadgeState cc line = do + cc <## line + cc <## "badge site: not configured" + +-- | Nothing more is reported: no event followed the response. +reportsNoBadgeEvent :: HasCallStack => TestCC -> Expectation +reportsNoBadgeEvent cc = cc String +purchaseCodeCmd code = "/_badge purchase 1 {\"type\":\"code\",\"code\":\"" <> T.unpack code <> "\"}" + +-- The badge state a 3-month code redeemed at 'testClockStart' leaves, spelled out: the period is +-- [2026-03-10, 2026-04-10) and the 2 months still funded run from its end, so the profile is paid +-- through 2026-06-10. +threeMonthBadgeState :: String +threeMonthBadgeState = "supporter badge 1 (shown): issued, 2 month(s) left, paid through 2026-06-10" + +-- | The stored credential of every issuance the client holds, oldest period first. +clientIssuedCredentials :: HasCallStack => TestCC -> IO [BadgeCredential] +clientIssuedCredentials cc = do + rows <- withClientStore cc $ \db -> DB.query_ db "SELECT credential FROM badge_issuances ORDER BY period_start" + mapM decodeCredential rows + where + decodeCredential (Only (Binary bs)) = + maybe (expectationFailure "a stored badge credential does not decode" >> error "unreachable") pure $ + J.decodeStrict (bs :: BC.ByteString) + +-- | The master key of the client's only purchase, as the row holds it. +clientPurchaseMasterKey :: HasCallStack => TestCC -> IO BadgeMasterKey +clientPurchaseMasterKey cc = + withClientStore cc (\db -> DB.query_ db "SELECT master_key FROM badge_purchases") >>= \case + [Only (Binary mk)] -> pure $ BadgeMasterKey mk + other -> expectationFailure ("expected exactly one client purchase, got " <> show (length other)) >> error "unreachable" + +credentialMasterKey :: BadgeCredential -> BadgeMasterKey +credentialMasterKey BadgeCredential {masterKey} = masterKey + +credentialBadgeType :: BadgeCredential -> BadgeType +credentialBadgeType BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = badgeType + +-- The happy path --------------------------------------------------------------- + +-- | A profile with no prior connection to the service redeems a seeded code on the first attempt, +-- and everything that redemption leaves behind is checked in one place: the reported state, the +-- profile's own badge, the five client rows and their columns, the credential's verification under +-- the key the service actually loaded, and the ledger replica against the service's own rows. +-- +-- One 'IORef' is both clocks, so every date is a literal and the client's badge status is computed +-- at the instant the service issued the period. +testC5RedeemCodeShowsBadge :: HasCallStack => TestParams -> IO () +testC5RedeemCodeShowsBadge ps = do + clock <- newTestClock testClockStart + codeRef <- newIORef "" + ledgerRef <- newIORef [] + withBadgeClient ps clock (seedOneSupporterCode ps >>= writeIORef codeRef) $ \alice -> do + code <- readIORef codeRef + alice ##> purchaseCodeCmd code + expectBadgeState alice threeMonthBadgeState + -- the response IS the state: a successful redemption emits no CEvtBadgeChanged, which would + -- print the badge line a second time + reportsNoBadgeEvent alice + -- the profile carries the badge + alice ##> "/p" + alice <## "user profile: alice (Alice, * supporter)" + alice <## "use /p [] to change it" + -- and the state reads the same when asked again (which also signals the worker, and it finds + -- the month already issued and does nothing) + alice ##> "/_badge state 1" + expectBadgeState alice threeMonthBadgeState + reportsNoBadgeEvent alice + -- the credential verifies under the key the service actually loaded, so it went through + -- 'verifyUserBadge' rather than being stored on the service's word + issuerPub <- readTestIssuerPublicKey (tmpPath ps) + cred <- + clientIssuedCredentials alice >>= \case + [c] -> pure c + other -> expectationFailure ("expected exactly one issuance, got " <> show (length other)) >> error "unreachable" + verifyCredential issuerPub cred `shouldReturn` True + credentialBadgeType cred `shouldBe` BTSupporter + -- and it is bound to the master key the purchase row holds + clientPurchaseMasterKey alice `shouldReturn` credentialMasterKey cred + -- exactly one row of each kind, with the columns C1 specified + clientBadgeRowCounts alice `shouldReturn` (1, 1, 2, 1, 1) + User {userId = aliceUserId} <- clientUser alice + withClientStore alice $ \db -> do + [paymentRow] <- DB.query_ db "SELECT payment_id, provider, invoice_id, status FROM payments" + let (paymentRowId, provider, invoiceId, paymentStatus) = paymentRow :: (Text, Text, Maybe Text, Text) + ("payment" :: String, (provider, invoiceId, paymentStatus)) `shouldBe` ("payment", ("code", Nothing, "settled")) + [purchaseRow] <- + DB.query_ db "SELECT badge_purchase_id, user_id, initial_badge_type, current_badge_type, status, payment_id FROM badge_purchases" + let (purchaseId, purchaseUserId, initialType, currentType, purchaseStatus, purchasePayment) = + purchaseRow :: (Int64, Int64, Text, Text, Text, Maybe Text) + ("purchase" :: String, (purchaseUserId, initialType, currentType, purchaseStatus, purchasePayment)) + `shouldBe` ("purchase", (aliceUserId, "supporter", "supporter", "issued", Just paymentRowId)) + -- the private key column is the client-only one C1 added, and without it the purchase could + -- never sign an issueBadge again + [Only privKey] <- DB.query_ db "SELECT purchase_priv_key FROM badge_purchases" + ("purchase private key" :: String, isJust (privKey :: Maybe (Binary BC.ByteString))) + `shouldBe` ("purchase private key", True) + [Only shownBadgeId] <- DB.query db "SELECT shown_badge_id FROM users WHERE user_id = ?" (Only aliceUserId) + ("shown badge" :: String, shownBadgeId) `shouldBe` ("shown badge", Just purchaseId) + -- the issuance carries the period the statement implied, and the credential's own expiry + [issuanceRow] <- + DB.query_ db "SELECT badge_purchase_id, badge_type, period_start, period_end, expiry, entry_id FROM badge_issuances" + let (issuancePurchase, issuanceType, periodStart, periodEnd, expiry, entryId) = + issuanceRow :: (Int64, Text, UTCTime, UTCTime, UTCTime, Maybe Int64) + ("issuance" :: String, (issuancePurchase, issuanceType, entryId)) + `shouldBe` ("issuance", (purchaseId, "supporter", Nothing)) + periodStart `shouldBeStoredAt` testClockStart + periodEnd `shouldBeStoredAt` firstPeriodEnd + expiry `shouldBeStoredAt` firstCredentialExpiry + -- held for the parity check below: the service's database cannot be opened while the service + -- itself is running + clientLedgerRows alice >>= writeIORef ledgerRef + clientRows <- readIORef ledgerRef + withServiceDB ps $ \db -> do + serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + serviceLedgerParityRows db >>= shouldMatchServiceLedger clientRows + +-- | The only assertion that the post-lock broadcast actually happens: a contact connected BEFORE +-- the redemption sees the badge on the profile afterwards, with no action of alice's beyond the +-- redemption itself. +-- +-- The star on @alice *>@ is the assertion: a contact prints it only for a badge it verified and +-- found ACTIVE, and that status is computed against wall-clock time, hence the real clock here. +testC5ContactSeesBadgeAfterRedeem :: HasCallStack => TestParams -> IO () +testC5ContactSeesBadgeAfterRedeem ps = do + codeRef <- newIORef "" + withBadgeClientNow ps (seedOneSupporterCode ps >>= writeIORef codeRef) $ \alice _links -> do + issuerPub <- readTestIssuerPublicKey (tmpPath ps) + withNewTestChatCfg ps (testCfg {badgePublicKeys = testBadgeKeys issuerPub}) badgeSecondClientDbPrefix bobProfile $ \bob -> do + connectUsers alice bob + -- before the redemption the profile bob holds carries no badge + alice #> "@bob hi" + bob <# "alice> hi" + code <- readIORef codeRef + alice ##> purchaseCodeCmd code + alice <##. "supporter badge 1 (shown): issued, 2 month(s) left, paid through " + alice <## "badge site: not configured" + -- the badge XInfo is delivered in order before this message, so bob has stored it + alice #> "@bob hi again" + bob <# "alice *> hi again" + +-- | The client half of the funded-tier ruling: a LEGEND code redeemed through the same tier-less +-- command yields a LEGEND badge. The request names supporter ('badgeCodeRequest' hardcodes it, +-- plan §9) and the service signs the tier the code funds, so the purchase row, the issuance and +-- the profile must all take the tier the RESPONSE carries -- which fails the day 'createPurchase' +-- is fed the request's tier instead of the credential's. +testC5RedeemLegendCodeGivesLegendBadge :: HasCallStack => TestParams -> IO () +testC5RedeemLegendCodeGivesLegendBadge ps = do + clock <- newTestClock testClockStart + codeRef <- newIORef "" + let seedCode = seedTestCodes ps [(BTLegend, 3, testCodeExpiry)] >>= writeIORef codeRef . head + withBadgeClient ps clock seedCode $ \alice -> do + code <- readIORef codeRef + alice ##> purchaseCodeCmd code + expectBadgeState alice "legend badge 1 (shown): issued, 2 month(s) left, paid through 2026-06-10" + alice ##> "/p" + alice <## "user profile: alice (Alice, * legend)" + alice <## "use /p [] to change it" + cred <- + clientIssuedCredentials alice >>= \case + [c] -> pure c + other -> expectationFailure ("expected exactly one issuance, got " <> show (length other)) >> error "unreachable" + credentialBadgeType cred `shouldBe` BTLegend + withClientStore alice $ \db -> do + [purchaseTypes] <- DB.query_ db "SELECT initial_badge_type, current_badge_type FROM badge_purchases" + ("purchase tier" :: String, purchaseTypes :: (Text, Text)) `shouldBe` ("purchase tier", ("legend", "legend")) + [Only issuanceType] <- DB.query_ db "SELECT badge_type FROM badge_issuances" + ("issuance tier" :: String, issuanceType :: Text) `shouldBe` ("issuance tier", "legend") + +-- The paths that must write nothing --------------------------------------------- + +-- | The three service refusals a code can earn, each surfaced with its own code and each leaving +-- the client that asked with no row of any kind. The counts are the assertion: a client that wrote +-- a purchase row and then raised would produce the same three lines. +-- +-- The @code_used@ case needs a SECOND client, not a second command from the first: C4 mints a +-- fresh purchase key per redemption, so the code is presented by a key the service has never seen +-- either way, and a second profile of the same app would prove nothing the second client does not. +testC5RefusedCodesWriteNothing :: HasCallStack => TestParams -> IO () +testC5RefusedCodesWriteNothing ps = do + clock <- newTestClock testClockStart + codesRef <- newIORef [] + let seedCodes = seedTestCodes ps [(BTSupporter, 3, expiredCodeExpiry), (BTSupporter, 3, testCodeExpiry)] >>= writeIORef codesRef + withBadgeClientCfg ps (readIORef clock) seedCodes (sharedClockCfg clock) $ \alice links -> do + [expiredCode, usedCode] <- readIORef codesRef + -- a code the service has never seen + unknownCode <- mintUnknownCode + alice ##> purchaseCodeCmd unknownCode + alice <## "badge service error: code_invalid" + noClientBadgeRows "after an unknown code" alice + -- one that alice then redeems for herself + alice ##> purchaseCodeCmd usedCode + expectBadgeState alice threeMonthBadgeState + pk <- readTestIssuerPublicKey (tmpPath ps) + withNewTestChatCfg ps (sharedClockCfg clock links pk) badgeSecondClientDbPrefix bobProfile $ \bob -> do + bob ##> purchaseCodeCmd usedCode + bob <## "badge service error: code_used" + noClientBadgeRows "after a code redeemed by someone else" bob + bob ##> purchaseCodeCmd expiredCode + bob <## "badge service error: code_expired" + noClientBadgeRows "after an expired code" bob + -- and alice's single redemption is untouched by either refusal + clientBadgeRowCounts alice `shouldReturn` (1, 1, 2, 1, 1) + +-- | The credential is verified BEFORE the transaction opens, so a credential this client cannot +-- verify leaves nothing behind -- even though the service redeemed the code and will never hand it +-- back. The client is started with an issuer key that is not the service's, which is what a +-- rotated or spoofed issuer looks like from here. +testC5UnverifiableCredentialWritesNothing :: HasCallStack => TestParams -> IO () +testC5UnverifiableCredentialWritesNothing ps = do + clock <- newTestClock testClockStart + codeRef <- newIORef "" + Right (otherPk, _otherSk) <- bbsKeyGen + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + cfg (sLink, _fullLink) _servicePk = (badgeClientCfg sLink otherPk) {badgeCurrentTime = readIORef clock} + withBadgeClientCfg ps (readIORef clock) seedCode cfg $ \alice _links -> do + code <- readIORef codeRef + alice ##> purchaseCodeCmd code + alice <## "badge service error: internal, badge credential does not verify against configured key" + noClientBadgeRows "after an unverifiable credential" alice + -- and the service DID redeem it: this is the operator-recoverable case C4's first concern names + code <- readIORef codeRef + codeIsRedeemed ps code `shouldReturn` True + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + +-- | With no badge service address configured, both commands that need one fail locally, contact +-- nothing and write nothing. This is the failure C3's worker already reports a pass with (see +-- 'Bots.BadgeManagerTests'), reached here through the two user-facing commands. +testC5NoServiceAddressConfigured :: HasCallStack => TestParams -> IO () +testC5NoServiceAddressConfigured ps = + withNewTestChatCfg ps testCfg badgeClientDbPrefix aliceProfile $ \alice -> do + alice ##> "/_badge catalog 1" + alice <## "badge service error: internal, badge service address is not configured" + alice ##> purchaseCodeCmd "C5-NO-ADDRESS" + alice <## "badge service error: internal, badge service address is not configured" + reportsNoBadgeEvent alice + noClientBadgeRows "with no service address" alice + +-- | Both store payment methods are reachable through the API today and are permanently refused +-- (plan §6): they present the evidence of a @payments@ row an app purchase flow created, and +-- neither that row nor its writer exists. +testC5StorePaymentsUnsupported :: HasCallStack => TestParams -> IO () +testC5StorePaymentsUnsupported ps = + withNewTestChatCfg ps testCfg badgeClientDbPrefix aliceProfile $ \alice -> do + alice ##> "/_badge purchase 1 {\"type\":\"apple\",\"paymentId\":\"p\",\"jws\":\"j\"}" + alice <## "badge service error: internal, badge store payments are not supported" + alice ##> "/_badge purchase 1 {\"type\":\"google\",\"paymentId\":\"p\",\"token\":\"t\"}" + alice <## "badge service error: internal, badge store payments are not supported" + reportsNoBadgeEvent alice + noClientBadgeRows "after store payments" alice + +-- | With the service's address published but nothing listening on it, both commands report the +-- transport failure as a badge service error and write nothing. +-- +-- The agent's 'serviceRequestTimeout' is shortened to two seconds for this example only: its +-- default is thirty, which is longer than any terminal assertion waits, and what is being pinned +-- is what happens AFTER the timeout, not how long the default is. +testC5ServiceStoppedIsInternal :: HasCallStack => TestParams -> IO () +testC5ServiceStoppedIsInternal ps = + -- the two startup phases publish the service's address and then it stays down: 'withService' is + -- never called + withBadgeServiceAddress ps getCurrentTime (writeTestBadgeServiceConfig ps) (pure ()) $ \(sLink, _fullLink) _withService -> do + pk <- readTestIssuerPublicKey (tmpPath ps) + let cfg = (badgeClientCfg sLink pk) {agentConfig = testAgentCfg {serviceRequestTimeout = 2}} + withNewTestChatCfg ps cfg badgeClientDbPrefix aliceProfile $ \alice -> do + alice ##> "/_badge catalog 1" + alice <##. "badge service error: internal, The badge service could not be reached, and the request was not delivered." + alice ##> purchaseCodeCmd "C5-SERVICE-DOWN" + alice <##. "badge service error: internal, The badge service could not be reached, and the request was not delivered." + noClientBadgeRows "with the service stopped" alice + +-- Supersession and the slot ----------------------------------------------------- + +-- | A second code redeemed on the same profile takes the slot: the first purchase becomes +-- @superseded@ and the second is @issued@ and shown. The first purchase keeps everything it had -- +-- its ledger rows, its issuance and, above all, its unconsumed months, which never move between +-- purchases because purchases are unlinkable and the service cannot transfer a balance. +testC5SecondCodeSupersedesFirst :: HasCallStack => TestParams -> IO () +testC5SecondCodeSupersedesFirst ps = do + clock <- newTestClock testClockStart + codesRef <- newIORef [] + let seedCodes = seedTestCodes ps [(BTSupporter, 3, testCodeExpiry), (BTLegend, 3, testCodeExpiry)] >>= writeIORef codesRef + withBadgeClient ps clock seedCodes $ \alice -> do + [firstCode, secondCode] <- readIORef codesRef + alice ##> purchaseCodeCmd firstCode + expectBadgeState alice threeMonthBadgeState + firstLedger <- clientLedgerRows alice + alice ##> purchaseCodeCmd secondCode + expectBadgeState alice "legend badge 2 (shown): issued, 2 month(s) left, paid through 2026-06-10" + -- two of everything, and one shown badge + clientBadgeRowCounts alice `shouldReturn` (2, 2, 4, 2, 1) + User {userId = aliceUserId} <- clientUser alice + withClientStore alice $ \db -> do + statuses <- DB.query_ db "SELECT badge_purchase_id, current_badge_type, status FROM badge_purchases ORDER BY badge_purchase_id" + ("purchase statuses" :: String, statuses :: [(Int64, Text, Text)]) + `shouldBe` ("purchase statuses", [(1, "supporter", "superseded"), (2, "legend", "issued")]) + [Only shownBadgeId] <- DB.query db "SELECT shown_badge_id FROM users WHERE user_id = ?" (Only aliceUserId) + ("shown badge" :: String, shownBadgeId :: Maybe Int64) `shouldBe` ("shown badge", Just 2) + -- the superseded purchase still has its issuance + [Only firstIssuances] <- DB.query_ db "SELECT count(*) FROM badge_issuances WHERE badge_purchase_id = 1" + ("superseded purchase issuances" :: String, firstIssuances :: Int) `shouldBe` ("superseded purchase issuances", 1) + -- and the months it did not spend are still on it + [Only firstBalance] <- DB.query_ db "SELECT balance_months FROM badge_ledger WHERE badge_purchase_id = 1 ORDER BY entry_id DESC LIMIT 1" + ("superseded purchase months left" :: String, firstBalance :: Int) `shouldBe` ("superseded purchase months left", 2) + -- its ledger rows are the rows it had before the second redemption, unchanged and still first + afterLedger <- clientLedgerRows alice + ("superseded purchase ledger" :: String, take (length firstLedger) afterLedger) + `shouldBe` ("superseded purchase ledger", firstLedger) + +-- The catalog ------------------------------------------------------------------- + +-- | The catalog from a profile with no prior connection: the four seeded offers with the service's +-- own totals and both prices, written nowhere. +-- +-- It is UNSIGNED, and this is what proves it: the service answers a SIGNED @getBadgeCatalog@ from +-- a key it holds no purchase for with @unknown_purchase_key@ +-- ('testBadgeServiceGetCatalogUnknownSignerKey'), and this profile has never bought anything, so a +-- signed request could not have returned a catalog at all. +testC5CatalogFromFreshProfile :: HasCallStack => TestParams -> IO () +testC5CatalogFromFreshProfile ps = do + clock <- newTestClock testClockStart + withBadgeClient ps clock (pure ()) $ \alice -> do + alice ##> "/_badge catalog 1" + -- neither catalog query orders its rows, so the six lines are compared as a set + catalogLines <- replicateM 6 (getTermLine alice) + sort catalogLines + `shouldBe` sort + [ "price 2170da16-66e5-481f-9c75-6949e2dd14e1: supporter 700 usd per month, active", + "price 6a778279-753e-45db-8acc-0e382c1d054a: legend 7000 usd per month, active", + "offer 29e35444-2f85-43fb-8933-16875e6d3776: 3 month(s), {\"type\":\"freeMonths\",\"freeMonths\":1}, total 1400, active", + "offer 71bd8ad1-15c4-4735-b3d4-b12a670dfb7e: 12 month(s), {\"type\":\"freeMonths\",\"freeMonths\":6}, total 4200, active", + "offer 88885a0a-c407-4aaa-bf53-90f9de7bdfc0: 3 month(s), {\"type\":\"freeMonths\",\"freeMonths\":1}, total 14000, active", + "offer 35ca9daa-4dca-4cc1-af74-631674906cc9: 12 month(s), {\"type\":\"freeMonths\",\"freeMonths\":6}, total 42000, active" + ] + reportsNoBadgeEvent alice + noClientBadgeRows "after the catalog" alice + +-- The worker (C3) against the live service --------------------------------------- + +-- | A month on, @\/_badge state@ signals the worker and ONE pass issues the second period against +-- the live service: a second issuance, one more @debit(badge)@ in the ledger, and a +-- 'CEvtBadgeChanged' reporting the new state. No test waits on 'badgePassInterval' -- the shared +-- clock is moved and the command is the trigger. +-- +-- It also pins the master key across the two credentials. A pass that regenerated it would be +-- answered with a credential bound to the OLD key on the service's cached-issuance path, which is +-- unusable and raises no error anywhere ('badgeIssueRequest', plan §9); both credentials verify and +-- both carry the key @badge_purchases.master_key@ holds. +testC5WorkerIssuesSecondPeriod :: HasCallStack => TestParams -> IO () +testC5WorkerIssuesSecondPeriod ps = do + clock <- newTestClock testClockStart + codeRef <- newIORef "" + withBadgeClient ps clock (seedOneSupporterCode ps >>= writeIORef codeRef) $ \alice -> do + code <- readIORef codeRef + alice ##> purchaseCodeCmd code + expectBadgeState alice threeMonthBadgeState + -- both clocks move together: the month the first period covered has ended + advanceTestClockMonths clock 1 + alice ##> "/_badge state 1" + -- the state as it is BEFORE the pass the same command signalled + expectBadgeState alice threeMonthBadgeState + -- the pass, issuing [2026-04-10, 2026-05-10): one month spent, still paid through 2026-06-10 + alice <## "supporter badge 1 (shown): issued, 1 month(s) left, paid through 2026-06-10" + reportsNoBadgeEvent alice + -- one more issuance and one more ledger entry, and nothing else + clientBadgeRowCounts alice `shouldReturn` (1, 1, 3, 2, 1) + withClientStore alice $ \db -> do + entryTypes <- DB.query_ db "SELECT entry_type, entry_credit_type, entry_debit_type FROM badge_ledger ORDER BY entry_id" + ("ledger" :: String, entryTypes :: [(Text, Maybe Text, Maybe Text)]) + `shouldBe` ( "ledger", + [ ("credit", Just "payment", Nothing), + ("debit", Nothing, Just "badge"), + ("debit", Nothing, Just "badge") + ] + ) + periods <- DB.query_ db "SELECT period_start, period_end FROM badge_issuances ORDER BY period_start" + case periods :: [(UTCTime, UTCTime)] of + [(firstStart, firstEnd), (secondStart, secondEnd)] -> do + firstStart `shouldBeStoredAt` testClockStart + firstEnd `shouldBeStoredAt` firstPeriodEnd + secondStart `shouldBeStoredAt` firstPeriodEnd + secondEnd `shouldBeStoredAt` UTCTime (fromGregorian 2026 5 10) noonUTC + other -> expectationFailure $ "expected two issuances, got: " <> show other + -- the master key is the purchase's on both credentials, and both verify + issuerPub <- readTestIssuerPublicKey (tmpPath ps) + purchaseMasterKey <- clientPurchaseMasterKey alice + creds <- clientIssuedCredentials alice + ("issued credentials" :: String, length creds) `shouldBe` ("issued credentials", 2) + forM_ (zip [1 :: Int ..] creds) $ \(n, cred) -> do + verifyCredential issuerPub cred `shouldReturn` True + ("credential " <> show n <> " master key", credentialMasterKey cred) + `shouldBe` ("credential " <> show n <> " master key", purchaseMasterKey) + -- and the second credential is not the first one served again + case creds of + [firstCred, secondCred] -> + ("second period credential" :: String, secondCred == firstCred) `shouldBe` ("second period credential", False) + _ -> pure () + +-- The active profile -------------------------------------------------------------- + +-- | A redemption that FINISHES after the active profile has been switched must not point the app +-- back at the profile it was redeemed for. +-- +-- 'withUserId' checks activeness at ENTRY and the round trip that follows is seconds long, so the +-- guard in 'redeemBadgeCode' is load-bearing and needs the racing case, not the static one. The +-- client's 'badgeCurrentTime' is read after the request has been answered and before the first row +-- is written, which is exactly the window that guard covers, so gating that clock (C3's +-- 'BadgeGate') parks the redemption there while the profile is switched. +-- +-- The redemption runs off the terminal's input loop, which is single-threaded: a @\/create user@ +-- typed at it would queue BEHIND the parked redemption and could never race it. +testC5RedeemAfterProfileSwitchKeepsActiveUser :: HasCallStack => TestParams -> IO () +testC5RedeemAfterProfileSwitchKeepsActiveUser ps = do + clock <- newTestClock testClockStart + gate <- newBadgeGate + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + cfg (sLink, _fullLink) pk = (badgeClientCfg sLink pk) {badgeCurrentTime = gatedClockAt testClockStart gate} + withBadgeClientCfg ps (readIORef clock) seedCode cfg $ \alice _links -> do + -- the chat-start pass reads the gated clock first; let it through so it cannot take the permit + -- the redemption needs. It finds no purchase and writes nothing. + allowPass gate + waitPasses gate 1 + User {userId = aliceUserId} <- clientUser alice + code <- readIORef codeRef + redeeming <- + async $ runReaderT (execChatCommand' (APIPurchaseBadge aliceUserId (BPPCode code)) 0) (chatController alice) + -- the request has been sent and answered, and the redemption is parked on its clock read + waitPasses gate 2 + alice ##> "/create user secret" + alice <## "user profile: secret" + alice <## "use /p [] to change it" + User {userId = secretUserId} <- clientUser alice + ("switched profile" :: String, secretUserId == aliceUserId) `shouldBe` ("switched profile", False) + -- released, the redemption writes its rows and answers + allowPass gate + wait redeeming >>= \case + Right _ -> pure () + Left e -> expectationFailure $ "the redemption failed: " <> show e + -- the badge landed on the redeeming profile ... + withClientStore alice $ \db -> do + [Only purchaseOwner] <- DB.query_ db "SELECT user_id FROM badge_purchases" + ("purchase owner" :: String, purchaseOwner :: Int64) `shouldBe` ("purchase owner", aliceUserId) + [Only shownBadgeId] <- DB.query db "SELECT shown_badge_id FROM users WHERE user_id = ?" (Only aliceUserId) + ("redeeming profile shown badge" :: String, shownBadgeId :: Maybe Int64) + `shouldBe` ("redeeming profile shown badge", Just 1) + -- ... and the active profile did not move back to it + User {userId = activeAfter} <- clientUser alice + ("active profile" :: String, activeAfter) `shouldBe` ("active profile", secretUserId) + +-- Idempotency and recovery --------------------------------------------------------- + +-- | The same code presented again from the same profile mints a FRESH purchase key, so the RPC's +-- "repeat the identical request" idempotency is unreachable from the client by design: the service +-- sees a second key and answers @code_used@. The client writes nothing and the first badge stays +-- shown. +-- +-- After the operator clears the redemption, the same code redeems again into a NEW purchase and +-- supersedes the old one -- the recovery path C4's "a response lost in flight consumes the code" +-- depends on. H2's @codes unredeem@ CLI does not exist yet (@BadgeService.Admin@ has issue, revoke +-- and status only), so this drives B1's 'unredeemCode' directly, which is the function that CLI +-- will call. +testC5SameCodeAgainThenUnredeemed :: HasCallStack => TestParams -> IO () +testC5SameCodeAgainThenUnredeemed ps = do + clock <- newTestClock testClockStart + codeRef <- newIORef "" + withBadgeServiceAddress ps (readIORef clock) (writeTestBadgeServiceConfig ps) (seedOneSupporterCode ps >>= writeIORef codeRef) $ + \links withService -> do + pk <- readTestIssuerPublicKey (tmpPath ps) + -- the client is started OUTSIDE the service phases, so it outlives the restart the unredeem + -- needs: the service's database cannot be opened while the service holds it + withNewTestChatCfg ps (sharedClockCfg clock links pk) badgeClientDbPrefix aliceProfile $ \alice -> do + code <- readIORef codeRef + withService $ do + alice ##> purchaseCodeCmd code + expectBadgeState alice threeMonthBadgeState + -- the same code, the same profile, a new key + alice ##> purchaseCodeCmd code + alice <## "badge service error: code_used" + clientBadgeRowCounts alice `shouldReturn` (1, 1, 2, 1, 1) + alice ##> "/_badge state 1" + expectBadgeState alice threeMonthBadgeState + -- the operator clears the redemption while the service is stopped + withServiceStore ps $ \db -> unredeemCode db (Codes.codeHash (Codes.normalizeCode code)) testClockStart + withService $ do + alice ##> purchaseCodeCmd code + expectBadgeState alice "supporter badge 2 (shown): issued, 2 month(s) left, paid through 2026-06-10" + clientBadgeRowCounts alice `shouldReturn` (2, 2, 4, 2, 1) + withClientStore alice $ \db -> do + statuses <- DB.query_ db "SELECT badge_purchase_id, status FROM badge_purchases ORDER BY badge_purchase_id" + ("purchase statuses" :: String, statuses :: [(Int64, Text)]) + `shouldBe` ("purchase statuses", [(1, "superseded"), (2, "issued")]) + +-- Address resolution ----------------------------------------------------------------- + +-- | Whether a parsed badge service address is the FULL contact request URI form rather than the +-- short link every other example configures. Top level, and not a @case@ in the example itself, +-- because 'ConnectTarget' is a GADT and matching one in a local binding is what +-- @-Wgadt-mono-local-binds@ warns about. +isFullContactTarget :: ConnectTarget 'CMContact -> Bool +isFullContactTarget target = case target of + CTFullContact _ -> True + _ -> False + +-- | The service's address given as a full contact request URI redeems exactly as the short link +-- does. 'resolveServiceTarget' accepts four target forms and, without this, only the short link +-- would ever be exercised. The 'CTName' and 'CTDomain' forms need a resolvable SimpleX name, which +-- this harness cannot publish; they are recorded as untested in the plan's §9. +testC5FullContactUriRedeems :: HasCallStack => TestParams -> IO () +testC5FullContactUriRedeems ps = do + clock <- newTestClock testClockStart + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + cfg (_sLink, fullLink) pk = (badgeClientCfg fullLink pk) {badgeCurrentTime = readIORef clock} + withBadgeClientCfg ps (readIORef clock) seedCode cfg $ \alice (_sLink, fullLink) -> do + -- the configured target really is the FULL form: a full URI that had silently decoded as a + -- short link would make this the short-link example over again + ("full contact URI target" :: String, isFullContactTarget (badgeServiceTarget fullLink)) + `shouldBe` ("full contact URI target", True) + code <- readIORef codeRef + alice ##> purchaseCodeCmd code + expectBadgeState alice threeMonthBadgeState + clientBadgeRowCounts alice `shouldReturn` (1, 1, 2, 1, 1) + +-- The stub responder -------------------------------------------------------------------- + +-- | A stub badge service: a chat client accepting service requests on a contact address of its +-- own, which the test answers with a canned body. +-- +-- Six of C5's cases need a response the real service cannot produce -- an absent credential, a +-- statement carrying no issued period, a credential with no expiry, a statement carrying an entry +-- type this build cannot store, a response of the wrong shape for the command, and a body that is +-- not a 'BadgeServiceResponse' at all. Each is a branch of C4's 'redeemBadgeCode' whose whole +-- purpose is to write nothing, and without a responder that can be made to lie all six would be +-- untested. +-- +-- The credential the stub signs is real -- 'bbsKeyGen' here and the public half in the client's +-- 'badgePublicKeys' -- so 'verifyUserBadge' passes and the branch under test is the one that +-- fails. +withBadgeStub :: HasCallStack => TestParams -> (TestCC -> TestCC -> BBSSecretKey -> IO ()) -> IO () +withBadgeStub ps test = do + Right (pk, sk) <- bbsKeyGen + withNewTestChatCfgOpts_ ps testCfg testOpts badgeStubDbPrefix True badgeStubProfile $ \stub -> do + -- SREQ delivery gates on this flag, exactly as 'badgePostStartHook' sets it + atomically $ writeTVar (processServiceRequests (chatController stub)) True + -- a DR address: service RPC requires one, which is why the real service creates it with + -- pqRatchet 'Just True' + stub ##> "/ad pq_ratchet=on" + (sLink, _fullLink) <- getContactLinks stub True + withNewTestChatCfg ps (badgeClientCfg sLink pk) badgeClientDbPrefix aliceProfile $ \alice -> + test alice stub sk + +badgeStubProfile :: Profile +badgeStubProfile = badgeProfile {displayName = "SimpleX Badge Stub"} + +-- | Answers the one service request the stub is holding with 'body'. What the request carried is +-- B5's business, not C5's, so it is read and dropped. +answerStubRequest :: HasCallStack => TestCC -> J.Value -> IO () +answerStubRequest stub body = do + reqLine <- getTermLine' (Just "service request") stub + reqId <- case stripPrefix "service request " reqLine of + Just i -> pure i + Nothing -> expectationFailure ("expected a service request line, got: " <> reqLine) >> error "unreachable" + -- 'signed by' precedes the request for a signed purchaseBadge and is absent for the unsigned + -- getBadgeCatalog + next <- getTermLine' (Just "signed by, or the request") stub + unless ("request: " `isPrefixOf` next) $ stub <##. "request: " + stub ##> ("/_service_response 1 " <> reqId <> " " <> LBC.unpack (J.encode body)) + -- the command's own answer and the agent's SSENT event for the reply, in either order + forM_ [1 :: Int, 2] $ \_ -> do + l <- getTermLine' (Just "service reply") stub + unless ("service reply " `isPrefixOf` l) $ + expectationFailure ("expected a service reply line, got: " <> l) + +-- 'StatementEntry' is constructed positionally, as everywhere else in this module (see the import +-- list's Haddock): entryId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, +-- wasPausedSince, createdAt, entryType. +stubEntry :: Text -> Int -> Int -> UTCTime -> StatementEntryType -> StatementEntry +stubEntry entryId changeMonths balanceMonths balanceStartTs = + StatementEntry entryId changeMonths balanceMonths balanceStartTs BTSupporter Nothing testClockStart + +-- | The statement a three-month code redemption produces: the credit, then the @debit(badge)@ that +-- carries the issued period. +stubRedeemStatement :: BadgeStatement +stubRedeemStatement = + BadgeStatement + { entries = + [ stubEntry "c5-stub-credit" 3 3 testClockStart (SECredit (SCPayment Nothing)), + stubEntry "c5-stub-debit" (-1) 2 firstPeriodEnd (SEDebit SDBadge) + ], + previousEntryId = Nothing + } + +stubCredential :: HasCallStack => BBSSecretKey -> Maybe UTCTime -> IO BadgeCredential +stubCredential sk badgeExpiry = do + drg <- C.newRandom + mk <- generateMasterKey drg + let req = BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry, badgeExtra = ""}} + issueBadge 1 sk (VerifiedBadgeRequest req) + >>= either (\e -> expectationFailure ("the stub could not sign a credential: " <> e) >> error "unreachable") pure + +stubCredentialResponse :: Maybe BadgeCredential -> BadgeStatement -> J.Value +stubCredentialResponse credential statement = + J.toJSON BSPBadgeCredential {credential, receipt = Nothing, statement} + +-- | Every response a redemption can be refused for once it has arrived, each answered with the +-- message C4 raises and each leaving the client with no row of any kind. +-- +-- The order is the order 'redeemBadgeCode' checks them in, and the last is the reason +-- 'checkStatementEntries' exists at all: an unstorable entry type reaching 'insertLedgerEntries' +-- would COMMIT the payment and purchase rows written above it, because a 'Left' inside @withStore@ +-- does not roll the transaction back. +testC5UnrecordableResponsesWriteNothing :: HasCallStack => TestParams -> IO () +testC5UnrecordableResponsesWriteNothing ps = + withBadgeStub ps $ \alice stub sk -> do + let redeemAnsweredWith label body message = do + alice ##> purchaseCodeCmd "C5-STUB-CODE" + answerStubRequest stub body + alice <##. message + noClientBadgeRows label alice + -- no credential at all: the exhausted balance of an issueBadge, which a redemption cannot be + redeemAnsweredWith + "after a redemption with no credential" + (stubCredentialResponse Nothing stubRedeemStatement) + "badge service error: internal, badge service redeemed the code without issuing a credential" + -- a statement that issued no period, so nothing says which month was bought + cred <- stubCredential sk (Just firstCredentialExpiry) + let creditOnly = + BadgeStatement + { entries = [stubEntry "c5-stub-credit-only" 3 3 testClockStart (SECredit (SCPayment Nothing))], + previousEntryId = Nothing + } + redeemAnsweredWith + "after a statement with no issued period" + (stubCredentialResponse (Just cred) creditOnly) + "badge service error: internal, badge service issued no period for the redeemed code" + -- a credential with no expiry, which 'issueSignedBadge' never signs + noExpiryCred <- stubCredential sk Nothing + redeemAnsweredWith + "after a credential with no expiry" + (stubCredentialResponse (Just noExpiryCred) stubRedeemStatement) + "badge service error: internal, issued badge credential carries no expiry" + -- an entry type this build cannot store, refused BEFORE the transaction opens + let unstorable = + BadgeStatement + { entries = + [ stubEntry "c5-stub-charge" 3 3 testClockStart (SECredit (SCCharge "c5-charge")), + stubEntry "c5-stub-debit" (-1) 2 firstPeriodEnd (SEDebit SDBadge) + ], + previousEntryId = Nothing + } + redeemAnsweredWith + "after an unstorable statement" + (stubCredentialResponse (Just cred) unstorable) + "badge service error: internal, badge service statement cannot be stored: " + +-- | A response of the wrong shape for the command it answers, and one that is not a +-- 'BadgeServiceResponse' at all, on both commands that send one. +-- +-- Neither is a silent no-op: a service speaking a protocol this build does not know is reported, +-- with the response in the message for the first and the app-version sentence for the second. +testC5UnreadableResponsesAreReported :: HasCallStack => TestParams -> IO () +testC5UnreadableResponsesAreReported ps = + withBadgeStub ps $ \alice stub sk -> do + cred <- stubCredential sk (Just firstCredentialExpiry) + let emptyCatalog = J.toJSON BSPBadgeCatalog {catalog = BadgeCatalog {prices = [], offers = []}, badgeStatement = Nothing} + credentialBody = stubCredentialResponse (Just cred) stubRedeemStatement + undecodable = J.object ["type" J..= ("badgeSomethingElse" :: Text)] + -- a catalog answering a purchase + alice ##> purchaseCodeCmd "C5-STUB-CODE" + answerStubRequest stub emptyCatalog + alice <##. "badge service error: internal, unexpected badge service response to purchaseBadge: " + noClientBadgeRows "after a catalog answering a purchase" alice + -- a credential answering a catalog + alice ##> "/_badge catalog 1" + answerStubRequest stub credentialBody + alice <##. "badge service error: internal, unexpected badge service response to getBadgeCatalog: " + -- a body that does not decode as a response at all, on both commands + alice ##> purchaseCodeCmd "C5-STUB-CODE" + answerStubRequest stub undecodable + alice <##. "badge service error: internal, The badge service answered with something this app version cannot read." + alice ##> "/_badge catalog 1" + answerStubRequest stub undecodable + alice <##. "badge service error: internal, The badge service answered with something this app version cannot read." + noClientBadgeRows "after unreadable responses" alice diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index f16b3ac090..82e446e7a3 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -19,7 +19,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B import Data.Char (isDigit) -import Data.List (isPrefixOf, isSuffixOf) +import Data.List (isPrefixOf, isSuffixOf, stripPrefix) import Data.Maybe (fromMaybe) import Data.String import qualified Data.Text as T @@ -169,7 +169,41 @@ cc1 <##> cc2 = do (##>) :: HasCallStack => TestCC -> String -> IO () cc ##> cmd = do cc `send` cmd - cc <## cmd + drainEcho cc cmd + +-- | Consumes the echo of a typed command, tolerating how the virtual terminal delivers it. +-- +-- 'Simplex.Chat.Terminal.Input.runInputLoop' echoes the command with @printToTerminal@ before it +-- runs, so what has to be consumed here is exactly the string the test sent — it carries no +-- information the test did not itself write, which is why this DRAINS the echo instead of +-- asserting on it. 'readTerminalOutput' samples a 24-row window from another thread and reports +-- the rows that scrolled off it, so under load one echoed line can reach the queue as several +-- fragments, or behind the input prompt row (@\"> \"@) that the same render overwrites. Comparing +-- the first queued line against the command therefore failed about one run in three of the badge +-- service suite, whose commands are the longest in the test tree, in examples that had nothing to +-- do with the failure (C5). +-- +-- What is tolerated is narrow: a leading @\"> \"@ prompt prefix, and fragments that spell the +-- command out in order. Anything else — an event line, a response line, an unrelated command's +-- echo — is not a prefix of what was sent and is reported as the same mismatch as before. +drainEcho :: HasCallStack => TestCC -> String -> Expectation +drainEcho cc cmd = drain (0 :: Int) "" + where + drain n acc + | acc == cmd = pure () + | otherwise = do + l <- getTermLine' (Just $ "echo of: " <> cmd) cc + let acc' = acc <> dropPromptPrefix l + -- 8 fragments is far more than the terminal has ever produced for one line, and stops + -- a genuinely lost echo from consuming the rest of the example's output + if acc' `isPrefixOf` cmd && n < 8 + then drain (n + 1) acc' + else acc' `shouldBe` cmd + -- only when the command itself cannot start that way, so a command that does is compared + -- exactly as before + dropPromptPrefix l + | "> " `isPrefixOf` cmd = l + | otherwise = fromMaybe l (stripPrefix "> " l) (#>) :: HasCallStack => TestCC -> String -> IO () cc #> cmd = do