From 89e10958429a4b7e58f94a80f5806dbf8bf4f97c Mon Sep 17 00:00:00 2001 From: shum Date: Sat, 22 Aug 2026 14:39:06 +0000 Subject: [PATCH] core: guard badge offer totals and item status encoding --- .../src/BadgeService/Catalog.hs | 48 +++++++++++++------ .../src/BadgeService/Service.hs | 5 +- src/Simplex/Chat/Badges/Types.hs | 30 ++++++++++-- tests/Bots/BadgeServiceTests.hs | 41 +++++++++++++++- 4 files changed, 103 insertions(+), 21 deletions(-) diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs index cc063fdeb4..60def2a9e1 100644 --- a/apps/simplex-badge-service/src/BadgeService/Catalog.hs +++ b/apps/simplex-badge-service/src/BadgeService/Catalog.hs @@ -15,8 +15,10 @@ module BadgeService.Catalog ) where +import Control.Exception (evaluate) +import Control.Monad (void) import Data.List (find) -import Data.Text (Text) +import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Word (Word8) import Simplex.Chat.Badges (BadgeType (..)) @@ -129,11 +131,26 @@ defaultCatalog createdAt = offerTotal :: BadgePrice -> Maybe BadgeOffer -> CurrencyAmount offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} Nothing = CurrencyAmount monthPriceMinor -offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} (Just BadgeOffer {months, discount}) = +offerTotal BadgePrice {monthPrice = CurrencyAmount monthPriceMinor} (Just offer@BadgeOffer {months, discount}) = CurrencyAmount $ case discount of - ODFreeMonths freeMonths -> fromIntegral (months - freeMonths) * monthPriceMinor + ODFreeMonths freeMonths -> fromIntegral (chargeableMonths offer months freeMonths) * monthPriceMinor ODDiscount percent -> (fromIntegral months * monthPriceMinor * fromIntegral (100 - percent)) `div` 100 +-- | months - freeMonths, but only once it's known safe: a bare 'Word8' subtraction is +-- unsigned and unguarded, so an offer seeded with freeMonths >= months (a typo, a future +-- repricing, operator tooling) would silently wrap (3 - 12 :: Word8 == 247) and this +-- money-computing module would hand out a wildly wrong charge without any sign anything +-- went wrong. freeMonths >= months isn't a value to compute a (wrong) answer for at all — +-- it charges for zero or a negative number of months, which isn't an offer — so this fails +-- loudly and by name instead of ever reaching the subtraction. +chargeableMonths :: BadgeOffer -> Word8 -> Word8 -> Word8 +chargeableMonths BadgeOffer {offerId = BadgeOfferId oid} months freeMonths + | freeMonths >= months = + error $ + "offerTotal: offer " <> T.unpack oid <> " has freeMonths (" <> show freeMonths + <> ") >= months (" <> show months <> "), which is not a chargeable offer" + | otherwise = months - freeMonths + -- | 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, @@ -152,13 +169,23 @@ catalogTotals BadgeCatalog {prices, offers} = -- 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. +-- +-- Validates every offer's total before writing anything: 'catalogTotals' forces +-- 'chargeableMonths'' guard for each offer, so a catalog with a bad offer (freeMonths >= +-- months) fails the service at startup, by name, instead of persisting a row that would +-- only misprice a purchase later. seedCatalog :: DBStore -> IO () seedCatalog st = do createdAt <- getCurrentTime - let BadgeCatalog {prices, offers} = defaultCatalog createdAt + let catalog@BadgeCatalog {prices, offers} = defaultCatalog createdAt + BadgeCatalog {offers = pricedOffers} = catalogTotals catalog + mapM_ forceTotal pricedOffers withTransaction st $ \db -> do mapM_ (insertPrice db) prices mapM_ (insertOffer db) offers + where + forceTotal BadgeOffer {total = Just (CurrencyAmount amount)} = void $ evaluate amount + forceTotal BadgeOffer {total = Nothing} = pure () insertPrice :: DB.Connection -> BadgePrice -> IO () insertPrice db BadgePrice {priceId = BadgePriceId pid, badgeType, monthPrice = CurrencyAmount amt, currency, status, createdAt} = @@ -166,7 +193,7 @@ insertPrice db BadgePrice {priceId = BadgePriceId pid, badgeType, monthPrice = C 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) + (pid, textEncode badgeType, amt, currency, textEncode status, createdAt) insertOffer :: DB.Connection -> BadgeOffer -> IO () insertOffer db BadgeOffer {offerId = BadgeOfferId oid, priceId, months, discount, status, createdAt} = @@ -174,18 +201,9 @@ insertOffer db BadgeOffer {offerId = BadgeOfferId oid, priceId, months, discount 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) + (oid, unBadgePriceId <$> priceId, months, freeMonthsColumn, discountColumn, textEncode 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 ce670429af..6aaedf836e 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -97,8 +97,9 @@ processQueuedRequests env = do 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. +-- of the service must see the catalog before it can serve a request. B8's operator +-- subcommand (not yet implemented) will need to call seedCatalog the same way, so operator +-- tooling sees the same catalog. badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO () badgePreStartHook opts ChatController {config, chatStore} = do runBadgeServiceMigrations opts config chatStore diff --git a/src/Simplex/Chat/Badges/Types.hs b/src/Simplex/Chat/Badges/Types.hs index 8a88456a69..b0885a8244 100644 --- a/src/Simplex/Chat/Badges/Types.hs +++ b/src/Simplex/Chat/Badges/Types.hs @@ -39,7 +39,7 @@ import Simplex.Messaging.Agent.Protocol (UserId) import Simplex.Messaging.Agent.Store.DB (fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON) +import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON) #if defined(dbPostgres) import Database.PostgreSQL.Simple.FromField (FromField (..)) import Database.PostgreSQL.Simple.ToField (ToField (..)) @@ -187,6 +187,32 @@ data UserBadgeState = UserBadgeState alert :: Maybe BadgeAlert } +-- BadgeItemStatus crosses both the wire (BadgePrice/BadgeOffer JSON) and the +-- badge_prices/badge_offers.status columns (A4's seedCatalog); TextEncoding is the single +-- spelling both ToJSON/FromJSON and ToField/FromField derive from, so the two can't drift +-- into two independent encodings of the same enum. +instance TextEncoding BadgeItemStatus where + textEncode = \case + BISActive -> "active" + BISDeprecated -> "deprecated" + BISDisabled -> "disabled" + textDecode s = case s of + "active" -> Just BISActive + "deprecated" -> Just BISDeprecated + "disabled" -> Just BISDisabled + _ -> Nothing + +instance ToJSON BadgeItemStatus where + toJSON = textToJSON + toEncoding = textToEncoding + +instance FromJSON BadgeItemStatus where + parseJSON = textParseJSON "BadgeItemStatus" + +instance ToField BadgeItemStatus where toField = toField . textEncode + +instance FromField BadgeItemStatus where fromField = fromTextField_ textDecode + -- DB column spelling for BadgePurchaseStatus: the type does not cross the wire, so this spelling -- is only ever read back from the badge_purchases.status column it was written to. The payment -- statuses of the same rows are PaymentService.Types' InvoiceStatus and PaymentStatus, which @@ -217,6 +243,4 @@ instance FromField BadgePurchaseStatus where fromField = fromTextField_ textDeco -- JSON -$(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus) - $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount) diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 594cb03bbd..6a9ca1476d 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -12,14 +12,17 @@ import ChatClient import ChatTests.DBUtils import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) -import Control.Exception (SomeException, finally, try) +import Control.Exception (SomeException, evaluate, finally, try) +import qualified Data.Aeson as J import Data.List (find) 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 (BadgeType (..)) import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..)) +import Simplex.Chat.Badges.Types (BadgeItemStatus (..), BadgeOfferId (..), OfferDiscount (..)) import Simplex.Chat.Controller (ChatConfig) import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB @@ -48,6 +51,8 @@ badgeServiceTests = do 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 + it "should reject an offer with freeMonths >= months instead of wrapping" testBadgeCatalogOfferTotalRejectsBadFreeMonths + it "should encode BadgeItemStatus on the wire as active/deprecated/disabled" testBadgeItemStatusJsonWireFormat 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} @@ -194,6 +199,40 @@ testBadgeCatalogTotalsFillsSeededOffers _ps = do length offers `shouldBe` 4 all (\BadgeOffer {total} -> isJust total) offers `shouldBe` True +-- A Word8 subtraction of freeMonths from months is unsigned and unguarded: an offer with +-- freeMonths >= months (a typo, a future repricing) would wrap silently +-- (3 - 12 :: Word8 == 247) and hand out a wildly wrong charge. offerTotal must instead fail +-- loudly, naming the offer, before it ever reaches that subtraction. +testBadgeCatalogOfferTotalRejectsBadFreeMonths :: HasCallStack => TestParams -> IO () +testBadgeCatalogOfferTotalRejectsBadFreeMonths _ps = do + now <- getCurrentTime + let BadgeCatalog {prices} = defaultCatalog now + price@BadgePrice {priceId} = fromJust $ find (\BadgePrice {badgeType} -> badgeType == BTSupporter) prices + badOffer = + BadgeOffer + { offerId = BadgeOfferId "test-bad-offer-freeMonths-ge-months", + priceId = Just priceId, + months = 3, + discount = ODFreeMonths 12, + status = BISActive, + createdAt = now, + total = Nothing + } + result <- try (evaluate (offerTotal price (Just badOffer))) :: IO (Either SomeException CurrencyAmount) + case result of + Left _ -> pure () + Right (CurrencyAmount total) -> + expectationFailure $ "offerTotal should reject freeMonths >= months, got: " <> show total + +-- BadgeItemStatus's JSON crosses the wire (BadgePrice/BadgeOffer.status), so pinning finding +-- 2's TextEncoding-derived encoding to what the earlier TH-derived instance produced proves +-- the change is invisible on the wire, not just asserted to be. +testBadgeItemStatusJsonWireFormat :: HasCallStack => TestParams -> IO () +testBadgeItemStatusJsonWireFormat _ps = do + J.encode BISActive `shouldBe` "\"active\"" + J.encode BISDeprecated `shouldBe` "\"deprecated\"" + J.encode BISDisabled `shouldBe` "\"disabled\"" + #if defined(dbPostgres) runMigrationsToRun :: DBStore -> MigrationsToRun -> IO () runMigrationsToRun st = Migrations.run st Nothing