diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index ed4204abb7..802221f976 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -11,6 +11,7 @@ module Directory.Events ( DirectoryEvent (..), DirectoryCmd (..), ADirectoryCmd (..), + DirectoryHelpSection (..), DirectoryRole (..), SDirectoryRole (..), crDirectoryEvent, @@ -25,6 +26,7 @@ import qualified Data.Attoparsec.Text as A import Data.Char (isSpace) import Data.Either (fromRight) import Data.Functor (($>)) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -45,7 +47,7 @@ data DirectoryEvent = DEContactConnected Contact | DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole} | DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember} - | DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo} + | DEGroupUpdated {member :: GroupMember, fromGroup :: GroupInfo, toGroup :: GroupInfo} | DEPendingMember GroupInfo GroupMember | DEPendingMemberMsg GroupInfo GroupMember ChatItemId Text | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed @@ -66,7 +68,7 @@ crDirectoryEvent = \case CRContactConnected {contact} -> Just $ DEContactConnected contact CRReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} CRUserJoinedGroup {groupInfo, hostMember} -> (\contactId -> DEServiceJoinedGroup {contactId, groupInfo, hostMember}) <$> memberContactId hostMember - CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_) + CRGroupUpdated {fromGroup, toGroup, member_} -> (\member -> DEGroupUpdated {member, fromGroup, toGroup}) <$> member_ CRJoinedGroupMember {groupInfo, member = m} | pending m -> Just $ DEPendingMember groupInfo m | otherwise -> Nothing @@ -137,8 +139,11 @@ deriving instance Show (DirectoryCmdTag r) data ADirectoryCmdTag = forall r. ADCT (SDirectoryRole r) (DirectoryCmdTag r) +data DirectoryHelpSection = DHSRegistration | DHSCommands + deriving (Show) + data DirectoryCmd (r :: DirectoryRole) where - DCHelp :: DirectoryCmd 'DRUser + DCHelp :: DirectoryHelpSection -> DirectoryCmd 'DRUser DCSearchGroup :: Text -> DirectoryCmd 'DRUser DCSearchNext :: DirectoryCmd 'DRUser DCAllGroups :: DirectoryCmd 'DRUser @@ -180,7 +185,7 @@ directoryCmdP = (tagP >>= \(ADCT u t) -> ADC u <$> (cmdP t <|> pure (DCCommandError t))) <|> pure (ADC SDRUser DCUnknownCommand) tagP = - A.takeTill (== ' ') >>= \case + A.takeTill isSpace >>= \case "help" -> u DCHelp_ "h" -> u DCHelp_ "next" -> u DCSearchNext_ @@ -213,11 +218,19 @@ directoryCmdP = su = pure . ADCT SDRSuperUser cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r) cmdP = \case - DCHelp_ -> pure DCHelp + DCHelp_ -> DCHelp . fromMaybe DHSRegistration <$> optional (A.takeWhile isSpace *> helpSectionP) + where + helpSectionP = + A.takeText >>= \case + "registration" -> pure DHSRegistration + "r" -> pure DHSRegistration + "commands" -> pure DHSCommands + "c" -> pure DHSCommands + _ -> fail "bad help section" DCSearchNext_ -> pure DCSearchNext DCAllGroups_ -> pure DCAllGroups DCRecentGroups_ -> pure DCRecentGroups - DCSubmitGroup_ -> fmap DCSubmitGroup . strDecode . encodeUtf8 <$?> (A.takeWhile1 isSpace *> A.takeText) + DCSubmitGroup_ -> fmap DCSubmitGroup . strDecode . encodeUtf8 <$?> (spacesP *> A.takeText) DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup DCListUserGroups_ -> pure DCListUserGroups DCDeleteGroup_ -> gc DCDeleteGroup @@ -228,7 +241,7 @@ directoryCmdP = DCGroupFilter_ -> do (groupId, displayName_) <- gc_ (,) acceptance_ <- - (A.takeWhile (== ' ') >> A.endOfInput) $> Nothing + (A.takeWhile isSpace >> A.endOfInput) $> Nothing <|> Just <$> (acceptancePresetsP <|> acceptanceFiltersP) pure $ DCGroupFilter groupId displayName_ acceptance_ where @@ -272,15 +285,15 @@ directoryCmdP = where gc f = f <$> (spacesP *> A.decimal) <*> (A.char ':' *> displayNameTextP) gc_ f = f <$> (spacesP *> A.decimal) <*> optional (A.char ':' *> displayNameTextP) - -- wordP = spacesP *> A.takeTill (== ' ') - spacesP = A.takeWhile1 (== ' ') + -- wordP = spacesP *> A.takeTill isSpace + spacesP = A.takeWhile1 isSpace viewName :: Text -> Text -viewName n = if T.any (== ' ') n then "'" <> n <> "'" else n +viewName n = if T.any isSpace n then "'" <> n <> "'" else n directoryCmdTag :: DirectoryCmd r -> Text directoryCmdTag = \case - DCHelp -> "help" + DCHelp _ -> "help" DCSearchGroup _ -> "search" DCSearchNext -> "next" DCAllGroups -> "all" diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 054f261b4e..bf998840f6 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -48,6 +48,7 @@ import Simplex.Chat.Bot import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller import Simplex.Chat.Core +import Simplex.Chat.Markdown (FormattedText (..), Format (..), parseMaybeMarkdownList) import Simplex.Chat.Messages import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) @@ -61,6 +62,7 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Shared import Simplex.Chat.View (serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), SConnectionMode (..), sameConnReqContact) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Encoding.String import Simplex.Messaging.TMap (TMap) @@ -185,13 +187,13 @@ useMemberFilter img_ = \case Nothing -> False readBlockedWordsConfig :: DirectoryOpts -> IO BlockedWordsConfig -readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, nameSpellingFile, blockedExtensionRules} = do +readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, nameSpellingFile, blockedExtensionRules, testing} = do extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules spelling <- maybe (pure M.empty) (fmap (M.fromList . read) . readFile) nameSpellingFile blockedFragments <- S.fromList <$> maybe (pure []) (fmap T.lines . T.readFile) blockedFragmentsFile bws <- maybe (pure []) (fmap lines . readFile) blockedWordsFile let blockedWords = S.fromList $ concatMap (wordVariants extensionRules) bws - putStrLn $ "Blocked fragments: " <> show (length blockedFragments) <> ", blocked words: " <> show (length blockedWords) <> ", spelling rules: " <> show (M.size spelling) + 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 :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> ChatResponse -> IO () @@ -200,7 +202,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName 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 {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup + DEGroupUpdated {member, fromGroup, toGroup} -> deGroupUpdated member fromGroup toGroup DEPendingMember g m -> dePendingMember g m DEPendingMemberMsg g m ciId t -> dePendingMemberMsg g m ciId t DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role @@ -253,17 +255,25 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName getDuplicateGroup GroupInfo {groupId, groupProfile = GroupProfile {displayName, fullName}} = getGroups fullName >>= mapM duplicateGroup where - sameGroup (GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}}, _) = - gId /= groupId && n == displayName && fn == fullName + sameGroupNotRemoved (g@GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}}, _) = + gId /= groupId && n == displayName && fn == fullName && not (memberRemoved $ membership g) duplicateGroup [] = pure DGUnique duplicateGroup groups = do - let gs = filter sameGroup groups + let gs = filter sameGroupNotRemoved groups if null gs then pure DGUnique else do (lgs, rgs) <- atomically $ (,) <$> readTVar (listedGroups st) <*> readTVar (reservedGroups st) let reserved = any (\(GroupInfo {groupId = gId}, _) -> gId `S.member` lgs || gId `S.member` rgs) gs - pure $ if reserved then DGReserved else DGRegistered + if reserved + then pure DGReserved + else do + removed <- foldM (\r -> fmap (r &&) . isGroupRemoved) True gs + pure $ if removed then DGUnique else DGRegistered + isGroupRemoved (GroupInfo {groupId = gId}, _) = + getGroupReg st gId >>= \case + Just GroupReg {groupRegStatus} -> groupRemoved <$> readTVarIO groupRegStatus + Nothing -> pure True processInvitation :: Contact -> GroupInfo -> IO () processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do @@ -354,78 +364,95 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName _ -> notifyOwner gr $ unexpectedError "can't create group link" _ -> notifyOwner gr $ unexpectedError "can't create group link" - deGroupUpdated :: ContactId -> GroupInfo -> GroupInfo -> IO () - deGroupUpdated ctId fromGroup toGroup = do + deGroupUpdated :: GroupMember -> GroupInfo -> GroupInfo -> IO () + deGroupUpdated m@GroupMember {memberProfile = LocalProfile {displayName = mName}} fromGroup toGroup = do logInfo $ "group updated " <> viewGroupName toGroup unless (sameProfile p p') $ do withGroupReg toGroup "group updated" $ \gr -> do let userGroupRef = userGroupReference gr toGroup + byMember = case memberContactId m of + Just ctId | ctId `isOwner` gr -> "" -- group registration owner, not any group owner. + _ -> " by " <> mName -- owner notification from directory will include the name. readTVarIO (groupRegStatus gr) >>= \case GRSPendingConfirmation -> pure () GRSProposed -> pure () GRSPendingUpdate -> groupProfileUpdate >>= \case GPNoServiceLink -> - when (ctId `isOwner` gr) $ notifyOwner gr $ "The profile updated for " <> userGroupRef <> ", but the group link is not added to the welcome message." - GPServiceLinkAdded - | ctId `isOwner` gr -> groupLinkAdded gr - | otherwise -> notifyOwner gr "The group link is added by another group member, your registration will not be processed.\n\nPlease update the group profile yourself." - GPServiceLinkRemoved -> when (ctId `isOwner` gr) $ notifyOwner gr $ "The group link of " <> userGroupRef <> " is removed from the welcome message, please add it." - GPHasServiceLink -> when (ctId `isOwner` gr) $ groupLinkAdded gr + notifyOwner gr $ "The profile updated for " <> userGroupRef <> byMember <> ", but the group link is not added to the welcome message." + GPServiceLinkAdded -> groupLinkAdded gr byMember + GPServiceLinkRemoved -> + notifyOwner gr $ + "The group link of " <> userGroupRef <> " is removed from the welcome message" <> byMember <> ", please add it." + GPHasServiceLink -> groupLinkAdded gr byMember GPServiceLinkError -> do - when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> userGroupRef <> ". Please report the error to the developers." + notifyOwner gr $ + ("Error: " <> serviceName <> " has no group link for " <> userGroupRef) + <> " after profile was updated" <> byMember <> ". Please report the error to the developers." logError $ "Error: no group link for " <> userGroupRef - GRSPendingApproval n -> processProfileChange gr $ n + 1 - GRSActive -> processProfileChange gr 1 - GRSSuspended -> processProfileChange gr 1 - GRSSuspendedBadRoles -> processProfileChange gr 1 + GRSPendingApproval n -> processProfileChange gr byMember $ n + 1 + GRSActive -> processProfileChange gr byMember 1 + GRSSuspended -> processProfileChange gr byMember 1 + GRSSuspendedBadRoles -> processProfileChange gr byMember 1 GRSRemoved -> pure () where - isInfix l d_ = l `T.isInfixOf` fromMaybe "" d_ GroupInfo {groupId, groupProfile = p} = fromGroup GroupInfo {groupProfile = p'} = toGroup sameProfile GroupProfile {displayName = n, fullName = fn, image = i, description = d} GroupProfile {displayName = n', fullName = fn', image = i', description = d'} = n == n' && fn == fn' && i == i' && d == d' - groupLinkAdded gr = do + groupLinkAdded gr byMember = do getDuplicateGroup toGroup >>= \case Nothing -> notifyOwner gr "Error: getDuplicateGroup. Please notify the developers." Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup _ -> do let gaId = 1 setGroupStatus st gr $ GRSPendingApproval gaId - notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 48 hours." + notifyOwner gr $ + ("Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message" <> byMember) + <> ".\nYou will be notified once the group is added to the directory - it may take up to 48 hours." checkRolesSendToApprove gr gaId - processProfileChange gr n' = do + processProfileChange gr byMember n' = do setGroupStatus st gr GRSPendingUpdate let userGroupRef = userGroupReference gr toGroup groupRef = groupReference toGroup groupProfileUpdate >>= \case GPNoServiceLink -> do - notifyOwner gr $ "The group profile is updated " <> userGroupRef <> ", but no link is added to the welcome message.\n\nThe group will remain hidden from the directory until the group link is added and the group is re-approved." + notifyOwner gr $ + ("The group profile is updated for " <> userGroupRef <> byMember <> ", but no link is added to the welcome message.\n\n") + <> "The group will remain hidden from the directory until the group link is added and the group is re-approved." GPServiceLinkRemoved -> do - notifyOwner gr $ "The group link for " <> userGroupRef <> " is removed from the welcome message.\n\nThe group is hidden from the directory until the group link is added and the group is re-approved." + notifyOwner gr $ + ("The group link for " <> userGroupRef <> " is removed from the welcome message" <> byMember) + <> ".\n\nThe group is hidden from the directory until the group link is added and the group is re-approved." notifyAdminUsers $ "The group link is removed from " <> groupRef <> ", de-listed." GPServiceLinkAdded -> do setGroupStatus st gr $ GRSPendingApproval n' - notifyOwner gr $ "The group link is added to " <> userGroupRef <> "!\nIt is hidden from the directory until approved." - notifyAdminUsers $ "The group link is added to " <> groupRef <> "." + notifyOwner gr $ + ("The group link is added to " <> userGroupRef <> byMember) + <> "!\nIt is hidden from the directory until approved." + notifyAdminUsers $ "The group link is added to " <> groupRef <> byMember <> "." checkRolesSendToApprove gr n' GPHasServiceLink -> do setGroupStatus st gr $ GRSPendingApproval n' - notifyOwner gr $ "The group " <> userGroupRef <> " is updated!\nIt is hidden from the directory until approved." - notifyAdminUsers $ "The group " <> groupRef <> " is updated." + notifyOwner gr $ + ("The group " <> userGroupRef <> " is updated" <> byMember) + <> "!\nIt is hidden from the directory until approved." + notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> "." checkRolesSendToApprove gr n' GPServiceLinkError -> logError $ "Error: no group link for " <> groupRef <> " pending approval." groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId) where profileUpdate = \case CRGroupLink {connReqContact} -> - let groupLink1 = strEncodeTxt connReqContact - groupLink2 = strEncodeTxt $ simplexChatContact connReqContact - hadLinkBefore = groupLink1 `isInfix` description p || groupLink2 `isInfix` description p - hasLinkNow = groupLink1 `isInfix` description p' || groupLink2 `isInfix` description p' + let hadLinkBefore = profileHasGroupLink fromGroup + hasLinkNow = profileHasGroupLink toGroup + profileHasGroupLink GroupInfo {groupProfile = gp} = + maybe False (any ftHasLink) $ parseMaybeMarkdownList =<< description gp + ftHasLink = \case + FormattedText (Just SimplexLink {simplexUri = ACR SCMContact cr'}) _ -> sameConnReqContact connReqContact cr' + _ -> False in if | hadLinkBefore && hasLinkNow -> GPHasServiceLink | hadLinkBefore -> GPServiceLinkRemoved @@ -617,7 +644,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO () deUserCommand ct ciId = \case - DCHelp -> + DCHelp DHSRegistration -> sendMessage cc ct $ "You must be the owner to add the group to the directory:\n\ \1. Invite " @@ -628,7 +655,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName <> " bot will create a public group link for the new members to join even when you are offline.\n\ \3. You will then need to add this link to the group welcome message.\n\ \4. Once the link is added, service admins will approve the group (it can take up to 48 hours), and everybody will be able to find it in directory.\n\n\ - \Start from inviting the bot to your group as admin - it will guide you through the process" + \Start from inviting the bot to your group as admin - it will guide you through the process." + DCHelp DHSCommands -> + sendMessage cc ct $ + "*/help commands* - receive this help message.\n\ + \*/help* - how to register your group to be added to directory.\n\ + \*/list* - list the groups you registered.\n\ + \*/delete :* - remove the group you submitted from directory, with _ID_ and _name_ as shown by */list* command.\n\ + \*/role * - view and set default member role for your group.\n\ + \*/filter * - view and set spam filter settings for group.\n\n\ + \To search for groups, send the search text." DCSearchGroup s -> withFoundListedGroups (Just s) $ sendSearchResults s DCSearchNext -> atomically (TM.lookup (contactId' ct) searchRequests) >>= \case @@ -667,10 +703,10 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName "0 registered groups for " <> localDisplayName' ct <> " (" <> tshow (contactId' ct) <> ") out of " <> tshow total <> " registrations" void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} -> sendGroupInfo ct gr userGroupRegId Nothing - DCDeleteGroup ugrId gName -> - withUserGroupReg ugrId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do + DCDeleteGroup gId gName -> + (if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do delGroupReg st gr - sendReply $ "Your group " <> displayName <> " is deleted from the directory" + sendReply $ (if isAdmin then "The group " else "Your group ") <> displayName <> " is deleted from the directory" DCMemberRole gId gName_ mRole_ -> (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> do let GroupInfo {groupProfile = GroupProfile {displayName = n}} = g @@ -802,9 +838,12 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName setGroupStatus st gr GRSActive let approved = "The group " <> userGroupReference' gr n <> " is approved" notifyOwner gr $ - (approved <> " and listed in directory!\n") + (approved <> " and listed in directory - please moderate it!\n") <> "Please note: if you change the group profile it will be hidden from directory until it is re-approved.\n\n" - <> ("Use */filter " <> tshow ugrId <> "* to configure anti-spam filter and */role " <> tshow ugrId <> "* to set default member role.") + <> "Supported commands:\n" + <> ("- */filter " <> tshow ugrId <> "* - to configure anti-spam filter.\n") + <> ("- */role " <> tshow ugrId <> "* - to set default member role.\n") + <> "- */help commands* - other commands." invited <- forM ownersGroup $ \og@KnownGroup {localDisplayName = ogName} -> do inviteToOwnersGroup og gr $ \case diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index fed52f494f..031d05fd49 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -25,6 +25,7 @@ module Directory.Store filterListedGroups, groupRegStatusText, pendingApproval, + groupRemoved, fromCustomData, toCustomData, noJoinFilter, @@ -139,13 +140,19 @@ data GroupRegStatus | GRSSuspended | GRSSuspendedBadRoles | GRSRemoved + deriving (Show) pendingApproval :: GroupRegStatus -> Bool pendingApproval = \case GRSPendingApproval _ -> True _ -> False -data DirectoryStatus = DSListed | DSReserved | DSRegistered +groupRemoved :: GroupRegStatus -> Bool +groupRemoved = \case + GRSRemoved -> True + _ -> False + +data DirectoryStatus = DSListed | DSReserved | DSRegistered | DSRemoved groupRegStatusText :: GroupRegStatus -> Text groupRegStatusText = \case @@ -163,6 +170,7 @@ grDirectoryStatus = \case GRSActive -> DSListed GRSSuspended -> DSReserved GRSSuspendedBadRoles -> DSReserved + GRSRemoved -> DSRemoved _ -> DSRegistered $(JQ.deriveJSON (enumJSON $ dropPrefix "PC") ''ProfileCondition) @@ -200,8 +208,9 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do | otherwise = mx delGroupReg :: DirectoryStore -> GroupReg -> IO () -delGroupReg st GroupReg {dbGroupId = gId} = do +delGroupReg st GroupReg {dbGroupId = gId, groupRegStatus} = do logGDelete st gId + atomically $ writeTVar groupRegStatus GRSRemoved atomically $ unlistGroup st gId atomically $ modifyTVar' (groupRegs st) $ filter ((gId ==) . dbGroupId) @@ -216,6 +225,7 @@ setGroupStatus st gr grStatus = do DSListed -> listGroup DSReserved -> reserveGroup DSRegistered -> unlistGroup + DSRemoved -> unlistGroup setGroupRegOwner :: DirectoryStore -> GroupReg -> GroupMember -> IO () setGroupRegOwner st gr owner = do @@ -390,6 +400,7 @@ mkDirectoryStore h groups = DSListed -> (grs', S.insert gId listed, reserved) DSReserved -> (grs', listed, S.insert gId reserved) DSRegistered -> (grs', listed, reserved) + DSRemoved -> (grs, listed, reserved) mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> IO DirectoryStore mkDirectoryStore_ h (grs, listed, reserved) = do diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index 0d1432c7e5..3ed2a8fa0b 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -49,7 +49,7 @@ data Format | Secret | Colored {color :: FormatColor} | Uri - | SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text} + | SimplexLink {linkType :: SimplexLinkType, simplexUri :: AConnectionRequestUri, smpHosts :: NonEmpty Text} | Mention {memberName :: Text} | Email | Phone @@ -255,12 +255,12 @@ markdownP = mconcat <$> A.many' fragmentP noFormat = pure . unmarked simplexUriFormat :: AConnectionRequestUri -> Format simplexUriFormat = \case - ACR _ (CRContactUri crData) -> - let uri = safeDecodeUtf8 . strEncode $ CRContactUri crData {crScheme = SSSimplex} - in SimplexLink (linkType' crData) uri $ uriHosts crData - ACR _ (CRInvitationUri crData e2e) -> - let uri = safeDecodeUtf8 . strEncode $ CRInvitationUri crData {crScheme = SSSimplex} e2e - in SimplexLink XLInvitation uri $ uriHosts crData + ACR m (CRContactUri crData) -> + let cReq = ACR m $ CRContactUri crData {crScheme = SSSimplex} + in SimplexLink (linkType' crData) cReq $ uriHosts crData + ACR m (CRInvitationUri crData e2e) -> + let cReq = ACR m $ CRInvitationUri crData {crScheme = SSSimplex} e2e + in SimplexLink XLInvitation cReq $ uriHosts crData where uriHosts ConnReqUriData {crSmpQueues} = L.map (safeDecodeUtf8 . strEncode) $ sconcat $ L.map (host . qServer) crSmpQueues linkType' ConnReqUriData {crClientData} = case crClientData >>= decodeJSON of diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 6601032a79..92d70727e3 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -34,6 +34,7 @@ directoryServiceTests = do it "should register group" testDirectoryService it "should suspend and resume group, send message to owner" testSuspendResume it "should delete group registration" testDeleteGroup + it "admin should delete group registration" testDeleteGroupAdmin it "should change initial member role" testSetRole it "should join found group via link" testJoinGroup it "should support group names with spaces" testGroupNameWithSpaces @@ -52,10 +53,12 @@ directoryServiceTests = do it "should NOT allow approving if roles are incorrect" testNotApprovedBadRoles describe "should require re-approval if profile is changed by" $ do it "the registration owner" testRegOwnerChangedProfile - it "another owner" testAnotherOwnerChangedProfile -- TODO fix - doesn't work if another owner is not connected as contact + it "another owner" testAnotherOwnerChangedProfile + it "another owner not connected to directory" testNotConnectedOwnerChangedProfile describe "should require profile update if group link is removed by " $ do it "the registration owner" testRegOwnerRemovedLink - it "another owner" testAnotherOwnerRemovedLink -- TODO fix - doesn't work if another owner is not connected as contact + it "another owner" testAnotherOwnerRemovedLink + it "another owner not connected to directory" testNotConnectedOwnerRemovedLink describe "duplicate groups (same display name and full name)" $ do it "should ask for confirmation if a duplicate group is submitted" testDuplicateAskConfirmation it "should prohibit registration if a duplicate group is listed" testDuplicateProhibitRegistration @@ -186,10 +189,13 @@ testDirectoryService ps = superUser #> "@SimpleX-Directory /approve 1:PSA 1" superUser <# "SimpleX-Directory> > /approve 1:PSA 1" superUser <## " Group approved!" - bob <# "SimpleX-Directory> The group ID 1 (PSA) is approved and listed in directory!" + bob <# "SimpleX-Directory> The group ID 1 (PSA) is approved and listed in directory - please moderate it!" bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." bob <## "" - bob <## "Use /filter 1 to configure anti-spam filter and /role 1 to set default member role." + bob <## "Supported commands:" + bob <## "- /filter 1 - to configure anti-spam filter." + bob <## "- /role 1 - to set default member role." + bob <## "- /help commands - other commands." search bob "privacy" welcomeWithLink' search bob "security" welcomeWithLink' cath `connectVia` dsLink @@ -266,6 +272,38 @@ testDeleteGroup ps = bob <## " Your group privacy is deleted from the directory" groupNotFound bob "privacy" +testDeleteGroupAdmin :: HasCallStack => TestParams -> IO () +testDeleteGroupAdmin ps = + withDirectoryService ps $ \superUser dsLink -> + withNewTestChat ps "bob" bobProfile $ \bob -> do + withNewTestChat ps "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + cath `connectVia` dsLink + registerGroupId superUser cath "security" "Security" 2 1 + groupFound bob "privacy" + groupFound bob "security" + listUserGroup bob "privacy" "Privacy" + listUserGroup cath "security" "Security" + superUser #> "@SimpleX-Directory /last" + superUser <# "SimpleX-Directory> > /last" + superUser <## " 2 registered group(s)" + memberGroupListing superUser bob 1 "privacy" "Privacy" 2 "active" + memberGroupListing superUser cath 2 "security" "Security" 2 "active" + -- trying to register group with the same name + submitGroup bob "security" "Security" + bob <# "SimpleX-Directory> The group security (Security) is already listed in the directory, please choose another name." + bob ##> "/d #security" + bob <## "#security: you deleted the group" + -- admin can delete the group + superUser #> "@SimpleX-Directory /delete 2:security" + superUser <# "SimpleX-Directory> > /delete 2:security" + superUser <## " The group security is deleted from the directory" + groupFound bob "privacy" + groupNotFound bob "security" + -- another user can register the group with the same name + registerGroupId superUser bob "security" "Security" 4 1 + testSetRole :: HasCallStack => TestParams -> IO () testSetRole ps = withDirectoryService ps $ \superUser dsLink -> @@ -726,13 +764,34 @@ testAnotherOwnerChangedProfile ps = cath <## "full name changed to: Privacy and Security" bob <## "cath updated group #privacy:" bob <## "full name changed to: Privacy and Security" - bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated!" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated by cath!" bob <## "It is hidden from the directory until approved." groupNotFound cath "privacy" - superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated by cath." reapproveGroup 3 superUser bob groupFoundN 3 cath "privacy" +testNotConnectedOwnerChangedProfile :: HasCallStack => TestParams -> IO () +testNotConnectedOwnerChangedProfile ps = + withDirectoryService ps $ \superUser dsLink -> + withNewTestChat ps "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> do + withNewTestChat ps "dan" danProfile $ \dan -> do + bob `connectVia` dsLink + dan `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + cath ##> "/gp privacy privacy Privacy and Security" + cath <## "full name changed to: Privacy and Security" + bob <## "cath updated group #privacy:" + bob <## "full name changed to: Privacy and Security" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated by cath!" + bob <## "It is hidden from the directory until approved." + groupNotFound dan "privacy" + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated by cath." + reapproveGroup 3 superUser bob + groupFoundN 3 dan "privacy" + testRegOwnerRemovedLink :: HasCallStack => TestParams -> IO () testRegOwnerRemovedLink ps = withDirectoryService ps $ \superUser dsLink -> @@ -758,14 +817,15 @@ testRegOwnerRemovedLink ps = cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory" cath <## "use @SimpleX-Directory to send messages" groupNotFound cath "privacy" - bob ##> ("/set welcome #privacy " <> welcomeWithLink) + let withChangedLink = T.unpack $ T.replace "contact#/?v=2-7&" "contact#/?v=3-7&" $ T.pack welcomeWithLink + bob ##> ("/set welcome #privacy " <> withChangedLink) bob <## "description changed to:" - bob <## welcomeWithLink + bob <## withChangedLink bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message." bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." cath <## "bob updated group #privacy:" cath <## "description changed to:" - cath <## welcomeWithLink + cath <## withChangedLink reapproveGroup 3 superUser bob groupFoundN 3 cath "privacy" @@ -789,7 +849,7 @@ testAnotherOwnerRemovedLink ps = bob <## "cath updated group #privacy:" bob <## "description changed to:" bob <## "Welcome!" - bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message." + bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message by cath." bob <## "" bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed." @@ -800,20 +860,55 @@ testAnotherOwnerRemovedLink ps = bob <## "cath updated group #privacy:" bob <## "description changed to:" bob <## welcomeWithLink - bob <# "SimpleX-Directory> The group link is added by another group member, your registration will not be processed." - bob <## "" - bob <## "Please update the group profile yourself." - bob ##> ("/set welcome #privacy " <> welcomeWithLink <> " - welcome!") - bob <## "description changed to:" - bob <## (welcomeWithLink <> " - welcome!") - bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message." + bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message by cath." bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." - cath <## "bob updated group #privacy:" - cath <## "description changed to:" - cath <## (welcomeWithLink <> " - welcome!") reapproveGroup 3 superUser bob groupFoundN 3 cath "privacy" +testNotConnectedOwnerRemovedLink :: HasCallStack => TestParams -> IO () +testNotConnectedOwnerRemovedLink ps = + withDirectoryService ps $ \superUser dsLink -> + withNewTestChat ps "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> do + withNewTestChat ps "dan" danProfile $ \dan -> do + bob `connectVia` dsLink + dan `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + bob ##> "/show welcome #privacy" + bob <## "Welcome message:" + welcomeWithLink <- getTermLine bob + cath ##> "/set welcome #privacy Welcome!" + cath <## "description changed to:" + cath <## "Welcome!" + bob <## "cath updated group #privacy:" + bob <## "description changed to:" + bob <## "Welcome!" + bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message by cath." + bob <## "" + bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." + superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed." + groupNotFound dan "privacy" + cath ##> ("/set welcome #privacy " <> welcomeWithLink) + cath <## "description changed to:" + cath <## welcomeWithLink + bob <## "cath updated group #privacy:" + bob <## "description changed to:" + bob <## welcomeWithLink + -- bob <# "SimpleX-Directory> The group link is added by another group member, your registration will not be processed." + -- bob <## "" + -- bob <## "Please update the group profile yourself." + -- bob ##> ("/set welcome #privacy " <> welcomeWithLink <> " - welcome!") + -- bob <## "description changed to:" + -- bob <## (welcomeWithLink <> " - welcome!") + bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message by cath." + bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." + -- cath <## "bob updated group #privacy:" + -- cath <## "description changed to:" + -- cath <## (welcomeWithLink <> " - welcome!") + reapproveGroup 3 superUser bob + groupFoundN 3 dan "privacy" + testDuplicateAskConfirmation :: HasCallStack => TestParams -> IO () testDuplicateAskConfirmation ps = withDirectoryService ps $ \superUser dsLink -> @@ -937,14 +1032,7 @@ testListUserGroups ps = cath <## "use @SimpleX-Directory to send messages" registerGroupId superUser bob "security" "Security" 2 2 registerGroupId superUser cath "anonymity" "Anonymity" 3 1 - cath #> "@SimpleX-Directory /list" - cath <# "SimpleX-Directory> > /list" - cath <## " 1 registered group(s)" - cath <# "SimpleX-Directory> 1. anonymity (Anonymity)" - cath <## "Welcome message:" - cath <##. "Link to join the group anonymity: " - cath <## "2 members" - cath <## "Status: active" + listUserGroup cath "anonymity" "Anonymity" -- with de-listed group groupFound cath "anonymity" cath ##> "/mr anonymity SimpleX-Directory member" @@ -1076,27 +1164,11 @@ testCaptcha _ps = do listGroups :: HasCallStack => TestCC -> TestCC -> TestCC -> IO () listGroups superUser bob cath = do - bob #> "@SimpleX-Directory /list" - bob <# "SimpleX-Directory> > /list" - bob <## " 2 registered group(s)" - bob <# "SimpleX-Directory> 1. privacy (Privacy)" - bob <## "Welcome message:" - bob <##. "Link to join the group privacy: " - bob <## "3 members" - bob <## "Status: active" - bob <# "SimpleX-Directory> 2. security (Security)" - bob <## "Welcome message:" - bob <##. "Link to join the group security: " - bob <## "2 members" - bob <## "Status: active" - cath #> "@SimpleX-Directory /list" - cath <# "SimpleX-Directory> > /list" - cath <## " 1 registered group(s)" - cath <# "SimpleX-Directory> 1. anonymity (Anonymity)" - cath <## "Welcome message:" - cath <##. "Link to join the group anonymity: " - cath <## "2 members" - cath <## "Status: suspended because roles changed" + sendListCommand bob 2 + groupListing bob 1 "privacy" "Privacy" 3 "active" + groupListing bob 2 "security" "Security" 2 "active" + sendListCommand cath 1 + groupListing cath 1 "anonymity" "Anonymity" 2 "suspended because roles changed" -- superuser lists all groups bob #> "@SimpleX-Directory /last" bob <# "SimpleX-Directory> > /last" @@ -1104,34 +1176,42 @@ listGroups superUser bob cath = do superUser #> "@SimpleX-Directory /last" superUser <# "SimpleX-Directory> > /last" superUser <## " 3 registered group(s)" - superUser <# "SimpleX-Directory> 1. privacy (Privacy)" - superUser <## "Welcome message:" - superUser <##. "Link to join the group privacy: " - superUser <## "Owner: bob" - superUser <## "3 members" - superUser <## "Status: active" - superUser <# "SimpleX-Directory> 2. security (Security)" - superUser <## "Welcome message:" - superUser <##. "Link to join the group security: " - superUser <## "Owner: bob" - superUser <## "2 members" - superUser <## "Status: active" - superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)" - superUser <## "Welcome message:" - superUser <##. "Link to join the group anonymity: " - superUser <## "Owner: cath" - superUser <## "2 members" - superUser <## "Status: suspended because roles changed" + memberGroupListing superUser bob 1 "privacy" "Privacy" 3 "active" + memberGroupListing superUser bob 2 "security" "Security" 2 "active" + memberGroupListing superUser cath 3 "anonymity" "Anonymity" 2 "suspended because roles changed" -- showing last 1 group superUser #> "@SimpleX-Directory /last 1" superUser <# "SimpleX-Directory> > /last 1" superUser <## " 3 registered group(s), showing the last 1" - superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)" - superUser <## "Welcome message:" - superUser <##. "Link to join the group anonymity: " - superUser <## "Owner: cath" - superUser <## "2 members" - superUser <## "Status: suspended because roles changed" + memberGroupListing superUser cath 3 "anonymity" "Anonymity" 2 "suspended because roles changed" + +listUserGroup :: HasCallStack => TestCC -> String -> String -> IO () +listUserGroup u n fn = do + sendListCommand u 1 + groupListing u 1 n fn 2 "active" + +sendListCommand :: HasCallStack => TestCC -> Int -> IO () +sendListCommand u count = do + u #> "@SimpleX-Directory /list" + u <# "SimpleX-Directory> > /list" + u <## (" " <> show count <> " registered group(s)") + +groupListing :: HasCallStack => TestCC -> Int -> String -> String -> Int -> String -> IO () +groupListing u = groupListing_ u Nothing + +memberGroupListing :: HasCallStack => TestCC -> TestCC -> Int -> String -> String -> Int -> String -> IO () +memberGroupListing su owner = groupListing_ su (Just owner) + +groupListing_ :: HasCallStack => TestCC -> Maybe TestCC -> Int -> String -> String -> Int -> String -> IO () +groupListing_ su owner_ gId n fn count status = do + su <# ("SimpleX-Directory> " <> show gId <> ". " <> n <> " (" <> fn <> ")") + su <## "Welcome message:" + su <##. ("Link to join the group " <> n <> ": ") + forM_ owner_ $ \owner -> do + ownerName <- userName owner + su <## ("Owner: " <> ownerName) + su <## (show count <> " members") + su <## ("Status: " <> status) reapproveGroup :: HasCallStack => Int -> TestCC -> TestCC -> IO () reapproveGroup count superUser bob = do @@ -1146,10 +1226,13 @@ reapproveGroup count superUser bob = do superUser #> "@SimpleX-Directory /approve 1:privacy 1" superUser <# "SimpleX-Directory> > /approve 1:privacy 1" superUser <## " Group approved!" - bob <# "SimpleX-Directory> The group ID 1 (privacy) is approved and listed in directory!" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is approved and listed in directory - please moderate it!" bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." bob <## "" - bob <## "Use /filter 1 to configure anti-spam filter and /role 1 to set default member role." + bob <## "Supported commands:" + bob <## "- /filter 1 - to configure anti-spam filter." + bob <## "- /role 1 - to set default member role." + bob <## "- /help commands - other commands." addCathAsOwner :: HasCallStack => TestCC -> TestCC -> IO () addCathAsOwner bob cath = do @@ -1293,10 +1376,13 @@ approveRegistrationId su u n gId ugId = do su #> ("@SimpleX-Directory " <> approve) su <# ("SimpleX-Directory> > " <> approve) su <## " Group approved!" - u <# ("SimpleX-Directory> The group ID " <> show ugId <> " (" <> n <> ") is approved and listed in directory!") + u <# ("SimpleX-Directory> The group ID " <> show ugId <> " (" <> n <> ") is approved and listed in directory - please moderate it!") u <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." u <## "" - u <## ("Use /filter " <> show ugId <> " to configure anti-spam filter and /role " <> show ugId <> " to set default member role.") + u <## "Supported commands:" + u <## ("- /filter " <> show ugId <> " - to configure anti-spam filter.") + u <## ("- /role " <> show ugId <> " - to set default member role.") + u <## "- /help commands - other commands." connectVia :: TestCC -> String -> IO () u `connectVia` dsLink = do diff --git a/tests/MarkdownTests.hs b/tests/MarkdownTests.hs index ec4e336fe9..fc872f05b1 100644 --- a/tests/MarkdownTests.hs +++ b/tests/MarkdownTests.hs @@ -8,7 +8,9 @@ module MarkdownTests where import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Simplex.Chat.Markdown +import Simplex.Messaging.Encoding.String import System.Console.ANSI.Types import Test.Hspec @@ -169,7 +171,12 @@ uri :: Text -> Markdown uri = Markdown $ Just Uri simplexLink :: SimplexLinkType -> Text -> NonEmpty Text -> Text -> Markdown -simplexLink linkType simplexUri smpHosts = Markdown $ Just SimplexLink {linkType, simplexUri, smpHosts} +simplexLink linkType uriText smpHosts t = Markdown (simplexLinkFormat linkType uriText smpHosts) t + +simplexLinkFormat :: SimplexLinkType -> Text -> NonEmpty Text -> Maybe Format +simplexLinkFormat linkType uriText smpHosts = case strDecode $ encodeUtf8 uriText of + Right simplexUri -> Just SimplexLink {linkType, simplexUri, smpHosts} + Left e -> error e textWithUri :: Spec textWithUri = describe "text with Uri" do @@ -275,6 +282,6 @@ multilineMarkdownList = describe "multiline markdown" do it "multiline with simplex link" do ("https://simplex.chat" <> inv <> "\ntext") <<==>> - [ FormattedText (Just $ SimplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"]) ("https://simplex.chat" <> inv), + [ FormattedText (simplexLinkFormat XLInvitation ("simplex:" <> inv) ["smp.simplex.im"]) ("https://simplex.chat" <> inv), "\ntext" ]