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;