badges: add the managed group

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/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

@@ -3,13 +3,16 @@
 
 module BadgeService.Codes
   ( issueOneCode,
+    issueFailedText,
+    revokeBadgeCode,
     singleUse,
   )
 where
 
-import BadgeService.Store (insertBadgeCode)
+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)
@@ -20,6 +23,15 @@ 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 = "issuing the code failed"
+
 -- | 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

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,451 @@
+{-# 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, when)
+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 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
+
+-- GETracker carries the redeem count its claim reached.
+data GroupEvent
+  = GEInGroup GroupId GroupAction
+  | GETracker Int64 BadgeCode Int
+  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
+
+coalesceTrackerRefreshes :: [GroupEvent] -> [GroupEvent]
+coalesceTrackerRefreshes evs = snd $ foldr keepOne (highestClaims, []) evs
+  where
+    -- The highest claim decides the exhaustion notice, whatever order the claims were queued in.
+    highestClaims = M.fromListWith max [(badgeCodeId, n) | GETracker badgeCodeId _ n <- evs]
+    keepOne ev (todo, kept) = case ev of
+      GETracker badgeCodeId code _ -> case M.lookup badgeCodeId todo of
+        Just n -> (M.delete badgeCodeId todo, GETracker badgeCodeId code n : kept)
+        Nothing -> (todo, kept)
+      _ -> (todo, 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 claimedCount -> updateTracker cc groupId badgeCodeId code claimedCount
+
+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 <> ", the rest failed"]
+  -- 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.
+trackerBody :: BadgeCode -> Int -> Int -> Maybe UTCTime -> Text
+trackerBody code remaining total redeemedAt =
+  "!2 " <> formatBadgeCode code <> "!\n" <> maybe "" lastRedeemed redeemedAt <> tshow remaining <> "/" <> tshow total <> " remaining"
+  where
+    lastRedeemed ts = "Last redeemed: " <> fmtDay ts <> " — "
+
+exhaustedBody :: BadgeCode -> Int -> Text
+exhaustedBody code total = formatBadgeCode code <> " fully redeemed — all " <> tshow total <> " used"
+
+revokedBody :: BadgeCode -> Text
+revokedBody code = formatBadgeCode code <> " revoked — no longer redeemable"
+
+fmtDay :: UTCTime -> Text
+fmtDay = T.pack . formatTime defaultTimeLocale "%Y-%m-%d"
+
+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.
+-- With MayRepost the result is Nothing when there is nothing to write or the message is gone, so no notice follows.
+setTrackerBody :: ChatController -> GroupId -> Int64 -> RepostPolicy -> (CodeTracker -> Maybe Text) -> IO (Maybe CodeTracker)
+setTrackerBody cc groupId badgeCodeId policy mkBody =
+  withDB' "getCodeTracker" cc (`getCodeTracker` badgeCodeId) >>= \case
+    Right (Just tracker@CodeTracker {trackerItemId, trackerSentAt}) ->
+      pure (mkBody tracker) $>>= \body -> do
+        now <- truncateToSecond <$> getCurrentTime
+        let handled = pure (Just tracker)
+            repost =
+              trackerItemText cc groupId trackerItemId >>= \case
+                Nothing -> do
+                  logWarn $ "badge group tracker not reposted, code " <> tshow badgeCodeId <> " is no longer published"
+                  pure Nothing
+                -- Past the window every write reposts, so an unchanged body is not posted again.
+                Just current
+                  | current == body -> handled
+                  | otherwise -> do
+                      sendGroupText cc groupId ("tracker repost, code " <> tshow badgeCodeId <> " keeps its old message") body
+                        >>= mapM_ (\i -> withDB' "setCodeGroupItem" cc (\db -> setCodeGroupItem db badgeCodeId i now))
+                      handled
+            -- 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 -> do
+                logWarn $ "badge group tracker left uncorrected, code " <> tshow badgeCodeId <> " can no longer be edited"
+                handled
+        case trackerDecision now trackerSentAt of
+          Edit ->
+            sendChatCmd cc (APIUpdateChatItem (ChatRef CTGroup groupId Nothing) trackerItemId False (UpdatedMessage (MCText body) M.empty)) >>= \case
+              Right CRChatItemUpdated {} -> handled
+              Right CRChatItemNotChanged {} -> handled
+              Left (ChatError CEInvalidChatItemUpdate) -> uneditable
+              -- Any other failure may still have applied the edit, so a repost could publish the code twice.
+              -- The notice still follows the claim while the tracker is published.
+              r -> do
+                logError $ "badge group tracker not updated, code " <> tshow badgeCodeId <> ": " <> tshow r
+                ($> tracker) <$> trackerItemText cc groupId trackerItemId
+          Repost -> uneditable
+    _ -> pure Nothing
+
+-- 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 -> Int -> IO ()
+refreshTracker cc trackerQ_ badgeCodeId code claimedCount = case trackerQ_ of
+  Just q -> atomically $ writeTQueue q (GETracker badgeCodeId code claimedCount)
+  Nothing -> logUncaught $ withManagedGroup cc $ \groupId -> updateTracker cc groupId badgeCodeId code claimedCount
+
+-- The notice follows the claim, not the count read now, so queued refreshes post it once.
+updateTracker :: ChatController -> GroupId -> Int64 -> BadgeCode -> Int -> IO ()
+updateTracker cc groupId badgeCodeId code claimedCount =
+  setTrackerBody cc groupId badgeCodeId MayRepost (counterBody code)
+    >>= mapM_ (\CodeTracker {redeemLimit} -> when (claimedCount == redeemLimit) $ postNotice redeemLimit)
+  where
+    postNotice redeemLimit = void $ sendGroupText cc groupId ("notice, code " <> tshow badgeCodeId) (exhaustedBody code redeemLimit)
+
+-- | 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 "revoked" 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 "code was redeemed already, so it cannot be revoked"
+    Right NoSuchCode -> pure $ Left "no such code"
+    Left _ -> pure $ Left "revoking the code failed"
+  where
+    retire badgeCodeId = logUncaught $ withManagedGroup cc $ \groupId ->
+      void $ 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) = void $ 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 = "use: /" <> 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, and this code is now visible to the group - ask an admin to revoke it"

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,8 +19,10 @@ module BadgeService.Service
 where
 
 import BadgeService.Catalog (defaultCatalog)
-import BadgeService.Codes (issueOneCode, singleUse)
+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)
@@ -34,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)
@@ -55,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)
@@ -77,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
@@ -129,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
@@ -189,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)
@@ -208,25 +204,15 @@ 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
+        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 $ "use: //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 =
@@ -242,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,
@@ -264,52 +241,33 @@ issueBadgeCode :: ChatController -> IssueCodeOpts -> IO (Either String BadgeCode
 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
@@ -331,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
@@ -373,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
@@ -397,13 +355,15 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText
                 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 has uses left and is not revoked" $> errorResponse BSEInternal
-                  Just (purchaseId, _) -> liftIO $ do
+                      Left resp -> pure (resp, Nothing)
+                      Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> (errorResponse BSEInternal, Nothing)
+                  Just (purchaseId, claimedCount) -> 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_, Just claimedCount)
+              let (resp, claimedCount_) = fromRight (errorResponse BSEInternal, Nothing) r
+              when (hasTracker redeemLimit) $ forM_ claimedCount_ $ refreshTracker cc trackerQ_ badgeCodeId code
+              pure resp
   where
     readCode now code db = liftIO $
       getBadgeCode db (badgeCodeHash code) >>= \case

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

@@ -12,6 +12,11 @@ module BadgeService.Store
     KeyPurchase (..),
     NewCodePurchase (..),
     ServicePurchase (..),
+    ManagedGroup (..),
+    getManagedGroup,
+    insertManagedGroup,
+    clearCodeGroupItems,
+    markOwnerBootstrapped,
     getBadgeCode,
     getCodePurchaseForKey,
     purchaseKeyExists,
@@ -23,6 +28,10 @@ module BadgeService.Store
     appendLedgerPlan,
     createCodePurchase,
     insertBadgeCode,
+    setCodeGroupItem,
+    CodeTracker (..),
+    getCodeTracker,
+    getEditableTrackers,
     RevokeResult (..),
     revokeCode,
   )
@@ -34,6 +43,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)
@@ -41,7 +51,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')
@@ -88,6 +98,48 @@ 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 $
@@ -255,7 +307,9 @@ createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = Bad
       (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now)
     (,claimedCount) <$> 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 with no uses left can't be revoked, because every badge it grants was already given out.
@@ -266,14 +320,15 @@ revokeCode db codeHash now = do
       db
       "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 -> Int -> UTCTime -> IO Int64
 insertBadgeCode db codeHash badgeType months paymentStatus redeemLimit now = do
@@ -285,3 +340,46 @@ insertBadgeCode db codeHash badgeType months paymentStatus redeemLimit now = do
     |]
     (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

@@ -115,10 +115,21 @@ 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;
@@ -134,8 +145,11 @@ 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.

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

@@ -116,10 +116,21 @@ 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;
@@ -135,8 +146,11 @@ 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.