From 593ae1c768d59fe7830be77e848601951fd7aec5 Mon Sep 17 00:00:00 2001 From: shum Date: Tue, 25 Aug 2026 17:53:56 +0000 Subject: [PATCH] core: broaden badge service test assertions --- .../src/BadgeService/Ledger.hs | 9 +- .../src/BadgeService/Service.hs | 8 + .../2026-08-21-badges-web-checkout.md | 3 +- tests/Bots/BadgeServiceTests.hs | 155 ++++++++++++++---- 4 files changed, 140 insertions(+), 35 deletions(-) diff --git a/apps/simplex-badge-service/src/BadgeService/Ledger.hs b/apps/simplex-badge-service/src/BadgeService/Ledger.hs index 699a5358e6..7835e4521d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Ledger.hs +++ b/apps/simplex-badge-service/src/BadgeService/Ledger.hs @@ -61,7 +61,14 @@ debitAll _reason st = st {balanceMonths = 0} -- | @consume@: issues a credential for @[balanceStartTs, addMonths 1 balanceStartTs)@, debiting -- one month. 'Nothing' when @balanceMonths == 0@ (nothing to issue) or when the current month is --- already issued (@balanceStartTs > t@); the caller tells the two apart by the balance. +-- already issued (@balanceStartTs > t@). +-- +-- __A caller telling those two apart must test @balanceStartTs > t@, never the balance.__ The two +-- reasons are not exclusive: once the LAST funded month has been issued both hold at once, and a +-- caller reading the balance there calls an already-issued month exhausted — refusing to hand back +-- a credential that was already issued and stored, which is what @badges-rpc.md@ §Idempotency is +-- about. That was a real defect in @BadgeService.Service.planLedger@ (found and fixed in B10, plan +-- §9); this comment used to instruct it. -- -- This guard only works because 'advance' steps to the same month boundaries 'issue' does (see -- 'advance''s Haddock): whenever 'advance' is not capped by a low balance, its resulting diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 6f6bc3a297..9a2cb8650f 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -731,6 +731,14 @@ planLedger now' creditWith wasPaused st0 = -- sets it to @now@, 'credit' to @max balanceStartTs now@, and 'advance' steps it only to -- boundaries at or before @now@. So an issuance covering @now@ always exists here, which is -- what 'resolveIssue' then fetches. + -- + -- __That argument assumes the clock does not run backwards.__ It is an unstated premise + -- everywhere else in this module too, and it is stated here because an unstated premise is + -- what hid the defect above. Under a backwards jump past the start of the issued period, + -- @now@ falls outside it, 'getIssuanceForPeriod' matches nothing and 'resolveIssue' answers + -- 'internal' with a logged error, having written nothing — safe, but not the answer this + -- branch promises. Only a rewound host clock can produce it: 'BadgeServiceEnv.now' is the + -- one clock read, and nothing here persists a time it did not come from. Nothing -> case st2 of LedgerState {balanceStartTs = startTs} | startTs > now' -> IssueCached 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 11d6a5ca11..c091768dfd 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -1373,10 +1373,11 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **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 — `Ledger.issue`'s own Haddock instructed the defect, and is corrected.** It told callers to "tell the two apart by the balance", which is precisely the rule that produced the bug below; it is the one comment a future caller of `issue` reads. It now says to test `balanceStartTs > t` and why the two refusal reasons are not exclusive. Correcting `planLedger` and plan §5 alone would have left the instruction in place for the next caller. - **B10 — a B7 defect found and FIXED here: a zero balance hid an already-issued month.** `planLedger` told `IssueCached` from `IssueExhausted` by the balance alone, but `issue` returns `Nothing` for two independent reasons — an exhausted balance, and a month that is already issued. Once the LAST funded month had been issued both held at once, so a repeat `issueBadge` inside that same month answered `credential = Nothing` instead of the credential the service had already signed, stored and delivered. **Failure mode: C3's worker retries `issueBadge` after a timeout in the final funded month, is told there is no credential, and the user loses a month they paid for** — the exact case RPC §Idempotency exists for. Fixed by classifying on `balanceStartTs > now` (`issue`'s own already-issued guard) instead of `balanceMonths == 0`, which is total over both reasons on every path: `initialLedgerState` sets `balanceStartTs` to `now`, `credit` to `max balanceStartTs now` and `advance` only to boundaries at or before `now`, so a `balanceStartTs` past `now` can only have been set by a previous `issue` and an issuance covering `now` always exists there. B7's step 4 above is corrected in place. This is B7 code changed inside B10's commit range, deliberately: B10 held the reproduction. Pinned by `testBadgeServiceIssueBadgeCachedInLastFundedMonth` (one funded month, issued, then `issueBadge` again at the same instant and ten days later — both must return the cached credential), proved able to fail by reverting the classification; `testBadgeServiceIssueBadgeExhaustedBalance` holds the genuinely-exhausted month after it, and `testBadgeServiceIssueBadgeSecondPeriod` funds four months so the two cases stay separate. - **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 — the two `#if !defined(dbPostgres)` assertions are a SQLite-only guard, and want a Postgres twin.** The §3 Linkage schema assertion (no table references both `@web_orders` and `@badge_purchases`) and B8's no-plaintext-at-rest check both read a database *file*, so both are guarded — as this step's brief requires, since the Postgres run would otherwise break. The consequence is that the privacy regression guard does not run on the backend a real deployment uses. A twin reading `information_schema.table_constraints`/`key_column_usage` for the first, and `pg_dump`ing the schema-qualified tables for the second, is a small follow-up worth doing before the web-order tables acquire any new column. +- **B10 — what the §3 Linkage guard does and does not cover, in full.** It enumerates every table in the service database and flags one as holding an order (purchase) reference if it declares a foreign key to `@web_orders` (`@badge_purchases`) **or names a column after it** — `web_order_id TEXT` with no `REFERENCES` clause is invisible to `pragma_foreign_key_list`, and D0, the next step, is what adds order tables. Three anti-vacuity controls: both tables are seen by name, `@codes`'s real declared foreign key to `@badge_purchases` is seen, and a probe table carrying both columns with **no** foreign keys is created, caught and dropped before the real scan. Residual limits, all disclosed: **(a)** it is SQLite-only (`#if !defined(dbPostgres)`), and `Store/Postgres/Migrations.hs` is a separately hand-maintained file, so a linkage column added *only* there is invisible to this guard forever — a twin over `information_schema.table_constraints`/`key_column_usage` is the fix, and it is a follow-up, not done here; **(b)** the name half matches substrings, so an innocent `sort_order` column would raise a false alarm — deliberate, since the cost is one reader's minute against the privacy claim the whole web checkout rests on; **(c)** it sees only *columns*, so a join built some other way (a view, a lookup table keyed by a hash of both, an out-of-band file) passes. B8's no-plaintext-at-rest scan is guarded for the same file-reading reason and now carries a positive control (the batch label, which IS stored in the clear, must be found in the same bytes), so it can no longer pass because it read the wrong or an empty file. - **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 diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 562a999095..03e9661c96 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -41,14 +41,13 @@ import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.STM (atomically, readTVarIO) import Control.Exception (SomeException, finally, try) -import Control.Monad (forM, forM_, replicateM, void) +import Control.Monad (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 @@ -59,7 +58,6 @@ 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) @@ -131,6 +129,13 @@ import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations) import Database.SQLite.Simple (Only (..)) import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +-- Reachable only from the two '#if !defined(dbPostgres)' tests below (the schema-linkage scan and +-- the no-plaintext-at-rest scan), so they are imported here rather than unconditionally: under +-- 'client_postgres' the code that uses them is compiled out and an unconditional import would +-- make that build warn (-Wunused-imports). +import Control.Monad (forM) +import qualified Data.ByteString as BS +import Data.Text.Encoding (encodeUtf8) #endif badgeServiceTests :: SpecWith TestParams @@ -1518,6 +1523,13 @@ testBadgeServiceCodeFailureOutcomes ps = do -- 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. +-- +-- BOTH buckets are overridden, because "debits neither" is a claim about both and every debit +-- spends one token from each. The global budget is set to exactly one more than the number of +-- genuine failures here (3 + the fresh signer's one at the end), so a single spurious GLOBAL +-- debit anywhere in the four non-failure requests leaves nothing for that last request and turns +-- it into rate_limited. With the global left at its default 600, a service that debited the +-- shared budget on every success would have passed this example unchanged. testBadgeServiceFailureDebitsBucketOncePerFailure :: HasCallStack => TestParams -> IO () testBadgeServiceFailureDebitsBucketOncePerFailure ps = do clock <- newTestClock testClockStart @@ -1525,7 +1537,15 @@ testBadgeServiceFailureDebitsBucketOncePerFailure ps = do otherSigner <- newTestSigner codesRef <- newIORef [] let writeConfig = - writeTestBadgeServiceConfigWith ps ["", "[throttle]", "signer_failure_capacity = 3", "signer_failure_start_tokens = 3"] + writeTestBadgeServiceConfigWith + ps + [ "", + "[throttle]", + "signer_failure_capacity = 3", + "signer_failure_start_tokens = 3", + "global_failure_capacity = 4", + "global_failure_start_tokens = 4" + ] seedCodes = seedTestCodes ps [(BTSupporter, 3, testCodeExpiry), (BTLegend, 3, testCodeExpiry)] >>= writeIORef codesRef withBadgeServiceClock ps (readIORef clock) writeConfig seedCodes $ \client bsLink -> do [supporterCode, legendCode] <- readIORef codesRef @@ -1552,15 +1572,30 @@ testBadgeServiceFailureDebitsBucketOncePerFailure ps = do -- 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 + -- another signer's bucket is its own -- and this is also the global budget's last token, so + -- it only answers code_invalid if nothing above spent one it should not have 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. +-- lets the same request succeed once the bucket has refilled. Time moves through A6's clock; no +-- test sleeps. +-- +-- The clock is advanced in two PARTIAL steps rather than one full hour, so that "a rate_limited +-- rejection must not debit again" (item 13) is actually pinned rather than merely stated. Both +-- buckets refill at capacity tokens per hour, and 'debitBucket' clamps at zero, so a spurious +-- debit is invisible unless the bucket is left short of the threshold afterwards: +-- +-- * 900s at capacity 3 puts the global budget at 0.75 tokens -- still below 1, so the valid +-- code is refused, with 0.25 of margin either side of the threshold; +-- * a further 600s adds 0.5. Without a debit that is 1.25 and the retry succeeds; with one it +-- is 0.5 and the retry would still be refused. +-- +-- The per-signer capacity is 1 for the same reason, from the other side: it refills 1 token per +-- hour, so a signer bucket debited by the rejection would hold 1500/3600 = 0.42 tokens at the +-- retry and refuse it. Either bucket being debited by a rejection fails this example. testBadgeServiceGlobalFailureBudgetRefills :: HasCallStack => TestParams -> IO () testBadgeServiceGlobalFailureBudgetRefills ps = do clock <- newTestClock testClockStart @@ -1568,7 +1603,15 @@ testBadgeServiceGlobalFailureBudgetRefills ps = do redeemer <- newTestSigner codeRef <- newIORef "" let writeConfig = - writeTestBadgeServiceConfigWith ps ["", "[throttle]", "global_failure_capacity = 3", "global_failure_start_tokens = 3"] + writeTestBadgeServiceConfigWith + ps + [ "", + "[throttle]", + "signer_failure_capacity = 1", + "signer_failure_start_tokens = 1", + "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 @@ -1576,10 +1619,12 @@ testBadgeServiceGlobalFailureBudgetRefills ps = do unknownCode <- mintUnknownCode sendRequest client bsLink failingSigner (purchaseCodeRequest failingSigner BTSupporter unknownCode) expectErrorCode ("global budget failure " <> show n) client "code_invalid" + -- 0.75 of a token: refused, and far enough below the threshold that no rounding decides it + advanceTestClockSeconds clock 900 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 + -- +0.5: enough only if the rejection above spent nothing + advanceTestClockSeconds clock 600 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")] @@ -1591,12 +1636,12 @@ testBadgeServiceGlobalFailureBudgetRefills ps = do -- 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. +-- The code funds FOUR months, so a month is still funded after the second period is issued. Three +-- would work too now: exhausting the balance in an already-issued month is answered with that +-- month's cached credential since the B7 defect this step found was fixed, and +-- 'testBadgeServiceIssueBadgeCachedInLastFundedMonth' holds exactly that case. Four is kept +-- deliberately, so this example exercises the multi-period path with a balance still funded and +-- stays independent of the cached-in-the-last-month behaviour it used to collide with. testBadgeServiceIssueBadgeSecondPeriod :: HasCallStack => TestParams -> IO () testBadgeServiceIssueBadgeSecondPeriod ps = do clock <- newTestClock testClockStart @@ -1862,30 +1907,69 @@ testBadgeServiceCachedIssuanceAtClampedMonthBoundary ps = do withServiceDB ps $ \db -> serviceRowCounts db `shouldReturn` (1, 1, 3, 2, 1) #if !defined(dbPostgres) +-- What one table holds, as the database itself reports it: its declared foreign-key targets and +-- its column names. +data TableRefs = TableRefs + { refTable :: Text, + refFkTargets :: [Text], + refColumns :: [Text] + } + deriving (Show) + +-- | A table holds an order (purchase) reference if it declares a foreign key to that table __or__ +-- names a column after it. The name half is the load-bearing one for what comes next: a plain +-- @web_order_id TEXT@ with no @REFERENCES@ clause is invisible to 'pragma_foreign_key_list', and +-- D0 -- the very next step -- is what adds order tables. A false alarm from an innocent column +-- name (@sort_order@) is the intended trade: it costs one reader a minute, and the failure it +-- guards against costs the privacy claim the whole web checkout rests on. +holdsOrderRef :: TableRefs -> Bool +holdsOrderRef TableRefs {refFkTargets, refColumns} = + any ("web_orders" `T.isSuffixOf`) refFkTargets || any ("order" `T.isInfixOf`) refColumns + +holdsPurchaseRef :: TableRefs -> Bool +holdsPurchaseRef TableRefs {refFkTargets, refColumns} = + any ("badge_purchases" `T.isSuffixOf`) refFkTargets || any ("purchase" `T.isInfixOf`) refColumns + -- 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. +-- may carry a reference to @web_orders and a reference to @badge_purchases at once. Enumerated +-- from the database itself (sqlite_master, each table's foreign keys and each table's columns), +-- 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. +-- +-- Three anti-vacuity controls, because an assertion that only ever says "no rows matched" is one +-- typo away from proving nothing: the enumeration must see both tables by name, it must see the +-- real declared foreign key from @codes to @badge_purchases, and -- the control for the half that +-- foreign keys cannot see -- a probe table carrying both columns with NO foreign keys at all must +-- be caught, then dropped before the real scan. 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 + let refsOf table = do + fks <- withConnection st $ \db -> DB.query db "SELECT \"table\" FROM pragma_foreign_key_list(?)" (Only table) + cols <- withConnection st $ \db -> DB.query db "SELECT name FROM pragma_table_info(?)" (Only table) + pure TableRefs {refTable = table, refFkTargets = map fromOnly fks, refColumns = map fromOnly cols} + listTables = + map fromOnly + <$> withConnection + st + (\db -> DB.query_ db "SELECT name FROM sqlite_master WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY name") + -- control 3, first: exactly the shape D0 could add without a REFERENCES clause + withConnection st $ \db -> DB.execute_ db "CREATE TABLE b10_linkage_probe (web_order_id TEXT, badge_purchase_id INTEGER)" + probe <- refsOf "b10_linkage_probe" + (refTable probe, holdsOrderRef probe, holdsPurchaseRef probe) `shouldBe` ("b10_linkage_probe", True, True) + refFkTargets probe `shouldBe` [] -- and it is caught with no foreign key to go on + withConnection st $ \db -> DB.execute_ db "DROP TABLE b10_linkage_probe" + tableNames <- listTables + -- controls 1 and 2: the enumeration sees both tables, and sees a real declared foreign key 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`) + tableNames `shouldSatisfy` notElem "b10_linkage_probe" + codeRefs <- refsOf "sx_badge_service_codes" + refFkTargets codeRefs `shouldSatisfy` any ("badge_purchases" `T.isSuffixOf`) + references <- forM tableNames refsOf + map refTable (filter holdsOrderRef references) `shouldBe` ["sx_badge_service_web_orders"] + map refTable (filter (\refs -> holdsOrderRef refs && holdsPurchaseRef refs) references) `shouldBe` [] #endif -- B8's Verify line, formally owed by B10: @codes issue@ mints the requested number of codes, @@ -1921,6 +2005,11 @@ testBadgeServiceCodesIssueRevokeStatus ps@TestParams {tmpPath} = do -- 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")) + -- positive control FIRST: the batch label is stored in the clear and must be found in these + -- bytes. Without it every assertion below is an absence, and an absence passes for the wrong + -- reason the day the rows move to another file, the file is renamed, or the scan reads a + -- database that was never written to. + (testCodeBatch, encodeUtf8 testCodeBatch `BS.isInfixOf` dbBytes) `shouldBe` (testCodeBatch, True) forM_ issued $ \code -> do (code, encodeUtf8 code `BS.isInfixOf` dbBytes) `shouldBe` (code, False) (code, encodeUtf8 (Codes.normalizeCode code) `BS.isInfixOf` dbBytes) `shouldBe` (code, False)