diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index ef6056fbc4..bfbc025a49 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -49,6 +49,7 @@ data DirectoryEvent | DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole} | DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember} | DEGroupUpdated {member :: GroupMember, fromGroup :: GroupInfo, toGroup :: GroupInfo} + | DEGroupLinkCheck GroupInfo | DEPendingMember GroupInfo GroupMember | DEPendingMemberMsg GroupInfo GroupMember ChatItemId Text | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 94305abaa2..f566ed5ded 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -42,6 +42,7 @@ data DirectoryOpts = DirectoryOpts runCLI :: Bool, searchResults :: Int, webFolder :: Maybe FilePath, + linkCheckInterval :: Int, testing :: Bool } @@ -162,6 +163,14 @@ directoryOpts appDir defaultDbName = do <> metavar "WEB_FOLDER" <> help "Folder to store static web assets" ) + linkCheckInterval <- + option + auto + ( long "link-check-interval" + <> metavar "SECONDS" + <> help "Interval in seconds to check public group link data (default: 1800)" + <> value 1800 + ) pure DirectoryOpts { coreOptions, @@ -182,6 +191,7 @@ directoryOpts appDir defaultDbName = do runCLI, searchResults = 10, webFolder, + linkCheckInterval, testing = False } diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index c1cf61f5a1..400f250979 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -18,8 +18,7 @@ module Directory.Service ) where -import Control.Concurrent (forkIO) -import Control.Concurrent.Async (race_) +import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM import Control.Exception (SomeException, try) import Control.Logger.Simple @@ -66,9 +65,10 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.View (serializeChatError, serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) -import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ACreatedConnLink (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), sameConnReqContact, sameShortLinkContact) +import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ACreatedConnLink (..), AgentErrorType (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), sameConnReqContact, sameShortLinkContact) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (ErrorType (..)) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (eitherToMaybe, raceAny_, safeDecodeUtf8, tshow, unlessM, (<$$>)) @@ -100,7 +100,9 @@ data ServiceState = ServiceState { searchRequests :: TMap ContactId SearchRequest, blockedWordsCfg :: BlockedWordsConfig, pendingCaptchas :: TMap GroupMemberId PendingCaptcha, - updateListingsJob :: TMVar ChatController + serviceCC :: TMVar ChatController, + eventQ :: TQueue DirectoryEvent, + updateListingsJob :: TMVar () } data CaptchaMode = CMText | CMAudio @@ -126,8 +128,10 @@ newServiceState opts = do searchRequests <- TM.emptyIO blockedWordsCfg <- readBlockedWordsConfig opts pendingCaptchas <- TM.emptyIO + serviceCC <- newEmptyTMVarIO + eventQ <- newTQueueIO updateListingsJob <- newEmptyTMVarIO - pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, updateListingsJob} + pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, serviceCC, eventQ, updateListingsJob} welcomeGetOpts :: IO DirectoryOpts welcomeGetOpts = do @@ -151,9 +155,8 @@ welcomeGetOpts = do directoryServiceCLI :: DirectoryLog -> DirectoryOpts -> IO () directoryServiceCLI st opts = do - env <- newServiceState opts - eventQ <- newTQueueIO - let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp) + env@ServiceState {eventQ} <- newServiceState opts + let eventHook _cc resp = atomically $ resp <$ mapM_ (writeTQueue eventQ) (crDirectoryEvent resp) chatHooks = defaultChatHooks { preStartHook = Just $ directoryPreStartHook opts, @@ -163,14 +166,18 @@ directoryServiceCLI st opts = do } raceAny_ $ [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing, - processEvents eventQ env + processEvents env ] <> maybeToList (updateListingsThread_ opts env) + <> maybeToList (linkCheckThread_ opts env) where - processEvents eventQ env = forever $ do - (cc, resp) <- atomically $ readTQueue eventQ + processEvents env@ServiceState {eventQ} = do + cc <- atomically $ readTMVar $ serviceCC env u_ <- readTVarIO (currentUser cc) - forM_ u_ $ \user -> directoryServiceEvent st opts env user cc resp + forM_ u_ $ \user -> + forever $ do + event <- atomically $ readTQueue eventQ + directoryServiceEvent st opts env user cc event updateListingDelay :: Int updateListingDelay = 5 * 60 * 1000000 -- update every 5 minutes @@ -179,15 +186,30 @@ updateListingsThread_ :: DirectoryOpts -> ServiceState -> Maybe (IO ()) updateListingsThread_ opts env = updateListingsThread <$> webFolder opts where updateListingsThread f = do - cc <- atomically $ takeTMVar $ updateListingsJob env + cc <- atomically $ readTMVar $ serviceCC env forever $ do u <- readTVarIO $ currentUser cc forM_ u $ \user -> updateGroupListingFiles cc user f delay <- registerDelay updateListingDelay atomically $ void (takeTMVar $ updateListingsJob env) `orElse` unlessM (readTVar delay) retry -listingsUpdated :: ServiceState -> ChatController -> IO () -listingsUpdated env = void . atomically . tryPutTMVar (updateListingsJob env) +listingsUpdated :: ServiceState -> IO () +listingsUpdated env = void $ atomically $ tryPutTMVar (updateListingsJob env) () + +linkCheckThread_ :: DirectoryOpts -> ServiceState -> Maybe (IO ()) +linkCheckThread_ opts env@ServiceState {eventQ} + | linkCheckInterval opts > 0 = Just $ do + cc <- atomically $ readTMVar $ serviceCC env + forever $ do + threadDelay $ linkCheckInterval opts * 1000000 + u <- readTVarIO $ currentUser cc + forM_ u $ \user -> + withDB' "linkCheckThread" cc (\db -> getAllGroupRegs_ db user) >>= \case + Left e -> logError $ "linkCheckThread error: " <> T.pack e + Right grs -> forM_ grs $ \(gInfo, gr) -> + unless (groupRemoved $ groupRegStatus gr) $ + atomically $ writeTQueue eventQ $ DEGroupLinkCheck gInfo + | otherwise = Nothing directoryPreStartHook :: DirectoryOpts -> ChatController -> IO () directoryPreStartHook opts ChatController {config, chatStore} = runDirectoryMigrations opts config chatStore @@ -198,7 +220,8 @@ directoryPostStartHook opts@DirectoryOpts {noAddress, testing} env cc = Nothing -> putStrLn "No current user" >> exitFailure Just User {userId, profile = p@LocalProfile {preferences}} -> do unless noAddress $ initializeBotAddress' (not testing) cc - listingsUpdated env cc + void $ atomically $ tryPutTMVar (serviceCC env) cc + listingsUpdated env let cmds = fromMaybe [] $ preferences >>= commands_ unless (cmds == directoryCommands) $ do let prefs = (fromMaybe emptyChatPrefs preferences) {files = Just FilesPreference {allow = FANo}, commands = Just directoryCommands} :: Preferences @@ -227,7 +250,7 @@ directoryCommands = directoryService :: DirectoryLog -> DirectoryOpts -> ChatConfig -> IO () directoryService st opts cfg = do - env <- newServiceState opts + env@ServiceState {eventQ} <- newServiceState opts let chatHooks = defaultChatHooks { preStartHook = Just $ directoryPreStartHook opts, @@ -235,10 +258,16 @@ directoryService st opts cfg = do acceptMember = Just $ acceptMemberHook opts env } simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \user cc -> - maybe id race_ (updateListingsThread_ opts env) $ - forever $ do - (_, resp) <- atomically . readTBQueue $ outputQ cc - directoryServiceEvent st opts env user cc resp + raceAny_ $ + [ forever $ do + (_, resp) <- atomically . readTBQueue $ outputQ cc + mapM_ (atomically . writeTQueue eventQ) $ crDirectoryEvent resp, + forever $ do + event <- atomically $ readTQueue eventQ + directoryServiceEvent st opts env user cc event + ] + <> maybeToList (updateListingsThread_ opts env) + <> maybeToList (linkCheckThread_ opts env) acceptMemberHook :: DirectoryOpts -> ServiceState -> GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)) acceptMemberHook @@ -281,13 +310,13 @@ readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, na unless testing $ putStrLn $ "Blocked fragments: " <> show (length blockedFragments) <> ", blocked words: " <> show (length blockedWords) <> ", spelling rules: " <> show (M.size spelling) pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling} -directoryServiceEvent :: DirectoryLog -> DirectoryOpts -> ServiceState -> User -> ChatController -> Either ChatError ChatEvent -> IO () -directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} env@ServiceState {searchRequests} user@User {userId} cc event = - forM_ (crDirectoryEvent event) $ \case +directoryServiceEvent :: DirectoryLog -> DirectoryOpts -> ServiceState -> User -> ChatController -> DirectoryEvent -> IO () +directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} env@ServiceState {searchRequests} user@User {userId} cc = \case DEContactConnected ct -> deContactConnected ct DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner DEGroupUpdated {member, fromGroup, toGroup} -> deGroupUpdated member fromGroup toGroup + DEGroupLinkCheck g -> deGroupLinkCheck g DEPendingMember g m -> dePendingMember g m DEPendingMemberMsg g m ciId t -> dePendingMemberMsg g m ciId t DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role @@ -762,6 +791,47 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let approveCmd = MCText $ "/approve " <> tshow groupId <> ":" <> viewName displayName <> " " <> tshow gaId <> if promoted then " promote=on" else "" sendComposedMessages cc (SRDirect cId) [msg, approveCmd] + deGroupLinkCheck :: GroupInfo -> IO () + deGroupLinkCheck gInfo@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}, groupSummary = summary} = + withGroupReg gInfo "link check" $ \gr@GroupReg {groupRegStatus, dbOwnerMemberId} -> + forM_ pg_ $ \pg@PublicGroupProfile {groupLink} -> + when (groupRegStatus == GRSActive || pendingApproval groupRegStatus) $ do + let link = ACL SCMContact $ CLShort groupLink + sendChatCmd cc (APIConnectPlan userId (Just link) True Nothing) >>= \case + Right (CRConnectionPlan _ _ (CPGroupLink (GLPKnown {groupInfo = g', groupUpdated = BoolDef updated, linkOwners = ListDef owners}))) -> + checkValidOwner dbOwnerMemberId owners $ do + when updated $ reapprove pg gr groupRegStatus g' + when (updated || summary /= groupSummary g') $ listingsUpdated env + Left (ChatErrorAgent {agentError = SMP _ err}) | linkDeleted err -> + setGroupStatus logError st env cc groupId GRSRemoved $ \gr' -> + notifyOwner gr' "The channel link is no longer valid.\nThe channel is removed from the directory." + _ -> pure () + where + linkDeleted = \case + AUTH -> True + BLOCKED {} -> True + _ -> False + checkValidOwner dbOwnerMemberId owners onValid = case dbOwnerMemberId of + Just ownerGMId -> + withDB "checkGroupLink" cc (\db -> withExceptT show $ getGroupMember db (vr cc) user groupId ownerGMId) >>= \case + Right GroupMember {memberId, memberPubKey} + | any (\GroupLinkOwner {memberId = mId, memberKey} -> memberId == mId && memberPubKey == Just memberKey) owners -> onValid + _ -> setGroupStatus logError st env cc groupId GRSSuspendedBadRoles $ \gr' -> + notifyOwner gr' "The registration owner is no longer a channel owner.\nThe channel is no longer listed in the directory." + Nothing -> onValid + reapprove pg gr groupRegStatus g' = do + let gt = groupTypeStr' pg + groupRef = groupReference gInfo + notifyAdminUsers $ "The " <> gt <> " " <> groupRef <> " profile changed." + case groupRegStatus of + GRSActive -> + setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval 1) $ \gr' -> do + notifyOwner gr' $ "The " <> gt <> " profile has changed.\nIt is hidden from the directory until approved." + sendToApprove g' gr' 1 + GRSPendingApproval n -> + sendToApprove g' gr (n + 1) + _ -> pure () + deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO () deContactRoleChanged g@GroupInfo {groupId, membership = GroupMember {memberRole = serviceRole}} ctId contactRole = do logInfo $ "contact ID " <> tshow ctId <> " role changed in group " <> viewGroupName g <> " to " <> tshow contactRole @@ -893,8 +963,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName (_, Just (OVFailed reason)) -> sendMessage cc ct $ "Link signature verification failed: " <> reason <> ".\nYou must be the " <> gt <> " owner to register it." (Nothing, _) -> sendMessage cc ct $ "Error: no " <> gt <> " information available via the link." _ -> sendMessage cc ct $ "Error: could not verify " <> gt <> " ownership. Please report it to directory admins." - GLPKnown {groupInfo = g, groupUpdated, ownerVerification} -> case ownerVerification of - Just OVVerified -> deReregistration ct g groupUpdated ownerSig + GLPKnown {groupInfo = g, groupUpdated = BoolDef updated, ownerVerification} -> case ownerVerification of + Just OVVerified -> deReregistration ct g updated ownerSig Just (OVFailed reason) -> sendMessage cc ct $ "Link signature verification failed: " <> reason <> ".\nYou must be the " <> gt <> " owner to register it." Nothing -> sendMessage cc ct $ "Error: could not verify " <> gt <> " ownership." GLPConnectingProhibit _ -> sendMessage cc ct $ "Already connecting to this " <> gt <> "." @@ -1408,7 +1478,7 @@ setGroupStatusPromo sendReply st env cc GroupReg {dbGroupId = gId} grStatus' grP Left e -> sendReply $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (status, grPromoted) -> do when ((status == DSListed || status' == DSListed) && (status /= status' || grPromoted /= grPromoted')) $ - listingsUpdated env cc + listingsUpdated env logGUpdateStatus st gId grStatus' logGUpdatePromotion st gId grPromoted' continue @@ -1428,7 +1498,7 @@ setGroupStatus sendMsg st env cc gId grStatus' continue = do Left e -> sendMsg $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (grStatus, gr) -> do let status = grDirectoryStatus grStatus - when ((status == DSListed || status' == DSListed) && status /= status') $ listingsUpdated env cc + when ((status == DSListed || status' == DSListed) && status /= status') $ listingsUpdated env logGUpdateStatus st gId grStatus' continue gr @@ -1437,7 +1507,7 @@ setGroupPromoted sendReply st env cc GroupReg {dbGroupId = gId} grPromoted' cont setGroupPromotedStore cc gId grPromoted' >>= \case Left e -> sendReply $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (status, grPromoted) -> do - when (status == DSListed && grPromoted' /= grPromoted) $ listingsUpdated env cc + when (status == DSListed && grPromoted' /= grPromoted) $ listingsUpdated env logGUpdatePromotion st gId grPromoted' continue diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index 2e4f64dcdd..ccef82eca9 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -95,6 +95,7 @@ This file is generated automatically. - [GroupInfo](#groupinfo) - [GroupKeys](#groupkeys) - [GroupLink](#grouplink) +- [GroupLinkOwner](#grouplinkowner) - [GroupLinkPlan](#grouplinkplan) - [GroupMember](#groupmember) - [GroupMemberAdmission](#groupmemberadmission) @@ -2264,6 +2265,15 @@ MemberSupport: - acceptMemberRole: [GroupMemberRole](#groupmemberrole) +--- + +## GroupLinkOwner + +**Record type**: +- memberId: string +- memberKey: string + + --- ## GroupLinkPlan @@ -2292,6 +2302,7 @@ Known: - groupInfo: [GroupInfo](#groupinfo) - groupUpdated: bool - ownerVerification: [OwnerVerification](#ownerverification)? +- linkOwners: [[GroupLinkOwner](#grouplinkowner)] NoRelays: - type: "noRelays" diff --git a/bots/src/API/Docs/Types.hs b/bots/src/API/Docs/Types.hs index de5b721b2d..50adf6f7e5 100644 --- a/bots/src/API/Docs/Types.hs +++ b/bots/src/API/Docs/Types.hs @@ -278,6 +278,7 @@ chatTypesDocsData = (sti @GroupKeys, STRecord, "", [], "", ""), (sti @GroupRootKey, STUnion, "GRK", [], "", ""), (sti @GroupLink, STRecord, "", [], "", ""), + (sti @GroupLinkOwner, STRecord, "", [], "", ""), (sti @GroupLinkPlan, STUnion, "GLP", [], "", ""), (sti @GroupMember, STRecord, "", [], "", ""), (sti @GroupMemberAdmission, STRecord, "", [], "", ""), @@ -482,6 +483,7 @@ deriving instance Generic GroupInfo deriving instance Generic GroupKeys deriving instance Generic GroupRootKey deriving instance Generic GroupLink +deriving instance Generic GroupLinkOwner deriving instance Generic GroupLinkPlan deriving instance Generic GroupMember deriving instance Generic GroupMemberAdmission diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index 08cb225cbc..7cc9205ff4 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -2565,6 +2565,11 @@ export interface GroupLink { acceptMemberRole: GroupMemberRole } +export interface GroupLinkOwner { + memberId: string + memberKey: string +} + export type GroupLinkPlan = | GroupLinkPlan.Ok | GroupLinkPlan.OwnLink @@ -2612,6 +2617,7 @@ export namespace GroupLinkPlan { groupInfo: GroupInfo groupUpdated: boolean ownerVerification?: OwnerVerification + linkOwners: GroupLinkOwner[] } export interface NoRelays extends Interface { diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index a7f4ceced0..0b263a6fa2 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -1037,10 +1037,16 @@ data GroupLinkPlan | GLPOwnLink {groupInfo :: GroupInfo} | GLPConnectingConfirmReconnect | GLPConnectingProhibit {groupInfo_ :: Maybe GroupInfo} - | GLPKnown {groupInfo :: GroupInfo, groupUpdated :: Bool, ownerVerification :: Maybe OwnerVerification} + | GLPKnown {groupInfo :: GroupInfo, groupUpdated :: BoolDef, ownerVerification :: Maybe OwnerVerification, linkOwners :: ListDef GroupLinkOwner} | GLPNoRelays {groupSLinkData_ :: Maybe GroupShortLinkData} deriving (Show) +data GroupLinkOwner = GroupLinkOwner + { memberId :: MemberId, + memberKey :: C.PublicKeyEd25519 + } + deriving (Show) + data OwnerVerification = OVVerified | OVFailed {reason :: Text} @@ -1662,6 +1668,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CAP") ''ContactAddressPlan) $(JQ.deriveJSON defaultJSON ''GroupShortLinkInfo) +$(JQ.deriveJSON defaultJSON ''GroupLinkOwner) + $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GLP") ''GroupLinkPlan) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "FC") ''ForwardConfirmation) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 7a5309164b..543014a346 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1772,15 +1772,14 @@ processChatCommand vr nm = \case APIGroupInfo gId -> withUser $ \user -> CRGroupInfo user <$> withFastStore (\db -> getGroupInfo db vr user gId) APIGetUpdatedGroupLinkData groupId -> withUser $ \user -> do - gInfo@GroupInfo {groupProfile = GroupProfile {publicGroup}} <- withFastStore $ \db -> getGroupInfo db vr user groupId - case publicGroup of - Just PublicGroupProfile {groupLink = sLnk} | useRelays' gInfo -> do + gInfo@GroupInfo {groupProfile = p, groupSummary = GroupSummary {publicMemberCount = localCount}} <- withFastStore $ \db -> getGroupInfo db vr user groupId + case p of + GroupProfile {publicGroup = Just PublicGroupProfile {groupLink = sLnk}} | useRelays' gInfo -> do (_, cData) <- getShortLinkConnReq nm user sLnk groupSLinkData_ <- liftIO $ decodeLinkUserData cData - let publicGroupData_ = groupSLinkData_ >>= \GroupShortLinkData {publicGroupData} -> publicGroupData - publicMemberCount_ = (\PublicGroupData {publicMemberCount} -> publicMemberCount) <$> publicGroupData_ - gInfo' <- fromMaybe gInfo - <$> forM publicMemberCount_ (\count -> withFastStore $ \db -> setPublicMemberCount db vr user gInfo count) + gInfo' <- case groupSLinkData_ of + Just sLinkData -> fst <$> updateGroupFromLinkData user gInfo sLinkData + _ -> pure gInfo pure $ CRGroupInfo user gInfo' _ -> throwCmdError "group link data not available" APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do @@ -4037,10 +4036,10 @@ processChatCommand vr nm = \case where l' = serverShortLink l con cReq = ACCL SCMContact $ CCLink cReq (Just l') - gPlan (cReq, g) = if memberRemoved (membership g) then Nothing else Just (con cReq, CPGroupLink (GLPKnown g False Nothing)) + gPlan (cReq, g) = if memberRemoved (membership g) then Nothing else Just (con cReq, CPGroupLink (GLPKnown g (BoolDef False) Nothing (ListDef []))) groupShortLinkPlan = knownLinkPlans >>= \case - Just (_, CPGroupLink (GLPKnown g _ _)) + Just (_, CPGroupLink (GLPKnown g _ _ _)) | resolveKnown -> resolveKnownGroup g Just r -> pure r Nothing -> do @@ -4065,15 +4064,15 @@ processChatCommand vr nm = \case liftIO (getGroupInfoViaUserShortLink db vr user l') >>= \case Just (cReq, g) -> pure $ Just (con cReq, CPGroupLink (GLPOwnLink g)) Nothing -> (gPlan =<<) <$> getGroupViaShortLinkToConnect db vr user l' - resolveKnownGroup g@GroupInfo {groupProfile = p} = do + resolveKnownGroup g = do (fd@FixedLinkData {rootKey = rk}, cData@(ContactLinkData _ UserContactData {owners})) <- getShortLinkConnReq' nm user l' groupSLinkData_ <- liftIO $ decodeLinkUserData cData let ov = verifyLinkOwner rk owners l' sig_ + glOwners = map (\OwnerAuth {ownerId, ownerKey} -> GroupLinkOwner {memberId = MemberId ownerId, memberKey = ownerKey}) owners (g', updated) <- case groupSLinkData_ of - Just GroupShortLinkData {groupProfile} - | p /= groupProfile -> (,True) <$> withStore (\db -> updateGroupProfile db user g groupProfile) + Just sLinkData -> updateGroupFromLinkData user g sLinkData _ -> pure (g, False) - pure (con (linkConnReq fd), CPGroupLink (GLPKnown g' updated ov)) + pure (con (linkConnReq fd), CPGroupLink (GLPKnown g' (BoolDef updated) ov (ListDef glOwners))) connectWithPlan :: User -> IncognitoEnabled -> ACreatedConnLink -> ConnectionPlan -> CM ChatResponse connectWithPlan user@User {userId} incognito ccLink plan | connectionPlanProceed plan = do @@ -4153,10 +4152,10 @@ processChatCommand vr nm = \case (Just gInfo, _) -> groupPlan gInfo linkInfo gld ov groupPlan :: GroupInfo -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan groupPlan gInfo@GroupInfo {membership} linkInfo gld ov - | memberStatus membership == GSMemRejected = pure $ CPGroupLink (GLPKnown gInfo False ov) + | memberStatus membership == GSMemRejected = pure $ CPGroupLink (GLPKnown gInfo (BoolDef False) ov (ListDef [])) | not (memberActive membership) && not (memberRemoved membership) = pure $ CPGroupLink (GLPConnectingProhibit $ Just gInfo) - | memberActive membership = pure $ CPGroupLink (GLPKnown gInfo False ov) + | memberActive membership = pure $ CPGroupLink (GLPKnown gInfo (BoolDef False) ov (ListDef [])) | otherwise = pure $ CPGroupLink (GLPOk linkInfo gld ov) contactCReqSchemas :: ConnReqUriData -> (ConnReqContact, ConnReqContact) contactCReqSchemas crData = diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index f82b6884b2..c6203b4b42 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -1328,6 +1328,24 @@ updatePublicGroupData user gInfo pure gInfo' | otherwise = pure gInfo +updateGroupFromLinkData :: User -> GroupInfo -> GroupShortLinkData -> CM (GroupInfo, Bool) +updateGroupFromLinkData user gInfo@GroupInfo {groupProfile = p, groupSummary = GroupSummary {publicMemberCount = localCount}} GroupShortLinkData {groupProfile, publicGroupData} + | profileChanged || countChanged = do + vr <- chatVersionRange + withStore $ \db -> do + g <- if profileChanged then updateGroupProfile db user gInfo groupProfile else pure gInfo + g' <- case publicGroupData of + Just PublicGroupData {publicMemberCount} | countChanged -> + setPublicMemberCount db vr user g publicMemberCount + _ -> pure g + pure (g', profileChanged) + | otherwise = pure (gInfo, False) + where + profileChanged = p /= groupProfile + countChanged = case publicGroupData of + Just PublicGroupData {publicMemberCount} -> Just publicMemberCount /= localCount + _ -> False + -- TODO [relays] owner: set owners on updating link data (multi-owner) groupLinkData :: GroupInfo -> GroupLink -> [GroupRelay] -> (UserConnLinkData 'CMContact, CRClientData) groupLinkData gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {publicMemberCount}, membership = GroupMember {memberId}, groupKeys} GroupLink {groupLinkId} groupRelays = diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 2bd48d297a..98eb811f5a 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -2103,7 +2103,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case GLPConnectingConfirmReconnect -> [grpLink "connecting, allowed to reconnect"] GLPConnectingProhibit Nothing -> [grpLink "connecting"] GLPConnectingProhibit (Just g) -> connecting g - GLPKnown g@GroupInfo {preparedGroup, membership = m} _ _ -> case preparedGroup of + GLPKnown g@GroupInfo {preparedGroup, membership = m} _ _ _ -> case preparedGroup of Just PreparedGroup {connLinkStartedConnection} -> case memberStatus m of GSMemUnknown | connLinkStartedConnection -> connecting g diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index bf2f1c8128..b57127eced 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -93,6 +93,7 @@ directoryServiceTests = do it "should reject card shared by non-owner" testNonOwnerSharesCard it "should delete channel registration and leave" testDeleteChannelRegistration it "should handle re-registration when already listed" testReregistrationAlreadyListed + it "should update subscriber count periodically" testLinkCheckUpdatesCount directoryProfile :: Profile directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing} @@ -128,6 +129,7 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = runCLI = False, searchResults = 3, webFolder, + linkCheckInterval = 0, testing = True } @@ -1976,7 +1978,7 @@ testRegisterChannelViaCard ps = superUser <## "news" superUser <##. "Link to join channel: " superUser <## "You need SimpleX Chat app v6.5 to join." - superUser <## "2 subscribers" + superUser <## "1 subscribers" superUser <## "" superUser <## "To approve send:" superUser <# "'SimpleX Directory'> /approve 1:news 1" @@ -1999,7 +2001,7 @@ testRegisterChannelViaCard ps = superUser <## "news (News and Updates)" superUser <##. "Link to join channel: " superUser <## "You need SimpleX Chat app v6.5 to join." - superUser <## "3 subscribers" + superUser <## "2 subscribers" superUser <## "" superUser <## "To approve send:" superUser <# "'SimpleX Directory'> /approve 1:news 1" @@ -2074,7 +2076,7 @@ testDeleteChannelRegistration ps = superUser <## "news" superUser <##. "Link to join channel: " superUser <## "You need SimpleX Chat app v6.5 to join." - superUser <## "2 subscribers" + superUser <## "1 subscribers" superUser <## "" superUser <## "To approve send:" superUser <# "'SimpleX Directory'> /approve 1:news 1" @@ -2118,7 +2120,7 @@ testReregistrationAlreadyListed ps = superUser <## "news" superUser <##. "Link to join channel: " superUser <## "You need SimpleX Chat app v6.5 to join." - superUser <## "2 subscribers" + superUser <## "1 subscribers" superUser <## "" superUser <## "To approve send:" superUser <# "'SimpleX Directory'> /approve 1:news 1" @@ -2135,7 +2137,7 @@ testReregistrationAlreadyListed ps = bob <# "'SimpleX Directory'> news" bob <##. "Link to join channel: " bob <## "You need SimpleX Chat app v6.5 to join." - bob <## "3 subscribers" + bob <## "1 subscribers" -- owner re-shares card while already listed bob ##> "/share chat #news @'SimpleX Directory'" bob <# "@'SimpleX Directory' link to join channel #news (signed):" @@ -2143,6 +2145,79 @@ testReregistrationAlreadyListed ps = _ <- getTermLine bob -- ownerSig JSON bob <# "'SimpleX Directory'> Channel is already listed in the directory." +testLinkCheckUpdatesCount :: HasCallStack => TestParams -> IO () +testLinkCheckUpdatesCount ps = do + dsLink <- + withNewTestChatCfg ps testCfg serviceDbPrefix directoryProfile $ \ds -> + withNewTestChatCfg ps testCfg "super_user" aliceProfile $ \superUser -> do + connectUsers ds superUser + ds ##> "/ad" + getContactLink ds True + let opts = (mkDirectoryOpts ps [KnownContact 2 "alice"] Nothing Nothing) {linkCheckInterval = 1} + runDirectory testCfg opts $ + withTestChatCfg ps testCfg "super_user" $ \superUser -> do + superUser <## "subscribed 1 connections on server localhost" + withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> + withRelay ps $ \relay -> + withNewTestChatCfg ps testCfg "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + (shortLink, fullLink) <- prepareChannel1Relay "news" bob relay + -- register and approve + bob ##> "/share chat #news @'SimpleX Directory'" + bob <# "@'SimpleX Directory' link to join channel #news (signed):" + _ <- getTermLine bob -- short link + _ <- getTermLine bob -- ownerSig JSON + bob <# "'SimpleX Directory'> Joining the channel news…" + concurrentlyN_ + [ do + relay <## "'SimpleX Directory': accepting request to join group #news..." + relay <## "#news: 'SimpleX Directory' joined the group", + bob <## "#news: relay added 'SimpleX Directory_1' to the group" + ] + bob <# "'SimpleX Directory'> Joined the channel news. Registration is pending approval — it may take up to 48 hours." + superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" + superUser <## "news" + superUser <##. "Link to join channel: " + superUser <## "You need SimpleX Chat app v6.5 to join." + superUser <## "1 subscribers" + superUser <## "" + superUser <## "To approve send:" + superUser <# "'SimpleX Directory'> /approve 1:news 1" + let approve = "/approve 1:news 1" + superUser #> ("@'SimpleX Directory' " <> approve) + superUser <# ("'SimpleX Directory'> > " <> approve) + superUser <## " Channel approved!" + bob <# ("'SimpleX Directory'> The channel ID 1 (news) is approved and listed in directory - please moderate it!") + bob <## "Please note: if you change the channel profile it will be hidden from directory until it is re-approved." + -- search shows initial count + bob #> "@'SimpleX Directory' news" + bob <# "'SimpleX Directory'> > news" + bob <## " Found 1 group(s)." + bob <# "'SimpleX Directory'> news" + bob <##. "Link to join channel: " + bob <## "You need SimpleX Chat app v6.5 to join." + bob <## "1 subscribers" + -- link check updates count (bot joined) + threadDelay 1000000 + bob #> "@'SimpleX Directory' news" + bob <# "'SimpleX Directory'> > news" + bob <## " Found 1 group(s)." + bob <# "'SimpleX Directory'> news" + bob <##. "Link to join channel: " + bob <## "You need SimpleX Chat app v6.5 to join." + bob <## "2 subscribers" + -- second subscriber joins + memberJoinChannel "news" [relay] [bob] shortLink fullLink cath + -- link check updates count again + threadDelay 1000000 + bob #> "@'SimpleX Directory' news" + bob <# "'SimpleX Directory'> > news" + bob <## " Found 1 group(s)." + bob <# "'SimpleX Directory'> news" + bob <##. "Link to join channel: " + bob <## "You need SimpleX Chat app v6.5 to join." + bob <## "3 subscribers" + testGetCaptchaStr :: HasCallStack => TestParams -> IO () testGetCaptchaStr _ps = do s0 <- getCaptchaStr 0 ""