From 42a16c4e44588a9fd713851c74ab0440ec94e9a9 Mon Sep 17 00:00:00 2001 From: shum Date: Tue, 25 Aug 2026 16:03:43 +0000 Subject: [PATCH] core: badge service integration tests --- .../src/BadgeService/Config.hs | 15 +- .../src/BadgeService/Options.hs | 13 +- .../src/BadgeService/Service.hs | 4 +- .../2026-08-21-badges-web-checkout.md | 10 +- tests/Bots/BadgeServiceTests.hs | 907 +++++++++++++++++- 5 files changed, 923 insertions(+), 26 deletions(-) diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index 309648b3e5..2dda66c797 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -39,7 +39,7 @@ import Data.Maybe (isJust) import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, diffUTCTime) import Data.Word (Word32) import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Crypto as C @@ -573,15 +573,20 @@ data BadgeServiceEnv = BadgeServiceEnv catalogBucket :: TVar TokenBucket } -newBadgeServiceEnv :: BadgeServiceConfig -> DBStore -> IO BadgeServiceEnv -newBadgeServiceEnv cfg st = do +-- | @clock@ becomes the env's 'now' and is also what the two service-wide buckets are +-- initialised against, so every instant the service reads -- a handler's, a bucket's refill +-- origin -- comes from one source. Production passes 'getCurrentTime' +-- ('BadgeService.Options.serviceClock'); a test passes a settable clock so it can advance +-- service time (a bucket's refill window, a month boundary) without sleeping. +newBadgeServiceEnv :: BadgeServiceConfig -> DBStore -> IO UTCTime -> IO BadgeServiceEnv +newBadgeServiceEnv cfg st clock = do codeSecret <- loadCodeSecret (codesSecretFile (codes cfg)) issuerKey <- loadIssuerKey (issuerKeyFile (issuer cfg)) (issuerKeyIdx (issuer cfg)) - now0 <- getCurrentTime + now0 <- clock signerFailureBucket <- newSignerBucketFamily (signerFailure (throttle cfg)) globalFailureBucket <- newTVarIO (newTokenBucket (globalFailure (throttle cfg)) now0) catalogBucket <- newTVarIO (newTokenBucket (catalog (throttle cfg)) now0) - pure BadgeServiceEnv {config = cfg, store = st, now = getCurrentTime, codeSecret, issuerKey, signerFailureBucket, globalFailureBucket, catalogBucket} + pure BadgeServiceEnv {config = cfg, store = st, now = clock, codeSecret, issuerKey, signerFailureBucket, globalFailureBucket, catalogBucket} -- | The pre-processing gate for a signed 'purchaseBadge{code}' (B5 decision 5): peeks both -- the caller's per-signer bucket and the service-wide failure budget, WITHOUT debiting either diff --git a/apps/simplex-badge-service/src/BadgeService/Options.hs b/apps/simplex-badge-service/src/BadgeService/Options.hs index eb87f7eac7..38b352dded 100644 --- a/apps/simplex-badge-service/src/BadgeService/Options.hs +++ b/apps/simplex-badge-service/src/BadgeService/Options.hs @@ -16,6 +16,7 @@ where import BadgeService.Admin (AdminOpts (..), adminCommandParser) import qualified Data.Text as T +import Data.Time.Clock (UTCTime, getCurrentTime) import Options.Applicative import Simplex.Chat.Controller (updateStr, versionNumber, versionString) import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, CreateBotOpts (..), coreChatOptsP) @@ -28,7 +29,14 @@ data BadgeServiceOpts = BadgeServiceOpts noAddress :: Bool, runCLI :: Bool, testing :: Bool, - configFile :: FilePath + configFile :: FilePath, + -- | The clock 'BadgeService.Config.newBadgeServiceEnv' installs as + -- 'BadgeService.Config.BadgeServiceEnv.now', which is the only clock any service component + -- reads. Always 'getCurrentTime' in production -- the CLI parser below has no option for + -- it. The test harness, which builds this record directly rather than parsing it, passes a + -- settable clock so a test can advance service time (a throttle bucket's refill window, a + -- month boundary) without sleeping. + serviceClock :: IO UTCTime } -- | Either the plain service run -- the DEFAULT when no subcommand is given -- or the @@ -85,7 +93,8 @@ badgeServiceOpts appDir defaultDbName = do noAddress, runCLI, testing = False, - configFile + configFile, + serviceClock = getCurrentTime } getBadgeServiceOpts :: FilePath -> FilePath -> IO BadgeServiceOpts diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index b3f62c9db6..12db345b4d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -242,13 +242,13 @@ logSweepFailure e = case fromException e of -- and validates badge_service.ini, exits on a bad config (naming the file and the offending -- key), and stores the built env for badgePostStartHook and the request handlers to reach. badgePreStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () -badgePreStartHook opts@BadgeServiceOpts {configFile} ServiceState {serviceEnv} ChatController {config, chatStore} = do +badgePreStartHook opts@BadgeServiceOpts {configFile, serviceClock} ServiceState {serviceEnv} ChatController {config, chatStore} = do runBadgeServiceMigrations opts config chatStore seedCatalog chatStore readBadgeServiceConfig configFile >>= \case Left e -> putStrLn e >> exitFailure Right bsConfig -> do - bsEnv <- newBadgeServiceEnv bsConfig chatStore + bsEnv <- newBadgeServiceEnv bsConfig chatStore serviceClock atomically $ putTMVar serviceEnv bsEnv badgePostStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () 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 7652307b2b..f24ea99523 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -143,7 +143,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | B7 | `purchaseBadge{code}` and `issueBadge` | B1, B2, B3, B4, B5 | ☑ | | B8 | `codes` operator subcommand | A4, B1, B3 | ☑ | | B9 | Service address publication | A6, B5 | ☑ | -| B10 | Service integration tests | B7, B8 | ☐ | +| B10 | Service integration tests | B7, B8 | ☑ | | C1 | `Store/Badges.hs`: client badge store | A1, A2 | ☐ | | C2 | Commands, responses, events, parsers, View | A2, B2, C1 | ☐ | | C3 | `BadgeManager` worker | C1, C2 | ☐ | @@ -1370,6 +1370,14 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **B9 — the address is re-read via a second `ShowMyAddress`, not threaded from `initializeBotAddress'`'s own result.** `initializeBotAddress'` (`src/Simplex/Chat/Bot.hs`) is shared by four callers (this service, the directory service, the broadcast bot, `bot-advanced`) and returns nothing; changing its signature to hand back the resolved link would touch all four for a need only this step has. `badgePostStartHook` instead calls `sendChatCmd cc ShowMyAddress` again immediately after, which is cheap (a local store read, no network) and already proven safe by the existing two-phase test harness relying on the same command. - **B9 — `writeAddressFile`'s three deliberate failure modes.** No address-file pattern existed anywhere in the repo to copy (the step's own **Do** section says so), so these were decided here, not inherited: (1) an unwritable path (including a parent directory that does not exist — nothing here creates one) is logged as an error and does **not** stop the service, since `initializeBotAddress'` already put the same address on stdout and nothing about serving RPC requests depends on this file; (2) same as (1) — a missing parent directory is treated as any other write failure, not auto-created, since silently creating directories from an operator-supplied config path is more surprising than helpful for a deployment file; (3) a file that already holds a *different* address is always overwritten (logging a warning first) rather than left alone, so an operator who restarts the service can never be looking at a stale address — the file is unconditionally rewritten with whatever `ShowMyAddress` reports on every start where `address_file` is configured. +- **B10 — the harness's `now` override did not exist, and B10 built it.** A6's step says `withBadgeService` "also accepts a `now` override, used by B10 and C5", but A6 shipped `newBadgeServiceEnv` with `now = getCurrentTime` hardcoded and no way to reach it from a test — the live service builds its own env in `badgePreStartHook`. B10 adds `BadgeServiceOpts.serviceClock :: IO UTCTime` (the CLI parser has no option for it and always sets `getCurrentTime`, so production is unchanged) and makes `newBadgeServiceEnv` take the clock as a parameter, which also fixes a smaller inconsistency: the two service-wide token buckets were initialised from `getCurrentTime` while every handler read `BadgeServiceEnv.now`, so under an overridden clock their refill origin would have come from a different timeline. The test harness gains `withBadgeServiceClock`, of which the existing `withBadgeServiceConfig` is now the real-clock case. **C5 needs the client-side twin (`badgeCurrentTime`) and should not assume it exists either.** +- **B10 — the single `unsupported_version` test was NOT replaced, only added to.** The step's "Replace the single `unsupported_version` test with …" was written when that was the file's only test; B5, B6, B7 and B9 have since put 46 more examples in it, and B7's own note above says "B10 replaces the surrounding suite". Nothing was removed or weakened: the 18 new examples were added alongside, and `testBadgeServiceUnsupportedVersion` still asserts the version gate. +- **B10 — `balance_start_ts` is backdated by moving the injected clock, not by seeding a row through B1.** The step says "with the purchase's `balance_start_ts` backdated one month through B1". A hand-seeded backdated ledger row has no matching `badge_issuances` row, so the second half of the same bullet — "a third call inside the same month returns the cached credential" — would reach `IssueCached` with nothing to fetch and answer `internal`. Advancing `BadgeServiceEnv.now` past a real redemption exercises the same boundary against a self-consistent database, and is what the "No test sleeps" rule points at anyway. +- **B10 — DEFECT FOUND, NOT FIXED: a zero balance hides an already-issued month.** `planLedger` tells `IssueCached` from `IssueExhausted` by the balance alone (`Service.hs`), but `issue` returns `Nothing` for two different reasons — an exhausted balance, and a month that is already issued. Once the LAST funded month has been issued, both hold, and a repeat `issueBadge` inside that same month answers `credential = Nothing` instead of the credential the service already signed and stored for it. RPC §Idempotency requires the cached credential; C3's worker retrying after a timeout in the final funded month is the reachable case. The fix is to classify by `balanceStartTs > now'` (which is what `issue`'s own guard tests) rather than by `balanceMonths == 0`. B10 is a test step and does not change B7's handler; `testBadgeServiceIssueBadgeSecondPeriod` funds four months so it keeps the *specified* behaviour under test instead of pinning the wrong one. **Whoever owns C3 or the next service step must settle this.** +- **B10 — `SECodeConflict`'s retry path is left untested, deliberately.** B7's own concern: driving it needs two redemptions of one code interleaved between classification and write, and the request loop handles one request at a time. Nothing in B10 pretends to cover it; the one mutation that reached it (a same-key replay reclassified as `RedeemOk`) proved only that the code-row guard fires, not that the retry resolves correctly. +- **B10 — the Postgres cross-check deferred since A3 was run, and passes.** `--flags=client_postgres` with `-m "Badge service"`: 64 examples, 0 failures (65 minus the one `#if !defined(dbPostgres)` example). Four environment obstacles, none of them code: the flag build reuses `dist-newstyle` and so invalidates the SQLite build in both directions; the socket directory must be short (`/tmp/pgs`, not a long scratchpad path — `sun_path` is 107 bytes); the suite needs **two** roles, `test_chat_user` (owner of `test_chat_db`) and a superuser **`postgres`**, which `Test.hs`'s `createdDropDb` bracket connects as; and `max_connections` must be raised well above the default 100 (30 of 64 examples failed on connection slots until it was 500). The two file-reading assertions are guarded, so the §3 Linkage privacy guard and the no-plaintext-at-rest check run on SQLite only — a Postgres twin over `information_schema` is a worthwhile follow-up. +- **B10 — B8's `codes` assertions run through `runAdminCmd` with stdout captured, and inspect the database only through `codes status`.** `runAdminCmd` opens its own store and creates a chat database with no user profile, which the test harness's `withTestChat` reopen cannot read (it requires an active user) — so the row-level checks are made by asking the tool itself: each of the ten printed codes resolves to an unredeemed row, and `codes revoke` reports exactly ten in the batch. The plaintext-at-rest check reads the SQLite file directly and is `#if !defined(dbPostgres)`-guarded, as is the §3 Linkage schema assertion. + ## 10. End-to-end verification After F5: diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index a1028503b7..933352e084 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -8,7 +8,12 @@ module Bots.BadgeServiceTests where +import BadgeService.Admin (AdminCmd (..), AdminOpts (..), IssueOpts (..), adminCommandParser, runAdminCmd) import BadgeService.Catalog (catalogTotals, defaultCatalog, offerTotal, seedCatalog) +-- imported qualified: 'codeHash' and 'normalizeCode' would otherwise be ambiguous against +-- 'BadgeService.Store.BadgeCode''s 'codeHash' field, which this module already uses as a record +-- field (the same reason 'BadgeService.Admin' imports this module qualified). +import qualified BadgeService.Codes as Codes import BadgeService.Config ( BadgeServiceConfig (..), BadgeServiceEnv (..), @@ -36,26 +41,33 @@ import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.STM (atomically, readTVarIO) import Control.Exception (SomeException, finally, try) -import Control.Monad (replicateM, void) +import Control.Monad (forM, forM_, replicateM, void) +import Control.Monad.Except (ExceptT) +import Control.Monad.IO.Class (liftIO) import Crypto.Random (getRandomBytes) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.Types as JT +import qualified Data.ByteString as BS 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 (newIORef, readIORef, writeIORef) -import Data.List (find, isInfixOf) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import Data.List (find, isInfixOf, nub) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, isJust, mapMaybe) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO import Data.Time.Calendar (fromGregorian) import Data.Time.Calendar.WeekDate (toWeekDate) -import Data.Time.Clock (DiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay, secondsToDiffTime) -import Data.Word (Word32) +import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay, secondsToDiffTime) +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.Months (addMonths) import Simplex.Chat.Badges.Service @@ -75,8 +87,11 @@ import Simplex.Chat.Badges.Service BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), - StatementCreditType (SCOpening), - StatementDebitType (SDLapse), + -- '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), + StatementDebitType (SDBadge, SDLapse), StatementEntry (StatementEntry), StatementEntryType (SECredit, SEDebit), pattern VersionBadgeService, @@ -103,9 +118,10 @@ import Simplex.Messaging.Agent.Store.Interface (closeDBStore, createDBStore) import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (BBSPublicKey (..), BBSSecretKey (..), bbsKeyGen) -import Simplex.Messaging.Encoding.String (strEncode) +import Simplex.Messaging.Encoding.String (strDecode, strEncode) import System.Exit (ExitCode (..)) import System.FilePath (()) +import System.IO (IOMode (..), hClose, hFlush, openFile, stdout) import Test.Hspec hiding (it) #if defined(dbPostgres) import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations) @@ -158,6 +174,26 @@ badgeServiceTests = do it "should disable a price out of the active catalog while both stay reachable by id" testBadgeStoreSetPriceStatusDisabled it "should return the redeeming purchase key from getCodeByHash" testBadgeStoreGetCodeByHashRedeemer it "should clear both redemption columns and set unredeemed_at" testBadgeStoreUnredeemCode + it "should redeem a valid code into a verifiable credential, with a credit(payment) then debit(badge) ledger" testBadgeServiceRedeemCodeIssuesCredential + it "should return the same credential and write no new row when the identical request is repeated" testBadgeServiceRedeemCodeIdempotent + it "should append exactly one debit(lapse) when the identical request is repeated after months lapsed" testBadgeServiceReplayAfterLapseHealsOnce + it "should respond code_used to the same code presented by a second purchase key" testBadgeServiceCodeUsedBySecondKey + it "should answer code_invalid for unknown, mistyped and revoked codes and code_expired for an expired one, consuming none" testBadgeServiceCodeFailureOutcomes + it "should debit the per-signer bucket once per failed redemption and not at all for a success, replay, badgeExtra or tier mismatch" testBadgeServiceFailureDebitsBucketOncePerFailure + it "should rate_limit a fresh signer once the global failure budget is drained, and let the same code succeed after it refills" testBadgeServiceGlobalFailureBudgetRefills + it "should issue the second period with debit(lapse) before debit(badge), then serve the cached credential" testBadgeServiceIssueBadgeSecondPeriod + it "should return no credential and a zero-balance statement when the balance is exhausted" testBadgeServiceIssueBadgeExhaustedBalance + it "should credit a second code to the existing purchase with its own payment and no second issuance" testBadgeServiceSecondCodeSamePurchaseKey + it "should respond bad_request to a badgeRequest naming a tier the funding does not cover, on every path" testBadgeServiceTierMismatchIsBadRequest + it "should respond bad_request to a purchase carrying an upgrade, leaving the code unredeemed" testBadgeServiceUpgradeIsBadRequest + it "should respond bad_request to a reserved badgeExtra, leaving the code unredeemed" testBadgeServiceBadgeExtraIsBadRequest + it "should return only the entries after an asserted cursor, and the full history for an unknown or another purchase's one" testBadgeServiceIssueBadgeCursor + it "should serve the current month's cached credential across a clamped month boundary" testBadgeServiceCachedIssuanceAtClampedMonthBoundary +#if !defined(dbPostgres) + it "should have no table referencing both web_orders and badge_purchases" testBadgeServiceNoTableLinksOrdersToPurchases +#endif + it "should issue 10 codes with distinct hashes, no plaintext at rest, and revoke and report them by batch" testBadgeServiceCodesIssueRevokeStatus + it "should reject codes issue --type investor at parse time" testBadgeServiceCodesRejectsInvestorType it "should sign a credential that verifies with the matching public key, and fail with a different one" testBadgeCredentialSignAndVerify it "should set badgeExpiry to the next Sunday at 23:59:59 UTC" testBadgeCredentialExpiryIsSundayEndOfDay it "should roll a periodEnd already on a Sunday to the following Sunday" testBadgeCredentialExpirySundayRollsToFollowingSunday @@ -191,19 +227,27 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} = noAddress = False, runCLI = False, testing = True, - configFile = badgeServiceConfigPath ps + configFile = badgeServiceConfigPath ps, + -- the real clock, as in production; 'withBadgeServiceClock' overrides this field for the + -- tests that advance service time (B10) + serviceClock = getCurrentTime } badgeServiceConfigPath :: FilePath -> FilePath badgeServiceConfigPath tmpPath = tmpPath "badge_service.ini" +-- The `badge keygen`-shaped file writeTestBadgeServiceSecrets generates the issuer key into, +-- named once so 'readTestIssuerPublicKey' reads back the very key the service loaded. +testIssuerKeyFile :: FilePath -> FilePath +testIssuerKeyFile tmpPath = tmpPath "badge-issuer.keys" + -- Generates a real issuer key file (the two-line `badge keygen` output: "secret ..\npublic -- ..") and a real 32-byte code secret (base64-encoded), at fixed names under tmpPath. A6 -- doesn't read either file's contents -- that's B3 and B4 -- but the harness must still hand -- every later step real files at real paths, per the config keys naming secrets as files. writeTestBadgeServiceSecrets :: FilePath -> IO (FilePath, FilePath) writeTestBadgeServiceSecrets tmpPath = do - let issuerKeyFile = tmpPath "badge-issuer.keys" + let issuerKeyFile = testIssuerKeyFile tmpPath codeSecretFile = tmpPath "badge-code.secret" Right (BBSPublicKey pk, BBSSecretKey sk) <- bbsKeyGen writeFile issuerKeyFile $ "secret " <> BC.unpack (strEncode sk) <> "\npublic " <> BC.unpack (strEncode pk) <> "\n" @@ -226,9 +270,15 @@ issuerCodesIniLines issuerKeyFile codeSecretFile = -- section) at the path mkBadgeServiceOpts points BadgeServiceOpts's configFile at. Provider -- sections are omitted until E2 and F1 add them. writeTestBadgeServiceConfig :: TestParams -> IO () -writeTestBadgeServiceConfig TestParams {tmpPath} = do +writeTestBadgeServiceConfig ps = writeTestBadgeServiceConfigWith ps [] + +-- The same file with extra ini lines appended -- so far only a '[throttle]' override (B5 +-- decision 5), which is how B10 drives the failure buckets to their limits in a handful of +-- requests instead of hundreds. +writeTestBadgeServiceConfigWith :: TestParams -> [String] -> IO () +writeTestBadgeServiceConfigWith TestParams {tmpPath} extraLines = do (issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets tmpPath - writeFile (badgeServiceConfigPath tmpPath) $ unlines (issuerCodesIniLines issuerKeyFile codeSecretFile) + writeFile (badgeServiceConfigPath tmpPath) $ unlines (issuerCodesIniLines issuerKeyFile codeSecretFile ++ extraLines) withBadgeService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO () withBadgeService ps = withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps) (pure ()) @@ -243,8 +293,16 @@ withBadgeService ps = withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps) -- service's own phase is running deadlocks against its writer lock (verified: reliably fails -- 'createDBStore' with a pattern-match-on-Right, i.e. sqlite busy, when tried in that window). withBadgeServiceConfig :: HasCallStack => TestParams -> IO () -> IO () -> (TestCC -> String -> IO ()) -> IO () -withBadgeServiceConfig ps writeConfig betweenPhases test = do - let opts = mkBadgeServiceOpts ps +withBadgeServiceConfig ps = withBadgeServiceClock ps getCurrentTime + +-- The same harness with the service's own clock replaced (A6: 'BadgeServiceEnv.now' is the only +-- clock any service component reads, and 'BadgeServiceOpts.serviceClock' is what +-- 'newBadgeServiceEnv' installs there). Both service starts get the same clock, so time is +-- 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 + let opts = (mkBadgeServiceOpts ps) {serviceClock = clock} writeConfig withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure () -- First start: badge service takes the CreateMyAddress branch. @@ -483,7 +541,7 @@ mkTestBadgeServiceEnv TestParams {tmpPath} st = do catalog = BucketLimits {blCapacity = 600, blStartTokens = 600} } } - newBadgeServiceEnv cfg st + newBadgeServiceEnv cfg st getCurrentTime -- Fix round 1 (unbounded per-signer map): the convincing form the review asked for. Driving -- many distinct, never-before-seen signer keys through the pre-processing throttle check @@ -1059,6 +1117,823 @@ testBadgeServiceGetCatalogBucketThrottle ps = do sendSignedServiceRequest client bsLink priv signedReq expectCatalog "signed request" client +-- B7 purchaseBadge{code} and issueBadge, B8 codes tooling (B10) --------------- +-- +-- B7's and B8's Verify lines are both "covered by B10", so everything below is the only check +-- those two steps have. Three rules shape how they assert: +-- * time is the injected clock (A6), never a sleep: 'withBadgeServiceClock' hands the service +-- an 'IORef UTCTime' the test moves forward; +-- * expected values are literal (fixed dates, fixed row shapes), never recomputed the way +-- production computes them; +-- * "wrote nothing" is a row count, never "the response looked the same". + +-- | The instant every clock-driven test starts service time at. Fixed rather than derived from +-- 'getCurrentTime' so periods and expiries below are literal dates: 2026-03-10 is a Tuesday, so +-- a first period ends Friday 2026-04-10 and its credential expires Sunday 2026-04-12 (B4). +testClockStart :: UTCTime +testClockStart = UTCTime (fromGregorian 2026 3 10) noonUTC + +noonUTC :: DiffTime +noonUTC = secondsToDiffTime (12 * 3600) + +-- The end of a period issued at 'testClockStart': one month on, no clamping involved. +firstPeriodEnd :: UTCTime +firstPeriodEnd = UTCTime (fromGregorian 2026 4 10) noonUTC + +-- And that period's credential expiry: the Sunday after 'firstPeriodEnd', spelled out rather +-- than computed with 'sundayAfter', which is the function under test. +firstCredentialExpiry :: UTCTime +firstCredentialExpiry = UTCTime (fromGregorian 2026 4 12) sundayEndOfDay + +-- Far enough ahead of 'testClockStart' that no seeded code expires during a test. +testCodeExpiry :: UTCTime +testCodeExpiry = UTCTime (fromGregorian 2027 1 1) 0 + +-- Behind 'testClockStart': the code_expired case. +expiredCodeExpiry :: UTCTime +expiredCodeExpiry = UTCTime (fromGregorian 2026 1 1) 0 + +testCodeBatch :: Text +testCodeBatch = "b10-test-batch" + +-- | The injectable service clock (A6) as a settable fixture: @readIORef@ is what +-- 'withBadgeServiceClock' installs as 'BadgeServiceEnv.now', the only clock any service +-- component reads. Moving it is how every time-dependent behaviour below is driven; no test +-- sleeps. +newTestClock :: UTCTime -> IO (IORef UTCTime) +newTestClock = newIORef + +setTestClock :: IORef UTCTime -> UTCTime -> IO () +setTestClock = writeIORef + +advanceTestClockMonths :: IORef UTCTime -> Int -> IO () +advanceTestClockMonths clock n = modifyIORef' clock (addMonths n) + +advanceTestClockSeconds :: IORef UTCTime -> NominalDiffTime -> IO () +advanceTestClockSeconds clock s = modifyIORef' clock (addUTCTime s) + +-- | One client identity: the keypair the request is signed with (which is also the purchase +-- key) and the badge master key its credential is signed over. C4 mints a fresh one per +-- redemption, so most tests below use one signer per purchase. +data TestSigner = TestSigner + { signerPub :: C.PublicKeyEd25519, + signerPriv :: C.PrivateKeyEd25519, + signerMaster :: BadgeMasterKey + } + +newTestSigner :: IO TestSigner +newTestSigner = do + (signerPub, signerPriv) <- mkTestKeyPair + signerMaster <- BadgeMasterKey <$> getRandomBytes 32 + pure TestSigner {signerPub, signerPriv, signerMaster} + +badgeRequestFor :: TestSigner -> BadgeType -> Text -> BadgeRequest +badgeRequestFor TestSigner {signerMaster} badgeType badgeExtra = + BadgeRequest {masterKey = signerMaster, badgeInfo = BadgeInfo {badgeType, badgeExpiry = Nothing, badgeExtra}} + +-- | A @purchaseBadge{code}@ request with the badgeRequest and upgrade spelled out, so the tests +-- that vary either (a tier the code does not fund, a reserved badgeExtra, an upgrade) go through +-- the same builder as a normal redemption. +purchaseRequest :: TestSigner -> BadgeRequest -> Maybe BadgeUpgrade -> Text -> BadgeServiceRequest +purchaseRequest TestSigner {signerPub} badgeRequest upgrade code = + BadgeServiceRequest + { version = VersionBadgeService 1, + purchaseKey = Just signerPub, + request = BSCPurchaseBadge {badgeRequest, payment = SPCode code, upgrade} + } + +-- The normal redemption: the tier the code funds, no reserved extra, no upgrade. +purchaseCodeRequest :: TestSigner -> BadgeType -> Text -> BadgeServiceRequest +purchaseCodeRequest signer badgeType = purchaseRequest signer (badgeRequestFor signer badgeType "") Nothing + +-- | An @issueBadge@ asserting @entryUuid@ as the last entry the client holds. Only that field of +-- the asserted entry is read by the service ('assertedEntryId'); the rest is filler, constructed +-- positionally (see the import list's Haddock). +issueRequest :: TestSigner -> BadgeType -> Text -> Text -> BadgeServiceRequest +issueRequest signer@TestSigner {signerPub} badgeType badgeExtra entryUuid = + BadgeServiceRequest + { version = VersionBadgeService 1, + purchaseKey = Just signerPub, + request = + BSCIssueBadge + { badgeRequest = badgeRequestFor signer badgeType badgeExtra, + balance = BadgeBalance (StatementEntry entryUuid 1 1 testClockStart badgeType Nothing testClockStart (SECredit SCOpening)) + } + } + +-- An entry uuid the service holds for nobody. +unknownEntryUuid :: Text +unknownEntryUuid = "b10-no-such-entry" + +sendRequest :: TestCC -> String -> TestSigner -> BadgeServiceRequest -> IO () +sendRequest client bsLink TestSigner {signerPriv} = sendSignedServiceRequest client bsLink signerPriv + +-- | Decodes one 'BSPBadgeCredential' and asserts, on every single one of them, that @receipt@ is +-- absent: nothing in this milestone issues a receipt, and B7 hardcodes 'Nothing' -- checking it +-- here is what makes that hold for every credential response in the file rather than one. +expectCredentialResponse :: HasCallStack => String -> TestCC -> IO (Maybe BadgeCredential, BadgeStatement) +expectCredentialResponse label client = + getServiceResponse client >>= \case + BSPBadgeCredential {credential, receipt, statement} -> do + (label, receipt) `shouldBe` (label, Nothing) + pure (credential, statement) + other -> expectationFailure (label <> ": expected BSPBadgeCredential, got: " <> show other) >> error "unreachable" + +expectCredential :: HasCallStack => String -> TestCC -> IO (BadgeCredential, BadgeStatement) +expectCredential label client = + expectCredentialResponse label client >>= \case + (Just cred, statement) -> pure (cred, statement) + (Nothing, _) -> expectationFailure (label <> ": expected a credential, got none") >> error "unreachable" + +expectErrorCode :: HasCallStack => String -> TestCC -> Text -> IO () +expectErrorCode label client code = do + obj <- getServiceResponseObject client + (label, KM.lookup "code" obj) `shouldBe` (label, Just (J.String code)) + +-- rate_limited always carries a retryAfter the client can act on (B5). +expectRateLimited :: HasCallStack => String -> TestCC -> IO () +expectRateLimited label client = do + obj <- getServiceResponseObject client + (label, KM.lookup "code" obj) `shouldBe` (label, Just (J.String "rate_limited")) + case KM.lookup "retryAfter" obj of + Just (J.Number n) -> (label, n > 0) `shouldBe` (label, True) + other -> expectationFailure $ label <> ": expected a positive retryAfter, got: " <> show other + +-- | The wire statement as @(changeMonths, balanceMonths, entry type)@, for comparison against a +-- literal list. 'StatementEntry' is matched positionally (see the import list's Haddock). +statementShape :: BadgeStatement -> [(Int, Int, String)] +statementShape BadgeStatement {entries} = map entryShape entries + where + entryShape (StatementEntry _ changeMonths balanceMonths _ _ _ _ entryType) = (changeMonths, balanceMonths, entryTypeLabel entryType) + +-- Spelled out rather than derived, so 'credit payment' with an invoiceId can never read the same +-- as one without: a code payment has no invoice (B7 §3), and that is what the client is told. +entryTypeLabel :: StatementEntryType -> String +entryTypeLabel = \case + SECredit (SCPayment Nothing) -> "credit payment (no invoiceId)" + SECredit (SCPayment (Just _)) -> "credit payment (with invoiceId)" + SECredit SCOpening -> "credit opening" + SECredit _ -> "credit (other)" + SEDebit SDBadge -> "debit badge" + SEDebit SDLapse -> "debit lapse" + SEDebit _ -> "debit (other)" + +statementEntryIds :: BadgeStatement -> [Text] +statementEntryIds BadgeStatement {entries} = map (\(StatementEntry entryId _ _ _ _ _ _ _) -> entryId) entries + +-- | Runs a store transaction against the service's database while the service is NOT running -- +-- the harness's between-phases window, or after its body has returned. Opening a second +-- connection during a running phase deadlocks against the service's writer lock (see +-- 'withBadgeServiceConfig'). +withServiceStore :: HasCallStack => TestParams -> (DB.Connection -> ExceptT ServiceError IO a) -> IO a +withServiceStore ps action = + withTestChat ps serviceDbPrefix $ \bs -> do + bs <## "subscribed 1 connections on server localhost" + expectRight $ withServiceTransaction (chatStore (chatController bs)) action + +withServiceDB :: HasCallStack => TestParams -> (DB.Connection -> IO a) -> IO a +withServiceDB ps action = withServiceStore ps (liftIO . action) + +serviceRowCount :: DB.Connection -> String -> IO Int +serviceRowCount db table = do + [Only n] <- DB.query_ db (fromString ("SELECT count(*) FROM sx_badge_service_" <> table)) + pure n + +-- | The five row kinds one redemption writes, counted together: purchases, payments, ledger +-- entries, issuances, redeemed codes. Every "writes nothing" assertion below pins this tuple, +-- because an unchanged response is not evidence that nothing was written. +serviceRowCounts :: DB.Connection -> IO (Int, Int, Int, Int, Int) +serviceRowCounts db = do + purchases <- serviceRowCount db "badge_purchases" + payments <- serviceRowCount db "payments" + entries <- serviceRowCount db "badge_ledger" + issuances <- serviceRowCount db "badge_issuances" + [Only redeemed] <- DB.query_ db "SELECT count(*) FROM sx_badge_service_codes WHERE redeemed_purchase_id IS NOT NULL" + pure (purchases, payments, entries, issuances, redeemed) + +-- | The ledger as the database holds it, in append order: @(changeMonths, balanceMonths, +-- entry_type, entry_credit_type, entry_debit_type, payment_id)@. Read as raw columns rather than +-- through 'getLedgerSince', so the assertion pins what was written rather than what the decoder +-- makes of it. +serviceLedgerRows :: DB.Connection -> IO [(Int, Int, Text, Maybe Text, Maybe Text, Maybe Text)] +serviceLedgerRows db = + DB.query_ + db + "SELECT change_months, balance_months, entry_type, entry_credit_type, entry_debit_type, payment_id FROM sx_badge_service_badge_ledger ORDER BY entry_id" + +-- | Stored timestamps are compared within a second: Postgres TIMESTAMPTZ truncates to +-- microseconds, so an exact 'UTCTime' round trip is not guaranteed on that backend (the same +-- reason 'testBadgeStoreUnredeemCode' gives). Every value compared this way differs from a wrong +-- one by days, never by microseconds. +shouldBeStoredAt :: HasCallStack => UTCTime -> UTCTime -> Expectation +shouldBeStoredAt stored expected + | abs (diffUTCTime stored expected) < 1 = pure () + | otherwise = expectationFailure $ "stored timestamp " <> show stored <> " should have been " <> show expected + +-- | Mints plaintext codes with B3's generator and stores only their hashes, exactly as B8's +-- @codes issue@ does. Returns the plaintexts, which from here on exist only in the test. +seedTestCodes :: HasCallStack => TestParams -> [(BadgeType, Word8, UTCTime)] -> IO [Text] +seedTestCodes ps specs = do + drg <- C.newRandom + plainCodes <- replicateM (length specs) (Codes.generateBatchCode drg) + withServiceStore ps $ \db -> insertCodes db (zipWith newCode plainCodes specs) testClockStart + pure plainCodes + where + newCode plain (badgeType, months, expiresAt) = + NewBadgeCode {codeHash = Codes.codeHash (Codes.normalizeCode plain), badgeType, months, batch = testCodeBatch, expiresAt} + +-- One supporter code funding three months, the shape almost every test below starts from. +seedOneSupporterCode :: HasCallStack => TestParams -> IO Text +seedOneSupporterCode ps = + seedTestCodes ps [(BTSupporter, 3, testCodeExpiry)] >>= \case + [code] -> pure code + other -> expectationFailure ("expected exactly one seeded code, got " <> show (length other)) >> error "unreachable" + +-- | A well-formed code (valid check character) that was never inserted: the @code_invalid@ that +-- does reach the database and finds nothing there. +mintUnknownCode :: IO Text +mintUnknownCode = C.newRandom >>= Codes.generateBatchCode + +-- | The same code with its check character replaced by a different one. B3 rejects it in +-- 'classifyRedemption' before 'getCodeByHash' is ever forced, so this is the @code_invalid@ that +-- never reaches the database at all. +corruptCheckCharacter :: Text -> Text +corruptCheckCharacter code = T.init code <> (if T.last code == '0' then "1" else "0") + +codeIsRedeemed :: HasCallStack => TestParams -> Text -> IO Bool +codeIsRedeemed ps code = + withServiceStore ps (\db -> getCodeByHash db (Codes.codeHash (Codes.normalizeCode code))) >>= \case + Just (BadgeCode {redeemedPurchaseId}, _) -> pure (isJust redeemedPurchaseId) + Nothing -> expectationFailure "expected the seeded code to exist" >> error "unreachable" + +-- | The public half of the issuer key 'writeTestBadgeServiceSecrets' generated, read back from +-- the same two-line key file the service loaded its secret from -- so 'verifyCredential' below +-- verifies against the key that actually signed, not one the test made up. +readTestIssuerPublicKey :: HasCallStack => FilePath -> IO BBSPublicKey +readTestIssuerPublicKey tmpPath = do + contents <- BC.readFile (testIssuerKeyFile tmpPath) + case mapMaybe (BC.stripPrefix "public ") (BC.lines contents) of + (b64 : _) -> either (\e -> expectationFailure ("issuer key file: " <> e) >> error "unreachable") pure (strDecode b64) + [] -> expectationFailure "issuer key file has no 'public' line" >> error "unreachable" + +-- B10 item 1 / brief 1-2: the happy path, end to end. Every assertion here is one nothing else +-- in the plan makes: the credential verifies under the issuer key the service actually loaded, +-- the ledger is exactly credit(payment) then debit(badge), the wire statement says the same, the +-- credit entry references the payments row that was written for it, and the issuance's stored +-- expiry is the credential's own (the disagreement 'credentialExpiry' refuses to allow). +testBadgeServiceRedeemCodeIssuesCredential :: HasCallStack => TestParams -> IO () +testBadgeServiceRedeemCodeIssuesCredential ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code) + (cred, statement) <- expectCredential "redeem" client + statementShape statement `shouldBe` [(3, 3, "credit payment (no invoiceId)"), (-1, 2, "debit badge")] + previousEntryId statement `shouldBe` Nothing + let BadgeCredential {masterKey = credMasterKey, badgeInfo = BadgeInfo {badgeType, badgeExpiry, badgeExtra}} = cred + badgeType `shouldBe` BTSupporter + badgeExtra `shouldBe` "" + badgeExpiry `shouldBe` Just firstCredentialExpiry + credMasterKey `shouldBe` signerMaster signer + issuerPub <- readTestIssuerPublicKey (tmpPath ps) + verifyCredential issuerPub cred `shouldReturn` True + withServiceDB ps $ \db -> do + serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + [Only paymentRowId] <- DB.query_ db "SELECT payment_id FROM sx_badge_service_payments" + [Only purchasePaymentId] <- DB.query_ db "SELECT payment_id FROM sx_badge_service_badge_purchases" + ledgerRows <- serviceLedgerRows db + ledgerRows + `shouldBe` [ (3, 3, "credit", Just "payment", Nothing, Just paymentRowId), + (-1, 2, "debit", Nothing, Just "badge", Nothing) + ] + purchasePaymentId `shouldBe` Just (paymentRowId :: Text) + [(issuanceExpiry, periodStart, periodEnd)] <- + DB.query_ db "SELECT expiry, period_start, period_end FROM sx_badge_service_badge_issuances" + issuanceExpiry `shouldBeStoredAt` firstCredentialExpiry + periodStart `shouldBeStoredAt` testClockStart + periodEnd `shouldBeStoredAt` firstPeriodEnd + -- nothing in this milestone issues a receipt, so no row records the hash of one + [Only receiptHashes] <- DB.query_ db "SELECT count(*) FROM sx_badge_service_payments WHERE receipt_hash IS NOT NULL" + (receiptHashes :: Int) `shouldBe` 0 + +-- B10 item 2 (first half) / brief 3: an identical repeat returns the SAME credential and writes +-- no row of any kind. The row counts are the assertion -- an idempotent handler and a handler +-- that redeemed the code twice can return identical-looking responses. +testBadgeServiceRedeemCodeIdempotent :: HasCallStack => TestParams -> IO () +testBadgeServiceRedeemCodeIdempotent ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + let req = purchaseCodeRequest signer BTSupporter code + sendRequest client bsLink signer req + (cred1, statement1) <- expectCredential "first redemption" client + sendRequest client bsLink signer req + (cred2, statement2) <- expectCredential "identical repeat" client + cred2 `shouldBe` cred1 + statementShape statement2 `shouldBe` statementShape statement1 + statementEntryIds statement2 `shouldBe` statementEntryIds statement1 + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + +-- B10 item 2 (second half): a repeat AFTER months have lapsed still returns the same credential, +-- and appends exactly one debit(lapse) -- no second credit, payment, debit(badge), issuance or +-- redemption. The heal is intended (the RPC has the service heal before answering any +-- statement); a future reader must not "fix" it away. +testBadgeServiceReplayAfterLapseHealsOnce :: HasCallStack => TestParams -> IO () +testBadgeServiceReplayAfterLapseHealsOnce ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + let req = purchaseCodeRequest signer BTSupporter code + sendRequest client bsLink signer req + (cred1, _) <- expectCredential "first redemption" client + -- two months on: the balance of 2 covered one of them, so exactly one month lapses + advanceTestClockMonths clock 2 + sendRequest client bsLink signer req + (cred2, statement) <- expectCredential "replay after a lapse" client + cred2 `shouldBe` cred1 + statementShape statement + `shouldBe` [(3, 3, "credit payment (no invoiceId)"), (-1, 2, "debit badge"), (-1, 1, "debit lapse")] + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 3, 1, 1) + +-- Brief 4: the same code from a second purchase key is code_used, and that second key gets no +-- purchase row out of the attempt. +testBadgeServiceCodeUsedBySecondKey :: HasCallStack => TestParams -> IO () +testBadgeServiceCodeUsedBySecondKey ps = do + clock <- newTestClock testClockStart + firstSigner <- newTestSigner + secondSigner <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + sendRequest client bsLink firstSigner (purchaseCodeRequest firstSigner BTSupporter code) + _ <- expectCredential "first key redeems" client + sendRequest client bsLink secondSigner (purchaseCodeRequest secondSigner BTSupporter code) + expectErrorCode "second key" client "code_used" + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + +-- Brief 5 / B10 item 4 (the outcomes half) and item 5: every classified failure, each answered +-- with its own code, and none of them consuming the code it was presented. A revoked code must +-- read exactly like one that never existed. +testBadgeServiceCodeFailureOutcomes :: HasCallStack => TestParams -> IO () +testBadgeServiceCodeFailureOutcomes ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codesRef <- newIORef [] + let seedCodes = + seedTestCodes ps [(BTSupporter, 3, expiredCodeExpiry), (BTSupporter, 3, testCodeExpiry)] >>= \case + codes@[_expired, revoked] -> do + withServiceStore ps $ \db -> revokeCode db (Codes.codeHash (Codes.normalizeCode revoked)) testClockStart + writeIORef codesRef codes + other -> expectationFailure $ "expected two seeded codes, got " <> show (length other) + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCodes $ \client bsLink -> do + [expiredCode, revokedCode] <- readIORef codesRef + unknownCode <- mintUnknownCode + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter unknownCode) + expectErrorCode "unknown code" client "code_invalid" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter (corruptCheckCharacter unknownCode)) + expectErrorCode "bad check character" client "code_invalid" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter revokedCode) + expectErrorCode "revoked code" client "code_invalid" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter expiredCode) + expectErrorCode "expired code" client "code_expired" + [expiredCode, revokedCode] <- readIORef codesRef + codeIsRedeemed ps expiredCode `shouldReturn` False + codeIsRedeemed ps revokedCode `shouldReturn` False + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (0, 0, 0, 0, 0) + +-- B10 item 4 (the accounting half) and the brief's per-signer throttle bullet, in one sequence +-- against a bucket of 3 tokens. A success, a same-key replay, a reserved badgeExtra and a tier +-- mismatch must debit NOTHING -- if any of them did, the third genuine failure below would come +-- back rate_limited instead of code_invalid. The fourth genuine failure must be rate_limited, +-- which pins each of the three preceding ones at exactly one token. A fresh signer is unaffected +-- by another signer's drained bucket and gets its own outcome. +testBadgeServiceFailureDebitsBucketOncePerFailure :: HasCallStack => TestParams -> IO () +testBadgeServiceFailureDebitsBucketOncePerFailure ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + otherSigner <- newTestSigner + codesRef <- newIORef [] + let writeConfig = + writeTestBadgeServiceConfigWith ps ["", "[throttle]", "signer_failure_capacity = 3", "signer_failure_start_tokens = 3"] + seedCodes = seedTestCodes ps [(BTSupporter, 3, testCodeExpiry), (BTLegend, 3, testCodeExpiry)] >>= writeIORef codesRef + withBadgeServiceClock ps (readIORef clock) writeConfig seedCodes $ \client bsLink -> do + [supporterCode, legendCode] <- readIORef codesRef + unknown1 <- mintUnknownCode + unknown2 <- mintUnknownCode + unknown3 <- mintUnknownCode + unknown4 <- mintUnknownCode + -- none of these four is a failed redemption, so none may spend a token + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter supporterCode) + _ <- expectCredential "success does not debit" client + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter supporterCode) + _ <- expectCredential "replay does not debit" client + sendRequest client bsLink signer (purchaseRequest signer (badgeRequestFor signer BTSupporter "reserved") Nothing supporterCode) + expectErrorCode "reserved badgeExtra does not debit" client "bad_request" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter legendCode) + expectErrorCode "tier mismatch does not debit" client "bad_request" + -- three genuine failures, one token each + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter unknown1) + expectErrorCode "first failure" client "code_invalid" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter (corruptCheckCharacter unknown2)) + expectErrorCode "second failure (never reaches the database)" client "code_invalid" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter unknown3) + expectErrorCode "third failure" client "code_invalid" + -- the bucket is now empty: the fourth is refused before it is even classified + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter unknown4) + expectRateLimited "fourth failure" client + -- another signer's bucket is its own + sendRequest client bsLink otherSigner (purchaseCodeRequest otherSigner BTSupporter unknown4) + expectErrorCode "fresh signer" client "code_invalid" + +-- The brief's global-budget bullet and B10 item 13: the service-wide failure budget is drained by +-- three DIFFERENT signers, so the fourth -- a fresh signer presenting a perfectly VALID code -- +-- is rate_limited before the code is classified. That leaves the code unredeemed, which is what +-- lets the same request succeed once the bucket has refilled. The refill is reached by moving +-- A6's clock an hour, not by sleeping. +testBadgeServiceGlobalFailureBudgetRefills :: HasCallStack => TestParams -> IO () +testBadgeServiceGlobalFailureBudgetRefills ps = do + clock <- newTestClock testClockStart + signers <- replicateM 3 newTestSigner + redeemer <- newTestSigner + codeRef <- newIORef "" + let writeConfig = + writeTestBadgeServiceConfigWith ps ["", "[throttle]", "global_failure_capacity = 3", "global_failure_start_tokens = 3"] + seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) writeConfig seedCode $ \client bsLink -> do + code <- readIORef codeRef + forM_ (zip [1 :: Int ..] signers) $ \(n, failingSigner) -> do + unknownCode <- mintUnknownCode + sendRequest client bsLink failingSigner (purchaseCodeRequest failingSigner BTSupporter unknownCode) + expectErrorCode ("global budget failure " <> show n) client "code_invalid" + sendRequest client bsLink redeemer (purchaseCodeRequest redeemer BTSupporter code) + expectRateLimited "valid code with the global budget drained" client + -- capacity 3 refills 3 tokens per hour, so an hour of service time is a full bucket + advanceTestClockSeconds clock 3600 + sendRequest client bsLink redeemer (purchaseCodeRequest redeemer BTSupporter code) + (_, statement) <- expectCredential "same code after the budget refilled" client + statementShape statement `shouldBe` [(3, 3, "credit payment (no invoiceId)"), (-1, 2, "debit badge")] + -- exactly one purchase: the three throttled failures wrote nothing, and the rate_limited + -- request neither consumed the code nor created a purchase + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + +-- Brief 6 / B10 item 9: two months on, issueBadge writes debit(lapse) and THEN debit(badge) -- +-- in that order -- plus a second issuance; a third call inside the same month returns the cached +-- credential and writes nothing. +-- +-- The code funds FOUR months, so a month is still funded after the second period is issued. With +-- three the second issuance would exhaust the balance, and a third call inside that same, +-- already-issued month answers with NO credential instead of the cached one: 'planLedger' tells +-- 'IssueCached' from 'IssueExhausted' by the balance alone, so a zero balance hides an +-- already-issued month. That is a real defect (RPC "Idempotency"), reported by B10 rather than +-- pinned here -- asserting it would enshrine it. +testBadgeServiceIssueBadgeSecondPeriod :: HasCallStack => TestParams -> IO () +testBadgeServiceIssueBadgeSecondPeriod ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedTestCodes ps [(BTSupporter, 4, testCodeExpiry)] >>= writeIORef codeRef . head + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code) + (cred1, _) <- expectCredential "redeem" client + advanceTestClockMonths clock 2 + let req = issueRequest signer BTSupporter "" unknownEntryUuid + sendRequest client bsLink signer req + (cred2, statement) <- expectCredential "second period" client + cred2 `shouldNotBe` cred1 + statementShape statement + `shouldBe` [ (4, 4, "credit payment (no invoiceId)"), + (-1, 3, "debit badge"), + (-1, 2, "debit lapse"), + (-1, 1, "debit badge") + ] + -- the period issued is [2026-05-10, 2026-06-10); 2026-06-10 is a Wednesday + badgeCredentialExpiry cred2 `shouldBe` Just (UTCTime (fromGregorian 2026 6 14) sundayEndOfDay) + sendRequest client bsLink signer req + (cred3, statement3) <- expectCredential "third call inside the same month" client + cred3 `shouldBe` cred2 + statementShape statement3 `shouldBe` statementShape statement + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 4, 2, 1) + +badgeCredentialExpiry :: BadgeCredential -> Maybe UTCTime +badgeCredentialExpiry BadgeCredential {badgeInfo = BadgeInfo {badgeExpiry}} = badgeExpiry + +-- Brief 7 / B10 item 10: an exhausted balance is not an error -- no credential, and a statement +-- ending at zero months that says why. +testBadgeServiceIssueBadgeExhaustedBalance :: HasCallStack => TestParams -> IO () +testBadgeServiceIssueBadgeExhaustedBalance ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedTestCodes ps [(BTSupporter, 1, testCodeExpiry)] >>= writeIORef codeRef . head + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code) + (_, statement1) <- expectCredential "redeem one month" client + statementShape statement1 `shouldBe` [(1, 1, "credit payment (no invoiceId)"), (-1, 0, "debit badge")] + advanceTestClockMonths clock 1 + sendRequest client bsLink signer (issueRequest signer BTSupporter "" unknownEntryUuid) + (credential, statement2) <- expectCredentialResponse "exhausted balance" client + credential `shouldBe` Nothing + statementShape statement2 `shouldBe` statementShape statement1 + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + +-- B10 items 8 and 15 / brief 9: a second code under a purchase key that already exists credits +-- the existing ledger, gets its OWN payments row while the purchase keeps pointing at the first +-- one, and -- because the month is already issued -- writes no second debit(badge) and no second +-- issuance, returning the credential that already exists. A code of a different tier under the +-- same key is bad_request. +testBadgeServiceSecondCodeSamePurchaseKey :: HasCallStack => TestParams -> IO () +testBadgeServiceSecondCodeSamePurchaseKey ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codesRef <- newIORef [] + let seedCodes = + seedTestCodes ps [(BTSupporter, 3, testCodeExpiry), (BTSupporter, 3, testCodeExpiry), (BTLegend, 3, testCodeExpiry)] + >>= writeIORef codesRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCodes $ \client bsLink -> do + [code1, code2, legendCode] <- readIORef codesRef + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code1) + (cred1, _) <- expectCredential "first code" client + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code2) + (cred2, statement) <- expectCredential "second code, same key" client + cred2 `shouldBe` cred1 + statementShape statement + `shouldBe` [ (3, 3, "credit payment (no invoiceId)"), + (-1, 2, "debit badge"), + (3, 5, "credit payment (no invoiceId)") + ] + sendRequest client bsLink signer (purchaseCodeRequest signer BTLegend legendCode) + expectErrorCode "a different tier under an existing key" client "bad_request" + withServiceDB ps $ \db -> do + serviceRowCounts db `shouldReturn` (1, 2, 3, 1, 2) + creditPayments <- + DB.query_ db "SELECT payment_id FROM sx_badge_service_badge_ledger WHERE entry_type = 'credit' ORDER BY entry_id" + [Only purchasePaymentId] <- DB.query_ db "SELECT payment_id FROM sx_badge_service_badge_purchases" + case creditPayments of + [Only firstPayment, Only secondPayment] -> do + (firstPayment :: Text) `shouldNotBe` secondPayment + purchasePaymentId `shouldBe` Just firstPayment + other -> expectationFailure $ "expected two credit entries with distinct payments, got: " <> show other + +-- B10 item 6, the security assertion of this step: the service signs exactly the content the +-- client sent, so a badgeRequest naming a tier the funding does not cover is refused on ALL +-- THREE paths -- a fresh redemption, a replay of one, and issueBadge. Without this a supporter +-- code buys a signed legend credential, since 'issueSignedBadge' overrides only badgeExpiry. +-- The refusal must also leave the code intact: it is redeemed successfully in between. +testBadgeServiceTierMismatchIsBadRequest :: HasCallStack => TestParams -> IO () +testBadgeServiceTierMismatchIsBadRequest ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + sendRequest client bsLink signer (purchaseCodeRequest signer BTLegend code) + expectErrorCode "legend request with a supporter code" client "bad_request" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code) + _ <- expectCredential "the same code still redeems" client + sendRequest client bsLink signer (purchaseCodeRequest signer BTLegend code) + expectErrorCode "legend request replaying a supporter redemption" client "bad_request" + sendRequest client bsLink signer (issueRequest signer BTLegend "" unknownEntryUuid) + expectErrorCode "issueBadge naming another tier" client "bad_request" + -- exactly what the one successful redemption writes: the three refusals wrote nothing + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + +-- B10 item 7: a purchase carrying an upgrade is refused before the payment is even looked at, so +-- the code is not consumed by a request whose upgrade would have been silently dropped. +testBadgeServiceUpgradeIsBadRequest :: HasCallStack => TestParams -> IO () +testBadgeServiceUpgradeIsBadRequest ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + otherSigner <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + -- BadgeUpgrade is constructed positionally: its 'receipt' and 'balance' fields collide with + -- BadgeServiceResponse's and BSCIssueBadge's, so only its constructor is imported. + let upgrade = + BadgeUpgrade + (signerPub otherSigner) + "test-receipt" + (C.sign' (signerPriv otherSigner) "test-receipt") + (BadgeBalance (StatementEntry unknownEntryUuid 1 1 testClockStart BTSupporter Nothing testClockStart (SECredit SCOpening))) + sendRequest client bsLink signer (purchaseRequest signer (badgeRequestFor signer BTSupporter "") (Just upgrade) code) + expectErrorCode "purchase carrying an upgrade" client "bad_request" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code) + _ <- expectCredential "the same code still redeems" client + pure () + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + +-- B10 item 12, first half: a reserved (non-empty) badgeExtra is a CLIENT fault -- bad_request, +-- terminal -- refused by both handlers before anything is classified, planned or signed, leaving +-- the code unredeemed. Its counterpart, a signing failure answering 'internal', cannot be induced +-- from a test without a fault injector and is recorded as untested rather than folded in here: +-- conflating the two is the defect B7's fix round removed. +testBadgeServiceBadgeExtraIsBadRequest :: HasCallStack => TestParams -> IO () +testBadgeServiceBadgeExtraIsBadRequest ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + sendRequest client bsLink signer (purchaseRequest signer (badgeRequestFor signer BTSupporter "reserved") Nothing code) + expectErrorCode "purchaseBadge with a reserved badgeExtra" client "bad_request" + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code) + _ <- expectCredential "the same code still redeems" client + sendRequest client bsLink signer (issueRequest signer BTSupporter "reserved" unknownEntryUuid) + expectErrorCode "issueBadge with a reserved badgeExtra" client "bad_request" + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 2, 1, 1) + +-- B10 item 11: the statement cursor. An assertion naming an entry the service holds returns only +-- what follows it and echoes it back; an unknown uuid, or -- the privacy assertion -- one +-- belonging to ANOTHER purchase, returns the complete history with previousEntryId absent, and +-- never a single entry of that other purchase. +testBadgeServiceIssueBadgeCursor :: HasCallStack => TestParams -> IO () +testBadgeServiceIssueBadgeCursor ps = do + clock <- newTestClock testClockStart + signer <- newTestSigner + otherSigner <- newTestSigner + codesRef <- newIORef [] + let seedCodes = seedTestCodes ps [(BTSupporter, 3, testCodeExpiry), (BTSupporter, 3, testCodeExpiry)] >>= writeIORef codesRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCodes $ \client bsLink -> do + [code, otherCode] <- readIORef codesRef + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code) + (_, ownStatement) <- expectCredential "own redemption" client + sendRequest client bsLink otherSigner (purchaseCodeRequest otherSigner BTSupporter otherCode) + (_, otherStatement) <- expectCredential "other purchase's redemption" client + ownEntries <- case statementEntryIds ownStatement of + ids@[_, _] -> pure ids + other -> expectationFailure ("expected two own entries, got: " <> show other) >> error "unreachable" + otherEntries <- case statementEntryIds otherStatement of + ids@[_, _] -> pure ids + other -> expectationFailure ("expected two other entries, got: " <> show other) >> error "unreachable" + -- a cursor the service holds for THIS purchase: only what follows it + sendRequest client bsLink signer (issueRequest signer BTSupporter "" (head ownEntries)) + (_, afterCursor) <- expectCredential "cursor hit" client + statementEntryIds afterCursor `shouldBe` drop 1 ownEntries + previousEntryId afterCursor `shouldBe` Just (head ownEntries) + -- a uuid belonging to a different purchase resolves to nothing: the full own history follows + sendRequest client bsLink signer (issueRequest signer BTSupporter "" (head otherEntries)) + (_, crossPurchase) <- expectCredential "cursor from another purchase" client + statementEntryIds crossPurchase `shouldBe` ownEntries + previousEntryId crossPurchase `shouldBe` Nothing + -- and so does one the service has never seen + sendRequest client bsLink signer (issueRequest signer BTSupporter "" unknownEntryUuid) + (_, unknownCursor) <- expectCredential "unknown cursor" client + statementEntryIds unknownCursor `shouldBe` ownEntries + previousEntryId unknownCursor `shouldBe` Nothing + -- three cached issueBadge calls wrote nothing: two purchases, two entries each + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (2, 2, 4, 2, 2) + +-- B10 item 14, the regression guard for B7's §9 ruling: the cached credential is fetched by +-- probing the issuance table at NOW, not at @addMonths (-1) balanceStartTs@. Stepping a month +-- back from a clamped boundary (31 Jan + 1 month = 28 Feb; 28 Feb - 1 month = 28 Jan) lands +-- BEFORE the period it came from, so the brief's original formula returns the PREVIOUS month's +-- credential -- a wrong credential, not an absent one. Two consecutive periods are issued across +-- exactly that boundary so the wrong answer is available to be returned. +testBadgeServiceCachedIssuanceAtClampedMonthBoundary :: HasCallStack => TestParams -> IO () +testBadgeServiceCachedIssuanceAtClampedMonthBoundary ps = do + clock <- newTestClock (UTCTime (fromGregorian 2025 12 31) noonUTC) + signer <- newTestSigner + codeRef <- newIORef "" + let seedCode = seedOneSupporterCode ps >>= writeIORef codeRef + withBadgeServiceClock ps (readIORef clock) (writeTestBadgeServiceConfig ps) seedCode $ \client bsLink -> do + code <- readIORef codeRef + -- period 1: [2025-12-31, 2026-01-31) + sendRequest client bsLink signer (purchaseCodeRequest signer BTSupporter code) + (cred1, _) <- expectCredential "period starting 2025-12-31" client + -- period 2: [2026-01-31, 2026-02-28) -- the clamped boundary + setTestClock clock (UTCTime (fromGregorian 2026 1 31) noonUTC) + sendRequest client bsLink signer (issueRequest signer BTSupporter "" unknownEntryUuid) + (cred2, _) <- expectCredential "period starting 2026-01-31" client + cred2 `shouldNotBe` cred1 + -- inside period 2: the cached credential must be period 2's, never period 1's + setTestClock clock (UTCTime (fromGregorian 2026 2 15) noonUTC) + sendRequest client bsLink signer (issueRequest signer BTSupporter "" unknownEntryUuid) + (cached, _) <- expectCredential "inside the already-issued clamped month" client + cached `shouldBe` cred2 + cached `shouldNotBe` cred1 + withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 3, 2, 1) + +#if !defined(dbPostgres) +-- The brief's schema assertion (§3 Linkage), and the regression guard for the privacy claim the +-- whole web-checkout design rests on: an order and a purchase must never be joinable, so NO table +-- may carry a column referencing @web_orders and a column referencing @badge_purchases at once. +-- Enumerated from the database itself (sqlite_master plus each table's foreign keys), not from +-- the migration source, so it fails the day a later step adds such a column. Reads a SQLite file, +-- hence the guard: A3's Postgres run of this spec would break on it otherwise. +testBadgeServiceNoTableLinksOrdersToPurchases :: HasCallStack => TestParams -> IO () +testBadgeServiceNoTableLinksOrdersToPurchases ps = + withFreshBadgeStore ps $ \st -> do + tables <- withConnection st $ \db -> + DB.query_ db "SELECT name FROM sqlite_master WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY name" + let tableNames = map fromOnly tables :: [Text] + -- the enumeration must actually see the two tables in question, or it proves nothing + tableNames `shouldSatisfy` elem "sx_badge_service_web_orders" + tableNames `shouldSatisfy` elem "sx_badge_service_codes" + references <- forM tableNames $ \table -> do + refs <- withConnection st $ \db -> DB.query db "SELECT \"table\" FROM pragma_foreign_key_list(?)" (Only table) + pure (table, map fromOnly refs :: [Text]) + -- and it must actually see foreign keys: @codes does reference @badge_purchases, so a pragma + -- that returned nothing would make the assertion below vacuous + map fst (filter (refersTo "badge_purchases" . snd) references) `shouldSatisfy` elem "sx_badge_service_codes" + map fst (filter (\(_, refs) -> refersTo "web_orders" refs && refersTo "badge_purchases" refs) references) `shouldBe` [] + where + refersTo suffix = any (suffix `T.isSuffixOf`) +#endif + +-- B8's Verify line, formally owed by B10: @codes issue@ mints the requested number of codes, +-- prints each plaintext exactly once, stores only distinct hashes of them, @codes revoke@ revokes +-- the whole batch, @codes status@ reports what the row says, and a past @--expires@ is accepted. +-- Driven through 'runAdminCmd' -- the real entry point 'Main.hs' calls, opening its own store and +-- reading the same ini a service run does -- with stdout captured, since the plaintext codes exist +-- nowhere else. +testBadgeServiceCodesIssueRevokeStatus :: HasCallStack => TestParams -> IO () +testBadgeServiceCodesIssueRevokeStatus ps@TestParams {tmpPath} = do + writeTestBadgeServiceConfig ps + let adminOpts cmd = + AdminOpts + { adminCoreOptions = coreOptions (mkBadgeServiceOpts ps), + adminConfigFile = badgeServiceConfigPath tmpPath, + adminCmd = cmd + } + issueOpts batch expires = + CmdIssue IssueOpts {issueType = BTSupporter, issueMonths = 3, issueCount = 10, issueBatch = batch, issueExpires = expires} + runCodes label cmd = withCapturedStdout (tmpPath (label <> ".out")) (runAdminCmd (adminOpts cmd)) + issued <- runCodes "issue" (issueOpts testCodeBatch Nothing) + length issued `shouldBe` 10 + length (nub issued) `shouldBe` 10 + all (Codes.verifyChecksum . Codes.normalizeCode) issued `shouldBe` True + length (nub (map (Codes.codeHash . Codes.normalizeCode) issued)) `shouldBe` 10 + -- every printed code resolves to a stored row of its own -- @codes status@ hashes what it is + -- given and looks that up, so this is what proves the rows are keyed by the hash of exactly + -- what was printed. The revoke count below then confirms there are ten of them and no more. + forM_ (zip [1 :: Int ..] issued) $ \(n, code) -> do + status <- runCodes ("status-issued-" <> show n) (CmdStatus code) + (n, status) `shouldSatisfy` any (T.isInfixOf "status=unredeemed") . snd +#if !defined(dbPostgres) + -- the property the whole design hinges on: no plaintext code anywhere in the database file, + -- neither as printed nor as normalized. Reads the SQLite file, hence the guard. + dbBytes <- BC.readFile (tmpPath (serviceDbPrefix <> "_chat.db")) + forM_ issued $ \code -> do + (code, encodeUtf8 code `BS.isInfixOf` dbBytes) `shouldBe` (code, False) + (code, encodeUtf8 (Codes.normalizeCode code) `BS.isInfixOf` dbBytes) `shouldBe` (code, False) +#endif + statusBefore <- runCodes "status-before" (CmdStatus (head issued)) + statusBefore `shouldSatisfy` any (T.isInfixOf "status=unredeemed") + statusBefore `shouldSatisfy` any (T.isInfixOf ("batch=" <> testCodeBatch)) + statusBefore `shouldSatisfy` any (T.isInfixOf "type=supporter") + statusBefore `shouldSatisfy` any (T.isInfixOf "months=3") + -- a past --expires is stored exactly as given, with no validation beyond the date format + pastExpiry <- runCodes "issue-past" (issueOpts "b10-expired-batch" (Just (fromGregorian 2000 1 1))) + length pastExpiry `shouldBe` 10 + statusPast <- runCodes "status-past" (CmdStatus (head pastExpiry)) + statusPast `shouldSatisfy` any (T.isInfixOf "expires=2000-01-01") + revoked <- runCodes "revoke" (CmdRevoke testCodeBatch) + revoked `shouldBe` ["10 code(s) revoked in batch " <> testCodeBatch] + statusAfter <- runCodes "status-after" (CmdStatus (head issued)) + statusAfter `shouldSatisfy` any (T.isInfixOf "status=revoked") + -- the other batch is untouched: revoke is scoped to the batch it names + statusOther <- runCodes "status-other-batch" (CmdStatus (head pastExpiry)) + statusOther `shouldSatisfy` any (T.isInfixOf "status=unredeemed") + +-- | Runs an action with stdout redirected to a file, returning the lines it printed. The only way +-- to read what @codes issue@ minted: the plaintext codes are printed once and never stored. +withCapturedStdout :: FilePath -> IO () -> IO [Text] +withCapturedStdout path action = do + saved <- hDuplicate stdout + h <- openFile path WriteMode + (hDuplicateTo h stdout >> action) `finally` do + hFlush stdout + hDuplicateTo saved stdout + hClose saved + hClose h + T.lines <$> TIO.readFile path + +-- B8's remaining Verify item: lifetime badges are out of scope, so @--type investor@ is rejected +-- by the parser itself, before any store is opened. +testBadgeServiceCodesRejectsInvestorType :: HasCallStack => TestParams -> IO () +testBadgeServiceCodesRejectsInvestorType _ps = + case O.execParserPure O.defaultPrefs (O.info adminCommandParser O.fullDesc) issueInvestor of + O.Failure failure -> fst (O.renderFailure failure "codes") `shouldSatisfy` isInfixOf "expected 'supporter' or 'legend'" + O.Success _ -> expectationFailure "expected --type investor to be rejected" + O.CompletionInvoked _ -> expectationFailure "expected --type investor to be rejected" + where + issueInvestor = ["issue", "--type", "investor", "--months", "3", "--count", "10", "--batch", "b10-investor"] + -- B1 store layer ------------------------------------------------------------- -- A fresh, migrated badge-service database, independent of any running bot: these tests