badges: add multi-use codes

apps/simplex-badge-service/src/BadgeService/Codes.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module BadgeService.Codes
+  ( issueOneCode,
+    singleUse,
+  )
+where
+
+import BadgeService.Store (insertBadgeCode)
+import BadgeService.Store.Invoices (truncateToSecond)
+import Data.Int (Int64)
+import Data.Time.Clock (getCurrentTime)
+import Simplex.Chat.Badges (BadgeType)
+import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, randomBadgeCode)
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus)
+import Simplex.Chat.Bot.Store (withDB')
+import Simplex.Chat.Controller (ChatController (..))
+
+singleUse :: Int
+singleUse = 1
+
+-- | The code table keeps only the hash, so the caller must deliver the code.
+issueOneCode :: ChatController -> BadgeType -> Int -> BadgeCodePaymentStatus -> Int -> IO (Either String (BadgeCode, Int64))
+issueOneCode cc badgeType months paymentStatus redeemLimit = do
+  code <- randomBadgeCode $ random cc
+  now <- truncateToSecond <$> getCurrentTime
+  fmap (code,) <$> withDB' "issueBadgeCode" cc (\db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus redeemLimit now)

apps/simplex-badge-service/src/BadgeService/Service.hs

@@ -21,6 +21,7 @@ module BadgeService.Service
 where
 
 import BadgeService.Catalog (defaultCatalog)
+import BadgeService.Codes (issueOneCode, singleUse)
 import BadgeService.Config (BadgeIssuerKey (..), ServiceConfig (..), readServiceConfig)
 import BadgeService.Options
 import BadgeService.Poller (newPollerEnv, newReadHints, runPoller)
@@ -259,13 +260,9 @@ data IssueCodeOpts = IssueCodeOpts
     paymentStatus :: BadgeCodePaymentStatus
   }
 
--- | The caller sees the code once; only its hash is stored, so a lost code cannot be recovered.
 issueBadgeCode :: ChatController -> IssueCodeOpts -> IO (Either String BadgeCode)
-issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = do
-  code <- randomBadgeCode $ random cc
-  now <- getCurrentTime
-  r <- withDB' "issueBadgeCode" cc $ \db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus now
-  pure $ code <$ r
+issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} =
+  fmap fst <$> issueOneCode cc badgeType months paymentStatus singleUse
 
 processQueuedRequests :: BadgeIssuerKey -> ServiceState -> IO ()
 processQueuedRequests key env = do
@@ -395,14 +392,14 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText
           Just issued -> credentialForEntry key masterKey issued >>= \case
             Left e -> logError ("badge service signing failed: " <> T.pack e) $> errorResponse BSEInternal
             Right signed -> do
-              -- If the code was revoked or redeemed while signing, the claim fails. Read the code again to tell the client why.
+              -- If the code was revoked or used up while signing, the claim fails. Read the code again to tell the client why.
               r <- withDB "writeCodeRedemption" cc $ \db ->
                 liftIO (createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now) >>= \case
                   Nothing ->
                     readCode now code db >>= \case
                       Left resp -> pure resp
-                      Right _ -> logError "badge service: redeeming a code failed, but the code is neither redeemed nor revoked" $> errorResponse BSEInternal
-                  Just purchaseId -> liftIO $ do
+                      Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> errorResponse BSEInternal
+                  Just (purchaseId, _) -> liftIO $ do
                     appendLedgerPlan db purchaseId [granted] $ Just $ issuanceAfter granted signed
                     entries_ <- getLedgerEntries db purchaseId 0
                     pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_
@@ -411,25 +408,24 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText
     readCode now code db = liftIO $
       getBadgeCode db (badgeCodeHash code) >>= \case
         Nothing -> pure $ Left $ errorResponse BSECodeInvalid
-        Just c@IssuedCode {revokedAt, paymentStatus, expiresAt, redemption}
-          -- Revoked is checked first, so it answers as if the code never existed.
-          | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid
-          -- Redeeming an unpaid code would issue a free badge, so unpaid is refused.
-          | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending
-          | otherwise ->
-              checkUnspent db redemption >>= \case
-                Left resp -> pure $ Left resp
-                Right ()
-                  | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired
-                  | otherwise -> pure $ Right c
-    checkUnspent db = \case
-      CodeUnredeemed -> pure $ Right ()
-      CodeRedeemedUnreadable -> pure $ Left $ errorResponse BSEInternal
-      CodeRedeemed RedeemedCode {purchaseKey = k, badgePurchaseId, credential}
-        | k /= purchaseKey -> pure $ Left $ errorResponse BSECodeUsed
-        | otherwise ->
-            maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing)
-              <$> getLedgerEntries db badgePurchaseId 0
+        Just c@IssuedCode {badgeCodeId, revokedAt, paymentStatus, expiresAt, redeemLimit, redeemCount} ->
+          getCodePurchaseForKey db badgeCodeId purchaseKey >>= \case
+            -- A key that already redeemed gets its credential back without a use, even if the code has since
+            -- expired or been revoked: a client whose reply was lost retries, and would otherwise lose the badge.
+            KeyRedeemed KeyPurchase {badgePurchaseId, credential} ->
+              maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing)
+                <$> getLedgerEntries db badgePurchaseId 0
+            -- code_used would make the client drop its keys, so the holder could never get the badge back.
+            KeyRedeemedUnreadable ->
+              logError "badge service: a redeemed code's credential is missing or unreadable" $> Left (errorResponse BSEInternal)
+            KeyUnredeemed
+              -- Revoked is checked first, so it answers as if the code never existed.
+              | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid
+              -- Redeeming an unpaid code would issue a free badge, so unpaid is refused.
+              | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending
+              | redeemCount >= redeemLimit -> pure $ Left $ errorResponse BSECodeUsed
+              | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired
+              | otherwise -> pure $ Right c
 
 -- | The purchase is reached through the verified signer key and no other way.
 issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse

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

@@ -4,14 +4,16 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module BadgeService.Store
   ( IssuedCode (..),
-    CodeRedemption (..),
-    RedeemedCode (..),
+    KeyRedemption (..),
+    KeyPurchase (..),
     NewCodePurchase (..),
     ServicePurchase (..),
     getBadgeCode,
+    getCodePurchaseForKey,
     purchaseKeyExists,
     getPurchaseByKey,
     getLedgerTip,
@@ -27,6 +29,7 @@ module BadgeService.Store
 where
 
 import BadgeService.Store.Invoices (executeChanging)
+import Control.Monad (forM)
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -58,17 +61,17 @@ data IssuedCode = IssuedCode
     paymentStatus :: BadgeCodePaymentStatus,
     revokedAt :: Maybe UTCTime,
     expiresAt :: Maybe UTCTime,
-    redemption :: CodeRedemption
+    redeemLimit :: Int,
+    redeemCount :: Int
   }
 
-data CodeRedemption
-  = CodeUnredeemed
-  | CodeRedeemed RedeemedCode
-  | CodeRedeemedUnreadable
+data KeyRedemption
+  = KeyUnredeemed
+  | KeyRedeemed KeyPurchase
+  | KeyRedeemedUnreadable
 
-data RedeemedCode = RedeemedCode
+data KeyPurchase = KeyPurchase
   { badgePurchaseId :: Int64,
-    purchaseKey :: C.PublicKeyEd25519,
     credential :: BadgeCredential
   }
 
@@ -91,24 +94,33 @@ getBadgeCode db codeHash =
     DB.query
       db
       [sql|
-        SELECT c.badge_code_id, c.badge_type, c.months, c.code_payment_status, c.revoked_at,
-               c.expires_at, p.badge_purchase_id, p.purchase_key, i.credential
-        FROM sx_badge_service_badge_codes c
-        LEFT JOIN sx_badge_service_badge_purchases p ON p.badge_code_id = c.badge_code_id
-        LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id
-        WHERE c.code_hash = ?
-        ORDER BY i.period_end DESC
-        LIMIT 1
+        SELECT badge_code_id, badge_type, months, code_payment_status, revoked_at, expires_at, redeem_limit, redeem_count
+        FROM sx_badge_service_badge_codes
+        WHERE code_hash = ?
       |]
       (Only (Binary codeHash))
   where
-    toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, purchaseId_, purchaseKey_, credential_) =
-      IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redemption = codeRedemption purchaseId_ purchaseKey_ credential_}
-    codeRedemption purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of
-      (Just badgePurchaseId, Just purchaseKey) -> case decodeCredential =<< credential_ of
-        Just credential -> CodeRedeemed RedeemedCode {badgePurchaseId, purchaseKey, credential}
-        Nothing -> CodeRedeemedUnreadable
-      _ -> CodeUnredeemed
+    toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redeemLimit, redeemCount) =
+      IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redeemLimit, redeemCount}
+
+getCodePurchaseForKey :: DB.Connection -> Int64 -> C.PublicKeyEd25519 -> IO KeyRedemption
+getCodePurchaseForKey db badgeCodeId key =
+  maybeFirstRow' KeyUnredeemed toRedemption $
+    DB.query
+      db
+      [sql|
+        SELECT p.badge_purchase_id, i.credential
+        FROM sx_badge_service_badge_purchases p
+        LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id
+        WHERE p.badge_code_id = ? AND p.purchase_key = ?
+        ORDER BY i.period_end DESC
+        LIMIT 1
+      |]
+      (badgeCodeId, key)
+  where
+    toRedemption (badgePurchaseId, credential_) = case decodeCredential =<< credential_ of
+      Just credential -> KeyRedeemed KeyPurchase {badgePurchaseId, credential}
+      Nothing -> KeyRedeemedUnreadable
     decodeCredential (Binary bs) = J.decodeStrict' bs
 
 purchaseKeyExists :: DB.Connection -> C.PublicKeyEd25519 -> IO Bool
@@ -222,39 +234,37 @@ appendLedgerPlan db purchaseId rows issuance_ = do
         ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType))
       insertedRowId db
 
--- redeemed_at is stamped here, so this must run in the same transaction as the credential rows.
--- Mark the code as redeemed before adding the purchase. On Postgres, a revoke or redemption running
--- at the same time then waits, sees the code is taken, and fails.
-createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO (Maybe Int64)
+-- The claim takes one use before adding the purchase, so a concurrent revoke or redemption waits on this row and sees the new count.
+-- Run it in the credential's transaction. It returns the use count this claim reached.
+createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO (Maybe (Int64, Int))
 createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do
-  claimed <-
-    executeChanging
-      db
-      "UPDATE sx_badge_service_badge_codes SET redeemed_at = ? WHERE badge_code_id = ? AND redeemed_at IS NULL AND revoked_at IS NULL"
-      (now, badgeCodeId)
-  if claimed == 0
-    then pure Nothing
-    else do
-      DB.execute
+  claimed_ <-
+    maybeFirstRow fromOnly $
+      DB.query
         db
-        [sql|
-          INSERT INTO sx_badge_service_badge_purchases
-            (purchase_key, master_key, initial_badge_type, current_badge_type, status, badge_code_id, created_at, updated_at)
-          VALUES (?,?,?,?,?,?,?,?)
-        |]
-        (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now)
-      Just <$> insertedRowId db
+        "UPDATE sx_badge_service_badge_codes SET redeem_count = redeem_count + 1, redeemed_at = ? WHERE badge_code_id = ? AND redeem_count < redeem_limit AND revoked_at IS NULL RETURNING redeem_count"
+        (now, badgeCodeId)
+  forM claimed_ $ \claimedCount -> do
+    DB.execute
+      db
+      [sql|
+        INSERT INTO sx_badge_service_badge_purchases
+          (purchase_key, master_key, initial_badge_type, current_badge_type, status, badge_code_id, created_at, updated_at)
+        VALUES (?,?,?,?,?,?,?,?)
+      |]
+      (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now)
+    (,claimedCount) <$> insertedRowId db
 
 data RevokeResult = Revoked | AlreadyRevoked | AlreadyRedeemed | NoSuchCode
   deriving (Eq, Show)
 
--- | A code that was already redeemed can't be revoked, because its badge was already given out.
+-- | A code with no uses left can't be revoked, because every badge it grants was already given out.
 revokeCode :: DB.Connection -> ByteString -> UTCTime -> IO RevokeResult
 revokeCode db codeHash now = do
   revoked <-
     executeChanging
       db
-      "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeemed_at IS NULL"
+      "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeem_count < redeem_limit"
       (now, Binary codeHash)
   if revoked > 0
     then pure Revoked
@@ -265,12 +275,13 @@ revokeCode db codeHash now = do
     refusal :: Only (Maybe UTCTime) -> RevokeResult
     refusal (Only revokedAt) = maybe AlreadyRedeemed (const AlreadyRevoked) revokedAt
 
-insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> UTCTime -> IO ()
-insertBadgeCode db codeHash badgeType months paymentStatus now =
+insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64
+insertBadgeCode db codeHash badgeType months paymentStatus redeemLimit now = do
   DB.execute
     db
     [sql|
-      INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at)
-      VALUES (?,?,?,?,?)
+      INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, redeem_limit, created_at)
+      VALUES (?,?,?,?,?,?)
     |]
-    (Binary codeHash, badgeType, months, paymentStatus, now)
+    (Binary codeHash, badgeType, months, paymentStatus, redeemLimit, now)
+  insertedRowId db

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 =
-  [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema)
+  [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema),
+    ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops)
   ]
 
 -- | The client tables share this database, so the service tables are the same names behind a prefix.
@@ -109,6 +110,34 @@ DROP INDEX @idx_badge_purchases_code;
 DROP TABLE @badge_codes;
 |]
 
+m20260918_badge_group_ops :: Text
+m20260918_badge_group_ops =
+  withPrefix
+    servicePrefix
+    [r|
+ALTER TABLE @badge_codes ADD COLUMN redeem_limit INTEGER NOT NULL DEFAULT 1;
+
+ALTER TABLE @badge_codes ADD COLUMN redeem_count INTEGER NOT NULL DEFAULT 0;
+
+-- Redemptions made before this migration must count against the new limit, or every code
+-- redeemed already would read as unspent and could be redeemed once more.
+UPDATE @badge_codes SET redeem_count = 1 WHERE redeemed_at IS NOT NULL;
+
+DROP INDEX @idx_badge_purchases_code;
+
+CREATE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id);
+|]
+
+-- The index stays non-unique, since a multi-use code may already have several purchases.
+down_m20260918_badge_group_ops :: Text
+down_m20260918_badge_group_ops =
+  withPrefix
+    servicePrefix
+    [r|
+ALTER TABLE @badge_codes DROP COLUMN redeem_count;
+ALTER TABLE @badge_codes DROP COLUMN redeem_limit;
+|]
+
 {- TODO [badges] deferred with the draft in M20260915_user_badges, service only.
 
 ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA;

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 =
-  [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema)
+  [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema),
+    ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops)
   ]
 
 -- | The client tables share this database, so the service tables are the same names behind a prefix.
@@ -110,6 +111,34 @@ DROP INDEX @idx_badge_purchases_code;
 DROP TABLE @badge_codes;
 |]
 
+m20260918_badge_group_ops :: Query
+m20260918_badge_group_ops =
+  withPrefix
+    servicePrefix
+    [sql|
+ALTER TABLE @badge_codes ADD COLUMN redeem_limit INTEGER NOT NULL DEFAULT 1;
+
+ALTER TABLE @badge_codes ADD COLUMN redeem_count INTEGER NOT NULL DEFAULT 0;
+
+-- Redemptions made before this migration must count against the new limit, or every code
+-- redeemed already would read as unspent and could be redeemed once more.
+UPDATE @badge_codes SET redeem_count = 1 WHERE redeemed_at IS NOT NULL;
+
+DROP INDEX @idx_badge_purchases_code;
+
+CREATE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id);
+|]
+
+-- The index stays non-unique, since a multi-use code may already have several purchases.
+down_m20260918_badge_group_ops :: Query
+down_m20260918_badge_group_ops =
+  withPrefix
+    servicePrefix
+    [sql|
+ALTER TABLE @badge_codes DROP COLUMN redeem_count;
+ALTER TABLE @badge_codes DROP COLUMN redeem_limit;
+|]
+
 {- TODO [badges] deferred with the draft in M20260915_user_badges, service only.
 
 ALTER TABLE @payments ADD COLUMN receipt_hash BLOB;

simplex-chat.cabal

@@ -429,6 +429,7 @@ executable simplex-badge-service
       StrictData
   other-modules:
       BadgeService.Catalog
+      BadgeService.Codes
       BadgeService.Config
       BadgeService.Log
       BadgeService.Options
@@ -717,6 +718,7 @@ test-suite simplex-chat-test
       API.Docs.Types
       API.TypeInfo
       BadgeService.Catalog
+      BadgeService.Codes
       BadgeService.Config
       BadgeService.Log
       BadgeService.Options

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