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/README.md b/apps/simplex-badge-service/README.md index 8467e57906..83b7ca4c40 100644 --- a/apps/simplex-badge-service/README.md +++ b/apps/simplex-badge-service/README.md @@ -21,8 +21,10 @@ At this stage the service: - creates a double-ratchet contact address on first start (service RPC requires DR, see [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md)), - listens for service requests (`CEvtServiceRequest`) on that address, rejects a request whose `purchaseKey` is not the key the agent verified the signature against, and answers `redeemBadgeCode`, -- issues redemption codes, storing only their `SHA-256` and printing each code once, -- does not accept contact requests unless `[dev] chat_redeem` is on: the address is for RPC only, +- issues redemption codes, storing only their `SHA-256` in its code table, +- does not accept contact requests: the address is for RPC only, +- in service mode with `[group]` in the ini, manages one SimpleX group and serves `/issue`, `/bulk` + and `/revoke` in it (see [Issuing codes](#issuing-codes)), - in service mode with `--service-config`, also serves the built web app (`npm run build` in `web/`), `POST /api/invoice` and `GET /api/invoice/:id`, the BTCPay and Stripe webhook routes, and a payment poller, seeding its price/offer catalog on every start, - owns the `sx_badge_service_`-prefixed tables and its own migrations table (`sx_badge_service_migrations`). @@ -47,8 +49,9 @@ simplex-badge-service --help - default (no `--run-cli`): background service mode, no interactive terminal. - `--run-cli`: interactive CLI that also processes service requests (mirrors `simplex-directory-service --run-cli`). This mode is the chat/RPC side and the `//` commands - below: it starts no web listener and no poller, and `[dev] chat_redeem` does not apply to it, - whatever `--service-config` says. + below: it starts no web listener and no poller, and serves no group commands, whatever + `--service-config` says. It still updates a code's group message when the code is redeemed or + revoked. - `--no-address`: skip address creation on start-up (for operators who provision the address themselves). The service cannot sign credentials without an issuer key and refuses to start without one: @@ -92,7 +95,9 @@ Other options: `badge_service.ini` holds the listener bind address and `static_dir`, an optional `[btcpay]` section (omitting it disables Bitcoin and Monero), an optional `[stripe]` -section (omitting it disables card payments) and the poll cadence. +section (omitting it disables card payments), an optional `[group]` section (omitting it +turns off the group's commands, though a group created earlier still has its code messages updated) +and the poll cadence. `badge_service.ini.example` is the committed template; `badge_service.ini` itself is gitignored, since a real one holds API keys and webhook secrets. @@ -203,27 +208,15 @@ the exception: each answers 200, 400 or 413 with an empty body, because its prov caller and nothing it could read would change what the route does. A wrong verb on any route, those two included, answers `method_not_allowed`. -### Redeeming over chat, for local testing - -```ini -[dev] -chat_redeem = on -``` - -With this on, the service accepts contact requests and answers `/redeem ` from a contact -with the credential as one-line JSON, ready to paste into a client as `/badge add `. Off by -default, and only `on`/`off` parse, so a typo cannot silently arm it. It applies to the service -mode only; `--run-cli` ignores it. - -Keep it off anywhere real. The service RPC signs over a master key only the client holds; here -there is no client key, so the service generates one and hands it over with the credential, which -means it can link every badge it issues this way. `simplex-chat badge sign` has the same property -and is the offline equivalent. - ## Issuing codes -Issuing a code is an operator command sent to the running service in `--run-cli` mode, not a way -to start it — so codes are issued without a second process touching the service's database: +Operators issue codes two ways: from the service's own command line in `--run-cli` mode, and from the +managed group in service mode. Both are commands to a running process, so no second process +touches the service's database. + +### From the command line + +The command is sent to the running service in `--run-cli` mode, not a way to start it: ``` //issue [months] [paid|unpaid|free] @@ -245,8 +238,76 @@ A code that leaked, or that was refunded, is withdrawn the same way: ``` A revoked code answers redemption with `code_invalid`, as if it had never existed, so its holder -learns nothing from trying. Revoking is not repeatable: the second attempt says so. A code that -was already redeemed cannot be revoked: its badge was issued, and the command answers with an error. +learns nothing from trying. A client that redeemed it before the revoke still gets its own badge +back when it asks again. Revoking it again answers "already revoked" and fixes its group +message if the first revoke didn't. A code with no uses left can't be revoked, because its badges +were already given out, and the command answers with an error. A multi-use code with uses left can +be revoked, which stops the uses that remain. Core parses `//...` into `CustomChatCommand` and leaves it to the service's `preCmdHook`, which is why issuing codes lives in the service rather than in core. + +### From the group + +With `[group]` in `badge_service.ini`, the service manages one group and serves three commands in +it: `/issue [months ] [uses ]` and `/bulk [months ] count ` for moderators +and above, `/revoke ` for admins and owners. `months` is 1 to 255, `uses` 1 to 1000 and +`count` 1 to 100; a value outside these gets the usage reply. A member's role is checked as the +service last saw it, so a command sent by a moderator just demoted or removed can still run if it +reaches the service first; revoke any code the service posts for them after the change. `uses` +above 1 makes a multi-use code, tracked by a group message showing its remaining uses and the time +of the last one; when every use is redeemed, the same message says so. Every reply carrying a code is read by every member, +since the group has no private lane, so a code issued there is only as private as its least trusted +member. +Those replies are also kept as plain text in the service's chat database, so a copy of the database +holds every code issued in the group. Keep the group's visible history off: with it on, each new +member receives recent messages, and the codes in them, when they join. A multi-use code's message +carries the code, and every redemption edits it or, after a day, posts it again; either way every +current member receives it, so a member who joined after the code was issued gets the code while it +still has uses left. A message replaced by a new post stays in the group with its old count. Keep +disappearing messages off in the group and set no message TTL for the service's chats: a code's +message that expires is treated as deleted and never posted again, so its counter stops. +Every member can see when each use of a multi-use code was redeemed: the message shows the time of +the last one, and its edit times show the rest. +`/revoke ` names the code in an ordinary group message, so every member holds it before the +service reads the command, and the code stays redeemable until the service acts on it — for the +whole of any downtime. Revoke a code that is not already public in the group, a refunded one above +all, with `//revoke` in `--run-cli` mode. A `/revoke ` with nothing after the code, from a +member below admin, is answered that the code was not revoked and is now visible to the group. A +group command the service received but had not run when it stopped, or received while it ran in +`--run-cli` mode, is dropped with no reply, so resend it, or use `//revoke`. + +The first member to join through the link is promoted to owner, so the operator joins before sharing +it. Keep the service an owner too: below owner it cannot update the group's command menu, and below +author it cannot post codes or replies. A failed promotion is logged at once, and an owner who left +is logged at the next start or join. Then make the member you choose owner with the `/mr` command +that the log line names, in `--run-cli` mode; the service never promotes anyone once the first +promotion was attempted. + +The join link logged when the group is created stays valid: anyone who has it can join later, as a +member, and read every code posted or edited from then on. That includes a removed member, who can +rejoin through it, so removing a member does not stop them seeing new codes. Keep the log that holds +it private. The link is also stored in the `group_link` column of `sx_badge_service_group`, where it +can be read again. + +If an owner deletes the group, or removes the service from it, the service logs an error on start +and stops serving the group. To create a new group, stop the service, delete the row, and start it +again: with SQLite, run `DELETE FROM sx_badge_service_group;` on the `_chat.db` file +(`~/.simplex/simplex_badge_service_chat.db` by default), opened with `sqlcipher` and the database key +if one is set; with PostgreSQL, run +`DELETE FROM _chat_schema.sx_badge_service_group;` (`simplex_v1_chat_schema` by default). +Multi-use codes issued in the old group stay redeemable, but their messages there are no longer +updated, so revoke with `//revoke` any that should not stay live. + +The group is identified by the single `sx_badge_service_group` row. Rolling back past the +`20260918_badge_group_ops` migration drops that table, so a later re-upgrade creates a second group +and orphans the first one with its members and roles; multi-use codes come back single-use with +their claims re-derived, and outstanding trackers come back unanchored. Redeemed credentials are +preserved and no code becomes redeemable again, though while the old version runs, only the holder +whose credential ends last gets it back on a retry, and any other holder of a multi-use code gets +`code_used`; every holder of a revoked code gets `code_invalid`. Rolling back means re-creating and +re-sharing the group; delete the orphaned one with `/d #''` in `--run-cli` mode, as its +join link still works and its messages hold every code posted there. + +The configured `display_name` and `description` apply only to the group the service creates. Editing +them later is logged as not applied and changes nothing. 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 new file mode 100644 index 0000000000..06d3517359 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Codes.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module BadgeService.Codes + ( issueOneCode, + issueFailedText, + revokeBadgeCode, + singleUse, + ) +where + +import BadgeService.Store (RevokeResult, insertBadgeCode, revokeCode) +import BadgeService.Store.Invoices (truncateToSecond) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Simplex.Chat.Badges (BadgeType) +import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, randomBadgeCode) +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus) +import Simplex.Chat.Bot.Store (withDB') +import Simplex.Chat.Controller (ChatController (..)) + +singleUse :: Int +singleUse = 1 + +revokeBadgeCode :: ChatController -> BadgeCode -> IO (Either String RevokeResult) +revokeBadgeCode cc code = do + now <- truncateToSecond <$> getCurrentTime + withDB' "revokeBadgeCode" cc $ \db -> revokeCode db (badgeCodeHash code) now + +-- | The group is joined through a bearer link, so this reply names no database error. +issueFailedText :: Text +issueFailedText = "The code could not be issued." + +-- | The code table keeps only the hash, so the caller must deliver the code. +issueOneCode :: ChatController -> BadgeType -> Int -> BadgeCodePaymentStatus -> Int -> IO (Either String (BadgeCode, Int64)) +issueOneCode cc badgeType months paymentStatus redeemLimit = do + code <- randomBadgeCode $ random cc + now <- truncateToSecond <$> getCurrentTime + fmap (code,) <$> withDB' "issueBadgeCode" cc (\db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus redeemLimit now) 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..28117655ef --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Group.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module BadgeService.Group + ( ensureManagedGroup, + runGroupLane, + inertGroupConfig, + GroupEvent (..), + GroupAction (..), + groupEvent, + hasTracker, + refreshTracker, + revokeWithTracker, + coalesceTrackerRefreshes, + TrackerAction (..), + trackerDecision, + codeInTracker, + noOwnerHint, + orphanHint, + ) +where + +import BadgeService.Codes (issueFailedText, issueOneCode, revokeBadgeCode, singleUse) +import BadgeService.Config (GroupConfig (..)) +import BadgeService.Group.Command (CmdAction (..), GroupCmd (..), groupCmdAction, groupCommands) +import BadgeService.Log (logError, logInfo, logWarn) +import BadgeService.Store (CodeTracker (..), ManagedGroup (..), RevokeResult (..), clearCodeGroupItems, getCodeTracker, getEditableTrackers, getManagedGroup, insertManagedGroup, markOwnerBootstrapped, setCodeGroupItem) +import BadgeService.Store.Invoices (truncateToSecond) +import Control.Concurrent.STM (TQueue, atomically, flushTQueue, readTQueue, readTVarIO, writeTQueue) +import Control.Monad (forM_, forever, mfilter, replicateM, unless, void) +import Control.Monad.Except (runExceptT) +import Data.Either (partitionEithers) +import Data.Functor (($>), (<&>)) +import Data.Int (Int64) +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDay) +import Data.Time.Format (defaultTimeLocale, formatTime) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Simplex.Chat.Badges.Code (BadgeCode, formatBadgeCode, parseBadgeCode) +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) +import Simplex.Chat.Bot.Store (withDB') +import Simplex.Chat.Controller +import Simplex.Chat.Core (sendChatCmd) +import Simplex.Chat.Markdown (viewName) +import Simplex.Chat.Messages +import Simplex.Chat.Messages.CIContent (CIContent (..), ciContentToText) +import Simplex.Chat.Protocol (MsgContent (..)) +import Simplex.Chat.Store.Messages (getGroupChatItem) +import Simplex.Chat.Store.Shared (StoreError (..)) +import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences (GroupPreferences (..), commands_, emptyGroupPrefs) +import Simplex.Chat.Types.Shared (GroupMemberRole (..)) +import Simplex.Chat.View (simplexChatContact) +import Simplex.Messaging.Agent.Protocol (CreatedConnLink (..), UserId) +import Simplex.Messaging.Encoding.String (StrEncoding, strEncode) +import Simplex.Messaging.Util (catchOwn', safeDecodeUtf8, tshow, ($>>=)) +import System.Exit (exitFailure) + +buildGroupProfile :: GroupConfig -> GroupProfile +buildGroupProfile GroupConfig {gDisplayName, gDescription} = + GroupProfile + { displayName = gDisplayName, + fullName = "", + shortDescr = Nothing, + description = gDescription, + image = Nothing, + publicGroup = Nothing, + groupPreferences = Just (emptyGroupPrefs {commands = Just groupCommands} :: GroupPreferences), + memberAdmission = Nothing + } + +ensureManagedGroup :: ChatController -> GroupConfig -> IO (Maybe GroupId) +ensureManagedGroup cc gc = + withDB' "getManagedGroup" cc getManagedGroup >>= \case + -- A read error must not fall through to create, which would orphan a second group. + -- The service stops instead, so a restart retries rather than leaving the group unserved. + Left _ -> logError "badge group lookup failed, stopping" >> exitFailure + -- The join link is a bearer secret, logged only where it is created. + Right (Just ManagedGroup {mgGroupId}) -> + sendChatCmd cc (APIGroupInfo mgGroupId) >>= \case + Right CRGroupInfo {groupInfo = GroupInfo {membership, groupProfile = p}} + | memberCurrent membership -> do + forM_ (inertGroupConfig gc p) logWarn + unless (commandsCurrent p) $ advertiseCommands cc mgGroupId p + logInfo "badge group ready" + pure (Just mgGroupId) + | otherwise -> groupGone + Left (ChatErrorStore SEGroupNotFound {}) -> groupGone + r -> do + logError ("badge group info failed: " <> tshow r) + pure (Just mgGroupId) + Right Nothing -> + readTVarIO (currentUser cc) >>= \case + Nothing -> logError "badge group not created: no current user" >> pure Nothing + Just User {userId} -> createManagedGroup cc gc userId + where + groupGone = do + logError "badge group was deleted or the service was removed from it; delete the sx_badge_service_group row and restart to create a new group" + pure Nothing + +createManagedGroup :: ChatController -> GroupConfig -> UserId -> IO (Maybe GroupId) +createManagedGroup cc gc userId = + sendChatCmd cc (APINewGroup userId False (buildGroupProfile gc)) >>= \case + Right CRGroupCreated {groupInfo = g@GroupInfo {groupId}} -> + sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case + Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact}} -> do + now <- truncateToSecond <$> getCurrentTime + let linkText = groupLinkText connLinkContact + withDB' "insertManagedGroup" cc (\db -> insertManagedGroup db groupId linkText now >> clearCodeGroupItems db) >>= \case + Right () -> do + logInfo $ "badge group created, join link: " <> linkText + pure (Just groupId) + Left _ -> logError ("badge group " <> tshow groupId <> " not recorded - " <> orphanHint (groupName' g)) >> pure Nothing + r -> logError ("badge group " <> tshow groupId <> " link failed: " <> tshow r <> " - " <> orphanHint (groupName' g)) >> pure Nothing + r -> logError ("badge group creation failed: " <> tshow r) >> pure Nothing + +-- The next start creates another group, so a partly created one is left for the operator to delete. +orphanHint :: GroupName -> Text +orphanHint gName = "delete this orphan group with /d #" <> viewName gName <> " in --run-cli mode" + +-- An existing group gets the current commands, so an upgrade that changes them reaches its members. +commandsCurrent :: GroupProfile -> Bool +commandsCurrent groupProfile = (groupPreferences groupProfile >>= commands_) == Just groupCommands + +advertiseCommands :: ChatController -> GroupId -> GroupProfile -> IO () +advertiseCommands cc groupId groupProfile = + sendChatCmd cc (APIUpdateGroupProfile groupId p') >>= \case + Right CRGroupUpdated {} -> logInfo "badge group commands advertised" + r -> logError ("badge group profile update failed: " <> tshow r) + where + prefs = fromMaybe emptyGroupPrefs (groupPreferences groupProfile) + p' = groupProfile {groupPreferences = Just (prefs {commands = Just groupCommands} :: GroupPreferences)} + +-- Config is applied only at creation, since a group rename is broadcast to every member. +inertGroupConfig :: GroupConfig -> GroupProfile -> Maybe Text +inertGroupConfig GroupConfig {gDisplayName, gDescription} GroupProfile {displayName, description} + | null diverged = Nothing + | otherwise = Just $ "badge group config is not applied to an existing group: " <> T.intercalate "; " diverged + where + diverged = + [ field <> " \"" <> configured <> "\", group has \"" <> live <> "\"" + | (field, configured, live) <- + [ ("display_name", gDisplayName, displayName), + ("description", fromMaybe "" gDescription, fromMaybe "" description) + ], + configured /= live + ] + +groupLinkText :: CreatedLinkContact -> Text +groupLinkText (CCLink cReq sLnk_) = maybe (strEncodeTxt (simplexChatContact cReq)) strEncodeTxt sLnk_ + +strEncodeTxt :: StrEncoding a => a -> Text +strEncodeTxt = safeDecodeUtf8 . strEncode + +data GroupEvent + = GEInGroup GroupId GroupAction + | GETracker Int64 BadgeCode + deriving (Eq, Show) + +data GroupAction + = GAJoined + | GACommand GroupMemberRole Text + deriving (Eq, Show) + +-- Support-scope, moderated or blocked, and live items are ignored: the reply would go to the main group, +-- moderation or blocking without Full Delete keeps the content, and a live item holds only partial text. +groupEvent :: ChatEvent -> Maybe GroupEvent +groupEvent = \case + CEvtJoinedGroupMember {groupInfo = GroupInfo {groupId}} -> Just $ GEInGroup groupId GAJoined + CEvtNewChatItems {chatItems = AChatItem _ _ (GroupChat GroupInfo {groupId} scope) ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent (MCText t), meta = CIMeta {itemDeleted, itemLive}} : _} + | isNothing scope && isNothing itemDeleted && itemLive /= Just True -> Just $ GEInGroup groupId (GACommand (memberRole' m) t) + _ -> Nothing + +-- A refresh reads the code's count when it runs, so the last one queued shows every claim before it. +coalesceTrackerRefreshes :: [GroupEvent] -> [GroupEvent] +coalesceTrackerRefreshes = snd . foldr keepLast (S.empty, []) + where + keepLast ev (seen, kept) = case ev of + GETracker badgeCodeId _ + | badgeCodeId `S.member` seen -> (seen, kept) + | otherwise -> (S.insert badgeCodeId seen, ev : kept) + _ -> (seen, ev : kept) + +logUncaught :: HasCallStack => IO () -> IO () +logUncaught a = a `catchOwn'` withFrozenCallStack (logError . tshow) + +handleGroupEvent :: ChatController -> GroupId -> GroupEvent -> IO () +handleGroupEvent cc groupId ev = logUncaught (handle ev) + where + handle = \case + GEInGroup gid action + | gid /= groupId -> pure () + | otherwise -> case action of + GAJoined -> promoteOwner cc groupId + GACommand role t -> case groupCmdAction role t of + RunCmd cmd -> runGroupCmd cc groupId cmd + ReplyText txt -> void $ sendGroupText cc groupId "command reply" txt + IgnoreMsg -> pure () + GETracker badgeCodeId code -> updateTracker cc groupId badgeCodeId code + +promoteFirstOwner :: ChatController -> GroupInfo -> GroupMember -> IO () +promoteFirstOwner cc g@GroupInfo {groupId} member = + -- The flag is set before promoting, so a retry cannot promote a second owner. + withDB' "markOwnerBootstrapped" cc (`markOwnerBootstrapped` groupId) >>= \case + Right True -> + sendChatCmd cc (APIMembersRole groupId (groupMemberId' member :| []) GROwner) >>= \case + -- The core returns no members when every store update failed. + Right CRMembersRoleUser {members = _ : _} -> logInfo $ "badge group owner promoted: member " <> tshow (groupMemberId' member) + r -> logError $ "badge group owner promotion failed: " <> tshow r <> " - " <> noOwnerHint (groupName' g) + _ -> pure () + +-- Nothing is a group that is not served, so its events are drained. +runGroupLane :: ChatController -> TQueue GroupEvent -> Maybe GroupId -> IO () +runGroupLane cc q groupId_ = case groupId_ of + Just groupId -> do + promoteOwner cc groupId + -- Reconciling precedes the first batch, so queued events write after the correction. + reconcileTrackers cc groupId + forever $ do + evs <- atomically $ (:) <$> readTQueue q <*> flushTQueue q + mapM_ (handleGroupEvent cc groupId) (coalesceTrackerRefreshes evs) + Nothing -> forever $ void $ atomically (readTQueue q) + +-- The earliest joined member is promoted, not the one who just joined, so a join the lane never handled +-- (under --run-cli, or lost in a crash) or a failed attempt never hands the group to a later joiner. +promoteOwner :: ChatController -> GroupId -> IO () +promoteOwner cc groupId = + withDB' "getManagedGroup" cc getManagedGroup >>= \case + Right (Just ManagedGroup {mgOwnerBootstrapped}) -> + sendChatCmd cc (APIListMembers groupId) >>= \case + Right CRGroupMembers {group = Group {groupInfo, members}} + -- An owner made by hand only needs the flag set, or promoting would add a second owner. + | any (\m -> memberRole' m == GROwner && memberCurrent m) members -> + unless mgOwnerBootstrapped $ void $ withDB' "markOwnerBootstrapped" cc (`markOwnerBootstrapped` groupId) + -- A crash between setting the flag and promoting leaves no owner, and only the operator may retry. + | mgOwnerBootstrapped -> logError $ noOwnerHint (groupName' groupInfo) + | otherwise -> mapM_ (promoteFirstOwner cc groupInfo) $ listToMaybe $ sortOn groupMemberId' $ filter joined members + r -> logError $ "badge group members not listed: " <> tshow r + _ -> pure () + where + -- A member still joining cannot act yet, so it is not a candidate. + joined m = memberStatus m `elem` [GSMemConnected, GSMemComplete] + +-- The live local name, quoted as --run-cli parses it, can differ from the configured one after a name clash or a rename. +noOwnerHint :: GroupName -> Text +noOwnerHint gName = "the badge group has no member owner, make one with /mr #" <> viewName gName <> " owner in --run-cli mode" + +runGroupCmd :: ChatController -> GroupId -> GroupCmd -> IO () +runGroupCmd cc groupId = \case + GCIssue bt months uses -> + issueOneCode cc bt months CPSFree uses >>= \case + Left _ -> reply issueFailedText + Right (code, badgeCodeId) + | not (hasTracker uses) -> reply ("Code: " <> formatBadgeCode code) + | otherwise -> do + now <- truncateToSecond <$> getCurrentTime + sendGroupText cc groupId ("tracker, code " <> tshow badgeCodeId <> " is lost") (initialTrackerBody code uses) + >>= mapM_ (\iid -> withDB' "setCodeGroupItem" cc $ \db -> setCodeGroupItem db badgeCodeId iid now) + GCBulk bt months count -> do + codes <- replicateM count (issueOneCode cc bt months CPSFree singleUse) + let (errs, ok) = partitionEithers codes + issued = map (formatBadgeCode . fst) ok + reply . T.intercalate "\n" $ case errs of + [] -> issued + _ : _ -> issued <> ["Issued " <> tshow (length issued) <> " of " <> tshow count <> " codes. The remaining codes could not be issued."] + -- Naming the code tells concurrent revokes apart; the command already made it public. + GCRevoke code -> do + outcome <- either id id <$> revokeWithTracker cc code + reply (formatBadgeCode code <> ": " <> outcome) + where + reply = void . sendGroupText cc groupId "reply, any codes in it are lost" + +-- The label says what is lost when the send fails, since the log line is its only trace. +sendGroupText :: HasCallStack => ChatController -> GroupId -> Text -> Text -> IO (Maybe ChatItemId) +sendGroupText cc groupId label txt = + sendChatCmd cc (APISendMessages (SRGroup groupId Nothing False) False Nothing False (ComposedMessage Nothing Nothing (MCText txt) M.empty :| [])) >>= \case + Right CRNewChatItems {chatItems = ci : _} -> pure (Just (aChatItemId ci)) + r -> withFrozenCallStack logError ("badge group message not sent (" <> label <> "): " <> tshow r) $> Nothing + +initialTrackerBody :: BadgeCode -> Int -> Text +initialTrackerBody code total = trackerBody code total total Nothing + +-- The body is dated by the last redemption, not now, because reconcile rewrites it after a restart. +-- The code is green only while it can still be redeemed. +trackerBody :: BadgeCode -> Int -> Int -> Maybe UTCTime -> Text +trackerBody code remaining total redeemedAt + | remaining > 0 = "!2 " <> formatBadgeCode code <> "!\n" <> tshow remaining <> " of " <> tshow total <> " uses remaining" <> lastUsed + | otherwise = formatBadgeCode code <> "\nAll " <> tshow total <> " uses redeemed" <> lastUsed + where + lastUsed = maybe "" ((", last used " <>) . fmtTime) redeemedAt + +revokedBody :: BadgeCode -> Text +revokedBody code = formatBadgeCode code <> "\nRevoked, can no longer be redeemed" + +fmtTime :: UTCTime -> Text +fmtTime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" + +data TrackerAction = Edit | Repost + deriving (Eq, Show) + +-- The core refuses to edit a sent message older than this. +editWindow :: NominalDiffTime +editWindow = nominalDay + +trackerDecision :: UTCTime -> UTCTime -> TrackerAction +trackerDecision now sentAt + | diffUTCTime now sentAt < editWindow = Edit + | otherwise = Repost + +-- A repost publishes the code a second time, so the reconcile pass may only edit. +data RepostPolicy = MayRepost | EditOnly + +-- A deleted or moderated tracker is not reposted, because deleting it does not revoke the code. +setTrackerBody :: ChatController -> GroupId -> Int64 -> RepostPolicy -> (CodeTracker -> Maybe Text) -> IO () +setTrackerBody cc groupId badgeCodeId policy mkBody = + withDB' "getCodeTracker" cc (`getCodeTracker` badgeCodeId) >>= \case + Right (Just tracker@CodeTracker {trackerItemId, trackerSentAt}) -> + forM_ (mkBody tracker) $ \body -> do + now <- truncateToSecond <$> getCurrentTime + let repost = + trackerItemText cc groupId trackerItemId >>= \case + Nothing -> logWarn $ "badge group tracker not reposted, code " <> tshow badgeCodeId <> " is no longer published" + -- Past the window every write reposts, so an unchanged body is not posted again. + Just current -> + unless (current == body) $ + sendGroupText cc groupId ("tracker repost, code " <> tshow badgeCodeId <> " keeps its old message") body + >>= mapM_ (\i -> withDB' "setCodeGroupItem" cc (\db -> setCodeGroupItem db badgeCodeId i now)) + -- The core can also refuse an edit inside the window, because it uses the message's own timestamp. + uneditable = case policy of + MayRepost -> repost + EditOnly -> logWarn $ "badge group tracker left uncorrected, code " <> tshow badgeCodeId <> " can no longer be edited" + case trackerDecision now trackerSentAt of + Edit -> + sendChatCmd cc (APIUpdateChatItem (ChatRef CTGroup groupId Nothing) trackerItemId False (UpdatedMessage (MCText body) M.empty)) >>= \case + Right CRChatItemUpdated {} -> pure () + Right CRChatItemNotChanged {} -> pure () + Left (ChatError CEInvalidChatItemUpdate) -> uneditable + -- Any other failure may still have applied the edit, so a repost could publish the code twice. + r -> logError $ "badge group tracker not updated, code " <> tshow badgeCodeId <> ": " <> tshow r + Repost -> uneditable + _ -> pure () + +-- A revoke and a redemption can arrive in either order, so a revoked tracker is left alone. +counterBody :: BadgeCode -> CodeTracker -> Maybe Text +counterBody code CodeTracker {redeemCount, redeemLimit, revokedAt, redeemedAt} + | isJust revokedAt = Nothing + | otherwise = Just $ trackerBody code (redeemLimit - redeemCount) redeemLimit redeemedAt + +hasTracker :: Int -> Bool +hasTracker redeemLimit = redeemLimit > singleUse + +-- The tracker edit reaches every member, so the group lane runs it off the request path. +-- Without a lane (--run-cli, or no [group]) it runs here, before the response. +refreshTracker :: ChatController -> Maybe (TQueue GroupEvent) -> Int64 -> BadgeCode -> IO () +refreshTracker cc trackerQ_ badgeCodeId code = case trackerQ_ of + Just q -> atomically $ writeTQueue q (GETracker badgeCodeId code) + Nothing -> logUncaught $ withManagedGroup cc $ \groupId -> updateTracker cc groupId badgeCodeId code + +updateTracker :: ChatController -> GroupId -> Int64 -> BadgeCode -> IO () +updateTracker cc groupId badgeCodeId code = setTrackerBody cc groupId badgeCodeId MayRepost (counterBody code) + +-- | Left is a refusal or a failure; both sides are the text to show whoever sent the revoke. +revokeWithTracker :: ChatController -> BadgeCode -> IO (Either Text Text) +revokeWithTracker cc code = + revokeBadgeCode cc code >>= \case + -- The message is retired before the answer, so the answer never sits beside a live counter. + Right (Revoked badgeCodeId) -> Right "Revoked." <$ retire badgeCodeId + -- A repeated revoke repairs a message that an earlier revoke failed to update. + Right (AlreadyRevoked badgeCodeId) -> Right "Already revoked." <$ retire badgeCodeId + Right AlreadyRedeemed -> pure $ Left "Fully redeemed. It cannot be revoked." + Right NoSuchCode -> pure $ Left "No such code." + Left _ -> pure $ Left "The code could not be revoked." + where + retire badgeCodeId = logUncaught $ withManagedGroup cc $ \groupId -> + setTrackerBody cc groupId badgeCodeId MayRepost (const $ Just $ revokedBody code) + +withManagedGroup :: ChatController -> (GroupId -> IO ()) -> IO () +withManagedGroup cc action = + withDB' "getManagedGroup" cc getManagedGroup >>= \case + Right (Just ManagedGroup {mgGroupId}) -> action mgGroupId + _ -> pure () + +-- A claim's refresh is queued after the claim commits, so a crash can drop it. +reconcileTrackers :: ChatController -> GroupId -> IO () +reconcileTrackers cc groupId = do + editableAfter <- addUTCTime (-editWindow) <$> getCurrentTime + withDB' "getEditableTrackers" cc (`getEditableTrackers` editableAfter) >>= \case + Left _ -> logError "badge group trackers not reconciled: tracked code lookup failed" + Right codes -> forM_ codes $ \(badgeCodeId, itemId) -> logUncaught $ reconcileTracker cc groupId badgeCodeId itemId + +-- An unchanged edit still walks every member, so a tracker already showing the right text is skipped. +reconcileTracker :: ChatController -> GroupId -> Int64 -> ChatItemId -> IO () +reconcileTracker cc groupId badgeCodeId itemId = + readTrackerCode cc groupId badgeCodeId itemId >>= mapM_ reconcile + where + reconcile (code, current) = setTrackerBody cc groupId badgeCodeId EditOnly (correctedBody code current) + -- A crash after a revoke committed can leave its tracker still counting, so a revoked code is retired here. + correctedBody code current tracker@CodeTracker {revokedAt} = + mfilter (/= current) $ if isJust revokedAt then Just (revokedBody code) else counterBody code tracker + +readTrackerCode :: ChatController -> GroupId -> Int64 -> ChatItemId -> IO (Maybe (BadgeCode, Text)) +readTrackerCode cc groupId badgeCodeId itemId = + trackerItemText cc groupId itemId >>= \case + Nothing -> do + logWarn $ "badge group tracker not read, code " <> tshow badgeCodeId + pure Nothing + Just current -> case codeInTracker current of + Nothing -> do + logError $ "badge group tracker carries no readable code, code " <> tshow badgeCodeId + pure Nothing + Just code -> pure (Just (code, current)) + +codeInTracker :: Text -> Maybe BadgeCode +codeInTracker = listToMaybe . mapMaybe parseBadgeCode . T.words + +-- The item is read from the store, because the core's item info also loads every edit and every member's delivery status. +-- Moderation can keep a deleted item's content, so itemDeleted is checked. +trackerItemText :: ChatController -> GroupId -> ChatItemId -> IO (Maybe Text) +trackerItemText cc groupId itemId = + readTVarIO (currentUser cc) $>>= \user -> + withDB' "getGroupChatItem" cc (\db -> runExceptT $ getGroupChatItem db user groupId itemId) <&> \case + Right (Right (CChatItem _ ChatItem {content, meta = CIMeta {itemDeleted}})) | isNothing itemDeleted -> Just (ciContentToText content) + _ -> Nothing 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..799e1a2fcf --- /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 = "Usage: /" <> cmdName tag <> " " <> cmdParams tag + +cmdArgsP :: CmdTag -> A.Parser GroupCmd +cmdArgsP = \case + CTIssue -> GCIssue <$> badgeTypeP <*> monthsOpt <*> keyOpt "uses" maxUses + CTBulk -> GCBulk <$> badgeTypeP <*> monthsOpt <*> (A.space *> keyValue "count" maxBulk) + CTRevoke -> GCRevoke <$> codeP + where + monthsOpt = keyOpt "months" maxMonths + keyOpt kw hi = fromMaybe 1 <$> optional (A.space *> keyValue kw hi) + keyValue kw hi = A.string kw *> A.space *> boundedInt kw hi + +groupCommands :: [ChatBotCommand] +groupCommands = map command [minBound .. maxBound] + where + command tag = CBCCommand (cmdName tag) (cmdLabel tag) (Just (cmdParams tag)) + +codeP :: A.Parser BadgeCode +codeP = A.takeWhile1 (not . isSpace) >>= maybe (fail "not a badge code") pure . parseBadgeCode . safeDecodeUtf8 + +-- attoparsec's decimal wraps silently at Int, so the bound is checked on the wider Integer. +boundedInt :: ByteString -> Int -> A.Parser Int +boundedInt kw hi = do + n <- A.decimal :: A.Parser Integer + if n >= 1 && n <= fromIntegral hi + then pure (fromInteger n) + else fail (B.unpack kw <> " out of range") + +-- BadgeType decodes anything to BTUnknown, so a typo would issue an unusable code. +badgeTypeP :: A.Parser BadgeType +badgeTypeP = + textTokenP >>= \case + BTUnknown t -> fail $ "unknown badge type " <> T.unpack t + bt -> pure bt + +textTokenP :: TextEncoding a => A.Parser a +textTokenP = do + t <- A.takeWhile1 (not . isSpace) + maybe (fail "invalid value") pure $ textDecode $ safeDecodeUtf8 t + +-- The advertised menu lists the commands in this order. +data CmdTag = CTIssue | CTBulk | CTRevoke + deriving (Bounded, Enum) + +cmdName :: CmdTag -> Text +cmdName = \case + CTIssue -> "issue" + CTBulk -> "bulk" + CTRevoke -> "revoke" + +cmdLabel :: CmdTag -> Text +cmdLabel = \case + CTIssue -> "Generate a badge code" + CTBulk -> "Generate many single-use codes" + CTRevoke -> "Revoke a code" + +-- | The parameters are quoted in the usage reply and advertised to the group, so the two cannot drift apart. +cmdParams :: CmdTag -> Text +cmdParams = \case + CTIssue -> " [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. This code is now visible to all members." diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 9a3a3f4236..0e189a3489 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,7 +19,10 @@ module BadgeService.Service where import BadgeService.Catalog (defaultCatalog) +import BadgeService.Codes (issueFailedText, issueOneCode, singleUse) import BadgeService.Config (BadgeIssuerKey (..), ServiceConfig (..), readServiceConfig) +import BadgeService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane) +import BadgeService.Group.Command (badgeTypeP, codeP, maxMonths, textTokenP) import BadgeService.Options import BadgeService.Poller (newPollerEnv, newReadHints, runPoller) import BadgeService.Providers.BTCPay (btcpayProvider) @@ -33,19 +34,17 @@ import BadgeService.Waiters (Waiters, newWaiters) import BadgeService.Web.Server (exportWebapp, newWebEnv, runWebListener) import Control.Applicative (optional) import Control.Concurrent.STM -import BadgeService.Log (logError, logInfo, logWarn) +import BadgeService.Log (logError, logInfo) import Control.Monad import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Char (isSpace) import Data.Either (fromRight) -import Data.Functor (($>)) +import Data.Functor (($>), (<&>)) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (fromMaybe, isJust, maybeToList) import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Word (Word32) @@ -54,20 +53,18 @@ import Simplex.Chat.Badges.Code import Simplex.Chat.Badges.Ledger import Simplex.Chat.Badges.Service import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) -import Simplex.Chat.Bot (initializeBotAddress', sendMessage) +import Simplex.Chat.Bot (initializeBotAddress') import Simplex.Chat.Bot.Store (withDB, withDB') import Simplex.Chat.Controller import Simplex.Chat.Core (sendChatCmd, simplexChatCore) -import Simplex.Chat.Messages -import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..), ciContentToText) import Simplex.Chat.Options (printDbOpts) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') -import Simplex.Chat.Types (AgentInvId (..), Contact, User (..)) +import Simplex.Chat.Types (AgentInvId (..), User (..)) import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (bbsPublicKey) -import Simplex.Messaging.Encoding.String (TextEncoding, strEncode, textDecode, textEncode) +import Simplex.Messaging.Encoding.String (strEncode) import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow) import Simplex.Messaging.Version (isCompatible) import System.Directory (getAppUserDataDirectory) @@ -76,15 +73,15 @@ import System.Exit (exitFailure) data ServiceState = ServiceState { serviceCC :: TMVar ChatController, serviceRequestQ :: TQueue (User, AgentInvId, Maybe C.PublicKeyEd25519, J.Object), - chatRedeemQ :: TQueue (Contact, T.Text) + groupEventQ :: TQueue GroupEvent } newServiceState :: IO ServiceState newServiceState = do serviceCC <- newEmptyTMVarIO serviceRequestQ <- newTQueueIO - chatRedeemQ <- newTQueueIO - pure ServiceState {serviceCC, serviceRequestQ, chatRedeemQ} + groupEventQ <- newTQueueIO + pure ServiceState {serviceCC, serviceRequestQ, groupEventQ} welcomeGetOpts :: IO BadgeServiceOpts welcomeGetOpts = do @@ -128,29 +125,29 @@ badgeService opts@BadgeServiceOpts {serviceConfigFile} cfg env = do serviceCfg <- traverse readConfigOrExit serviceConfigFile key <- requireIssuerKey opts serviceCfg cfg waiters <- newWaiters - let devRedeem = maybe False devChatRedeem serviceCfg - chatHooks = - defaultChatHooks - { preStartHook = Just $ badgePreStartHook opts, - postStartHook = Just $ badgePostStartHook opts devRedeem env, - preCmdHook = Just badgeCmdHook - } - when devRedeem $ logWarn "[dev] chat_redeem is on: /redeem over chat hands out credentials this service can link" - -- The reader must not block, since outputQ carries every chat event. - simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> do - lanes <- maybe (pure []) (serviceLanes waiters cc) serviceCfg - raceAny_ $ - [ forever $ + let groupCfg = serviceCfg >>= \ServiceConfig {group} -> group + trackerQ_ = groupEventQ env <$ groupCfg + readEvents cc = + forever $ atomically (readTBQueue $ outputQ cc) >>= \case (_, Right (CEvtServiceRequest u reqId sigKey reqData)) -> atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey, reqData) - (_, Right CEvtNewChatItems {chatItems = AChatItem _ SMDRcv (DirectChat ct) ChatItem {content = mc@CIRcvMsgContent {}} : _}) - | devRedeem -> atomically $ writeTQueue (chatRedeemQ env) (ct, ciContentToText mc) - _ -> pure (), - processQueuedRequests key env - ] - <> [processChatRedeems key env | devRedeem] - <> lanes + (_, Right ev) + | isJust groupCfg -> forM_ (groupEvent ev) $ atomically . writeTQueue (groupEventQ env) + _ -> pure () + startLanes cc = do + lanes <- maybe (pure []) (serviceLanes waiters cc) serviceCfg + -- The group is resolved before the other lanes start, so a failed lookup exits at once rather than waiting for them to end. + groupLane_ <- forM groupCfg $ \gc -> runGroupLane cc (groupEventQ env) <$> ensureManagedGroup cc gc + raceAny_ $ processQueuedRequests key trackerQ_ env : maybeToList groupLane_ <> lanes + chatHooks = + defaultChatHooks + { preStartHook = Just $ badgePreStartHook opts, + postStartHook = Just $ badgePostStartHook opts env, + preCmdHook = Just badgeCmdHook + } + -- The reader runs from the start and must not block, since outputQ carries every chat event and a full queue stalls the core. + simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> raceAny_ [readEvents cc, startLanes cc] where serviceLanes :: Waiters -> ChatController -> ServiceConfig -> IO [IO ()] serviceLanes ws ChatController {chatStore} sc = do @@ -188,13 +185,13 @@ badgeServiceCLI opts@BadgeServiceOpts {serviceConfigFile} = do chatHooks = defaultChatHooks { preStartHook = Just $ badgePreStartHook opts, - postStartHook = Just $ badgePostStartHook opts False env, + postStartHook = Just $ badgePostStartHook opts env, preCmdHook = Just badgeCmdHook, eventHook = Just eventHook } raceAny_ [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing, - processQueuedRequests key env + processQueuedRequests key Nothing env ] badgeCmdHook :: ChatController -> ChatCommand -> IO (Either (Either ChatError ChatResponse) ChatCommand) @@ -206,26 +203,16 @@ runBadgeCmd :: ChatController -> ByteString -> IO (Either ChatError ChatResponse runBadgeCmd cc cmd | Right issueOpts <- A.parseOnly issueCmdP cmd = issueBadgeCode cc issueOpts >>= \case - Right code -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "code " <> formatBadgeCode code} - Left e -> pure $ chatCmdError $ "issuing code: " <> e + Right code -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "Code: " <> formatBadgeCode code} + Left _ -> pure $ chatCmdError (T.unpack issueFailedText) | Right code <- A.parseOnly revokeCmdP cmd = - revokeBadgeCode cc code >>= \case - Right Revoked -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "revoked"} - Right AlreadyRevoked -> pure $ chatCmdError "code was revoked already" - Right AlreadyRedeemed -> pure $ chatCmdError "code was redeemed already, so it cannot be revoked" - Right NoSuchCode -> pure $ chatCmdError "no such code" - Left e -> pure $ chatCmdError $ "revoking code: " <> e - | otherwise = pure $ chatCmdError "use: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke " + revokeWithTracker cc code <&> \case + Right response -> Right CRCustomChatResponse {user_ = Nothing, response} + Left e -> chatCmdError (T.unpack e) + | otherwise = pure $ chatCmdError $ "Usage: //issue supporter|legend|investor [months 1-" <> show maxMonths <> "] [paid|unpaid|free], or //revoke " revokeCmdP :: A.Parser BadgeCode -revokeCmdP = - "revoke " *> (A.takeWhile1 (not . isSpace) >>= maybe (fail "not a badge code") pure . parseBadgeCode . safeDecodeUtf8) - <* (A.skipSpace *> A.endOfInput) - -revokeBadgeCode :: ChatController -> BadgeCode -> IO (Either String RevokeResult) -revokeBadgeCode cc code = do - now <- truncateToSecond <$> getCurrentTime - withDB' "revokeBadgeCode" cc $ \db -> revokeCode db (badgeCodeHash code) now +revokeCmdP = "revoke " *> codeP <* (A.skipSpace *> A.endOfInput) issueCmdP :: A.Parser IssueCodeOpts issueCmdP = @@ -241,17 +228,8 @@ issueCmdP = where -- Integer, because attoparsec's decimal wraps silently at Int, so the guard would check a truncated count. checkMonths n - | n >= 1 && n <= 255 = pure (fromInteger n) - | otherwise = fail "months must be between 1 and 255" - -- BadgeType decodes anything to BTUnknown, so a typo would issue an unusable code - badgeTypeP = - textTokenP >>= \case - BTUnknown t -> fail $ "unknown badge type " <> T.unpack t - bt -> pure bt - textTokenP :: TextEncoding a => A.Parser a - textTokenP = do - t <- A.takeWhile1 (not . isSpace) - maybe (fail "invalid value") pure $ textDecode $ safeDecodeUtf8 t + | n >= 1 && n <= fromIntegral maxMonths = pure (fromInteger n) + | otherwise = fail $ "months must be between 1 and " <> show maxMonths data IssueCodeOpts = IssueCodeOpts { badgeType :: BadgeType, @@ -259,60 +237,37 @@ data IssueCodeOpts = IssueCodeOpts paymentStatus :: BadgeCodePaymentStatus } --- | The caller sees the code once; only its hash is stored, so a lost code cannot be recovered. issueBadgeCode :: ChatController -> IssueCodeOpts -> IO (Either String BadgeCode) -issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = do - code <- randomBadgeCode $ random cc - now <- getCurrentTime - r <- withDB' "issueBadgeCode" cc $ \db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus now - pure $ code <$ r +issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = + fmap fst <$> issueOneCode cc badgeType months paymentStatus singleUse -processQueuedRequests :: BadgeIssuerKey -> ServiceState -> IO () -processQueuedRequests key env = do +processQueuedRequests :: BadgeIssuerKey -> Maybe (TQueue GroupEvent) -> ServiceState -> IO () +processQueuedRequests key trackerQ_ env = do cc <- atomically $ readTMVar $ serviceCC env forever $ do (u, reqId, sigKey, reqData) <- atomically $ readTQueue $ serviceRequestQ env - handleServiceRequest key cc u reqId sigKey reqData - -processChatRedeems :: BadgeIssuerKey -> ServiceState -> IO () -processChatRedeems key env = do - cc <- atomically $ readTMVar $ serviceCC env - forever $ do - (ct, msg) <- atomically $ readTQueue $ chatRedeemQ env - chatRedeem key cc ct msg - --- | Here the service generates the master key and can link the badge, so [dev] chat_redeem gates this. -chatRedeem :: BadgeIssuerKey -> ChatController -> Contact -> T.Text -> IO () -chatRedeem key cc ct msg = case T.stripPrefix "/redeem" (T.strip msg) of - Just rest | not (T.null (T.strip rest)) -> do - masterKey <- generateMasterKey (random cc) - (purchaseKey, _) <- atomically $ C.generateKeyPair (random cc) :: IO (C.KeyPair 'C.Ed25519) - resp <- redeemCode key cc purchaseKey masterKey (T.strip rest) - sendMessage cc ct $ case resp of - BSPBadgeCredential {credential = Just cred} -> safeDecodeUtf8 $ LB.toStrict $ J.encode cred - BSPError {code} -> "error: " <> textEncode code - _ -> "unexpected response" - _ -> sendMessage cc ct "send: /redeem " + handleServiceRequest key cc trackerQ_ u reqId sigKey reqData badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO () badgePreStartHook opts ChatController {config, chatStore} = runBadgeServiceMigrations opts config chatStore -badgePostStartHook :: BadgeServiceOpts -> Bool -> ServiceState -> ChatController -> IO () -badgePostStartHook BadgeServiceOpts {noAddress, testing} devRedeem env cc = do +badgePostStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () +badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do -- Core starts this False and gates service request delivery on it, so the hook must set it. atomically $ writeTVar (processServiceRequests cc) True readTVarIO (currentUser cc) >>= \case Nothing -> putStrLn "No current user" >> exitFailure Just _ -> do - unless noAddress $ initializeBotAddress' (not testing) (Just True) devRedeem cc + -- The address carries service RPC only, so contact requests are never auto-accepted. + unless noAddress $ initializeBotAddress' (not testing) (Just True) False cc void $ atomically $ tryPutTMVar (serviceCC env) cc -handleServiceRequest :: BadgeIssuerKey -> ChatController -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO () -handleServiceRequest key cc User {userId} reqId sigKey reqData = do +handleServiceRequest :: BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO () +handleServiceRequest key cc trackerQ_ User {userId} reqId sigKey reqData = do let reqIdT = safeDecodeUtf8 (strEncode reqId) logInfo $ "badge service request " <> reqIdT - resp <- badgeServiceResponse key cc sigKey reqData + resp <- badgeServiceResponse key cc trackerQ_ sigKey reqData sendChatCmd cc (APISendServiceResponse userId reqId (responseObject resp)) >>= \case Right _ -> pure () Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e @@ -334,15 +289,15 @@ badgeErrorRetryAfter = \case -- | The agent verified the signature, so sigKey is a key the sender holds; a differing purchaseKey would let a client claim a purchase it cannot sign for. -badgeServiceResponse :: BadgeIssuerKey -> ChatController -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse -badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData) of +badgeServiceResponse :: BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse +badgeServiceResponse key cc trackerQ_ sigKey reqData = case J.fromJSON (J.Object reqData) of J.Error _ -> pure $ errorResponse BSEBadRequest J.Success BadgeServiceRequest {version, purchaseKey, request} | not (version `isCompatible` supportedBadgeServiceVRange) -> pure $ errorResponse BSEUnsupportedVersion | purchaseKey /= sigKey -> pure $ errorResponse BSEBadRequest | otherwise -> case request of BSCRedeemBadgeCode {masterKey, code} -> case purchaseKey of - Just k -> redeemCode key cc k masterKey code + Just k -> redeemCode key cc trackerQ_ k masterKey code Nothing -> pure $ errorResponse BSEBadRequest BSCIssueBadge {balance} -> case purchaseKey of Just k -> issueBadgeCmd key cc k balance @@ -376,15 +331,15 @@ credentialResponse credential previousEntryId entries = BSPBadgeCredential {credential, receipt = Nothing, statement = BadgeStatement {entries, previousEntryId}} -- | Nothing is written until the credential is signed, so a signing failure leaves the code unspent. -redeemCode :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> T.Text -> IO BadgeServiceResponse -redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText of +redeemCode :: BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> C.PublicKeyEd25519 -> BadgeMasterKey -> T.Text -> IO BadgeServiceResponse +redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode codeText of Nothing -> pure $ errorResponse BSECodeInvalid Just code -> do now <- badgeNow cc withDB "getBadgeCode" cc (readCode now code) >>= \case Left _ -> pure $ errorResponse BSEInternal Right (Left resp) -> pure resp - Right (Right IssuedCode {badgeCodeId, badgeType, months}) -> do + Right (Right IssuedCode {badgeCodeId, badgeType, months, redeemLimit}) -> do (grantUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc -- TODO [badges] a top-up grants onto an existing ledger, and must lapse before it or the -- months it adds are counted from a start already in the past @@ -395,41 +350,42 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText Just issued -> credentialForEntry key masterKey issued >>= \case Left e -> logError ("badge service signing failed: " <> T.pack e) $> errorResponse BSEInternal Right signed -> do - -- If the code was revoked or redeemed while signing, the claim fails. Read the code again to tell the client why. + -- If the code was revoked or used up while signing, the claim fails. Read the code again to tell the client why. r <- withDB "writeCodeRedemption" cc $ \db -> liftIO (createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now) >>= \case Nothing -> readCode now code db >>= \case - Left resp -> pure resp - Right _ -> logError "badge service: redeeming a code failed, but the code is neither redeemed nor revoked" $> errorResponse BSEInternal + Left resp -> pure (resp, False) + Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> (errorResponse BSEInternal, False) Just purchaseId -> liftIO $ do appendLedgerPlan db purchaseId [granted] $ Just $ issuanceAfter granted signed entries_ <- getLedgerEntries db purchaseId 0 - pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_ - pure $ fromRight (errorResponse BSEInternal) r + pure (maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_, True) + let (resp, claimed) = fromRight (errorResponse BSEInternal, False) r + when (claimed && hasTracker redeemLimit) $ refreshTracker cc trackerQ_ badgeCodeId code + pure resp where readCode now code db = liftIO $ getBadgeCode db (badgeCodeHash code) >>= \case Nothing -> pure $ Left $ errorResponse BSECodeInvalid - Just c@IssuedCode {revokedAt, paymentStatus, expiresAt, redemption} - -- Revoked is checked first, so it answers as if the code never existed. - | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid - -- Redeeming an unpaid code would issue a free badge, so unpaid is refused. - | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending - | otherwise -> - checkUnspent db redemption >>= \case - Left resp -> pure $ Left resp - Right () - | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired - | otherwise -> pure $ Right c - checkUnspent db = \case - CodeUnredeemed -> pure $ Right () - CodeRedeemedUnreadable -> pure $ Left $ errorResponse BSEInternal - CodeRedeemed RedeemedCode {purchaseKey = k, badgePurchaseId, credential} - | k /= purchaseKey -> pure $ Left $ errorResponse BSECodeUsed - | otherwise -> - maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) - <$> getLedgerEntries db badgePurchaseId 0 + Just c@IssuedCode {badgeCodeId, revokedAt, paymentStatus, expiresAt, redeemLimit, redeemCount} -> + getCodePurchaseForKey db badgeCodeId purchaseKey >>= \case + -- A key that already redeemed gets its credential back without a use, even if the code has since + -- expired or been revoked: a client whose reply was lost retries, and would otherwise lose the badge. + KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> + maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) + <$> getLedgerEntries db badgePurchaseId 0 + -- code_used would make the client drop its keys, so the holder could never get the badge back. + KeyRedeemedUnreadable -> + logError "badge service: a redeemed code's credential is missing or unreadable" $> Left (errorResponse BSEInternal) + KeyUnredeemed + -- Revoked is checked first, so it answers as if the code never existed. + | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid + -- Redeeming an unpaid code would issue a free badge, so unpaid is refused. + | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending + | redeemCount >= redeemLimit -> pure $ Left $ errorResponse BSECodeUsed + | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired + | otherwise -> pure $ Right c -- | The purchase is reached through the verified signer key and no other way. issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index d8ab44c268..b51e47bdad 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -7,11 +7,17 @@ module BadgeService.Store ( IssuedCode (..), - CodeRedemption (..), - RedeemedCode (..), + KeyRedemption (..), + KeyPurchase (..), NewCodePurchase (..), ServicePurchase (..), + ManagedGroup (..), + getManagedGroup, + insertManagedGroup, + clearCodeGroupItems, + markOwnerBootstrapped, getBadgeCode, + getCodePurchaseForKey, purchaseKeyExists, getPurchaseByKey, getLedgerTip, @@ -21,6 +27,10 @@ module BadgeService.Store appendLedgerPlan, createCodePurchase, insertBadgeCode, + setCodeGroupItem, + CodeTracker (..), + getCodeTracker, + getEditableTrackers, RevokeResult (..), revokeCode, ) @@ -31,6 +41,7 @@ import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) +import Data.Maybe (isJust) import Data.Text (Text) import Data.Time.Clock (UTCTime) import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType) @@ -38,7 +49,7 @@ import Simplex.Chat.Badges.Ledger import Simplex.Chat.Badges.Service (StatementEntry (..)) import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus, BadgePurchaseStatus (..)) import Simplex.Chat.Store.Shared (insertedRowId) -import Simplex.Messaging.Agent.Store.DB (Binary (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow') @@ -58,17 +69,17 @@ data IssuedCode = IssuedCode paymentStatus :: BadgeCodePaymentStatus, revokedAt :: Maybe UTCTime, expiresAt :: Maybe UTCTime, - redemption :: CodeRedemption + redeemLimit :: Int, + redeemCount :: Int } -data CodeRedemption - = CodeUnredeemed - | CodeRedeemed RedeemedCode - | CodeRedeemedUnreadable +data KeyRedemption + = KeyUnredeemed + | KeyRedeemed KeyPurchase + | KeyRedeemedUnreadable -data RedeemedCode = RedeemedCode +data KeyPurchase = KeyPurchase { badgePurchaseId :: Int64, - purchaseKey :: C.PublicKeyEd25519, credential :: BadgeCredential } @@ -85,30 +96,81 @@ data ServicePurchase = ServicePurchase badgeType :: BadgeType } +data ManagedGroup = ManagedGroup + { mgGroupId :: Int64, + mgGroupLink :: Text, + mgOwnerBootstrapped :: Bool + } + deriving (Eq) + +-- The join link is a bearer secret, so it is left out. +instance Show ManagedGroup where + show ManagedGroup {mgGroupId, mgOwnerBootstrapped} = "managed group " <> show mgGroupId <> ", owner set up: " <> show mgOwnerBootstrapped + +getManagedGroup :: DB.Connection -> IO (Maybe ManagedGroup) +getManagedGroup db = + maybeFirstRow toGroup $ + DB.query_ db "SELECT group_id, group_link, owner_bootstrapped FROM sx_badge_service_group LIMIT 1" + where + toGroup (mgGroupId, mgGroupLink, BI mgOwnerBootstrapped) = ManagedGroup {mgGroupId, mgGroupLink, mgOwnerBootstrapped} + +-- getManagedGroup reads with no ordering, so a second row would change which group is used. +insertManagedGroup :: DB.Connection -> Int64 -> Text -> UTCTime -> IO () +insertManagedGroup db gid link now = + DB.execute + db + [sql| + INSERT INTO sx_badge_service_group (group_id, group_link, owner_bootstrapped, created_at) + SELECT ?,?,0,? WHERE NOT EXISTS (SELECT 1 FROM sx_badge_service_group) + |] + (gid, link, now) + +-- A tracker's item id is only found in the group it was posted to, so a new group starts with none. +clearCodeGroupItems :: DB.Connection -> IO () +clearCodeGroupItems db = + DB.execute_ db "UPDATE sx_badge_service_badge_codes SET group_item_id = NULL, group_item_sent_at = NULL WHERE group_item_id IS NOT NULL" + +markOwnerBootstrapped :: DB.Connection -> Int64 -> IO Bool +markOwnerBootstrapped db gid = + (> 0) + <$> executeChanging + db + "UPDATE sx_badge_service_group SET owner_bootstrapped = 1 WHERE group_id = ? AND owner_bootstrapped = 0" + (Only gid) + getBadgeCode :: DB.Connection -> ByteString -> IO (Maybe IssuedCode) getBadgeCode db codeHash = maybeFirstRow toCode $ DB.query db [sql| - SELECT c.badge_code_id, c.badge_type, c.months, c.code_payment_status, c.revoked_at, - c.expires_at, p.badge_purchase_id, p.purchase_key, i.credential - FROM sx_badge_service_badge_codes c - LEFT JOIN sx_badge_service_badge_purchases p ON p.badge_code_id = c.badge_code_id - LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id - WHERE c.code_hash = ? - ORDER BY i.period_end DESC - LIMIT 1 + SELECT badge_code_id, badge_type, months, code_payment_status, revoked_at, expires_at, redeem_limit, redeem_count + FROM sx_badge_service_badge_codes + WHERE code_hash = ? |] (Only (Binary codeHash)) where - toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, purchaseId_, purchaseKey_, credential_) = - IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redemption = codeRedemption purchaseId_ purchaseKey_ credential_} - codeRedemption purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of - (Just badgePurchaseId, Just purchaseKey) -> case decodeCredential =<< credential_ of - Just credential -> CodeRedeemed RedeemedCode {badgePurchaseId, purchaseKey, credential} - Nothing -> CodeRedeemedUnreadable - _ -> CodeUnredeemed + toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redeemLimit, redeemCount) = + IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redeemLimit, redeemCount} + +getCodePurchaseForKey :: DB.Connection -> Int64 -> C.PublicKeyEd25519 -> IO KeyRedemption +getCodePurchaseForKey db badgeCodeId key = + maybeFirstRow' KeyUnredeemed toRedemption $ + DB.query + db + [sql| + SELECT p.badge_purchase_id, i.credential + FROM sx_badge_service_badge_purchases p + LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id + WHERE p.badge_code_id = ? AND p.purchase_key = ? + ORDER BY i.period_end DESC + LIMIT 1 + |] + (badgeCodeId, key) + where + toRedemption (badgePurchaseId, credential_) = case decodeCredential =<< credential_ of + Just credential -> KeyRedeemed KeyPurchase {badgePurchaseId, credential} + Nothing -> KeyRedeemedUnreadable decodeCredential (Binary bs) = J.decodeStrict' bs purchaseKeyExists :: DB.Connection -> C.PublicKeyEd25519 -> IO Bool @@ -222,15 +284,14 @@ appendLedgerPlan db purchaseId rows issuance_ = do ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType)) insertedRowId db --- redeemed_at is stamped here, so this must run in the same transaction as the credential rows. --- Mark the code as redeemed before adding the purchase. On Postgres, a revoke or redemption running --- at the same time then waits, sees the code is taken, and fails. +-- The claim takes one use before adding the purchase, so a concurrent revoke or redemption waits on this row and sees the new count. +-- Run it in the credential's transaction. createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO (Maybe Int64) createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do claimed <- executeChanging db - "UPDATE sx_badge_service_badge_codes SET redeemed_at = ? WHERE badge_code_id = ? AND redeemed_at IS NULL AND revoked_at IS NULL" + "UPDATE sx_badge_service_badge_codes SET redeem_count = redeem_count + 1, redeemed_at = ? WHERE badge_code_id = ? AND redeem_count < redeem_limit AND revoked_at IS NULL" (now, badgeCodeId) if claimed == 0 then pure Nothing @@ -245,32 +306,79 @@ createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = Bad (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now) Just <$> insertedRowId db -data RevokeResult = Revoked | AlreadyRevoked | AlreadyRedeemed | NoSuchCode +-- | Revoked and AlreadyRevoked carry the code id, so the caller can retire the code's group tracker, +-- or repair one an earlier revoke left live. +data RevokeResult = Revoked Int64 | AlreadyRevoked Int64 | AlreadyRedeemed | NoSuchCode deriving (Eq, Show) --- | A code that was already redeemed can't be revoked, because its badge was already given out. +-- | A code with no uses left can't be revoked, because every badge it grants was already given out. revokeCode :: DB.Connection -> ByteString -> UTCTime -> IO RevokeResult revokeCode db codeHash now = do revoked <- executeChanging db - "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeemed_at IS NULL" + "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeem_count < redeem_limit" (now, Binary codeHash) - if revoked > 0 - then pure Revoked - else - maybeFirstRow' NoSuchCode refusal $ - DB.query db "SELECT revoked_at FROM sx_badge_service_badge_codes WHERE code_hash = ?" (Only (Binary codeHash)) + -- The result is read in the same transaction as the UPDATE, so the row it answers about is the row that changed. + maybeFirstRow' NoSuchCode (result revoked) $ + DB.query db "SELECT badge_code_id, revoked_at FROM sx_badge_service_badge_codes WHERE code_hash = ?" (Only (Binary codeHash)) where - refusal :: Only (Maybe UTCTime) -> RevokeResult - refusal (Only revokedAt) = maybe AlreadyRedeemed (const AlreadyRevoked) revokedAt + result :: Int -> (Int64, Maybe UTCTime) -> RevokeResult + result revoked (badgeCodeId, revokedAt) + | revoked > 0 = Revoked badgeCodeId + | isJust revokedAt = AlreadyRevoked badgeCodeId + | otherwise = AlreadyRedeemed -insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> UTCTime -> IO () -insertBadgeCode db codeHash badgeType months paymentStatus now = +insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64 +insertBadgeCode db codeHash badgeType months paymentStatus redeemLimit now = do DB.execute db [sql| - INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) - VALUES (?,?,?,?,?) + INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, redeem_limit, created_at) + VALUES (?,?,?,?,?,?) |] - (Binary codeHash, badgeType, months, paymentStatus, now) + (Binary codeHash, badgeType, months, paymentStatus, redeemLimit, now) + insertedRowId db + +setCodeGroupItem :: DB.Connection -> Int64 -> Int64 -> UTCTime -> IO () +setCodeGroupItem db badgeCodeId itemId sentAt = + DB.execute + db + "UPDATE sx_badge_service_badge_codes SET group_item_id = ?, group_item_sent_at = ? WHERE badge_code_id = ?" + (itemId, sentAt, badgeCodeId) + +data CodeTracker = CodeTracker + { trackerItemId :: Int64, + trackerSentAt :: UTCTime, + redeemLimit :: Int, + redeemCount :: Int, + revokedAt :: Maybe UTCTime, + redeemedAt :: Maybe UTCTime + } + +getCodeTracker :: DB.Connection -> Int64 -> IO (Maybe CodeTracker) +getCodeTracker db badgeCodeId = + maybeFirstRow toTracker $ + DB.query + db + [sql| + SELECT group_item_id, group_item_sent_at, redeem_limit, redeem_count, revoked_at, redeemed_at + FROM sx_badge_service_badge_codes + WHERE badge_code_id = ? AND group_item_id IS NOT NULL AND group_item_sent_at IS NOT NULL + |] + (Only badgeCodeId) + where + toTracker (trackerItemId, trackerSentAt, redeemLimit, redeemCount, revokedAt, redeemedAt) = + CodeTracker {trackerItemId, trackerSentAt, redeemLimit, redeemCount, revokedAt, redeemedAt} + +getEditableTrackers :: DB.Connection -> UTCTime -> IO [(Int64, Int64)] +getEditableTrackers db sentAfter = + DB.query + db + [sql| + SELECT badge_code_id, group_item_id + FROM sx_badge_service_badge_codes + WHERE group_item_id IS NOT NULL AND group_item_sent_at > ? + ORDER BY badge_code_id + |] + (Only sentAfter) 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 c8179d5df2..f096d3098d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs @@ -17,7 +17,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = - [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema) + [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), + ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -109,6 +110,48 @@ DROP INDEX @idx_badge_purchases_code; DROP TABLE @badge_codes; |] +m20260918_badge_group_ops :: Text +m20260918_badge_group_ops = + withPrefix + servicePrefix + [r| +CREATE TABLE @group( + group_id BIGINT NOT NULL PRIMARY KEY, + group_link TEXT NOT NULL, + owner_bootstrapped SMALLINT NOT NULL DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL +); + +ALTER TABLE @badge_codes ADD COLUMN redeem_limit INTEGER NOT NULL DEFAULT 1; + +ALTER TABLE @badge_codes ADD COLUMN redeem_count INTEGER NOT NULL DEFAULT 0; + +ALTER TABLE @badge_codes ADD COLUMN group_item_id BIGINT; + +ALTER TABLE @badge_codes ADD COLUMN group_item_sent_at TIMESTAMPTZ; + +-- Redemptions made before this migration must count against the new limit, or every code +-- redeemed already would read as unspent and could be redeemed once more. +UPDATE @badge_codes SET redeem_count = 1 WHERE redeemed_at IS NOT NULL; + +DROP INDEX @idx_badge_purchases_code; + +CREATE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id); +|] + +-- The index stays non-unique, since a multi-use code may already have several purchases. +down_m20260918_badge_group_ops :: Text +down_m20260918_badge_group_ops = + withPrefix + servicePrefix + [r| +ALTER TABLE @badge_codes DROP COLUMN group_item_sent_at; +ALTER TABLE @badge_codes DROP COLUMN group_item_id; +ALTER TABLE @badge_codes DROP COLUMN redeem_count; +ALTER TABLE @badge_codes DROP COLUMN redeem_limit; +DROP TABLE @group; +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA; 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 bf022f189c..cd89859686 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs @@ -18,7 +18,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations = - [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema) + [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), + ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -110,6 +111,48 @@ DROP INDEX @idx_badge_purchases_code; DROP TABLE @badge_codes; |] +m20260918_badge_group_ops :: Query +m20260918_badge_group_ops = + withPrefix + servicePrefix + [sql| +CREATE TABLE @group( + group_id INTEGER NOT NULL PRIMARY KEY, + group_link TEXT NOT NULL, + owner_bootstrapped INTEGER NOT NULL DEFAULT 0, + created_at TEXT NOT NULL +) STRICT; + +ALTER TABLE @badge_codes ADD COLUMN redeem_limit INTEGER NOT NULL DEFAULT 1; + +ALTER TABLE @badge_codes ADD COLUMN redeem_count INTEGER NOT NULL DEFAULT 0; + +ALTER TABLE @badge_codes ADD COLUMN group_item_id INTEGER; + +ALTER TABLE @badge_codes ADD COLUMN group_item_sent_at TEXT; + +-- Redemptions made before this migration must count against the new limit, or every code +-- redeemed already would read as unspent and could be redeemed once more. +UPDATE @badge_codes SET redeem_count = 1 WHERE redeemed_at IS NOT NULL; + +DROP INDEX @idx_badge_purchases_code; + +CREATE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id); +|] + +-- The index stays non-unique, since a multi-use code may already have several purchases. +down_m20260918_badge_group_ops :: Query +down_m20260918_badge_group_ops = + withPrefix + servicePrefix + [sql| +ALTER TABLE @badge_codes DROP COLUMN group_item_sent_at; +ALTER TABLE @badge_codes DROP COLUMN group_item_id; +ALTER TABLE @badge_codes DROP COLUMN redeem_count; +ALTER TABLE @badge_codes DROP COLUMN redeem_limit; +DROP TABLE @group; +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BLOB; diff --git a/docs/protocol/badges-overview.md b/docs/protocol/badges-overview.md index 41ed3c5eaa..255f3cd88f 100644 --- a/docs/protocol/badges-overview.md +++ b/docs/protocol/badges-overview.md @@ -92,7 +92,7 @@ In SimpleX: - A badge does not restrict anything that is available today: the defaults are unchanged, and a badge only raises them. - A badge does not create an identity: it has no persistent identifier, it is not linked across conversations, and an incognito profile does not show it. -- A badge cannot be transferred: a code can be redeemed once, and the credential obtained with it is usable only with the master key it was issued for. +- A badge cannot be transferred: a code can be redeemed once for each use it was issued with (usually one), and the credential obtained with it is usable only with the master key it was issued for. - A badge does not exempt its holder from the limits a server applies: it lowers the cost of a resource without removing the limit on it. - A badge cannot be revoked; credentials are issued for one month at a time instead. @@ -139,11 +139,11 @@ A purchase is identified by an Ed25519 key pair that the app generates for it an A badge is bought for one or more months, either on the web or in the app. -On the web the purchase produces a code, which is then redeemed in the app. The code is the only data passed from the web site to the app: the web site does not learn which app redeems a code, and the app does not see the payment. The code is generated in the buyer's browser, and the service stores only its hash; at redemption the app presents the code itself, and the service matches it against the stored hash. A badge issued without a sale, for example in compensation for a problem, is a code generated by the operator and redeemed in the same way. +On the web the purchase produces a code, which is then redeemed in the app. The code is the only data passed from the web site to the app: the web site does not learn which app redeems a code, and the app does not see the payment. The code is generated in the buyer's browser, and the service stores only its hash; at redemption the app presents the code itself, and the service matches it against the stored hash. A badge issued without a sale, for example in compensation for a problem, is a code generated by the operator, or by a moderator of the service's managed group, and redeemed in the same way. In the app, the user pays by card, in cryptocurrency, or through the app store. The app requests an invoice from the service, or presents the receipt of the app store, and the service issues the credential once the payment is confirmed. -In both cases the app generates the master key and the purchase key pair before the purchase. To redeem a code, the app sends the code and the master key to the service, which issues the credential. A code redeemed a second time with the same purchase key returns the same credential; a code redeemed with a different purchase key is refused. +In both cases the app generates the master key and the purchase key pair before the purchase. To redeem a code, the app sends the code and the master key to the service, which issues the credential. A code redeemed a second time with the same purchase key returns its latest credential; a code redeemed with a different purchase key is refused once all its uses are taken. ### Monthly issuance @@ -203,7 +203,7 @@ Service requests are protected by the double ratchet of the [SimpleX agent](http 1. A proof discloses no value that links it to another proof or to the purchase. 2. A proof used in one context, whether a session, a conversation or a file, cannot be used in another context. 3. The timing of presentations does not identify the holder: all credentials expiring in the same week share the same expiry, and the renewal request and the profile update are made on different days. -4. Requests to the badge service cannot be linked to each other, to a profile or to a network address, and a request about a purchase can be made only by the holder of the purchase key. +4. Requests to the badge service cannot be linked to each other, to a profile or to a network address, other than the redemptions of one multi-use code and the codes issued in the service's managed group or redeemed by its members, and a request about a purchase can be made only by the holder of the purchase key. 5. A credential cannot be forged: the issuer keys are fixed in apps and servers, and the app verifies a credential before storing it. 6. A missing or failed proof leaves the default limit in place, and a server cannot be configured to grant a badge type less than the default. @@ -217,10 +217,12 @@ This threat model assumes the [SimpleX network threat model](https://github.com/ - See the purchase key of every badge, the master key generated for it, the number of months bought, and the payment record. - Issue any credential, or refuse to issue one, as it holds the issuer key. +- Link a code issued in its managed group to the member who asked for it and to that group, as the group's messages, codes included, are kept in the service's chat database. +- Link a redemption to a member of its managed group whose profile shows a new badge soon after it. *cannot:* -- Connect a purchase with a profile, a contact, a group or a session with a server - a proof contains nothing that refers back to the purchase. +- Connect a purchase with a profile, a contact, a group or a session with a server, other than a code issued in its managed group or redeemed by one of its members, as above - a proof contains nothing that refers back to the purchase. - Learn where a badge is shown or used. - Learn the network address of the app - requests reach the service through SMP servers, on connections created for the request. @@ -236,6 +238,20 @@ This threat model assumes the [SimpleX network threat model](https://github.com/ - Reuse a profile proof or a file proof in another context. - Distinguish the holder from the other supporters whose badges expire in the same week. +**A member of the badge service's managed group** + +*can:* + +- Redeem any code issued in the group that is not revoked and has uses left, as every code is posted to the group. +- See when each use of a multi-use code was redeemed. +- Issue free codes of any type as a moderator or above, and revoke any code whose text they hold as an admin or above. +- Become the group's owner by being the first to join it, before an owner is set up. +- Guess who redeemed a code, when a member's profile shows a new badge soon after the code's message changes. + +*cannot:* + +- Redeem a revoked code, or a code with no uses left. + **A server operator** *can:* @@ -271,7 +287,7 @@ An attacker who obtains the credential and the purchase key can use the badge un **Interception of a code** -A code is a bearer secret until it is redeemed; once redeemed, it is refused to any other purchase key. +A code is a bearer secret until its last use is taken; after that, it is refused to any other purchase key. **A passive network observer** diff --git a/docs/protocol/badges-rpc.md b/docs/protocol/badges-rpc.md index 8ea70e1d19..8c43ca6b28 100644 --- a/docs/protocol/badges-rpc.md +++ b/docs/protocol/badges-rpc.md @@ -19,7 +19,7 @@ A purchase record is created by `redeemBadgeCode`, by `getBadgeInvoice`, or by ` A timeout hides the outcome, so the client repeats the identical signed request at its next trigger, never on a poll timer. - `getBadgeInvoice` — returns the open invoice again; a new invoice is created only when none is open. -- `redeemBadgeCode` — a code already redeemed by the signing key returns the same `badgeCredential` and writes nothing; redeemed by another key, `code_used`. The client must therefore keep the key it first signed with, or a retry cannot be recognised. +- `redeemBadgeCode` — a code already redeemed by the signing key returns its latest `badgeCredential` and writes nothing; once other keys have taken all its uses, `code_used`. The client must therefore keep the key it first signed with, or a retry cannot be recognised. - `purchaseBadge` — a payment already credited returns the same `badgeCredential` and writes nothing. - `upgradeBadgeSubscription` — evidence already applied returns the same result and writes nothing. - `issueBadge` — repeated within an issued period, returns the cached credential and writes nothing. @@ -31,7 +31,7 @@ A timeout hides the outcome, so the client repeats the identical signed request - `getBadgeCatalog` → `badgeCatalog` — the prices and offers; signed, also the purchase's `badgeStatement`. Store builds never send it: prices come from the store and SKUs from app config. - `getBadgeInvoice` → `badgeInvoice` — prices the purchase for `badgeInfo` and `paymentVia` (`card` — Stripe; `crypto` — btc, xmr). The response holds the generic `invoice` — `invoiceId`, `price`, `discount`, the upgrade `credit`, `amount` = price − discount − credit, `currency`, `expiresAt`, and `paymentTo` (`url` for card; `address` and `cryptoAmount` for crypto) — beside the badge part, `badgeType` and `months`. `priceId` pins the price the client displayed; `offerId` selects a discounted duration, and its absence buys one month at that price. Price and offer status is checked here only: `deprecated` is still accepted, `disabled` is rejected; a badge type with no active price yields `product_unavailable`. -- `redeemBadgeCode` → `badgeCredential` — redeems a code, records the credit, and issues the first credential, in one round trip. It carries `masterKey` and `code` and no `badgeRequest`: a code states no tier and no expiry, so the credential is what reports them. Errors: `code_invalid` for an unknown or malformed code, `code_used` when another key redeemed it, `code_expired` past a redemption deadline. +- `redeemBadgeCode` → `badgeCredential` — redeems a code, records the credit, and issues the first credential, in one round trip. It carries `masterKey` and `code` and no `badgeRequest`: a code states no tier and no expiry, so the credential is what reports them. Errors: `code_invalid` for an unknown or malformed code, `code_used` when other keys have taken all its uses (a code has one use unless issued with more), `code_expired` past a redemption deadline. - `purchaseBadge` → `badgeCredential` — verifies the funding (`apple` JWS offline; `google` token via the Publisher API; `invoice` against webhook-confirmed settlement, `payment_pending` until it lands; `receipt`), records the credit, and issues the first credential, in one round trip. The response `receipt` is the recovery bearer secret (model § recovery); the service stores its hash; lifetime badges receive none. - Funding by `receipt` is a transfer (post-MVP): the unissued months of the purchase that receipt belongs to move to the signing key, recorded as `debit(transferOut)` on the source and `credit(transferIn)` on the new purchase, and the presented receipt is retired for a fresh one. The transferred period's issuance debits a month like any other. Lifetime badges hold no receipt, so support handles them. - `upgradeBadgeSubscription` → `badgeCredential` — the app-led store subscription change, on the same key: verifies the store evidence of the replaced subscription and records the new plan; an immediate upgrade returns the new credential, a deferred change returns none. @@ -63,4 +63,4 @@ An assertion that names an entry the service holds is a prefix: the service proc ## Errors -`retryAfter` marks the transient codes: `payment_pending`, `provider_unavailable`, `rate_limited`. `offer_disabled` calls for a catalog refresh. `code_invalid` covers unknown, malformed and revoked codes alike, so a guesser learns nothing from the difference; `code_used` — redeemed under another key; `code_expired` — past its redemption deadline. `receipt_invalid` covers unknown receipts. All other codes are terminal for the attempted command. +`retryAfter` marks the transient codes: `payment_pending`, `provider_unavailable`, `rate_limited`. `offer_disabled` calls for a catalog refresh. `code_invalid` covers unknown, malformed and revoked codes alike, so a guesser learns nothing from the difference; `code_used` — all its uses taken by other keys; `code_expired` — past its redemption deadline. `receipt_invalid` covers unknown receipts. All other codes are terminal for the attempted command. 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 38e02cfd18..ddecfced48 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -429,7 +429,10 @@ executable simplex-badge-service StrictData other-modules: BadgeService.Catalog + BadgeService.Codes BadgeService.Config + BadgeService.Group + BadgeService.Group.Command BadgeService.Log BadgeService.Options BadgeService.Orders @@ -717,7 +720,10 @@ test-suite simplex-chat-test API.Docs.Types API.TypeInfo BadgeService.Catalog + BadgeService.Codes BadgeService.Config + BadgeService.Group + BadgeService.Group.Command BadgeService.Log BadgeService.Options BadgeService.Orders @@ -737,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/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 433e2605fd..ccf6f15bdb 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -13,12 +13,15 @@ module Simplex.Chat.Core ) where +import Control.Concurrent (forkIO) +import Control.Exception (mask, onException, throwTo) import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.Reader import qualified Data.ByteString.Char8 as B import Data.List (find) +import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -94,8 +97,12 @@ runSimplexChat ChatConfig {testView} ChatOpts {coreOptions = CoreChatOpts {chatR a1 <- runReaderT (startChatController True True False) cc when (chatRelay && not testView) $ askCreateRelayAddress cc u chatRelayServer headless forM_ (postStartHook chatHooks) ($ cc) - a2 <- async $ chat u cc - waitEither_ a1 a2 + -- throwTo waits while the callback is masked, so an outside interrupt cancels it from a forked thread. + -- A /_stop sent from the callback ends a1 first, which leaves the callback running. + mask $ \restore -> do + a2 <- asyncWithUnmask $ \unmask -> unmask (chat u cc) + let cancelCallback = poll a1 >>= \r -> when (isNothing r) $ void $ forkIO $ throwTo (asyncThreadId a2) AsyncCancelled + restore (waitEither_ a1 a2) `onException` cancelCallback sendChatCmdStr :: ChatController -> String -> IO (Either ChatError ChatResponse) sendChatCmdStr cc s = runReaderT (execChatCommand CSLocal (encodeUtf8 $ T.pack s) 0) cc diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index c11af7f4d1..2f2dade67d 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -10,10 +10,13 @@ module Bots.BadgeService.BotTests where +import BadgeService.Codes (issueOneCode) import BadgeService.Config (BadgeIssuerKey (..), readServiceConfig) +import BadgeService.Group (GroupEvent) import Bots.BadgeService.ConfigTests (withIssuer) import BadgeService.Options import BadgeService.Service +import BadgeService.Store (IssuedCode (..), getBadgeCode) import BadgeService.Store.Invoices (markCodePaid) import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -21,7 +24,7 @@ import ChatClient import ChatTests.DBUtils import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) -import Control.Concurrent.STM (atomically, readTMVar) +import Control.Concurrent.STM (TQueue, atomically, readTMVar) import Control.Monad (forM_, void, when) import Control.Exception (finally) import qualified Data.Aeson as J @@ -43,14 +46,15 @@ import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode) import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, endOfMondayAfter) import Simplex.Chat.Badges.Service +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) import Simplex.Chat.Bot.Store (withDB') -import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (CRCustomChatResponse)) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError (..), ChatErrorType (..), ChatResponse (CRCustomChatResponse)) import Simplex.Chat.Core (sendChatCmdStr) import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) -import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) import Simplex.Messaging.Agent.Store.DB (BoolInt (..)) import Simplex.Chat.Types (ChatPeerType (..), Profile (..)) import qualified Simplex.Messaging.Crypto as C @@ -76,20 +80,27 @@ badgeServiceTests = do it "should refuse a code that has not been paid for" testRedeemUnpaidCode it "should refuse a badge code past its redemption deadline" testExpiredCode it "should keep answering a code redeemed before its deadline" testRedeemedBeforeTheDeadline - it "should refuse a revoked badge code, and refuse to revoke it twice" testRevokedCode + it "should refuse a revoked badge code, and report a second revoke as already revoked" testRevokedCode it "should refuse to revoke a code that was redeemed, and keep its badge" testRevokeRedeemedCode it "should answer revoking an unknown code as no such code" testRevokeUnknownCode + it "should answer code_invalid to a code that is both unpaid and revoked" testRevokedUnpaidCode + it "should refuse a revoke with trailing input, leaving the code live" testRevokeRejectsTrailingInput it "should refuse to issue a code with an unknown badge type or a nonsense month count" testIssueRejectsBadArguments it "should refuse a request whose purchaseKey is not the verified signer" testPurchaseKeyMismatch it "should refuse to start unless the issuer secret is the key trusted at its index" testIssuerKeyMustMatchConfig it "should refuse to start when the [issuer] key is not one clients trust" testIssuerIniKeyMustBeTrusted it "should credit a code's months and issue one credential per month" testCodeMonthsRenew it "should return the stored credential for a repeat inside an issued period" testRepeatInsideIssuedPeriod + it "should redeem a multi-use code to its limit with no group to track it" testMultiUseWithoutGroup + it "should not spend a multi-use code again when its holder redeems it after the badge ended" testMultiUseRepeatAfterExpiry + it "should answer internal, spending no use, when a holder's stored credential is unreadable" testUnreadableCredentialIsInternal it "should lapse only the months that elapsed while the client was away" testLapseWhileAway it "should round the last month's expiry up to the end of the Monday after it" testLastMonthExpiryRounds it "should sign a renewal with the master key stored on the purchase" testRenewalSignsWithStoredMasterKey it "should leave the client holding the same ledger rows as the service" testClientReplicatesLedger it "should renew a badge whose credential is lapsing, with no command" testWorkerRenews + it "should keep answering and renewing a holder after its partly used multi-use code is revoked" testRevokedMultiUseHolderRenews + it "should return a multi-use holder's renewed credential on a repeat, apart from a later holder" testMultiUseHoldersRenewApart it "should request from the wake it set a day before the credential lapses" testRequestWakeFires it "should present from the wake it set at the credential's expiry" testPresentWakeFires it "should renew a badge whose newest ledger row is of an unknown type" testRenewsAfterUnknownEntry @@ -107,8 +118,11 @@ badgeServiceTests = do it "should broadcast the current profile when a renewal presents a badge" testRenewalKeepsProfileEdits it "should present the month already issued when a previous pass did not" testPresentationCatchesUp +badgeBotName :: Text +badgeBotName = "SimpleX Badges" + badgeProfile :: Profile -badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} +badgeProfile = Profile {displayName = badgeBotName, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} serviceDbPrefix :: FilePath serviceDbPrefix = "badge_service" @@ -129,7 +143,7 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey = {dbFilePrefix = ps serviceDbPrefix} #endif }, - serviceName = "SimpleX Badges", + serviceName = badgeBotName, clientService = True, noAddress = False, runCLI = False, @@ -180,7 +194,9 @@ withBadgeServiceEnv ps test = do bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do bs <## "subscribed 1 connections on server localhost" bs ##> "/sa" - (sLink, _) <- getContactLinks bs False + -- getContactLinks gives the old-clients line only half a second, which a loaded run can miss. + sLink <- getContactLink_ bs False + bs <##. "The contact link for old clients: " bs <## "auto_accept off" pure sLink let clientCfg = @@ -192,17 +208,21 @@ withBadgeServiceEnv ps test = do issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode issueCode cc badgeType months = issueCodeAs cc badgeType months "free" -revokeCodeAs :: HasCallStack => ChatController -> BadgeCode -> IO T.Text -revokeCodeAs cc code = - sendChatCmdStr cc ("//revoke " <> T.unpack (formatBadgeCode code)) >>= \case - Right (CRCustomChatResponse _ response) -> pure response - Left e -> pure (T.pack (show e)) +revokeCodeAs :: HasCallStack => ChatController -> BadgeCode -> IO (Either T.Text T.Text) +revokeCodeAs cc code = revokeRaw cc (formatBadgeCode code) + +-- | Left is a refusal or a failure the service answers as a command error. +revokeRaw :: HasCallStack => ChatController -> T.Text -> IO (Either T.Text T.Text) +revokeRaw cc args = + sendChatCmdStr cc ("//revoke " <> T.unpack args) >>= \case + Right (CRCustomChatResponse _ response) -> pure (Right response) + Left (ChatError (CECommandError e)) -> pure (Left (T.pack e)) r -> error $ "revoke failed: " <> show (() <$ r) issueCodeAs :: HasCallStack => ChatController -> BadgeType -> Int -> String -> IO BadgeCode issueCodeAs cc badgeType months status = sendChatCmdStr cc ("//issue " <> T.unpack (textEncode badgeType) <> " " <> show months <> " " <> status) >>= \case - Right (CRCustomChatResponse _ response) -> case T.stripPrefix "code " response of + Right (CRCustomChatResponse _ response) -> case T.stripPrefix "Code: " response of Just c | Just code <- parseBadgeCode c -> pure code _ -> error $ "unexpected issue response: " <> T.unpack response r -> error $ "issue failed: " <> show (() <$ r) @@ -313,11 +333,13 @@ testIssueRejectsBadArguments ps = refuses "" issueRaw cc "supporter 255 paid" >>= (`shouldSatisfy` isRight) -issueRaw :: ChatController -> String -> IO (Either () ()) +-- | Left is a refusal or a failure the service answers as a command error. +issueRaw :: HasCallStack => ChatController -> String -> IO (Either T.Text ()) issueRaw cc args = sendChatCmdStr cc ("//issue " <> args) >>= \case Right CRCustomChatResponse {} -> pure $ Right () - _ -> pure $ Left () + Left (ChatError (CECommandError e)) -> pure (Left (T.pack e)) + r -> error $ "issue failed: " <> show (() <$ r) testRedeemSecondCode :: HasCallStack => TestParams -> IO () testRedeemSecondCode ps = @@ -359,12 +381,16 @@ testRedeemSameCodeOtherProfile ps = showActiveUser alice "alice (Alice, * supporter)" serviceCmd :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse -serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} purchaseKey request = - badgeServiceResponse bsIssuerKey bsController (Just purchaseKey) reqObject - where - reqObject = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of - J.Object o -> o - _ -> error "badge service request must encode as an object" +serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} = serviceCmdWith bsIssuerKey bsController Nothing + +serviceCmdWith :: HasCallStack => BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse +serviceCmdWith key cc trackerQ_ purchaseKey request = + badgeServiceResponse key cc trackerQ_ (Just purchaseKey) (requestObject purchaseKey request) + +requestObject :: HasCallStack => C.PublicKeyEd25519 -> BadgeServiceCommand -> J.Object +requestObject purchaseKey request = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of + J.Object o -> o + _ -> error "badge service request must encode as an object" entryOf :: StatementEntry -> (Int, Int, UTCTime) entryOf StatementEntry {changeMonths, balanceMonths, balanceStartTs} = (changeMonths, balanceMonths, balanceStartTs) @@ -387,6 +413,17 @@ credentialOf = \case BSPBadgeCredential {credential} -> credential r -> error $ "expected badgeCredential, got " <> show (J.toJSON r) +shouldAnswerError :: HasCallStack => BadgeServiceResponse -> BadgeServiceErrorCode -> IO () +shouldAnswerError r expected = case r of + BSPError {code = ec} -> ec `shouldBe` expected + _ -> expectationFailure $ "expected " <> show expected <> ", got: " <> show (J.toJSON r) + +codeCounts :: DBStore -> ByteString -> IO (Maybe (Int, Int)) +codeCounts st codeHash = fmap (\IssuedCode {redeemLimit, redeemCount} -> (redeemLimit, redeemCount)) <$> withTransaction st (`getBadgeCode` codeHash) + +codeUses :: ChatController -> BadgeCode -> IO (Maybe (Int, Int)) +codeUses cc code = codeCounts (chatStore cc) (badgeCodeHash code) + nextDue :: [StatementEntry] -> UTCTime nextDue entries = let (_, _, start) = entryOf (last entries) in start @@ -396,6 +433,17 @@ newPurchaseKeys = do (purchaseKey, _) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519) (purchaseKey,) <$> generateMasterKey g +redeemAsNewPurchase :: HasCallStack => BadgeServiceEnv -> BadgeCode -> IO BadgeServiceResponse +redeemAsNewPurchase BadgeServiceEnv {bsIssuerKey, bsController} = redeemWithQueue bsIssuerKey bsController Nothing . badgeCodeText + +redeemWithKeys :: HasCallStack => BadgeServiceEnv -> (C.PublicKeyEd25519, BadgeMasterKey) -> BadgeCode -> IO BadgeServiceResponse +redeemWithKeys env (purchaseKey, masterKey) code = serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + +redeemWithQueue :: HasCallStack => BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> Text -> IO BadgeServiceResponse +redeemWithQueue key cc trackerQ_ codeText = do + (purchaseKey, masterKey) <- newPurchaseKeys + serviceCmdWith key cc trackerQ_ purchaseKey BSCRedeemBadgeCode {masterKey, code = codeText} + assertBalance :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> StatementEntry -> IO BadgeServiceResponse assertBalance env purchaseKey lastEntry = serviceCmd env purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry}} @@ -403,6 +451,9 @@ assertBalance env purchaseKey lastEntry = expiryOf :: HasCallStack => BadgeServiceResponse -> Maybe UTCTime expiryOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) -> badgeExpiry) <$> credentialOf r +badgeTypeOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeType +badgeTypeOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeType}) -> badgeType) <$> credentialOf r + masterKeyOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeMasterKey masterKeyOf r = (\(BadgeCredential _ mk _ _) -> mk) <$> credentialOf r @@ -410,8 +461,8 @@ testCodeMonthsRenew :: HasCallStack => TestParams -> IO () testCodeMonthsRenew ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do code <- issueCode cc BTSupporter 3 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, _) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code let (entries, previousEntryId) = statementOf redeemed previousEntryId `shouldBe` Nothing map entryTag entries `shouldBe` ["code", "badge"] @@ -435,19 +486,79 @@ testRepeatInsideIssuedPeriod :: HasCallStack => TestParams -> IO () testRepeatInsideIssuedPeriod ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do code <- issueCode cc BTSupporter 2 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, _) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code let (entries, _) = statementOf redeemed repeated <- assertBalance env purchaseKey (last entries) map entryTag (fst $ statementOf repeated) `shouldBe` [] credentialOf repeated `shouldBe` credentialOf redeemed +testMultiUseRepeatAfterExpiry :: HasCallStack => TestParams -> IO () +testMultiUseRepeatAfterExpiry ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + code <- issueMultiUseCode cc BTSupporter 1 2 + redeemFirstBadge alice code + rows <- ledgerRows (chatController alice) "badge_ledger" + setClockAt bsClock $ dueAtOf rows + alice ##> "/_app activate" + alice <## "ok" + alice <##. "badge alert: support_ended " + alice <##. "1: supporter" + alice <##. "badge alert: support_ended " + waitShownBadge (chatController alice) Nothing + -- The repeat uses the same purchase key, so the service returns the credential it already issued. + alice ##> ("/_redeem_badge_code 1 " <> codeArg code) + alice <## "badge already redeemed" + waitShownBadge (chatController alice) Nothing + codeUses cc code `shouldReturn` Just (2, 1) + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> redeemFirstBadge bob code + redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeUsed) + +testMultiUseWithoutGroup :: HasCallStack => TestParams -> IO () +testMultiUseWithoutGroup ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + code <- issueMultiUseCode cc BTLegend 2 2 + forM_ [1 :: Int, 2] $ \claimed -> do + keys@(_, masterKey) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code + let (entries, _) = statementOf redeemed + map (\e -> let (c, m, _) = entryOf e in (c, m)) entries `shouldBe` [(2, 2), (-1, 1)] + badgeTypeOf redeemed `shouldBe` Just BTLegend + expiryOf redeemed `shouldBe` Just (endOfMondayAfter (nextDue entries)) + masterKeyOf redeemed `shouldBe` Just masterKey + codeUses cc code `shouldReturn` Just (2, claimed) + redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeUsed) + +testUnreadableCredentialIsInternal :: HasCallStack => TestParams -> IO () +testUnreadableCredentialIsInternal ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + code <- issueMultiUseCode cc BTSupporter 1 2 + let redeem keys = redeemWithKeys env keys code + holder <- newPurchaseKeys + redeem holder >>= (`shouldSatisfy` isJust) . credentialOf + withTransaction (chatStore cc) $ \db -> + DB.execute db "UPDATE sx_badge_service_badge_issuances SET credential = ?" (Only (Binary ("not a credential" :: ByteString))) + redeem holder >>= (`shouldAnswerError` BSEInternal) + codeUses cc code `shouldReturn` Just (2, 1) + newPurchaseKeys >>= redeem >>= (`shouldSatisfy` isJust) . credentialOf + codeUses cc code `shouldReturn` Just (2, 2) + redeem holder >>= (`shouldAnswerError` BSEInternal) + codeUses cc code `shouldReturn` Just (2, 2) + +-- Multi-use codes come from the group command, and this service has no group. +issueMultiUseCode :: HasCallStack => ChatController -> BadgeType -> Int -> Int -> IO BadgeCode +issueMultiUseCode cc badgeType months uses = + issueOneCode cc badgeType months CPSFree uses >>= \case + Right (code, _) -> pure code + Left e -> error $ "issuing a multi-use code failed: " <> e + testLapseWhileAway :: HasCallStack => TestParams -> IO () testLapseWhileAway ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do code <- issueCode cc BTSupporter 6 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, _) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code let (entries, _) = statementOf redeemed -- The clock is moved from the anchor because adding months to an already clipped due date would miss the boundary. setClockAt bsClock (addMonths 4 (anchorOf (last entries))) @@ -461,8 +572,8 @@ testLastMonthExpiryRounds :: HasCallStack => TestParams -> IO () testLastMonthExpiryRounds ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do code <- issueCode cc BTSupporter 2 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, _) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code let (entries, _) = statementOf redeemed setClockAt bsClock (nextDue entries) renewed <- assertBalance env purchaseKey (last entries) @@ -475,8 +586,8 @@ testRenewalSignsWithStoredMasterKey :: HasCallStack => TestParams -> IO () testRenewalSignsWithStoredMasterKey ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do code <- issueCode cc BTSupporter 2 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, masterKey) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code masterKeyOf redeemed `shouldBe` Just masterKey let (entries, _) = statementOf redeemed setClockAt bsClock (nextDue entries) @@ -486,14 +597,30 @@ testRenewalSignsWithStoredMasterKey ps = -- This type omits service_created_at and created_at because the client records when it stored a row, not when the service wrote it, so those columns never match. type ReplicatedRow = (Text, Int, Int, UTCTime, Text, Maybe Text) +replicatedColumns :: String +replicatedColumns = + "entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, " + <> "COALESCE(entry_credit_type, entry_debit_type)" + ledgerRows :: ChatController -> String -> IO [ReplicatedRow] ledgerRows ChatController {chatStore} table = withTransaction chatStore $ \db -> DB.query_ db . fromString $ - "SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, " - <> "COALESCE(entry_credit_type, entry_debit_type) FROM " - <> table - <> " ORDER BY entry_id" + "SELECT " <> replicatedColumns <> " FROM " <> table <> " ORDER BY entry_id" + +purchaseLedgerRows :: ChatController -> Text -> IO [ReplicatedRow] +purchaseLedgerRows ChatController {chatStore} entryUuid = + withTransaction chatStore $ \db -> + DB.query + db + ( fromString $ + "SELECT " + <> replicatedColumns + <> " FROM sx_badge_service_badge_ledger " + <> "WHERE badge_purchase_id = (SELECT badge_purchase_id FROM sx_badge_service_badge_ledger WHERE entry_uuid = ?) " + <> "ORDER BY entry_id" + ) + (Only entryUuid) -- the two dates the CLI prints for each row ledgerTimes :: ChatController -> IO [(UTCTime, UTCTime)] @@ -697,6 +824,78 @@ testWorkerRenews ps = alice <## "ok" waitShownIssued (chatController alice) +testRevokedMultiUseHolderRenews :: HasCallStack => TestParams -> IO () +testRevokedMultiUseHolderRenews ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + code <- issueMultiUseCode cc BTSupporter 3 2 + redeemFirstBadge alice code + redeemed <- ledgerRows (chatController alice) "badge_ledger" + revokeCodeAs cc code `shouldReturn` Right "Revoked." + redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeInvalid) + codeUses cc code `shouldReturn` Just (2, 1) + -- A holder whose reply was lost retries with the same key and still gets its badge. + alice ##> ("/_redeem_badge_code 1 " <> codeArg code) + alice <## "badge already redeemed" + codeUses cc code `shouldReturn` Just (2, 1) + let (requestAt, presentAt) = renewalMoments redeemed + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 3 + alice <##. "1: supporter" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")] + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` renewed + setClockAt bsClock presentAt + alice ##> "/_app activate" + alice <## "ok" + waitShownIssued (chatController alice) + +testMultiUseHoldersRenewApart :: HasCallStack => TestParams -> IO () +testMultiUseHoldersRenewApart ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + code <- issueMultiUseCode cc BTSupporter 3 2 + redeemFirstBadge alice code + redeemed <- ledgerRows (chatController alice) "badge_ledger" + let requestAt = fst $ renewalMoments redeemed + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 3 + alice <##. "1: supporter" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")] + bobRows <- withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + redeemFirstBadge bob code + ledgerRows (chatController bob) "badge_ledger" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) bobRows `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge")] + let (bobFirstUuid, _, _, bobRedeemedAt, _, _) = head bobRows + bobRedeemedAt `shouldSatisfy` (>= requestAt) + purchaseLedgerRows cc bobFirstUuid `shouldReturn` bobRows + issued <- issuedExpiries (chatController alice) + length issued `shouldBe` 2 + alice ##> ("/_redeem_badge_code 1 " <> codeArg code) + alice <## "badge already redeemed" + codeUses cc code `shouldReturn` Just (2, 2) + let (aliceFirstUuid, _, _, _, _, _) = head renewed + ledgerRows (chatController alice) "badge_ledger" `shouldReturn` renewed + purchaseLedgerRows cc aliceFirstUuid `shouldReturn` renewed + issuedExpiries (chatController alice) `shouldReturn` issued + alicePurchaseKey <- codeRedemptionKey (chatController alice) + (_, masterKey) <- newPurchaseKeys + repeated <- redeemWithKeys env (alicePurchaseKey, masterKey) code + expiryOf repeated `shouldBe` Just (last issued) + codeUses cc code `shouldReturn` Just (2, 2) + +codeRedemptionKey :: HasCallStack => ChatController -> IO C.PublicKeyEd25519 +codeRedemptionKey ChatController {chatStore} = do + rows :: [Only C.PublicKeyEd25519] <- + withTransaction chatStore $ \db -> + DB.query_ db "SELECT purchase_key FROM badge_code_redemptions" + case rows of + [Only k] -> pure k + _ -> error $ "expected one code redemption, got " <> show (length rows) + testRequestWakeFires :: HasCallStack => TestParams -> IO () testRequestWakeFires ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> @@ -1319,7 +1518,7 @@ testRevokeRedeemedCode ps = alice <## "supporter badge - active" alice <##. "expires " refused <- revokeCodeAs cc code - refused `shouldSatisfy` T.isInfixOf "redeemed already, so it cannot be revoked" + refused `shouldBe` Left "Fully redeemed. It cannot be revoked." alice ##> ("/_redeem_badge_code 1 " <> codeArg code) alice <## "badge already redeemed" @@ -1329,15 +1528,34 @@ testRevokeUnknownCode ps = g <- C.newRandom code <- randomBadgeCode g unknown <- revokeCodeAs cc code - unknown `shouldSatisfy` T.isInfixOf "no such code" + unknown `shouldBe` Left "No such code." testRevokedCode :: HasCallStack => TestParams -> IO () testRevokedCode ps = withBadgeService ps $ \clientCfg _ cc -> withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do paid <- issueCodeAs cc BTSupporter 1 "paid" - revokeCodeAs cc paid `shouldReturn` "revoked" + revokeCodeAs cc paid `shouldReturn` Right "Revoked." alice ##> ("/_redeem_badge_code 1 " <> codeArg paid) alice <## "cannot redeem badge code: badge service error: code_invalid" - second <- revokeCodeAs cc paid - second `shouldSatisfy` T.isInfixOf "revoked already" + revokeCodeAs cc paid `shouldReturn` Right "Already revoked." + +testRevokedUnpaidCode :: HasCallStack => TestParams -> IO () +testRevokedUnpaidCode ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + code <- issueCodeAs cc BTSupporter 1 "unpaid" + revokeCodeAs cc code `shouldReturn` Right "Revoked." + redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeInvalid) + +testRevokeRejectsTrailingInput :: HasCallStack => TestParams -> IO () +testRevokeRejectsTrailingInput ps = + withBadgeService ps $ \_ _ cc -> do + code <- issueCodeAs cc BTSupporter 1 "paid" + refused <- revokeRaw cc (formatBadgeCode code <> " junk") + -- If the refused call revoked the code anyway, this fails with "Already revoked.". + revokeCodeAs cc code `shouldReturn` Right "Revoked." + refused `shouldBe` Left badgeCmdUsage + +-- The text is spelled out rather than taken from the service, so a change there fails here. +badgeCmdUsage :: Text +badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke " 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..1b80adcd13 --- /dev/null +++ b/tests/Bots/BadgeService/GroupIntegrationTests.hs @@ -0,0 +1,1376 @@ +{-# 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 in one message across redemptions and refuses it when used up" testMultiUseTracker + it "leaves a used-up code's tracker as it is on a stale refresh" testStaleRefreshIgnored + it "keeps each multi-use code's counter to its own claims" testCountersKeptApart + 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 "publishes nothing when a code whose tracker was deleted is used up" testDeletedTrackerUsedUp + 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 a used-up tracker whose refresh was lost, in place" testUsedUpTrackerReconciledOnRestart + 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 <> "> Usage: /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 "Usage: /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 codes. The remaining codes could not be issued."] + 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` "The code could not be issued." + issueRaw cc "supporter" `shouldReturn` Left "The code could not be issued." + 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 "The code could not be revoked." + 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 of 2 uses remaining" + redeemOk gsKey cc env code + t1 <- waitItemText cc trackerItemId "1 of 2 uses remaining" + t1 `shouldSatisfy` T.isInfixOf "last used" + redeemOk gsKey cc env code + usedUp <- waitItemText cc trackerItemId "All 2 uses redeemed" + sentItemsWithCode cc code `shouldReturn` [usedUp] + 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 + usedUp <- waitItemText cc trackerItemId "All 2 uses redeemed" + replayRefresh cc env code 2 + awaitLane cc env + sentItemsWithCode cc code `shouldReturn` [usedUp] + +testCountersKeptApart :: HasCallStack => TestParams -> IO () +testCountersKeptApart ps = + withGroupOwner ps $ \gsKey cc env alice -> do + (firstItemId, _, firstCode) <- issueTracked cc alice "supporter" 5 + replicateM_ 3 (redeemOk gsKey cc env firstCode) + void $ waitItemText cc firstItemId "2 of 5 uses remaining" + (secondItemId, _, secondCode) <- issueTracked cc alice "legend" 3 + replicateM_ 3 (redeemOk gsKey cc env secondCode) + void $ waitItemText cc secondItemId "All 3 uses redeemed" + readItemText cc firstItemId >>= (`shouldSatisfy` T.isInfixOf "2 of 5 uses 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 of 2 uses remaining" + t1 `shouldSatisfy` T.isInfixOf "last used" + redeemOkWith gsKey cc Nothing code + readItemText cc trackerItemId >>= (`shouldSatisfy` T.isInfixOf "All 2 uses redeemed") + 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 of 2 uses 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 of 2 uses 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 of 2 uses 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 of 2 uses remaining" + redeemOk gsKey cc env code + usedUp <- waitItemText cc itemId1 "All 2 uses redeemed" + sentItemsWithCode cc code `shouldReturn` [tracker0, usedUp] + +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 "All 2 uses redeemed" + +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. +testDeletedTrackerUsedUp :: HasCallStack => TestParams -> IO () +testDeletedTrackerUsedUp 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 + 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 + 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 + +testUsedUpTrackerReconciledOnRestart :: HasCallStack => TestParams -> IO () +testUsedUpTrackerReconciledOnRestart ps = do + svc@GroupSvc {gsKey} <- prepareGroupService ps + (lostItemId, lostCode) <- runWithOwner svc $ \cc env _ alice -> do + (doneItemId, _, doneCode) <- issueTracked cc alice "supporter" 2 + redeemOk gsKey cc env doneCode + redeemOk gsKey cc env doneCode + void $ waitItemText cc doneItemId "All 2 uses redeemed" + (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, lostCode) + runGroupService svc $ \cc env _ -> do + corrected <- waitItemText cc lostItemId "All 3 uses redeemed" + corrected `shouldBe` (lostCode <> "\nAll 3 uses redeemed, last used 2026-02-28 23:50 UTC") + awaitLane cc env + sentItemsWithCode cc lostCode `shouldReturn` [corrected] + 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, code) <- 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 of 5 uses remaining" + redeemLosingRefresh gsKey cc code + readItemText cc stalledItemId `shouldReturn` stalled + dateRedemption cc 5 lostRedeemedAt + pure (stalledItemId, code) + runGroupService svc $ \cc env _ -> do + corrected <- waitItemText cc stalledItemId "2 of 5 uses remaining" + corrected `shouldBe` ("!2 " <> code <> "!\n2 of 5 uses remaining, last used 2026-02-28 23:50 UTC") + awaitLane cc env + sentItemsWithCode cc code `shouldReturn` [corrected] + +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 of 5 uses remaining" + first1 `shouldSatisfy` T.isInfixOf "last used " + second1 <- waitItemText cc secondItemId "2 of 3 uses remaining" + second1 `shouldSatisfy` T.isInfixOf "last used " + awaitLane cc env + 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 of 3 uses 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 of 2 uses remaining" + revokeInGroup cc alice code "Revoked." + retired <- waitItemText cc trackerItemId "Revoked" + retired `shouldBe` retiredText code + revokedTrackerCount cc `shouldReturn` 1 + replayRefresh cc env code 2 + awaitLane cc env + readItemText cc trackerItemId `shouldReturn` retired + 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 of 2 uses 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 -> IO () +replayRefresh cc env codeText uses = 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) + +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 used%'" + +revokedTrackerCount :: ChatController -> IO Int +revokedTrackerCount cc = countRows cc ("chat_items WHERE item_text LIKE '" <> T.unpack (retiredText "SB-%") <> "'") + +retiredText :: Text -> Text +retiredText code = code <> "\nRevoked, can no longer be redeemed" + +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..c592178a91 --- /dev/null +++ b/tests/Bots/BadgeService/GroupTests.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Bots.BadgeService.GroupTests where + +import BadgeService.Config (GroupConfig (..)) +import BadgeService.Group (GroupAction (..), GroupEvent (..), TrackerAction (..), coalesceTrackerRefreshes, inertGroupConfig, noOwnerHint, orphanHint, trackerDecision) +import BadgeService.Group.Command +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), addUTCTime) +import Simplex.Chat.Badges (BadgeType (..)) +import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeText, randomBadgeCode) +import Simplex.Chat.Controller (ChatCommand (DeleteGroup, MemberRole)) +import Simplex.Chat.Library.Commands (parseChatCommand) +import Simplex.Chat.Types (GroupProfile (..)) +import Simplex.Chat.Types.Shared (GroupMemberRole (..)) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Util (tshow) +import Test.Hspec + +badgeGroupTests :: Spec +badgeGroupTests = describe "badge group" $ do + let p = groupCmdAction GROwner + issueUsage = ReplyText "Usage: /issue [months ] [uses ]" + bulkUsage = ReplyText "Usage: /bulk [months ] count " + revokeUsage = ReplyText "Usage: /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. This code is now visible to all members.") + describe "configured group name and description" $ do + let cfg name descr = GroupConfig {gDisplayName = name, gDescription = descr} + profile name descr = + GroupProfile + { displayName = name, + fullName = "", + shortDescr = Nothing, + description = descr, + image = Nothing, + publicGroup = Nothing, + groupPreferences = Nothing, + memberAdmission = Nothing + } + it "says nothing when the config matches the group profile" $ do + inertGroupConfig (cfg "SimpleX Badges" (Just "badge ops desk")) (profile "SimpleX Badges" (Just "badge ops desk")) + `shouldBe` Nothing + inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" Nothing) `shouldBe` Nothing + it "says nothing when an omitted description meets an empty one" $ + inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" (Just "")) `shouldBe` Nothing + it "reports a name the config would change" $ + inertGroupConfig (cfg "SimpleX Badges 2026" (Just "badge ops desk")) (profile "SimpleX Badges" (Just "badge ops desk")) + `shouldBe` Just "badge group config is not applied to an existing group: display_name \"SimpleX Badges 2026\", group has \"SimpleX Badges\"" + it "shows a non-ASCII name as written" $ + inertGroupConfig (cfg "Значки" Nothing) (profile "SimpleX Badges" Nothing) + `shouldBe` Just "badge group config is not applied to an existing group: display_name \"Значки\", group has \"SimpleX Badges\"" + it "reports a description the config would change or remove" $ do + inertGroupConfig (cfg "SimpleX Badges" (Just "new desk")) (profile "SimpleX Badges" (Just "badge ops desk")) + `shouldBe` Just "badge group config is not applied to an existing group: description \"new desk\", group has \"badge ops desk\"" + inertGroupConfig (cfg "SimpleX Badges" Nothing) (profile "SimpleX Badges" (Just "badge ops desk")) + `shouldBe` Just "badge group config is not applied to an existing group: description \"\", group has \"badge ops desk\"" + it "reports both fields when both would change" $ + inertGroupConfig (cfg "SimpleX Badges 2026" (Just "new desk")) (profile "SimpleX Badges" Nothing) + `shouldBe` Just + "badge group config is not applied to an existing group: \ + \display_name \"SimpleX Badges 2026\", group has \"SimpleX Badges\"; \ + \description \"new desk\", group has \"\"" + describe "tracker" $ + it "edits within 24h, reposts after" $ do + let t0 = UTCTime (fromGregorian 2026 1 1) 0 + within = addUTCTime (23 * 3600) t0 + past = addUTCTime (25 * 3600) t0 + trackerDecision within t0 `shouldBe` Edit + trackerDecision past t0 `shouldBe` Repost + describe "coalescing tracker refreshes" $ do + it "keeps the last refresh of each code" $ do + code1 <- newCode + code2 <- newCode + coalesceTrackerRefreshes [GETracker 1 code1, GETracker 2 code2, GETracker 1 code1] + `shouldBe` [GETracker 2 code2, GETracker 1 code1] + it "keeps every other event, in order" $ do + code <- newCode + coalesceTrackerRefreshes + [ GEInGroup 7 (GACommand GRAdmin "a"), + GETracker 1 code, + GEInGroup 7 GAJoined, + GETracker 1 code + ] + `shouldBe` [GEInGroup 7 (GACommand GRAdmin "a"), GEInGroup 7 GAJoined, GETracker 1 code] + +newCode :: IO BadgeCode +newCode = C.newRandom >>= randomBadgeCode diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index 633ad14564..b83f4f8f05 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/tests/Bots/BadgeService/WebTests.hs @@ -14,11 +14,11 @@ import BadgeService.Poller import BadgeService.Providers import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages) import BadgeService.Providers.Stripe (stripeProvider) -import BadgeService.Store (CodeRedemption (..), IssuedCode (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getBadgeCode, insertBadgeCode, revokeCode) +import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, getManagedGroup, insertBadgeCode, insertManagedGroup, markOwnerBootstrapped, revokeCode) import BadgeService.Store.Invoices import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount) import BadgeService.Web.Server -import Bots.BadgeService.BotTests (newPurchaseKeys) +import Bots.BadgeService.BotTests (codeCounts, newPurchaseKeys) import Bots.BadgeService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource) import Bots.BadgeService.FakeBTCPay import Bots.BadgeService.FakeStripe (FakeStripe (..), fakeIntentStatus, setIntentState, stripeEvent, stripeSigHeader, withFakeStripe) @@ -41,9 +41,10 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (toLower) import Data.Either (isLeft) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) -import Data.List (sort, sortOn) +import Data.Int (Int64) +import Data.List (isInfixOf, sort, sortOn) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, isNothing, fromMaybe) +import Data.Maybe (catMaybes, isJust, isNothing, fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -57,15 +58,16 @@ import Network.HTTP.Client (Manager, Request (..), RequestBody (..), Response, d import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType) import Network.HTTP.Types.Status (statusCode) import qualified Network.Wai.Handler.Warp as Warp -import Simplex.Chat.Badges (BadgeType (..)) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeType (..)) import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..)) import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..)) import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..)) import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface -import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..)) +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSSignature (..)) import Simplex.Messaging.Encoding.String (textDecode, textEncode) import Simplex.Messaging.Util (safeDecodeUtf8, tshow) import System.Directory (createDirectoryIfMissing, createFileLink, doesFileExist, listDirectory) @@ -81,6 +83,7 @@ import UnliftIO.Temporary (withTempDirectory) import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations) import ChatClient (testDBConnectInfo, testDBConnstr) import Database.PostgreSQL.Simple (Only (..)) +import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) #else import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations) @@ -88,6 +91,7 @@ import Data.String (fromString) import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL import Simplex.Messaging.Agent.Store.DB (TrackQueries (..)) +import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations #endif #if defined(dbPostgres) @@ -134,6 +138,10 @@ badgeWebTests = do describe "badge service schema" $ do it "carries the five service-only columns" testServiceColumns it "refuses a duplicate provider_ref" testProviderRefUnique + it "M20260918 adds the multi-use columns and the group table" testGroupOpsColumns + it "M20260918 defaults a fresh code to one use with none spent" testGroupOpsRedeemCounts + it "migrates all the way down and up again" testSchemaDownUpCycle + it "rolls back only the group migration and re-applies it, keeping a code redeemed twice spent" testGroupOpsDownUp describe "badge service store" $ do it "writes the invoice, its code and their link atomically" testCreationIsAtomic it "newInvoiceId is 128 CSPRNG bits, base64url, and two calls differ" testNewInvoiceIdRandom @@ -144,7 +152,15 @@ badgeWebTests = do it "expireOverdue spares an invoice funded by dust, or by the verdict alone" testExpireOverdueSparesAZeroAmount it "readCatalogRows drops every disabled row" testReadCatalogRowsDropsDisabled it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther + it "a multi-use code can be revoked while it has uses left, and not once they are gone" testRevokeMultiUseCode it "every timestamp round-trips to the second" testTimestampRoundTrip + describe "managed group" $ do + it "round-trips and bootstraps once" testManagedGroupRoundTripsAndBootstrapsOnce + it "refuses a second row and burns the flag per group" testManagedGroupIsSingleRow + describe "multi-use" $ do + it "finds a key's own purchase with its newest credential, and none for another key" testKeyPurchaseLookup + it "gives concurrent claims exactly the code's uses" testMultiUseConcurrentClaimsUpToLimit + it "refuses a second claim by the same key without using up a use" testSameKeyClaimsOnce describe "badge service catalog seed" $ do it "writes the compiled-in catalog into an empty database" testSeedWritesTheCatalog it "leaves exactly one row per id when the service starts twice" testSeedIsIdempotent @@ -302,6 +318,59 @@ testServiceColumns = withServiceStore $ \st -> do columnsOf st "sx_badge_service_badge_codes" >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["expires_at", "revoked_at"]) +testGroupOpsColumns :: IO () +testGroupOpsColumns = withServiceStore assertGroupOpsColumns + +assertGroupOpsColumns :: HasCallStack => DBStore -> IO () +assertGroupOpsColumns st = do + columnsOf st "sx_badge_service_badge_codes" + >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["redeem_limit", "redeem_count", "group_item_id", "group_item_sent_at"]) + columnsOf st "sx_badge_service_group" + >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["group_id", "group_link", "owner_bootstrapped", "created_at"]) + +runMigrations :: DBStore -> MigrationsToRun -> IO () +#if defined(dbPostgres) +runMigrations st = Migrations.run st Nothing +#else +runMigrations st = Migrations.run st Nothing True +#endif + +testSchemaDownUpCycle :: IO () +testSchemaDownUpCycle = withServiceStore $ \st -> do + let downMigrations = mapMaybe toDownMigration badgeServiceSchemaMigrations + length downMigrations `shouldBe` length badgeServiceSchemaMigrations + runMigrations st $ MTRDown downMigrations + columnsOf st "sx_badge_service_badge_codes" `shouldReturn` [] + columnsOf st "sx_badge_service_group" `shouldReturn` [] + runMigrations st $ MTRUp badgeServiceSchemaMigrations + assertGroupOpsColumns st + +testGroupOpsDownUp :: IO () +testGroupOpsDownUp = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + let redeemedHash = digestFixture 44 + unredeemedHash = digestFixture 45 + groupOps = [m | m@Migration {name = "20260918_badge_group_ops"} <- badgeServiceSchemaMigrations] + redeemed <- insertCode st redeemedHash CPSPaid 2 now + void $ insertCode st unredeemedHash CPSPaid 1 now + -- Two purchases of one code would break a down migration that restored the unique index. + replicateM_ 2 $ newPurchaseKeys >>= claimUse st redeemed now >>= (`shouldSatisfy` isJust) + runMigrations st $ MTRDown (mapMaybe toDownMigration groupOps) + columnsOf st "sx_badge_service_badge_codes" >>= (`shouldNotSatisfy` elem "redeem_count") + runMigrations st $ MTRUp groupOps + codeCounts st redeemedHash `shouldReturn` Just (1, 1) + codeCounts st unredeemedHash `shouldReturn` Just (1, 0) + +testGroupOpsRedeemCounts :: IO () +testGroupOpsRedeemCounts = withServiceStore $ \st -> do + let codeHash = digestFixture 43 + withConnection st $ \db -> + DB.execute + db + "INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)" + (DB.Binary codeHash, "supporter" :: Text, 1 :: Int, "free" :: Text, someCreated) + codeCounts st codeHash `shouldReturn` Just (1, 0) + testProviderRefUnique :: IO () testProviderRefUnique = withServiceStore $ \st -> do seedBadgePrice st "price1" @@ -464,25 +533,35 @@ expireAllOverdue st now = overdueInvoices st now >>= expireOverdue st now . map testRevokeAndRedeemExcludeEachOther :: IO () testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do now <- truncateToSecond <$> getCurrentTime - (purchaseKey, masterKey) <- newPurchaseKeys - let newCode codeHash = withTransaction st $ \db -> do - insertBadgeCode db codeHash BTSupporter 1 CPSPaid now - maybe (error "the code was not written") (\IssuedCode {badgeCodeId} -> badgeCodeId) <$> getBadgeCode db codeHash - redeem badgeCodeId = withTransaction st $ \db -> createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now + keys <- newPurchaseKeys + let newCode codeHash = insertCode st codeHash CPSPaid 1 now + redeem badgeCodeId = claimUse st badgeCodeId now keys revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now - unredeemed codeHash = - withTransaction st (`getBadgeCode` codeHash) >>= \case - Just IssuedCode {redemption = CodeUnredeemed} -> pure True - _ -> pure False revokedFirst <- newCode "revoked-first" - revoke "revoked-first" `shouldReturn` Revoked + revoke "revoked-first" `shouldReturn` Revoked revokedFirst redeem revokedFirst `shouldReturn` Nothing - unredeemed "revoked-first" `shouldReturn` True + codeCounts st "revoked-first" `shouldReturn` Just (1, 0) redeemedFirst <- newCode "redeemed-first" isJust <$> redeem redeemedFirst `shouldReturn` True revoke "redeemed-first" `shouldReturn` AlreadyRedeemed redeem redeemedFirst `shouldReturn` Nothing +testRevokeMultiUseCode :: IO () +testRevokeMultiUseCode = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + let newCode codeHash = insertCode st codeHash CPSPaid 2 now + -- A purchase key redeems once, so every redemption here brings its own. + redeem badgeCodeId = newPurchaseKeys >>= claimUse st badgeCodeId now + revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now + partlyUsed <- newCode "partly-used" + isJust <$> redeem partlyUsed `shouldReturn` True + revoke "partly-used" `shouldReturn` Revoked partlyUsed + redeem partlyUsed `shouldReturn` Nothing + usedUp <- newCode "used-up" + isJust <$> redeem usedUp `shouldReturn` True + isJust <$> redeem usedUp `shouldReturn` True + revoke "used-up" `shouldReturn` AlreadyRedeemed + testReadCatalogRowsDropsDisabled :: IO () testReadCatalogRowsDropsDisabled = withServiceStore $ \st -> do insertPrice st "price-active" "supporter" 500 "active" @@ -616,6 +695,103 @@ testTimestampRoundTrip = withServiceStore $ \st -> do irExpiresAt row `shouldBe` truncated irCreatedAt row `shouldBe` truncated +testManagedGroupRoundTripsAndBootstrapsOnce :: IO () +testManagedGroupRoundTripsAndBootstrapsOnce = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + beforeInsert <- withTransaction st getManagedGroup + beforeInsert `shouldBe` Nothing + withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now + afterInsert <- withTransaction st getManagedGroup + afterInsert `shouldBe` Just ManagedGroup {mgGroupId = 42, mgGroupLink = "https://link", mgOwnerBootstrapped = False} + show afterInsert `shouldNotSatisfy` ("https://link" `isInfixOf`) + firstMark <- withTransaction st (`markOwnerBootstrapped` 42) + secondMark <- withTransaction st (`markOwnerBootstrapped` 42) + (firstMark, secondMark) `shouldBe` (True, False) + +testManagedGroupIsSingleRow :: IO () +testManagedGroupIsSingleRow = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now + withTransaction st $ \db -> insertManagedGroup db 43 "https://other" now + withTransaction st $ \db -> insertManagedGroup db 42 "https://again" now + managedGroupRows st `shouldReturn` [(42, "https://link")] + withTransaction st (`markOwnerBootstrapped` 43) `shouldReturn` False + (fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just False + withTransaction st (`markOwnerBootstrapped` 42) `shouldReturn` True + (fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just True + +managedGroupRows :: DBStore -> IO [(Int64, Text)] +managedGroupRows st = + withConnection st $ \db -> DB.query_ db "SELECT group_id, group_link FROM sx_badge_service_group ORDER BY group_id" + +insertCode :: DBStore -> ByteString -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64 +insertCode st codeHash paymentStatus redeemLimit now = + withTransaction st $ \db -> insertBadgeCode db codeHash BTSupporter 1 paymentStatus redeemLimit now + +claimUse :: DBStore -> Int64 -> UTCTime -> (C.PublicKeyEd25519, BadgeMasterKey) -> IO (Maybe Int64) +claimUse st badgeCodeId now (purchaseKey, masterKey) = + withTransaction st $ \db -> + createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now + +-- The signature is dummy bytes, since only the JSON round-trip is under test; 80 is the length its decoder accepts. +seededCredential :: BadgeMasterKey -> UTCTime -> BadgeCredential +seededCredential masterKey expiry = + BadgeCredential {badgeKeyIdx = 1, masterKey, signature = BBSSignature (BS.replicate 80 7), badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}} + +seedIssuance :: DBStore -> Int64 -> Text -> BadgeMasterKey -> UTCTime -> UTCTime -> IO () +seedIssuance st purchaseId issuanceId masterKey at periodEnd = + withConnection st $ \db -> + DB.execute + db + "INSERT INTO sx_badge_service_badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at) VALUES (?,?,?,?,?,?,?,?)" + (issuanceId, purchaseId, "supporter" :: Text, at, periodEnd, periodEnd, DB.Binary (LB.toStrict (J.encode (seededCredential masterKey periodEnd))), at) + +testKeyPurchaseLookup :: IO () +testKeyPurchaseLookup = withServiceStore $ \st -> do + now <- getCurrentTime + let codeHash = digestFixture 41 + badgeCodeId <- insertCode st codeHash CPSFree 2 now + keys@(k1, mk1) <- newPurchaseKeys + Just purchaseId <- claimUse st badgeCodeId now keys + withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1) >>= \case + KeyRedeemedUnreadable -> pure () + _ -> expectationFailure "expected a purchase with no issuance to be unreadable" + let firstPeriodEnd = someExpiry + renewedPeriodEnd = addUTCTime 86400 someExpiry + seedIssuance st purchaseId "iss-first" mk1 now firstPeriodEnd + seedIssuance st purchaseId "iss-renewed" mk1 now renewedPeriodEnd + (unusedKey, _) <- newPurchaseKeys + withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId unusedKey) >>= \case + KeyUnredeemed -> pure () + _ -> expectationFailure "expected no purchase for a key that never redeemed" + replayed <- withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1) + case replayed of + KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> do + badgePurchaseId `shouldBe` purchaseId + credential `shouldBe` seededCredential mk1 renewedPeriodEnd + _ -> expectationFailure "expected the redeemed key's purchase" + +testSameKeyClaimsOnce :: IO () +testSameKeyClaimsOnce = withServiceStore $ \st -> do + now <- getCurrentTime + let codeHash = digestFixture 46 + badgeCodeId <- insertCode st codeHash CPSFree 3 now + keys <- newPurchaseKeys + claimUse st badgeCodeId now keys >>= (`shouldSatisfy` isJust) + -- The key is unique across purchases, so the second insert fails and its transaction returns the use. + claimUse st badgeCodeId now keys `shouldThrow` anyException + codeCounts st codeHash `shouldReturn` Just (3, 1) + +testMultiUseConcurrentClaimsUpToLimit :: IO () +testMultiUseConcurrentClaimsUpToLimit = withServiceStore $ \st -> do + now <- getCurrentTime + let codeHash = digestFixture 42 + badgeCodeId <- insertCode st codeHash CPSFree 3 now + contenders <- replicateM 6 newPurchaseKeys + results <- Async.mapConcurrently (claimUse st badgeCodeId now) contenders + length (catMaybes results) `shouldBe` 3 + codeCounts st codeHash `shouldReturn` Just (3, 3) + data StubCall = StubCreate ServicePaymentMethod OrderDraft | StubRead Text @@ -802,7 +978,7 @@ testServiceConfig staticDir trustForwarded = stripe = Nothing, poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60}, issuer = Nothing, - devChatRedeem = False + group = Nothing } testServeWebappOff :: IO () diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 2a4eeccb74..f96eac2870 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -20,7 +20,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.Time.Format (defaultTimeLocale, formatTime) import qualified Data.Map.Strict as M import Simplex.Chat.Badges (BadgeCredential, BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment) @@ -284,11 +284,13 @@ futureDate = posixSecondsToUTCTime 4102444800 -- 2100-01-01 issueTestBadge :: BBSSecretKey -> UTCTime -> IO BadgeCredential issueTestBadge sk = issueTestBadgeType sk BTSupporter +-- The expiry is signed as written but PostgreSQL stores it to the microsecond, so it is cut to whole seconds, as the service issues it. issueTestBadgeType :: BBSSecretKey -> BadgeType -> UTCTime -> IO BadgeCredential -issueTestBadgeType sk badgeType badgeExpiry = do +issueTestBadgeType sk badgeType expiry = do drg <- C.newRandom mk <- generateMasterKey drg - let info = BadgeInfo {badgeType, badgeExpiry, badgeExtra = ""} + let badgeExpiry = posixSecondsToUTCTime $ fromInteger $ truncate $ utcTimeToPOSIXSeconds expiry + info = BadgeInfo {badgeType, badgeExpiry, badgeExtra = ""} Just vreq <- verifyPayment (BPRedeemCode "TEST") BadgeRequest {masterKey = mk, badgeInfo = info} Right cred <- issueBadge 1 sk vreq pure cred 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