badges: add the managed group

tests/Bots/BadgeService/BotTests.hs

@@ -12,6 +12,7 @@ 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
@@ -23,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
@@ -47,7 +48,7 @@ import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, endOf
 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
@@ -79,16 +80,18 @@ 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" testMultiUseWithoutGroup
+  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
@@ -115,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"
@@ -137,7 +143,7 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey =
                 {dbFilePrefix = ps </> serviceDbPrefix}
 #endif
           },
-      serviceName = "SimpleX Badges",
+      serviceName = badgeBotName,
       clientService = True,
       noAddress = False,
       runCLI = False,
@@ -202,11 +208,15 @@ 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
@@ -323,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 =
@@ -369,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)
@@ -418,11 +434,16 @@ newPurchaseKeys = do
   (purchaseKey,) <$> generateMasterKey g
 
 redeemAsNewPurchase :: HasCallStack => BadgeServiceEnv -> BadgeCode -> IO BadgeServiceResponse
-redeemAsNewPurchase env code = newPurchaseKeys >>= \keys -> redeemWithKeys env keys code
+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}}
@@ -525,7 +546,7 @@ testUnreadableCredentialIsInternal ps =
     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.
+-- 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
@@ -810,7 +831,7 @@ testRevokedMultiUseHolderRenews ps =
       code <- issueMultiUseCode cc BTSupporter 3 2
       redeemFirstBadge alice code
       redeemed <- ledgerRows (chatController alice) "badge_ledger"
-      revokeCodeAs cc code `shouldReturn` "revoked"
+      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.
@@ -1497,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 "code was redeemed already, so it cannot be revoked"
       alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
       alice <## "badge already redeemed"
 
@@ -1507,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 = "use: //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,177 @@
+{-# 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 "use: /issue <type> [months <M>] [uses <N>]"
+      bulkUsage = ReplyText "use: /bulk <type> [months <M>] count <B>"
+      revokeUsage = ReplyText "use: /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, and this code is now visible to the group - ask an admin to revoke it")
+  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 one refresh per code, carrying the highest claim" $ do
+      code <- newCode
+      coalesceTrackerRefreshes [GETracker 1 code 1, GETracker 1 code 3, GETracker 2 code 1]
+        `shouldBe` [GETracker 1 code 3, GETracker 2 code 1]
+    it "keeps the highest claim whichever order it queued in" $ do
+      code <- newCode
+      coalesceTrackerRefreshes [GETracker 1 code 3, GETracker 1 code 1] `shouldBe` [GETracker 1 code 3]
+    it "keeps every other event, in order" $ do
+      code <- newCode
+      coalesceTrackerRefreshes
+        [ GEInGroup 7 (GACommand GRAdmin "a"),
+          GETracker 1 code 1,
+          GEInGroup 7 GAJoined,
+          GETracker 1 code 2
+        ]
+        `shouldBe` [GEInGroup 7 (GACommand GRAdmin "a"), GEInGroup 7 GAJoined, GETracker 1 code 2]
+
+newCode :: IO BadgeCode
+newCode = C.newRandom >>= randomBadgeCode

tests/Bots/BadgeService/WebTests.hs

@@ -14,7 +14,7 @@ import BadgeService.Poller
 import BadgeService.Providers
 import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages)
 import BadgeService.Providers.Stripe (stripeProvider)
-import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, 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
@@ -42,7 +42,7 @@ 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 Data.List (isInfixOf, sort, sortOn)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (catMaybes, isJust, isNothing, fromMaybe, mapMaybe)
 import Data.Text (Text)
@@ -138,7 +138,7 @@ 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 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
@@ -154,6 +154,9 @@ badgeWebTests = do
     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, each a distinct count" testMultiUseConcurrentClaimsUpToLimit
@@ -321,7 +324,9 @@ 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"])
+    >>= (`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)
@@ -336,6 +341,7 @@ testSchemaDownUpCycle = withServiceStore $ \st -> do
   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
 
@@ -532,7 +538,7 @@ testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do
       redeem badgeCodeId = claimUse st badgeCodeId now keys
       revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
   revokedFirst <- newCode "revoked-first"
-  revoke "revoked-first" `shouldReturn` Revoked
+  revoke "revoked-first" `shouldReturn` Revoked revokedFirst
   redeem revokedFirst `shouldReturn` Nothing
   codeCounts st "revoked-first" `shouldReturn` Just (1, 0)
   redeemedFirst <- newCode "redeemed-first"
@@ -549,7 +555,7 @@ testRevokeMultiUseCode = withServiceStore $ \st -> do
       revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
   partlyUsed <- newCode "partly-used"
   isJust <$> redeem partlyUsed `shouldReturn` True
-  revoke "partly-used" `shouldReturn` Revoked
+  revoke "partly-used" `shouldReturn` Revoked partlyUsed
   redeem partlyUsed `shouldReturn` Nothing
   usedUp <- newCode "used-up"
   isJust <$> redeem usedUp `shouldReturn` True
@@ -689,6 +695,35 @@ 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
@@ -943,7 +978,7 @@ testServiceConfig staticDir trustForwarded =
       stripe = Nothing,
       poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60},
       issuer = Nothing,
-      devChatRedeem = False
+      group = Nothing
     }
 
 testServeWebappOff :: IO ()

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