From b078a382dbcad67e154ea012ea2d0c0103c2c83d Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 25 Sep 2026 15:51:22 +0000 Subject: [PATCH] badges: add the managed group --- apps/simplex-badge-service/Main.hs | 18 +- .../badge_service.ini.example | 14 +- .../src/BadgeService/Codes.hs | 14 +- .../src/BadgeService/Config.hs | 46 +- .../src/BadgeService/Group.hs | 451 ++++++ .../src/BadgeService/Group/Command.hs | 142 ++ .../src/BadgeService/Service.hs | 170 +- .../src/BadgeService/Store.hs | 116 +- .../BadgeService/Store/Postgres/Migrations.hs | 14 + .../BadgeService/Store/SQLite/Migrations.hs | 14 + .../badge-service/badge_service.ini.example | 12 +- simplex-chat.cabal | 6 + tests/Bots/BadgeService/BotTests.hs | 94 +- tests/Bots/BadgeService/ConfigTests.hs | 95 +- .../BadgeService/GroupIntegrationTests.hs | 1411 +++++++++++++++++ tests/Bots/BadgeService/GroupTests.hs | 177 +++ tests/Bots/BadgeService/WebTests.hs | 49 +- tests/Test.hs | 7 +- 18 files changed, 2647 insertions(+), 203 deletions(-) create mode 100644 apps/simplex-badge-service/src/BadgeService/Group.hs create mode 100644 apps/simplex-badge-service/src/BadgeService/Group/Command.hs create mode 100644 tests/Bots/BadgeService/GroupIntegrationTests.hs create mode 100644 tests/Bots/BadgeService/GroupTests.hs diff --git a/apps/simplex-badge-service/Main.hs b/apps/simplex-badge-service/Main.hs index cdeb1c0c1e..68369995e2 100644 --- a/apps/simplex-badge-service/Main.hs +++ b/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 diff --git a/apps/simplex-badge-service/badge_service.ini.example b/apps/simplex-badge-service/badge_service.ini.example index b1f5f4b1c1..00584fed41 100644 --- a/apps/simplex-badge-service/badge_service.ini.example +++ b/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 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 diff --git a/apps/simplex-badge-service/src/BadgeService/Codes.hs b/apps/simplex-badge-service/src/BadgeService/Codes.hs index 195adf849d..17ced20739 100644 --- a/apps/simplex-badge-service/src/BadgeService/Codes.hs +++ b/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 diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index 10d55d7da7..9e33f4459d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/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 diff --git a/apps/simplex-badge-service/src/BadgeService/Group.hs b/apps/simplex-badge-service/src/BadgeService/Group.hs new file mode 100644 index 0000000000..0f10f590a1 --- /dev/null +++ b/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 <> " 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 diff --git a/apps/simplex-badge-service/src/BadgeService/Group/Command.hs b/apps/simplex-badge-service/src/BadgeService/Group/Command.hs new file mode 100644 index 0000000000..ad3b1eb691 --- /dev/null +++ b/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 -> " [months ] [uses ]" + CTBulk -> " [months ] count " + CTRevoke -> "" + +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" diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 03ead6e987..32557844dc 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/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 " + 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 " 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 " + 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 diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index ab39dc38ad..2f25b6c6f6 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/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) diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs index c59fa73b5e..f096d3098d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs +++ b/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. diff --git a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs index d2f5d274f6..cd89859686 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs +++ b/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. diff --git a/scripts/badge-service/badge_service.ini.example b/scripts/badge-service/badge_service.ini.example index 09ca430fc7..dcc9364d62 100644 --- a/scripts/badge-service/badge_service.ini.example +++ b/scripts/badge-service/badge_service.ini.example @@ -42,5 +42,13 @@ idle_seconds = 60 index = 1 private_key = replace-me -[dev] -chat_redeem = on +; Optional. When present, the service creates and manages one group 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 diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 225d865688..ddecfced48 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -431,6 +431,8 @@ executable simplex-badge-service BadgeService.Catalog BadgeService.Codes BadgeService.Config + BadgeService.Group + BadgeService.Group.Command BadgeService.Log BadgeService.Options BadgeService.Orders @@ -720,6 +722,8 @@ test-suite simplex-chat-test BadgeService.Catalog BadgeService.Codes BadgeService.Config + BadgeService.Group + BadgeService.Group.Command BadgeService.Log BadgeService.Options BadgeService.Orders @@ -739,6 +743,8 @@ test-suite simplex-chat-test Bots.BadgeService.ConfigTests Bots.BadgeService.FakeBTCPay Bots.BadgeService.FakeStripe + Bots.BadgeService.GroupIntegrationTests + Bots.BadgeService.GroupTests Bots.BadgeService.StripeTests Bots.BadgeService.WaitersTests Bots.BadgeService.WebTests diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index a6b57a6674..5188a8da92 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -12,6 +12,7 @@ module Bots.BadgeService.BotTests where import BadgeService.Codes (issueOneCode) import BadgeService.Config (BadgeIssuerKey (..), readServiceConfig) +import BadgeService.Group (GroupEvent) import Bots.BadgeService.ConfigTests (withIssuer) import BadgeService.Options import BadgeService.Service @@ -23,7 +24,7 @@ import ChatClient import ChatTests.DBUtils import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) -import Control.Concurrent.STM (atomically, readTMVar) +import Control.Concurrent.STM (TQueue, atomically, readTMVar) import Control.Monad (forM_, void, when) import Control.Exception (finally) import qualified Data.Aeson as J @@ -47,7 +48,7 @@ import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, endOf import Simplex.Chat.Badges.Service import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) import Simplex.Chat.Bot.Store (withDB') -import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (CRCustomChatResponse)) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError (..), ChatErrorType (..), ChatResponse (CRCustomChatResponse)) import Simplex.Chat.Core (sendChatCmdStr) import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB @@ -79,16 +80,18 @@ badgeServiceTests = do it "should refuse a code that has not been paid for" testRedeemUnpaidCode it "should refuse a badge code past its redemption deadline" testExpiredCode it "should keep answering a code redeemed before its deadline" testRedeemedBeforeTheDeadline - it "should refuse a revoked badge code, and refuse to revoke it twice" testRevokedCode + it "should refuse a revoked badge code, and report a second revoke as already revoked" testRevokedCode it "should refuse to revoke a code that was redeemed, and keep its badge" testRevokeRedeemedCode it "should answer revoking an unknown code as no such code" testRevokeUnknownCode + it "should answer code_invalid to a code that is both unpaid and revoked" testRevokedUnpaidCode + it "should refuse a revoke with trailing input, leaving the code live" testRevokeRejectsTrailingInput it "should refuse to issue a code with an unknown badge type or a nonsense month count" testIssueRejectsBadArguments it "should refuse a request whose purchaseKey is not the verified signer" testPurchaseKeyMismatch it "should refuse to start unless the issuer secret is the key trusted at its index" testIssuerKeyMustMatchConfig it "should refuse to start when the [issuer] key is not one clients trust" testIssuerIniKeyMustBeTrusted it "should credit a code's months and issue one credential per month" testCodeMonthsRenew it "should return the stored credential for a repeat inside an issued period" testRepeatInsideIssuedPeriod - it "should redeem a multi-use code to its limit" testMultiUseWithoutGroup + it "should redeem a multi-use code to its limit with no group to track it" testMultiUseWithoutGroup it "should not spend a multi-use code again when its holder redeems it after the badge ended" testMultiUseRepeatAfterExpiry it "should answer internal, spending no use, when a holder's stored credential is unreadable" testUnreadableCredentialIsInternal it "should lapse only the months that elapsed while the client was away" testLapseWhileAway @@ -115,8 +118,11 @@ badgeServiceTests = do it "should broadcast the current profile when a renewal presents a badge" testRenewalKeepsProfileEdits it "should present the month already issued when a previous pass did not" testPresentationCatchesUp +badgeBotName :: Text +badgeBotName = "SimpleX Badges" + badgeProfile :: Profile -badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} +badgeProfile = Profile {displayName = badgeBotName, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} serviceDbPrefix :: FilePath serviceDbPrefix = "badge_service" @@ -137,7 +143,7 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey = {dbFilePrefix = ps serviceDbPrefix} #endif }, - serviceName = "SimpleX Badges", + serviceName = badgeBotName, clientService = True, noAddress = False, runCLI = False, @@ -202,11 +208,15 @@ withBadgeServiceEnv ps test = do issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode issueCode cc badgeType months = issueCodeAs cc badgeType months "free" -revokeCodeAs :: HasCallStack => ChatController -> BadgeCode -> IO T.Text -revokeCodeAs cc code = - sendChatCmdStr cc ("//revoke " <> T.unpack (formatBadgeCode code)) >>= \case - Right (CRCustomChatResponse _ response) -> pure response - Left e -> pure (T.pack (show e)) +revokeCodeAs :: HasCallStack => ChatController -> BadgeCode -> IO (Either T.Text T.Text) +revokeCodeAs cc code = revokeRaw cc (formatBadgeCode code) + +-- | Left is a refusal or a failure the service answers as a command error. +revokeRaw :: HasCallStack => ChatController -> T.Text -> IO (Either T.Text T.Text) +revokeRaw cc args = + sendChatCmdStr cc ("//revoke " <> T.unpack args) >>= \case + Right (CRCustomChatResponse _ response) -> pure (Right response) + Left (ChatError (CECommandError e)) -> pure (Left (T.pack e)) r -> error $ "revoke failed: " <> show (() <$ r) issueCodeAs :: HasCallStack => ChatController -> BadgeType -> Int -> String -> IO BadgeCode @@ -323,11 +333,13 @@ testIssueRejectsBadArguments ps = refuses "" issueRaw cc "supporter 255 paid" >>= (`shouldSatisfy` isRight) -issueRaw :: ChatController -> String -> IO (Either () ()) +-- | Left is a refusal or a failure the service answers as a command error. +issueRaw :: HasCallStack => ChatController -> String -> IO (Either T.Text ()) issueRaw cc args = sendChatCmdStr cc ("//issue " <> args) >>= \case Right CRCustomChatResponse {} -> pure $ Right () - _ -> pure $ Left () + Left (ChatError (CECommandError e)) -> pure (Left (T.pack e)) + r -> error $ "issue failed: " <> show (() <$ r) testRedeemSecondCode :: HasCallStack => TestParams -> IO () testRedeemSecondCode ps = @@ -369,12 +381,16 @@ testRedeemSameCodeOtherProfile ps = showActiveUser alice "alice (Alice, * supporter)" serviceCmd :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse -serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} purchaseKey request = - badgeServiceResponse bsIssuerKey bsController (Just purchaseKey) reqObject - where - reqObject = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of - J.Object o -> o - _ -> error "badge service request must encode as an object" +serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} = serviceCmdWith bsIssuerKey bsController Nothing + +serviceCmdWith :: HasCallStack => BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse +serviceCmdWith key cc trackerQ_ purchaseKey request = + badgeServiceResponse key cc trackerQ_ (Just purchaseKey) (requestObject purchaseKey request) + +requestObject :: HasCallStack => C.PublicKeyEd25519 -> BadgeServiceCommand -> J.Object +requestObject purchaseKey request = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of + J.Object o -> o + _ -> error "badge service request must encode as an object" entryOf :: StatementEntry -> (Int, Int, UTCTime) entryOf StatementEntry {changeMonths, balanceMonths, balanceStartTs} = (changeMonths, balanceMonths, balanceStartTs) @@ -418,11 +434,16 @@ newPurchaseKeys = do (purchaseKey,) <$> generateMasterKey g redeemAsNewPurchase :: HasCallStack => BadgeServiceEnv -> BadgeCode -> IO BadgeServiceResponse -redeemAsNewPurchase env code = newPurchaseKeys >>= \keys -> redeemWithKeys env keys code +redeemAsNewPurchase BadgeServiceEnv {bsIssuerKey, bsController} = redeemWithQueue bsIssuerKey bsController Nothing . badgeCodeText redeemWithKeys :: HasCallStack => BadgeServiceEnv -> (C.PublicKeyEd25519, BadgeMasterKey) -> BadgeCode -> IO BadgeServiceResponse redeemWithKeys env (purchaseKey, masterKey) code = serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} +redeemWithQueue :: HasCallStack => BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> Text -> IO BadgeServiceResponse +redeemWithQueue key cc trackerQ_ codeText = do + (purchaseKey, masterKey) <- newPurchaseKeys + serviceCmdWith key cc trackerQ_ purchaseKey BSCRedeemBadgeCode {masterKey, code = codeText} + assertBalance :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> StatementEntry -> IO BadgeServiceResponse assertBalance env purchaseKey lastEntry = serviceCmd env purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry}} @@ -525,7 +546,7 @@ testUnreadableCredentialIsInternal ps = redeem holder >>= (`shouldAnswerError` BSEInternal) codeUses cc code `shouldReturn` Just (2, 2) --- The operator's //issue makes single-use codes only, so multi-use codes are issued directly. +-- Multi-use codes come from the group command, and this service has no group. issueMultiUseCode :: HasCallStack => ChatController -> BadgeType -> Int -> Int -> IO BadgeCode issueMultiUseCode cc badgeType months uses = issueOneCode cc badgeType months CPSFree uses >>= \case @@ -810,7 +831,7 @@ testRevokedMultiUseHolderRenews ps = code <- issueMultiUseCode cc BTSupporter 3 2 redeemFirstBadge alice code redeemed <- ledgerRows (chatController alice) "badge_ledger" - revokeCodeAs cc code `shouldReturn` "revoked" + revokeCodeAs cc code `shouldReturn` Right "revoked" redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeInvalid) codeUses cc code `shouldReturn` Just (2, 1) -- A holder whose reply was lost retries with the same key and still gets its badge. @@ -1497,7 +1518,7 @@ testRevokeRedeemedCode ps = alice <## "supporter badge - active" alice <##. "expires " refused <- revokeCodeAs cc code - refused `shouldSatisfy` T.isInfixOf "redeemed already, so it cannot be revoked" + refused `shouldBe` Left "code was redeemed already, so it cannot be revoked" alice ##> ("/_redeem_badge_code 1 " <> codeArg code) alice <## "badge already redeemed" @@ -1507,15 +1528,34 @@ testRevokeUnknownCode ps = g <- C.newRandom code <- randomBadgeCode g unknown <- revokeCodeAs cc code - unknown `shouldSatisfy` T.isInfixOf "no such code" + unknown `shouldBe` Left "no such code" testRevokedCode :: HasCallStack => TestParams -> IO () testRevokedCode ps = withBadgeService ps $ \clientCfg _ cc -> withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do paid <- issueCodeAs cc BTSupporter 1 "paid" - revokeCodeAs cc paid `shouldReturn` "revoked" + revokeCodeAs cc paid `shouldReturn` Right "revoked" alice ##> ("/_redeem_badge_code 1 " <> codeArg paid) alice <## "cannot redeem badge code: badge service error: code_invalid" - second <- revokeCodeAs cc paid - second `shouldSatisfy` T.isInfixOf "revoked already" + revokeCodeAs cc paid `shouldReturn` Right "already revoked" + +testRevokedUnpaidCode :: HasCallStack => TestParams -> IO () +testRevokedUnpaidCode ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + code <- issueCodeAs cc BTSupporter 1 "unpaid" + revokeCodeAs cc code `shouldReturn` Right "revoked" + redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeInvalid) + +testRevokeRejectsTrailingInput :: HasCallStack => TestParams -> IO () +testRevokeRejectsTrailingInput ps = + withBadgeService ps $ \_ _ cc -> do + code <- issueCodeAs cc BTSupporter 1 "paid" + refused <- revokeRaw cc (formatBadgeCode code <> " junk") + -- If the refused call revoked the code anyway, this fails with "already revoked". + revokeCodeAs cc code `shouldReturn` Right "revoked" + refused `shouldBe` Left badgeCmdUsage + +-- The text is spelled out rather than taken from the service, so a change there fails here. +badgeCmdUsage :: Text +badgeCmdUsage = "use: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke " diff --git a/tests/Bots/BadgeService/ConfigTests.hs b/tests/Bots/BadgeService/ConfigTests.hs index d27698622d..7d5c5c9a7f 100644 --- a/tests/Bots/BadgeService/ConfigTests.hs +++ b/tests/Bots/BadgeService/ConfigTests.hs @@ -36,6 +36,7 @@ badgeConfigTests = describe "badge service config" $ do it "accepts a payment tolerance and refuses one that settles for a satoshi" testPaymentTolerance it "refuses a host that would send the api key in the clear" testHostMustBeHttps it "names a setting nothing reads, in every section it parses" testUnknownKeysAreNamed + it "ignores a section nothing reads rather than refusing the file" testUnknownSectionStillBoots it "refuses a file one malformed line would silently truncate" testMalformedLineRefused it "accepts a comment or blank line after the last setting" testTrailingCommentIsAccepted it "reports a missing file rather than throwing" testMissingFileIsReported @@ -46,16 +47,17 @@ badgeConfigTests = describe "badge service config" $ do it "refuses an index that is not a positive whole number" testIssuerIndexInvalid it "refuses a private key that is not a valid issuer secret" testIssuerBadSecret it "names the old default and key_ settings, then refuses the boot" testIssuerOldFormat - it "leaves chat redemption off when the dev section is absent" testDevRedeemAbsent - it "reads chat_redeem = on" testDevRedeemOn - it "reads chat_redeem = off" testDevRedeemOff - it "refuses a chat_redeem that is not on or off" testDevRedeemNotBoolean + groupConfigTests fullIni :: T.Text fullIni = T.unlines [ "[listener]", "static_dir = /srv/badges", + -- [group] stays before [btcpay], since tests append btcpay keys to this fixture. + "[group]", + "display_name = SimpleX Badges", + "description = badge ops desk", "[btcpay]", "host = https://btcpay.example.org", "api_key = token-value", @@ -224,19 +226,25 @@ testExpiryMinutes = do testUnknownKeysAreNamed :: IO () testUnknownKeysAreNamed = - withIni (fullIni <> "speed_polcy = LowSpeed\ntrust_forwaded_for = on\n[poll]\nwaiting_secnds = 5\n[dev]\nchat_redem = on\n") $ \p -> do + withIni (fullIni <> "speed_polcy = LowSpeed\ntrust_forwaded_for = on\n[poll]\nwaiting_secnds = 5\n[stripe]\nsecret_ky = rk_test_x\n") $ \p -> do Right ini <- readIniFile p - unknownKeys ini `shouldMatchList` ["btcpay.speed_polcy", "btcpay.trust_forwaded_for", "poll.waiting_secnds", "dev.chat_redem"] + unknownKeys ini `shouldMatchList` ["btcpay.speed_polcy", "btcpay.trust_forwaded_for", "poll.waiting_secnds", "stripe.secret_ky"] withIni (T.replace "[btcpay]" "[btcpai]" fullIni) $ \wrongSection -> do Right sectionIni <- readIniFile wrongSection unknownKeys sectionIni `shouldContain` ["[btcpai]"] - withIni ("chat_redeem = on\n" <> fullIni) $ \stray -> do + withIni ("static_dir = /srv/badges\n" <> fullIni) $ \stray -> do Right strayIni <- readIniFile stray - unknownKeys strayIni `shouldContain` ["chat_redeem, written above the first section header"] + unknownKeys strayIni `shouldContain` ["static_dir, written above the first section header"] withIni fullIni $ \clean -> do Right cleanIni <- readIniFile clean unknownKeys cleanIni `shouldBe` [] +testUnknownSectionStillBoots :: IO () +testUnknownSectionStillBoots = + parseIni (fullIni <> "[legacy]\nsetting = on\n") >>= \r -> case r of + Right cfg -> lStaticDir (listener cfg) `shouldBe` "/srv/badges" + Left e -> expectationFailure ("a section nothing reads must be ignored, not refused: " <> e) + -- | The ini parser stops at the first line it cannot read and keeps what it has, so without this a -- missing `=` in [listener] would silently drop every section below it, and the provider with it. testMalformedLineRefused :: IO () @@ -252,7 +260,7 @@ testTrailingCommentIsAccepted :: IO () testTrailingCommentIsAccepted = do accepts (fullIni <> "; rotated the api key on 2026-09-01\n") accepts (fullIni <> "\n\n") - accepts (fullIni <> "[dev]\n; chat_redeem = on\n") + accepts (fullIni <> "[poll]\n; idle_seconds = 5\n") accepts (fullIni <> "# a hash comment, with no newline after it") where accepts t = @@ -345,25 +353,58 @@ testIssuerOldFormat = do unknownKeys ini `shouldMatchList` ["issuer.default", "issuer.key_1"] issuerRefusal old `shouldReturn` "issuer.index is required" -testDevRedeemAbsent :: IO () -testDevRedeemAbsent = withIni fullIni $ \p -> do - Right cfg <- readServiceConfig p - devChatRedeem cfg `shouldBe` False +parseIni :: T.Text -> IO (Either String ServiceConfig) +parseIni t = withIni t readServiceConfig -testDevRedeemOn :: IO () -testDevRedeemOn = withDev "chat_redeem = on\n" $ \r -> case r of - Right cfg -> devChatRedeem cfg `shouldBe` True - Left e -> expectationFailure ("[dev] chat_redeem = on is legal: " <> e) +groupConfigTests :: Spec +groupConfigTests = describe "group config" $ do + it "parses display_name and description" testGroupNameAndDescription + it "defaults description to Nothing" testGroupNoDescription + it "treats a blank description as absent" testGroupBlankDescription + it "refuses a display_name no group can be created under" testGroupInvalidName + it "suggests no name when no character of display_name is valid" testGroupNoValidName + it "requires display_name when the section is present" testGroupMissingName + it "leaves group Nothing when the section is absent" testGroupAbsent -testDevRedeemOff :: IO () -testDevRedeemOff = withDev "chat_redeem = off\n" $ \r -> case r of - Right cfg -> devChatRedeem cfg `shouldBe` False - Left e -> expectationFailure ("[dev] chat_redeem = off is legal: " <> e) +listenerIni :: T.Text +listenerIni = "[listener]\nstatic_dir = /srv/web\n" -testDevRedeemNotBoolean :: IO () -testDevRedeemNotBoolean = withDev "chat_redeem = true\n" $ \r -> case r of - Left e -> e `shouldContain` "chat_redeem" - Right _ -> expectationFailure "only on and off are accepted, so a typo cannot silently disarm the gate" +groupIni :: T.Text -> IO (Either String ServiceConfig) +groupIni body = parseIni (listenerIni <> "[group]\n" <> body) -withDev :: T.Text -> (Either String ServiceConfig -> IO a) -> IO a -withDev keys act = withIni (fullIni <> "[dev]\n" <> keys) $ \p -> readServiceConfig p >>= act +testGroupNameAndDescription :: IO () +testGroupNameAndDescription = do + r <- groupIni "display_name = SimpleX Badges\ndescription = Welcome\n" + fmap group r `shouldBe` Right (Just GroupConfig {gDisplayName = "SimpleX Badges", gDescription = Just "Welcome"}) + +testGroupNoDescription :: IO () +testGroupNoDescription = do + r <- groupIni "display_name = X\n" + fmap group r `shouldBe` Right (Just GroupConfig {gDisplayName = "X", gDescription = Nothing}) + +testGroupBlankDescription :: IO () +testGroupBlankDescription = do + r <- groupIni "display_name = X\ndescription = \n" + fmap group r `shouldBe` Right (Just GroupConfig {gDisplayName = "X", gDescription = Nothing}) + +testGroupInvalidName :: IO () +testGroupInvalidName = do + r <- groupIni "display_name = Значки (staging)\n" + case r of + Left e -> e `shouldBe` "group.display_name \"Значки (staging)\" is not a valid group name, the closest valid name is \"Значки staging\"" + Right cfg -> expectationFailure ("a name the core refuses must not boot, and this one kept " <> show (group cfg)) + +testGroupNoValidName :: IO () +testGroupNoValidName = do + r <- groupIni "display_name = !!!\n" + fmap group r `shouldBe` Left "group.display_name \"!!!\" is not a valid group name" + +testGroupMissingName :: IO () +testGroupMissingName = do + r <- groupIni "description = hi\n" + fmap group r `shouldBe` Left "group.display_name is required" + +testGroupAbsent :: IO () +testGroupAbsent = do + r <- parseIni listenerIni + fmap group r `shouldBe` Right Nothing diff --git a/tests/Bots/BadgeService/GroupIntegrationTests.hs b/tests/Bots/BadgeService/GroupIntegrationTests.hs new file mode 100644 index 0000000000..afde82c359 --- /dev/null +++ b/tests/Bots/BadgeService/GroupIntegrationTests.hs @@ -0,0 +1,1411 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Members' messages reach a console over separate connections in no fixed order, so gating is asserted from the bot's store. +module Bots.BadgeService.GroupIntegrationTests (badgeGroupIntegrationTests) where + +import BadgeService.Config (BadgeIssuerKey (..), GroupConfig (..)) +import BadgeService.Group (GroupAction (..), GroupEvent (..), codeInTracker, ensureManagedGroup) +import BadgeService.Group.Command (maxUses) +import BadgeService.Options (BadgeServiceOpts (..)) +import BadgeService.Service (ServiceState (..), badgeService, newServiceState) +import BadgeService.Store (ManagedGroup (..), getManagedGroup) +import Bots.BadgeService.BotTests (badgeBotName, badgeProfile, badgeTypeOf, credentialOf, entryOf, issueCode, issueRaw, mkBadgeServiceOpts, newPurchaseKeys, redeemWithQueue, requestObject, revokeRaw, serviceDbPrefix, shouldAnswerError, statementOf, stopBadgeService, testIssuerKeyIdx) +import ChatClient +import ChatTests.DBUtils +import ChatTests.Utils +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, async, cancel, poll, waitCatchSTM) +import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, orElse, readTMVar, readTQueue, readTVarIO, tryReadTMVar, writeTQueue) +import Control.Exception (IOException, bracket, catch, finally, throwIO, try) +import Control.Monad (forM_, guard, mfilter, replicateM_, unless, void, when) +import Data.Either (isRight) +import Data.Int (Int64) +import Data.List (isInfixOf) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, getCurrentTime) +import Network.Socket (Family (..), SockAddr (..), SocketType (..), close, connect, defaultProtocol, socket, tupleToHostAddress) +import Network.Wai.Handler.Warp (openFreePort) +import Simplex.Chat.Badges (BadgeType (..)) +import Simplex.Chat.Badges.Code (formatBadgeCode, parseBadgeCode, randomBadgeCode) +import Simplex.Chat.Badges.Service +import Simplex.Chat.Controller (ChatCommand (APIDeleteChatItem), ChatConfig (..), ChatController (..), ChatResponse (CRChatItemsDeleted)) +import Simplex.Chat.Core (sendChatCmd, sendChatCmdStr) +import Simplex.Chat.Messages (ChatRef (ChatRef), ChatType (CTGroup)) +import Simplex.Chat.Messages.CIContent (CIDeleteMode (CIDMInternal)) +import Simplex.Chat.Types (AgentInvId (..)) +import Simplex.Chat.Types.Preferences (ChatBotCommand (..), FullDeleteGroupPreference (..), GroupFeatureEnabled (..), GroupFeatureI (..), GroupPreferences (..), HistoryGroupPreference (..), SGroupFeature (..), commands_, emptyGroupPrefs, getGroupPreference) +import Simplex.Chat.Types.Shared (GroupMemberRole (..)) +import Simplex.Messaging.Agent (disposeAgentClient) +import Simplex.Messaging.Agent.Protocol (AConnShortLink (..), ConnShortLink (..), ContactConnType (..)) +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Crypto.BBS (bbsKeyGen) +import Simplex.Messaging.Encoding.String (strDecode) +import Simplex.Messaging.Util (tshow) +import System.Directory (createDirectoryIfMissing) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.Timeout (timeout) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (FromRow, Only (..)) +#else +import Database.SQLite.Simple (FromRow, Only (..)) +#endif +import Test.Hspec hiding (it) + +badgeGroupIntegrationTests :: SpecWith TestParams +badgeGroupIntegrationTests = do + it "creates the group and a join link on first start; on restart reuses it, re-advertises commands and keeps other preferences" testGroupCreateReuse + it "keeps the group's name and description when the configured ones change" testConfigNotApplied + it "promotes the first joiner to owner and leaves a later joiner a member" testFirstJoinerPromoted + it "promotes nobody after the first promotion failed" testFailedPromotionNotRetried + it "promotes the earliest member on start when their join was never handled" testMissedOwnerPromotedOnStart + it "promotes the earliest member, not a later joiner, when no owner was set up" testEarliestPromotedOnLaterJoin + it "skips a member still joining when promoting on start" testJoiningMemberSkippedOnStart + it "only records an owner made by hand on start, promoting nobody" testHandMadeOwnerKeptOnStart + it "promotes a member on start when the owner made by hand has left" testLeftOwnerReplacedOnStart + it "promotes nobody on start once the owner was set up, even with no owner left" testSetUpOwnerNotReplacedOnStart + it "does not serve a group its owner deleted" testDeletedGroupNotServed + it "does not serve a group the service itself deleted" testOwnDeletedGroupNotServed + it "drops the old group's trackers when it creates a new group" testReplacedGroupDropsTrackers + it "stops rather than create a second group when the group lookup fails" testGroupLookupFailureStops + it "stops the service's lanes when its runner is cancelled" testCancelStopsLanes + it "issues on a privileged member's command, ignores a plain member's" testRoleGatedIssue + it "ignores a command from a privileged member blocked for all" testBlockedMemberCommandIgnored + it "ignores a command sent in a member support scope" testSupportScopeIgnored + it "ignores a command sent as a live message" testLiveMessageIgnored + it "ignores an event for another group" testOtherGroupEventIgnored + it "issues a batch of redeemable single-use codes of the asked type and months on /bulk" testBulkIssue + it "issues an /issue code for the months the command asked for" testIssueMonths + it "answers a failed /issue or //issue without naming what failed in the store" testIssueFailureIsOpaque + it "lists the codes a /bulk issued before an insert failed" testBulkPartialFailureListsIssued + it "answers a failed /revoke without naming what failed in the store" testRevokeFailureIsOpaque + it "tracks a multi-use code across redemptions and refuses it when used up" testMultiUseTracker + it "keeps the counter and posts no second notice for a stale refresh of a used-up code" testStaleRefreshIgnored + it "announces a second multi-use code used up on the claim that uses it up" testSecondMultiUseCodeExhausted + it "refreshes the tracker for a redemption served with no group lane" testLanelessRedeemRefreshesTracker + it "refreshes the tracker for a redemption from the service's request queue" testQueuedRequestRefreshesTracker + it "refreshes the tracker inline for a queued redemption after a restart without [group]" testQueuedRequestWithoutGroupConfig + it "reposts and re-anchors the tracker past the edit window" testTrackerRepost + it "reposts and re-anchors the tracker when the core refuses the edit" testRefusedEditReposted + it "keeps the tracker anchored when the repost cannot be sent" testFailedRepostDropped + it "never reposts a tracker deleted on the service's side, publishing the code no further" testDeletedTrackerNotReposted + it "never reposts a tracker an owner deleted for everyone" testModeratedTrackerNotReposted + it "revokes a code whose tracker was deleted on the service's side without reposting it" testDeletedTrackerNotRepostedOnRevoke + it "posts no notice when a code whose tracker was deleted is used up" testDeletedTrackerNoNotice + it "revokes a code whose tracker an owner deleted for everyone without reposting it" testModeratedTrackerNotRepostedOnRevoke + it "revokes a code on /revoke, answers a repeat as already revoked and an unknown code as no such code" testGroupRevoke + it "retires the tracker message when a multi-use code is revoked" testRevokeRetiresTracker + it "retires the tracker message when the service command revokes the code" testServiceRevokeRetiresTracker + it "retires a tracker left behind when the code is revoked again" testGroupRevokeRepairsTracker + it "retires a tracker left behind when the service command revokes again" testServiceRevokeRepairsTracker + it "posts one retired tracker however often a revoke past the window repeats" testRevokeRepeatPastWindow + it "reconciles an exhausted tracker whose refresh was lost, posting no notice" testExhaustedTrackerReconciledOnRestart + it "reconciles a tracker with uses left whose refresh was lost" testStalledTrackerReconciledOnRestart + it "retires on restart a tracker whose revoke never reached it" testRevokedTrackerReconciledOnRestart + it "reconciles every stalled tracker on restart, not only the first" testEveryStalledTrackerReconciled + it "leaves a tracker it cannot edit alone rather than publishing the code again" testUneditableTrackerLeftAlone + +groupName :: String +groupName = "testbadges" + +groupDescr :: Text +groupDescr = "badge ops desk" + +testGroupConfig :: GroupConfig +testGroupConfig = GroupConfig {gDisplayName = T.pack groupName, gDescription = Just groupDescr} + +revokeReply :: Text -> Text -> Text +revokeReply code outcome = code <> ": " <> outcome + +revokeCmd :: Text -> String +revokeCmd code = "/revoke " <> T.unpack code + +revokeInGroup :: HasCallStack => ChatController -> TestCC -> Text -> Text -> IO () +revokeInGroup cc member code outcome = do + sendGroupCmd member (revokeCmd code) + waitStoredItem cc (revokeReply code outcome) + +-- The name is quoted because console output quotes a name with a space. +botName :: String +botName = "'" <> T.unpack badgeBotName <> "'" + +data GroupSvc = GroupSvc + { gsCfg :: ChatConfig, + gsKey :: BadgeIssuerKey, + gsStaticDir :: FilePath, + gsPs :: TestParams + } + +prepareGroupService :: HasCallStack => TestParams -> IO GroupSvc +prepareGroupService ps@TestParams {tmpPath} = + bbsKeyGen >>= \case + Left e -> error $ "bbsKeyGen failed: " <> e + Right (pk, sk) -> do + let gsKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk} + gsCfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk} + gsStaticDir = tmpPath "badge_group_static" + createDirectoryIfMissing True gsStaticDir + withNewTestChatCfg ps gsCfg serviceDbPrefix badgeProfile $ \_ -> pure () + pure GroupSvc {gsCfg, gsKey, gsStaticDir, gsPs = ps} + +runGroupService :: HasCallStack => GroupSvc -> (ChatController -> ServiceState -> Int64 -> IO a) -> IO a +runGroupService svc = runGroupServiceAs svc (Just testGroupConfig) + +runGroupServiceAs :: HasCallStack => GroupSvc -> Maybe GroupConfig -> (ChatController -> ServiceState -> Int64 -> IO a) -> IO a +runGroupServiceAs svc groupCfg action = do + (t, cc, env, port) <- startGroupService svc groupCfg + -- The web listener starts after group start-up, so the stop cannot land inside start-up's database calls. + let started = pollUntilTrue (listening port) >> pollUntil (getStoredGroup cc) + -- A stop inside a lane's database call leaves a statement open, and closing the store then fails. + settle gid = when (isJust groupCfg) $ do + status <- memberStatus cc gid badgeBotName + forM_ status $ \s -> unless (s `elem` ["removed", "left", "deleted"]) $ settleLane cc env gid + (started >>= \ManagedGroup {mgGroupId} -> action cc env mgGroupId <* settle mgGroupId) `finally` stopGroupService t cc + +-- It returns once chat has started, while group start-up may still run; the Int is its web listener's port. +startGroupService :: HasCallStack => GroupSvc -> Maybe GroupConfig -> IO (Async (), ChatController, ServiceState, Int) +startGroupService svc@GroupSvc {gsCfg} groupCfg = do + (opts, port) <- groupServiceOpts svc groupCfg + env <- newServiceState + t <- async $ badgeService opts gsCfg env + -- A service that ends before it is ready fails the test with its own error, not the timeout. + cc <- + timeout waitLimit (atomically $ (Right <$> readTMVar (serviceCC env)) `orElse` (Left <$> waitCatchSTM t)) >>= \case + Just (Right cc) -> pure cc + Just (Left ended) -> either throwIO (\_ -> error "badge service ended before it started") ended + Nothing -> cancel t >> error "badge service did not start" + pure (t, cc, env, port) + +-- Cancelling ends the service lanes while chat still runs; stopping chat first would leave them running. +stopGroupService :: Async () -> ChatController -> IO () +stopGroupService t cc = do + -- cancel discards how the service ended, so a crash is read first and rethrown after cleanup. + ended <- poll t + cancel t + stopChat cc + forM_ ended $ either throwIO pure + +stopChat :: ChatController -> IO () +stopChat cc = stopBadgeService cc >> disposeAgentClient (smpAgent cc) + +-- It writes the service's ini on a free port; Nothing omits the [group] section. +groupServiceOpts :: GroupSvc -> Maybe GroupConfig -> IO (BadgeServiceOpts, Int) +groupServiceOpts GroupSvc {gsKey = BadgeIssuerKey {secretKey}, gsStaticDir, gsPs = ps@TestParams {tmpPath}} groupCfg = do + (port, sock) <- openFreePort + close sock + let iniPath = tmpPath "badge_group.ini" + writeFile iniPath $ + unlines $ + [ "[listener]", + "host = 127.0.0.1", + "port = " <> show port, + "static_dir = " <> gsStaticDir + ] + <> maybe [] groupSection groupCfg + pure ((mkBadgeServiceOpts ps secretKey) {serviceConfigFile = Just iniPath, noAddress = True}, port) + where + groupSection GroupConfig {gDisplayName, gDescription} = + ["", "[group]", "display_name = " <> T.unpack gDisplayName] + <> maybe [] (\d -> ["description = " <> T.unpack d]) gDescription + +withGroupOwner :: HasCallStack => TestParams -> (BadgeIssuerKey -> ChatController -> ServiceState -> TestCC -> IO ()) -> IO () +withGroupOwner ps action = do + svc@GroupSvc {gsKey} <- prepareGroupService ps + runWithOwner svc $ \cc env _ -> action gsKey cc env + +runWithOwner :: HasCallStack => GroupSvc -> (ChatController -> ServiceState -> Int64 -> TestCC -> IO a) -> IO a +runWithOwner svc@GroupSvc {gsPs} action = runGroupService svc $ \cc env gid -> withOwnerJoined gsPs cc gid $ action cc env gid + +withOwnerJoined :: HasCallStack => TestParams -> ChatController -> Int64 -> (TestCC -> IO a) -> IO a +withOwnerJoined ps cc gid action = + withNewTestChat ps "alice" aliceProfile $ \alice -> do + joinGroup cc alice + waitMemberRole cc gid "alice" "owner" + r <- action alice + drainConsole alice + pure r + +-- Bob joins after the first member and is connected to her. +withMemberJoined :: HasCallStack => TestParams -> ChatController -> TestCC -> (TestCC -> IO a) -> IO a +withMemberJoined ps cc alice action = + withNewTestChat ps "bob" bobProfile $ \bob -> do + joinGroup cc bob + drainUntil alice ["#" <> groupName <> ": new member bob is connected"] + r <- action bob + drainConsole bob + pure r + +joinGroup :: HasCallStack => ChatController -> TestCC -> IO () +joinGroup cc member = groupLink cc >>= send member . ("/c " <>) + +sendGroupCmd :: TestCC -> String -> IO () +sendGroupCmd member cmd = send member ("#" <> groupName <> " " <> cmd) + +issueTracked :: HasCallStack => ChatController -> TestCC -> String -> Int -> IO (Int64, Text, Text) +issueTracked cc member badgeType uses = do + sendGroupCmd member ("/issue " <> badgeType <> " uses " <> show uses) + (citemId, body) <- waitTrackerItemOf cc uses + pure (citemId, body, extractCode body) + +testGroupCreateReuse :: HasCallStack => TestParams -> IO () +testGroupCreateReuse ps = do + svc <- prepareGroupService ps + runGroupService svc $ \cc _ gid -> do + ManagedGroup {mgGroupLink} <- storedGroup cc + shortLinkContactType mgGroupLink `shouldBe` Right CCTGroup + groupCount cc `shouldReturn` 1 + advertisedCommands cc gid `shouldReturn` Just expectedCommands + profileDescription cc gid `shouldReturn` Just groupDescr + profileFullNameShortDescr cc gid `shouldReturn` ("", Nothing) + groupFeaturePreference cc gid SGFHistory `shouldReturn` HistoryGroupPreference {enable = FEOff} + -- The first run never rewrites the profile, so only the restart can restore what is blanked here. + clearCommandsSettingFullDelete cc gid + advertisedAt <- runGroupService svc $ \cc _ gid -> do + -- Commands are advertised as the group is resolved, so once they are back this run has found the stored group. + waitAdvertisedCommands cc gid + groupCount cc `shouldReturn` 1 + profileDisplayName cc gid `shouldReturn` T.pack groupName + profileDescription cc gid `shouldReturn` Just groupDescr + profileFullNameShortDescr cc gid `shouldReturn` ("", Nothing) + groupFeaturePreference cc gid SGFFullDelete `shouldReturn` FullDeleteGroupPreference {enable = FEOn, role = Nothing} + profileUpdatedAt cc gid + -- The lane drains only after the group is resolved, so the promotion proves the start-up sync has run. + runWithOwner svc $ \cc _ gid _ -> profileUpdatedAt cc gid `shouldReturn` advertisedAt + +testConfigNotApplied :: HasCallStack => TestParams -> IO () +testConfigNotApplied ps = do + svc <- prepareGroupService ps + -- Clearing the commands makes the restart rewrite the profile, the only path that could apply the new config. + runGroupService svc $ \cc _ gid -> clearCommandsSettingFullDelete cc gid + runGroupServiceAs svc (Just GroupConfig {gDisplayName = "renamedbadges", gDescription = Just "renamed desk"}) $ \cc env gid -> do + waitAdvertisedCommands cc gid + awaitLane cc env + groupCount cc `shouldReturn` 1 + profileDisplayName cc gid `shouldReturn` T.pack groupName + profileDescription cc gid `shouldReturn` Just groupDescr + +testMissedOwnerPromotedOnStart :: HasCallStack => TestParams -> IO () +testMissedOwnerPromotedOnStart ps = do + svc <- prepareGroupService ps + -- A demoted owner with the flag cleared looks like a join the lane never handled. + withTwoMembersOwnerUnset svc $ \cc gid _ -> setMemberRole cc gid "alice" "member" + runGroupService svc $ \cc env gid -> do + waitMemberRole cc gid "alice" "owner" + awaitLane cc env + memberRoles cc gid `shouldReturn` [("alice", "owner"), ("bob", "member")] + +testEarliestPromotedOnLaterJoin :: HasCallStack => TestParams -> IO () +testEarliestPromotedOnLaterJoin ps = do + svc <- prepareGroupService ps + runWithOwner svc $ \cc env gid alice -> do + setMemberRole cc gid "alice" "member" + executeSql cc "UPDATE sx_badge_service_group SET owner_bootstrapped = 0" + withMemberJoined ps cc alice $ \_ -> do + waitMemberRole cc gid "alice" "owner" + awaitLane cc env + memberRoles cc gid `shouldReturn` [("alice", "owner"), ("bob", "member")] + +testJoiningMemberSkippedOnStart :: HasCallStack => TestParams -> IO () +testJoiningMemberSkippedOnStart ps = do + svc <- prepareGroupService ps + withTwoMembersOwnerUnset svc $ \cc gid _ -> do + setMemberRole cc gid "alice" "member" + withTransaction (chatStore cc) $ \db -> + DB.execute db "UPDATE group_members SET member_status = 'accepted' WHERE group_id = ? AND local_display_name = 'alice'" (Only gid) + runGroupService svc $ \cc env gid -> do + waitMemberRole cc gid "bob" "owner" + awaitLane cc env + memberRoles cc gid `shouldReturn` [("alice", "member"), ("bob", "owner")] + +testHandMadeOwnerKeptOnStart :: HasCallStack => TestParams -> IO () +testHandMadeOwnerKeptOnStart ps = do + svc <- prepareGroupService ps + withTwoMembersOwnerUnset svc $ \cc gid _ -> do + setMemberRole cc gid "bob" "owner" + setMemberRole cc gid "alice" "member" + runGroupService svc $ \cc env gid -> do + awaitLane cc env + memberRoles cc gid `shouldReturn` [("alice", "member"), ("bob", "owner")] + fmap mgOwnerBootstrapped <$> getStoredGroup cc `shouldReturn` Just True + +testDeletedGroupNotServed :: HasCallStack => TestParams -> IO () +testDeletedGroupNotServed ps = do + svc <- prepareGroupService ps + runWithOwner svc $ \cc _ gid alice -> do + drainConsole alice + alice ##> ("/d #" <> groupName) + alice <## ("#" <> groupName <> ": you deleted the group (signed)") + pollUntilTrue $ (== Just "deleted") <$> memberStatus cc gid badgeBotName + runGroupService svc $ \cc _ _ -> + ensureManagedGroup cc testGroupConfig `shouldReturn` Nothing + +testOwnDeletedGroupNotServed :: HasCallStack => TestParams -> IO () +testOwnDeletedGroupNotServed ps = do + svc <- prepareGroupService ps + runGroupService svc $ \cc env gid -> do + -- The harness cannot settle a deleted group, so the lane must be idle before the delete. + settleLane cc env gid + sendChatCmdStr cc ("/d #" <> groupName) >>= (`shouldSatisfy` isRight) + runGroupService svc $ \cc _ _ -> + ensureManagedGroup cc testGroupConfig `shouldReturn` Nothing + +testReplacedGroupDropsTrackers :: HasCallStack => TestParams -> IO () +testReplacedGroupDropsTrackers ps = do + svc <- prepareGroupService ps + runWithOwner svc $ \cc _ _ alice -> do + void $ issueTracked cc alice "supporter" 3 + executeSql cc "DELETE FROM sx_badge_service_group" + runGroupService svc $ \cc _ _ -> + countRows cc "sx_badge_service_badge_codes WHERE group_item_id IS NOT NULL OR group_item_sent_at IS NOT NULL" `shouldReturn` 0 + +testGroupLookupFailureStops :: HasCallStack => TestParams -> IO () +testGroupLookupFailureStops ps = do + svc@GroupSvc {gsCfg} <- prepareGroupService ps + runGroupService svc $ \cc _ _ -> + executeSql cc "ALTER TABLE sx_badge_service_group RENAME TO sx_badge_service_group_hidden" + (opts, _) <- groupServiceOpts svc (Just testGroupConfig) + env <- newServiceState + -- Falling through to create would keep the service running, so the timeout would fire instead. + ended <- timeout waitLimit (try $ badgeService opts gsCfg env) + atomically (tryReadTMVar (serviceCC env)) >>= mapM_ stopChat + ended `shouldBe` Just (Left (ExitFailure 1)) + +-- The web listener is one of the service's lanes and only the cancel precedes the check, +-- so its port closing shows the core ended the lanes. +testCancelStopsLanes :: HasCallStack => TestParams -> IO () +testCancelStopsLanes ps = do + svc <- prepareGroupService ps + (t, cc, _, port) <- startGroupService svc (Just testGroupConfig) + (pollUntilTrue (listening port) >> cancel t >> pollUntilTrue (not <$> listening port)) `finally` (cancel t >> stopChat cc) + +listening :: Int -> IO Bool +listening port = + bracket (socket AF_INET Stream defaultProtocol) close $ \s -> + (True <$ connect s (SockAddrInet (fromIntegral port) (tupleToHostAddress (127, 0, 0, 1)))) `catch` \(_ :: IOException) -> pure False + +testLeftOwnerReplacedOnStart :: HasCallStack => TestParams -> IO () +testLeftOwnerReplacedOnStart ps = do + svc <- prepareGroupService ps + withTwoMembersOwnerUnset svc $ \cc gid bob -> do + setMemberRole cc gid "bob" "owner" + setMemberRole cc gid "alice" "member" + send bob ("/l " <> groupName) + pollUntilTrue $ (== Just "left") <$> memberStatus cc gid "bob" + runGroupService svc $ \cc _ gid -> waitMemberRole cc gid "alice" "owner" + +testSetUpOwnerNotReplacedOnStart :: HasCallStack => TestParams -> IO () +testSetUpOwnerNotReplacedOnStart ps = do + svc <- prepareGroupService ps + runWithOwner svc $ \cc _ gid _ -> setMemberRole cc gid "alice" "member" + runGroupService svc $ \cc env gid -> do + awaitLane cc env + memberRoles cc gid `shouldReturn` [("alice", "member")] + +memberStatus :: ChatController -> Int64 -> Text -> IO (Maybe Text) +memberStatus cc gid name = + queryFirst cc $ + "SELECT member_status FROM group_members WHERE group_id = " + <> show gid + <> " AND local_display_name = '" + <> T.unpack name + <> "'" + +withTwoMembersOwnerUnset :: HasCallStack => GroupSvc -> (ChatController -> Int64 -> TestCC -> IO ()) -> IO () +withTwoMembersOwnerUnset svc@GroupSvc {gsPs = ps} action = + runWithOwner svc $ \cc env gid alice -> + withMemberJoined ps cc alice $ \bob -> do + -- The lane must handle bob's join before the flag is cleared, or it would act on the cleared flag in this run. + awaitLane cc env + action cc gid bob + executeSql cc "UPDATE sx_badge_service_group SET owner_bootstrapped = 0" + +testFirstJoinerPromoted :: HasCallStack => TestParams -> IO () +testFirstJoinerPromoted ps = do + svc <- prepareGroupService ps + runWithOwner svc $ \cc _ gid alice -> + withMemberJoined ps cc alice $ \bob -> do + waitMemberRole cc gid "bob" "member" + -- The bot queues bob's join before it introduces him, so alice's code proves the join was handled. + sendGroupCmd alice "/issue supporter" + waitCodeOfType cc "supporter" + memberRoles cc gid `shouldReturn` [("alice", "owner"), ("bob", "member")] + let codeReply = "#" <> groupName <> " " <> botName <> "> code SB-" + drainUntil alice [codeReply] + drainUntil bob [codeReply, "#" <> groupName <> ": member alice"] + +testFailedPromotionNotRetried :: HasCallStack => TestParams -> IO () +testFailedPromotionNotRetried ps = do + svc <- prepareGroupService ps + runGroupService svc $ \cc env gid -> do + -- An admin cannot make an owner, so the core refuses the promotion. + setBotRole cc "admin" + withNewTestChat ps "alice" aliceProfile $ \alice -> do + joinGroup cc alice + pollUntilTrue $ mgOwnerBootstrapped <$> storedGroup cc + awaitLane cc env + setBotRole cc "owner" + withMemberJoined ps cc alice $ \_ -> awaitLane cc env + memberRoles cc gid `shouldReturn` [("alice", "member"), ("bob", "member")] + drainConsole alice + +testRoleGatedIssue :: HasCallStack => TestParams -> IO () +testRoleGatedIssue ps = do + svc <- prepareGroupService ps + runWithOwner svc $ \cc _ gid alice -> + withNewTestChat ps "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> do + let announced name = "#" <> groupName <> ": " <> botName <> " added " <> name + preMember name = "#" <> groupName <> ": member " <> name + newMember name = "#" <> groupName <> ": new member " <> name <> " is connected" + usageReply = "#" <> groupName <> " " <> botName <> "> use: /issue " + joinGroup cc bob + waitMemberRole cc gid "bob" "member" + -- cath joins only after alice sees bob announced, or cath's console shows a different line. + drainUntil alice [announced "bob"] + joinGroup cc cath + waitMemberRole cc gid "cath" "member" + drainUntil cath [preMember "alice", preMember "bob"] + drainConsole cath + sendGroupCmd alice "/issue supporter" + getInAnyOrder + dropTime + cath + [ StartsWith ("#" <> groupName <> " alice> /issue supporter"), + StartsWith ("#" <> groupName <> " " <> botName <> "> code SB-") + ] + codeCount cc `shouldReturn` 1 + sendGroupCmd bob "/issue legend" + waitStoredItem cc "/issue legend" + ownerIssuesNext cc alice 2 + sendGroupCmd alice "/issue supporter uses 0" + waitStoredItem cc "use: /issue [months ] [uses ]" + codeCount cc `shouldReturn` 2 + drainUntil alice [usageReply, newMember "bob", newMember "cath"] + drainUntil bob [usageReply, preMember "alice", newMember "cath"] + drainUntil cath [usageReply] + drainConsole bob + drainConsole cath + +testBlockedMemberCommandIgnored :: HasCallStack => TestParams -> IO () +testBlockedMemberCommandIgnored ps = do + svc <- prepareGroupService ps + runWithOwner svc $ \cc _ gid alice -> + withMemberJoined ps cc alice $ \bob -> do + waitMemberRole cc gid "bob" "member" + -- bob is made moderator so that only the block can refuse his command. + send alice ("/mr #" <> groupName <> " bob moderator") + waitMemberRole cc gid "bob" "moderator" + -- The block and the command travel over different connections, so the block is awaited first. + send alice ("/block for all #" <> groupName <> " bob") + waitMemberBlocked cc gid "bob" + sendGroupCmd bob "/bulk legend months 255 count 100" + (deleted, content) <- waitBlockedItem cc "/bulk legend months 255 count 100" + deleted `shouldBe` blockedByAdminMark + content `shouldSatisfy` T.isInfixOf "/bulk legend months 255 count 100" + ownerIssuesNext cc alice 1 + +-- The lane is a single FIFO drainer, so the owner's next code proves every earlier command was handled. +ownerIssuesNext :: HasCallStack => ChatController -> TestCC -> Int -> IO () +ownerIssuesNext cc owner total = do + sendGroupCmd owner "/issue investor" + waitCodeOfType cc "investor" + codeCount cc `shouldReturn` total + +-- This is the item_deleted value the core writes for a message from a member blocked for all. +blockedByAdminMark :: Int +blockedByAdminMark = 3 + +testSupportScopeIgnored :: HasCallStack => TestParams -> IO () +testSupportScopeIgnored ps = + withGroupOwner ps $ \_ cc _ alice -> do + send alice "/_send #1(_support) text /issue legend" + waitStoredItem cc "/issue legend" + ownerIssuesNext cc alice 1 + +testLiveMessageIgnored :: HasCallStack => TestParams -> IO () +testLiveMessageIgnored ps = + withGroupOwner ps $ \_ cc _ alice -> do + send alice ("/live #" <> groupName <> " /issue legend") + waitStoredItem cc "/issue legend" + ownerIssuesNext cc alice 1 + +testOtherGroupEventIgnored :: HasCallStack => TestParams -> IO () +testOtherGroupEventIgnored ps = do + svc <- prepareGroupService ps + runGroupService svc $ \cc env gid -> do + atomically $ writeTQueue (groupEventQ env) (GEInGroup (gid + 1) (GACommand GROwner "/issue legend")) + awaitLane cc env + queryColumn cc "SELECT badge_type FROM sx_badge_service_badge_codes" `shouldReturn` ["supporter" :: Text] + +testBulkIssue :: HasCallStack => TestParams -> IO () +testBulkIssue ps = + withGroupOwner ps $ \gsKey cc env alice -> do + codes <- map extractCode . T.lines <$> replyTo cc alice "/bulk legend months 2 count 3" + length codes `shouldBe` 3 + codeCount cc `shouldReturn` 3 + singleUseCodeCount cc `shouldReturn` 3 + freeCodeCount cc `shouldReturn` 3 + forM_ codes $ \code -> do + r <- redeemViaService gsKey cc env code + badgeTypeOf r `shouldBe` Just BTLegend + map (\e -> let (c, m, _) = entryOf e in (c, m)) (fst $ statementOf r) `shouldBe` [(2, 2), (-1, 1)] + forM_ codes $ \code -> redeemViaService gsKey cc env code >>= (`shouldAnswerError` BSECodeUsed) + countRows cc "sx_badge_service_badge_codes WHERE group_item_id IS NOT NULL" `shouldReturn` 0 + +testIssueMonths :: HasCallStack => TestParams -> IO () +testIssueMonths ps = + withGroupOwner ps $ \_ cc _ alice -> do + sendGroupCmd alice "/issue legend months 12" + waitCodeMonths cc "legend" `shouldReturn` 12 + freeCodeCount cc `shouldReturn` 1 + +testBulkPartialFailureListsIssued :: HasCallStack => TestParams -> IO () +testBulkPartialFailureListsIssued ps = + withGroupOwner ps $ \gsKey cc env alice -> do + codeLines <- withCodeTableCapped cc 2 $ do + (codeLines, summary) <- splitAt 2 . T.lines <$> replyTo cc alice "/bulk supporter count 3" + summary `shouldBe` ["issued 2 of 3, the rest failed"] + pure codeLines + codeCount cc `shouldReturn` 2 + forM_ codeLines $ redeemOk gsKey cc env . extractCode + +testIssueFailureIsOpaque :: HasCallStack => TestParams -> IO () +testIssueFailureIsOpaque ps = + withGroupOwner ps $ \_ cc _ alice -> do + withCodeTableHidden cc $ do + replyTo cc alice "/issue supporter" `shouldReturn` "issuing the code failed" + issueRaw cc "supporter" `shouldReturn` Left "issuing the code failed" + void $ replyTo cc alice "/issue supporter" + codeCount cc `shouldReturn` 1 + +testRevokeFailureIsOpaque :: HasCallStack => TestParams -> IO () +testRevokeFailureIsOpaque ps = + withGroupOwner ps $ \_ cc _ alice -> do + code <- extractCode <$> replyTo cc alice "/issue supporter" + withCodeTableHidden cc $ + replyTo cc alice (revokeCmd code) `shouldReturn` revokeReply code "revoking the code failed" + revokeInGroup cc alice code "revoked" + +withCodeTableHidden :: ChatController -> IO a -> IO a +withCodeTableHidden cc action = rename codeTable hidden >> (action `finally` rename hidden codeTable) + where + codeTable = "sx_badge_service_badge_codes" + hidden = codeTable <> "_hidden" + rename from to = executeSql cc $ "ALTER TABLE " <> from <> " RENAME TO " <> to + +-- A test-only trigger fails every insert once the code table holds cap rows. +withCodeTableCapped :: ChatController -> Int -> IO a -> IO a +withCodeTableCapped cc cap action = mapM_ (executeSql cc) createCap >> (action `finally` mapM_ (executeSql cc) dropCap) + where +#if defined(dbPostgres) + createCap = + [ "CREATE FUNCTION sx_badge_service_test_cap() RETURNS trigger AS $$ BEGIN IF (SELECT COUNT(*) FROM sx_badge_service_badge_codes) >= " + <> show cap + <> " THEN RAISE EXCEPTION 'code table full'; END IF; RETURN NEW; END; $$ LANGUAGE plpgsql", + "CREATE TRIGGER sx_badge_service_test_cap BEFORE INSERT ON sx_badge_service_badge_codes FOR EACH ROW EXECUTE FUNCTION sx_badge_service_test_cap()" + ] + dropCap = ["DROP FUNCTION sx_badge_service_test_cap() CASCADE"] +#else + createCap = + [ "CREATE TRIGGER sx_badge_service_test_cap BEFORE INSERT ON sx_badge_service_badge_codes WHEN (SELECT COUNT(*) FROM sx_badge_service_badge_codes) >= " + <> show cap + <> " BEGIN SELECT RAISE(ABORT, 'code table full'); END" + ] + dropCap = ["DROP TRIGGER sx_badge_service_test_cap"] +#endif + +testMultiUseTracker :: HasCallStack => TestParams -> IO () +testMultiUseTracker ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (trackerItemId, tracker0, code) <- issueTracked cc alice "supporter" 2 + tracker0 `shouldSatisfy` T.isInfixOf "2/2 remaining" + redeemOk gsKey cc env code + t1 <- waitItemText cc trackerItemId "1/2 remaining" + t1 `shouldSatisfy` T.isInfixOf "Last redeemed" + redeemOk gsKey cc env code + void $ waitItemText cc trackerItemId "0/2 remaining" + waitExhausted cc `shouldReturn` exhaustedText code 2 + redeemViaService gsKey cc env code >>= (`shouldAnswerError` BSECodeUsed) + +testStaleRefreshIgnored :: HasCallStack => TestParams -> IO () +testStaleRefreshIgnored ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 + redeemOk gsKey cc env code + redeemOk gsKey cc env code + void $ waitItemText cc trackerItemId "0/2 remaining" + notice <- waitExhausted cc + replayRefresh cc env code 2 1 + awaitLane cc env + exhaustedNotices cc `shouldReturn` [notice] + readItemText cc trackerItemId >>= (`shouldSatisfy` T.isInfixOf "0/2 remaining") + redeemedTrackerCount cc `shouldReturn` 1 + +testSecondMultiUseCodeExhausted :: HasCallStack => TestParams -> IO () +testSecondMultiUseCodeExhausted ps = + withGroupOwner ps $ \gsKey cc env alice -> do + -- The first code gets 3 claims, the second code's limit, so reading the wrong count would post the notice early. + (firstItemId, _, firstCode) <- issueTracked cc alice "supporter" 5 + replicateM_ 3 (redeemOk gsKey cc env firstCode) + void $ waitItemText cc firstItemId "2/5 remaining" + awaitLane cc env + exhaustedNotices cc `shouldReturn` [] + (secondItemId, _, secondCode) <- issueTracked cc alice "legend" 3 + -- Each claim is awaited because the lane coalesces refreshes queued together. + redeemOk gsKey cc env secondCode + void $ waitItemText cc secondItemId "2/3 remaining" + redeemOk gsKey cc env secondCode + void $ waitItemText cc secondItemId "1/3 remaining" + awaitLane cc env + exhaustedNotices cc `shouldReturn` [] + redeemOk gsKey cc env secondCode + void $ waitItemText cc secondItemId "0/3 remaining" + waitExhausted cc `shouldReturn` exhaustedText secondCode 3 + readItemText cc firstItemId >>= (`shouldSatisfy` T.isInfixOf "2/5 remaining") + +testLanelessRedeemRefreshesTracker :: HasCallStack => TestParams -> IO () +testLanelessRedeemRefreshesTracker ps = + withGroupOwner ps $ \gsKey cc _ alice -> do + offsetCodeIds cc + (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 + redeemOkWith gsKey cc Nothing code + -- The refresh runs before the response, so the counter is already written here. + t1 <- readItemText cc trackerItemId + t1 `shouldSatisfy` T.isInfixOf "1/2 remaining" + t1 `shouldSatisfy` T.isInfixOf "Last redeemed" + exhaustedNotices cc `shouldReturn` [] + redeemOkWith gsKey cc Nothing code + readItemText cc trackerItemId >>= (`shouldSatisfy` T.isInfixOf "0/2 remaining") + exhaustedNotices cc `shouldReturn` [exhaustedText code 2] + redeemedTrackerCount cc `shouldReturn` 1 + +testQueuedRequestRefreshesTracker :: HasCallStack => TestParams -> IO () +testQueuedRequestRefreshesTracker ps = + withGroupOwner ps $ \_ cc env alice -> do + (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 + queueRedemption cc env code + void $ waitItemText cc trackerItemId "1/2 remaining" + +testQueuedRequestWithoutGroupConfig :: HasCallStack => TestParams -> IO () +testQueuedRequestWithoutGroupConfig ps = do + svc <- prepareGroupService ps + (trackerItemId, code) <- runWithOwner svc $ \cc _ _ alice -> + (\(i, _, c) -> (i, c)) <$> issueTracked cc alice "supporter" 2 + runGroupServiceAs svc Nothing $ \cc env _ -> do + queueRedemption cc env code + void $ waitItemText cc trackerItemId "1/2 remaining" + +testTrackerRepost :: HasCallStack => TestParams -> IO () +testTrackerRepost ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (itemId0, tracker0, code) <- issueTracked cc alice "supporter" 2 + backdated <- backdateTracker cc 2 + redeemOk gsKey cc env code + (_, tracker1) <- waitTrackerRepost cc 2 itemId0 + tracker1 `shouldSatisfy` T.isInfixOf "1/2 remaining" + readItemText cc itemId0 `shouldReturn` tracker0 + sentAt <- trackerSentAt cc 2 + sentAt `shouldSatisfy` (> backdated) + +testRefusedEditReposted :: HasCallStack => TestParams -> IO () +testRefusedEditReposted ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (itemId0, tracker0, code) <- issueTracked cc alice "supporter" 2 + backdateTrackerItem cc itemId0 + redeemOk gsKey cc env code + (itemId1, tracker1) <- waitTrackerRepost cc 2 itemId0 + tracker1 `shouldSatisfy` T.isInfixOf "1/2 remaining" + redeemOk gsKey cc env code + void $ waitItemText cc itemId1 "0/2 remaining" + waitExhausted cc `shouldReturn` exhaustedText code 2 + readItemText cc itemId0 `shouldReturn` tracker0 + +testFailedRepostDropped :: HasCallStack => TestParams -> IO () +testFailedRepostDropped ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (itemId0, tracker0, code) <- issueTracked cc alice "supporter" 2 + void $ backdateTracker cc 2 + setBotRole cc "observer" + redeemOk gsKey cc env code + awaitLane cc env + sentItemsWithCode cc code `shouldReturn` [tracker0] + readItemText cc itemId0 `shouldReturn` tracker0 + trackerAnchor cc 2 `shouldReturn` Just itemId0 + setBotRole cc "owner" + redeemOk gsKey cc env code + (_, tracker1) <- waitTrackerRepost cc 2 itemId0 + tracker1 `shouldSatisfy` T.isInfixOf "0/2 remaining" + waitExhausted cc `shouldReturn` exhaustedText code 2 + +testDeletedTrackerNotReposted :: HasCallStack => TestParams -> IO () +testDeletedTrackerNotReposted ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (itemId0, _, code) <- issueTracked cc alice "supporter" 2 + deleteItem cc itemId0 + readItemText cc itemId0 `shouldReturn` "" + trackerNeverReposted gsKey cc env code itemId0 [] + +testDeletedTrackerNotRepostedOnRevoke :: HasCallStack => TestParams -> IO () +testDeletedTrackerNotRepostedOnRevoke ps = + withGroupOwner ps $ \_ cc _ alice -> do + (itemId0, _, code) <- issueTracked cc alice "supporter" 2 + deleteItem cc itemId0 + -- Past the edit window the revoke goes straight to the repost path and its guard. + void $ backdateTracker cc 2 + revokeNeverReposts cc alice code [] + +-- Both claims fall inside the edit window, so each edit fails because the message is gone. +testDeletedTrackerNoNotice :: HasCallStack => TestParams -> IO () +testDeletedTrackerNoNotice ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (itemId0, _, code) <- issueTracked cc alice "supporter" 2 + deleteItem cc itemId0 + replicateM_ 2 $ redeemOk gsKey cc env code + awaitLane cc env + exhaustedNotices cc `shouldReturn` [] + sentItemsWithCode cc code `shouldReturn` [] + +testModeratedTrackerNotRepostedOnRevoke :: HasCallStack => TestParams -> IO () +testModeratedTrackerNotRepostedOnRevoke ps = + withGroupOwner ps $ \_ cc _ alice -> do + (itemId0, tracker0, code) <- issueTracked cc alice "supporter" 2 + moderateBotItem alice tracker0 + void $ waitModeratedItem cc itemId0 + revokeNeverReposts cc alice code [tracker0] + +testModeratedTrackerNotReposted :: HasCallStack => TestParams -> IO () +testModeratedTrackerNotReposted ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (itemId0, tracker0, code) <- issueTracked cc alice "supporter" 2 + moderateBotItem alice tracker0 + (deleted, byMember, content) <- waitModeratedItem cc itemId0 + deleted `shouldBe` moderatedMark + byMember `shouldSatisfy` isJust + content `shouldSatisfy` T.isInfixOf code + readItemText cc itemId0 `shouldReturn` tracker0 + trackerNeverReposted gsKey cc env code itemId0 [tracker0] + +-- This is the item_deleted value the core writes for a message a member deleted for everyone. +moderatedMark :: Int +moderatedMark = 1 + +-- The code must be the 2-use tracked one: two claims, the second past the edit window and using it up, +-- leave the code's bot items as they were. +trackerNeverReposted :: HasCallStack => BadgeIssuerKey -> ChatController -> ServiceState -> Text -> Int64 -> [Text] -> IO () +trackerNeverReposted key cc env code itemId0 codeItems = do + redeemOk key cc env code + awaitLane cc env + sentItemsWithCode cc code `shouldReturn` codeItems + trackerAnchor cc 2 `shouldReturn` Just itemId0 + void $ backdateTracker cc 2 + redeemOk key cc env code + awaitLane cc env + sentItemsWithCode cc code `shouldReturn` codeItems + exhaustedNotices cc `shouldReturn` [] + trackerAnchor cc 2 `shouldReturn` Just itemId0 + +revokeNeverReposts :: HasCallStack => ChatController -> TestCC -> Text -> [Text] -> IO () +revokeNeverReposts cc member code codeItems = do + revokeInGroup cc member code "revoked" + sentItemsWithCode cc code `shouldReturn` codeItems <> [revokeReply code "revoked"] + revokedTrackerCount cc `shouldReturn` 0 + +testGroupRevoke :: HasCallStack => TestParams -> IO () +testGroupRevoke ps = + withGroupOwner ps $ \gsKey cc env alice -> do + code <- extractCode <$> replyTo cc alice "/issue supporter" + other <- extractCode <$> replyTo cc alice "/issue legend" + revokeInGroup cc alice code "revoked" + redeemViaService gsKey cc env code >>= (`shouldAnswerError` BSECodeInvalid) + redeemOk gsKey cc env other + revokeInGroup cc alice code "already revoked" + -- The reply follows the tracker step, so the revoke has already passed it here. + revokedTrackerCount cc `shouldReturn` 0 + unissued <- formatBadgeCode <$> randomBadgeCode (random cc) + revokeInGroup cc alice unissued "no such code" + +testGroupRevokeRepairsTracker :: HasCallStack => TestParams -> IO () +testGroupRevokeRepairsTracker ps = + withGroupOwner ps $ \_ cc _ alice -> do + offsetCodeIds cc + (trackerItemId, tracker0, code) <- issueTracked cc alice "supporter" 2 + revokeInStore cc 2 + readItemText cc trackerItemId `shouldReturn` tracker0 + sendGroupCmd alice (revokeCmd code) + retired <- waitItemText cc trackerItemId "revoked" + retired `shouldBe` retiredText code + waitStoredItem cc (revokeReply code "already revoked") + revokedTrackerCount cc `shouldReturn` 1 + +testRevokeRepeatPastWindow :: HasCallStack => TestParams -> IO () +testRevokeRepeatPastWindow ps = + withGroupOwner ps $ \_ cc _ alice -> do + offsetCodeIds cc + (itemId0, tracker0, code) <- issueTracked cc alice "supporter" 2 + void $ backdateTracker cc 2 + revokeInGroup cc alice code "revoked" + (itemId1, retired) <- waitTrackerRepost cc 2 itemId0 + retired `shouldBe` retiredText code + revokedTrackerCount cc `shouldReturn` 1 + void $ backdateTracker cc 2 + revokeInGroup cc alice code "already revoked" + revokedTrackerCount cc `shouldReturn` 1 + trackerAnchor cc 2 `shouldReturn` Just itemId1 + readItemText cc itemId1 `shouldReturn` retiredText code + readItemText cc itemId0 `shouldReturn` tracker0 + +testExhaustedTrackerReconciledOnRestart :: HasCallStack => TestParams -> IO () +testExhaustedTrackerReconciledOnRestart ps = do + svc@GroupSvc {gsKey} <- prepareGroupService ps + (lostItemId, notice, lostCode) <- runWithOwner svc $ \cc env _ alice -> do + (doneItemId, _, doneCode) <- issueTracked cc alice "supporter" 2 + redeemOk gsKey cc env doneCode + redeemOk gsKey cc env doneCode + notice <- waitExhausted cc + (lostItemId, lost0, lostCode) <- issueTracked cc alice "legend" 3 + replicateM_ 3 (redeemLosingRefresh gsKey cc lostCode) + readItemText cc lostItemId `shouldReturn` lost0 + trackerAnchor cc 2 `shouldReturn` Just doneItemId + dateRedemption cc 3 lostRedeemedAt + pure (lostItemId, notice, lostCode) + runGroupService svc $ \cc env _ -> do + corrected <- waitItemText cc lostItemId "0/3 remaining" + corrected `shouldBe` ("!2 " <> lostCode <> "!\nLast redeemed: 2026-02-28 — 0/3 remaining") + awaitLane cc env + exhaustedNotices cc `shouldReturn` [notice] + redeemedTrackerCount cc `shouldReturn` 2 + +-- This date is far from any day the test runs on, so a body dated now cannot match it. +lostRedeemedAt :: UTCTime +lostRedeemedAt = UTCTime (fromGregorian 2026 2 28) (23 * 3600 + 50 * 60) + +testStalledTrackerReconciledOnRestart :: HasCallStack => TestParams -> IO () +testStalledTrackerReconciledOnRestart ps = do + svc@GroupSvc {gsKey} <- prepareGroupService ps + stalledItemId <- runWithOwner svc $ \cc env _ alice -> do + (stalledItemId, _, code) <- issueTracked cc alice "supporter" 5 + redeemOk gsKey cc env code + redeemOk gsKey cc env code + awaitLane cc env + stalled <- waitItemText cc stalledItemId "3/5 remaining" + redeemLosingRefresh gsKey cc code + readItemText cc stalledItemId `shouldReturn` stalled + pure stalledItemId + runGroupService svc $ \cc env _ -> do + corrected <- waitItemText cc stalledItemId "2/5 remaining" + corrected `shouldSatisfy` T.isInfixOf "Last redeemed: " + awaitLane cc env + exhaustedNotices cc `shouldReturn` [] + redeemedTrackerCount cc `shouldReturn` 1 + +testRevokedTrackerReconciledOnRestart :: HasCallStack => TestParams -> IO () +testRevokedTrackerReconciledOnRestart ps = do + svc <- prepareGroupService ps + (trackerItemId, code) <- runWithOwner svc $ \cc _ _ alice -> do + (trackerItemId, tracker0, code) <- issueTracked cc alice "supporter" 2 + revokeInStore cc 2 + readItemText cc trackerItemId `shouldReturn` tracker0 + pure (trackerItemId, code) + runGroupService svc $ \cc env _ -> do + retired <- waitItemText cc trackerItemId "revoked" + retired `shouldBe` retiredText code + awaitLane cc env + revokedTrackerCount cc `shouldReturn` 1 + +testEveryStalledTrackerReconciled :: HasCallStack => TestParams -> IO () +testEveryStalledTrackerReconciled ps = do + svc@GroupSvc {gsKey} <- prepareGroupService ps + (firstItemId, secondItemId) <- runWithOwner svc $ \cc _ _ alice -> do + (firstItemId, first0, firstCode) <- issueTracked cc alice "supporter" 5 + replicateM_ 2 (redeemLosingRefresh gsKey cc firstCode) + (secondItemId, second0, secondCode) <- issueTracked cc alice "legend" 3 + redeemLosingRefresh gsKey cc secondCode + readItemText cc firstItemId `shouldReturn` first0 + readItemText cc secondItemId `shouldReturn` second0 + pure (firstItemId, secondItemId) + runGroupService svc $ \cc env _ -> do + first1 <- waitItemText cc firstItemId "3/5 remaining" + first1 `shouldSatisfy` T.isInfixOf "Last redeemed: " + second1 <- waitItemText cc secondItemId "2/3 remaining" + second1 `shouldSatisfy` T.isInfixOf "Last redeemed: " + awaitLane cc env + exhaustedNotices cc `shouldReturn` [] + redeemedTrackerCount cc `shouldReturn` 2 + +testUneditableTrackerLeftAlone :: HasCallStack => TestParams -> IO () +testUneditableTrackerLeftAlone ps = do + svc@GroupSvc {gsKey} <- prepareGroupService ps + (staleItemId, stale0, staleCode, liveItemId, liveCode) <- runWithOwner svc $ \cc _ _ alice -> do + (staleItemId, stale0, staleCode) <- issueTracked cc alice "supporter" 2 + redeemLosingRefresh gsKey cc staleCode + backdateTrackerItem cc staleItemId + readItemText cc staleItemId `shouldReturn` stale0 + -- The lane drains only after the pass returns, so this code's update marks the pass as done. + (liveItemId, _, liveCode) <- issueTracked cc alice "legend" 3 + pure (staleItemId, stale0, staleCode, liveItemId, liveCode) + runGroupService svc $ \cc env _ -> do + redeemOk gsKey cc env liveCode + void $ waitItemText cc liveItemId "2/3 remaining" + readItemText cc staleItemId `shouldReturn` stale0 + sentItemsWithCode cc staleCode `shouldReturn` [stale0] + trackerAnchor cc 2 `shouldReturn` Just staleItemId + +testRevokeRetiresTracker :: HasCallStack => TestParams -> IO () +testRevokeRetiresTracker ps = + withGroupOwner ps $ \gsKey cc env alice -> do + offsetCodeIds cc + (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 + redeemOk gsKey cc env code + void $ waitItemText cc trackerItemId "1/2 remaining" + revokeInGroup cc alice code "revoked" + retired <- waitItemText cc trackerItemId "revoked" + retired `shouldBe` retiredText code + revokedTrackerCount cc `shouldReturn` 1 + replayRefresh cc env code 2 2 + awaitLane cc env + readItemText cc trackerItemId `shouldReturn` retired + exhaustedNotices cc `shouldReturn` [] + revokedTrackerCount cc `shouldReturn` 1 + redeemViaService gsKey cc env code >>= (`shouldAnswerError` BSECodeInvalid) + +testServiceRevokeRetiresTracker :: HasCallStack => TestParams -> IO () +testServiceRevokeRetiresTracker ps = + withGroupOwner ps $ \gsKey cc env alice -> do + offsetCodeIds cc + (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 + redeemOk gsKey cc env code + void $ waitItemText cc trackerItemId "1/2 remaining" + revokeRaw cc code `shouldReturn` Right "revoked" + readItemText cc trackerItemId `shouldReturn` retiredText code + revokedTrackerCount cc `shouldReturn` 1 + revokeRaw cc code `shouldReturn` Right "already revoked" + revokedTrackerCount cc `shouldReturn` 1 + single <- extractCode <$> replyTo cc alice "/issue legend" + revokeRaw cc single `shouldReturn` Right "revoked" + revokedTrackerCount cc `shouldReturn` 1 + +testServiceRevokeRepairsTracker :: HasCallStack => TestParams -> IO () +testServiceRevokeRepairsTracker ps = + withGroupOwner ps $ \_ cc _ alice -> do + offsetCodeIds cc + (trackerItemId, tracker0, code) <- issueTracked cc alice "supporter" 2 + revokeInStore cc 2 + readItemText cc trackerItemId `shouldReturn` tracker0 + revokeRaw cc code `shouldReturn` Right "already revoked" + readItemText cc trackerItemId `shouldReturn` retiredText code + revokedTrackerCount cc `shouldReturn` 1 + +-- A discarded code makes later code ids differ from the group id, so swapped arguments fail. +offsetCodeIds :: HasCallStack => ChatController -> IO () +offsetCodeIds cc = void $ issueCode cc BTSupporter 1 + +redeemOk :: HasCallStack => BadgeIssuerKey -> ChatController -> ServiceState -> Text -> IO () +redeemOk key cc env = redeemOkWith key cc (Just (groupEventQ env)) + +redeemOkWith :: HasCallStack => BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> Text -> IO () +redeemOkWith key cc trackerQ_ code = do + r <- redeemWithQueue key cc trackerQ_ code + credentialOf r `shouldSatisfy` isJust + +redeemViaService :: HasCallStack => BadgeIssuerKey -> ChatController -> ServiceState -> Text -> IO BadgeServiceResponse +redeemViaService key cc env = redeemWithQueue key cc (Just (groupEventQ env)) + +-- The reply to the made-up request id fails after the redemption, and the service only logs it. +queueRedemption :: HasCallStack => ChatController -> ServiceState -> Text -> IO () +queueRedemption cc env codeText = do + user <- readTVarIO (currentUser cc) >>= maybe (error "no current user") pure + (purchaseKey, masterKey) <- newPurchaseKeys + let request = requestObject purchaseKey BSCRedeemBadgeCode {masterKey, code = codeText} + atomically $ writeTQueue (serviceRequestQ env) (user, AgentInvId "test-request", Just purchaseKey, request) + +redeemLosingRefresh :: HasCallStack => BadgeIssuerKey -> ChatController -> Text -> IO () +redeemLosingRefresh key cc codeText = newTQueueIO >>= \q -> redeemOkWith key cc (Just q) codeText + +replayRefresh :: HasCallStack => ChatController -> ServiceState -> Text -> Int -> Int -> IO () +replayRefresh cc env codeText uses claim = case parseBadgeCode codeText of + Nothing -> error $ "not a badge code: " <> T.unpack codeText + Just code -> do + badgeCodeId <- trackedCodeId cc uses + atomically $ writeTQueue (groupEventQ env) (GETracker badgeCodeId code claim) + +getStoredGroup :: ChatController -> IO (Maybe ManagedGroup) +getStoredGroup cc = withTransaction (chatStore cc) getManagedGroup + +shortLinkContactType :: Text -> Either String ContactConnType +shortLinkContactType linkText = case strDecode (encodeUtf8 linkText) of + Right (ACSL _ (CSLContact _ ct _ _)) -> Right ct + Right (ACSL _ CSLInvitation {}) -> Left "invitation short link" + Left e -> Left e + +groupLink :: HasCallStack => ChatController -> IO String +groupLink cc = T.unpack . mgGroupLink <$> storedGroup cc + +storedGroup :: HasCallStack => ChatController -> IO ManagedGroup +storedGroup cc = getStoredGroup cc >>= maybe (error "no managed group recorded") pure + +groupCount :: ChatController -> IO Int +groupCount cc = countRows cc "groups" + +-- The lane runs events in order, so once this command's code exists every event queued before it is done. +awaitLane :: HasCallStack => ChatController -> ServiceState -> IO () +awaitLane cc env = do + ManagedGroup {mgGroupId} <- storedGroup cc + issued <- codeCount cc + atomically $ writeTQueue (groupEventQ env) (GEInGroup mgGroupId (GACommand GROwner "/issue supporter")) + pollUntilTrue $ (> issued) <$> codeCount cc + +-- Saving a tracker's item id is the lane's last write for its command, so the lane is idle after it. +settleLane :: HasCallStack => ChatController -> ServiceState -> Int64 -> IO () +settleLane cc env gid = do + anchoredBefore <- anchored + atomically $ writeTQueue (groupEventQ env) (GEInGroup gid (GACommand GROwner ("/issue supporter uses " <> tshow settleUses))) + pollUntilTrue $ (> anchoredBefore) <$> anchored + where + anchored = countRows cc ("sx_badge_service_badge_codes WHERE redeem_limit = " <> show settleUses <> " AND group_item_id IS NOT NULL") + +-- No test tracks a code with this many uses, so the settling codes never match a test's lookup. +settleUses :: Int +settleUses = maxUses + +codeCount :: ChatController -> IO Int +codeCount cc = countRows cc "sx_badge_service_badge_codes" + +freeCodeCount :: ChatController -> IO Int +freeCodeCount cc = countRows cc "sx_badge_service_badge_codes WHERE code_payment_status = 'free'" + +singleUseCodeCount :: ChatController -> IO Int +singleUseCodeCount cc = countRows cc "sx_badge_service_badge_codes WHERE redeem_limit = 1" + +countRows :: ChatController -> String -> IO Int +countRows cc fromWhere = fromMaybe 0 <$> queryFirst cc ("SELECT COUNT(*) FROM " <> fromWhere) + +-- A test finds each tracked code by its number of uses, so no two of its codes may share one. +trackedCodeColumn :: (HasCallStack, DB.FromField a) => ChatController -> Int -> String -> IO a +trackedCodeColumn cc uses column = + queryOne cc ("no code issued with " <> show uses <> " uses") $ + "SELECT " <> column <> " FROM sx_badge_service_badge_codes WHERE redeem_limit = " <> show uses + +trackedCodeId :: HasCallStack => ChatController -> Int -> IO Int64 +trackedCodeId cc uses = trackedCodeColumn cc uses "badge_code_id" + +queryRows :: FromRow r => ChatController -> String -> IO [r] +queryRows cc sql = withTransaction (chatStore cc) (\db -> DB.query_ db (fromString sql)) + +executeSql :: ChatController -> String -> IO () +executeSql cc sql = withTransaction (chatStore cc) (\db -> DB.execute_ db (fromString sql)) + +queryColumn :: DB.FromField a => ChatController -> String -> IO [a] +queryColumn cc sql = map fromOnly <$> queryRows cc sql + +queryFirst :: DB.FromField a => ChatController -> String -> IO (Maybe a) +queryFirst cc sql = listToMaybe <$> queryColumn cc sql + +queryOne :: (HasCallStack, DB.FromField a) => ChatController -> String -> String -> IO a +queryOne cc err sql = queryColumn cc sql >>= maybe (error err) pure . singleRow sql + +singleRow :: HasCallStack => String -> [a] -> Maybe a +singleRow sql = \case + [] -> Nothing + [r] -> Just r + _ -> error $ "more than one row from: " <> sql + +-- The list is spelled out rather than taken from the service, so a change there fails here. +expectedCommands :: [ChatBotCommand] +expectedCommands = + [ CBCCommand "issue" "Generate a badge code" (Just " [months ] [uses ]"), + CBCCommand "bulk" "Generate many single-use codes" (Just " [months ] count "), + CBCCommand "revoke" "Revoke a code" (Just "") + ] + +advertisedCommands :: HasCallStack => ChatController -> Int64 -> IO (Maybe [ChatBotCommand]) +advertisedCommands cc gid = + (>>= commands_) + <$> (queryOne cc "no group profile to read commands from" (groupProfileSql "p.preferences" gid) :: IO (Maybe GroupPreferences)) + +profileDisplayName :: HasCallStack => ChatController -> Int64 -> IO Text +profileDisplayName cc gid = + queryOne cc "no group profile to read a display name from" (groupProfileSql "p.display_name" gid) + +profileFullNameShortDescr :: HasCallStack => ChatController -> Int64 -> IO (Text, Maybe Text) +profileFullNameShortDescr cc gid = + queryRows cc sql >>= maybe (error "no group profile to read a full name from") pure . singleRow sql + where + sql = groupProfileSql "p.full_name, p.short_descr" gid + +profileDescription :: HasCallStack => ChatController -> Int64 -> IO (Maybe Text) +profileDescription cc gid = queryOne cc "no group profile to read a description from" (groupProfileSql "p.description" gid) + +profileUpdatedAt :: HasCallStack => ChatController -> Int64 -> IO UTCTime +profileUpdatedAt cc gid = + queryOne cc "no group profile to read an update time from" (groupProfileSql "p.updated_at" gid) + +groupFeaturePreference :: HasCallStack => ChatController -> Int64 -> SGroupFeature f -> IO (GroupFeaturePreference f) +groupFeaturePreference cc gid feature = + getGroupPreference feature + <$> (queryOne cc "no group profile to read preferences from" (groupProfileSql "p.preferences" gid) :: IO (Maybe GroupPreferences)) + +groupProfileSql :: String -> Int64 -> String +groupProfileSql columns gid = + "SELECT " + <> columns + <> " FROM group_profiles p JOIN groups g ON g.group_profile_id = p.group_profile_id WHERE g.group_id = " + <> show gid + +clearCommandsSettingFullDelete :: ChatController -> Int64 -> IO () +clearCommandsSettingFullDelete cc gid = + withTransaction (chatStore cc) $ \db -> + DB.execute + db + "UPDATE group_profiles SET preferences = ? WHERE group_profile_id IN (SELECT group_profile_id FROM groups WHERE group_id = ?)" + (fullDeleteOnly, gid) + where + fullDeleteOnly = + emptyGroupPrefs {fullDelete = Just FullDeleteGroupPreference {enable = FEOn, role = Nothing}} :: GroupPreferences + +revokeInStore :: HasCallStack => ChatController -> Int -> IO () +revokeInStore cc uses = getCurrentTime >>= setTrackedCodeTime cc uses "revoked_at" + +backdateTracker :: HasCallStack => ChatController -> Int -> IO UTCTime +backdateTracker cc uses = do + past <- addUTCTime pastEditWindow <$> getCurrentTime + setTrackedCodeTime cc uses "group_item_sent_at" past + pure past + +-- This is an hour past the core's 24-hour edit window. +pastEditWindow :: NominalDiffTime +pastEditWindow = -25 * 3600 + +-- The code row keeps its sent time, so the service still tries an edit the core refuses. +backdateTrackerItem :: ChatController -> Int64 -> IO () +backdateTrackerItem cc citemId = do + past <- addUTCTime pastEditWindow <$> getCurrentTime + withTransaction (chatStore cc) $ \db -> + DB.execute db "UPDATE chat_items SET item_ts = ? WHERE chat_item_id = ?" (past, citemId) + +-- Below author the core refuses every send from the bot. +setBotRole :: ChatController -> Text -> IO () +setBotRole cc role = + withTransaction (chatStore cc) $ \db -> + DB.execute db "UPDATE group_members SET member_role = ? WHERE member_category = ?" (role, "user" :: Text) + +dateRedemption :: HasCallStack => ChatController -> Int -> UTCTime -> IO () +dateRedemption cc uses = setTrackedCodeTime cc uses "redeemed_at" + +setTrackedCodeTime :: HasCallStack => ChatController -> Int -> String -> UTCTime -> IO () +setTrackedCodeTime cc uses column ts = do + badgeCodeId <- trackedCodeId cc uses + withTransaction (chatStore cc) $ \db -> + DB.execute db (fromString $ "UPDATE sx_badge_service_badge_codes SET " <> column <> " = ? WHERE badge_code_id = ?") (ts, badgeCodeId) + +-- Member messages are excluded because a /revoke names the code too. +sentItemsWithCode :: ChatController -> Text -> IO [Text] +sentItemsWithCode cc code = + queryColumn cc $ + "SELECT item_text FROM chat_items WHERE item_sent = 1 AND item_text LIKE '%" + <> T.unpack code + <> "%' ORDER BY chat_item_id" + +-- It reads the code row, not a join, so it still answers after the message is deleted. +trackerAnchor :: HasCallStack => ChatController -> Int -> IO (Maybe Int64) +trackerAnchor cc uses = trackedCodeColumn cc uses "group_item_id" + +trackerSentAt :: HasCallStack => ChatController -> Int -> IO UTCTime +trackerSentAt cc uses = trackedCodeColumn cc uses "group_item_sent_at" + +deleteItem :: HasCallStack => ChatController -> Int64 -> IO () +deleteItem cc citemId = do + ManagedGroup {mgGroupId} <- storedGroup cc + sendChatCmd cc (APIDeleteChatItem (ChatRef CTGroup mgGroupId Nothing) (citemId :| []) CIDMInternal) >>= \case + Right CRChatItemsDeleted {} -> pure () + r -> error $ "deleting chat item " <> show citemId <> " failed: " <> show r + +-- The member must have received the message before the command can find it. +moderateBotItem :: HasCallStack => TestCC -> Text -> IO () +moderateBotItem member body = do + void (pollUntil (queryFirst (chatController member) received) :: IO Int64) + send member ("\\\\ #" <> groupName <> " @" <> botName <> " " <> T.unpack header) + where + header = T.takeWhile (/= '\n') body + received = "SELECT chat_item_id FROM chat_items WHERE item_sent = 0 AND item_text LIKE '" <> T.unpack header <> "%'" + +waitModeratedItem :: HasCallStack => ChatController -> Int64 -> IO (Int, Maybe Int64, Text) +waitModeratedItem cc citemId = + pollUntil $ + mfilter (\(deleted, _, _) -> deleted /= 0) . listToMaybe + <$> queryRows cc ("SELECT item_deleted, item_deleted_by_group_member_id, item_content FROM chat_items WHERE chat_item_id = " <> show citemId) + +memberRoles :: ChatController -> Int64 -> IO [(Text, Text)] +memberRoles cc gid = + filter ((/= badgeBotName) . fst) + <$> queryRows cc ("SELECT local_display_name, member_role FROM group_members WHERE group_id = " <> show gid <> " ORDER BY group_member_id") + +readItemText :: ChatController -> Int64 -> IO Text +readItemText cc citemId = fromMaybe "" <$> firstText cc ("chat_item_id = " <> show citemId) + +-- A line left unread when the test ends fails the per-core teardown check. +drainUntil :: HasCallStack => TestCC -> [String] -> IO () +drainUntil cc markers = + timeout waitLimit (go markers) >>= \case + Just () -> pure () + Nothing -> error $ "drainUntil: console never showed " <> show markers + where + go [] = pure () + go unseen = do + l <- atomically $ readTQueue (termQ cc) + go $ filter (not . (`isInfixOf` l)) unseen + +drainConsole :: TestCC -> IO () +drainConsole cc = + timeout quietPeriod (atomically (readTQueue (termQ cc))) >>= \case + Just _ -> drainConsole cc + Nothing -> pure () + +-- A console silent this long is taken as drained. +quietPeriod :: Int +quietPeriod = 500000 + +pollInterval :: Int +pollInterval = 200000 + +maxPolls :: Int +maxPolls = 150 + +waitLimit :: Int +waitLimit = maxPolls * pollInterval + +pollUntil :: HasCallStack => IO (Maybe a) -> IO a +pollUntil act = go maxPolls + where + go n = + act >>= \case + Just a -> pure a + Nothing + | n <= (0 :: Int) -> error "pollUntil: timed out waiting for chat state" + | otherwise -> threadDelay pollInterval >> go (n - 1) + +pollUntilTrue :: HasCallStack => IO Bool -> IO () +pollUntilTrue cond = pollUntil (guard <$> cond) + +waitMemberRole :: HasCallStack => ChatController -> Int64 -> Text -> Text -> IO () +waitMemberRole cc gid name role = pollUntilTrue $ elem (name, role) <$> memberRoles cc gid + +setMemberRole :: HasCallStack => ChatController -> Int64 -> Text -> Text -> IO () +setMemberRole cc gid name role = do + sendChatCmdStr cc ("/mr #" <> groupName <> " " <> T.unpack name <> " " <> T.unpack role) >>= (`shouldSatisfy` isRight) + waitMemberRole cc gid name role + +waitMemberBlocked :: HasCallStack => ChatController -> Int64 -> Text -> IO () +waitMemberBlocked cc gid name = + pollUntilTrue $ (== Just (Just ("blocked" :: Text))) <$> queryFirst cc restrictionSql + where + restrictionSql = + "SELECT member_restriction FROM group_members WHERE group_id = " + <> show gid + <> " AND local_display_name = '" + <> T.unpack name + <> "'" + +waitBlockedItem :: HasCallStack => ChatController -> Text -> IO (Int, Text) +waitBlockedItem cc txt = + pollUntil $ + mfilter ((/= 0) . fst) . listToMaybe + <$> queryRows cc ("SELECT item_deleted, item_content FROM chat_items WHERE item_sent = 0 AND item_text = '" <> T.unpack txt <> "'") + +waitAdvertisedCommands :: HasCallStack => ChatController -> Int64 -> IO () +waitAdvertisedCommands cc gid = pollUntilTrue $ (== Just expectedCommands) <$> advertisedCommands cc gid + +waitStoredItem :: HasCallStack => ChatController -> Text -> IO () +waitStoredItem cc txt = void . pollUntil $ firstText cc ("item_text = '" <> T.unpack txt <> "'") + +-- The reply is the first item the service sends after the command arrives. +replyTo :: HasCallStack => ChatController -> TestCC -> String -> IO Text +replyTo cc member cmd = do + lastId <- maxChatItemId cc + sendGroupCmd member cmd + waitReceivedItemId cc lastId (T.pack cmd) >>= waitReplyAfter cc + +maxChatItemId :: ChatController -> IO Int64 +maxChatItemId cc = fromMaybe 0 <$> queryFirst cc "SELECT COALESCE(MAX(chat_item_id), 0) FROM chat_items" + +waitReceivedItemId :: HasCallStack => ChatController -> Int64 -> Text -> IO Int64 +waitReceivedItemId cc afterId txt = + pollUntil . queryFirst cc $ + "SELECT chat_item_id FROM chat_items WHERE item_sent = 0 AND chat_item_id > " <> show afterId <> " AND item_text = '" <> T.unpack txt <> "'" + +waitReplyAfter :: HasCallStack => ChatController -> Int64 -> IO Text +waitReplyAfter cc afterId = + pollUntil . firstText cc $ "item_sent = 1 AND chat_item_id > " <> show afterId <> " ORDER BY chat_item_id LIMIT 1" + +waitItemText :: HasCallStack => ChatController -> Int64 -> Text -> IO Text +waitItemText cc citemId marker = + pollUntil $ mfilter (marker `T.isInfixOf`) . Just <$> readItemText cc citemId + +waitCodeOfType :: HasCallStack => ChatController -> Text -> IO () +waitCodeOfType cc badgeType = + pollUntilTrue $ (> 0) <$> countRows cc ("sx_badge_service_badge_codes WHERE badge_type = '" <> T.unpack badgeType <> "'") + +waitCodeMonths :: HasCallStack => ChatController -> Text -> IO Int +waitCodeMonths cc badgeType = + pollUntil $ do + months <- queryColumn cc $ "SELECT months FROM sx_badge_service_badge_codes WHERE badge_type = '" <> T.unpack badgeType <> "'" + pure $ case months of + [m] -> Just m + _ -> Nothing + +firstText :: ChatController -> String -> IO (Maybe Text) +firstText cc cond = queryFirst cc ("SELECT item_text FROM chat_items WHERE " <> cond) + +trackerItem :: HasCallStack => ChatController -> Int -> IO (Maybe (Int64, Text)) +trackerItem cc uses = singleRow sql <$> queryRows cc sql + where + sql = + "SELECT c.group_item_id, ci.item_text " + <> "FROM sx_badge_service_badge_codes c " + <> "JOIN chat_items ci ON ci.chat_item_id = c.group_item_id " + <> "WHERE c.redeem_limit = " + <> show uses + +waitTrackerItemOf :: HasCallStack => ChatController -> Int -> IO (Int64, Text) +waitTrackerItemOf cc = pollUntil . trackerItem cc + +waitTrackerRepost :: HasCallStack => ChatController -> Int -> Int64 -> IO (Int64, Text) +waitTrackerRepost cc uses itemId0 = pollUntil $ mfilter ((/= itemId0) . fst) <$> trackerItem cc uses + +redeemedTrackerCount :: ChatController -> IO Int +redeemedTrackerCount cc = countRows cc "chat_items WHERE item_text LIKE '%Last redeemed%'" + +revokedTrackerCount :: ChatController -> IO Int +revokedTrackerCount cc = countRows cc ("chat_items WHERE item_text LIKE '" <> T.unpack (retiredText "SB-%") <> "'") + +retiredText :: Text -> Text +retiredText code = code <> " revoked — no longer redeemable" + +exhaustedText :: Text -> Int -> Text +exhaustedText code uses = code <> " fully redeemed — all " <> tshow uses <> " used" + +-- Notices are not filtered by code or total, so a wrong one still shows up. +exhaustedNotices :: ChatController -> IO [Text] +exhaustedNotices cc = queryColumn cc "SELECT item_text FROM chat_items WHERE item_text LIKE '%fully redeemed%' ORDER BY chat_item_id" + +waitExhausted :: HasCallStack => ChatController -> IO Text +waitExhausted cc = + pollUntil (mfilter (not . null) . Just <$> exhaustedNotices cc) >>= \case + [t] -> pure t + ts -> error $ "expected one exhaustion notice, got " <> show (length ts) + +extractCode :: HasCallStack => Text -> Text +extractCode t = maybe (error ("no badge code in: " <> T.unpack t)) formatBadgeCode (codeInTracker t) diff --git a/tests/Bots/BadgeService/GroupTests.hs b/tests/Bots/BadgeService/GroupTests.hs new file mode 100644 index 0000000000..d8eecf1ecc --- /dev/null +++ b/tests/Bots/BadgeService/GroupTests.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Bots.BadgeService.GroupTests where + +import BadgeService.Config (GroupConfig (..)) +import BadgeService.Group (GroupAction (..), GroupEvent (..), TrackerAction (..), coalesceTrackerRefreshes, inertGroupConfig, noOwnerHint, orphanHint, trackerDecision) +import BadgeService.Group.Command +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), addUTCTime) +import Simplex.Chat.Badges (BadgeType (..)) +import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeText, randomBadgeCode) +import Simplex.Chat.Controller (ChatCommand (DeleteGroup, MemberRole)) +import Simplex.Chat.Library.Commands (parseChatCommand) +import Simplex.Chat.Types (GroupProfile (..)) +import Simplex.Chat.Types.Shared (GroupMemberRole (..)) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Util (tshow) +import Test.Hspec + +badgeGroupTests :: Spec +badgeGroupTests = describe "badge group" $ do + let p = groupCmdAction GROwner + issueUsage = ReplyText "use: /issue [months ] [uses ]" + bulkUsage = ReplyText "use: /bulk [months ] count " + revokeUsage = ReplyText "use: /revoke " + it "issue defaults" $ p "/issue supporter" `shouldBe` RunCmd (GCIssue BTSupporter 1 1) + it "issue with months and uses" $ p "/issue legend months 6 uses 50" `shouldBe` RunCmd (GCIssue BTLegend 6 50) + it "bulk with count" $ p "/bulk supporter count 20" `shouldBe` RunCmd (GCBulk BTSupporter 1 20) + it "rejects values past the upper bounds" $ do + p "/issue supporter uses 1001" `shouldBe` issueUsage + p "/bulk supporter count 101" `shouldBe` bulkUsage + p "/issue supporter months 256" `shouldBe` issueUsage + it "rejects zero values" $ do + p "/bulk supporter count 0" `shouldBe` bulkUsage + p "/issue supporter months 0" `shouldBe` issueUsage + it "rejects values past the machine word" $ do + let past64 = tshow (2 ^ (64 :: Int) + 1 :: Integer) + p ("/issue supporter uses " <> past64) `shouldBe` issueUsage + p ("/bulk supporter count " <> past64) `shouldBe` bulkUsage + p ("/issue supporter months " <> past64) `shouldBe` issueUsage + it "accepts the upper bounds" $ do + p "/issue supporter uses 1000" `shouldBe` RunCmd (GCIssue BTSupporter 1 1000) + p "/bulk supporter count 100" `shouldBe` RunCmd (GCBulk BTSupporter 1 100) + p "/issue supporter months 255" `shouldBe` RunCmd (GCIssue BTSupporter 255 1) + it "revoke" $ do + code <- newCode + p ("/revoke " <> badgeCodeText code) `shouldBe` RunCmd (GCRevoke code) + it "authorization, per role, as (issue, bulk, revoke)" $ do + someCode <- newCode + let runs role t = case groupCmdAction role t of + RunCmd _ -> True + _ -> False + allowed role = + ( runs role "/issue supporter", + runs role "/bulk supporter count 1", + runs role ("/revoke " <> badgeCodeText someCode) + ) + roles = [GRUnknown "future", GRRelay, GRObserver, GRAuthor, GRMember, GRModerator, GRAdmin, GROwner] + map (\role -> (role, allowed role)) roles + `shouldBe` [ (GRUnknown "future", (False, False, False)), + (GRRelay, (False, False, False)), + (GRObserver, (False, False, False)), + (GRAuthor, (False, False, False)), + (GRMember, (False, False, False)), + (GRModerator, (True, True, False)), + (GRAdmin, (True, True, True)), + (GROwner, (True, True, True)) + ] + describe "log hints give commands --run-cli parses for a group name with a space" $ do + let hintCommand = fst . T.breakOn " in --run-cli" . snd . T.breakOnEnd " with " + parsedHint hint = let cmd = hintCommand hint in (cmd, parseChatCommand (encodeUtf8 cmd)) + it "owner" $ + case parsedHint (T.replace "" "alice" $ noOwnerHint "SimpleX Badges_1") of + (_, Right (MemberRole g m GROwner)) -> (g, m) `shouldBe` ("SimpleX Badges_1", "alice") + (cmd, r) -> expectationFailure $ "owner command " <> show cmd <> " parsed as " <> show r + it "orphan group" $ + case parsedHint (orphanHint "SimpleX Badges_1") of + (_, Right (DeleteGroup g)) -> g `shouldBe` "SimpleX Badges_1" + (cmd, r) -> expectationFailure $ "delete command " <> show cmd <> " parsed as " <> show r + describe "classifying a group message" $ do + it "answers an advertised command that does not parse" $ do + map p + [ "/issue", + "/issue supporter uses 0", + "/issue supporter 3", + "/issue suporter", + "/issue supporter uses 5", + "/bulk supporter", + "/revoke", + "/revoke not-a-badge-code" + ] + `shouldBe` replicate 5 issueUsage <> [bulkUsage, revokeUsage, revokeUsage] + it "answers a mistyped command only to a sender who may run it" $ do + map (`groupCmdAction` "/issue supporter uses 0") [GRMember, GRModerator, GRAdmin] + `shouldBe` [IgnoreMsg, issueUsage, issueUsage] + map (`groupCmdAction` "/bulk supporter") [GRMember, GRModerator, GRAdmin] + `shouldBe` [IgnoreMsg, bulkUsage, bulkUsage] + map (`groupCmdAction` "/revoke not-a-badge-code") [GRMember, GRModerator, GRAdmin] + `shouldBe` [IgnoreMsg, IgnoreMsg, revokeUsage] + it "accepts a command padded with whitespace" $ do + p " /issue supporter " `shouldBe` RunCmd (GCIssue BTSupporter 1 1) + p "\t/bulk supporter count 1" `shouldBe` RunCmd (GCBulk BTSupporter 1 1) + it "says nothing to anything that is not an advertised command" $ + map p ["", "hello", "issue supporter", "/issued supporter", "/help", "see /issue above"] + `shouldBe` replicate 6 IgnoreMsg + it "says nothing to a command the sender may not run" $ do + map (`groupCmdAction` "/issue supporter") [GRMember, GRAuthor] `shouldBe` [IgnoreMsg, IgnoreMsg] + groupCmdAction GRMember "/bulk supporter count 1" `shouldBe` IgnoreMsg + it "tells a sender below admin that their revoke did not happen" $ do + code <- newCode + map (`groupCmdAction` ("/revoke " <> badgeCodeText code)) [GRMember, GRModerator] + `shouldBe` replicate 2 (ReplyText "only admins can revoke codes, and this code is now visible to the group - ask an admin to revoke it") + describe "configured group name and description" $ do + let cfg name descr = GroupConfig {gDisplayName = name, gDescription = descr} + profile name descr = + GroupProfile + { displayName = name, + fullName = "", + shortDescr = Nothing, + description = descr, + image = Nothing, + publicGroup = Nothing, + groupPreferences = Nothing, + memberAdmission = Nothing + } + it "says nothing when the config matches the group profile" $ do + inertGroupConfig (cfg "SimpleX Badges" (Just "badge ops desk")) (profile "SimpleX Badges" (Just "badge ops desk")) + `shouldBe` Nothing + inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" Nothing) `shouldBe` Nothing + it "says nothing when an omitted description meets an empty one" $ + inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" (Just "")) `shouldBe` Nothing + it "reports a name the config would change" $ + inertGroupConfig (cfg "SimpleX Badges 2026" (Just "badge ops desk")) (profile "SimpleX Badges" (Just "badge ops desk")) + `shouldBe` Just "badge group config is not applied to an existing group: display_name \"SimpleX Badges 2026\", group has \"SimpleX Badges\"" + it "shows a non-ASCII name as written" $ + inertGroupConfig (cfg "Значки" Nothing) (profile "SimpleX Badges" Nothing) + `shouldBe` Just "badge group config is not applied to an existing group: display_name \"Значки\", group has \"SimpleX Badges\"" + it "reports a description the config would change or remove" $ do + inertGroupConfig (cfg "SimpleX Badges" (Just "new desk")) (profile "SimpleX Badges" (Just "badge ops desk")) + `shouldBe` Just "badge group config is not applied to an existing group: description \"new desk\", group has \"badge ops desk\"" + inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" (Just "badge ops desk")) + `shouldBe` Just "badge group config is not applied to an existing group: description \"\", group has \"badge ops desk\"" + it "reports both fields when both would change" $ + inertGroupConfig (cfg "SimpleX Badges 2026" (Just "new desk")) (profile "SimpleX Badges" Nothing) + `shouldBe` Just + "badge group config is not applied to an existing group: \ + \display_name \"SimpleX Badges 2026\", group has \"SimpleX Badges\"; \ + \description \"new desk\", group has \"\"" + describe "tracker" $ + it "edits within 24h, reposts after" $ do + let t0 = UTCTime (fromGregorian 2026 1 1) 0 + within = addUTCTime (23 * 3600) t0 + past = addUTCTime (25 * 3600) t0 + trackerDecision within t0 `shouldBe` Edit + trackerDecision past t0 `shouldBe` Repost + describe "coalescing tracker refreshes" $ do + it "keeps one refresh per code, carrying the highest claim" $ do + code <- newCode + coalesceTrackerRefreshes [GETracker 1 code 1, GETracker 1 code 3, GETracker 2 code 1] + `shouldBe` [GETracker 1 code 3, GETracker 2 code 1] + it "keeps the highest claim whichever order it queued in" $ do + code <- newCode + coalesceTrackerRefreshes [GETracker 1 code 3, GETracker 1 code 1] `shouldBe` [GETracker 1 code 3] + it "keeps every other event, in order" $ do + code <- newCode + coalesceTrackerRefreshes + [ GEInGroup 7 (GACommand GRAdmin "a"), + GETracker 1 code 1, + GEInGroup 7 GAJoined, + GETracker 1 code 2 + ] + `shouldBe` [GEInGroup 7 (GACommand GRAdmin "a"), GEInGroup 7 GAJoined, GETracker 1 code 2] + +newCode :: IO BadgeCode +newCode = C.newRandom >>= randomBadgeCode diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index 7f3e9f0ba2..71a3b60d15 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/tests/Bots/BadgeService/WebTests.hs @@ -14,7 +14,7 @@ import BadgeService.Poller import BadgeService.Providers import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages) import BadgeService.Providers.Stripe (stripeProvider) -import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, insertBadgeCode, revokeCode) +import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, getManagedGroup, insertBadgeCode, insertManagedGroup, markOwnerBootstrapped, revokeCode) import BadgeService.Store.Invoices import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount) import BadgeService.Web.Server @@ -42,7 +42,7 @@ import Data.Char (toLower) import Data.Either (isLeft) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import Data.Int (Int64) -import Data.List (sort, sortOn) +import Data.List (isInfixOf, sort, sortOn) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, isJust, isNothing, fromMaybe, mapMaybe) import Data.Text (Text) @@ -138,7 +138,7 @@ badgeWebTests = do describe "badge service schema" $ do it "carries the five service-only columns" testServiceColumns it "refuses a duplicate provider_ref" testProviderRefUnique - it "M20260918 adds the multi-use columns" testGroupOpsColumns + it "M20260918 adds the multi-use columns and the group table" testGroupOpsColumns it "M20260918 defaults a fresh code to one use with none spent" testGroupOpsRedeemCounts it "migrates all the way down and up again" testSchemaDownUpCycle it "rolls back only the group migration and re-applies it, keeping a code redeemed twice spent" testGroupOpsDownUp @@ -154,6 +154,9 @@ badgeWebTests = do it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther it "a multi-use code can be revoked while it has uses left, and not once they are gone" testRevokeMultiUseCode it "every timestamp round-trips to the second" testTimestampRoundTrip + describe "managed group" $ do + it "round-trips and bootstraps once" testManagedGroupRoundTripsAndBootstrapsOnce + it "refuses a second row and burns the flag per group" testManagedGroupIsSingleRow describe "multi-use" $ do it "finds a key's own purchase with its newest credential, and none for another key" testKeyPurchaseLookup it "gives concurrent claims exactly the code's uses, each a distinct count" testMultiUseConcurrentClaimsUpToLimit @@ -321,7 +324,9 @@ testGroupOpsColumns = withServiceStore assertGroupOpsColumns assertGroupOpsColumns :: HasCallStack => DBStore -> IO () assertGroupOpsColumns st = do columnsOf st "sx_badge_service_badge_codes" - >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["redeem_limit", "redeem_count"]) + >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["redeem_limit", "redeem_count", "group_item_id", "group_item_sent_at"]) + columnsOf st "sx_badge_service_group" + >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["group_id", "group_link", "owner_bootstrapped", "created_at"]) runMigrations :: DBStore -> MigrationsToRun -> IO () #if defined(dbPostgres) @@ -336,6 +341,7 @@ testSchemaDownUpCycle = withServiceStore $ \st -> do length downMigrations `shouldBe` length badgeServiceSchemaMigrations runMigrations st $ MTRDown downMigrations columnsOf st "sx_badge_service_badge_codes" `shouldReturn` [] + columnsOf st "sx_badge_service_group" `shouldReturn` [] runMigrations st $ MTRUp badgeServiceSchemaMigrations assertGroupOpsColumns st @@ -532,7 +538,7 @@ testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do redeem badgeCodeId = claimUse st badgeCodeId now keys revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now revokedFirst <- newCode "revoked-first" - revoke "revoked-first" `shouldReturn` Revoked + revoke "revoked-first" `shouldReturn` Revoked revokedFirst redeem revokedFirst `shouldReturn` Nothing codeCounts st "revoked-first" `shouldReturn` Just (1, 0) redeemedFirst <- newCode "redeemed-first" @@ -549,7 +555,7 @@ testRevokeMultiUseCode = withServiceStore $ \st -> do revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now partlyUsed <- newCode "partly-used" isJust <$> redeem partlyUsed `shouldReturn` True - revoke "partly-used" `shouldReturn` Revoked + revoke "partly-used" `shouldReturn` Revoked partlyUsed redeem partlyUsed `shouldReturn` Nothing usedUp <- newCode "used-up" isJust <$> redeem usedUp `shouldReturn` True @@ -689,6 +695,35 @@ testTimestampRoundTrip = withServiceStore $ \st -> do irExpiresAt row `shouldBe` truncated irCreatedAt row `shouldBe` truncated +testManagedGroupRoundTripsAndBootstrapsOnce :: IO () +testManagedGroupRoundTripsAndBootstrapsOnce = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + beforeInsert <- withTransaction st getManagedGroup + beforeInsert `shouldBe` Nothing + withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now + afterInsert <- withTransaction st getManagedGroup + afterInsert `shouldBe` Just ManagedGroup {mgGroupId = 42, mgGroupLink = "https://link", mgOwnerBootstrapped = False} + show afterInsert `shouldNotSatisfy` ("https://link" `isInfixOf`) + firstMark <- withTransaction st (`markOwnerBootstrapped` 42) + secondMark <- withTransaction st (`markOwnerBootstrapped` 42) + (firstMark, secondMark) `shouldBe` (True, False) + +testManagedGroupIsSingleRow :: IO () +testManagedGroupIsSingleRow = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now + withTransaction st $ \db -> insertManagedGroup db 43 "https://other" now + withTransaction st $ \db -> insertManagedGroup db 42 "https://again" now + managedGroupRows st `shouldReturn` [(42, "https://link")] + withTransaction st (`markOwnerBootstrapped` 43) `shouldReturn` False + (fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just False + withTransaction st (`markOwnerBootstrapped` 42) `shouldReturn` True + (fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just True + +managedGroupRows :: DBStore -> IO [(Int64, Text)] +managedGroupRows st = + withConnection st $ \db -> DB.query_ db "SELECT group_id, group_link FROM sx_badge_service_group ORDER BY group_id" + insertCode :: DBStore -> ByteString -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64 insertCode st codeHash paymentStatus redeemLimit now = withTransaction st $ \db -> insertBadgeCode db codeHash BTSupporter 1 paymentStatus redeemLimit now @@ -943,7 +978,7 @@ testServiceConfig staticDir trustForwarded = stripe = Nothing, poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60}, issuer = Nothing, - devChatRedeem = False + group = Nothing } testServeWebappOff :: IO () diff --git a/tests/Test.hs b/tests/Test.hs index dd2a7b8d59..0a5b56b230 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -7,6 +7,8 @@ import Bots.BadgeService.BTCPayTests import Bots.BadgeService.BotTests import Bots.BadgeService.CatalogTests import Bots.BadgeService.ConfigTests +import Bots.BadgeService.GroupIntegrationTests +import Bots.BadgeService.GroupTests import Bots.BadgeService.StripeTests import Bots.BadgeService.WaitersTests import Bots.BadgeService.WebTests @@ -74,6 +76,7 @@ main = do badgeConfigTests badgeWebTests badgeCatalogTests + badgeGroupTests badgeWaitersTests badgeBTCPayTests badgeStripeTests @@ -102,7 +105,9 @@ main = do describe "SimpleX chat client" chatTests xdescribe'' "SimpleX Broadcast bot" broadcastBotTests xdescribe'' "SimpleX Directory service bot" directoryServiceTests - xdescribe'' "SimpleX badge service e2e" badgeServiceTests + xdescribe'' "SimpleX badge service e2e" $ do + badgeServiceTests + describe "managed group" badgeGroupIntegrationTests describe "Remote session" remoteTests #if !defined(dbPostgres) xdescribe'' "Save query plans" saveQueryPlans