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

apps/simplex-badge-service/Main.hs

@@ -5,13 +5,19 @@ module Main where
 import BadgeService.Options (BadgeServiceOpts (..))
 import BadgeService.Service
 import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
+import GHC.IO.Encoding (setLocaleEncoding)
 import Simplex.Chat.Terminal (terminalChatConfig)
+import System.IO (hSetEncoding, stderr, stdout, utf8)
 
 -- | withGlobalLogging installs the SMP agent's log sinks, which the chat core otherwise installs only under --log-agent.
 main :: IO ()
-main = withGlobalLogging LogConfig {lc_file = Nothing, lc_stderr = True} $ do
-  setLogLevel LogWarn
-  opts@BadgeServiceOpts {runCLI} <- welcomeGetOpts
-  if runCLI
-    then badgeServiceCLI opts
-    else newServiceState >>= badgeService opts terminalChatConfig
+main = do
+  -- Without a UTF-8 locale GHC reads the ini and writes logs as ASCII, and throws on a non-ASCII group name.
+  setLocaleEncoding utf8
+  mapM_ (`hSetEncoding` utf8) [stdout, stderr]
+  withGlobalLogging LogConfig {lc_file = Nothing, lc_stderr = True} $ do
+    setLogLevel LogWarn
+    opts@BadgeServiceOpts {runCLI} <- welcomeGetOpts
+    if runCLI
+      then badgeServiceCLI opts
+      else newServiceState >>= badgeService opts terminalChatConfig

apps/simplex-badge-service/README.md

@@ -21,8 +21,10 @@ At this stage the service:
 
 - creates a double-ratchet contact address on first start (service RPC requires DR, see [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md)),
 - listens for service requests (`CEvtServiceRequest`) on that address, rejects a request whose `purchaseKey` is not the key the agent verified the signature against, and answers `redeemBadgeCode`,
-- issues redemption codes, storing only their `SHA-256` and printing each code once,
-- does not accept contact requests unless `[dev] chat_redeem` is on: the address is for RPC only,
+- issues redemption codes, storing only their `SHA-256` in its code table,
+- does not accept contact requests: the address is for RPC only,
+- in service mode with `[group]` in the ini, manages one SimpleX group and serves `/issue`, `/bulk`
+  and `/revoke` in it (see [Issuing codes](#issuing-codes)),
 - in service mode with `--service-config`, also serves the built web app (`npm run build` in `web/`), `POST /api/invoice` and `GET /api/invoice/:id`, the BTCPay and Stripe webhook routes, and a payment poller, seeding its price/offer catalog on every start,
 - owns the `sx_badge_service_`-prefixed tables and its own migrations table (`sx_badge_service_migrations`).
 
@@ -47,8 +49,9 @@ simplex-badge-service --help
 - default (no `--run-cli`): background service mode, no interactive terminal.
 - `--run-cli`: interactive CLI that also processes service requests (mirrors
   `simplex-directory-service --run-cli`). This mode is the chat/RPC side and the `//` commands
-  below: it starts no web listener and no poller, and `[dev] chat_redeem` does not apply to it,
-  whatever `--service-config` says.
+  below: it starts no web listener and no poller, and serves no group commands, whatever
+  `--service-config` says. It still updates a code's group message when the code is redeemed or
+  revoked.
 - `--no-address`: skip address creation on start-up (for operators who provision the address themselves).
 The service cannot sign credentials without an issuer key and refuses to start without one:
 
@@ -92,7 +95,9 @@ Other options:
 
 `badge_service.ini` holds the listener bind address and `static_dir`, an optional
 `[btcpay]` section (omitting it disables Bitcoin and Monero), an optional `[stripe]`
-section (omitting it disables card payments) and the poll cadence.
+section (omitting it disables card payments), an optional `[group]` section (omitting it
+turns off the group's commands, though a group created earlier still has its code messages updated)
+and the poll cadence.
 `badge_service.ini.example` is the committed template; `badge_service.ini` itself is
 gitignored, since a real one holds API keys and webhook secrets.
 
@@ -203,27 +208,15 @@ the exception: each answers 200, 400 or 413 with an empty body, because its prov
 caller and nothing it could read would change what the route does. A wrong verb on any route, those
 two included, answers `method_not_allowed`.
 
-### Redeeming over chat, for local testing
-
-```ini
-[dev]
-chat_redeem = on
-```
-
-With this on, the service accepts contact requests and answers `/redeem <code>` from a contact
-with the credential as one-line JSON, ready to paste into a client as `/badge add <json>`. Off by
-default, and only `on`/`off` parse, so a typo cannot silently arm it. It applies to the service
-mode only; `--run-cli` ignores it.
-
-Keep it off anywhere real. The service RPC signs over a master key only the client holds; here
-there is no client key, so the service generates one and hands it over with the credential, which
-means it can link every badge it issues this way. `simplex-chat badge sign` has the same property
-and is the offline equivalent.
-
 ## Issuing codes
 
-Issuing a code is an operator command sent to the running service in `--run-cli` mode, not a way
-to start it — so codes are issued without a second process touching the service's database:
+Operators issue codes two ways: from the service's own command line in `--run-cli` mode, and from the
+managed group in service mode. Both are commands to a running process, so no second process
+touches the service's database.
+
+### From the command line
+
+The command is sent to the running service in `--run-cli` mode, not a way to start it:
 
 ```
 //issue <badge_type> [months] [paid|unpaid|free]
@@ -245,8 +238,76 @@ A code that leaked, or that was refunded, is withdrawn the same way:
 ```
 
 A revoked code answers redemption with `code_invalid`, as if it had never existed, so its holder
-learns nothing from trying. Revoking is not repeatable: the second attempt says so. A code that
-was already redeemed cannot be revoked: its badge was issued, and the command answers with an error.
+learns nothing from trying. A client that redeemed it before the revoke still gets its own badge
+back when it asks again. Revoking it again answers "already revoked" and fixes its group
+message if the first revoke didn't. A code with no uses left can't be revoked, because its badges
+were already given out, and the command answers with an error. A multi-use code with uses left can
+be revoked, which stops the uses that remain.
 
 Core parses `//...` into `CustomChatCommand` and leaves it to the service's `preCmdHook`, which is
 why issuing codes lives in the service rather than in core.
+
+### From the group
+
+With `[group]` in `badge_service.ini`, the service manages one group and serves three commands in
+it: `/issue <type> [months <M>] [uses <N>]` and `/bulk <type> [months <M>] count <B>` for moderators
+and above, `/revoke <code>` for admins and owners. `months` is 1 to 255, `uses` 1 to 1000 and
+`count` 1 to 100; a value outside these gets the usage reply. A member's role is checked as the
+service last saw it, so a command sent by a moderator just demoted or removed can still run if it
+reaches the service first; revoke any code the service posts for them after the change. `uses`
+above 1 makes a multi-use code, tracked by a group message showing its remaining uses and the time
+of the last one; when every use is redeemed, the same message says so. Every reply carrying a code is read by every member,
+since the group has no private lane, so a code issued there is only as private as its least trusted
+member.
+Those replies are also kept as plain text in the service's chat database, so a copy of the database
+holds every code issued in the group. Keep the group's visible history off: with it on, each new
+member receives recent messages, and the codes in them, when they join. A multi-use code's message
+carries the code, and every redemption edits it or, after a day, posts it again; either way every
+current member receives it, so a member who joined after the code was issued gets the code while it
+still has uses left. A message replaced by a new post stays in the group with its old count. Keep
+disappearing messages off in the group and set no message TTL for the service's chats: a code's
+message that expires is treated as deleted and never posted again, so its counter stops.
+Every member can see when each use of a multi-use code was redeemed: the message shows the time of
+the last one, and its edit times show the rest.
+`/revoke <code>` names the code in an ordinary group message, so every member holds it before the
+service reads the command, and the code stays redeemable until the service acts on it — for the
+whole of any downtime. Revoke a code that is not already public in the group, a refunded one above
+all, with `//revoke` in `--run-cli` mode. A `/revoke <code>` with nothing after the code, from a
+member below admin, is answered that the code was not revoked and is now visible to the group. A
+group command the service received but had not run when it stopped, or received while it ran in
+`--run-cli` mode, is dropped with no reply, so resend it, or use `//revoke`.
+
+The first member to join through the link is promoted to owner, so the operator joins before sharing
+it. Keep the service an owner too: below owner it cannot update the group's command menu, and below
+author it cannot post codes or replies. A failed promotion is logged at once, and an owner who left
+is logged at the next start or join. Then make the member you choose owner with the `/mr` command
+that the log line names, in `--run-cli` mode; the service never promotes anyone once the first
+promotion was attempted.
+
+The join link logged when the group is created stays valid: anyone who has it can join later, as a
+member, and read every code posted or edited from then on. That includes a removed member, who can
+rejoin through it, so removing a member does not stop them seeing new codes. Keep the log that holds
+it private. The link is also stored in the `group_link` column of `sx_badge_service_group`, where it
+can be read again.
+
+If an owner deletes the group, or removes the service from it, the service logs an error on start
+and stops serving the group. To create a new group, stop the service, delete the row, and start it
+again: with SQLite, run `DELETE FROM sx_badge_service_group;` on the `<prefix>_chat.db` file
+(`~/.simplex/simplex_badge_service_chat.db` by default), opened with `sqlcipher` and the database key
+if one is set; with PostgreSQL, run
+`DELETE FROM <schema-prefix>_chat_schema.sx_badge_service_group;` (`simplex_v1_chat_schema` by default).
+Multi-use codes issued in the old group stay redeemable, but their messages there are no longer
+updated, so revoke with `//revoke` any that should not stay live.
+
+The group is identified by the single `sx_badge_service_group` row. Rolling back past the
+`20260918_badge_group_ops` migration drops that table, so a later re-upgrade creates a second group
+and orphans the first one with its members and roles; multi-use codes come back single-use with
+their claims re-derived, and outstanding trackers come back unanchored. Redeemed credentials are
+preserved and no code becomes redeemable again, though while the old version runs, only the holder
+whose credential ends last gets it back on a retry, and any other holder of a multi-use code gets
+`code_used`; every holder of a revoked code gets `code_invalid`. Rolling back means re-creating and
+re-sharing the group; delete the orphaned one with `/d #'<old local name>'` in `--run-cli` mode, as its
+join link still works and its messages hold every code posted there.
+
+The configured `display_name` and `description` apply only to the group the service creates. Editing
+them later is logged as not applied and changes nothing.

apps/simplex-badge-service/badge_service.ini.example

@@ -50,7 +50,13 @@ idle_seconds = 60
 ;index = 1
 ;private_key = replace-me
 
-; local testing only: signs a credential for anyone who sends /redeem <code> over chat,
-; with a master key this service generates and can therefore link
-[dev]
-chat_redeem = off
+; optional: when present the service manages one group, created on its first start without
+; --run-cli, and logs its join link once, on the start that creates it. The link is a bearer
+; secret that stays valid, so keep that log private. The first member to join is promoted to
+; owner, so join right away.
+; moderators can /issue and /bulk codes; admins and owners can also /revoke.
+; display_name must be a name the chat core accepts unchanged: one it would spell
+; differently stops the whole service, payments included, from starting.
+;[group]
+;display_name = SimpleX Badges
+;description = Welcome to the badges group

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

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module BadgeService.Codes
+  ( issueOneCode,
+    issueFailedText,
+    revokeBadgeCode,
+    singleUse,
+  )
+where
+
+import BadgeService.Store (RevokeResult, insertBadgeCode, revokeCode)
+import BadgeService.Store.Invoices (truncateToSecond)
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Simplex.Chat.Badges (BadgeType)
+import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, randomBadgeCode)
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus)
+import Simplex.Chat.Bot.Store (withDB')
+import Simplex.Chat.Controller (ChatController (..))
+
+singleUse :: Int
+singleUse = 1
+
+revokeBadgeCode :: ChatController -> BadgeCode -> IO (Either String RevokeResult)
+revokeBadgeCode cc code = do
+  now <- truncateToSecond <$> getCurrentTime
+  withDB' "revokeBadgeCode" cc $ \db -> revokeCode db (badgeCodeHash code) now
+
+-- | The group is joined through a bearer link, so this reply names no database error.
+issueFailedText :: Text
+issueFailedText = "The code could not be issued."
+
+-- | The code table keeps only the hash, so the caller must deliver the code.
+issueOneCode :: ChatController -> BadgeType -> Int -> BadgeCodePaymentStatus -> Int -> IO (Either String (BadgeCode, Int64))
+issueOneCode cc badgeType months paymentStatus redeemLimit = do
+  code <- randomBadgeCode $ random cc
+  now <- truncateToSecond <$> getCurrentTime
+  fmap (code,) <$> withDB' "issueBadgeCode" cc (\db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus redeemLimit now)

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

@@ -11,6 +11,7 @@ module BadgeService.Config
     speedPolicyName,
     PollConfig (..),
     BadgeIssuerKey (..),
+    GroupConfig (..),
     ServiceConfig (..),
     defaultExpiryMinutes,
     defaultSessionMinutes,
@@ -21,12 +22,15 @@ where
 
 import qualified Control.Exception as E
 import BadgeService.Log (logWarn)
+import Control.Monad (mfilter)
 import Data.Attoparsec.Text (Parser, endOfInput, isEndOfLine, parseOnly, satisfy, skipMany, skipSpace, skipWhile)
 import qualified Data.ByteString.Char8 as B
 import Data.Ini (Ini, iniGlobals, iniParser, keys, lookupValue, sections)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
+import Simplex.Chat.Library.Commands (mkValidName)
 import Simplex.Messaging.Crypto.BBS (BBSSecretKey)
 import Simplex.Messaging.Encoding.String (strDecode)
 import System.IO.Error (ioeGetErrorString)
@@ -97,14 +101,19 @@ data BadgeIssuerKey = BadgeIssuerKey
 instance Show BadgeIssuerKey where
   show BadgeIssuerKey {keyIdx} = "issuer key " <> show keyIdx
 
+data GroupConfig = GroupConfig
+  { gDisplayName :: Text,
+    gDescription :: Maybe Text
+  }
+  deriving (Eq, Show)
+
 data ServiceConfig = ServiceConfig
   { listener :: ListenerConfig,
     btcpay :: Maybe BTCPayConfig,
     stripe :: Maybe StripeConfig,
     poll :: PollConfig,
     issuer :: Maybe BadgeIssuerKey,
-    -- Local testing only; signs credentials with a master key this service can link.
-    devChatRedeem :: Bool
+    group :: Maybe GroupConfig
   }
   deriving (Eq, Show)
 
@@ -155,7 +164,7 @@ knownSettings =
     ("btcpay", ["host", "api_key", "store_id", "webhook_secret", "expiry_minutes", "speed_policy", "payment_tolerance"]),
     ("stripe", ["secret_key", "publishable_key", "webhook_secret", "session_minutes"]),
     ("poll", ["waiting_seconds", "idle_seconds"]),
-    ("dev", ["chat_redeem"]),
+    ("group", ["display_name", "description"]),
     ("issuer", ["index", "private_key"])
   ]
 
@@ -179,16 +188,14 @@ parseConfig ini = do
     p <- num "listener" "port" 8080
     if 1 <= p && p <= 65535 then Right p else Left "listener.port must be between 1 and 65535"
   lServeWebapp <- bool "listener" "serve_webapp" True
-  let lWebappExportDir = case fmap T.strip (look "listener" "webapp_export_dir") of
-        Just v | not (T.null v) -> Just (T.unpack v)
-        _ -> Nothing
+  let lWebappExportDir = T.unpack <$> present "listener" "webapp_export_dir"
   lTrustForwardedFor <- bool "listener" "trust_forwarded_for" False
   btc <- btcpaySection
   str <- stripeSection
   iss <- issuerSection
+  grp <- groupSection
   pWaitingSeconds <- cadence "waiting_seconds" 3
   pIdleSeconds <- cadence "idle_seconds" 60
-  devRedeem <- bool "dev" "chat_redeem" False
   pure
     ServiceConfig
       { listener = ListenerConfig {lHost, lPort, lStaticDir, lServeWebapp, lWebappExportDir, lTrustForwardedFor},
@@ -196,17 +203,14 @@ parseConfig ini = do
         stripe = str,
         poll = PollConfig {pWaitingSeconds, pIdleSeconds},
         issuer = iss,
-        devChatRedeem = devRedeem
+        group = grp
       }
   where
     hasSection s = s `elem` sections ini
     look s k = either (const Nothing) Just (lookupValue s k ini)
-    required s k = case look s k of
-      Just v | not (T.null (T.strip v)) -> Right (T.strip v)
-      _ -> Left (T.unpack s <> "." <> T.unpack k <> " is required")
-    optional s k d = case fmap T.strip (look s k) of
-      Just v | not (T.null v) -> Right v
-      _ -> Right d
+    present s k = mfilter (not . T.null) (T.strip <$> look s k)
+    required s k = maybe (Left (T.unpack s <> "." <> T.unpack k <> " is required")) Right (present s k)
+    optional s k d = Right (fromMaybe d (present s k))
     -- Integer, because readMaybe at Int wraps silently, reading 2^64+4 as 4.
     num s k d = case look s k of
       Nothing -> Right d
@@ -268,6 +272,20 @@ parseConfig ini = do
       Just v -> case readMaybe (T.unpack (T.strip v)) of
         Just d | d >= 0 && d <= maxTolerance -> Right d
         _ -> Left ("btcpay.payment_tolerance must be a percentage between 0 and " <> show maxTolerance)
+    groupSection
+      | not (hasSection "group") = Right Nothing
+      | otherwise = do
+          gDisplayName <- required "group" "display_name" >>= validGroupName
+          pure (Just GroupConfig {gDisplayName, gDescription = present "group" "description"})
+    -- The core refuses a group name that mkValidName would change, so it is rejected here.
+    validGroupName n =
+      let valid = T.pack (mkValidName (T.unpack n))
+       in if n == valid
+            then Right n
+            else Left ("group.display_name \"" <> T.unpack n <> "\" is not a valid group name" <> closest valid)
+    closest valid
+      | T.null valid = ""
+      | otherwise = ", the closest valid name is \"" <> T.unpack valid <> "\""
     stripeSection
       | not (hasSection "stripe") = Right Nothing
       | otherwise = do

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

@@ -0,0 +1,433 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
+module BadgeService.Group
+  ( ensureManagedGroup,
+    runGroupLane,
+    inertGroupConfig,
+    GroupEvent (..),
+    GroupAction (..),
+    groupEvent,
+    hasTracker,
+    refreshTracker,
+    revokeWithTracker,
+    coalesceTrackerRefreshes,
+    TrackerAction (..),
+    trackerDecision,
+    codeInTracker,
+    noOwnerHint,
+    orphanHint,
+  )
+where
+
+import BadgeService.Codes (issueFailedText, issueOneCode, revokeBadgeCode, singleUse)
+import BadgeService.Config (GroupConfig (..))
+import BadgeService.Group.Command (CmdAction (..), GroupCmd (..), groupCmdAction, groupCommands)
+import BadgeService.Log (logError, logInfo, logWarn)
+import BadgeService.Store (CodeTracker (..), ManagedGroup (..), RevokeResult (..), clearCodeGroupItems, getCodeTracker, getEditableTrackers, getManagedGroup, insertManagedGroup, markOwnerBootstrapped, setCodeGroupItem)
+import BadgeService.Store.Invoices (truncateToSecond)
+import Control.Concurrent.STM (TQueue, atomically, flushTQueue, readTQueue, readTVarIO, writeTQueue)
+import Control.Monad (forM_, forever, mfilter, replicateM, unless, void)
+import Control.Monad.Except (runExceptT)
+import Data.Either (partitionEithers)
+import Data.Functor (($>), (<&>))
+import Data.Int (Int64)
+import Data.List (sortOn)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import GHC.Stack (HasCallStack, withFrozenCallStack)
+import Simplex.Chat.Badges.Code (BadgeCode, formatBadgeCode, parseBadgeCode)
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
+import Simplex.Chat.Bot.Store (withDB')
+import Simplex.Chat.Controller
+import Simplex.Chat.Core (sendChatCmd)
+import Simplex.Chat.Markdown (viewName)
+import Simplex.Chat.Messages
+import Simplex.Chat.Messages.CIContent (CIContent (..), ciContentToText)
+import Simplex.Chat.Protocol (MsgContent (..))
+import Simplex.Chat.Store.Messages (getGroupChatItem)
+import Simplex.Chat.Store.Shared (StoreError (..))
+import Simplex.Chat.Types
+import Simplex.Chat.Types.Preferences (GroupPreferences (..), commands_, emptyGroupPrefs)
+import Simplex.Chat.Types.Shared (GroupMemberRole (..))
+import Simplex.Chat.View (simplexChatContact)
+import Simplex.Messaging.Agent.Protocol (CreatedConnLink (..), UserId)
+import Simplex.Messaging.Encoding.String (StrEncoding, strEncode)
+import Simplex.Messaging.Util (catchOwn', safeDecodeUtf8, tshow, ($>>=))
+import System.Exit (exitFailure)
+
+buildGroupProfile :: GroupConfig -> GroupProfile
+buildGroupProfile GroupConfig {gDisplayName, gDescription} =
+  GroupProfile
+    { displayName = gDisplayName,
+      fullName = "",
+      shortDescr = Nothing,
+      description = gDescription,
+      image = Nothing,
+      publicGroup = Nothing,
+      groupPreferences = Just (emptyGroupPrefs {commands = Just groupCommands} :: GroupPreferences),
+      memberAdmission = Nothing
+    }
+
+ensureManagedGroup :: ChatController -> GroupConfig -> IO (Maybe GroupId)
+ensureManagedGroup cc gc =
+  withDB' "getManagedGroup" cc getManagedGroup >>= \case
+    -- A read error must not fall through to create, which would orphan a second group.
+    -- The service stops instead, so a restart retries rather than leaving the group unserved.
+    Left _ -> logError "badge group lookup failed, stopping" >> exitFailure
+    -- The join link is a bearer secret, logged only where it is created.
+    Right (Just ManagedGroup {mgGroupId}) ->
+      sendChatCmd cc (APIGroupInfo mgGroupId) >>= \case
+        Right CRGroupInfo {groupInfo = GroupInfo {membership, groupProfile = p}}
+          | memberCurrent membership -> do
+              forM_ (inertGroupConfig gc p) logWarn
+              unless (commandsCurrent p) $ advertiseCommands cc mgGroupId p
+              logInfo "badge group ready"
+              pure (Just mgGroupId)
+          | otherwise -> groupGone
+        Left (ChatErrorStore SEGroupNotFound {}) -> groupGone
+        r -> do
+          logError ("badge group info failed: " <> tshow r)
+          pure (Just mgGroupId)
+    Right Nothing ->
+      readTVarIO (currentUser cc) >>= \case
+        Nothing -> logError "badge group not created: no current user" >> pure Nothing
+        Just User {userId} -> createManagedGroup cc gc userId
+  where
+    groupGone = do
+      logError "badge group was deleted or the service was removed from it; delete the sx_badge_service_group row and restart to create a new group"
+      pure Nothing
+
+createManagedGroup :: ChatController -> GroupConfig -> UserId -> IO (Maybe GroupId)
+createManagedGroup cc gc userId =
+  sendChatCmd cc (APINewGroup userId False (buildGroupProfile gc)) >>= \case
+    Right CRGroupCreated {groupInfo = g@GroupInfo {groupId}} ->
+      sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case
+        Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact}} -> do
+          now <- truncateToSecond <$> getCurrentTime
+          let linkText = groupLinkText connLinkContact
+          withDB' "insertManagedGroup" cc (\db -> insertManagedGroup db groupId linkText now >> clearCodeGroupItems db) >>= \case
+            Right () -> do
+              logInfo $ "badge group created, join link: " <> linkText
+              pure (Just groupId)
+            Left _ -> logError ("badge group " <> tshow groupId <> " not recorded - " <> orphanHint (groupName' g)) >> pure Nothing
+        r -> logError ("badge group " <> tshow groupId <> " link failed: " <> tshow r <> " - " <> orphanHint (groupName' g)) >> pure Nothing
+    r -> logError ("badge group creation failed: " <> tshow r) >> pure Nothing
+
+-- The next start creates another group, so a partly created one is left for the operator to delete.
+orphanHint :: GroupName -> Text
+orphanHint gName = "delete this orphan group with /d #" <> viewName gName <> " in --run-cli mode"
+
+-- An existing group gets the current commands, so an upgrade that changes them reaches its members.
+commandsCurrent :: GroupProfile -> Bool
+commandsCurrent groupProfile = (groupPreferences groupProfile >>= commands_) == Just groupCommands
+
+advertiseCommands :: ChatController -> GroupId -> GroupProfile -> IO ()
+advertiseCommands cc groupId groupProfile =
+  sendChatCmd cc (APIUpdateGroupProfile groupId p') >>= \case
+    Right CRGroupUpdated {} -> logInfo "badge group commands advertised"
+    r -> logError ("badge group profile update failed: " <> tshow r)
+  where
+    prefs = fromMaybe emptyGroupPrefs (groupPreferences groupProfile)
+    p' = groupProfile {groupPreferences = Just (prefs {commands = Just groupCommands} :: GroupPreferences)}
+
+-- Config is applied only at creation, since a group rename is broadcast to every member.
+inertGroupConfig :: GroupConfig -> GroupProfile -> Maybe Text
+inertGroupConfig GroupConfig {gDisplayName, gDescription} GroupProfile {displayName, description}
+  | null diverged = Nothing
+  | otherwise = Just $ "badge group config is not applied to an existing group: " <> T.intercalate "; " diverged
+  where
+    diverged =
+      [ field <> " \"" <> configured <> "\", group has \"" <> live <> "\""
+        | (field, configured, live) <-
+            [ ("display_name", gDisplayName, displayName),
+              ("description", fromMaybe "" gDescription, fromMaybe "" description)
+            ],
+          configured /= live
+      ]
+
+groupLinkText :: CreatedLinkContact -> Text
+groupLinkText (CCLink cReq sLnk_) = maybe (strEncodeTxt (simplexChatContact cReq)) strEncodeTxt sLnk_
+
+strEncodeTxt :: StrEncoding a => a -> Text
+strEncodeTxt = safeDecodeUtf8 . strEncode
+
+data GroupEvent
+  = GEInGroup GroupId GroupAction
+  | GETracker Int64 BadgeCode
+  deriving (Eq, Show)
+
+data GroupAction
+  = GAJoined
+  | GACommand GroupMemberRole Text
+  deriving (Eq, Show)
+
+-- Support-scope, moderated or blocked, and live items are ignored: the reply would go to the main group,
+-- moderation or blocking without Full Delete keeps the content, and a live item holds only partial text.
+groupEvent :: ChatEvent -> Maybe GroupEvent
+groupEvent = \case
+  CEvtJoinedGroupMember {groupInfo = GroupInfo {groupId}} -> Just $ GEInGroup groupId GAJoined
+  CEvtNewChatItems {chatItems = AChatItem _ _ (GroupChat GroupInfo {groupId} scope) ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent (MCText t), meta = CIMeta {itemDeleted, itemLive}} : _}
+    | isNothing scope && isNothing itemDeleted && itemLive /= Just True -> Just $ GEInGroup groupId (GACommand (memberRole' m) t)
+  _ -> Nothing
+
+-- A refresh reads the code's count when it runs, so the last one queued shows every claim before it.
+coalesceTrackerRefreshes :: [GroupEvent] -> [GroupEvent]
+coalesceTrackerRefreshes = snd . foldr keepLast (S.empty, [])
+  where
+    keepLast ev (seen, kept) = case ev of
+      GETracker badgeCodeId _
+        | badgeCodeId `S.member` seen -> (seen, kept)
+        | otherwise -> (S.insert badgeCodeId seen, ev : kept)
+      _ -> (seen, ev : kept)
+
+logUncaught :: HasCallStack => IO () -> IO ()
+logUncaught a = a `catchOwn'` withFrozenCallStack (logError . tshow)
+
+handleGroupEvent :: ChatController -> GroupId -> GroupEvent -> IO ()
+handleGroupEvent cc groupId ev = logUncaught (handle ev)
+  where
+    handle = \case
+      GEInGroup gid action
+        | gid /= groupId -> pure ()
+        | otherwise -> case action of
+            GAJoined -> promoteOwner cc groupId
+            GACommand role t -> case groupCmdAction role t of
+              RunCmd cmd -> runGroupCmd cc groupId cmd
+              ReplyText txt -> void $ sendGroupText cc groupId "command reply" txt
+              IgnoreMsg -> pure ()
+      GETracker badgeCodeId code -> updateTracker cc groupId badgeCodeId code
+
+promoteFirstOwner :: ChatController -> GroupInfo -> GroupMember -> IO ()
+promoteFirstOwner cc g@GroupInfo {groupId} member =
+  -- The flag is set before promoting, so a retry cannot promote a second owner.
+  withDB' "markOwnerBootstrapped" cc (`markOwnerBootstrapped` groupId) >>= \case
+    Right True ->
+      sendChatCmd cc (APIMembersRole groupId (groupMemberId' member :| []) GROwner) >>= \case
+        -- The core returns no members when every store update failed.
+        Right CRMembersRoleUser {members = _ : _} -> logInfo $ "badge group owner promoted: member " <> tshow (groupMemberId' member)
+        r -> logError $ "badge group owner promotion failed: " <> tshow r <> " - " <> noOwnerHint (groupName' g)
+    _ -> pure ()
+
+-- Nothing is a group that is not served, so its events are drained.
+runGroupLane :: ChatController -> TQueue GroupEvent -> Maybe GroupId -> IO ()
+runGroupLane cc q groupId_ = case groupId_ of
+  Just groupId -> do
+    promoteOwner cc groupId
+    -- Reconciling precedes the first batch, so queued events write after the correction.
+    reconcileTrackers cc groupId
+    forever $ do
+      evs <- atomically $ (:) <$> readTQueue q <*> flushTQueue q
+      mapM_ (handleGroupEvent cc groupId) (coalesceTrackerRefreshes evs)
+  Nothing -> forever $ void $ atomically (readTQueue q)
+
+-- The earliest joined member is promoted, not the one who just joined, so a join the lane never handled
+-- (under --run-cli, or lost in a crash) or a failed attempt never hands the group to a later joiner.
+promoteOwner :: ChatController -> GroupId -> IO ()
+promoteOwner cc groupId =
+  withDB' "getManagedGroup" cc getManagedGroup >>= \case
+    Right (Just ManagedGroup {mgOwnerBootstrapped}) ->
+      sendChatCmd cc (APIListMembers groupId) >>= \case
+        Right CRGroupMembers {group = Group {groupInfo, members}}
+          -- An owner made by hand only needs the flag set, or promoting would add a second owner.
+          | any (\m -> memberRole' m == GROwner && memberCurrent m) members ->
+              unless mgOwnerBootstrapped $ void $ withDB' "markOwnerBootstrapped" cc (`markOwnerBootstrapped` groupId)
+          -- A crash between setting the flag and promoting leaves no owner, and only the operator may retry.
+          | mgOwnerBootstrapped -> logError $ noOwnerHint (groupName' groupInfo)
+          | otherwise -> mapM_ (promoteFirstOwner cc groupInfo) $ listToMaybe $ sortOn groupMemberId' $ filter joined members
+        r -> logError $ "badge group members not listed: " <> tshow r
+    _ -> pure ()
+  where
+    -- A member still joining cannot act yet, so it is not a candidate.
+    joined m = memberStatus m `elem` [GSMemConnected, GSMemComplete]
+
+-- The live local name, quoted as --run-cli parses it, can differ from the configured one after a name clash or a rename.
+noOwnerHint :: GroupName -> Text
+noOwnerHint gName = "the badge group has no member owner, make one with /mr #" <> viewName gName <> " <member> owner in --run-cli mode"
+
+runGroupCmd :: ChatController -> GroupId -> GroupCmd -> IO ()
+runGroupCmd cc groupId = \case
+  GCIssue bt months uses ->
+    issueOneCode cc bt months CPSFree uses >>= \case
+      Left _ -> reply issueFailedText
+      Right (code, badgeCodeId)
+        | not (hasTracker uses) -> reply ("Code: " <> formatBadgeCode code)
+        | otherwise -> do
+            now <- truncateToSecond <$> getCurrentTime
+            sendGroupText cc groupId ("tracker, code " <> tshow badgeCodeId <> " is lost") (initialTrackerBody code uses)
+              >>= mapM_ (\iid -> withDB' "setCodeGroupItem" cc $ \db -> setCodeGroupItem db badgeCodeId iid now)
+  GCBulk bt months count -> do
+    codes <- replicateM count (issueOneCode cc bt months CPSFree singleUse)
+    let (errs, ok) = partitionEithers codes
+        issued = map (formatBadgeCode . fst) ok
+    reply . T.intercalate "\n" $ case errs of
+      [] -> issued
+      _ : _ -> issued <> ["Issued " <> tshow (length issued) <> " of " <> tshow count <> " codes. The remaining codes could not be issued."]
+  -- Naming the code tells concurrent revokes apart; the command already made it public.
+  GCRevoke code -> do
+    outcome <- either id id <$> revokeWithTracker cc code
+    reply (formatBadgeCode code <> ": " <> outcome)
+  where
+    reply = void . sendGroupText cc groupId "reply, any codes in it are lost"
+
+-- The label says what is lost when the send fails, since the log line is its only trace.
+sendGroupText :: HasCallStack => ChatController -> GroupId -> Text -> Text -> IO (Maybe ChatItemId)
+sendGroupText cc groupId label txt =
+  sendChatCmd cc (APISendMessages (SRGroup groupId Nothing False) False Nothing False (ComposedMessage Nothing Nothing (MCText txt) M.empty :| [])) >>= \case
+    Right CRNewChatItems {chatItems = ci : _} -> pure (Just (aChatItemId ci))
+    r -> withFrozenCallStack logError ("badge group message not sent (" <> label <> "): " <> tshow r) $> Nothing
+
+initialTrackerBody :: BadgeCode -> Int -> Text
+initialTrackerBody code total = trackerBody code total total Nothing
+
+-- The body is dated by the last redemption, not now, because reconcile rewrites it after a restart.
+-- The code is green only while it can still be redeemed.
+trackerBody :: BadgeCode -> Int -> Int -> Maybe UTCTime -> Text
+trackerBody code remaining total redeemedAt
+  | remaining > 0 = "!2 " <> formatBadgeCode code <> "!\n" <> tshow remaining <> " of " <> tshow total <> " uses remaining" <> lastUsed
+  | otherwise = formatBadgeCode code <> "\nAll " <> tshow total <> " uses redeemed" <> lastUsed
+  where
+    lastUsed = maybe "" ((", last used " <>) . fmtTime) redeemedAt
+
+revokedBody :: BadgeCode -> Text
+revokedBody code = formatBadgeCode code <> "\nRevoked, can no longer be redeemed"
+
+fmtTime :: UTCTime -> Text
+fmtTime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC"
+
+data TrackerAction = Edit | Repost
+  deriving (Eq, Show)
+
+-- The core refuses to edit a sent message older than this.
+editWindow :: NominalDiffTime
+editWindow = nominalDay
+
+trackerDecision :: UTCTime -> UTCTime -> TrackerAction
+trackerDecision now sentAt
+  | diffUTCTime now sentAt < editWindow = Edit
+  | otherwise = Repost
+
+-- A repost publishes the code a second time, so the reconcile pass may only edit.
+data RepostPolicy = MayRepost | EditOnly
+
+-- A deleted or moderated tracker is not reposted, because deleting it does not revoke the code.
+setTrackerBody :: ChatController -> GroupId -> Int64 -> RepostPolicy -> (CodeTracker -> Maybe Text) -> IO ()
+setTrackerBody cc groupId badgeCodeId policy mkBody =
+  withDB' "getCodeTracker" cc (`getCodeTracker` badgeCodeId) >>= \case
+    Right (Just tracker@CodeTracker {trackerItemId, trackerSentAt}) ->
+      forM_ (mkBody tracker) $ \body -> do
+        now <- truncateToSecond <$> getCurrentTime
+        let repost =
+              trackerItemText cc groupId trackerItemId >>= \case
+                Nothing -> logWarn $ "badge group tracker not reposted, code " <> tshow badgeCodeId <> " is no longer published"
+                -- Past the window every write reposts, so an unchanged body is not posted again.
+                Just current ->
+                  unless (current == body) $
+                    sendGroupText cc groupId ("tracker repost, code " <> tshow badgeCodeId <> " keeps its old message") body
+                      >>= mapM_ (\i -> withDB' "setCodeGroupItem" cc (\db -> setCodeGroupItem db badgeCodeId i now))
+            -- The core can also refuse an edit inside the window, because it uses the message's own timestamp.
+            uneditable = case policy of
+              MayRepost -> repost
+              EditOnly -> logWarn $ "badge group tracker left uncorrected, code " <> tshow badgeCodeId <> " can no longer be edited"
+        case trackerDecision now trackerSentAt of
+          Edit ->
+            sendChatCmd cc (APIUpdateChatItem (ChatRef CTGroup groupId Nothing) trackerItemId False (UpdatedMessage (MCText body) M.empty)) >>= \case
+              Right CRChatItemUpdated {} -> pure ()
+              Right CRChatItemNotChanged {} -> pure ()
+              Left (ChatError CEInvalidChatItemUpdate) -> uneditable
+              -- Any other failure may still have applied the edit, so a repost could publish the code twice.
+              r -> logError $ "badge group tracker not updated, code " <> tshow badgeCodeId <> ": " <> tshow r
+          Repost -> uneditable
+    _ -> pure ()
+
+-- A revoke and a redemption can arrive in either order, so a revoked tracker is left alone.
+counterBody :: BadgeCode -> CodeTracker -> Maybe Text
+counterBody code CodeTracker {redeemCount, redeemLimit, revokedAt, redeemedAt}
+  | isJust revokedAt = Nothing
+  | otherwise = Just $ trackerBody code (redeemLimit - redeemCount) redeemLimit redeemedAt
+
+hasTracker :: Int -> Bool
+hasTracker redeemLimit = redeemLimit > singleUse
+
+-- The tracker edit reaches every member, so the group lane runs it off the request path.
+-- Without a lane (--run-cli, or no [group]) it runs here, before the response.
+refreshTracker :: ChatController -> Maybe (TQueue GroupEvent) -> Int64 -> BadgeCode -> IO ()
+refreshTracker cc trackerQ_ badgeCodeId code = case trackerQ_ of
+  Just q -> atomically $ writeTQueue q (GETracker badgeCodeId code)
+  Nothing -> logUncaught $ withManagedGroup cc $ \groupId -> updateTracker cc groupId badgeCodeId code
+
+updateTracker :: ChatController -> GroupId -> Int64 -> BadgeCode -> IO ()
+updateTracker cc groupId badgeCodeId code = setTrackerBody cc groupId badgeCodeId MayRepost (counterBody code)
+
+-- | Left is a refusal or a failure; both sides are the text to show whoever sent the revoke.
+revokeWithTracker :: ChatController -> BadgeCode -> IO (Either Text Text)
+revokeWithTracker cc code =
+  revokeBadgeCode cc code >>= \case
+    -- The message is retired before the answer, so the answer never sits beside a live counter.
+    Right (Revoked badgeCodeId) -> Right "Revoked." <$ retire badgeCodeId
+    -- A repeated revoke repairs a message that an earlier revoke failed to update.
+    Right (AlreadyRevoked badgeCodeId) -> Right "Already revoked." <$ retire badgeCodeId
+    Right AlreadyRedeemed -> pure $ Left "Fully redeemed. It cannot be revoked."
+    Right NoSuchCode -> pure $ Left "No such code."
+    Left _ -> pure $ Left "The code could not be revoked."
+  where
+    retire badgeCodeId = logUncaught $ withManagedGroup cc $ \groupId ->
+      setTrackerBody cc groupId badgeCodeId MayRepost (const $ Just $ revokedBody code)
+
+withManagedGroup :: ChatController -> (GroupId -> IO ()) -> IO ()
+withManagedGroup cc action =
+  withDB' "getManagedGroup" cc getManagedGroup >>= \case
+    Right (Just ManagedGroup {mgGroupId}) -> action mgGroupId
+    _ -> pure ()
+
+-- A claim's refresh is queued after the claim commits, so a crash can drop it.
+reconcileTrackers :: ChatController -> GroupId -> IO ()
+reconcileTrackers cc groupId = do
+  editableAfter <- addUTCTime (-editWindow) <$> getCurrentTime
+  withDB' "getEditableTrackers" cc (`getEditableTrackers` editableAfter) >>= \case
+    Left _ -> logError "badge group trackers not reconciled: tracked code lookup failed"
+    Right codes -> forM_ codes $ \(badgeCodeId, itemId) -> logUncaught $ reconcileTracker cc groupId badgeCodeId itemId
+
+-- An unchanged edit still walks every member, so a tracker already showing the right text is skipped.
+reconcileTracker :: ChatController -> GroupId -> Int64 -> ChatItemId -> IO ()
+reconcileTracker cc groupId badgeCodeId itemId =
+  readTrackerCode cc groupId badgeCodeId itemId >>= mapM_ reconcile
+  where
+    reconcile (code, current) = setTrackerBody cc groupId badgeCodeId EditOnly (correctedBody code current)
+    -- A crash after a revoke committed can leave its tracker still counting, so a revoked code is retired here.
+    correctedBody code current tracker@CodeTracker {revokedAt} =
+      mfilter (/= current) $ if isJust revokedAt then Just (revokedBody code) else counterBody code tracker
+
+readTrackerCode :: ChatController -> GroupId -> Int64 -> ChatItemId -> IO (Maybe (BadgeCode, Text))
+readTrackerCode cc groupId badgeCodeId itemId =
+  trackerItemText cc groupId itemId >>= \case
+    Nothing -> do
+      logWarn $ "badge group tracker not read, code " <> tshow badgeCodeId
+      pure Nothing
+    Just current -> case codeInTracker current of
+      Nothing -> do
+        logError $ "badge group tracker carries no readable code, code " <> tshow badgeCodeId
+        pure Nothing
+      Just code -> pure (Just (code, current))
+
+codeInTracker :: Text -> Maybe BadgeCode
+codeInTracker = listToMaybe . mapMaybe parseBadgeCode . T.words
+
+-- The item is read from the store, because the core's item info also loads every edit and every member's delivery status.
+-- Moderation can keep a deleted item's content, so itemDeleted is checked.
+trackerItemText :: ChatController -> GroupId -> ChatItemId -> IO (Maybe Text)
+trackerItemText cc groupId itemId =
+  readTVarIO (currentUser cc) $>>= \user ->
+    withDB' "getGroupChatItem" cc (\db -> runExceptT $ getGroupChatItem db user groupId itemId) <&> \case
+      Right (Right (CChatItem _ ChatItem {content, meta = CIMeta {itemDeleted}})) | isNothing itemDeleted -> Just (ciContentToText content)
+      _ -> Nothing

apps/simplex-badge-service/src/BadgeService/Group/Command.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module BadgeService.Group.Command
+  ( GroupCmd (..),
+    CmdAction (..),
+    groupCmdAction,
+    groupCommands,
+    codeP,
+    badgeTypeP,
+    textTokenP,
+    maxMonths,
+    maxUses,
+  )
+where
+
+import Control.Applicative (optional, (<|>))
+import Control.Monad (void)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Char (isSpace)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Simplex.Chat.Badges (BadgeType (..))
+import Simplex.Chat.Badges.Code (BadgeCode, parseBadgeCode)
+import Simplex.Chat.Types.Preferences (ChatBotCommand (..))
+import Simplex.Chat.Types.Shared (GroupMemberRole (..))
+import Simplex.Messaging.Encoding.String (TextEncoding (..))
+import Simplex.Messaging.Util (safeDecodeUtf8)
+
+maxBulk, maxUses, maxMonths :: Int
+maxBulk = 100
+maxUses = 1000
+maxMonths = 255
+
+data GroupCmd
+  = GCIssue BadgeType Int Int
+  | GCBulk BadgeType Int Int
+  | GCRevoke BadgeCode
+  deriving (Eq, Show)
+
+data CmdAction
+  = RunCmd GroupCmd
+  | ReplyText Text
+  | IgnoreMsg
+  deriving (Eq, Show)
+
+groupCmdAction :: GroupMemberRole -> Text -> CmdAction
+groupCmdAction role t = case A.parseOnly cmdActionP (encodeUtf8 (T.strip t)) of
+  Right (tag, r)
+    | role >= cmdMinRole tag -> either ReplyText RunCmd r
+    | Right _ <- r, Just refusal <- cmdRefusal tag -> ReplyText refusal
+  _ -> IgnoreMsg
+
+-- | Left is the usage reply for an advertised command whose arguments do not parse.
+cmdActionP :: A.Parser (CmdTag, Either Text GroupCmd)
+cmdActionP = A.choice (map cmdP [minBound .. maxBound])
+  where
+    cmdP tag = (tag,) <$> (A.string ("/" <> encodeUtf8 (cmdName tag)) *> (Right <$> fullArgsP tag <|> Left (usage tag) <$ usageEndP))
+    fullArgsP tag = A.char ' ' *> cmdArgsP tag <* A.endOfInput
+    -- Without the space check "/issued" would get a usage reply.
+    usageEndP = void A.space <|> A.endOfInput
+    usage tag = "Usage: /" <> cmdName tag <> " " <> cmdParams tag
+
+cmdArgsP :: CmdTag -> A.Parser GroupCmd
+cmdArgsP = \case
+  CTIssue -> GCIssue <$> badgeTypeP <*> monthsOpt <*> keyOpt "uses" maxUses
+  CTBulk -> GCBulk <$> badgeTypeP <*> monthsOpt <*> (A.space *> keyValue "count" maxBulk)
+  CTRevoke -> GCRevoke <$> codeP
+  where
+    monthsOpt = keyOpt "months" maxMonths
+    keyOpt kw hi = fromMaybe 1 <$> optional (A.space *> keyValue kw hi)
+    keyValue kw hi = A.string kw *> A.space *> boundedInt kw hi
+
+groupCommands :: [ChatBotCommand]
+groupCommands = map command [minBound .. maxBound]
+  where
+    command tag = CBCCommand (cmdName tag) (cmdLabel tag) (Just (cmdParams tag))
+
+codeP :: A.Parser BadgeCode
+codeP = A.takeWhile1 (not . isSpace) >>= maybe (fail "not a badge code") pure . parseBadgeCode . safeDecodeUtf8
+
+-- attoparsec's decimal wraps silently at Int, so the bound is checked on the wider Integer.
+boundedInt :: ByteString -> Int -> A.Parser Int
+boundedInt kw hi = do
+  n <- A.decimal :: A.Parser Integer
+  if n >= 1 && n <= fromIntegral hi
+    then pure (fromInteger n)
+    else fail (B.unpack kw <> " out of range")
+
+-- BadgeType decodes anything to BTUnknown, so a typo would issue an unusable code.
+badgeTypeP :: A.Parser BadgeType
+badgeTypeP =
+  textTokenP >>= \case
+    BTUnknown t -> fail $ "unknown badge type " <> T.unpack t
+    bt -> pure bt
+
+textTokenP :: TextEncoding a => A.Parser a
+textTokenP = do
+  t <- A.takeWhile1 (not . isSpace)
+  maybe (fail "invalid value") pure $ textDecode $ safeDecodeUtf8 t
+
+-- The advertised menu lists the commands in this order.
+data CmdTag = CTIssue | CTBulk | CTRevoke
+  deriving (Bounded, Enum)
+
+cmdName :: CmdTag -> Text
+cmdName = \case
+  CTIssue -> "issue"
+  CTBulk -> "bulk"
+  CTRevoke -> "revoke"
+
+cmdLabel :: CmdTag -> Text
+cmdLabel = \case
+  CTIssue -> "Generate a badge code"
+  CTBulk -> "Generate many single-use codes"
+  CTRevoke -> "Revoke a code"
+
+-- | The parameters are quoted in the usage reply and advertised to the group, so the two cannot drift apart.
+cmdParams :: CmdTag -> Text
+cmdParams = \case
+  CTIssue -> "<type> [months <M>] [uses <N>]"
+  CTBulk -> "<type> [months <M>] count <B>"
+  CTRevoke -> "<code>"
+
+cmdMinRole :: CmdTag -> GroupMemberRole
+cmdMinRole = \case
+  CTIssue -> GRModerator
+  CTBulk -> GRModerator
+  CTRevoke -> GRAdmin
+
+-- | This is the reply to a well-formed command from a sender who may not run it; Nothing means silence.
+cmdRefusal :: CmdTag -> Maybe Text
+cmdRefusal = \case
+  CTIssue -> Nothing
+  CTBulk -> Nothing
+  -- The sender has just published a code that stays redeemable, so they must learn it was not revoked.
+  CTRevoke -> Just "Only admins can revoke codes. This code is now visible to all members."

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

@@ -1,6 +1,4 @@
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -21,7 +19,10 @@ module BadgeService.Service
 where
 
 import BadgeService.Catalog (defaultCatalog)
+import BadgeService.Codes (issueFailedText, issueOneCode, singleUse)
 import BadgeService.Config (BadgeIssuerKey (..), ServiceConfig (..), readServiceConfig)
+import BadgeService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane)
+import BadgeService.Group.Command (badgeTypeP, codeP, maxMonths, textTokenP)
 import BadgeService.Options
 import BadgeService.Poller (newPollerEnv, newReadHints, runPoller)
 import BadgeService.Providers.BTCPay (btcpayProvider)
@@ -33,19 +34,17 @@ import BadgeService.Waiters (Waiters, newWaiters)
 import BadgeService.Web.Server (exportWebapp, newWebEnv, runWebListener)
 import Control.Applicative (optional)
 import Control.Concurrent.STM
-import BadgeService.Log (logError, logInfo, logWarn)
+import BadgeService.Log (logError, logInfo)
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Char (isSpace)
 import Data.Either (fromRight)
-import Data.Functor (($>))
+import Data.Functor (($>), (<&>))
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, maybeToList)
+import Data.Maybe (fromMaybe, isJust, maybeToList)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Word (Word32)
@@ -54,20 +53,18 @@ import Simplex.Chat.Badges.Code
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
-import Simplex.Chat.Bot (initializeBotAddress', sendMessage)
+import Simplex.Chat.Bot (initializeBotAddress')
 import Simplex.Chat.Bot.Store (withDB, withDB')
 import Simplex.Chat.Controller
 import Simplex.Chat.Core (sendChatCmd, simplexChatCore)
-import Simplex.Chat.Messages
-import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..), ciContentToText)
 import Simplex.Chat.Options (printDbOpts)
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
-import Simplex.Chat.Types (AgentInvId (..), Contact, User (..))
+import Simplex.Chat.Types (AgentInvId (..), User (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (bbsPublicKey)
-import Simplex.Messaging.Encoding.String (TextEncoding, strEncode, textDecode, textEncode)
+import Simplex.Messaging.Encoding.String (strEncode)
 import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow)
 import Simplex.Messaging.Version (isCompatible)
 import System.Directory (getAppUserDataDirectory)
@@ -76,15 +73,15 @@ import System.Exit (exitFailure)
 data ServiceState = ServiceState
   { serviceCC :: TMVar ChatController,
     serviceRequestQ :: TQueue (User, AgentInvId, Maybe C.PublicKeyEd25519, J.Object),
-    chatRedeemQ :: TQueue (Contact, T.Text)
+    groupEventQ :: TQueue GroupEvent
   }
 
 newServiceState :: IO ServiceState
 newServiceState = do
   serviceCC <- newEmptyTMVarIO
   serviceRequestQ <- newTQueueIO
-  chatRedeemQ <- newTQueueIO
-  pure ServiceState {serviceCC, serviceRequestQ, chatRedeemQ}
+  groupEventQ <- newTQueueIO
+  pure ServiceState {serviceCC, serviceRequestQ, groupEventQ}
 
 welcomeGetOpts :: IO BadgeServiceOpts
 welcomeGetOpts = do
@@ -128,29 +125,29 @@ badgeService opts@BadgeServiceOpts {serviceConfigFile} cfg env = do
   serviceCfg <- traverse readConfigOrExit serviceConfigFile
   key <- requireIssuerKey opts serviceCfg cfg
   waiters <- newWaiters
-  let devRedeem = maybe False devChatRedeem serviceCfg
-      chatHooks =
-        defaultChatHooks
-          { preStartHook = Just $ badgePreStartHook opts,
-            postStartHook = Just $ badgePostStartHook opts devRedeem env,
-            preCmdHook = Just badgeCmdHook
-          }
-  when devRedeem $ logWarn "[dev] chat_redeem is on: /redeem over chat hands out credentials this service can link"
-  -- The reader must not block, since outputQ carries every chat event.
-  simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> do
-    lanes <- maybe (pure []) (serviceLanes waiters cc) serviceCfg
-    raceAny_ $
-      [ forever $
+  let groupCfg = serviceCfg >>= \ServiceConfig {group} -> group
+      trackerQ_ = groupEventQ env <$ groupCfg
+      readEvents cc =
+        forever $
           atomically (readTBQueue $ outputQ cc) >>= \case
             (_, Right (CEvtServiceRequest u reqId sigKey reqData)) ->
               atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey, reqData)
-            (_, Right CEvtNewChatItems {chatItems = AChatItem _ SMDRcv (DirectChat ct) ChatItem {content = mc@CIRcvMsgContent {}} : _})
-              | devRedeem -> atomically $ writeTQueue (chatRedeemQ env) (ct, ciContentToText mc)
-            _ -> pure (),
-        processQueuedRequests key env
-      ]
-        <> [processChatRedeems key env | devRedeem]
-        <> lanes
+            (_, Right ev)
+              | isJust groupCfg -> forM_ (groupEvent ev) $ atomically . writeTQueue (groupEventQ env)
+            _ -> pure ()
+      startLanes cc = do
+        lanes <- maybe (pure []) (serviceLanes waiters cc) serviceCfg
+        -- The group is resolved before the other lanes start, so a failed lookup exits at once rather than waiting for them to end.
+        groupLane_ <- forM groupCfg $ \gc -> runGroupLane cc (groupEventQ env) <$> ensureManagedGroup cc gc
+        raceAny_ $ processQueuedRequests key trackerQ_ env : maybeToList groupLane_ <> lanes
+      chatHooks =
+        defaultChatHooks
+          { preStartHook = Just $ badgePreStartHook opts,
+            postStartHook = Just $ badgePostStartHook opts env,
+            preCmdHook = Just badgeCmdHook
+          }
+  -- The reader runs from the start and must not block, since outputQ carries every chat event and a full queue stalls the core.
+  simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> raceAny_ [readEvents cc, startLanes cc]
   where
     serviceLanes :: Waiters -> ChatController -> ServiceConfig -> IO [IO ()]
     serviceLanes ws ChatController {chatStore} sc = do
@@ -188,13 +185,13 @@ badgeServiceCLI opts@BadgeServiceOpts {serviceConfigFile} = do
       chatHooks =
         defaultChatHooks
           { preStartHook = Just $ badgePreStartHook opts,
-            postStartHook = Just $ badgePostStartHook opts False env,
+            postStartHook = Just $ badgePostStartHook opts env,
             preCmdHook = Just badgeCmdHook,
             eventHook = Just eventHook
           }
   raceAny_
     [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing,
-      processQueuedRequests key env
+      processQueuedRequests key Nothing env
     ]
 
 badgeCmdHook :: ChatController -> ChatCommand -> IO (Either (Either ChatError ChatResponse) ChatCommand)
@@ -206,26 +203,16 @@ runBadgeCmd :: ChatController -> ByteString -> IO (Either ChatError ChatResponse
 runBadgeCmd cc cmd
   | Right issueOpts <- A.parseOnly issueCmdP cmd =
       issueBadgeCode cc issueOpts >>= \case
-        Right code -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "code " <> formatBadgeCode code}
-        Left e -> pure $ chatCmdError $ "issuing code: " <> e
+        Right code -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "Code: " <> formatBadgeCode code}
+        Left _ -> pure $ chatCmdError (T.unpack issueFailedText)
   | Right code <- A.parseOnly revokeCmdP cmd =
-      revokeBadgeCode cc code >>= \case
-        Right Revoked -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "revoked"}
-        Right AlreadyRevoked -> pure $ chatCmdError "code was revoked already"
-        Right AlreadyRedeemed -> pure $ chatCmdError "code was redeemed already, so it cannot be revoked"
-        Right NoSuchCode -> pure $ chatCmdError "no such code"
-        Left e -> pure $ chatCmdError $ "revoking code: " <> e
-  | otherwise = pure $ chatCmdError "use: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke <code>"
+      revokeWithTracker cc code <&> \case
+        Right response -> Right CRCustomChatResponse {user_ = Nothing, response}
+        Left e -> chatCmdError (T.unpack e)
+  | otherwise = pure $ chatCmdError $ "Usage: //issue supporter|legend|investor [months 1-" <> show maxMonths <> "] [paid|unpaid|free], or //revoke <code>"
 
 revokeCmdP :: A.Parser BadgeCode
-revokeCmdP =
-  "revoke " *> (A.takeWhile1 (not . isSpace) >>= maybe (fail "not a badge code") pure . parseBadgeCode . safeDecodeUtf8)
-    <* (A.skipSpace *> A.endOfInput)
-
-revokeBadgeCode :: ChatController -> BadgeCode -> IO (Either String RevokeResult)
-revokeBadgeCode cc code = do
-  now <- truncateToSecond <$> getCurrentTime
-  withDB' "revokeBadgeCode" cc $ \db -> revokeCode db (badgeCodeHash code) now
+revokeCmdP = "revoke " *> codeP <* (A.skipSpace *> A.endOfInput)
 
 issueCmdP :: A.Parser IssueCodeOpts
 issueCmdP =
@@ -241,17 +228,8 @@ issueCmdP =
   where
     -- Integer, because attoparsec's decimal wraps silently at Int, so the guard would check a truncated count.
     checkMonths n
-      | n >= 1 && n <= 255 = pure (fromInteger n)
-      | otherwise = fail "months must be between 1 and 255"
-    -- BadgeType decodes anything to BTUnknown, so a typo would issue an unusable code
-    badgeTypeP =
-      textTokenP >>= \case
-        BTUnknown t -> fail $ "unknown badge type " <> T.unpack t
-        bt -> pure bt
-    textTokenP :: TextEncoding a => A.Parser a
-    textTokenP = do
-      t <- A.takeWhile1 (not . isSpace)
-      maybe (fail "invalid value") pure $ textDecode $ safeDecodeUtf8 t
+      | n >= 1 && n <= fromIntegral maxMonths = pure (fromInteger n)
+      | otherwise = fail $ "months must be between 1 and " <> show maxMonths
 
 data IssueCodeOpts = IssueCodeOpts
   { badgeType :: BadgeType,
@@ -259,60 +237,37 @@ data IssueCodeOpts = IssueCodeOpts
     paymentStatus :: BadgeCodePaymentStatus
   }
 
--- | The caller sees the code once; only its hash is stored, so a lost code cannot be recovered.
 issueBadgeCode :: ChatController -> IssueCodeOpts -> IO (Either String BadgeCode)
-issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = do
-  code <- randomBadgeCode $ random cc
-  now <- getCurrentTime
-  r <- withDB' "issueBadgeCode" cc $ \db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus now
-  pure $ code <$ r
+issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} =
+  fmap fst <$> issueOneCode cc badgeType months paymentStatus singleUse
 
-processQueuedRequests :: BadgeIssuerKey -> ServiceState -> IO ()
-processQueuedRequests key env = do
+processQueuedRequests :: BadgeIssuerKey -> Maybe (TQueue GroupEvent) -> ServiceState -> IO ()
+processQueuedRequests key trackerQ_ env = do
   cc <- atomically $ readTMVar $ serviceCC env
   forever $ do
     (u, reqId, sigKey, reqData) <- atomically $ readTQueue $ serviceRequestQ env
-    handleServiceRequest key cc u reqId sigKey reqData
-
-processChatRedeems :: BadgeIssuerKey -> ServiceState -> IO ()
-processChatRedeems key env = do
-  cc <- atomically $ readTMVar $ serviceCC env
-  forever $ do
-    (ct, msg) <- atomically $ readTQueue $ chatRedeemQ env
-    chatRedeem key cc ct msg
-
--- | Here the service generates the master key and can link the badge, so [dev] chat_redeem gates this.
-chatRedeem :: BadgeIssuerKey -> ChatController -> Contact -> T.Text -> IO ()
-chatRedeem key cc ct msg = case T.stripPrefix "/redeem" (T.strip msg) of
-  Just rest | not (T.null (T.strip rest)) -> do
-    masterKey <- generateMasterKey (random cc)
-    (purchaseKey, _) <- atomically $ C.generateKeyPair (random cc) :: IO (C.KeyPair 'C.Ed25519)
-    resp <- redeemCode key cc purchaseKey masterKey (T.strip rest)
-    sendMessage cc ct $ case resp of
-      BSPBadgeCredential {credential = Just cred} -> safeDecodeUtf8 $ LB.toStrict $ J.encode cred
-      BSPError {code} -> "error: " <> textEncode code
-      _ -> "unexpected response"
-  _ -> sendMessage cc ct "send: /redeem <code>"
+    handleServiceRequest key cc trackerQ_ u reqId sigKey reqData
 
 badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO ()
 badgePreStartHook opts ChatController {config, chatStore} =
   runBadgeServiceMigrations opts config chatStore
 
-badgePostStartHook :: BadgeServiceOpts -> Bool -> ServiceState -> ChatController -> IO ()
-badgePostStartHook BadgeServiceOpts {noAddress, testing} devRedeem env cc = do
+badgePostStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO ()
+badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do
   -- Core starts this False and gates service request delivery on it, so the hook must set it.
   atomically $ writeTVar (processServiceRequests cc) True
   readTVarIO (currentUser cc) >>= \case
     Nothing -> putStrLn "No current user" >> exitFailure
     Just _ -> do
-      unless noAddress $ initializeBotAddress' (not testing) (Just True) devRedeem cc
+      -- The address carries service RPC only, so contact requests are never auto-accepted.
+      unless noAddress $ initializeBotAddress' (not testing) (Just True) False cc
       void $ atomically $ tryPutTMVar (serviceCC env) cc
 
-handleServiceRequest :: BadgeIssuerKey -> ChatController -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO ()
-handleServiceRequest key cc User {userId} reqId sigKey reqData = do
+handleServiceRequest :: BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO ()
+handleServiceRequest key cc trackerQ_ User {userId} reqId sigKey reqData = do
   let reqIdT = safeDecodeUtf8 (strEncode reqId)
   logInfo $ "badge service request " <> reqIdT
-  resp <- badgeServiceResponse key cc sigKey reqData
+  resp <- badgeServiceResponse key cc trackerQ_ sigKey reqData
   sendChatCmd cc (APISendServiceResponse userId reqId (responseObject resp)) >>= \case
     Right _ -> pure ()
     Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e
@@ -334,15 +289,15 @@ badgeErrorRetryAfter = \case
 
 
 -- | The agent verified the signature, so sigKey is a key the sender holds; a differing purchaseKey would let a client claim a purchase it cannot sign for.
-badgeServiceResponse :: BadgeIssuerKey -> ChatController -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse
-badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData) of
+badgeServiceResponse :: BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse
+badgeServiceResponse key cc trackerQ_ sigKey reqData = case J.fromJSON (J.Object reqData) of
   J.Error _ -> pure $ errorResponse BSEBadRequest
   J.Success BadgeServiceRequest {version, purchaseKey, request}
     | not (version `isCompatible` supportedBadgeServiceVRange) -> pure $ errorResponse BSEUnsupportedVersion
     | purchaseKey /= sigKey -> pure $ errorResponse BSEBadRequest
     | otherwise -> case request of
         BSCRedeemBadgeCode {masterKey, code} -> case purchaseKey of
-          Just k -> redeemCode key cc k masterKey code
+          Just k -> redeemCode key cc trackerQ_ k masterKey code
           Nothing -> pure $ errorResponse BSEBadRequest
         BSCIssueBadge {balance} -> case purchaseKey of
           Just k -> issueBadgeCmd key cc k balance
@@ -376,15 +331,15 @@ credentialResponse credential previousEntryId entries =
   BSPBadgeCredential {credential, receipt = Nothing, statement = BadgeStatement {entries, previousEntryId}}
 
 -- | Nothing is written until the credential is signed, so a signing failure leaves the code unspent.
-redeemCode :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> T.Text -> IO BadgeServiceResponse
-redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText of
+redeemCode :: BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> C.PublicKeyEd25519 -> BadgeMasterKey -> T.Text -> IO BadgeServiceResponse
+redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode codeText of
   Nothing -> pure $ errorResponse BSECodeInvalid
   Just code -> do
     now <- badgeNow cc
     withDB "getBadgeCode" cc (readCode now code) >>= \case
       Left _ -> pure $ errorResponse BSEInternal
       Right (Left resp) -> pure resp
-      Right (Right IssuedCode {badgeCodeId, badgeType, months}) -> do
+      Right (Right IssuedCode {badgeCodeId, badgeType, months, redeemLimit}) -> do
         (grantUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc
         -- TODO [badges] a top-up grants onto an existing ledger, and must lapse before it or the
         -- months it adds are counted from a start already in the past
@@ -395,41 +350,42 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText
           Just issued -> credentialForEntry key masterKey issued >>= \case
             Left e -> logError ("badge service signing failed: " <> T.pack e) $> errorResponse BSEInternal
             Right signed -> do
-              -- If the code was revoked or redeemed while signing, the claim fails. Read the code again to tell the client why.
+              -- If the code was revoked or used up while signing, the claim fails. Read the code again to tell the client why.
               r <- withDB "writeCodeRedemption" cc $ \db ->
                 liftIO (createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now) >>= \case
                   Nothing ->
                     readCode now code db >>= \case
-                      Left resp -> pure resp
-                      Right _ -> logError "badge service: redeeming a code failed, but the code is neither redeemed nor revoked" $> errorResponse BSEInternal
+                      Left resp -> pure (resp, False)
+                      Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> (errorResponse BSEInternal, False)
                   Just purchaseId -> liftIO $ do
                     appendLedgerPlan db purchaseId [granted] $ Just $ issuanceAfter granted signed
                     entries_ <- getLedgerEntries db purchaseId 0
-                    pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_
-              pure $ fromRight (errorResponse BSEInternal) r
+                    pure (maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_, True)
+              let (resp, claimed) = fromRight (errorResponse BSEInternal, False) r
+              when (claimed && hasTracker redeemLimit) $ refreshTracker cc trackerQ_ badgeCodeId code
+              pure resp
   where
     readCode now code db = liftIO $
       getBadgeCode db (badgeCodeHash code) >>= \case
         Nothing -> pure $ Left $ errorResponse BSECodeInvalid
-        Just c@IssuedCode {revokedAt, paymentStatus, expiresAt, redemption}
-          -- Revoked is checked first, so it answers as if the code never existed.
-          | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid
-          -- Redeeming an unpaid code would issue a free badge, so unpaid is refused.
-          | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending
-          | otherwise ->
-              checkUnspent db redemption >>= \case
-                Left resp -> pure $ Left resp
-                Right ()
-                  | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired
-                  | otherwise -> pure $ Right c
-    checkUnspent db = \case
-      CodeUnredeemed -> pure $ Right ()
-      CodeRedeemedUnreadable -> pure $ Left $ errorResponse BSEInternal
-      CodeRedeemed RedeemedCode {purchaseKey = k, badgePurchaseId, credential}
-        | k /= purchaseKey -> pure $ Left $ errorResponse BSECodeUsed
-        | otherwise ->
-            maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing)
-              <$> getLedgerEntries db badgePurchaseId 0
+        Just c@IssuedCode {badgeCodeId, revokedAt, paymentStatus, expiresAt, redeemLimit, redeemCount} ->
+          getCodePurchaseForKey db badgeCodeId purchaseKey >>= \case
+            -- A key that already redeemed gets its credential back without a use, even if the code has since
+            -- expired or been revoked: a client whose reply was lost retries, and would otherwise lose the badge.
+            KeyRedeemed KeyPurchase {badgePurchaseId, credential} ->
+              maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing)
+                <$> getLedgerEntries db badgePurchaseId 0
+            -- code_used would make the client drop its keys, so the holder could never get the badge back.
+            KeyRedeemedUnreadable ->
+              logError "badge service: a redeemed code's credential is missing or unreadable" $> Left (errorResponse BSEInternal)
+            KeyUnredeemed
+              -- Revoked is checked first, so it answers as if the code never existed.
+              | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid
+              -- Redeeming an unpaid code would issue a free badge, so unpaid is refused.
+              | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending
+              | redeemCount >= redeemLimit -> pure $ Left $ errorResponse BSECodeUsed
+              | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired
+              | otherwise -> pure $ Right c
 
 -- | The purchase is reached through the verified signer key and no other way.
 issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse

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

@@ -7,11 +7,17 @@
 
 module BadgeService.Store
   ( IssuedCode (..),
-    CodeRedemption (..),
-    RedeemedCode (..),
+    KeyRedemption (..),
+    KeyPurchase (..),
     NewCodePurchase (..),
     ServicePurchase (..),
+    ManagedGroup (..),
+    getManagedGroup,
+    insertManagedGroup,
+    clearCodeGroupItems,
+    markOwnerBootstrapped,
     getBadgeCode,
+    getCodePurchaseForKey,
     purchaseKeyExists,
     getPurchaseByKey,
     getLedgerTip,
@@ -21,6 +27,10 @@ module BadgeService.Store
     appendLedgerPlan,
     createCodePurchase,
     insertBadgeCode,
+    setCodeGroupItem,
+    CodeTracker (..),
+    getCodeTracker,
+    getEditableTrackers,
     RevokeResult (..),
     revokeCode,
   )
@@ -31,6 +41,7 @@ import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
+import Data.Maybe (isJust)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType)
@@ -38,7 +49,7 @@ import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service (StatementEntry (..))
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus, BadgePurchaseStatus (..))
 import Simplex.Chat.Store.Shared (insertedRowId)
-import Simplex.Messaging.Agent.Store.DB (Binary (..))
+import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow')
@@ -58,17 +69,17 @@ data IssuedCode = IssuedCode
     paymentStatus :: BadgeCodePaymentStatus,
     revokedAt :: Maybe UTCTime,
     expiresAt :: Maybe UTCTime,
-    redemption :: CodeRedemption
+    redeemLimit :: Int,
+    redeemCount :: Int
   }
 
-data CodeRedemption
-  = CodeUnredeemed
-  | CodeRedeemed RedeemedCode
-  | CodeRedeemedUnreadable
+data KeyRedemption
+  = KeyUnredeemed
+  | KeyRedeemed KeyPurchase
+  | KeyRedeemedUnreadable
 
-data RedeemedCode = RedeemedCode
+data KeyPurchase = KeyPurchase
   { badgePurchaseId :: Int64,
-    purchaseKey :: C.PublicKeyEd25519,
     credential :: BadgeCredential
   }
 
@@ -85,30 +96,81 @@ data ServicePurchase = ServicePurchase
     badgeType :: BadgeType
   }
 
+data ManagedGroup = ManagedGroup
+  { mgGroupId :: Int64,
+    mgGroupLink :: Text,
+    mgOwnerBootstrapped :: Bool
+  }
+  deriving (Eq)
+
+-- The join link is a bearer secret, so it is left out.
+instance Show ManagedGroup where
+  show ManagedGroup {mgGroupId, mgOwnerBootstrapped} = "managed group " <> show mgGroupId <> ", owner set up: " <> show mgOwnerBootstrapped
+
+getManagedGroup :: DB.Connection -> IO (Maybe ManagedGroup)
+getManagedGroup db =
+  maybeFirstRow toGroup $
+    DB.query_ db "SELECT group_id, group_link, owner_bootstrapped FROM sx_badge_service_group LIMIT 1"
+  where
+    toGroup (mgGroupId, mgGroupLink, BI mgOwnerBootstrapped) = ManagedGroup {mgGroupId, mgGroupLink, mgOwnerBootstrapped}
+
+-- getManagedGroup reads with no ordering, so a second row would change which group is used.
+insertManagedGroup :: DB.Connection -> Int64 -> Text -> UTCTime -> IO ()
+insertManagedGroup db gid link now =
+  DB.execute
+    db
+    [sql|
+      INSERT INTO sx_badge_service_group (group_id, group_link, owner_bootstrapped, created_at)
+      SELECT ?,?,0,? WHERE NOT EXISTS (SELECT 1 FROM sx_badge_service_group)
+    |]
+    (gid, link, now)
+
+-- A tracker's item id is only found in the group it was posted to, so a new group starts with none.
+clearCodeGroupItems :: DB.Connection -> IO ()
+clearCodeGroupItems db =
+  DB.execute_ db "UPDATE sx_badge_service_badge_codes SET group_item_id = NULL, group_item_sent_at = NULL WHERE group_item_id IS NOT NULL"
+
+markOwnerBootstrapped :: DB.Connection -> Int64 -> IO Bool
+markOwnerBootstrapped db gid =
+  (> 0)
+    <$> executeChanging
+      db
+      "UPDATE sx_badge_service_group SET owner_bootstrapped = 1 WHERE group_id = ? AND owner_bootstrapped = 0"
+      (Only gid)
+
 getBadgeCode :: DB.Connection -> ByteString -> IO (Maybe IssuedCode)
 getBadgeCode db codeHash =
   maybeFirstRow toCode $
     DB.query
       db
       [sql|
-        SELECT c.badge_code_id, c.badge_type, c.months, c.code_payment_status, c.revoked_at,
-               c.expires_at, p.badge_purchase_id, p.purchase_key, i.credential
-        FROM sx_badge_service_badge_codes c
-        LEFT JOIN sx_badge_service_badge_purchases p ON p.badge_code_id = c.badge_code_id
-        LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id
-        WHERE c.code_hash = ?
-        ORDER BY i.period_end DESC
-        LIMIT 1
+        SELECT badge_code_id, badge_type, months, code_payment_status, revoked_at, expires_at, redeem_limit, redeem_count
+        FROM sx_badge_service_badge_codes
+        WHERE code_hash = ?
       |]
       (Only (Binary codeHash))
   where
-    toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, purchaseId_, purchaseKey_, credential_) =
-      IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redemption = codeRedemption purchaseId_ purchaseKey_ credential_}
-    codeRedemption purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of
-      (Just badgePurchaseId, Just purchaseKey) -> case decodeCredential =<< credential_ of
-        Just credential -> CodeRedeemed RedeemedCode {badgePurchaseId, purchaseKey, credential}
-        Nothing -> CodeRedeemedUnreadable
-      _ -> CodeUnredeemed
+    toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redeemLimit, redeemCount) =
+      IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redeemLimit, redeemCount}
+
+getCodePurchaseForKey :: DB.Connection -> Int64 -> C.PublicKeyEd25519 -> IO KeyRedemption
+getCodePurchaseForKey db badgeCodeId key =
+  maybeFirstRow' KeyUnredeemed toRedemption $
+    DB.query
+      db
+      [sql|
+        SELECT p.badge_purchase_id, i.credential
+        FROM sx_badge_service_badge_purchases p
+        LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id
+        WHERE p.badge_code_id = ? AND p.purchase_key = ?
+        ORDER BY i.period_end DESC
+        LIMIT 1
+      |]
+      (badgeCodeId, key)
+  where
+    toRedemption (badgePurchaseId, credential_) = case decodeCredential =<< credential_ of
+      Just credential -> KeyRedeemed KeyPurchase {badgePurchaseId, credential}
+      Nothing -> KeyRedeemedUnreadable
     decodeCredential (Binary bs) = J.decodeStrict' bs
 
 purchaseKeyExists :: DB.Connection -> C.PublicKeyEd25519 -> IO Bool
@@ -222,15 +284,14 @@ appendLedgerPlan db purchaseId rows issuance_ = do
         ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType))
       insertedRowId db
 
--- redeemed_at is stamped here, so this must run in the same transaction as the credential rows.
--- Mark the code as redeemed before adding the purchase. On Postgres, a revoke or redemption running
--- at the same time then waits, sees the code is taken, and fails.
+-- The claim takes one use before adding the purchase, so a concurrent revoke or redemption waits on this row and sees the new count.
+-- Run it in the credential's transaction.
 createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO (Maybe Int64)
 createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do
   claimed <-
     executeChanging
       db
-      "UPDATE sx_badge_service_badge_codes SET redeemed_at = ? WHERE badge_code_id = ? AND redeemed_at IS NULL AND revoked_at IS NULL"
+      "UPDATE sx_badge_service_badge_codes SET redeem_count = redeem_count + 1, redeemed_at = ? WHERE badge_code_id = ? AND redeem_count < redeem_limit AND revoked_at IS NULL"
       (now, badgeCodeId)
   if claimed == 0
     then pure Nothing
@@ -245,32 +306,79 @@ createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = Bad
         (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now)
       Just <$> insertedRowId db
 
-data RevokeResult = Revoked | AlreadyRevoked | AlreadyRedeemed | NoSuchCode
+-- | Revoked and AlreadyRevoked carry the code id, so the caller can retire the code's group tracker,
+-- or repair one an earlier revoke left live.
+data RevokeResult = Revoked Int64 | AlreadyRevoked Int64 | AlreadyRedeemed | NoSuchCode
   deriving (Eq, Show)
 
--- | A code that was already redeemed can't be revoked, because its badge was already given out.
+-- | A code with no uses left can't be revoked, because every badge it grants was already given out.
 revokeCode :: DB.Connection -> ByteString -> UTCTime -> IO RevokeResult
 revokeCode db codeHash now = do
   revoked <-
     executeChanging
       db
-      "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeemed_at IS NULL"
+      "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeem_count < redeem_limit"
       (now, Binary codeHash)
-  if revoked > 0
-    then pure Revoked
-    else
-      maybeFirstRow' NoSuchCode refusal $
-        DB.query db "SELECT revoked_at FROM sx_badge_service_badge_codes WHERE code_hash = ?" (Only (Binary codeHash))
+  -- The result is read in the same transaction as the UPDATE, so the row it answers about is the row that changed.
+  maybeFirstRow' NoSuchCode (result revoked) $
+    DB.query db "SELECT badge_code_id, revoked_at FROM sx_badge_service_badge_codes WHERE code_hash = ?" (Only (Binary codeHash))
   where
-    refusal :: Only (Maybe UTCTime) -> RevokeResult
-    refusal (Only revokedAt) = maybe AlreadyRedeemed (const AlreadyRevoked) revokedAt
+    result :: Int -> (Int64, Maybe UTCTime) -> RevokeResult
+    result revoked (badgeCodeId, revokedAt)
+      | revoked > 0 = Revoked badgeCodeId
+      | isJust revokedAt = AlreadyRevoked badgeCodeId
+      | otherwise = AlreadyRedeemed
 
-insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> UTCTime -> IO ()
-insertBadgeCode db codeHash badgeType months paymentStatus now =
+insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64
+insertBadgeCode db codeHash badgeType months paymentStatus redeemLimit now = do
   DB.execute
     db
     [sql|
-      INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at)
-      VALUES (?,?,?,?,?)
+      INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, redeem_limit, created_at)
+      VALUES (?,?,?,?,?,?)
     |]
-    (Binary codeHash, badgeType, months, paymentStatus, now)
+    (Binary codeHash, badgeType, months, paymentStatus, redeemLimit, now)
+  insertedRowId db
+
+setCodeGroupItem :: DB.Connection -> Int64 -> Int64 -> UTCTime -> IO ()
+setCodeGroupItem db badgeCodeId itemId sentAt =
+  DB.execute
+    db
+    "UPDATE sx_badge_service_badge_codes SET group_item_id = ?, group_item_sent_at = ? WHERE badge_code_id = ?"
+    (itemId, sentAt, badgeCodeId)
+
+data CodeTracker = CodeTracker
+  { trackerItemId :: Int64,
+    trackerSentAt :: UTCTime,
+    redeemLimit :: Int,
+    redeemCount :: Int,
+    revokedAt :: Maybe UTCTime,
+    redeemedAt :: Maybe UTCTime
+  }
+
+getCodeTracker :: DB.Connection -> Int64 -> IO (Maybe CodeTracker)
+getCodeTracker db badgeCodeId =
+  maybeFirstRow toTracker $
+    DB.query
+      db
+      [sql|
+        SELECT group_item_id, group_item_sent_at, redeem_limit, redeem_count, revoked_at, redeemed_at
+        FROM sx_badge_service_badge_codes
+        WHERE badge_code_id = ? AND group_item_id IS NOT NULL AND group_item_sent_at IS NOT NULL
+      |]
+      (Only badgeCodeId)
+  where
+    toTracker (trackerItemId, trackerSentAt, redeemLimit, redeemCount, revokedAt, redeemedAt) =
+      CodeTracker {trackerItemId, trackerSentAt, redeemLimit, redeemCount, revokedAt, redeemedAt}
+
+getEditableTrackers :: DB.Connection -> UTCTime -> IO [(Int64, Int64)]
+getEditableTrackers db sentAfter =
+  DB.query
+    db
+    [sql|
+      SELECT badge_code_id, group_item_id
+      FROM sx_badge_service_badge_codes
+      WHERE group_item_id IS NOT NULL AND group_item_sent_at > ?
+      ORDER BY badge_code_id
+    |]
+    (Only sentAfter)

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

@@ -17,7 +17,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations
 
 schemaMigrations :: [(String, Text, Maybe Text)]
 schemaMigrations =
-  [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema)
+  [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema),
+    ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops)
   ]
 
 -- | The client tables share this database, so the service tables are the same names behind a prefix.
@@ -109,6 +110,48 @@ DROP INDEX @idx_badge_purchases_code;
 DROP TABLE @badge_codes;
 |]
 
+m20260918_badge_group_ops :: Text
+m20260918_badge_group_ops =
+  withPrefix
+    servicePrefix
+    [r|
+CREATE TABLE @group(
+  group_id BIGINT NOT NULL PRIMARY KEY,
+  group_link TEXT NOT NULL,
+  owner_bootstrapped SMALLINT NOT NULL DEFAULT 0,
+  created_at TIMESTAMPTZ NOT NULL
+);
+
+ALTER TABLE @badge_codes ADD COLUMN redeem_limit INTEGER NOT NULL DEFAULT 1;
+
+ALTER TABLE @badge_codes ADD COLUMN redeem_count INTEGER NOT NULL DEFAULT 0;
+
+ALTER TABLE @badge_codes ADD COLUMN group_item_id BIGINT;
+
+ALTER TABLE @badge_codes ADD COLUMN group_item_sent_at TIMESTAMPTZ;
+
+-- Redemptions made before this migration must count against the new limit, or every code
+-- redeemed already would read as unspent and could be redeemed once more.
+UPDATE @badge_codes SET redeem_count = 1 WHERE redeemed_at IS NOT NULL;
+
+DROP INDEX @idx_badge_purchases_code;
+
+CREATE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id);
+|]
+
+-- The index stays non-unique, since a multi-use code may already have several purchases.
+down_m20260918_badge_group_ops :: Text
+down_m20260918_badge_group_ops =
+  withPrefix
+    servicePrefix
+    [r|
+ALTER TABLE @badge_codes DROP COLUMN group_item_sent_at;
+ALTER TABLE @badge_codes DROP COLUMN group_item_id;
+ALTER TABLE @badge_codes DROP COLUMN redeem_count;
+ALTER TABLE @badge_codes DROP COLUMN redeem_limit;
+DROP TABLE @group;
+|]
+
 {- TODO [badges] deferred with the draft in M20260915_user_badges, service only.
 
 ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA;

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

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