badges: add multi-use codes

tests/Bots/BadgeService/BotTests.hs

@@ -10,10 +10,12 @@
 
 module Bots.BadgeService.BotTests where
 
+import BadgeService.Codes (issueOneCode)
 import BadgeService.Config (BadgeIssuerKey (..), readServiceConfig)
 import Bots.BadgeService.ConfigTests (withIssuer)
 import BadgeService.Options
 import BadgeService.Service
+import BadgeService.Store (IssuedCode (..), getBadgeCode)
 import BadgeService.Store.Invoices (markCodePaid)
 import Simplex.Messaging.Agent.Store.DB (Binary (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
@@ -43,6 +45,7 @@ import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey
 import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode)
 import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, endOfMondayAfter)
 import Simplex.Chat.Badges.Service
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
 import Simplex.Chat.Bot.Store (withDB')
 import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (CRCustomChatResponse))
 import Simplex.Chat.Core (sendChatCmdStr)
@@ -50,7 +53,7 @@ import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
-import Simplex.Messaging.Agent.Store.Common (withTransaction)
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
 import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
 import qualified Simplex.Messaging.Crypto as C
@@ -85,11 +88,16 @@ badgeServiceTests = do
   it "should refuse to start when the [issuer] key is not one clients trust" testIssuerIniKeyMustBeTrusted
   it "should credit a code's months and issue one credential per month" testCodeMonthsRenew
   it "should return the stored credential for a repeat inside an issued period" testRepeatInsideIssuedPeriod
+  it "should redeem a multi-use code to its limit" testMultiUseWithoutGroup
+  it "should not spend a multi-use code again when its holder redeems it after the badge ended" testMultiUseRepeatAfterExpiry
+  it "should answer internal, spending no use, when a holder's stored credential is unreadable" testUnreadableCredentialIsInternal
   it "should lapse only the months that elapsed while the client was away" testLapseWhileAway
   it "should round the last month's expiry up to the end of the Monday after it" testLastMonthExpiryRounds
   it "should sign a renewal with the master key stored on the purchase" testRenewalSignsWithStoredMasterKey
   it "should leave the client holding the same ledger rows as the service" testClientReplicatesLedger
   it "should renew a badge whose credential is lapsing, with no command" testWorkerRenews
+  it "should keep answering and renewing a holder after its partly used multi-use code is revoked" testRevokedMultiUseHolderRenews
+  it "should return a multi-use holder's renewed credential on a repeat, apart from a later holder" testMultiUseHoldersRenewApart
   it "should request from the wake it set a day before the credential lapses" testRequestWakeFires
   it "should present from the wake it set at the credential's expiry" testPresentWakeFires
   it "should renew a badge whose newest ledger row is of an unknown type" testRenewsAfterUnknownEntry
@@ -180,7 +188,9 @@ withBadgeServiceEnv ps test = do
   bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do
     bs <## "subscribed 1 connections on server localhost"
     bs ##> "/sa"
-    (sLink, _) <- getContactLinks bs False
+    -- getContactLinks gives the old-clients line only half a second, which a loaded run can miss.
+    sLink <- getContactLink_ bs False
+    bs <##. "The contact link for old clients: "
     bs <## "auto_accept off"
     pure sLink
   let clientCfg =
@@ -387,6 +397,17 @@ credentialOf = \case
   BSPBadgeCredential {credential} -> credential
   r -> error $ "expected badgeCredential, got " <> show (J.toJSON r)
 
+shouldAnswerError :: HasCallStack => BadgeServiceResponse -> BadgeServiceErrorCode -> IO ()
+shouldAnswerError r expected = case r of
+  BSPError {code = ec} -> ec `shouldBe` expected
+  _ -> expectationFailure $ "expected " <> show expected <> ", got: " <> show (J.toJSON r)
+
+codeCounts :: DBStore -> ByteString -> IO (Maybe (Int, Int))
+codeCounts st codeHash = fmap (\IssuedCode {redeemLimit, redeemCount} -> (redeemLimit, redeemCount)) <$> withTransaction st (`getBadgeCode` codeHash)
+
+codeUses :: ChatController -> BadgeCode -> IO (Maybe (Int, Int))
+codeUses cc code = codeCounts (chatStore cc) (badgeCodeHash code)
+
 nextDue :: [StatementEntry] -> UTCTime
 nextDue entries = let (_, _, start) = entryOf (last entries) in start
 
@@ -396,6 +417,12 @@ newPurchaseKeys = do
   (purchaseKey, _) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
   (purchaseKey,) <$> generateMasterKey g
 
+redeemAsNewPurchase :: HasCallStack => BadgeServiceEnv -> BadgeCode -> IO BadgeServiceResponse
+redeemAsNewPurchase env code = newPurchaseKeys >>= \keys -> redeemWithKeys env keys code
+
+redeemWithKeys :: HasCallStack => BadgeServiceEnv -> (C.PublicKeyEd25519, BadgeMasterKey) -> BadgeCode -> IO BadgeServiceResponse
+redeemWithKeys env (purchaseKey, masterKey) code = serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
+
 assertBalance :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> StatementEntry -> IO BadgeServiceResponse
 assertBalance env purchaseKey lastEntry =
   serviceCmd env purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry}}
@@ -403,6 +430,9 @@ assertBalance env purchaseKey lastEntry =
 expiryOf :: HasCallStack => BadgeServiceResponse -> Maybe UTCTime
 expiryOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) -> badgeExpiry) <$> credentialOf r
 
+badgeTypeOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeType
+badgeTypeOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeType}) -> badgeType) <$> credentialOf r
+
 masterKeyOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeMasterKey
 masterKeyOf r = (\(BadgeCredential _ mk _ _) -> mk) <$> credentialOf r
 
@@ -410,8 +440,8 @@ testCodeMonthsRenew :: HasCallStack => TestParams -> IO ()
 testCodeMonthsRenew ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
     code <- issueCode cc BTSupporter 3
-    (purchaseKey, masterKey) <- newPurchaseKeys
-    redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
+    keys@(purchaseKey, _) <- newPurchaseKeys
+    redeemed <- redeemWithKeys env keys code
     let (entries, previousEntryId) = statementOf redeemed
     previousEntryId `shouldBe` Nothing
     map entryTag entries `shouldBe` ["code", "badge"]
@@ -435,19 +465,79 @@ testRepeatInsideIssuedPeriod :: HasCallStack => TestParams -> IO ()
 testRepeatInsideIssuedPeriod ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do
     code <- issueCode cc BTSupporter 2
-    (purchaseKey, masterKey) <- newPurchaseKeys
-    redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
+    keys@(purchaseKey, _) <- newPurchaseKeys
+    redeemed <- redeemWithKeys env keys code
     let (entries, _) = statementOf redeemed
     repeated <- assertBalance env purchaseKey (last entries)
     map entryTag (fst $ statementOf repeated) `shouldBe` []
     credentialOf repeated `shouldBe` credentialOf redeemed
 
+testMultiUseRepeatAfterExpiry :: HasCallStack => TestParams -> IO ()
+testMultiUseRepeatAfterExpiry ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueMultiUseCode cc BTSupporter 1 2
+      redeemFirstBadge alice code
+      rows <- ledgerRows (chatController alice) "badge_ledger"
+      setClockAt bsClock $ dueAtOf rows
+      alice ##> "/_app activate"
+      alice <## "ok"
+      alice <##. "badge alert: support_ended "
+      alice <##. "1: supporter"
+      alice <##. "badge alert: support_ended "
+      waitShownBadge (chatController alice) Nothing
+      -- The repeat uses the same purchase key, so the service returns the credential it already issued.
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge already redeemed"
+      waitShownBadge (chatController alice) Nothing
+      codeUses cc code `shouldReturn` Just (2, 1)
+      withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> redeemFirstBadge bob code
+      redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeUsed)
+
+testMultiUseWithoutGroup :: HasCallStack => TestParams -> IO ()
+testMultiUseWithoutGroup ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do
+    code <- issueMultiUseCode cc BTLegend 2 2
+    forM_ [1 :: Int, 2] $ \claimed -> do
+      keys@(_, masterKey) <- newPurchaseKeys
+      redeemed <- redeemWithKeys env keys code
+      let (entries, _) = statementOf redeemed
+      map (\e -> let (c, m, _) = entryOf e in (c, m)) entries `shouldBe` [(2, 2), (-1, 1)]
+      badgeTypeOf redeemed `shouldBe` Just BTLegend
+      expiryOf redeemed `shouldBe` Just (endOfMondayAfter (nextDue entries))
+      masterKeyOf redeemed `shouldBe` Just masterKey
+      codeUses cc code `shouldReturn` Just (2, claimed)
+    redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeUsed)
+
+testUnreadableCredentialIsInternal :: HasCallStack => TestParams -> IO ()
+testUnreadableCredentialIsInternal ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do
+    code <- issueMultiUseCode cc BTSupporter 1 2
+    let redeem keys = redeemWithKeys env keys code
+    holder <- newPurchaseKeys
+    redeem holder >>= (`shouldSatisfy` isJust) . credentialOf
+    withTransaction (chatStore cc) $ \db ->
+      DB.execute db "UPDATE sx_badge_service_badge_issuances SET credential = ?" (Only (Binary ("not a credential" :: ByteString)))
+    redeem holder >>= (`shouldAnswerError` BSEInternal)
+    codeUses cc code `shouldReturn` Just (2, 1)
+    newPurchaseKeys >>= redeem >>= (`shouldSatisfy` isJust) . credentialOf
+    codeUses cc code `shouldReturn` Just (2, 2)
+    redeem holder >>= (`shouldAnswerError` BSEInternal)
+    codeUses cc code `shouldReturn` Just (2, 2)
+
+-- The operator's //issue makes single-use codes only, so multi-use codes are issued directly.
+issueMultiUseCode :: HasCallStack => ChatController -> BadgeType -> Int -> Int -> IO BadgeCode
+issueMultiUseCode cc badgeType months uses =
+  issueOneCode cc badgeType months CPSFree uses >>= \case
+    Right (code, _) -> pure code
+    Left e -> error $ "issuing a multi-use code failed: " <> e
+
 testLapseWhileAway :: HasCallStack => TestParams -> IO ()
 testLapseWhileAway ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
     code <- issueCode cc BTSupporter 6
-    (purchaseKey, masterKey) <- newPurchaseKeys
-    redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
+    keys@(purchaseKey, _) <- newPurchaseKeys
+    redeemed <- redeemWithKeys env keys code
     let (entries, _) = statementOf redeemed
     -- The clock is moved from the anchor because adding months to an already clipped due date would miss the boundary.
     setClockAt bsClock (addMonths 4 (anchorOf (last entries)))
@@ -461,8 +551,8 @@ testLastMonthExpiryRounds :: HasCallStack => TestParams -> IO ()
 testLastMonthExpiryRounds ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
     code <- issueCode cc BTSupporter 2
-    (purchaseKey, masterKey) <- newPurchaseKeys
-    redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
+    keys@(purchaseKey, _) <- newPurchaseKeys
+    redeemed <- redeemWithKeys env keys code
     let (entries, _) = statementOf redeemed
     setClockAt bsClock (nextDue entries)
     renewed <- assertBalance env purchaseKey (last entries)
@@ -475,8 +565,8 @@ testRenewalSignsWithStoredMasterKey :: HasCallStack => TestParams -> IO ()
 testRenewalSignsWithStoredMasterKey ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
     code <- issueCode cc BTSupporter 2
-    (purchaseKey, masterKey) <- newPurchaseKeys
-    redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
+    keys@(purchaseKey, masterKey) <- newPurchaseKeys
+    redeemed <- redeemWithKeys env keys code
     masterKeyOf redeemed `shouldBe` Just masterKey
     let (entries, _) = statementOf redeemed
     setClockAt bsClock (nextDue entries)
@@ -486,14 +576,30 @@ testRenewalSignsWithStoredMasterKey ps =
 -- This type omits service_created_at and created_at because the client records when it stored a row, not when the service wrote it, so those columns never match.
 type ReplicatedRow = (Text, Int, Int, UTCTime, Text, Maybe Text)
 
+replicatedColumns :: String
+replicatedColumns =
+  "entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, "
+    <> "COALESCE(entry_credit_type, entry_debit_type)"
+
 ledgerRows :: ChatController -> String -> IO [ReplicatedRow]
 ledgerRows ChatController {chatStore} table =
   withTransaction chatStore $ \db ->
     DB.query_ db . fromString $
-      "SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, "
-        <> "COALESCE(entry_credit_type, entry_debit_type) FROM "
-        <> table
-        <> " ORDER BY entry_id"
+      "SELECT " <> replicatedColumns <> " FROM " <> table <> " ORDER BY entry_id"
+
+purchaseLedgerRows :: ChatController -> Text -> IO [ReplicatedRow]
+purchaseLedgerRows ChatController {chatStore} entryUuid =
+  withTransaction chatStore $ \db ->
+    DB.query
+      db
+      ( fromString $
+          "SELECT "
+            <> replicatedColumns
+            <> " FROM sx_badge_service_badge_ledger "
+            <> "WHERE badge_purchase_id = (SELECT badge_purchase_id FROM sx_badge_service_badge_ledger WHERE entry_uuid = ?) "
+            <> "ORDER BY entry_id"
+      )
+      (Only entryUuid)
 
 -- the two dates the CLI prints for each row
 ledgerTimes :: ChatController -> IO [(UTCTime, UTCTime)]
@@ -697,6 +803,78 @@ testWorkerRenews ps =
       alice <## "ok"
       waitShownIssued (chatController alice)
 
+testRevokedMultiUseHolderRenews :: HasCallStack => TestParams -> IO ()
+testRevokedMultiUseHolderRenews ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueMultiUseCode cc BTSupporter 3 2
+      redeemFirstBadge alice code
+      redeemed <- ledgerRows (chatController alice) "badge_ledger"
+      revokeCodeAs cc code `shouldReturn` "revoked"
+      redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeInvalid)
+      codeUses cc code `shouldReturn` Just (2, 1)
+      -- A holder whose reply was lost retries with the same key and still gets its badge.
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge already redeemed"
+      codeUses cc code `shouldReturn` Just (2, 1)
+      let (requestAt, presentAt) = renewalMoments redeemed
+      setClockAt bsClock requestAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      renewed <- waitLedgerRows (chatController alice) 3
+      alice <##. "1: supporter"
+      map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
+      ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` renewed
+      setClockAt bsClock presentAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      waitShownIssued (chatController alice)
+
+testMultiUseHoldersRenewApart :: HasCallStack => TestParams -> IO ()
+testMultiUseHoldersRenewApart ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueMultiUseCode cc BTSupporter 3 2
+      redeemFirstBadge alice code
+      redeemed <- ledgerRows (chatController alice) "badge_ledger"
+      let requestAt = fst $ renewalMoments redeemed
+      setClockAt bsClock requestAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      renewed <- waitLedgerRows (chatController alice) 3
+      alice <##. "1: supporter"
+      map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
+      bobRows <- withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do
+        redeemFirstBadge bob code
+        ledgerRows (chatController bob) "badge_ledger"
+      map (\(_, ch, m, _, _, t) -> (ch, m, t)) bobRows `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge")]
+      let (bobFirstUuid, _, _, bobRedeemedAt, _, _) = head bobRows
+      bobRedeemedAt `shouldSatisfy` (>= requestAt)
+      purchaseLedgerRows cc bobFirstUuid `shouldReturn` bobRows
+      issued <- issuedExpiries (chatController alice)
+      length issued `shouldBe` 2
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge already redeemed"
+      codeUses cc code `shouldReturn` Just (2, 2)
+      let (aliceFirstUuid, _, _, _, _, _) = head renewed
+      ledgerRows (chatController alice) "badge_ledger" `shouldReturn` renewed
+      purchaseLedgerRows cc aliceFirstUuid `shouldReturn` renewed
+      issuedExpiries (chatController alice) `shouldReturn` issued
+      alicePurchaseKey <- codeRedemptionKey (chatController alice)
+      (_, masterKey) <- newPurchaseKeys
+      repeated <- redeemWithKeys env (alicePurchaseKey, masterKey) code
+      expiryOf repeated `shouldBe` Just (last issued)
+      codeUses cc code `shouldReturn` Just (2, 2)
+
+codeRedemptionKey :: HasCallStack => ChatController -> IO C.PublicKeyEd25519
+codeRedemptionKey ChatController {chatStore} = do
+  rows :: [Only C.PublicKeyEd25519] <-
+    withTransaction chatStore $ \db ->
+      DB.query_ db "SELECT purchase_key FROM badge_code_redemptions"
+  case rows of
+    [Only k] -> pure k
+    _ -> error $ "expected one code redemption, got " <> show (length rows)
+
 testRequestWakeFires :: HasCallStack => TestParams -> IO ()
 testRequestWakeFires ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->

tests/Bots/BadgeService/WebTests.hs

@@ -14,11 +14,11 @@ import BadgeService.Poller
 import BadgeService.Providers
 import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages)
 import BadgeService.Providers.Stripe (stripeProvider)
-import BadgeService.Store (CodeRedemption (..), IssuedCode (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getBadgeCode, insertBadgeCode, revokeCode)
+import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, insertBadgeCode, revokeCode)
 import BadgeService.Store.Invoices
 import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount)
 import BadgeService.Web.Server
-import Bots.BadgeService.BotTests (newPurchaseKeys)
+import Bots.BadgeService.BotTests (codeCounts, newPurchaseKeys)
 import Bots.BadgeService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource)
 import Bots.BadgeService.FakeBTCPay
 import Bots.BadgeService.FakeStripe (FakeStripe (..), fakeIntentStatus, setIntentState, stripeEvent, stripeSigHeader, withFakeStripe)
@@ -41,9 +41,10 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (toLower)
 import Data.Either (isLeft)
 import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
+import Data.Int (Int64)
 import Data.List (sort, sortOn)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (isJust, isNothing, fromMaybe)
+import Data.Maybe (catMaybes, isJust, isNothing, fromMaybe, mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
@@ -57,15 +58,16 @@ import Network.HTTP.Client (Manager, Request (..), RequestBody (..), Response, d
 import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType)
 import Network.HTTP.Types.Status (statusCode)
 import qualified Network.Wai.Handler.Warp as Warp
-import Simplex.Chat.Badges (BadgeType (..))
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeType (..))
 import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..))
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..))
 import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Interface
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSSignature (..))
 import Simplex.Messaging.Encoding.String (textDecode, textEncode)
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Directory (createDirectoryIfMissing, createFileLink, doesFileExist, listDirectory)
@@ -81,6 +83,7 @@ import UnliftIO.Temporary (withTempDirectory)
 import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations)
 import ChatClient (testDBConnectInfo, testDBConnstr)
 import Database.PostgreSQL.Simple (Only (..))
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser)
 #else
 import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations)
@@ -88,6 +91,7 @@ import Data.String (fromString)
 import Database.SQLite.Simple (Only (..))
 import qualified Database.SQLite.Simple as SQL
 import Simplex.Messaging.Agent.Store.DB (TrackQueries (..))
+import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 #endif
 
 #if defined(dbPostgres)
@@ -134,6 +138,10 @@ badgeWebTests = do
   describe "badge service schema" $ do
     it "carries the five service-only columns" testServiceColumns
     it "refuses a duplicate provider_ref" testProviderRefUnique
+    it "M20260918 adds the multi-use columns" testGroupOpsColumns
+    it "M20260918 defaults a fresh code to one use with none spent" testGroupOpsRedeemCounts
+    it "migrates all the way down and up again" testSchemaDownUpCycle
+    it "rolls back only the group migration and re-applies it, keeping a code redeemed twice spent" testGroupOpsDownUp
   describe "badge service store" $ do
     it "writes the invoice, its code and their link atomically" testCreationIsAtomic
     it "newInvoiceId is 128 CSPRNG bits, base64url, and two calls differ" testNewInvoiceIdRandom
@@ -144,7 +152,12 @@ badgeWebTests = do
     it "expireOverdue spares an invoice funded by dust, or by the verdict alone" testExpireOverdueSparesAZeroAmount
     it "readCatalogRows drops every disabled row" testReadCatalogRowsDropsDisabled
     it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther
+    it "a multi-use code can be revoked while it has uses left, and not once they are gone" testRevokeMultiUseCode
     it "every timestamp round-trips to the second" testTimestampRoundTrip
+  describe "multi-use" $ do
+    it "finds a key's own purchase with its newest credential, and none for another key" testKeyPurchaseLookup
+    it "gives concurrent claims exactly the code's uses, each a distinct count" testMultiUseConcurrentClaimsUpToLimit
+    it "refuses a second claim by the same key without using up a use" testSameKeyClaimsOnce
   describe "badge service catalog seed" $ do
     it "writes the compiled-in catalog into an empty database" testSeedWritesTheCatalog
     it "leaves exactly one row per id when the service starts twice" testSeedIsIdempotent
@@ -301,6 +314,56 @@ testServiceColumns = withServiceStore $ \st -> do
   columnsOf st "sx_badge_service_badge_codes"
     >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["expires_at", "revoked_at"])
 
+testGroupOpsColumns :: IO ()
+testGroupOpsColumns = withServiceStore assertGroupOpsColumns
+
+assertGroupOpsColumns :: HasCallStack => DBStore -> IO ()
+assertGroupOpsColumns st = do
+  columnsOf st "sx_badge_service_badge_codes"
+    >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["redeem_limit", "redeem_count"])
+
+runMigrations :: DBStore -> MigrationsToRun -> IO ()
+#if defined(dbPostgres)
+runMigrations st = Migrations.run st Nothing
+#else
+runMigrations st = Migrations.run st Nothing True
+#endif
+
+testSchemaDownUpCycle :: IO ()
+testSchemaDownUpCycle = withServiceStore $ \st -> do
+  let downMigrations = mapMaybe toDownMigration badgeServiceSchemaMigrations
+  length downMigrations `shouldBe` length badgeServiceSchemaMigrations
+  runMigrations st $ MTRDown downMigrations
+  columnsOf st "sx_badge_service_badge_codes" `shouldReturn` []
+  runMigrations st $ MTRUp badgeServiceSchemaMigrations
+  assertGroupOpsColumns st
+
+testGroupOpsDownUp :: IO ()
+testGroupOpsDownUp = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  let redeemedHash = digestFixture 44
+      unredeemedHash = digestFixture 45
+      groupOps = [m | m@Migration {name = "20260918_badge_group_ops"} <- badgeServiceSchemaMigrations]
+  redeemed <- insertCode st redeemedHash CPSPaid 2 now
+  void $ insertCode st unredeemedHash CPSPaid 1 now
+  -- Two purchases of one code would break a down migration that restored the unique index.
+  replicateM_ 2 $ newPurchaseKeys >>= claimUse st redeemed now >>= (`shouldSatisfy` isJust)
+  runMigrations st $ MTRDown (mapMaybe toDownMigration groupOps)
+  columnsOf st "sx_badge_service_badge_codes" >>= (`shouldNotSatisfy` elem "redeem_count")
+  runMigrations st $ MTRUp groupOps
+  codeCounts st redeemedHash `shouldReturn` Just (1, 1)
+  codeCounts st unredeemedHash `shouldReturn` Just (1, 0)
+
+testGroupOpsRedeemCounts :: IO ()
+testGroupOpsRedeemCounts = withServiceStore $ \st -> do
+  let codeHash = digestFixture 43
+  withConnection st $ \db ->
+    DB.execute
+      db
+      "INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)"
+      (DB.Binary codeHash, "supporter" :: Text, 1 :: Int, "free" :: Text, someCreated)
+  codeCounts st codeHash `shouldReturn` Just (1, 0)
+
 testProviderRefUnique :: IO ()
 testProviderRefUnique = withServiceStore $ \st -> do
   seedBadgePrice st "price1"
@@ -463,25 +526,35 @@ expireAllOverdue st now = overdueInvoices st now >>= expireOverdue st now . map
 testRevokeAndRedeemExcludeEachOther :: IO ()
 testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do
   now <- truncateToSecond <$> getCurrentTime
-  (purchaseKey, masterKey) <- newPurchaseKeys
-  let newCode codeHash = withTransaction st $ \db -> do
-        insertBadgeCode db codeHash BTSupporter 1 CPSPaid now
-        maybe (error "the code was not written") (\IssuedCode {badgeCodeId} -> badgeCodeId) <$> getBadgeCode db codeHash
-      redeem badgeCodeId = withTransaction st $ \db -> createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now
+  keys <- newPurchaseKeys
+  let newCode codeHash = insertCode st codeHash CPSPaid 1 now
+      redeem badgeCodeId = claimUse st badgeCodeId now keys
       revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
-      unredeemed codeHash =
-        withTransaction st (`getBadgeCode` codeHash) >>= \case
-          Just IssuedCode {redemption = CodeUnredeemed} -> pure True
-          _ -> pure False
   revokedFirst <- newCode "revoked-first"
   revoke "revoked-first" `shouldReturn` Revoked
   redeem revokedFirst `shouldReturn` Nothing
-  unredeemed "revoked-first" `shouldReturn` True
+  codeCounts st "revoked-first" `shouldReturn` Just (1, 0)
   redeemedFirst <- newCode "redeemed-first"
   isJust <$> redeem redeemedFirst `shouldReturn` True
   revoke "redeemed-first" `shouldReturn` AlreadyRedeemed
   redeem redeemedFirst `shouldReturn` Nothing
 
+testRevokeMultiUseCode :: IO ()
+testRevokeMultiUseCode = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  let newCode codeHash = insertCode st codeHash CPSPaid 2 now
+      -- A purchase key redeems once, so every redemption here brings its own.
+      redeem badgeCodeId = newPurchaseKeys >>= claimUse st badgeCodeId now
+      revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
+  partlyUsed <- newCode "partly-used"
+  isJust <$> redeem partlyUsed `shouldReturn` True
+  revoke "partly-used" `shouldReturn` Revoked
+  redeem partlyUsed `shouldReturn` Nothing
+  usedUp <- newCode "used-up"
+  isJust <$> redeem usedUp `shouldReturn` True
+  isJust <$> redeem usedUp `shouldReturn` True
+  revoke "used-up" `shouldReturn` AlreadyRedeemed
+
 testReadCatalogRowsDropsDisabled :: IO ()
 testReadCatalogRowsDropsDisabled = withServiceStore $ \st -> do
   insertPrice st "price-active" "supporter" 500 "active"
@@ -615,6 +688,74 @@ testTimestampRoundTrip = withServiceStore $ \st -> do
   irExpiresAt row `shouldBe` truncated
   irCreatedAt row `shouldBe` truncated
 
+insertCode :: DBStore -> ByteString -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64
+insertCode st codeHash paymentStatus redeemLimit now =
+  withTransaction st $ \db -> insertBadgeCode db codeHash BTSupporter 1 paymentStatus redeemLimit now
+
+claimUse :: DBStore -> Int64 -> UTCTime -> (C.PublicKeyEd25519, BadgeMasterKey) -> IO (Maybe (Int64, Int))
+claimUse st badgeCodeId now (purchaseKey, masterKey) =
+  withTransaction st $ \db ->
+    createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now
+
+-- The signature is dummy bytes, since only the JSON round-trip is under test; 80 is the length its decoder accepts.
+seededCredential :: BadgeMasterKey -> UTCTime -> BadgeCredential
+seededCredential masterKey expiry =
+  BadgeCredential {badgeKeyIdx = 1, masterKey, signature = BBSSignature (BS.replicate 80 7), badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}}
+
+seedIssuance :: DBStore -> Int64 -> Text -> BadgeMasterKey -> UTCTime -> UTCTime -> IO ()
+seedIssuance st purchaseId issuanceId masterKey at periodEnd =
+  withConnection st $ \db ->
+    DB.execute
+      db
+      "INSERT INTO sx_badge_service_badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at) VALUES (?,?,?,?,?,?,?,?)"
+      (issuanceId, purchaseId, "supporter" :: Text, at, periodEnd, periodEnd, DB.Binary (LB.toStrict (J.encode (seededCredential masterKey periodEnd))), at)
+
+testKeyPurchaseLookup :: IO ()
+testKeyPurchaseLookup = withServiceStore $ \st -> do
+  now <- getCurrentTime
+  let codeHash = digestFixture 41
+  badgeCodeId <- insertCode st codeHash CPSFree 2 now
+  keys@(k1, mk1) <- newPurchaseKeys
+  Just (purchaseId, _) <- claimUse st badgeCodeId now keys
+  withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1) >>= \case
+    KeyRedeemedUnreadable -> pure ()
+    _ -> expectationFailure "expected a purchase with no issuance to be unreadable"
+  let firstPeriodEnd = someExpiry
+      renewedPeriodEnd = addUTCTime 86400 someExpiry
+  seedIssuance st purchaseId "iss-first" mk1 now firstPeriodEnd
+  seedIssuance st purchaseId "iss-renewed" mk1 now renewedPeriodEnd
+  (unusedKey, _) <- newPurchaseKeys
+  withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId unusedKey) >>= \case
+    KeyUnredeemed -> pure ()
+    _ -> expectationFailure "expected no purchase for a key that never redeemed"
+  replayed <- withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1)
+  case replayed of
+    KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> do
+      badgePurchaseId `shouldBe` purchaseId
+      credential `shouldBe` seededCredential mk1 renewedPeriodEnd
+    _ -> expectationFailure "expected the redeemed key's purchase"
+
+testSameKeyClaimsOnce :: IO ()
+testSameKeyClaimsOnce = withServiceStore $ \st -> do
+  now <- getCurrentTime
+  let codeHash = digestFixture 46
+  badgeCodeId <- insertCode st codeHash CPSFree 3 now
+  keys <- newPurchaseKeys
+  claimUse st badgeCodeId now keys >>= (`shouldSatisfy` isJust)
+  -- The key is unique across purchases, so the second insert fails and its transaction returns the use.
+  claimUse st badgeCodeId now keys `shouldThrow` anyException
+  codeCounts st codeHash `shouldReturn` Just (3, 1)
+
+testMultiUseConcurrentClaimsUpToLimit :: IO ()
+testMultiUseConcurrentClaimsUpToLimit = withServiceStore $ \st -> do
+  now <- getCurrentTime
+  let codeHash = digestFixture 42
+  badgeCodeId <- insertCode st codeHash CPSFree 3 now
+  contenders <- replicateM 6 newPurchaseKeys
+  results <- Async.mapConcurrently (claimUse st badgeCodeId now) contenders
+  sort (map snd $ catMaybes results) `shouldBe` [1, 2, 3]
+  codeCounts st codeHash `shouldReturn` Just (3, 3)
+
 data StubCall
   = StubCreate ServicePaymentMethod OrderDraft
   | StubRead Text