core: badge service web order schema

apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs

@@ -17,7 +17,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations
 
 schemaMigrations :: [(String, Text, Maybe Text)]
 schemaMigrations =
-  [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema)
+  [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema),
+    ("20260821_badge_service_web", m20260821_badge_service_web, Just down_m20260821_badge_service_web)
   ]
 
 -- the client tables are in the same database, so the service tables are the same names with this prefix
@@ -35,3 +36,76 @@ ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA;
 
 down_m20260806_badge_service_schema :: Text
 down_m20260806_badge_service_schema = badgeSchemaDown servicePrefix
+
+m20260821_badge_service_web :: Text
+m20260821_badge_service_web =
+  withPrefix
+    servicePrefix
+    [r|
+CREATE TABLE @web_orders(
+  order_id TEXT NOT NULL PRIMARY KEY,   -- 128-bit random, base64url; a bearer capability, see E4
+  invoice_id TEXT REFERENCES @invoices, -- money side reuses the existing invoices table
+  -- provider invoice / session / payment-intent id; order-side only, never a code or purchase
+  -- reference. Unique across providers: a collision must fail loudly rather than resolve a
+  -- charge to the wrong order.
+  provider_ref TEXT,
+  method TEXT NOT NULL CHECK (method IN ('card','btc','xmr')),
+  short_ref TEXT NOT NULL,              -- 5 Crockford chars, generated per order (D6); the reference
+                                        -- support resolves by, shown on card statements (F1) and on
+                                        -- the crypto payment and result screens (E5, E6)
+  badge_type TEXT NOT NULL CHECK (badge_type IN ('supporter','legend')),
+  price_id TEXT REFERENCES @badge_prices,
+  offer_id TEXT REFERENCES @badge_offers,
+  months SMALLINT NOT NULL,
+  -- invoiced (created, unpaid) -> pending (partial or unconfirmed) -> paid (terminal).
+  -- invoiced|pending -> expired|failed; both remain recoverable to paid (E3).
+  status TEXT NOT NULL CHECK (status IN ('invoiced','pending','paid','expired','failed')),
+  -- amount received, in minor units of the invoice currency, at the rate the provider locked
+  amount_paid BIGINT,
+  settled_at TIMESTAMPTZ,
+  created_at TIMESTAMPTZ NOT NULL,
+  updated_at TIMESTAMPTZ NOT NULL
+);
+
+CREATE INDEX @idx_web_orders_invoice ON @web_orders(invoice_id);
+
+CREATE UNIQUE INDEX @idx_web_orders_provider_ref ON @web_orders(provider_ref);
+
+CREATE UNIQUE INDEX @idx_web_orders_short_ref ON @web_orders(short_ref);
+
+-- No order reference, and no code_hash on @web_orders: no row may hold both an order
+-- reference and a purchase reference (§3 Linkage). An order's code row is found by
+-- deriving the code from orderId and hashing it.
+CREATE TABLE @codes(
+  code_hash BYTEA NOT NULL PRIMARY KEY,
+  badge_type TEXT NOT NULL CHECK (badge_type IN ('supporter','legend')),
+  months SMALLINT NOT NULL CHECK (months > 0), -- lifetime codes are out of scope, see §6
+  batch TEXT NOT NULL,                  -- 'web' for web orders, else an operator batch name
+  expires_at TIMESTAMPTZ NOT NULL,             -- redemption deadline -> code_expired
+  redeemed_purchase_id BIGINT REFERENCES @badge_purchases,
+  redeemed_at TIMESTAMPTZ,
+  unredeemed_at TIMESTAMPTZ,                   -- set by B1's unredeemCode; reopens E4's window
+  revoked_at TIMESTAMPTZ,
+  created_at TIMESTAMPTZ NOT NULL
+);
+
+CREATE INDEX @idx_codes_batch ON @codes(batch);
+
+CREATE TABLE @provider_events(
+  provider TEXT NOT NULL,
+  event_id TEXT NOT NULL,
+  received_at TIMESTAMPTZ NOT NULL,
+  processed_at TIMESTAMPTZ,                    -- NULL means the previous attempt did not complete (E3)
+  PRIMARY KEY(provider, event_id)
+);
+|]
+
+down_m20260821_badge_service_web :: Text
+down_m20260821_badge_service_web =
+  withPrefix
+    servicePrefix
+    [r|
+DROP TABLE @provider_events;
+DROP TABLE @codes;
+DROP TABLE @web_orders;
+|]

apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs

@@ -18,7 +18,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations
 
 schemaMigrations :: [(String, Query, Maybe Query)]
 schemaMigrations =
-  [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema)
+  [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema),
+    ("20260821_badge_service_web", m20260821_badge_service_web, Just down_m20260821_badge_service_web)
   ]
 
 -- the client tables are in the same database, so the service tables are the same names with this prefix
@@ -36,3 +37,76 @@ ALTER TABLE @payments ADD COLUMN receipt_hash BLOB;
 
 down_m20260806_badge_service_schema :: Query
 down_m20260806_badge_service_schema = badgeSchemaDown servicePrefix
+
+m20260821_badge_service_web :: Query
+m20260821_badge_service_web =
+  withPrefix
+    servicePrefix
+    [sql|
+CREATE TABLE @web_orders(
+  order_id TEXT NOT NULL PRIMARY KEY,   -- 128-bit random, base64url; a bearer capability, see E4
+  invoice_id TEXT REFERENCES @invoices, -- money side reuses the existing invoices table
+  -- provider invoice / session / payment-intent id; order-side only, never a code or purchase
+  -- reference. Unique across providers: a collision must fail loudly rather than resolve a
+  -- charge to the wrong order.
+  provider_ref TEXT,
+  method TEXT NOT NULL CHECK (method IN ('card','btc','xmr')),
+  short_ref TEXT NOT NULL,              -- 5 Crockford chars, generated per order (D6); the reference
+                                        -- support resolves by, shown on card statements (F1) and on
+                                        -- the crypto payment and result screens (E5, E6)
+  badge_type TEXT NOT NULL CHECK (badge_type IN ('supporter','legend')),
+  price_id TEXT REFERENCES @badge_prices,
+  offer_id TEXT REFERENCES @badge_offers,
+  months INTEGER NOT NULL,
+  -- invoiced (created, unpaid) -> pending (partial or unconfirmed) -> paid (terminal).
+  -- invoiced|pending -> expired|failed; both remain recoverable to paid (E3).
+  status TEXT NOT NULL CHECK (status IN ('invoiced','pending','paid','expired','failed')),
+  -- amount received, in minor units of the invoice currency, at the rate the provider locked
+  amount_paid INTEGER,
+  settled_at TEXT,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL
+) STRICT;
+
+CREATE INDEX @idx_web_orders_invoice ON @web_orders(invoice_id);
+
+CREATE UNIQUE INDEX @idx_web_orders_provider_ref ON @web_orders(provider_ref);
+
+CREATE UNIQUE INDEX @idx_web_orders_short_ref ON @web_orders(short_ref);
+
+-- No order reference, and no code_hash on @web_orders: no row may hold both an order
+-- reference and a purchase reference (§3 Linkage). An order's code row is found by
+-- deriving the code from orderId and hashing it.
+CREATE TABLE @codes(
+  code_hash BLOB NOT NULL PRIMARY KEY,
+  badge_type TEXT NOT NULL CHECK (badge_type IN ('supporter','legend')),
+  months INTEGER NOT NULL CHECK (months > 0), -- lifetime codes are out of scope, see §6
+  batch TEXT NOT NULL,                  -- 'web' for web orders, else an operator batch name
+  expires_at TEXT NOT NULL,             -- redemption deadline -> code_expired
+  redeemed_purchase_id INTEGER REFERENCES @badge_purchases,
+  redeemed_at TEXT,
+  unredeemed_at TEXT,                   -- set by B1's unredeemCode; reopens E4's window
+  revoked_at TEXT,
+  created_at TEXT NOT NULL
+) STRICT;
+
+CREATE INDEX @idx_codes_batch ON @codes(batch);
+
+CREATE TABLE @provider_events(
+  provider TEXT NOT NULL,
+  event_id TEXT NOT NULL,
+  received_at TEXT NOT NULL,
+  processed_at TEXT,                    -- NULL means the previous attempt did not complete (E3)
+  PRIMARY KEY(provider, event_id)
+) STRICT;
+|]
+
+down_m20260821_badge_service_web :: Query
+down_m20260821_badge_service_web =
+  withPrefix
+    servicePrefix
+    [sql|
+DROP TABLE @provider_events;
+DROP TABLE @codes;
+DROP TABLE @web_orders;
+|]

plans/2026-08-21-badges-web-checkout.md

@@ -129,7 +129,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat
 |---|---|---|---|
 | A1 | Register the client badge migration, add `STRICT` | — | ☑ |
 | A2 | JSON instances for badge protocol types, and the offer `total` | — | ☑ |
-| A3 | Service schema: `web_orders`, `codes`, `provider_events` | — | ☐ |
+| A3 | Service schema: `web_orders`, `codes`, `provider_events` | — | ☑ |
 | A4 | `Catalog.hs`: internal pricing, totals, seeding | A2, A5 | ☐ |
 | A5 | Cabal dependencies for the service | — | ☐ |
 | A6 | `badge_service.ini`: configuration file | A3, A4, A5 | ☐ |

tests/Bots/BadgeServiceTests.hs

@@ -10,17 +10,34 @@ import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
-import Control.Exception (finally)
+import Control.Exception (SomeException, finally, try)
+import Data.List (find)
+import Data.Maybe (fromJust)
+import Data.String (fromString)
 import Simplex.Chat.Controller (ChatConfig)
 import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
 import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
+import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Agent.Store.Interface (closeDBStore, createDBStore)
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
 import System.FilePath ((</>))
 import Test.Hspec hiding (it)
+#if defined(dbPostgres)
+import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations)
+import Database.PostgreSQL.Simple (Only (..))
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
+#else
+import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations)
+import Database.SQLite.Simple (Only (..))
+import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
+#endif
 
 badgeServiceTests :: SpecWith TestParams
 badgeServiceTests = do
   it "should respond with unsupported_version to redeem" testBadgeServiceRedeemUnsupported
+  it "should migrate web_orders, codes and provider_events up and down" testBadgeServiceWebOrderSchemaMigration
 
 badgeProfile :: Profile
 badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing}
@@ -79,3 +96,41 @@ testBadgeServiceRedeemUnsupported ps =
           "{\"version\":1,\"request\":{\"type\":\"purchaseBadge\",\"payment\":{\"type\":\"code\",\"code\":\"TEST-CODE\"}}}"
     client ##> ("/_service_request 1 " <> bsLink <> " " <> redeemReq)
     client <## "service response: {\"code\":\"unsupported_version\",\"type\":\"error\"}"
+
+-- Applies every migration except 20260821_badge_service_web, then exercises that one
+-- migration's up/down/up cycle directly, checking the three new tables appear and
+-- disappear as expected.
+testBadgeServiceWebOrderSchemaMigration :: HasCallStack => TestParams -> IO ()
+testBadgeServiceWebOrderSchemaMigration ps = do
+  let dbOpts = toDBOpts (dbOptions $ coreOptions $ mkBadgeServiceOpts ps) chatSuffix False chatDBFunctions
+      priorMigrations = filter ((/= migrationName) . name) badgeServiceSchemaMigrations
+      webOrderMigration = fromJust $ find ((== migrationName) . name) badgeServiceSchemaMigrations
+      downMigration = fromJust $ toDownMigration webOrderMigration
+  Right st <- createDBStore dbOpts priorMigrations (MigrationConfig MCError Nothing)
+  mapM_ (assertTableMissing st) newTables
+  runMigrationsToRun st $ MTRUp [webOrderMigration]
+  mapM_ (assertTableExists st) newTables
+  runMigrationsToRun st $ MTRDown [downMigration]
+  mapM_ (assertTableMissing st) newTables
+  runMigrationsToRun st $ MTRUp [webOrderMigration]
+  mapM_ (assertTableExists st) newTables
+  closeDBStore st
+  where
+    migrationName = "20260821_badge_service_web"
+    newTables = ["sx_badge_service_web_orders", "sx_badge_service_codes", "sx_badge_service_provider_events"]
+    assertTableExists st tbl =
+      withConnection st (\db -> DB.query_ db (tableCountQuery tbl)) `shouldReturn` [Only (0 :: Int)]
+    assertTableMissing st tbl = do
+      r <- try (withConnection st (\db -> DB.query_ db (tableCountQuery tbl))) :: IO (Either SomeException [Only Int])
+      case r of
+        Left _ -> pure ()
+        Right rows -> expectationFailure $ tbl <> " should not exist after down migration, got: " <> show rows
+    tableCountQuery tbl = fromString ("SELECT count(*) FROM " <> tbl)
+
+#if defined(dbPostgres)
+runMigrationsToRun :: DBStore -> MigrationsToRun -> IO ()
+runMigrationsToRun st = Migrations.run st Nothing
+#else
+runMigrationsToRun :: DBStore -> MigrationsToRun -> IO ()
+runMigrationsToRun st = Migrations.run st Nothing True
+#endif