diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs new file mode 100644 index 0000000000..cc063fdeb4 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Catalog.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The single source of badge pricing (decision 8): the default catalog values, the one +-- function that turns a price and an offer into a total, and idempotent seeding into the +-- badge service's own database. No other module computes a total; every response that +-- leaves the service (B6's RPC, D4's /api/catalog) must go through 'catalogTotals'. +module BadgeService.Catalog + ( defaultCatalog, + offerTotal, + catalogTotals, + seedCatalog, + ) +where + +import Data.List (find) +import Data.Text (Text) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Word (Word8) +import Simplex.Chat.Badges (BadgeType (..)) +import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..)) +import Simplex.Chat.Badges.Types (BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..)) +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Encoding.String (textEncode) + +-- Prices and offers are seeded by literal id so re-seeding is idempotent: a fresh restart +-- inserts the same rows it always did instead of minting new ones every time. + +supporterPriceId :: BadgePriceId +supporterPriceId = BadgePriceId "2170da16-66e5-481f-9c75-6949e2dd14e1" + +legendPriceId :: BadgePriceId +legendPriceId = BadgePriceId "6a778279-753e-45db-8acc-0e382c1d054a" + +supporter3MonthsOfferId :: BadgeOfferId +supporter3MonthsOfferId = BadgeOfferId "29e35444-2f85-43fb-8933-16875e6d3776" + +supporter12MonthsOfferId :: BadgeOfferId +supporter12MonthsOfferId = BadgeOfferId "71bd8ad1-15c4-4735-b3d4-b12a670dfb7e" + +legend3MonthsOfferId :: BadgeOfferId +legend3MonthsOfferId = BadgeOfferId "88885a0a-c407-4aaa-bf53-90f9de7bdfc0" + +legend12MonthsOfferId :: BadgeOfferId +legend12MonthsOfferId = BadgeOfferId "35ca9daa-4dca-4cc1-af74-631674906cc9" + +-- | The default catalog: two prices (UX §1: supporter $7/month, legend $70/month) and four +-- offers pinned to them, one per badge type and duration (UX §6.12's 1x / 2x / 6x monthly +-- pricing). One month has no offer and is priced at 'monthPrice' (core §4). The 3-month +-- offer is 'ODFreeMonths' 1, never 'ODDiscount': at a 700 minor-unit monthly price, the +-- required 1400 total sits strictly between 'ODDiscount' 33 (1407) and 'ODDiscount' 34 +-- (1386), so no 'Word8' percent can express it. +defaultCatalog :: UTCTime -> BadgeCatalog +defaultCatalog createdAt = + BadgeCatalog + { prices = [supporterPrice, legendPrice], + offers = [supporter3Months, supporter12Months, legend3Months, legend12Months] + } + where + supporterPrice = + BadgePrice + { priceId = supporterPriceId, + badgeType = BTSupporter, + monthPrice = CurrencyAmount 700, + currency = "usd", + status = BISActive, + createdAt + } + legendPrice = + BadgePrice + { priceId = legendPriceId, + badgeType = BTLegend, + monthPrice = CurrencyAmount 7000, + currency = "usd", + status = BISActive, + createdAt + } + supporter3Months = + BadgeOffer + { offerId = supporter3MonthsOfferId, + priceId = Just supporterPriceId, + months = 3, + discount = ODFreeMonths 1, + status = BISActive, + createdAt, + total = Nothing + } + supporter12Months = + BadgeOffer + { offerId = supporter12MonthsOfferId, + priceId = Just supporterPriceId, + months = 12, + discount = ODFreeMonths 6, + status = BISActive, + createdAt, + total = Nothing + } + legend3Months = + BadgeOffer + { offerId = legend3MonthsOfferId, + priceId = Just legendPriceId, + months = 3, + discount = ODFreeMonths 1, + status = BISActive, + createdAt, + total = Nothing + } + legend12Months = + BadgeOffer + { offerId = legend12MonthsOfferId, + priceId = Just legendPriceId, + months = 12, + discount = ODFreeMonths 6, + status = BISActive, + createdAt, + total = Nothing + } + +-- | The only place a total is computed. 'CurrencyAmount' has no 'Num' instance, so every +-- step unwraps to 'Word32', computes, and re-wraps. 'Nothing' means exactly one month +-- (there is no unpriced multi-month path: a longer duration is only ever expressed as an +-- offer). A 'freeMonths' offer charges for the months that aren't free; an 'ODDiscount' +-- offer floors the discounted total, computed over integers so no floating point appears +-- anywhere in the pricing path. +offerTotal :: BadgePrice -> Maybe BadgeOffer -> CurrencyAmount +offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} Nothing = + CurrencyAmount monthPriceMinor +offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} (Just BadgeOffer {months, discount}) = + CurrencyAmount $ case discount of + ODFreeMonths freeMonths -> fromIntegral (months - freeMonths) * monthPriceMinor + ODDiscount percent -> (fromIntegral months * monthPriceMinor * fromIntegral (100 - percent)) `div` 100 + +-- | Fills every offer's 'total' (A2) with 'offerTotal' applied to that offer's pinned +-- price. Overwrites unconditionally, so it is idempotent to call again. It is a total +-- function: an offer whose price isn't found in the given catalog (which shouldn't happen, +-- relying on B1's invariant that every returned offer's pinned price is also returned) gets +-- 'total = Nothing' rather than a crash, same as an unpinned offer. +catalogTotals :: BadgeCatalog -> BadgeCatalog +catalogTotals BadgeCatalog {prices, offers} = + BadgeCatalog {prices, offers = map fillTotal offers} + where + fillTotal offer@BadgeOffer {priceId} = + offer {total = offerTotal <$> pricedBy priceId <*> pure (Just offer)} + pricedBy Nothing = Nothing + pricedBy (Just pid) = find (\BadgePrice {priceId = pid'} -> pid' == pid) prices + +-- | Inserts the default catalog's prices and offers, by literal id, into the badge +-- service's own tables. Never updates or deletes an existing row: repricing appends a new +-- price and deprecates the old one (UX §3) via B1's 'setPriceStatus', not a seed edit, so a +-- price deprecated out from under a re-seed stays deprecated. +seedCatalog :: DBStore -> IO () +seedCatalog st = do + createdAt <- getCurrentTime + let BadgeCatalog {prices, offers} = defaultCatalog createdAt + withTransaction st $ \db -> do + mapM_ (insertPrice db) prices + mapM_ (insertOffer db) offers + +insertPrice :: DB.Connection -> BadgePrice -> IO () +insertPrice db BadgePrice {priceId = BadgePriceId pid, badgeType, monthPrice = CurrencyAmount amt, currency, status, createdAt} = + DB.execute + db + "INSERT INTO sx_badge_service_badge_prices (price_id, badge_type, month_price, currency, status, created_at) \ + \VALUES (?,?,?,?,?,?) ON CONFLICT (price_id) DO NOTHING" + (pid, textEncode badgeType, amt, currency, itemStatusText status, createdAt) + +insertOffer :: DB.Connection -> BadgeOffer -> IO () +insertOffer db BadgeOffer {offerId = BadgeOfferId oid, priceId, months, discount, status, createdAt} = + DB.execute + db + "INSERT INTO sx_badge_service_badge_offers (offer_id, price_id, months, free_months, discount, status, created_at) \ + \VALUES (?,?,?,?,?,?,?) ON CONFLICT (offer_id) DO NOTHING" + (oid, unBadgePriceId <$> priceId, months, freeMonthsColumn, discountColumn, itemStatusText status, createdAt) + where + unBadgePriceId (BadgePriceId pid) = pid + (freeMonthsColumn, discountColumn) = case discount of + ODFreeMonths freeMonths -> (Just freeMonths, Nothing :: Maybe Word8) + ODDiscount percent -> (Nothing :: Maybe Word8, Just percent) + +-- Not a TextEncoding instance: BadgeItemStatus has no wire representation of its own +-- outside JSON (see Badges/Types.hs), and this spelling only ever round-trips through the +-- column it is written to. +itemStatusText :: BadgeItemStatus -> Text +itemStatusText = \case + BISActive -> "active" + BISDeprecated -> "deprecated" + BISDisabled -> "disabled" diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 64e934872e..ce670429af 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -10,6 +10,7 @@ module BadgeService.Service ) where +import BadgeService.Catalog (seedCatalog) import BadgeService.Options import BadgeService.Store.Migrate (runBadgeServiceMigrations) import Control.Concurrent.STM @@ -95,9 +96,13 @@ processQueuedRequests env = do (u, reqId, reqData) <- atomically $ readTQueue $ serviceRequestQ env handleServiceRequest cc u reqId reqData +-- Seeded here, after migrations and before badgePostStartHook starts the bot: every start +-- of the service (and B8's operator subcommand, which calls seedCatalog the same way) must +-- see the catalog before it can serve a request. badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO () -badgePreStartHook opts ChatController {config, chatStore} = +badgePreStartHook opts ChatController {config, chatStore} = do runBadgeServiceMigrations opts config chatStore + seedCatalog chatStore badgePostStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do diff --git a/plans/2026-08-21-badges-web-checkout.md b/plans/2026-08-21-badges-web-checkout.md index 3c57f8b6c9..a8861782d7 100644 --- a/plans/2026-08-21-badges-web-checkout.md +++ b/plans/2026-08-21-badges-web-checkout.md @@ -130,7 +130,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` | — | ☑ | -| A4 | `Catalog.hs`: internal pricing, totals, seeding | A2, A5 | ☐ | +| A4 | `Catalog.hs`: internal pricing, totals, seeding | A2, A5 | ☑ | | A5 | Cabal dependencies for the service | — | ☑ | | A6 | `badge_service.ini`: configuration file | A3, A4, A5 | ☐ | | B1 | Store layer: purchases, ledger, issuances, codes, catalog | A2, A3, A4, A5 | ☐ | diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 1c8b5e57e3..74dc346a6a 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -416,6 +416,7 @@ executable simplex-badge-service default-extensions: StrictData other-modules: + BadgeService.Catalog BadgeService.Options BadgeService.Service BadgeService.Store.Migrate @@ -691,6 +692,7 @@ test-suite simplex-chat-test API.Docs.Syntax.Types API.Docs.Types API.TypeInfo + BadgeService.Catalog BadgeService.Options BadgeService.Service BadgeService.Store.Migrate diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 69ecae717b..594cb03bbd 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Bots.BadgeServiceTests where +import BadgeService.Catalog (catalogTotals, defaultCatalog, offerTotal, seedCatalog) import BadgeService.Options import BadgeService.Service import ChatClient @@ -12,11 +14,16 @@ import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (SomeException, finally, try) import Data.List (find) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, isJust) import Data.String (fromString) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Data.Word (Word32) +import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..)) import Simplex.Chat.Controller (ChatConfig) import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) import Simplex.Chat.Types (ChatPeerType (..), Profile (..)) import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -38,6 +45,9 @@ 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 + it "should seed the catalog idempotently and preserve a deprecated price" testBadgeServiceCatalogSeeding + it "should price 3 months at 2x and 12 months at 6x the monthly price" testBadgeCatalogOfferTotal + it "should fill total for every seeded offer" testBadgeCatalogTotalsFillsSeededOffers 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} @@ -127,6 +137,63 @@ testBadgeServiceWebOrderSchemaMigration ps = do Right rows -> expectationFailure $ tbl <> " should not exist after down migration, got: " <> show rows tableCountQuery tbl = fromString ("SELECT count(*) FROM " <> tbl) +-- Seeds a fresh database, seeds again, and asserts price/offer row counts are unchanged; +-- then deprecates one price directly with SQL (B1's setPriceStatus doesn't exist yet) and +-- asserts a further re-seed leaves it deprecated rather than reviving it. +testBadgeServiceCatalogSeeding :: HasCallStack => TestParams -> IO () +testBadgeServiceCatalogSeeding ps = do + let dbOpts = toDBOpts (dbOptions $ coreOptions $ mkBadgeServiceOpts ps) chatSuffix False chatDBFunctions + Right st <- createDBStore dbOpts badgeServiceSchemaMigrations (MigrationConfig MCError Nothing) + seedCatalog st + pricesAfterFirstSeed <- rowCount st "sx_badge_service_badge_prices" + offersAfterFirstSeed <- rowCount st "sx_badge_service_badge_offers" + pricesAfterFirstSeed `shouldBe` 2 + offersAfterFirstSeed `shouldBe` 4 + [Only deprecatedPriceId] <- + withConnection st (\db -> DB.query_ db "SELECT price_id FROM sx_badge_service_badge_prices LIMIT 1") :: IO [Only Text] + withConnection + st + (\db -> DB.execute db "UPDATE sx_badge_service_badge_prices SET status = 'deprecated' WHERE price_id = ?" (Only deprecatedPriceId)) + seedCatalog st + pricesAfterSecondSeed <- rowCount st "sx_badge_service_badge_prices" + offersAfterSecondSeed <- rowCount st "sx_badge_service_badge_offers" + pricesAfterSecondSeed `shouldBe` pricesAfterFirstSeed + offersAfterSecondSeed `shouldBe` offersAfterFirstSeed + [Only statusAfterReseed] <- + withConnection st (\db -> DB.query db "SELECT status FROM sx_badge_service_badge_prices WHERE price_id = ?" (Only deprecatedPriceId)) :: IO [Only Text] + statusAfterReseed `shouldBe` "deprecated" + closeDBStore st + where + rowCount :: DBStore -> String -> IO Int + rowCount st tbl = do + [Only n] <- withConnection st (\db -> DB.query_ db (fromString ("SELECT count(*) FROM " <> tbl))) + pure n + +-- offerTotal must price 3 months at exactly 2x the monthly price and 12 months at exactly +-- 6x, for both badge types (UX §6.12). +testBadgeCatalogOfferTotal :: HasCallStack => TestParams -> IO () +testBadgeCatalogOfferTotal _ps = do + now <- getCurrentTime + let BadgeCatalog {prices, offers} = defaultCatalog now + priceFor pid = fromJust $ find (\BadgePrice {priceId = pid'} -> pid' == pid) prices + mapM_ (assertOfferTotal priceFor) offers + where + assertOfferTotal priceFor offer@BadgeOffer {months, priceId = Just pid} = do + let BadgePrice {monthPrice = CurrencyAmount monthly} = priceFor pid + CurrencyAmount total = offerTotal (priceFor pid) (Just offer) + multiplier = if months == 3 then 2 else 6 :: Word32 + total `shouldBe` monthly * multiplier + assertOfferTotal _ BadgeOffer {priceId = Nothing} = + expectationFailure "seeded offer must be pinned to a price" + +-- catalogTotals must fill total for all four seeded offers. +testBadgeCatalogTotalsFillsSeededOffers :: HasCallStack => TestParams -> IO () +testBadgeCatalogTotalsFillsSeededOffers _ps = do + now <- getCurrentTime + let BadgeCatalog {offers} = catalogTotals (defaultCatalog now) + length offers `shouldBe` 4 + all (\BadgeOffer {total} -> isJust total) offers `shouldBe` True + #if defined(dbPostgres) runMigrationsToRun :: DBStore -> MigrationsToRun -> IO () runMigrationsToRun st = Migrations.run st Nothing