core: guard badge offer totals and item status encoding

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"

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

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)

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