badges: service group with multi-use codes (#7578)

* core: cancel the chat callback on interrupt

* badges: add multi-use codes

* badges: add the managed group

* badges: document multi-use codes and the group

* core: sign test badges with whole-second expiry

* badges: rework tracker and reply texts

tests/Bots/BadgeService/BotTests.hs

@@ -10,10 +10,13 @@
 
 module Bots.BadgeService.BotTests where
 
+import BadgeService.Codes (issueOneCode)
 import BadgeService.Config (BadgeIssuerKey (..), readServiceConfig)
+import BadgeService.Group (GroupEvent)
 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
@@ -21,7 +24,7 @@ import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
-import Control.Concurrent.STM (atomically, readTMVar)
+import Control.Concurrent.STM (TQueue, atomically, readTMVar)
 import Control.Monad (forM_, void, when)
 import Control.Exception (finally)
 import qualified Data.Aeson as J
@@ -43,14 +46,15 @@ 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.Controller (ChatConfig (..), ChatController (..), ChatError (..), ChatErrorType (..), ChatResponse (CRCustomChatResponse))
 import Simplex.Chat.Core (sendChatCmdStr)
 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
@@ -76,20 +80,27 @@ badgeServiceTests = do
   it "should refuse a code that has not been paid for" testRedeemUnpaidCode
   it "should refuse a badge code past its redemption deadline" testExpiredCode
   it "should keep answering a code redeemed before its deadline" testRedeemedBeforeTheDeadline
-  it "should refuse a revoked badge code, and refuse to revoke it twice" testRevokedCode
+  it "should refuse a revoked badge code, and report a second revoke as already revoked" testRevokedCode
   it "should refuse to revoke a code that was redeemed, and keep its badge" testRevokeRedeemedCode
   it "should answer revoking an unknown code as no such code" testRevokeUnknownCode
+  it "should answer code_invalid to a code that is both unpaid and revoked" testRevokedUnpaidCode
+  it "should refuse a revoke with trailing input, leaving the code live" testRevokeRejectsTrailingInput
   it "should refuse to issue a code with an unknown badge type or a nonsense month count" testIssueRejectsBadArguments
   it "should refuse a request whose purchaseKey is not the verified signer" testPurchaseKeyMismatch
   it "should refuse to start unless the issuer secret is the key trusted at its index" testIssuerKeyMustMatchConfig
   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 with no group to track it" 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
@@ -107,8 +118,11 @@ badgeServiceTests = do
   it "should broadcast the current profile when a renewal presents a badge" testRenewalKeepsProfileEdits
   it "should present the month already issued when a previous pass did not" testPresentationCatchesUp
 
+badgeBotName :: Text
+badgeBotName = "SimpleX Badges"
+
 badgeProfile :: Profile
-badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing}
+badgeProfile = Profile {displayName = badgeBotName, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing}
 
 serviceDbPrefix :: FilePath
 serviceDbPrefix = "badge_service"
@@ -129,7 +143,7 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey =
                 {dbFilePrefix = ps </> serviceDbPrefix}
 #endif
           },
-      serviceName = "SimpleX Badges",
+      serviceName = badgeBotName,
       clientService = True,
       noAddress = False,
       runCLI = False,
@@ -180,7 +194,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 =
@@ -192,17 +208,21 @@ withBadgeServiceEnv ps test = do
 issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode
 issueCode cc badgeType months = issueCodeAs cc badgeType months "free"
 
-revokeCodeAs :: HasCallStack => ChatController -> BadgeCode -> IO T.Text
-revokeCodeAs cc code =
-  sendChatCmdStr cc ("//revoke " <> T.unpack (formatBadgeCode code)) >>= \case
-    Right (CRCustomChatResponse _ response) -> pure response
-    Left e -> pure (T.pack (show e))
+revokeCodeAs :: HasCallStack => ChatController -> BadgeCode -> IO (Either T.Text T.Text)
+revokeCodeAs cc code = revokeRaw cc (formatBadgeCode code)
+
+-- | Left is a refusal or a failure the service answers as a command error.
+revokeRaw :: HasCallStack => ChatController -> T.Text -> IO (Either T.Text T.Text)
+revokeRaw cc args =
+  sendChatCmdStr cc ("//revoke " <> T.unpack args) >>= \case
+    Right (CRCustomChatResponse _ response) -> pure (Right response)
+    Left (ChatError (CECommandError e)) -> pure (Left (T.pack e))
     r -> error $ "revoke failed: " <> show (() <$ r)
 
 issueCodeAs :: HasCallStack => ChatController -> BadgeType -> Int -> String -> IO BadgeCode
 issueCodeAs cc badgeType months status =
   sendChatCmdStr cc ("//issue " <> T.unpack (textEncode badgeType) <> " " <> show months <> " " <> status) >>= \case
-    Right (CRCustomChatResponse _ response) -> case T.stripPrefix "code " response of
+    Right (CRCustomChatResponse _ response) -> case T.stripPrefix "Code: " response of
       Just c | Just code <- parseBadgeCode c -> pure code
       _ -> error $ "unexpected issue response: " <> T.unpack response
     r -> error $ "issue failed: " <> show (() <$ r)
@@ -313,11 +333,13 @@ testIssueRejectsBadArguments ps =
     refuses ""
     issueRaw cc "supporter 255 paid" >>= (`shouldSatisfy` isRight)
 
-issueRaw :: ChatController -> String -> IO (Either () ())
+-- | Left is a refusal or a failure the service answers as a command error.
+issueRaw :: HasCallStack => ChatController -> String -> IO (Either T.Text ())
 issueRaw cc args =
   sendChatCmdStr cc ("//issue " <> args) >>= \case
     Right CRCustomChatResponse {} -> pure $ Right ()
-    _ -> pure $ Left ()
+    Left (ChatError (CECommandError e)) -> pure (Left (T.pack e))
+    r -> error $ "issue failed: " <> show (() <$ r)
 
 testRedeemSecondCode :: HasCallStack => TestParams -> IO ()
 testRedeemSecondCode ps =
@@ -359,12 +381,16 @@ testRedeemSameCodeOtherProfile ps =
       showActiveUser alice "alice (Alice, * supporter)"
 
 serviceCmd :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse
-serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} purchaseKey request =
-  badgeServiceResponse bsIssuerKey bsController (Just purchaseKey) reqObject
-  where
-    reqObject = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of
-      J.Object o -> o
-      _ -> error "badge service request must encode as an object"
+serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} = serviceCmdWith bsIssuerKey bsController Nothing
+
+serviceCmdWith :: HasCallStack => BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse
+serviceCmdWith key cc trackerQ_ purchaseKey request =
+  badgeServiceResponse key cc trackerQ_ (Just purchaseKey) (requestObject purchaseKey request)
+
+requestObject :: HasCallStack => C.PublicKeyEd25519 -> BadgeServiceCommand -> J.Object
+requestObject purchaseKey request = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of
+  J.Object o -> o
+  _ -> error "badge service request must encode as an object"
 
 entryOf :: StatementEntry -> (Int, Int, UTCTime)
 entryOf StatementEntry {changeMonths, balanceMonths, balanceStartTs} = (changeMonths, balanceMonths, balanceStartTs)
@@ -387,6 +413,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 +433,17 @@ newPurchaseKeys = do
   (purchaseKey, _) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
   (purchaseKey,) <$> generateMasterKey g
 
+redeemAsNewPurchase :: HasCallStack => BadgeServiceEnv -> BadgeCode -> IO BadgeServiceResponse
+redeemAsNewPurchase BadgeServiceEnv {bsIssuerKey, bsController} = redeemWithQueue bsIssuerKey bsController Nothing . badgeCodeText
+
+redeemWithKeys :: HasCallStack => BadgeServiceEnv -> (C.PublicKeyEd25519, BadgeMasterKey) -> BadgeCode -> IO BadgeServiceResponse
+redeemWithKeys env (purchaseKey, masterKey) code = serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
+
+redeemWithQueue :: HasCallStack => BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> Text -> IO BadgeServiceResponse
+redeemWithQueue key cc trackerQ_ codeText = do
+  (purchaseKey, masterKey) <- newPurchaseKeys
+  serviceCmdWith key cc trackerQ_ purchaseKey BSCRedeemBadgeCode {masterKey, code = codeText}
+
 assertBalance :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> StatementEntry -> IO BadgeServiceResponse
 assertBalance env purchaseKey lastEntry =
   serviceCmd env purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry}}
@@ -403,6 +451,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 +461,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 +486,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)
+
+-- Multi-use codes come from the group command, and this service has no group.
+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 +572,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 +586,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 +597,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 +824,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` Right "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} ->
@@ -1319,7 +1518,7 @@ testRevokeRedeemedCode ps =
       alice <## "supporter badge - active"
       alice <##. "expires "
       refused <- revokeCodeAs cc code
-      refused `shouldSatisfy` T.isInfixOf "redeemed already, so it cannot be revoked"
+      refused `shouldBe` Left "Fully redeemed. It cannot be revoked."
       alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
       alice <## "badge already redeemed"
 
@@ -1329,15 +1528,34 @@ testRevokeUnknownCode ps =
     g <- C.newRandom
     code <- randomBadgeCode g
     unknown <- revokeCodeAs cc code
-    unknown `shouldSatisfy` T.isInfixOf "no such code"
+    unknown `shouldBe` Left "No such code."
 
 testRevokedCode :: HasCallStack => TestParams -> IO ()
 testRevokedCode ps =
   withBadgeService ps $ \clientCfg _ cc ->
     withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
       paid <- issueCodeAs cc BTSupporter 1 "paid"
-      revokeCodeAs cc paid `shouldReturn` "revoked"
+      revokeCodeAs cc paid `shouldReturn` Right "Revoked."
       alice ##> ("/_redeem_badge_code 1 " <> codeArg paid)
       alice <## "cannot redeem badge code: badge service error: code_invalid"
-      second <- revokeCodeAs cc paid
-      second `shouldSatisfy` T.isInfixOf "revoked already"
+      revokeCodeAs cc paid `shouldReturn` Right "Already revoked."
+
+testRevokedUnpaidCode :: HasCallStack => TestParams -> IO ()
+testRevokedUnpaidCode ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do
+    code <- issueCodeAs cc BTSupporter 1 "unpaid"
+    revokeCodeAs cc code `shouldReturn` Right "Revoked."
+    redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeInvalid)
+
+testRevokeRejectsTrailingInput :: HasCallStack => TestParams -> IO ()
+testRevokeRejectsTrailingInput ps =
+  withBadgeService ps $ \_ _ cc -> do
+    code <- issueCodeAs cc BTSupporter 1 "paid"
+    refused <- revokeRaw cc (formatBadgeCode code <> " junk")
+    -- If the refused call revoked the code anyway, this fails with "Already revoked.".
+    revokeCodeAs cc code `shouldReturn` Right "Revoked."
+    refused `shouldBe` Left badgeCmdUsage
+
+-- The text is spelled out rather than taken from the service, so a change there fails here.
+badgeCmdUsage :: Text
+badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke <code>"

tests/Bots/BadgeService/ConfigTests.hs

@@ -36,6 +36,7 @@ badgeConfigTests = describe "badge service config" $ do
   it "accepts a payment tolerance and refuses one that settles for a satoshi" testPaymentTolerance
   it "refuses a host that would send the api key in the clear" testHostMustBeHttps
   it "names a setting nothing reads, in every section it parses" testUnknownKeysAreNamed
+  it "ignores a section nothing reads rather than refusing the file" testUnknownSectionStillBoots
   it "refuses a file one malformed line would silently truncate" testMalformedLineRefused
   it "accepts a comment or blank line after the last setting" testTrailingCommentIsAccepted
   it "reports a missing file rather than throwing" testMissingFileIsReported
@@ -46,16 +47,17 @@ badgeConfigTests = describe "badge service config" $ do
   it "refuses an index that is not a positive whole number" testIssuerIndexInvalid
   it "refuses a private key that is not a valid issuer secret" testIssuerBadSecret
   it "names the old default and key_<n> settings, then refuses the boot" testIssuerOldFormat
-  it "leaves chat redemption off when the dev section is absent" testDevRedeemAbsent
-  it "reads chat_redeem = on" testDevRedeemOn
-  it "reads chat_redeem = off" testDevRedeemOff
-  it "refuses a chat_redeem that is not on or off" testDevRedeemNotBoolean
+  groupConfigTests
 
 fullIni :: T.Text
 fullIni =
   T.unlines
     [ "[listener]",
       "static_dir = /srv/badges",
+      -- [group] stays before [btcpay], since tests append btcpay keys to this fixture.
+      "[group]",
+      "display_name = SimpleX Badges",
+      "description = badge ops desk",
       "[btcpay]",
       "host = https://btcpay.example.org",
       "api_key = token-value",
@@ -224,19 +226,25 @@ testExpiryMinutes = do
 
 testUnknownKeysAreNamed :: IO ()
 testUnknownKeysAreNamed =
-  withIni (fullIni <> "speed_polcy = LowSpeed\ntrust_forwaded_for = on\n[poll]\nwaiting_secnds = 5\n[dev]\nchat_redem = on\n") $ \p -> do
+  withIni (fullIni <> "speed_polcy = LowSpeed\ntrust_forwaded_for = on\n[poll]\nwaiting_secnds = 5\n[stripe]\nsecret_ky = rk_test_x\n") $ \p -> do
     Right ini <- readIniFile p
-    unknownKeys ini `shouldMatchList` ["btcpay.speed_polcy", "btcpay.trust_forwaded_for", "poll.waiting_secnds", "dev.chat_redem"]
+    unknownKeys ini `shouldMatchList` ["btcpay.speed_polcy", "btcpay.trust_forwaded_for", "poll.waiting_secnds", "stripe.secret_ky"]
     withIni (T.replace "[btcpay]" "[btcpai]" fullIni) $ \wrongSection -> do
       Right sectionIni <- readIniFile wrongSection
       unknownKeys sectionIni `shouldContain` ["[btcpai]"]
-    withIni ("chat_redeem = on\n" <> fullIni) $ \stray -> do
+    withIni ("static_dir = /srv/badges\n" <> fullIni) $ \stray -> do
       Right strayIni <- readIniFile stray
-      unknownKeys strayIni `shouldContain` ["chat_redeem, written above the first section header"]
+      unknownKeys strayIni `shouldContain` ["static_dir, written above the first section header"]
     withIni fullIni $ \clean -> do
       Right cleanIni <- readIniFile clean
       unknownKeys cleanIni `shouldBe` []
 
+testUnknownSectionStillBoots :: IO ()
+testUnknownSectionStillBoots =
+  parseIni (fullIni <> "[legacy]\nsetting = on\n") >>= \r -> case r of
+    Right cfg -> lStaticDir (listener cfg) `shouldBe` "/srv/badges"
+    Left e -> expectationFailure ("a section nothing reads must be ignored, not refused: " <> e)
+
 -- | The ini parser stops at the first line it cannot read and keeps what it has, so without this a
 -- missing `=` in [listener] would silently drop every section below it, and the provider with it.
 testMalformedLineRefused :: IO ()
@@ -252,7 +260,7 @@ testTrailingCommentIsAccepted :: IO ()
 testTrailingCommentIsAccepted = do
   accepts (fullIni <> "; rotated the api key on 2026-09-01\n")
   accepts (fullIni <> "\n\n")
-  accepts (fullIni <> "[dev]\n; chat_redeem = on\n")
+  accepts (fullIni <> "[poll]\n; idle_seconds = 5\n")
   accepts (fullIni <> "# a hash comment, with no newline after it")
   where
     accepts t =
@@ -345,25 +353,58 @@ testIssuerOldFormat = do
     unknownKeys ini `shouldMatchList` ["issuer.default", "issuer.key_1"]
   issuerRefusal old `shouldReturn` "issuer.index is required"
 
-testDevRedeemAbsent :: IO ()
-testDevRedeemAbsent = withIni fullIni $ \p -> do
-  Right cfg <- readServiceConfig p
-  devChatRedeem cfg `shouldBe` False
+parseIni :: T.Text -> IO (Either String ServiceConfig)
+parseIni t = withIni t readServiceConfig
 
-testDevRedeemOn :: IO ()
-testDevRedeemOn = withDev "chat_redeem = on\n" $ \r -> case r of
-  Right cfg -> devChatRedeem cfg `shouldBe` True
-  Left e -> expectationFailure ("[dev] chat_redeem = on is legal: " <> e)
+groupConfigTests :: Spec
+groupConfigTests = describe "group config" $ do
+  it "parses display_name and description" testGroupNameAndDescription
+  it "defaults description to Nothing" testGroupNoDescription
+  it "treats a blank description as absent" testGroupBlankDescription
+  it "refuses a display_name no group can be created under" testGroupInvalidName
+  it "suggests no name when no character of display_name is valid" testGroupNoValidName
+  it "requires display_name when the section is present" testGroupMissingName
+  it "leaves group Nothing when the section is absent" testGroupAbsent
 
-testDevRedeemOff :: IO ()
-testDevRedeemOff = withDev "chat_redeem = off\n" $ \r -> case r of
-  Right cfg -> devChatRedeem cfg `shouldBe` False
-  Left e -> expectationFailure ("[dev] chat_redeem = off is legal: " <> e)
+listenerIni :: T.Text
+listenerIni = "[listener]\nstatic_dir = /srv/web\n"
 
-testDevRedeemNotBoolean :: IO ()
-testDevRedeemNotBoolean = withDev "chat_redeem = true\n" $ \r -> case r of
-  Left e -> e `shouldContain` "chat_redeem"
-  Right _ -> expectationFailure "only on and off are accepted, so a typo cannot silently disarm the gate"
+groupIni :: T.Text -> IO (Either String ServiceConfig)
+groupIni body = parseIni (listenerIni <> "[group]\n" <> body)
 
-withDev :: T.Text -> (Either String ServiceConfig -> IO a) -> IO a
-withDev keys act = withIni (fullIni <> "[dev]\n" <> keys) $ \p -> readServiceConfig p >>= act
+testGroupNameAndDescription :: IO ()
+testGroupNameAndDescription = do
+  r <- groupIni "display_name = SimpleX Badges\ndescription = Welcome\n"
+  fmap group r `shouldBe` Right (Just GroupConfig {gDisplayName = "SimpleX Badges", gDescription = Just "Welcome"})
+
+testGroupNoDescription :: IO ()
+testGroupNoDescription = do
+  r <- groupIni "display_name = X\n"
+  fmap group r `shouldBe` Right (Just GroupConfig {gDisplayName = "X", gDescription = Nothing})
+
+testGroupBlankDescription :: IO ()
+testGroupBlankDescription = do
+  r <- groupIni "display_name = X\ndescription =    \n"
+  fmap group r `shouldBe` Right (Just GroupConfig {gDisplayName = "X", gDescription = Nothing})
+
+testGroupInvalidName :: IO ()
+testGroupInvalidName = do
+  r <- groupIni "display_name = Значки (staging)\n"
+  case r of
+    Left e -> e `shouldBe` "group.display_name \"Значки (staging)\" is not a valid group name, the closest valid name is \"Значки staging\""
+    Right cfg -> expectationFailure ("a name the core refuses must not boot, and this one kept " <> show (group cfg))
+
+testGroupNoValidName :: IO ()
+testGroupNoValidName = do
+  r <- groupIni "display_name = !!!\n"
+  fmap group r `shouldBe` Left "group.display_name \"!!!\" is not a valid group name"
+
+testGroupMissingName :: IO ()
+testGroupMissingName = do
+  r <- groupIni "description = hi\n"
+  fmap group r `shouldBe` Left "group.display_name is required"
+
+testGroupAbsent :: IO ()
+testGroupAbsent = do
+  r <- parseIni listenerIni
+  fmap group r `shouldBe` Right Nothing

tests/Bots/BadgeService/GroupTests.hs

@@ -0,0 +1,175 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.BadgeService.GroupTests where
+
+import BadgeService.Config (GroupConfig (..))
+import BadgeService.Group (GroupAction (..), GroupEvent (..), TrackerAction (..), coalesceTrackerRefreshes, inertGroupConfig, noOwnerHint, orphanHint, trackerDecision)
+import BadgeService.Group.Command
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Calendar (fromGregorian)
+import Data.Time.Clock (UTCTime (..), addUTCTime)
+import Simplex.Chat.Badges (BadgeType (..))
+import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeText, randomBadgeCode)
+import Simplex.Chat.Controller (ChatCommand (DeleteGroup, MemberRole))
+import Simplex.Chat.Library.Commands (parseChatCommand)
+import Simplex.Chat.Types (GroupProfile (..))
+import Simplex.Chat.Types.Shared (GroupMemberRole (..))
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Util (tshow)
+import Test.Hspec
+
+badgeGroupTests :: Spec
+badgeGroupTests = describe "badge group" $ do
+  let p = groupCmdAction GROwner
+      issueUsage = ReplyText "Usage: /issue <type> [months <M>] [uses <N>]"
+      bulkUsage = ReplyText "Usage: /bulk <type> [months <M>] count <B>"
+      revokeUsage = ReplyText "Usage: /revoke <code>"
+  it "issue defaults" $ p "/issue supporter" `shouldBe` RunCmd (GCIssue BTSupporter 1 1)
+  it "issue with months and uses" $ p "/issue legend months 6 uses 50" `shouldBe` RunCmd (GCIssue BTLegend 6 50)
+  it "bulk with count" $ p "/bulk supporter count 20" `shouldBe` RunCmd (GCBulk BTSupporter 1 20)
+  it "rejects values past the upper bounds" $ do
+    p "/issue supporter uses 1001" `shouldBe` issueUsage
+    p "/bulk supporter count 101" `shouldBe` bulkUsage
+    p "/issue supporter months 256" `shouldBe` issueUsage
+  it "rejects zero values" $ do
+    p "/bulk supporter count 0" `shouldBe` bulkUsage
+    p "/issue supporter months 0" `shouldBe` issueUsage
+  it "rejects values past the machine word" $ do
+    let past64 = tshow (2 ^ (64 :: Int) + 1 :: Integer)
+    p ("/issue supporter uses " <> past64) `shouldBe` issueUsage
+    p ("/bulk supporter count " <> past64) `shouldBe` bulkUsage
+    p ("/issue supporter months " <> past64) `shouldBe` issueUsage
+  it "accepts the upper bounds" $ do
+    p "/issue supporter uses 1000" `shouldBe` RunCmd (GCIssue BTSupporter 1 1000)
+    p "/bulk supporter count 100" `shouldBe` RunCmd (GCBulk BTSupporter 1 100)
+    p "/issue supporter months 255" `shouldBe` RunCmd (GCIssue BTSupporter 255 1)
+  it "revoke" $ do
+    code <- newCode
+    p ("/revoke " <> badgeCodeText code) `shouldBe` RunCmd (GCRevoke code)
+  it "authorization, per role, as (issue, bulk, revoke)" $ do
+    someCode <- newCode
+    let runs role t = case groupCmdAction role t of
+          RunCmd _ -> True
+          _ -> False
+        allowed role =
+          ( runs role "/issue supporter",
+            runs role "/bulk supporter count 1",
+            runs role ("/revoke " <> badgeCodeText someCode)
+          )
+        roles = [GRUnknown "future", GRRelay, GRObserver, GRAuthor, GRMember, GRModerator, GRAdmin, GROwner]
+    map (\role -> (role, allowed role)) roles
+      `shouldBe` [ (GRUnknown "future", (False, False, False)),
+                   (GRRelay, (False, False, False)),
+                   (GRObserver, (False, False, False)),
+                   (GRAuthor, (False, False, False)),
+                   (GRMember, (False, False, False)),
+                   (GRModerator, (True, True, False)),
+                   (GRAdmin, (True, True, True)),
+                   (GROwner, (True, True, True))
+                 ]
+  describe "log hints give commands --run-cli parses for a group name with a space" $ do
+    let hintCommand = fst . T.breakOn " in --run-cli" . snd . T.breakOnEnd " with "
+        parsedHint hint = let cmd = hintCommand hint in (cmd, parseChatCommand (encodeUtf8 cmd))
+    it "owner" $
+      case parsedHint (T.replace "<member>" "alice" $ noOwnerHint "SimpleX Badges_1") of
+        (_, Right (MemberRole g m GROwner)) -> (g, m) `shouldBe` ("SimpleX Badges_1", "alice")
+        (cmd, r) -> expectationFailure $ "owner command " <> show cmd <> " parsed as " <> show r
+    it "orphan group" $
+      case parsedHint (orphanHint "SimpleX Badges_1") of
+        (_, Right (DeleteGroup g)) -> g `shouldBe` "SimpleX Badges_1"
+        (cmd, r) -> expectationFailure $ "delete command " <> show cmd <> " parsed as " <> show r
+  describe "classifying a group message" $ do
+    it "answers an advertised command that does not parse" $ do
+      map p
+        [ "/issue",
+          "/issue supporter uses 0",
+          "/issue supporter 3",
+          "/issue suporter",
+          "/issue supporter  uses 5",
+          "/bulk supporter",
+          "/revoke",
+          "/revoke not-a-badge-code"
+        ]
+        `shouldBe` replicate 5 issueUsage <> [bulkUsage, revokeUsage, revokeUsage]
+    it "answers a mistyped command only to a sender who may run it" $ do
+      map (`groupCmdAction` "/issue supporter uses 0") [GRMember, GRModerator, GRAdmin]
+        `shouldBe` [IgnoreMsg, issueUsage, issueUsage]
+      map (`groupCmdAction` "/bulk supporter") [GRMember, GRModerator, GRAdmin]
+        `shouldBe` [IgnoreMsg, bulkUsage, bulkUsage]
+      map (`groupCmdAction` "/revoke not-a-badge-code") [GRMember, GRModerator, GRAdmin]
+        `shouldBe` [IgnoreMsg, IgnoreMsg, revokeUsage]
+    it "accepts a command padded with whitespace" $ do
+      p " /issue supporter " `shouldBe` RunCmd (GCIssue BTSupporter 1 1)
+      p "\t/bulk supporter count 1" `shouldBe` RunCmd (GCBulk BTSupporter 1 1)
+    it "says nothing to anything that is not an advertised command" $
+      map p ["", "hello", "issue supporter", "/issued supporter", "/help", "see /issue above"]
+        `shouldBe` replicate 6 IgnoreMsg
+    it "says nothing to a command the sender may not run" $ do
+      map (`groupCmdAction` "/issue supporter") [GRMember, GRAuthor] `shouldBe` [IgnoreMsg, IgnoreMsg]
+      groupCmdAction GRMember "/bulk supporter count 1" `shouldBe` IgnoreMsg
+    it "tells a sender below admin that their revoke did not happen" $ do
+      code <- newCode
+      map (`groupCmdAction` ("/revoke " <> badgeCodeText code)) [GRMember, GRModerator]
+        `shouldBe` replicate 2 (ReplyText "Only admins can revoke codes. This code is now visible to all members.")
+  describe "configured group name and description" $ do
+    let cfg name descr = GroupConfig {gDisplayName = name, gDescription = descr}
+        profile name descr =
+          GroupProfile
+            { displayName = name,
+              fullName = "",
+              shortDescr = Nothing,
+              description = descr,
+              image = Nothing,
+              publicGroup = Nothing,
+              groupPreferences = Nothing,
+              memberAdmission = Nothing
+            }
+    it "says nothing when the config matches the group profile" $ do
+      inertGroupConfig (cfg "SimpleX Badges" (Just "badge ops desk")) (profile "SimpleX Badges" (Just "badge ops desk"))
+        `shouldBe` Nothing
+      inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" Nothing) `shouldBe` Nothing
+    it "says nothing when an omitted description meets an empty one" $
+      inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" (Just "")) `shouldBe` Nothing
+    it "reports a name the config would change" $
+      inertGroupConfig (cfg "SimpleX Badges 2026" (Just "badge ops desk")) (profile "SimpleX Badges" (Just "badge ops desk"))
+        `shouldBe` Just "badge group config is not applied to an existing group: display_name \"SimpleX Badges 2026\", group has \"SimpleX Badges\""
+    it "shows a non-ASCII name as written" $
+      inertGroupConfig (cfg "Значки" Nothing) (profile "SimpleX Badges" Nothing)
+        `shouldBe` Just "badge group config is not applied to an existing group: display_name \"Значки\", group has \"SimpleX Badges\""
+    it "reports a description the config would change or remove" $ do
+      inertGroupConfig (cfg "SimpleX Badges" (Just "new desk")) (profile "SimpleX Badges" (Just "badge ops desk"))
+        `shouldBe` Just "badge group config is not applied to an existing group: description \"new desk\", group has \"badge ops desk\""
+      inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" (Just "badge ops desk"))
+        `shouldBe` Just "badge group config is not applied to an existing group: description \"\", group has \"badge ops desk\""
+    it "reports both fields when both would change" $
+      inertGroupConfig (cfg "SimpleX Badges 2026" (Just "new desk")) (profile "SimpleX Badges" Nothing)
+        `shouldBe` Just
+          "badge group config is not applied to an existing group: \
+          \display_name \"SimpleX Badges 2026\", group has \"SimpleX Badges\"; \
+          \description \"new desk\", group has \"\""
+  describe "tracker" $
+    it "edits within 24h, reposts after" $ do
+      let t0 = UTCTime (fromGregorian 2026 1 1) 0
+          within = addUTCTime (23 * 3600) t0
+          past = addUTCTime (25 * 3600) t0
+      trackerDecision within t0 `shouldBe` Edit
+      trackerDecision past t0 `shouldBe` Repost
+  describe "coalescing tracker refreshes" $ do
+    it "keeps the last refresh of each code" $ do
+      code1 <- newCode
+      code2 <- newCode
+      coalesceTrackerRefreshes [GETracker 1 code1, GETracker 2 code2, GETracker 1 code1]
+        `shouldBe` [GETracker 2 code2, GETracker 1 code1]
+    it "keeps every other event, in order" $ do
+      code <- newCode
+      coalesceTrackerRefreshes
+        [ GEInGroup 7 (GACommand GRAdmin "a"),
+          GETracker 1 code,
+          GEInGroup 7 GAJoined,
+          GETracker 1 code
+        ]
+        `shouldBe` [GEInGroup 7 (GACommand GRAdmin "a"), GEInGroup 7 GAJoined, GETracker 1 code]
+
+newCode :: IO BadgeCode
+newCode = C.newRandom >>= randomBadgeCode

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 (..), ManagedGroup (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, getManagedGroup, insertBadgeCode, insertManagedGroup, markOwnerBootstrapped, 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.List (sort, sortOn)
+import Data.Int (Int64)
+import Data.List (isInfixOf, 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 and the group table" 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,15 @@ 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 "managed group" $ do
+    it "round-trips and bootstraps once" testManagedGroupRoundTripsAndBootstrapsOnce
+    it "refuses a second row and burns the flag per group" testManagedGroupIsSingleRow
+  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" 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
@@ -302,6 +318,59 @@ 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", "group_item_id", "group_item_sent_at"])
+  columnsOf st "sx_badge_service_group"
+    >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["group_id", "group_link", "owner_bootstrapped", "created_at"])
+
+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` []
+  columnsOf st "sx_badge_service_group" `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"
@@ -464,25 +533,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
+  revoke "revoked-first" `shouldReturn` Revoked revokedFirst
   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 partlyUsed
+  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"
@@ -616,6 +695,103 @@ testTimestampRoundTrip = withServiceStore $ \st -> do
   irExpiresAt row `shouldBe` truncated
   irCreatedAt row `shouldBe` truncated
 
+testManagedGroupRoundTripsAndBootstrapsOnce :: IO ()
+testManagedGroupRoundTripsAndBootstrapsOnce = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  beforeInsert <- withTransaction st getManagedGroup
+  beforeInsert `shouldBe` Nothing
+  withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now
+  afterInsert <- withTransaction st getManagedGroup
+  afterInsert `shouldBe` Just ManagedGroup {mgGroupId = 42, mgGroupLink = "https://link", mgOwnerBootstrapped = False}
+  show afterInsert `shouldNotSatisfy` ("https://link" `isInfixOf`)
+  firstMark <- withTransaction st (`markOwnerBootstrapped` 42)
+  secondMark <- withTransaction st (`markOwnerBootstrapped` 42)
+  (firstMark, secondMark) `shouldBe` (True, False)
+
+testManagedGroupIsSingleRow :: IO ()
+testManagedGroupIsSingleRow = withServiceStore $ \st -> do
+  now <- truncateToSecond <$> getCurrentTime
+  withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now
+  withTransaction st $ \db -> insertManagedGroup db 43 "https://other" now
+  withTransaction st $ \db -> insertManagedGroup db 42 "https://again" now
+  managedGroupRows st `shouldReturn` [(42, "https://link")]
+  withTransaction st (`markOwnerBootstrapped` 43) `shouldReturn` False
+  (fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just False
+  withTransaction st (`markOwnerBootstrapped` 42) `shouldReturn` True
+  (fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just True
+
+managedGroupRows :: DBStore -> IO [(Int64, Text)]
+managedGroupRows st =
+  withConnection st $ \db -> DB.query_ db "SELECT group_id, group_link FROM sx_badge_service_group ORDER BY group_id"
+
+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)
+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
+  length (catMaybes results) `shouldBe` 3
+  codeCounts st codeHash `shouldReturn` Just (3, 3)
+
 data StubCall
   = StubCreate ServicePaymentMethod OrderDraft
   | StubRead Text
@@ -802,7 +978,7 @@ testServiceConfig staticDir trustForwarded =
       stripe = Nothing,
       poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60},
       issuer = Nothing,
-      devChatRedeem = False
+      group = Nothing
     }
 
 testServeWebappOff :: IO ()

tests/ChatTests/Profiles.hs

@@ -20,7 +20,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay)
-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import qualified Data.Map.Strict as M
 import Simplex.Chat.Badges (BadgeCredential, BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment)
@@ -284,11 +284,13 @@ futureDate = posixSecondsToUTCTime 4102444800 -- 2100-01-01
 issueTestBadge :: BBSSecretKey -> UTCTime -> IO BadgeCredential
 issueTestBadge sk = issueTestBadgeType sk BTSupporter
 
+-- The expiry is signed as written but PostgreSQL stores it to the microsecond, so it is cut to whole seconds, as the service issues it.
 issueTestBadgeType :: BBSSecretKey -> BadgeType -> UTCTime -> IO BadgeCredential
-issueTestBadgeType sk badgeType badgeExpiry = do
+issueTestBadgeType sk badgeType expiry = do
   drg <- C.newRandom
   mk <- generateMasterKey drg
-  let info = BadgeInfo {badgeType, badgeExpiry, badgeExtra = ""}
+  let badgeExpiry = posixSecondsToUTCTime $ fromInteger $ truncate $ utcTimeToPOSIXSeconds expiry
+      info = BadgeInfo {badgeType, badgeExpiry, badgeExtra = ""}
   Just vreq <- verifyPayment (BPRedeemCode "TEST") BadgeRequest {masterKey = mk, badgeInfo = info}
   Right cred <- issueBadge 1 sk vreq
   pure cred

tests/Test.hs

@@ -7,6 +7,8 @@ import Bots.BadgeService.BTCPayTests
 import Bots.BadgeService.BotTests
 import Bots.BadgeService.CatalogTests
 import Bots.BadgeService.ConfigTests
+import Bots.BadgeService.GroupIntegrationTests
+import Bots.BadgeService.GroupTests
 import Bots.BadgeService.StripeTests
 import Bots.BadgeService.WaitersTests
 import Bots.BadgeService.WebTests
@@ -74,6 +76,7 @@ main = do
         badgeConfigTests
         badgeWebTests
         badgeCatalogTests
+        badgeGroupTests
         badgeWaitersTests
         badgeBTCPayTests
         badgeStripeTests
@@ -102,7 +105,9 @@ main = do
           describe "SimpleX chat client" chatTests
           xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
           xdescribe'' "SimpleX Directory service bot" directoryServiceTests
-          xdescribe'' "SimpleX badge service e2e" badgeServiceTests
+          xdescribe'' "SimpleX badge service e2e" $ do
+            badgeServiceTests
+            describe "managed group" badgeGroupIntegrationTests
           describe "Remote session" remoteTests
 #if !defined(dbPostgres)
           xdescribe'' "Save query plans" saveQueryPlans