diff --git a/apps/simplex-store-service/README.md b/apps/simplex-store-service/README.md index 43e20806a8..cf0077b8de 100644 --- a/apps/simplex-store-service/README.md +++ b/apps/simplex-store-service/README.md @@ -1268,7 +1268,9 @@ group is single-use and `free`. A badge takes `months`, 1 to 255 and 1 by defaul also `uses`, 1 to 1000. `count` is 1 to 100. A value outside these bounds, a length for a badge, or the other kind's unit gets the usage reply, which lists the form, each kind's bounds and an example of each. The group's command menu shows every kind in each command's hint and fills the hint into -the message box. `/revoke` takes badge and name codes. The group has no `/refund`. A member's role +the message box. Without `[names]`, `/issue name` and `/bulk name` get a reply that names are not +enabled, and issue nothing. `/revoke` takes badge and name codes, so a name code issued before names +were turned off can still be withdrawn. The group has no `/refund`. 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 diff --git a/apps/simplex-store-service/src/StoreService/Group.hs b/apps/simplex-store-service/src/StoreService/Group.hs index 7193c0a33e..7fc393477e 100644 --- a/apps/simplex-store-service/src/StoreService/Group.hs +++ b/apps/simplex-store-service/src/StoreService/Group.hs @@ -198,8 +198,8 @@ coalesceTrackerRefreshes = snd . foldr keepLast (S.empty, []) logUncaught :: HasCallStack => IO () -> IO () logUncaught a = a `catchOwn'` withFrozenCallStack (logError . tshow) -handleGroupEvent :: ChatController -> Turns -> GroupId -> GroupEvent -> IO () -handleGroupEvent cc turns groupId ev = logUncaught (handle ev) +handleGroupEvent :: ChatController -> Turns -> Bool -> GroupId -> GroupEvent -> IO () +handleGroupEvent cc turns namesOn groupId ev = logUncaught (handle ev) where handle = \case GEInGroup gid action @@ -207,7 +207,7 @@ handleGroupEvent cc turns groupId ev = logUncaught (handle ev) | otherwise -> case action of GAJoined -> promoteOwner cc groupId GACommand role t -> case groupCmdAction role t of - RunCmd cmd -> runGroupCmd cc turns groupId cmd + RunCmd cmd -> runGroupCmd cc turns namesOn groupId cmd ReplyText txt -> void $ sendGroupText cc groupId "command reply" txt IgnoreMsg -> pure () GETracker badgeCodeId code -> updateTracker cc groupId badgeCodeId code @@ -224,15 +224,15 @@ promoteFirstOwner cc g@GroupInfo {groupId} member = _ -> pure () -- Nothing is a group that is not served, so its events are drained. -runGroupLane :: ChatController -> Turns -> TQueue GroupEvent -> Maybe GroupId -> IO () -runGroupLane cc turns q groupId_ = case groupId_ of +runGroupLane :: ChatController -> Turns -> Bool -> TQueue GroupEvent -> Maybe GroupId -> IO () +runGroupLane cc turns namesOn 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 turns groupId) (coalesceTrackerRefreshes evs) + mapM_ (handleGroupEvent cc turns namesOn 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 @@ -259,8 +259,8 @@ promoteOwner cc groupId = 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 -> Turns -> GroupId -> GroupCmd -> IO () -runGroupCmd cc turns groupId = \case +runGroupCmd :: ChatController -> Turns -> Bool -> GroupId -> GroupCmd -> IO () +runGroupCmd cc turns namesOn groupId = \case GCIssue bt months uses -> issueOneCode cc bt months CPSFree uses >>= \case Left _ -> reply issueFailedText @@ -271,6 +271,8 @@ runGroupCmd cc turns groupId = \case 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 -> issueMany count (fmap (formatBadgeCode . fst) <$> issueOneCode cc bt months CPSFree singleUse) + GCIssueName {} | not namesOn -> reply namesOffText + GCBulkName {} | not namesOn -> reply namesOffText GCIssueName len years -> issueNameCode cc len years CPSFree >>= reply . either (const issueFailedText) (("Code: " <>) . formatNameCode . NCPrepaid) GCBulkName len years count -> issueMany count (fmap (formatNameCode . NCPrepaid) <$> issueNameCode cc len years CPSFree) @@ -289,6 +291,9 @@ runGroupCmd cc turns groupId = \case [] -> issued _ : _ -> issued <> ["Issued " <> tshow (length issued) <> " of " <> tshow count <> " codes. The remaining codes could not be issued."] +namesOffText :: Text +namesOffText = "Names are not enabled on this service, so name codes cannot be issued." + -- 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 = diff --git a/apps/simplex-store-service/src/StoreService/Service.hs b/apps/simplex-store-service/src/StoreService/Service.hs index 232c42dc7a..19252cb46c 100644 --- a/apps/simplex-store-service/src/StoreService/Service.hs +++ b/apps/simplex-store-service/src/StoreService/Service.hs @@ -256,6 +256,7 @@ storeService opts@StoreServiceOpts {serviceConfigFile} baseCfg env = do requestEnv <- configureStoreVerifier serviceCfg env let groupCfg = serviceCfg >>= \ServiceConfig {group} -> group trackerQ_ = groupEventQ env <$ groupCfg + namesOn = isJust (serviceCfg >>= names) readEvents cc = forever $ atomically (readTBQueue $ outputQ cc) >>= \case @@ -267,7 +268,7 @@ storeService opts@StoreServiceOpts {serviceConfigFile} baseCfg env = do startLanes cc = do lanes <- maybe (pure []) (serviceLanes waiters turns 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 turns (groupEventQ env) <$> ensureManagedGroup cc gc + groupLane_ <- forM groupCfg $ \gc -> runGroupLane cc turns namesOn (groupEventQ env) <$> ensureManagedGroup cc gc raceAny_ $ processQueuedRequests key trackerQ_ requestEnv : maybeToList groupLane_ <> lanes chatHooks = defaultChatHooks diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 6a91d356f3..ecb2fa6211 100644 --- a/tests/Bots/StoreService/GroupIntegrationTests.hs +++ b/tests/Bots/StoreService/GroupIntegrationTests.hs @@ -132,6 +132,7 @@ badgeGroupIntegrationTests = do 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 "refuses /issue name and /bulk name while names are off, still revoking name codes" testGroupNameCodesNamesOff 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 @@ -1294,6 +1295,17 @@ testGroupRevoke ps = unissued <- formatBadgeCode <$> randomBadgeCode (random cc) revokeInGroup cc alice unissued "No such code." +testGroupNameCodesNamesOff :: HasCallStack => TestParams -> IO () +testGroupNameCodesNamesOff ps = + withGroupOwner ps $ \_ cc _ alice -> do + replyTo cc alice "/issue name 8" `shouldReturn` namesOffReply + replyTo cc alice "/bulk name 6 count 2" `shouldReturn` namesOffReply + countRows cc "sx_badge_service_name_prepaid_codes" `shouldReturn` 0 + unissued <- formatNameCode . NCPrepaid <$> randomNamePrepaidCode (random cc) 8 + revokeInGroup cc alice unissued "No such code." + where + namesOffReply = "Names are not enabled on this service, so name codes cannot be issued." + testGroupRevokeRepairsTracker :: HasCallStack => TestParams -> IO () testGroupRevokeRepairsTracker ps = withGroupOwner ps $ \_ cc _ alice -> do