From b2de37a9fb309284584e6691323270320c31af19 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 3 Mar 2025 18:57:29 +0000 Subject: [PATCH] core: member acceptance (#5678) * core: member acceptance * migration * move hook * core: support sending direct messages to members (#5680) * fix compilation, todos * fix test * predicates * comment * extend hook * wip * wip * wip * wip * fix test * mute output * schema * better query * plans * fix test * directory * captcha * captcha works * remove column, add UI types and group status icon * fix test * query plans * exclude messages of pending members from history * commands for filter settings * core: separately delete pending approval members; other apis validation (#5699) * accepted status * send captcha messages as replies * fix blocked words * simpler filter info * info about /filter and /role after group registration * update query plans --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --- .../Views/ChatList/ChatPreviewView.swift | 2 +- apps/ios/SimpleXChat/ChatTypes.swift | 5 + .../chat/simplex/common/model/ChatModel.kt | 5 + .../commonMain/resources/MR/base/strings.xml | 2 + .../resources/MR/images/ic_help_filled.svg | 1 + apps/simplex-directory-service/Main.hs | 7 +- .../src/Directory/BlockedWords.hs | 55 ++- .../src/Directory/Events.hs | 75 +++- .../src/Directory/Options.hs | 38 +- .../src/Directory/Service.hs | 384 +++++++++++++----- .../src/Directory/Store.hs | 127 ++++-- simplex-chat.cabal | 8 +- src/Simplex/Chat.hs | 3 - src/Simplex/Chat/Bot.hs | 17 +- src/Simplex/Chat/Controller.hs | 46 ++- src/Simplex/Chat/Library/Commands.hs | 207 ++++++---- src/Simplex/Chat/Library/Internal.hs | 161 +++++++- src/Simplex/Chat/Library/Subscriber.hs | 247 ++++------- src/Simplex/Chat/Messages.hs | 2 + src/Simplex/Chat/ProfileGenerator.hs | 13 - src/Simplex/Chat/Protocol.hs | 7 + src/Simplex/Chat/Store.hs | 1 + src/Simplex/Chat/Store/Groups.hs | 19 +- src/Simplex/Chat/Store/Messages.hs | 27 +- src/Simplex/Chat/Store/Profiles.hs | 40 +- .../SQLite/Migrations/chat_query_plans.txt | 4 +- src/Simplex/Chat/Types.hs | 12 + src/Simplex/Chat/Types/Shared.hs | 24 ++ src/Simplex/Chat/View.hs | 18 +- tests/Bots/DirectoryTests.hs | 15 +- tests/ChatTests/Groups.hs | 137 ++++++- tests/SchemaDump.hs | 4 +- 32 files changed, 1188 insertions(+), 525 deletions(-) create mode 100644 apps/multiplatform/common/src/commonMain/resources/MR/images/ic_help_filled.svg diff --git a/apps/ios/Shared/Views/ChatList/ChatPreviewView.swift b/apps/ios/Shared/Views/ChatList/ChatPreviewView.swift index 6969ae325c..7f92862f66 100644 --- a/apps/ios/Shared/Views/ChatList/ChatPreviewView.swift +++ b/apps/ios/Shared/Views/ChatList/ChatPreviewView.swift @@ -154,7 +154,7 @@ struct ChatPreviewView: View { } } - @ViewBuilder private func inactiveIcon() -> some View { + private func inactiveIcon() -> some View { Image(systemName: "multiply.circle.fill") .foregroundColor(.secondary.opacity(0.65)) .background(Circle().foregroundColor(Color(uiColor: .systemBackground))) diff --git a/apps/ios/SimpleXChat/ChatTypes.swift b/apps/ios/SimpleXChat/ChatTypes.swift index a601e60d5f..468bc2ea8f 100644 --- a/apps/ios/SimpleXChat/ChatTypes.swift +++ b/apps/ios/SimpleXChat/ChatTypes.swift @@ -2147,6 +2147,7 @@ public struct GroupMember: Identifiable, Decodable, Hashable { case .memGroupDeleted: return false case .memUnknown: return false case .memInvited: return false + case .memPendingApproval: return true case .memIntroduced: return false case .memIntroInvited: return false case .memAccepted: return false @@ -2165,6 +2166,7 @@ public struct GroupMember: Identifiable, Decodable, Hashable { case .memGroupDeleted: return false case .memUnknown: return false case .memInvited: return false + case .memPendingApproval: return false case .memIntroduced: return true case .memIntroInvited: return true case .memAccepted: return true @@ -2296,6 +2298,7 @@ public enum GroupMemberStatus: String, Decodable, Hashable { case memGroupDeleted = "deleted" case memUnknown = "unknown" case memInvited = "invited" + case memPendingApproval = "pending_approval" case memIntroduced = "introduced" case memIntroInvited = "intro-inv" case memAccepted = "accepted" @@ -2312,6 +2315,7 @@ public enum GroupMemberStatus: String, Decodable, Hashable { case .memGroupDeleted: return "group deleted" case .memUnknown: return "unknown status" case .memInvited: return "invited" + case .memPendingApproval: return "pending approval" case .memIntroduced: return "connecting (introduced)" case .memIntroInvited: return "connecting (introduction invitation)" case .memAccepted: return "connecting (accepted)" @@ -2330,6 +2334,7 @@ public enum GroupMemberStatus: String, Decodable, Hashable { case .memGroupDeleted: return "group deleted" case .memUnknown: return "unknown" case .memInvited: return "invited" + case .memPendingApproval: return "pending" case .memIntroduced: return "connecting" case .memIntroInvited: return "connecting" case .memAccepted: return "connecting" diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt index f784dcb9ed..7afcd69487 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt @@ -1917,6 +1917,7 @@ data class GroupMember ( GroupMemberStatus.MemGroupDeleted -> false GroupMemberStatus.MemUnknown -> false GroupMemberStatus.MemInvited -> false + GroupMemberStatus.MemPendingApproval -> true GroupMemberStatus.MemIntroduced -> false GroupMemberStatus.MemIntroInvited -> false GroupMemberStatus.MemAccepted -> false @@ -1933,6 +1934,7 @@ data class GroupMember ( GroupMemberStatus.MemGroupDeleted -> false GroupMemberStatus.MemUnknown -> false GroupMemberStatus.MemInvited -> false + GroupMemberStatus.MemPendingApproval -> false GroupMemberStatus.MemIntroduced -> true GroupMemberStatus.MemIntroInvited -> true GroupMemberStatus.MemAccepted -> true @@ -2037,6 +2039,7 @@ enum class GroupMemberStatus { @SerialName("deleted") MemGroupDeleted, @SerialName("unknown") MemUnknown, @SerialName("invited") MemInvited, + @SerialName("pending_approval") MemPendingApproval, @SerialName("introduced") MemIntroduced, @SerialName("intro-inv") MemIntroInvited, @SerialName("accepted") MemAccepted, @@ -2052,6 +2055,7 @@ enum class GroupMemberStatus { MemGroupDeleted -> generalGetString(MR.strings.group_member_status_group_deleted) MemUnknown -> generalGetString(MR.strings.group_member_status_unknown) MemInvited -> generalGetString(MR.strings.group_member_status_invited) + MemPendingApproval -> generalGetString(MR.strings.group_member_status_pending_approval) MemIntroduced -> generalGetString(MR.strings.group_member_status_introduced) MemIntroInvited -> generalGetString(MR.strings.group_member_status_intro_invitation) MemAccepted -> generalGetString(MR.strings.group_member_status_accepted) @@ -2068,6 +2072,7 @@ enum class GroupMemberStatus { MemGroupDeleted -> generalGetString(MR.strings.group_member_status_group_deleted) MemUnknown -> generalGetString(MR.strings.group_member_status_unknown_short) MemInvited -> generalGetString(MR.strings.group_member_status_invited) + MemPendingApproval -> generalGetString(MR.strings.group_member_status_pending_approval_short) MemIntroduced -> generalGetString(MR.strings.group_member_status_connecting) MemIntroInvited -> generalGetString(MR.strings.group_member_status_connecting) MemAccepted -> generalGetString(MR.strings.group_member_status_connecting) diff --git a/apps/multiplatform/common/src/commonMain/resources/MR/base/strings.xml b/apps/multiplatform/common/src/commonMain/resources/MR/base/strings.xml index d6f182bc02..52e25a6d8d 100644 --- a/apps/multiplatform/common/src/commonMain/resources/MR/base/strings.xml +++ b/apps/multiplatform/common/src/commonMain/resources/MR/base/strings.xml @@ -1632,6 +1632,8 @@ group deleted unknown status invited + pending approval + pending connecting (introduced) connecting (introduction invitation) connecting (accepted) diff --git a/apps/multiplatform/common/src/commonMain/resources/MR/images/ic_help_filled.svg b/apps/multiplatform/common/src/commonMain/resources/MR/images/ic_help_filled.svg new file mode 100644 index 0000000000..ba3d3a393a --- /dev/null +++ b/apps/multiplatform/common/src/commonMain/resources/MR/images/ic_help_filled.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index b01f088483..2091ab444b 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/apps/simplex-directory-service/Main.hs @@ -5,7 +5,9 @@ module Main where import Directory.Options import Directory.Service import Directory.Store +import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks) import Simplex.Chat.Core +import Simplex.Chat.Terminal (terminalChatConfig) main :: IO () main = do @@ -14,5 +16,6 @@ main = do if runCLI then directoryServiceCLI st opts else do - cfg <- directoryChatConfig opts - simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts + env <- newServiceState opts + let cfg = terminalChatConfig {chatHooks = defaultChatHooks {acceptMember = Just $ acceptMemberHook opts env}} + simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts env diff --git a/apps/simplex-directory-service/src/Directory/BlockedWords.hs b/apps/simplex-directory-service/src/Directory/BlockedWords.hs index 7477226e53..a29e2c99e0 100644 --- a/apps/simplex-directory-service/src/Directory/BlockedWords.hs +++ b/apps/simplex-directory-service/src/Directory/BlockedWords.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + module Directory.BlockedWords where import Data.Char (isMark, isPunctuation, isSpace) @@ -5,28 +8,38 @@ import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Data.Set (Set) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Normalize as TN -containsBlockedWords :: Map Char [Char] -> [String] -> Text -> Bool -containsBlockedWords spelling blockedWords s = - let normalizedWords = concatMap words $ normalizeText spelling s - -- Fully normalize the entire string (no spaces or punctuation) - fullNorm = normalizeText spelling $ T.filter (not . isSpace) s - -- Check if any individual word is a swear word - wordCheck = any (`elem` blockedWords) normalizedWords - -- Check if the full string, when normalized, matches a swear word exactly - fullCheck = any (\bw -> T.length s <= length bw * 2 && any (bw ==) fullNorm) blockedWords - -- Check if the string is a single word (no spaces) - isSingleWord = not $ T.any isSpace s - in wordCheck || (fullCheck && not isSingleWord) +data BlockedWordsConfig = BlockedWordsConfig + { blockedWords :: Set Text, + blockedFragments :: Set Text, + extensionRules :: [(String, [String])], + spelling :: Map Char [Char] + } -normalizeText :: Map Char [Char] -> Text -> [String] -normalizeText spelling = - filter (not . null) - . map (filter (\c -> not (isPunctuation c) && not (isMark c))) - . allSubstitutions spelling +hasBlockedFragments :: BlockedWordsConfig -> Text -> Bool +hasBlockedFragments BlockedWordsConfig {spelling, blockedFragments} s = + any (\w -> any (`T.isInfixOf` w) blockedFragments) ws + where + ws = S.fromList $ filter (not . T.null) $ normalizeText spelling s + +hasBlockedWords :: BlockedWordsConfig -> Text -> Bool +hasBlockedWords BlockedWordsConfig {spelling, blockedWords} s = + not $ ws1 `S.disjoint` blockedWords && (length ws <= 1 || ws2 `S.disjoint` blockedWords) + where + ws = T.words s + ws1 = normalizeWords ws + ws2 = normalizeWords $ T.splitOn " " s + normalizeWords = S.fromList . filter (not . T.null) . concatMap (normalizeText spelling) + +normalizeText :: Map Char [Char] -> Text -> [Text] +normalizeText spelling' = + map (T.pack . filter (\c -> not $ isSpace c || isPunctuation c || isMark c)) + . allSubstitutions spelling' . removeTriples . T.unpack . T.toLower @@ -44,12 +57,12 @@ removeTriples xs = go xs '\0' False -- Generate all possible strings by substituting each character allSubstitutions :: Map Char [Char] -> String -> [String] -allSubstitutions spelling = sequence . map substs +allSubstitutions spelling' = sequence . map substs where - substs c = fromMaybe [c] $ M.lookup c spelling + substs c = fromMaybe [c] $ M.lookup c spelling' -wordVariants :: [(String, [String])] -> String -> [String] -wordVariants [] s = [s] +wordVariants :: [(String, [String])] -> String -> [Text] +wordVariants [] s = [T.pack s] wordVariants (sub : subs) s = concatMap (wordVariants subs) (replace sub) where replace (pat, tos) = go s diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index adaccf612f..89099ab9df 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -19,7 +19,7 @@ module Directory.Events ) where -import Control.Applicative ((<|>)) +import Control.Applicative (optional, (<|>)) import Data.Attoparsec.Text (Parser) import qualified Data.Attoparsec.Text as A import Data.Char (isSpace) @@ -46,6 +46,8 @@ data DirectoryEvent | DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole} | DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember} | DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo} + | DEPendingMember GroupInfo GroupMember + | DEPendingMemberMsg GroupInfo GroupMember ChatItemId Text | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed | DEServiceRoleChanged GroupInfo GroupMemberRole | DEContactRemovedFromGroup ContactId GroupInfo @@ -65,6 +67,12 @@ crDirectoryEvent = \case 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_) + CRJoinedGroupMember {groupInfo, member = m} + | pending m -> Just $ DEPendingMember groupInfo m + | otherwise -> Nothing + CRNewChatItems {chatItems = AChatItem _ _ (GroupChat g) ci : _} -> case ci of + ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent (MCText t)} | pending m -> Just $ DEPendingMemberMsg g m (chatItemId' ci) t + _ -> Nothing CRMemberRole {groupInfo, member, toRole} | groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole | otherwise -> (\ctId -> DEContactRoleChanged groupInfo ctId toRole) <$> memberContactId member @@ -89,6 +97,8 @@ crDirectoryEvent = \case _ -> Just $ DELogChatResponse $ "chat error: " <> tshow chatError CRChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors) _ -> Nothing + where + pending m = memberStatus m == GSMemPendingApproval data DirectoryRole = DRUser | DRAdmin | DRSuperUser @@ -108,7 +118,8 @@ data DirectoryCmdTag (r :: DirectoryRole) where DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser DCListUserGroups_ :: DirectoryCmdTag 'DRUser DCDeleteGroup_ :: DirectoryCmdTag 'DRUser - DCSetRole_ :: DirectoryCmdTag 'DRUser + DCMemberRole_ :: DirectoryCmdTag 'DRUser + DCGroupFilter_ :: DirectoryCmdTag 'DRUser DCApproveGroup_ :: DirectoryCmdTag 'DRAdmin DCRejectGroup_ :: DirectoryCmdTag 'DRAdmin DCSuspendGroup_ :: DirectoryCmdTag 'DRAdmin @@ -118,6 +129,8 @@ data DirectoryCmdTag (r :: DirectoryRole) where DCShowGroupLink_ :: DirectoryCmdTag 'DRAdmin DCSendToGroupOwner_ :: DirectoryCmdTag 'DRAdmin DCInviteOwnerToGroup_ :: DirectoryCmdTag 'DRAdmin + -- DCAddBlockedWord_ :: DirectoryCmdTag 'DRAdmin + -- DCRemoveBlockedWord_ :: DirectoryCmdTag 'DRAdmin DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser deriving instance Show (DirectoryCmdTag r) @@ -134,7 +147,8 @@ data DirectoryCmd (r :: DirectoryRole) where DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser DCListUserGroups :: DirectoryCmd 'DRUser DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser - DCSetRole :: GroupId -> GroupName -> GroupMemberRole -> DirectoryCmd 'DRUser + DCMemberRole :: UserGroupRegId -> Maybe GroupName -> Maybe GroupMemberRole -> DirectoryCmd 'DRUser + DCGroupFilter :: UserGroupRegId -> Maybe GroupName -> Maybe DirectoryMemberAcceptance -> DirectoryCmd 'DRUser DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin @@ -144,6 +158,8 @@ data DirectoryCmd (r :: DirectoryRole) where DCShowGroupLink :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin DCSendToGroupOwner :: GroupId -> GroupName -> Text -> DirectoryCmd 'DRAdmin DCInviteOwnerToGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin + -- DCAddBlockedWord :: Text -> DirectoryCmd 'DRAdmin + -- DCRemoveBlockedWord :: Text -> DirectoryCmd 'DRAdmin DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser DCUnknownCommand :: DirectoryCmd 'DRUser DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r @@ -175,7 +191,8 @@ directoryCmdP = "list" -> u DCListUserGroups_ "ls" -> u DCListUserGroups_ "delete" -> u DCDeleteGroup_ - "role" -> u DCSetRole_ + "role" -> u DCMemberRole_ + "filter" -> u DCGroupFilter_ "approve" -> au DCApproveGroup_ "reject" -> au DCRejectGroup_ "suspend" -> au DCSuspendGroup_ @@ -185,6 +202,8 @@ directoryCmdP = "link" -> au DCShowGroupLink_ "owner" -> au DCSendToGroupOwner_ "invite" -> au DCInviteOwnerToGroup_ + -- "block_word" -> au DCAddBlockedWord_ + -- "unblock_word" -> au DCRemoveBlockedWord_ "exec" -> su DCExecuteCommand_ "x" -> su DCExecuteCommand_ _ -> fail "bad command tag" @@ -202,10 +221,36 @@ directoryCmdP = DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup DCListUserGroups_ -> pure DCListUserGroups DCDeleteGroup_ -> gc DCDeleteGroup - DCSetRole_ -> do - (groupId, displayName) <- gc (,) - memberRole <- A.space *> ("member" $> GRMember <|> "observer" $> GRObserver) - pure $ DCSetRole groupId displayName memberRole + DCMemberRole_ -> do + (groupId, displayName_) <- gc_ (,) + memberRole_ <- optional $ spacesP *> ("member" $> GRMember <|> "observer" $> GRObserver) + pure $ DCMemberRole groupId displayName_ memberRole_ + DCGroupFilter_ -> do + (groupId, displayName_) <- gc_ (,) + acceptance_ <- + (A.takeWhile (== ' ') >> A.endOfInput) $> Nothing + <|> Just <$> (acceptancePresetsP <|> acceptanceFiltersP) + pure $ DCGroupFilter groupId displayName_ acceptance_ + where + acceptancePresetsP = + spacesP + *> A.choice + [ "no" $> noJoinFilter, + "basic" $> basicJoinFilter, + ("moderate" <|> "mod") $> moderateJoinFilter, + "strong" $> strongJoinFilter + ] + acceptanceFiltersP = do + rejectNames <- filterP "name" + passCaptcha <- filterP "captcha" + makeObserver <- filterP "observer" + pure DirectoryMemberAcceptance {rejectNames, passCaptcha, makeObserver} + filterP :: Text -> Parser (Maybe ProfileCondition) + filterP s = Just <$> (spacesP *> A.string s *> conditionP) <|> pure Nothing + conditionP = + "=all" $> PCAll + <|> ("=noimage" <|> "=no_image" <|> "=no-image") $> PCNoImage + <|> pure PCAll DCApproveGroup_ -> do (groupId, displayName) <- gc (,) groupApprovalId <- A.space *> A.decimal @@ -221,9 +266,14 @@ directoryCmdP = msg <- A.space *> A.takeText pure $ DCSendToGroupOwner groupId displayName msg DCInviteOwnerToGroup_ -> gc DCInviteOwnerToGroup - DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText) + -- DCAddBlockedWord_ -> DCAddBlockedWord <$> wordP + -- DCRemoveBlockedWord_ -> DCRemoveBlockedWord <$> wordP + DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (spacesP *> A.takeText) where - gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameTextP + 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 (== ' ') viewName :: Text -> Text viewName n = if T.any (== ' ') n then "'" <> n <> "'" else n @@ -240,7 +290,8 @@ directoryCmdTag = \case DCListUserGroups -> "list" DCDeleteGroup {} -> "delete" DCApproveGroup {} -> "approve" - DCSetRole {} -> "role" + DCMemberRole {} -> "role" + DCGroupFilter {} -> "filter" DCRejectGroup {} -> "reject" DCSuspendGroup {} -> "suspend" DCResumeGroup {} -> "resume" @@ -249,6 +300,8 @@ directoryCmdTag = \case DCShowGroupLink {} -> "link" DCSendToGroupOwner {} -> "owner" DCInviteOwnerToGroup {} -> "invite" + -- DCAddBlockedWord _ -> "block_word" + -- DCRemoveBlockedWord _ -> "unblock_word" DCExecuteCommand _ -> "exec" DCUnknownCommand -> "unknown" DCCommandError _ -> "error" diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 277d332cf6..5ee52249ac 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -13,10 +13,9 @@ module Directory.Options where import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Options.Applicative import Simplex.Chat.Bot.KnownContacts -import Simplex.Chat.Controller (AcceptAsObserver (..), updateStr, versionNumber, versionString) +import Simplex.Chat.Controller (updateStr, versionNumber, versionString) import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, coreChatOptsP) data DirectoryOpts = DirectoryOpts @@ -25,10 +24,11 @@ data DirectoryOpts = DirectoryOpts superUsers :: [KnownContact], ownersGroup :: Maybe KnownGroup, blockedWordsFile :: Maybe FilePath, + blockedFragmentsFile :: Maybe FilePath, blockedExtensionRules :: Maybe FilePath, nameSpellingFile :: Maybe FilePath, profileNameLimit :: Int, - acceptAsObserver :: Maybe AcceptAsObserver, + captchaGenerator :: Maybe FilePath, directoryLog :: Maybe FilePath, serviceName :: T.Text, runCLI :: Bool, @@ -67,7 +67,14 @@ directoryOpts appDir defaultDbName = do strOption ( long "blocked-words-file" <> metavar "BLOCKED_WORDS_FILE" - <> help "File with the basic forms of words not allowed in profiles and groups" + <> help "File with the basic forms of words not allowed in profiles" + ) + blockedFragmentsFile <- + optional $ + strOption + ( long "blocked-fragments-file" + <> metavar "BLOCKED_WORDS_FILE" + <> help "File with the basic forms of word fragments not allowed in profiles" ) blockedExtensionRules <- optional $ @@ -91,13 +98,12 @@ directoryOpts appDir defaultDbName = do <> help "Max length of profile name that will be allowed to connect and to join groups" <> value maxBound ) - acceptAsObserver <- + captchaGenerator <- optional $ - option - parseAcceptAsObserver - ( long "accept-as-observer" - <> metavar "ACCEPT_AS_OBSERVER" - <> help "Whether to accept all or some of the joining members without posting rights ('all', 'no-image', 'incognito')" + strOption + ( long "captcha-generator" + <> metavar "CAPTCHA_GENERATOR" + <> help "Executable to generate captcha files, must accept text as parameter and save file to stdout as base64 up to 12500 bytes" ) directoryLog <- Just @@ -125,10 +131,11 @@ directoryOpts appDir defaultDbName = do superUsers, ownersGroup, blockedWordsFile, + blockedFragmentsFile, blockedExtensionRules, nameSpellingFile, profileNameLimit, - acceptAsObserver, + captchaGenerator, directoryLog, serviceName = T.pack serviceName, runCLI, @@ -165,12 +172,3 @@ mkChatOpts DirectoryOpts {coreOptions} = markRead = False, maintenance = False } - -parseAcceptAsObserver :: ReadM AcceptAsObserver -parseAcceptAsObserver = eitherReader $ decodeAAO . encodeUtf8 . T.pack - where - decodeAAO = \case - "all" -> Right AOAll - "name-only" -> Right AONameOnly - "incognito" -> Right AOIncognito - _ -> Left "bad AcceptAsObserver" diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 543ba2c84e..7c54f344ad 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -5,31 +5,38 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Directory.Service ( welcomeGetOpts, directoryService, directoryServiceCLI, - directoryChatConfig + newServiceState, + acceptMemberHook ) where import Control.Concurrent (forkIO) import Control.Concurrent.Async import Control.Concurrent.STM +import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad -import Data.Composition ((.:)) -import Data.Containers.ListUtils (nubOrd) +import Control.Monad.Except +import Control.Monad.IO.Class +import Data.Int (Int64) import Data.List (find, intercalate) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, maybeToList) import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Clock (diffUTCTime, getCurrentTime) +import qualified Data.Text.IO as T +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) import Directory.BlockedWords import Directory.Events @@ -43,17 +50,24 @@ import Simplex.Chat.Core import Simplex.Chat.Messages import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) +import Simplex.Chat.Store.Direct (getContact) +import Simplex.Chat.Store.Groups (getGroupInfo, getGroupLink, getGroupSummary, setGroupCustomData) +import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo) import Simplex.Chat.Store.Shared (StoreError (..)) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') 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 qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Encoding.String import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (safeDecodeUtf8, tshow, ($>>=), (<$$>)) import System.Directory (getAppUserDataDirectory) +import System.Process (readProcess) +import System.Random (randomRIO) data GroupProfileUpdate = GPNoServiceLink | GPServiceLinkAdded | GPServiceLinkRemoved | GPHasServiceLink | GPServiceLinkError @@ -70,13 +84,32 @@ data GroupRolesStatus deriving (Eq) data ServiceState = ServiceState - { searchRequests :: TMap ContactId SearchRequest + { searchRequests :: TMap ContactId SearchRequest, + blockedWordsCfg :: BlockedWordsConfig, + pendingCaptchas :: TMap GroupMemberId PendingCaptcha } -newServiceState :: IO ServiceState -newServiceState = do +data PendingCaptcha = PendingCaptcha + { captchaText :: Text, + sentAt :: UTCTime, + attempts :: Int + } + +captchaLength :: Int +captchaLength = 7 + +maxCaptchaAttempts :: Int +maxCaptchaAttempts = 5 + +captchaTTL :: NominalDiffTime +captchaTTL = 600 -- 10 minutes + +newServiceState :: DirectoryOpts -> IO ServiceState +newServiceState opts = do searchRequests <- TM.emptyIO - pure ServiceState {searchRequests} + blockedWordsCfg <- readBlockedWordsConfig opts + pendingCaptchas <- TM.emptyIO + pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas} welcomeGetOpts :: IO DirectoryOpts welcomeGetOpts = do @@ -100,12 +133,12 @@ welcomeGetOpts = do directoryServiceCLI :: DirectoryStore -> DirectoryOpts -> IO () directoryServiceCLI st opts = do - env <- newServiceState + env <- newServiceState opts eventQ <- newTQueueIO let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp) - cfg <- directoryChatConfig opts + chatHooks = defaultChatHooks {eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env} race_ - (simplexChatCLI' cfg {chatHooks = defaultChatHooks {eventHook}} (mkChatOpts opts) Nothing) + (simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing) (processEvents eventQ env) where processEvents eventQ env = forever $ do @@ -113,31 +146,63 @@ directoryServiceCLI st opts = do u_ <- readTVarIO (currentUser cc) forM_ u_ $ \user -> directoryServiceEvent st opts env user cc resp -directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO () -directoryService st opts@DirectoryOpts {testing} user cc = do +directoryService :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> IO () +directoryService st opts@DirectoryOpts {testing} env user cc = do initializeBotAddress' (not testing) cc - env <- newServiceState race_ (forever $ void getLine) . forever $ do (_, _, resp) <- atomically . readTBQueue $ outputQ cc directoryServiceEvent st opts env user cc resp -directoryChatConfig :: DirectoryOpts -> IO ChatConfig -directoryChatConfig DirectoryOpts {blockedWordsFile, nameSpellingFile, blockedExtensionRules, profileNameLimit, acceptAsObserver} = do - blockedWords <- mapM (fmap lines . readFile) blockedWordsFile +acceptMemberHook :: DirectoryOpts -> ServiceState -> GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)) +acceptMemberHook + DirectoryOpts {profileNameLimit} + ServiceState {blockedWordsCfg} + g + GroupLinkInfo {memberRole} + Profile {displayName, image = img} = runExceptT $ do + let a = groupMemberAcceptance g + when (useMemberFilter img $ rejectNames a) checkName + pure $ + if + | useMemberFilter img (passCaptcha a) -> (GAPending, GRMember) + | useMemberFilter img (makeObserver a) -> (GAAccepted, GRObserver) + | otherwise -> (GAAccepted, memberRole) + where + checkName :: ExceptT GroupRejectionReason IO () + checkName + | T.length displayName > profileNameLimit = throwError GRRLongName + | otherwise = do + when (hasBlockedFragments blockedWordsCfg displayName) $ throwError GRRBlockedName + when (hasBlockedWords blockedWordsCfg displayName) $ throwError GRRBlockedName + +groupMemberAcceptance :: GroupInfo -> DirectoryMemberAcceptance +groupMemberAcceptance GroupInfo {customData} = memberAcceptance $ fromCustomData customData + +useMemberFilter :: Maybe ImageData -> Maybe ProfileCondition -> Bool +useMemberFilter img_ = \case + Just PCAll -> True + Just PCNoImage -> maybe True (\(ImageData i) -> i == "") img_ + Nothing -> False + +readBlockedWordsConfig :: DirectoryOpts -> IO BlockedWordsConfig +readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, nameSpellingFile, blockedExtensionRules} = do + extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules spelling <- maybe (pure M.empty) (fmap (M.fromList . read) . readFile) nameSpellingFile - extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules - let !bws = nubOrd . concatMap (wordVariants extensionRules) <$> blockedWords - !allowedProfileName = not .: containsBlockedWords spelling <$> bws - putStrLn $ "Blocked words: " <> show (maybe 0 length bws) <> ", spelling rules: " <> show (M.size spelling) - pure terminalChatConfig {allowedProfileName, profileNameLimit, acceptAsObserver} + 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) + pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling} directoryServiceEvent :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> ChatResponse -> IO () -directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} ServiceState {searchRequests} user@User {userId} cc event = +directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} env@ServiceState {searchRequests} user@User {userId} cc event = forM_ (crDirectoryEvent event) $ \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 {contactId, fromGroup, toGroup} -> deGroupUpdated contactId 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 DEServiceRoleChanged g role -> deServiceRoleChanged g role DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g @@ -163,7 +228,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own notifyOwner GroupReg {dbContactId} = sendMessage' cc dbContactId ctId `isOwner` GroupReg {dbContactId} = ctId == dbContactId withGroupReg GroupInfo {groupId, localDisplayName} err action = do - atomically (getGroupReg st groupId) >>= \case + getGroupReg st groupId >>= \case Just gr -> action gr Nothing -> logError $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find group registration ID " <> tshow groupId groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} = @@ -373,10 +438,91 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own Just (Just msg) -> notifyOwner gr msg Just Nothing -> sendToApprove toGroup gr gaId + dePendingMember :: GroupInfo -> GroupMember -> IO () + dePendingMember g@GroupInfo {groupProfile = GroupProfile {displayName}} m + | memberRequiresCaptcha a m = sendMemberCaptcha g m Nothing captchaNotice 0 + | otherwise = approvePendingMember a g m + where + a = groupMemberAcceptance g + captchaNotice = "Captcha is generated by SimpleX Directory service.\n\n*Send captcha text* to join the group " <> displayName <> "." + + sendMemberCaptcha :: GroupInfo -> GroupMember -> Maybe ChatItemId -> Text -> Int -> IO () + sendMemberCaptcha GroupInfo {groupId} m quotedId noticeText prevAttempts = do + s <- getCaptchaStr captchaLength "" + mc <- getCaptcha s + sentAt <- getCurrentTime + let captcha = PendingCaptcha {captchaText = T.pack s, sentAt, attempts = prevAttempts + 1} + atomically $ TM.insert gmId captcha $ pendingCaptchas env + sendCaptcha mc + where + getCaptchaStr 0 s = pure s + getCaptchaStr n s = do + i <- randomRIO (0, length chars - 1) + let c = chars !! i + getCaptchaStr (n - 1) (c : s) + chars = "23456789ABCDEFGHIJKLMNOPQRSTUVWXYZabdefghijkmnpqrsty" + getCaptcha s = case captchaGenerator opts of + Nothing -> pure textMsg + Just script -> content <$> readProcess script [s] "" + where + textMsg = MCText $ T.pack s + content r = case T.lines $ T.pack r of + [] -> textMsg + "" : _ -> textMsg + img : _ -> MCImage "" $ ImageData img + sendCaptcha mc = sendComposedMessages_ cc (SRGroup groupId $ Just gmId) [(quotedId, MCText noticeText), (Nothing, mc)] + gmId = groupMemberId' m + + approvePendingMember :: DirectoryMemberAcceptance -> GroupInfo -> GroupMember -> IO () + approvePendingMember a g@GroupInfo {groupId} m@GroupMember {memberProfile = LocalProfile {displayName, image}} = do + gli_ <- join <$> withDB' cc (\db -> getGroupLinkInfo db userId groupId) + let role = if useMemberFilter image (makeObserver a) then GRObserver else maybe GRMember (\GroupLinkInfo {memberRole} -> memberRole) gli_ + gmId = groupMemberId' m + sendChatCmd cc (APIAcceptMember groupId gmId role) >>= \case + CRJoinedGroupMember {} -> do + atomically $ TM.delete gmId $ pendingCaptchas env + logInfo $ "Member " <> viewName displayName <> " accepted, group " <> tshow groupId <> ":" <> viewGroupName g + r -> logError $ "unexpected accept member response: " <> tshow r + + dePendingMemberMsg :: GroupInfo -> GroupMember -> ChatItemId -> Text -> IO () + dePendingMemberMsg g@GroupInfo {groupId, groupProfile = GroupProfile {displayName = n}} m@GroupMember {memberProfile = LocalProfile {displayName}} ciId msgText + | memberRequiresCaptcha a m = do + ts <- getCurrentTime + atomically (TM.lookup (groupMemberId' m) $ pendingCaptchas env) >>= \case + Just PendingCaptcha {captchaText, sentAt, attempts} + | ts `diffUTCTime` sentAt > captchaTTL -> sendMemberCaptcha g m (Just ciId) captchaExpired $ attempts - 1 + | captchaText == msgText -> do + sendComposedMessages_ cc (SRGroup groupId $ Just $ groupMemberId' m) [(Just ciId, MCText $ "Correct, you joined the group " <> n)] + approvePendingMember a g m + | attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts + | otherwise -> sendMemberCaptcha g m (Just ciId) (wrongCaptcha attempts) attempts + Nothing -> sendMemberCaptcha g m (Just ciId) noCaptcha 0 + | otherwise = approvePendingMember a g m + where + a = groupMemberAcceptance g + rejectPendingMember rjctNotice = do + let gmId = groupMemberId' m + sendComposedMessages cc (SRGroup groupId $ Just gmId) [MCText rjctNotice] + sendChatCmd cc (APIRemoveMembers groupId [gmId]) >>= \case + CRUserDeletedMembers _ _ (_ : _) -> do + atomically $ TM.delete gmId $ pendingCaptchas env + logInfo $ "Member " <> viewName displayName <> " rejected, group " <> tshow groupId <> ":" <> viewGroupName g + r -> logError $ "unexpected remove member response: " <> tshow r + captchaExpired = "Captcha expired, please try again." + wrongCaptcha attempts + | attempts == maxCaptchaAttempts - 1 = "Incorrect text, please try again - this is your last attempt." + | otherwise = "Incorrect text, please try again." + noCaptcha = "Unexpected message, please try again." + tooManyAttempts = "Too many failed attempts, you can't join group." + + memberRequiresCaptcha :: DirectoryMemberAcceptance -> GroupMember -> Bool + memberRequiresCaptcha a GroupMember {memberProfile = LocalProfile {image}} = + useMemberFilter image $ passCaptcha a + sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO () sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do - ct_ <- getContact cc dbContactId - gr_ <- getGroupAndSummary cc dbGroupId + ct_ <- getContact' cc user dbContactId + gr_ <- getGroupAndSummary cc user dbGroupId let membersStr = maybe "" (\(_, s) -> "_" <> tshow (currentMembers s) <> " members_\n") gr_ text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_ @@ -518,41 +664,86 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own _ -> processInvitation ct g _ -> sendReply $ "Error: the group ID " <> tshow ugrId <> " (" <> displayName <> ") is not pending confirmation." DCListUserGroups -> - atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do + getUserGroupRegs st (contactId' ct) >>= \grs -> do sendReply $ tshow (length grs) <> " registered group(s)" + -- debug how it can be that user has 0 registered groups + when (length grs == 0) $ do + total <- length <$> readTVarIO (groupRegs st) + withSuperUsers $ \ctId -> sendMessage' cc ctId $ + "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 delGroupReg st gr sendReply $ "Your group " <> displayName <> " is deleted from the directory" - DCSetRole gId gName mRole -> - (if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $ - \GroupInfo {groupId, groupProfile = GroupProfile {displayName}} _gr -> do - gLink_ <- setGroupLinkRole cc groupId mRole - sendReply $ case gLink_ of - Nothing -> "Error: the initial member role for the group " <> displayName <> " was NOT upgated" - Just gLink -> - ("The initial member role for the group " <> displayName <> " is set to *" <> strEncodeTxt mRole <> "*\n\n") - <> ("*Please note*: it applies only to members joining via this link: " <> strEncodeTxt (simplexChatContact gLink)) + DCMemberRole gId gName_ mRole_ -> + (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> do + let GroupInfo {groupProfile = GroupProfile {displayName = n}} = g + case mRole_ of + Nothing -> + getGroupLinkRole cc user g >>= \case + Just (_, gLink, mRole) -> do + let anotherRole = case mRole of GRObserver -> GRMember; _ -> GRObserver + sendReply $ + initialRole n mRole + <> ("Send */role " <> tshow gId <> " " <> strEncodeTxt anotherRole <> "* to change it.\n\n") + <> onlyViaLink gLink + Nothing -> sendReply $ "Error: failed reading the initial member role for the group " <> n + Just mRole -> do + setGroupLinkRole cc g mRole >>= \case + Just gLink -> sendReply $ initialRole n mRole <> "\n" <> onlyViaLink gLink + Nothing -> sendReply $ "Error: the initial member role for the group " <> n <> " was NOT upgated." + where + initialRole n mRole = "The initial member role for the group " <> n <> " is set to *" <> strEncodeTxt mRole <> "*\n" + onlyViaLink gLink = "*Please note*: it applies only to members joining via this link: " <> strEncodeTxt (simplexChatContact gLink) + DCGroupFilter gId gName_ acceptance_ -> + (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> do + let GroupInfo {groupProfile = GroupProfile {displayName = n}} = g + a = groupMemberAcceptance g + case acceptance_ of + Just a' | a /= a' -> do + let d = toCustomData $ DirectoryGroupData a' + withDB' cc (\db -> setGroupCustomData db user g $ Just d) >>= \case + Just () -> sendSettigns n a' " set to" + Nothing -> sendReply $ "Error changing spam filter settings for group " <> n + _ -> sendSettigns n a "" + where + sendSettigns n a setTo = + sendReply $ + T.unlines + [ "Spam filter settings for group " <> n <> setTo <> ":", + "- reject long/inappropriate names: " <> showCondition (rejectNames a), + "- pass captcha to join: " <> showCondition (passCaptcha a), + -- "- make observer: " <> showCondition (makeObserver a) <> (if isJust (makeObserver a) then "" else " (use default set with /role command)"), + "", + -- "Use */filter " <> tshow gId <> " * to change spam filter level: no (disable), basic, moderate, strong.", + -- "Or use */filter " <> tshow gId <> " [name[=noimage]] [captcha[=noimage]] [observer[=noimage]]* for advanced filter configuration." + "Or use */filter " <> tshow gId <> " [name] [captcha]* to configure filter." + ] + showCondition = \case + Nothing -> "_disabled_" + Just PCAll -> "_enabled_" + Just PCNoImage -> "_enabled for profiles without image_" DCUnknownCommand -> sendReply "Unknown command" DCCommandError tag -> sendReply $ "Command error: " <> tshow tag where knownCt = knownContact ct isAdmin = knownCt `elem` adminUsers || knownCt `elem` superUsers - withUserGroupReg ugrId gName action = - atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case + withUserGroupReg ugrId = withUserGroupReg_ ugrId . Just + withUserGroupReg_ ugrId gName_ action = + getUserGroupReg st (contactId' ct) ugrId >>= \case Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found" Just gr@GroupReg {dbGroupId} -> do - getGroup cc dbGroupId >>= \case + getGroup cc user dbGroupId >>= \case Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found" Just g@GroupInfo {groupProfile = GroupProfile {displayName}} - | displayName == gName -> action g gr + | maybe True (displayName ==) gName_ -> action g gr | otherwise -> sendReply $ "Group ID " <> tshow ugrId <> " has the display name " <> displayName sendReply = mkSendReply ct ciId withFoundListedGroups s_ action = getGroups_ s_ >>= \case - Just groups -> atomically (filterListedGroups st groups) >>= action + Just groups -> filterListedGroups st groups >>= action Nothing -> sendReply "Error: getGroups. Please notify the developers." sendSearchResults s = \case [] -> sendReply "No groups found" @@ -560,18 +751,18 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own let gs' = takeTop searchResults gs moreGroups = length gs - length gs' more = if moreGroups > 0 then ", sending top " <> tshow (length gs') else "" - sendReply $ "Found " <> tshow (length gs) <> " group(s)" <> more <> "." + reply = "Found " <> tshow (length gs) <> " group(s)" <> more <> "." updateSearchRequest (STSearch s) $ groupIds gs' - sendFoundGroups gs' moreGroups + sendFoundGroups reply gs' moreGroups sendAllGroups takeFirst sortName searchType = \case [] -> sendReply "No groups listed" gs -> do let gs' = takeFirst searchResults gs moreGroups = length gs - length gs' more = if moreGroups > 0 then ", sending " <> sortName <> " " <> tshow (length gs') else "" - sendReply $ tshow (length gs) <> " group(s) listed" <> more <> "." + reply = tshow (length gs) <> " group(s) listed" <> more <> "." updateSearchRequest searchType $ groupIds gs' - sendFoundGroups gs' moreGroups + sendFoundGroups reply gs' moreGroups sendNextSearchResults takeFirst SearchRequest {searchType, sentGroups} = \case [] -> do sendReply "Sorry, no more groups" @@ -580,33 +771,31 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own let gs' = takeFirst searchResults $ filterNotSent sentGroups gs sentGroups' = sentGroups <> groupIds gs' moreGroups = length gs - S.size sentGroups' - sendReply $ "Sending " <> tshow (length gs') <> " more group(s)." + reply = "Sending " <> tshow (length gs') <> " more group(s)." updateSearchRequest searchType sentGroups' - sendFoundGroups gs' moreGroups + sendFoundGroups reply gs' moreGroups updateSearchRequest :: SearchType -> Set GroupId -> IO () updateSearchRequest searchType sentGroups = do searchTime <- getCurrentTime let search = SearchRequest {searchType, searchTime, sentGroups} atomically $ TM.insert (contactId' ct) search searchRequests - sendFoundGroups gs moreGroups = - void . forkIO $ do - forM_ gs $ - \(GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do - let membersStr = "_" <> tshow currentMembers <> " members_" - showId = if isAdmin then tshow groupId <> ". " else "" - text = showId <> groupInfoText p <> "\n" <> membersStr - msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ - sendComposedMessage cc ct Nothing msg - when (moreGroups > 0) $ - sendComposedMessage cc ct Nothing $ - MCText $ - "Send */next* or just *.* for " <> tshow moreGroups <> " more result(s)." + sendFoundGroups reply gs moreGroups = + void . forkIO $ sendComposedMessages_ cc (SRDirect $ contactId' ct) msgs + where + msgs = replyMsg :| map foundGroup gs <> [moreMsg | moreGroups > 0] + replyMsg = (Just ciId, MCText reply) + foundGroup (GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) = + let membersStr = "_" <> tshow currentMembers <> " members_" + showId = if isAdmin then tshow groupId <> ". " else "" + text = showId <> groupInfoText p <> "\n" <> membersStr + in (Nothing, maybe (MCText text) (\image -> MCImage {text, image}) image_) + moreMsg = (Nothing, MCText $ "Send */next* or just *.* for " <> tshow moreGroups <> " more result(s).") deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO () deAdminCommand ct ciId cmd | knownCt `elem` adminUsers || knownCt `elem` superUsers = case cmd of DCApproveGroup {groupId, displayName = n, groupApprovalId} -> - withGroupAndReg sendReply groupId n $ \g gr -> + withGroupAndReg sendReply groupId n $ \g gr@GroupReg {userGroupRegId = ugrId} -> readTVarIO (groupRegStatus gr) >>= \case GRSPendingApproval gaId | gaId == groupApprovalId -> do @@ -618,7 +807,10 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own Just GRSOk -> do setGroupStatus st gr GRSActive let approved = "The group " <> userGroupReference' gr n <> " is approved" - notifyOwner gr $ approved <> " and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved." + notifyOwner gr $ + (approved <> " and listed in directory!\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.") invited <- forM ownersGroup $ \og@KnownGroup {localDisplayName = ogName} -> do inviteToOwnersGroup og gr $ \case @@ -699,6 +891,8 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own sendReply $ "you" <> invited Left err -> sendReply err Nothing -> sendReply "owners' group is not specified" + -- DCAddBlockedWord _word -> pure () + -- DCRemoveBlockedWord _word -> pure () DCCommandError tag -> sendReply $ "Command error: " <> tshow tag | otherwise = sendReply "You are not allowed to use this command" where @@ -713,7 +907,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own else pure groups sendReply $ tshow (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> tshow count else "") void . forkIO $ forM_ (reverse $ take count grs) $ \gr@GroupReg {dbGroupId, dbContactId} -> do - ct_ <- getContact cc dbContactId + ct_ <- getContact' cc user dbContactId let ownerStr = "Owner: " <> maybe "getContact error" localDisplayName' ct_ sendGroupInfo ct gr dbGroupId $ Just ownerStr inviteToOwnersGroup :: KnownGroup -> GroupReg -> (Either Text () -> IO a) -> IO a @@ -735,7 +929,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own putStrLn $ T.unpack err cont $ Left err groupOwnerInfo groupRef dbContactId = do - owner_ <- getContact cc dbContactId + owner_ <- getContact' cc user dbContactId let ownerInfo = "the owner of the group " <> groupRef ownerName ct' = "@" <> viewName (localDisplayName' ct') <> ", " pure $ maybe "" ownerName owner_ <> ownerInfo @@ -760,12 +954,15 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own mkSendReply ct ciId = sendComposedMessage cc ct (Just ciId) . MCText withGroupAndReg :: (Text -> IO ()) -> GroupId -> GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO () - withGroupAndReg sendReply gId gName action = - getGroup cc gId >>= \case + withGroupAndReg sendReply gId = withGroupAndReg_ sendReply gId . Just + + withGroupAndReg_ :: (Text -> IO ()) -> GroupId -> Maybe GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO () + withGroupAndReg_ sendReply gId gName_ action = + getGroup cc user gId >>= \case Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)" Just g@GroupInfo {groupProfile = GroupProfile {displayName}} - | displayName == gName -> - atomically (getGroupReg st gId) >>= \case + | maybe False (displayName ==) gName_ -> + getGroupReg st gId >>= \case Nothing -> sendReply $ "Registration for group ID " <> tshow gId <> " not found (getGroupReg)" Just gr -> action g gr | otherwise -> @@ -775,7 +972,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own sendGroupInfo ct gr@GroupReg {dbGroupId} useGroupId ownerStr_ = do grStatus <- readTVarIO $ groupRegStatus gr let statusStr = "Status: " <> groupRegStatusText grStatus - getGroupAndSummary cc dbGroupId >>= \case + getGroupAndSummary cc user dbGroupId >>= \case Just (GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do let membersStr = "_" <> tshow currentMembers <> " members_" text = T.unlines $ [tshow useGroupId <> ". " <> groupInfoText p] <> maybeToList ownerStr_ <> [membersStr, statusStr] @@ -785,31 +982,36 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own let text = T.unlines $ [tshow useGroupId <> ". Error: getGroup. Please notify the developers."] <> maybeToList ownerStr_ <> [statusStr] sendComposedMessage cc ct Nothing $ MCText text -getContact :: ChatController -> ContactId -> IO (Maybe Contact) -getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId) Nothing (CPLast 0) Nothing) - where - resp :: ChatResponse -> Maybe Contact - resp = \case - CRApiChat _ (AChat SCTDirect Chat {chatInfo = DirectChat ct}) _ -> Just ct - _ -> Nothing +getContact' :: ChatController -> User -> ContactId -> IO (Maybe Contact) +getContact' cc user ctId = withDB cc $ \db -> getContact db (vr cc) user ctId -getGroup :: ChatController -> GroupId -> IO (Maybe GroupInfo) -getGroup cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId) - where - resp :: ChatResponse -> Maybe GroupInfo - resp = \case - CRGroupInfo {groupInfo} -> Just groupInfo - _ -> Nothing +getGroup :: ChatController -> User -> GroupId -> IO (Maybe GroupInfo) +getGroup cc user gId = withDB cc $ \db -> getGroupInfo db (vr cc) user gId -getGroupAndSummary :: ChatController -> GroupId -> IO (Maybe (GroupInfo, GroupSummary)) -getGroupAndSummary cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId) - where - resp = \case - CRGroupInfo {groupInfo, groupSummary} -> Just (groupInfo, groupSummary) - _ -> Nothing +withDB' :: ChatController -> (DB.Connection -> IO a) -> IO (Maybe a) +withDB' cc a = withDB cc $ ExceptT . fmap Right . a -setGroupLinkRole :: ChatController -> GroupId -> GroupMemberRole -> IO (Maybe ConnReqContact) -setGroupLinkRole cc gId mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole gId mRole) +withDB :: ChatController -> (DB.Connection -> ExceptT StoreError IO a) -> IO (Maybe a) +withDB ChatController {chatStore} action = do + r_ :: Either ChatError a <- withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors + case r_ of + Right r -> pure $ Just r + Left e -> Nothing <$ logError ("Database error: " <> tshow e) + +getGroupAndSummary :: ChatController -> User -> GroupId -> IO (Maybe (GroupInfo, GroupSummary)) +getGroupAndSummary cc user gId = + withDB cc $ \db -> (,) <$> getGroupInfo db (vr cc) user gId <*> liftIO (getGroupSummary db user gId) + +vr :: ChatController -> VersionRangeChat +vr ChatController {config = ChatConfig {chatVRange}} = chatVRange +{-# INLINE vr #-} + +getGroupLinkRole :: ChatController -> User -> GroupInfo -> IO (Maybe (Int64, ConnReqContact, GroupMemberRole)) +getGroupLinkRole cc user gInfo = + withDB cc $ \db -> getGroupLink db user gInfo + +setGroupLinkRole :: ChatController -> GroupInfo -> GroupMemberRole -> IO (Maybe ConnReqContact) +setGroupLinkRole cc GroupInfo {groupId} mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole groupId mRole) where resp = \case CRGroupLink _ _ gLink _ -> Just gLink diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index cecb253e8d..fed52f494f 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Directory.Store ( DirectoryStore (..), @@ -10,6 +11,9 @@ module Directory.Store GroupRegStatus (..), UserGroupRegId, GroupApprovalId, + DirectoryGroupData (..), + DirectoryMemberAcceptance (..), + ProfileCondition (..), restoreDirectoryStore, addGroupReg, delGroupReg, @@ -21,25 +25,35 @@ module Directory.Store filterListedGroups, groupRegStatusText, pendingApproval, + fromCustomData, + toCustomData, + noJoinFilter, + basicJoinFilter, + moderateJoinFilter, + strongJoinFilter ) where import Control.Concurrent.STM import Control.Monad +import Data.Aeson ((.=), (.:)) +import qualified Data.Aeson.KeyMap as JM +import qualified Data.Aeson.TH as JQ +import qualified Data.Aeson.Types as JT import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Composition ((.:)) import Data.Int (Int64) import Data.List (find, foldl', sortOn) import Data.Map (Map) import qualified Data.Map.Strict as M -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import Simplex.Chat.Types import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) import Simplex.Messaging.Util (ifM) import System.Directory (doesFileExist, renameFile) import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile) @@ -67,6 +81,51 @@ data GroupRegData = GroupRegData groupRegStatus_ :: GroupRegStatus } +data DirectoryGroupData = DirectoryGroupData + { memberAcceptance :: DirectoryMemberAcceptance + } + +-- these filters are applied in the order of fields, depending on ProfileCondition: +-- Nothing - do not apply +-- Just +-- PCAll - apply to all profiles +-- PCNoImage - apply to profiles without images +data DirectoryMemberAcceptance = DirectoryMemberAcceptance + { rejectNames :: Maybe ProfileCondition, -- reject long names and names with profanity + passCaptcha :: Maybe ProfileCondition, -- run captcha challenge with joining members + makeObserver :: Maybe ProfileCondition -- the role assigned in the end, after captcha challenge + } + deriving (Eq, Show) + +data ProfileCondition = PCAll | PCNoImage deriving (Eq, Show) + +noJoinFilter :: DirectoryMemberAcceptance +noJoinFilter = DirectoryMemberAcceptance Nothing Nothing Nothing + +basicJoinFilter :: DirectoryMemberAcceptance +basicJoinFilter = + DirectoryMemberAcceptance + { rejectNames = Just PCNoImage, + passCaptcha = Nothing, + makeObserver = Nothing + } + +moderateJoinFilter :: DirectoryMemberAcceptance +moderateJoinFilter = + DirectoryMemberAcceptance + { rejectNames = Just PCAll, + passCaptcha = Just PCNoImage, + makeObserver = Nothing + } + +strongJoinFilter :: DirectoryMemberAcceptance +strongJoinFilter = + DirectoryMemberAcceptance + { rejectNames = Just PCAll, + passCaptcha = Just PCAll, + makeObserver = Nothing + } + type UserGroupRegId = Int64 type GroupApprovalId = Int64 @@ -106,16 +165,31 @@ grDirectoryStatus = \case GRSSuspendedBadRoles -> DSReserved _ -> DSRegistered +$(JQ.deriveJSON (enumJSON $ dropPrefix "PC") ''ProfileCondition) + +$(JQ.deriveJSON defaultJSON ''DirectoryMemberAcceptance) + +$(JQ.deriveJSON defaultJSON ''DirectoryGroupData) + +fromCustomData :: Maybe CustomData -> DirectoryGroupData +fromCustomData cd_ = + let memberAcceptance = fromMaybe noJoinFilter $ cd_ >>= \(CustomData o) -> JT.parseMaybe (.: "memberAcceptance") o + in DirectoryGroupData {memberAcceptance} + +toCustomData :: DirectoryGroupData -> CustomData +toCustomData DirectoryGroupData {memberAcceptance} = + CustomData $ JM.fromList ["memberAcceptance" .= memberAcceptance] + addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> IO UserGroupRegId addGroupReg st ct GroupInfo {groupId} grStatus = do - grData <- atomically addGroupReg_ + grData <- addGroupReg_ logGCreate st grData pure $ userGroupRegId_ grData where addGroupReg_ = do let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus} gr <- dataToGroupReg grData - stateTVar (groupRegs st) $ \grs -> + atomically $ stateTVar (groupRegs st) $ \grs -> let ugrId = 1 + foldl' maxUgrId 0 grs grData' = grData {userGroupRegId_ = ugrId} gr' = gr {userGroupRegId = ugrId} @@ -149,18 +223,18 @@ setGroupRegOwner st gr owner = do logGUpdateOwner st (dbGroupId gr) memberId atomically $ writeTVar (dbOwnerMemberId gr) (Just memberId) -getGroupReg :: DirectoryStore -> GroupId -> STM (Maybe GroupReg) -getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st) +getGroupReg :: DirectoryStore -> GroupId -> IO (Maybe GroupReg) +getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVarIO (groupRegs st) -getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg) -getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st) +getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> IO (Maybe GroupReg) +getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVarIO (groupRegs st) -getUserGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg] -getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st) +getUserGroupRegs :: DirectoryStore -> ContactId -> IO [GroupReg] +getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVarIO (groupRegs st) -filterListedGroups :: DirectoryStore -> [(GroupInfo, GroupSummary)] -> STM [(GroupInfo, GroupSummary)] +filterListedGroups :: DirectoryStore -> [(GroupInfo, GroupSummary)] -> IO [(GroupInfo, GroupSummary)] filterListedGroups st gs = do - lgs <- readTVar $ listedGroups st + lgs <- readTVarIO $ listedGroups st pure $ filter (\(GroupInfo {groupId}, _) -> groupId `S.member` lgs) gs listGroup :: DirectoryStore -> GroupId -> STM () @@ -200,10 +274,10 @@ logGDelete :: DirectoryStore -> GroupId -> IO () logGDelete st = logDLR st . GRDelete logGUpdateStatus :: DirectoryStore -> GroupId -> GroupRegStatus -> IO () -logGUpdateStatus st = logDLR st .: GRUpdateStatus +logGUpdateStatus st gId = logDLR st . GRUpdateStatus gId logGUpdateOwner :: DirectoryStore -> GroupId -> GroupMemberId -> IO () -logGUpdateOwner st = logDLR st .: GRUpdateOwner +logGUpdateOwner st gId = logDLR st . GRUpdateOwner gId instance StrEncoding DLRTag where strEncode = \case @@ -271,10 +345,10 @@ instance StrEncoding GroupRegStatus where "removed" -> pure GRSRemoved _ -> fail "invalid GroupRegStatus" -dataToGroupReg :: GroupRegData -> STM GroupReg +dataToGroupReg :: GroupRegData -> IO GroupReg dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = do - dbOwnerMemberId <- newTVar dbOwnerMemberId_ - groupRegStatus <- newTVar groupRegStatus_ + dbOwnerMemberId <- newTVarIO dbOwnerMemberId_ + groupRegStatus <- newTVarIO groupRegStatus_ pure GroupReg { dbGroupId = dbGroupId_, @@ -286,10 +360,9 @@ dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerM restoreDirectoryStore :: Maybe FilePath -> IO DirectoryStore restoreDirectoryStore = \case - Just f -> ifM (doesFileExist f) (restore f) (newFile f >>= new . Just) - Nothing -> new Nothing + Just f -> ifM (doesFileExist f) (restore f) (newFile f >>= newDirectoryStore . Just) + Nothing -> newDirectoryStore Nothing where - new = atomically . newDirectoryStore newFile f = do h <- openFile f WriteMode hSetBuffering h LineBuffering @@ -298,15 +371,15 @@ restoreDirectoryStore = \case grs <- readDirectoryData f renameFile f (f <> ".bak") h <- writeDirectoryData f grs -- compact - atomically $ mkDirectoryStore h grs + mkDirectoryStore h grs emptyStoreData :: ([GroupReg], Set GroupId, Set GroupId) emptyStoreData = ([], S.empty, S.empty) -newDirectoryStore :: Maybe Handle -> STM DirectoryStore +newDirectoryStore :: Maybe Handle -> IO DirectoryStore newDirectoryStore = (`mkDirectoryStore_` emptyStoreData) -mkDirectoryStore :: Handle -> [GroupRegData] -> STM DirectoryStore +mkDirectoryStore :: Handle -> [GroupRegData] -> IO DirectoryStore mkDirectoryStore h groups = foldM addGroupRegData emptyStoreData groups >>= mkDirectoryStore_ (Just h) where @@ -318,11 +391,11 @@ mkDirectoryStore h groups = DSReserved -> (grs', listed, S.insert gId reserved) DSRegistered -> (grs', listed, reserved) -mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> STM DirectoryStore +mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> IO DirectoryStore mkDirectoryStore_ h (grs, listed, reserved) = do - groupRegs <- newTVar grs - listedGroups <- newTVar listed - reservedGroups <- newTVar reserved + groupRegs <- newTVarIO grs + listedGroups <- newTVarIO listed + reservedGroups <- newTVarIO reserved pure DirectoryStore {groupRegs, listedGroups, reservedGroups, directoryLogFile = h} readDirectoryData :: FilePath -> IO [GroupRegData] diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 3f12ebd1af..f987162b78 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -416,13 +416,17 @@ executable simplex-directory-service Paths_simplex_chat ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded build-depends: - async ==2.2.* + aeson ==2.2.* + , async ==2.2.* , attoparsec ==0.14.* , base >=4.7 && <5 , composition ==1.0.* , containers ==0.6.* , directory ==1.3.* + , mtl >=2.3.1 && <3.0 , optparse-applicative >=0.15 && <0.17 + , process >=1.6 && <1.6.18 + , random >=1.1 && <1.3 , simple-logger ==0.1.* , simplex-chat , simplexmq >=6.3 @@ -470,6 +474,7 @@ test-suite simplex-chat-test ViewTests Broadcast.Bot Broadcast.Options + Directory.BlockedWords Directory.Events Directory.Options Directory.Search @@ -512,6 +517,7 @@ test-suite simplex-chat-test , mtl >=2.3.1 && <3.0 , network ==3.1.* , optparse-applicative >=0.15 && <0.17 + , random >=1.1 && <1.3 , silently ==1.2.* , simple-logger ==0.1.* , simplex-chat diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 89bd16b273..bf07e4ae51 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -112,9 +112,6 @@ defaultChatConfig = ntf = _defaultNtfServers, netCfg = defaultNetworkConfig }, - allowedProfileName = Nothing, - profileNameLimit = maxBound, - acceptAsObserver = Nothing, tbqSize = 1024, fileChunkSize = 15780, -- do not change xftpDescrPartSize = 14000, diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index e1f5ce1ef9..54e7baa194 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TupleSections #-} module Simplex.Chat.Bot where @@ -11,6 +12,8 @@ import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T @@ -68,10 +71,16 @@ sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgConte sendComposedMessage cc = sendComposedMessage' cc . contactId' sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO () -sendComposedMessage' cc ctId quotedItemId msgContent = do - let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent, mentions = M.empty} - sendChatCmd cc (APISendMessages (ChatRef CTDirect ctId) False Nothing [cm]) >>= \case - CRNewChatItems {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId +sendComposedMessage' cc ctId qiId mc = sendComposedMessages_ cc (SRDirect ctId) [(qiId, mc)] + +sendComposedMessages :: ChatController -> SendRef -> NonEmpty MsgContent -> IO () +sendComposedMessages cc sendRef = sendComposedMessages_ cc sendRef . L.map (Nothing,) + +sendComposedMessages_ :: ChatController -> SendRef -> NonEmpty (Maybe ChatItemId, MsgContent) -> IO () +sendComposedMessages_ cc sendRef qmcs = do + let cms = L.map (\(qiId, mc) -> ComposedMessage {fileSource = Nothing, quotedItemId = qiId, msgContent = mc, mentions = M.empty}) qmcs + sendChatCmd cc (APISendMessages sendRef False Nothing cms) >>= \case + CRNewChatItems {} -> printLog cc CLLInfo $ "sent " <> show (length cms) <> " messages to " <> show sendRef r -> putStrLn $ "unexpected send message response: " <> show r deleteMessage :: ChatController -> Contact -> ChatItemId -> IO () diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 71b57c72b2..e639771f41 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -19,7 +19,8 @@ module Simplex.Chat.Controller where import Control.Concurrent (ThreadId) import Control.Concurrent.Async (Async) -import Control.Exception +import Control.Exception (Exception, SomeException) +import qualified Control.Exception as E import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader @@ -60,7 +61,7 @@ import Simplex.Chat.Protocol import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Remote.Types import Simplex.Chat.Stats (PresentedServersSummary) -import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, UserMsgReceiptSettings) +import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, GroupLinkInfo, UserMsgReceiptSettings) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared @@ -93,7 +94,6 @@ import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitatio import Simplex.RemoteControl.Types import System.IO (Handle) import System.Mem.Weak (Weak) -import qualified UnliftIO.Exception as E import UnliftIO.STM #if !defined(dbPostgres) import Database.SQLite.Simple (SQLError) @@ -137,9 +137,6 @@ data ChatConfig = ChatConfig chatVRange :: VersionRangeChat, confirmMigrations :: MigrationConfirmation, presetServers :: PresetServers, - allowedProfileName :: Maybe (ContactName -> Bool), - profileNameLimit :: Int, - acceptAsObserver :: Maybe AcceptAsObserver, tbqSize :: Natural, fileChunkSize :: Integer, xftpDescrPartSize :: Int, @@ -161,11 +158,6 @@ data ChatConfig = ChatConfig chatHooks :: ChatHooks } -data AcceptAsObserver - = AOAll -- all members - | AONameOnly -- members without image - | AOIncognito -- members with incognito-style names and without image - data RandomAgentServers = RandomAgentServers { smpServers :: NonEmpty (ServerCfg 'PSMP), xftpServers :: NonEmpty (ServerCfg 'PXFTP) @@ -177,18 +169,16 @@ data ChatHooks = ChatHooks { -- preCmdHook can be used to process or modify the commands before they are processed. -- This hook should be used to process CustomChatCommand. -- if this hook returns ChatResponse, the command processing will be skipped. - preCmdHook :: ChatController -> ChatCommand -> IO (Either ChatResponse ChatCommand), + preCmdHook :: Maybe (ChatController -> ChatCommand -> IO (Either ChatResponse ChatCommand)), -- eventHook can be used to additionally process or modify events, -- it is called before the event is sent to the user (or to the UI). - eventHook :: ChatController -> ChatResponse -> IO ChatResponse + eventHook :: Maybe (ChatController -> ChatResponse -> IO ChatResponse), + -- acceptMember hook can be used to accept or reject member connecting via group link without API calls + acceptMember :: Maybe (GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))) } defaultChatHooks :: ChatHooks -defaultChatHooks = - ChatHooks - { preCmdHook = \_ -> pure . Right, - eventHook = \_ -> pure - } +defaultChatHooks = ChatHooks Nothing Nothing Nothing data PresetServers = PresetServers { operators :: NonEmpty PresetOperator, @@ -313,7 +303,7 @@ data ChatCommand | APIGetChat ChatRef (Maybe MsgContentTag) ChatPagination (Maybe String) | APIGetChatItems ChatPagination (Maybe String) | APIGetChatItemInfo ChatRef ChatItemId - | APISendMessages {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage} + | APISendMessages {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage} | APICreateChatTag ChatTagData | APISetChatTags ChatRef (Maybe (NonEmpty ChatTagId)) | APIDeleteChatTag ChatTagId @@ -366,6 +356,7 @@ data ChatCommand | ApiGetConnNtfMessages {connIds :: NonEmpty AgentConnId} | APIAddMember GroupId ContactId GroupMemberRole | APIJoinGroup {groupId :: GroupId, enableNtfs :: MsgFilter} + | APIAcceptMember GroupId GroupMemberId GroupMemberRole | APIMembersRole GroupId (NonEmpty GroupMemberId) GroupMemberRole | APIBlockMembersForAll GroupId (NonEmpty GroupMemberId) Bool | APIRemoveMembers GroupId (NonEmpty GroupMemberId) @@ -906,6 +897,17 @@ logResponseToFile = \case CRMessageError {} -> True _ -> False +-- (Maybe GroupMemberId) can later be changed to GroupSndScope = GSSAll | GSSAdmins | GSSMember GroupMemberId +data SendRef + = SRDirect ContactId + | SRGroup GroupId (Maybe GroupMemberId) + deriving (Eq, Show) + +sendToChatRef :: SendRef -> ChatRef +sendToChatRef = \case + SRDirect cId -> ChatRef CTDirect cId + SRGroup gId _ -> ChatRef CTGroup gId + data ChatPagination = CPLast Int | CPAfter ChatItemId Int @@ -1509,7 +1511,9 @@ toView = lift . toView' toView' :: ChatResponse -> CM' () toView' ev = do cc@ChatController {outputQ = localQ, remoteCtrlSession = session, config = ChatConfig {chatHooks}} <- ask - event <- liftIO $ eventHook chatHooks cc ev + event <- case eventHook chatHooks of + Just hook -> liftIO $ hook cc ev + Nothing -> pure ev atomically $ readTVar session >>= \case Just (_, RCSessionConnected {remoteOutputQ}) @@ -1544,7 +1548,7 @@ withStoreBatch actions = do liftIO $ withTransaction chatStore $ mapM (`E.catches` handleDBErrors) . actions -- TODO [postgres] postgres specific error handling -handleDBErrors :: [E.Handler IO (Either ChatError a)] +handleDBErrors :: [E.Handler (Either ChatError a)] handleDBErrors = #if !defined(dbPostgres) ( E.Handler $ \(e :: SQLError) -> diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index f44dca9026..821bc3d6ce 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -277,7 +277,9 @@ execChatCommand rh s = do | otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand _ -> do cc@ChatController {config = ChatConfig {chatHooks}} <- ask - liftIO (preCmdHook chatHooks cc cmd) >>= either pure (execChatCommand_ u) + case preCmdHook chatHooks of + Just hook -> liftIO (hook cc cmd) >>= either pure (execChatCommand_ u) + Nothing -> execChatCommand_ u cmd execChatCommand' :: ChatCommand -> CM' ChatResponse execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd) @@ -536,20 +538,17 @@ processChatCommand' vr = \case Just (CIFFGroup _ _ (Just gId) (Just fwdItemId)) -> Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId) _ -> pure Nothing - APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case cType of - CTDirect -> do + APISendMessages sendRef live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case sendRef of + SRDirect chatId -> do mapM_ assertNoMentions cms withContactLock "sendMessage" chatId $ sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms) - CTGroup -> + SRGroup chatId directMemId_ -> withGroupLock "sendMessage" chatId $ do (gInfo, cmrs) <- withFastStore $ \db -> do g <- getGroupInfo db vr user chatId (g,) <$> mapM (composedMessageReqMentions db user g) cms - sendGroupContentMessages user gInfo live itemTTL cmrs - CTLocal -> pure $ chatCmdError (Just user) "not supported" - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + sendGroupContentMessages user gInfo directMemId_ live itemTTL cmrs APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do _ <- createChatTag db user emoji text CRChatTags user <$> getUserChatTags db user @@ -583,7 +582,8 @@ processChatCommand' vr = \case mc = MCReport reportText reportReason cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc, mentions = M.empty} when (null ms') $ throwChatError $ CECommandError "no moderators support receiving reports" - sendGroupContentMessages_ user gInfo ms' False Nothing [composedMessageReq cm] + let numFileInvs = length $ filter memberCurrent ms' + sendGroupContentMessages_ user gInfo Nothing ms' numFileInvs False Nothing [composedMessageReq cm] where compatibleModerator GroupMember {activeConn, memberChatVRange} = maxVersion (maybe memberChatVRange peerChatVRange activeConn) >= contentReportsVersion @@ -633,6 +633,7 @@ processChatCommand' vr = \case then do ciMentions <- withFastStore $ \db -> getCIMentions db user gInfo ft_ mentions let mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions + -- TODO [knocking] send separately to pending approval member SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) ci' <- withFastStore' $ \db -> do currentTs <- liftIO getCurrentTime @@ -687,6 +688,7 @@ processChatCommand' vr = \case assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier let msgIds = itemsMsgIds items events = L.nonEmpty $ map (`XMsgDel` Nothing) msgIds + -- TODO [knocking] validate: only current members or only single pending approval member mapM_ (sendGroupMessages user gInfo ms) events delGroupChatItems user gInfo items False CTLocal -> do @@ -764,6 +766,7 @@ processChatCommand' vr = \case let GroupMember {memberId = itemMemberId} = chatItemMember g ci rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs + -- TODO [knocking] send separately to pending approval member SndMessage {msgId} <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add) createdAt <- liftIO getCurrentTime reactions <- withFastStore' $ \db -> do @@ -847,7 +850,7 @@ processChatCommand' vr = \case Just cmrs' -> withGroupLock "forwardChatItem, to group" toChatId $ do gInfo <- withFastStore $ \db -> getGroupInfo db vr user toChatId - sendGroupContentMessages user gInfo False itemTTL cmrs' + sendGroupContentMessages user gInfo Nothing False itemTTL cmrs' Nothing -> pure $ CRNewChatItems user [] CTLocal -> do cmrs <- prepareForward user @@ -1084,6 +1087,7 @@ processChatCommand' vr = \case cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo let doSendDel = memberActive membership && isOwner + -- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites) when doSendDel . void $ sendGroupMessage' user gInfo members XGrpDel deleteGroupLinkIfExists user gInfo deleteMembersConnections' user members doSendDel @@ -1127,7 +1131,7 @@ processChatCommand' vr = \case (user@User {userId}, cReq) <- withFastStore $ \db -> getContactRequest' db connReqId (ct, conn@Connection {connId}, sqSecured) <- acceptContactRequest user cReq incognito ucl <- withFastStore $ \db -> getUserContactLinkById db userId userContactLinkId - let contactUsed = (\(_, groupId_, _) -> isNothing groupId_) ucl + let contactUsed = (\(_, gLinkInfo_) -> isNothing gLinkInfo_) ucl ct' <- withStore' $ \db -> do deleteContactRequestRec db user cReq updateContactAccepted db user ct contactUsed @@ -1838,8 +1842,8 @@ processChatCommand' vr = \case CTDirect -> withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case Right ctId -> do - let chatRef = ChatRef CTDirect ctId - processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc] + let sendRef = SRDirect ctId + processChatCommand $ APISendMessages sendRef False Nothing [composedMessage Nothing mc] Left _ -> withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case Right [(gInfo, member)] -> do @@ -1854,8 +1858,8 @@ processChatCommand' vr = \case (gId, mentions) <- withFastStore $ \db -> do gId <- getGroupIdByName db user name (gId,) <$> liftIO (getMessageMentions db user gId msg) - let chatRef = ChatRef CTGroup gId - processChatCommand $ APISendMessages chatRef False Nothing [ComposedMessage Nothing Nothing mc mentions] + let sendRef = SRGroup gId Nothing + processChatCommand $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions] CTLocal | name == "" -> do folderId <- withFastStore (`getUserNoteFolderId` user) @@ -1877,12 +1881,13 @@ processChatCommand' vr = \case processChatCommand $ APISendMemberContactInvitation contactId (Just mc) cr -> pure cr Just ctId -> do - let chatRef = ChatRef CTDirect ctId - processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc] + let sendRef = SRDirect ctId + processChatCommand $ APISendMessages sendRef False Nothing [composedMessage Nothing mc] SendLiveMessage chatName msg -> withUser $ \user -> do (chatRef, mentions) <- getChatRefAndMentions user chatName msg - let mc = MCText msg - processChatCommand $ APISendMessages chatRef True Nothing [ComposedMessage Nothing Nothing mc mentions] + withSendRef chatRef $ \sendRef -> do + let mc = MCText msg + processChatCommand $ APISendMessages sendRef True Nothing [ComposedMessage Nothing Nothing mc mentions] SendMessageBroadcast msg -> withUser $ \user -> do contacts <- withFastStore' $ \db -> getUserContacts db vr user withChatLock "sendMessageBroadcast" . procCmd $ do @@ -1922,12 +1927,12 @@ processChatCommand' vr = \case combineResults _ _ (Left e) = Left e createCI :: DB.Connection -> User -> UTCTime -> (Contact, SndMessage) -> IO () createCI db user createdAt (ct, sndMsg) = - void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False createdAt + void $ createNewSndChatItem db user (CDDirectSnd ct) Nothing sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False createdAt SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do contactId <- withFastStore $ \db -> getContactIdByName db user cName quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg let mc = MCText msg - processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty] + processChatCommand $ APISendMessages (SRDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty] DeleteMessage chatName deletedMsg -> withUser $ \user -> do chatRef <- getChatRef user chatName deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg @@ -2023,14 +2028,27 @@ processChatCommand' vr = \case updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` (toView . CRChatError (Just user)) pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing Nothing -> throwChatError $ CEContactNotActive ct + APIAcceptMember groupId gmId role -> withUser $ \user -> do + (gInfo, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db vr user gmId + assertUserGroupRole gInfo GRAdmin + when (memberStatus m /= GSMemPendingApproval) $ throwChatError $ CECommandError "member is not pending approval" + case memberConn m of + Just mConn -> do + let msg = XGrpLinkAcpt role + void $ sendDirectMemberMessage mConn msg groupId + m' <- withFastStore' $ \db -> updateGroupMemberAccepted db user m role + introduceToGroup vr user gInfo m' + pure $ CRJoinedGroupMember user gInfo m' + _ -> throwChatError CEGroupMemberNotActive APIMembersRole groupId memberIds newRole -> withUser $ \user -> withGroupLock "memberRole" groupId . procCmd $ do g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId when (selfSelected gInfo) $ throwChatError $ CECommandError "can't change role for self" - let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin) = selectMembers members + let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound when (length memberIds > 1 && (anyAdmin || newRole >= GRAdmin)) $ throwChatError $ CECommandError "can't change role of multiple members when admins selected, or new role is admin" + when anyPending $ throwChatError $ CECommandError "can't change role of members pending approval" assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole]) (errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems (errs2, changed2, acis) <- changeRoleCurrentMems user g currentMems @@ -2040,19 +2058,20 @@ processChatCommand' vr = \case pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole} -- same order is not guaranteed where selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds - selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool) - selectMembers = foldr' addMember ([], [], [], GRObserver, False) + selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool) + selectMembers = foldr' addMember ([], [], [], GRObserver, False, False) where - addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin) + addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending) | groupMemberId `elem` memberIds = let maxRole' = max maxRole memberRole anyAdmin' = anyAdmin || memberRole >= GRAdmin + anyPending' = anyPending || memberStatus == GSMemPendingApproval in if - | memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin') - | memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin') - | otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin') - | otherwise = (invited, current, unchanged, maxRole, anyAdmin) + | memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending') + | memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending') + | otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending') + | otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending) changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember]) changeRoleInvitedMems user gInfo memsToChange = do -- not batched, as we need to send different invitations to different connections anyway @@ -2074,7 +2093,7 @@ processChatCommand' vr = \case let events = L.map (\GroupMember {memberId} -> XGrpMemRole memberId newRole) memsToChange' (msgs_, _gsr) <- sendGroupMessages user gInfo members events let itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo) Nothing itemsData Nothing False when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch" (errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange) let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) $ rights cis_ @@ -2084,7 +2103,7 @@ processChatCommand' vr = \case sndItemData GroupMember {groupMemberId, memberProfile} msg = let content = CISndGroupEvent $ SGEMemberRole groupMemberId (fromLocalProfile memberProfile) newRole ts = ciContentTexts content - in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing + in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing updMember db m = do updateGroupMemberRole db user m newRole pure (m :: GroupMember) {memberRole = newRole} @@ -2092,22 +2111,24 @@ processChatCommand' vr = \case withGroupLock "blockForAll" groupId . procCmd $ do Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId when (selfSelected gInfo) $ throwChatError $ CECommandError "can't block/unblock self" - let (blockMems, remainingMems, maxRole, anyAdmin) = selectMembers members + let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members when (length blockMems /= length memberIds) $ throwChatError CEGroupMemberNotFound when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't block/unblock multiple members when admins selected" + when anyPending $ throwChatError $ CECommandError "can't block/unblock members pending approval" assertUserGroupRole gInfo $ max GRModerator maxRole blockMembers user gInfo blockMems remainingMems where selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds - selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool) - selectMembers = foldr' addMember ([], [], GRObserver, False) + selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool, Bool) + selectMembers = foldr' addMember ([], [], GRObserver, False, False) where - addMember m@GroupMember {groupMemberId, memberRole} (block, remaining, maxRole, anyAdmin) + addMember m@GroupMember {groupMemberId, memberRole, memberStatus} (block, remaining, maxRole, anyAdmin, anyPending) | groupMemberId `elem` memberIds = let maxRole' = max maxRole memberRole anyAdmin' = anyAdmin || memberRole >= GRAdmin - in (m : block, remaining, maxRole', anyAdmin') - | otherwise = (block, m : remaining, maxRole, anyAdmin) + anyPending' = anyPending || memberStatus == GSMemPendingApproval + in (m : block, remaining, maxRole', anyAdmin', anyPending') + | otherwise = (block, m : remaining, maxRole, anyAdmin, anyPending) blockMembers :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ChatResponse blockMembers user gInfo blockMems remainingMems = case L.nonEmpty blockMems of Nothing -> throwChatError $ CECommandError "no members to block/unblock" @@ -2116,7 +2137,7 @@ processChatCommand' vr = \case events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems' (msgs_, _gsr) <- sendGroupMessages user gInfo remainingMems events let itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo) Nothing itemsData Nothing False when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch" let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) $ rights cis_ unless (null acis) $ toView $ CRNewChatItems user acis @@ -2130,33 +2151,37 @@ processChatCommand' vr = \case sndItemData GroupMember {groupMemberId, memberProfile} msg = let content = CISndGroupEvent $ SGEMemberBlocked groupMemberId (fromLocalProfile memberProfile) blockFlag ts = ciContentTexts content - in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing + in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing APIRemoveMembers groupId memberIds -> withUser $ \user -> withGroupLock "removeMembers" groupId . procCmd $ do - g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId - let (invitedMems, currentMems, maxRole, anyAdmin) = selectMembers members - when (length invitedMems + length currentMems /= length memberIds) $ throwChatError CEGroupMemberNotFound + Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId + let (invitedMems, pendingMems, currentMems, maxRole, anyAdmin) = selectMembers members + when (length invitedMems + length pendingMems + length currentMems /= length memberIds) $ throwChatError CEGroupMemberNotFound when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't remove multiple members when admins selected" assertUserGroupRole gInfo $ max GRAdmin maxRole (errs1, deleted1) <- deleteInvitedMems user invitedMems - (errs2, deleted2, acis) <- deleteCurrentMems user g currentMems + (errs2, deleted2, acis2) <- deleteMemsSend user gInfo members currentMems + rs <- forM pendingMems $ \m -> deleteMemsSend user gInfo [m] [m] + let (errs3, deleted3, acis3) = concatTuples rs + acis = acis2 <> acis3 + errs = errs1 <> errs2 <> errs3 unless (null acis) $ toView $ CRNewChatItems user acis - let errs = errs1 <> errs2 unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2) -- same order is not guaranteed + pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2 <> deleted3) -- same order is not guaranteed where - selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool) - selectMembers = foldr' addMember ([], [], GRObserver, False) + selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool) + selectMembers = foldr' addMember ([], [], [], GRObserver, False) where - addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, maxRole, anyAdmin) + addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, pending, current, maxRole, anyAdmin) | groupMemberId `elem` memberIds = let maxRole' = max maxRole memberRole anyAdmin' = anyAdmin || memberRole >= GRAdmin in - if memberStatus == GSMemInvited - then (m : invited, current, maxRole', anyAdmin') - else (invited, m : current, maxRole', anyAdmin') - | otherwise = (invited, current, maxRole, anyAdmin) + case memberStatus of + GSMemInvited -> (m : invited, pending, current, maxRole', anyAdmin') + GSMemPendingApproval -> (invited, m : pending, current, maxRole', anyAdmin') + _ -> (invited, pending, m : current, maxRole', anyAdmin') + | otherwise = (invited, pending, current, maxRole, anyAdmin) deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember]) deleteInvitedMems user memsToDelete = do deleteMembersConnections user memsToDelete @@ -2165,14 +2190,14 @@ processChatCommand' vr = \case delMember db m = do deleteGroupMember db user m pure m {memberStatus = GSMemRemoved} - deleteCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem]) - deleteCurrentMems user (Group gInfo members) memsToDelete = case L.nonEmpty memsToDelete of + deleteMemsSend :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem]) + deleteMemsSend user gInfo sendToMems memsToDelete = case L.nonEmpty memsToDelete of Nothing -> pure ([], [], []) Just memsToDelete' -> do let events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId) memsToDelete' - (msgs_, _gsr) <- sendGroupMessages user gInfo members events + (msgs_, _gsr) <- sendGroupMessages user gInfo sendToMems events let itemsData = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo) Nothing itemsData Nothing False when (length cis_ /= length memsToDelete) $ logError "deleteCurrentMems: memsToDelete and cis_ length mismatch" deleteMembersConnections' user memsToDelete True (errs, deleted) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete) @@ -2183,15 +2208,19 @@ processChatCommand' vr = \case sndItemData GroupMember {groupMemberId, memberProfile} msg = let content = CISndGroupEvent $ SGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) ts = ciContentTexts content - in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing + in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing delMember db m = do deleteOrUpdateMemberRecordIO db user m pure m {memberStatus = GSMemRemoved} + concatTuples :: [([a], [b], [c])] -> ([a], [b], [c]) + concatTuples xs = (concat as, concat bs, concat cs) + where (as, bs, cs) = unzip3 xs APILeaveGroup groupId -> withUser $ \user@User {userId} -> do Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo withGroupLock "leaveGroup" groupId . procCmd $ do cancelFilesInProgress user filesInfo + -- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites) msg <- sendGroupMessage' user gInfo members XGrpLeave ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] @@ -2320,7 +2349,7 @@ processChatCommand' vr = \case qiId <- getGroupChatItemIdByText db user gId cName quotedMsg (gId, qiId,) <$> liftIO (getMessageMentions db user gId msg) let mc = MCText msg - processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions] + processChatCommand $ APISendMessages (SRGroup groupId Nothing) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions] ClearNoteFolder -> withUser $ \user -> do folderId <- withFastStore (`getUserNoteFolderId` user) processChatCommand $ APIClearChat (ChatRef CTLocal folderId) @@ -2361,15 +2390,16 @@ processChatCommand' vr = \case chatRef <- getChatRef user chatName case chatRef of ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")] - _ -> processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCFile "")] + _ -> withSendRef chatRef $ \sendRef -> processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")] SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do chatRef <- getChatRef user chatName - filePath <- lift $ toFSFilePath fPath - unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath} - fileSize <- getFileSize filePath - unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} - -- TODO include file description for preview - processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)] + withSendRef chatRef $ \sendRef -> do + filePath <- lift $ toFSFilePath fPath + unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath} + fileSize <- getFileSize filePath + unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} + -- TODO include file description for preview + processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)] ForwardFile chatName fileId -> forwardFile chatName fileId SendFile ForwardImage chatName fileId -> forwardFile chatName fileId SendImage SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" @@ -2403,6 +2433,7 @@ processChatCommand' vr = \case void . sendDirectContactMessage user contact $ XFileCancel sharedMsgId Just (ChatRef CTGroup groupId) -> do (Group gInfo ms, sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId + -- TODO [knocking] send separately to pending approval member void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId Just _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId @@ -2795,6 +2826,7 @@ processChatCommand' vr = \case GroupMember {memberProfile = LocalProfile {displayName, fullName, image}} <- withStore $ \db -> getGroupMemberByMemberId db vr user g businessId let p'' = p' {displayName, fullName, image} :: GroupProfile + -- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites) void $ sendGroupMessage user g' oldMs (XGrpInfo p'') let ps' = fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' sendGroupMessage user g' newMs $ XGrpPrefs ps' @@ -2823,6 +2855,8 @@ processChatCommand' vr = \case assertUserGroupRole gInfo GRAdmin -- TODO GRModerator when most users migrate let msgMemIds = itemsMsgMemIds gInfo items events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId)) msgMemIds + -- TODO [knocking] validate: only current members or only single pending approval member, + -- TODO or prohibit pending approval members (only moderation and reports use this) mapM_ (sendGroupMessages user gInfo ms) events delGroupChatItems user gInfo items True where @@ -3115,7 +3149,7 @@ processChatCommand' vr = \case msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) msgs_ when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch" - r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live + r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) Nothing itemsData timed_ live processSendErrs user r forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> forM_ cis $ \ci -> @@ -3151,14 +3185,26 @@ processChatCommand' vr = \case quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) quoteData _ = throwError SEInvalidQuote - sendGroupContentMessages :: User -> GroupInfo -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse - sendGroupContentMessages user gInfo live itemTTL cmrs = do + sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupMemberId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse + sendGroupContentMessages user gInfo@GroupInfo {membership} directMemId_ live itemTTL cmrs = do assertMultiSendable live cmrs - ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo - sendGroupContentMessages_ user gInfo ms live itemTTL cmrs - sendGroupContentMessages_ :: User -> GroupInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse - sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} ms live itemTTL cmrs = do - assertUserGroupRole gInfo GRAuthor + (ms, numFileInvs, notInHistory_) <- case directMemId_ of + Nothing -> do + ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo + pure (ms, length $ filter memberCurrent ms, Nothing) + Just dmId -> do + when (dmId == groupMemberId' membership) $ throwChatError $ CECommandError "cannot send to self" + dm <- withFastStore $ \db -> getGroupMemberById db vr user dmId + unless (memberStatus dm == GSMemPendingApproval) $ throwChatError $ CECommandError "cannot send directly to member not pending approval" + pure ([dm], 1, Just NotInHistory) + sendGroupContentMessages_ user gInfo notInHistory_ ms numFileInvs live itemTTL cmrs + sendGroupContentMessages_ :: User -> GroupInfo -> Maybe NotInHistory -> [GroupMember] -> Int -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse + sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} notInHistory_ ms numFileInvs live itemTTL cmrs = do + -- TODO [knocking] pass GroupSndScope? + let allowedRole = case ms of + [m] | memberCategory m == GCHostMember && memberStatus membership == GSMemPendingApproval -> Nothing + _ -> Just GRAuthor + forM_ allowedRole $ assertUserGroupRole gInfo assertGroupContentAllowed processComposedMessages where @@ -3175,12 +3221,12 @@ processChatCommand' vr = \case Nothing processComposedMessages :: CM ChatResponse processComposedMessages = do - (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms) + (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers numFileInvs timed_ <- sndGroupCITimed live gInfo itemTTL (chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ (msgs_, gsr) <- sendGroupMessages user gInfo ms chatMsgEvents let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live + cis_ <- saveSndChatItems user (CDGroupSnd gInfo) notInHistory_ itemsData timed_ live when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch" createMemberSndStatuses cis_ msgs_ gsr let r@(_, cis) = partitionEithers cis_ @@ -3351,6 +3397,11 @@ processChatCommand' vr = \case getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId) CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId) + withSendRef :: ChatRef -> (SendRef -> CM ChatResponse) -> CM ChatResponse + withSendRef chatRef a = case chatRef of + ChatRef CTDirect cId -> a $ SRDirect cId + ChatRef CTGroup gId -> a $ SRGroup gId Nothing + _ -> throwChatError $ CECommandError "not supported" protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) protocolServers p (operators, smpServers, xftpServers) = case p of @@ -3833,7 +3884,7 @@ chatCommandP = "/_get chat " *> (APIGetChat <$> chatRefP <*> optional (" content=" *> strP) <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)), "/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)), "/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal), - "/_send " *> (APISendMessages <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), + "/_send " *> (APISendMessages <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), "/_create tag " *> (APICreateChatTag <$> jsonP), "/_tags " *> (APISetChatTags <$> chatRefP <*> optional _strP), "/_delete tag " *> (APIDeleteChatTag <$> A.decimal), @@ -3886,6 +3937,7 @@ chatCommandP = "/_ntf conn messages " *> (ApiGetConnNtfMessages <$> strP), "/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), "/_join #" *> (APIJoinGroup <$> A.decimal <*> pure MFAll), -- needs to be changed to support in UI + "/_accept member #" *> (APIAcceptMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), "/_member role #" *> (APIMembersRole <$> A.decimal <*> _strP <*> memberRole), "/_block #" *> (APIBlockMembersForAll <$> A.decimal <*> _strP <* A.space <* "blocked=" <*> onOffP), "/_remove #" *> (APIRemoveMembers <$> A.decimal <*> _strP), @@ -4206,6 +4258,9 @@ chatCommandP = ct -> ChatName ct <$> displayNameP chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayNameP chatRefP = ChatRef <$> chatTypeP <*> A.decimal + sendRefP = + (A.char '@' $> SRDirect <*> A.decimal) + <|> (A.char '#' $> SRGroup <*> A.decimal <*> optional (" @" *> A.decimal)) msgCountP = A.space *> A.decimal <|> pure 10 ciTTLDecimal = ("default" $> Nothing) <|> (Just <$> A.decimal) ciTTL = diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index eba1bf169f..1b18abda37 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -38,7 +38,7 @@ import Data.Functor (($>)) import Data.Functor.Identity import Data.Int (Int64) import Data.List (find, mapAccumL, partition) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -78,7 +78,7 @@ import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.Messaging.Agent as Agent import Simplex.Messaging.Agent.Client (getFastNetworkConfig, ipAddressProtected, withLockMap) -import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..)) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), ServerCfg (..)) import Simplex.Messaging.Agent.Lock (withLock) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) @@ -820,17 +820,19 @@ acceptContactRequestAsync user cReq@UserContactRequest {agentInvitationId = Agen setCommandConnId db user cmdId connId pure ct -acceptGroupJoinRequestAsync :: User -> GroupInfo -> UserContactRequest -> GroupMemberRole -> Maybe IncognitoProfile -> CM GroupMember +acceptGroupJoinRequestAsync :: User -> GroupInfo -> UserContactRequest -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> CM GroupMember acceptGroupJoinRequestAsync user gInfo@GroupInfo {groupProfile, membership, businessChat} ucr@UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange} + gAccepted gLinkMemRole incognitoProfile = do gVar <- asks random + let initialStatus = acceptanceToStatus gAccepted (groupMemberId, memberId) <- withStore $ \db -> do liftIO $ deleteContactRequestRec db user ucr - createJoiningMember db gVar user gInfo ucr gLinkMemRole GSMemAccepted + createJoiningMember db gVar user gInfo ucr gLinkMemRole initialStatus currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo let Profile {displayName} = profileToSendOnAccept user incognitoProfile True GroupMember {memberRole = userRole, memberId = userMemberId} = membership @@ -841,6 +843,7 @@ acceptGroupJoinRequestAsync fromMemberName = displayName, invitedMember = MemberIdRole memberId gLinkMemRole, groupProfile, + accepted = Just gAccepted, business = businessChat, groupSize = Just currentMemCount } @@ -900,6 +903,7 @@ acceptBusinessJoinRequestAsync fromMemberName = displayName, invitedMember = MemberIdRole memberId GRMember, groupProfile = businessGroupProfile userProfile groupPreferences, + accepted = Just GAAccepted, -- This refers to the "title member" that defines the group name and profile. -- This coincides with fromMember to be current user when accepting the connecting user, -- but it will be different when inviting somebody else. @@ -926,6 +930,132 @@ profileToSendOnAccept user ip = userProfileToSend user (getIncognitoProfile <$> NewIncognito p -> p ExistingIncognito lp -> fromLocalProfile lp +introduceToGroup :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM () +introduceToGroup _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active" +introduceToGroup vr user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn = Just conn} = do + members <- withStore' $ \db -> getGroupMembers db vr user gInfo + void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m + sendIntroductions members + when (groupFeatureAllowed SGFHistory gInfo) sendHistory + where + sendIntroductions members = do + intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m + shuffledIntros <- liftIO $ shuffleIntros intros + if m `supportsVersion` batchSendVersion + then do + let events = map (memberIntro . reMember) shuffledIntros + forM_ (L.nonEmpty events) $ \events' -> + sendGroupMemberMessages user conn events' groupId + else forM_ shuffledIntros $ \intro -> + processIntro intro `catchChatError` (toView . CRChatError (Just user)) + memberIntro :: GroupMember -> ChatMsgEvent 'Json + memberIntro reMember = + let mInfo = memberInfo reMember + mRestrictions = memberRestrictions reMember + in XGrpMemIntro mInfo mRestrictions + shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] + shuffleIntros intros = do + let (admins, others) = partition isAdmin intros + (admPics, admNoPics) = partition hasPicture admins + (othPics, othNoPics) = partition hasPicture others + mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics] + where + isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin + hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image + processIntro intro@GroupMemberIntro {introId} = do + void $ sendDirectMemberMessage conn (memberIntro $ reMember intro) groupId + withStore' $ \db -> updateIntroStatus db introId GMIntroSent + sendHistory = + when (m `supportsVersion` batchSendVersion) $ do + (errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100) + (errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items + let errors = map ChatErrorStore errs <> errs' + unless (null errors) $ toView $ CRChatErrors (Just user) errors + let events' = maybe (concat events) (\x -> concat events <> [x]) descrEvent_ + forM_ (L.nonEmpty events') $ \events'' -> + sendGroupMemberMessages user conn events'' groupId + descrEvent_ :: Maybe (ChatMsgEvent 'Json) + descrEvent_ + | m `supportsVersion` groupHistoryIncludeWelcomeVersion = do + let GroupInfo {groupProfile = GroupProfile {description}} = gInfo + fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description + | otherwise = Nothing + itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] + itemForwardEvents cci = case cci of + (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) + | not (blockedByAdmin sender) -> do + fInvDescr_ <- join <$> forM file getRcvFileInvDescr + processContentItem sender ci mc fInvDescr_ + (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do + fInvDescr_ <- join <$> forM file getSndFileInvDescr + processContentItem membership ci mc fInvDescr_ + _ -> pure [] + where + getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText)) + getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do + expired <- fileExpired + if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired + then pure Nothing + else do + rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId + pure $ invCompleteDescr ciFile rfd + getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText)) + getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do + expired <- fileExpired + if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired + then pure Nothing + else do + -- can also lookup in extra_xftp_file_descriptions, though it can be empty; + -- would be best if snd file had a single rcv description for all members saved in files table + rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId + pure $ invCompleteDescr ciFile rfd + fileExpired :: CM Bool + fileExpired = do + ttl <- asks $ rcvFilesTTL . agentConfig . config + cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime + pure $ chatItemTs cci < cutoffTs + invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText) + invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete} + | fileDescrComplete = + let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} + fInv = xftpFileInvitation fileName fileSize fInvDescr + in Just (fInv, fileDescrText) + | otherwise = Nothing + processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] + processContentItem sender ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ = + if isNothing fInvDescr_ && not (msgContentHasText mc) + then pure [] + else do + let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta + quotedItemId_ = quoteItemId =<< quotedItem + fInv_ = fst <$> fInvDescr_ + (mc', _, mentions') = updatedMentionNames mc formattedText mentions + mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions' + (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False + let senderVRange = memberChatVRange' sender + xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent} + fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of + (Just fileDescrText, Just msgId) -> do + partSize <- asks $ xftpDescrPartSize . config + let parts = splitFileDescr partSize fileDescrText + pure . L.toList $ L.map (XMsgFileDescr msgId) parts + _ -> pure [] + let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents + GroupMember {memberId} = sender + msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) + pure msgForwardEvents + +splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr +splitFileDescr partSize rfdText = splitParts 1 rfdText + where + splitParts partNo remText = + let (part, rest) = T.splitAt partSize remText + complete = T.null rest + fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete} + in if complete + then fileDescr :| [] + else fileDescr <| splitParts (partNo + 1) rest + deleteGroupLink' :: User -> GroupInfo -> CM () deleteGroupLink' user gInfo = do vr <- chatVersionRange @@ -1459,6 +1589,7 @@ sendGroupMessage' user gInfo members chatMsgEvent = sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) sendGroupMessages user gInfo members events = do + -- TODO [knocking] when sending to all, send profile update to pending approval members too, then filter for next step? when shouldSendProfileUpdate $ sendProfileUpdate `catchChatError` (toView . CRChatError (Just user)) sendGroupMessages_ user gInfo members events @@ -1489,7 +1620,10 @@ sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> No sendGroupMessages_ _user gInfo@GroupInfo {groupId} members events = do let idsEvts = L.map (GroupId groupId,) events sndMsgs_ <- lift $ createSndMessages idsEvts - recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) + -- TODO [knocking] Possibly we need to pass GroupSndScope through all functions to here to avoid ad-hoc filtering. + recipientMembers <- case members of + [m] | memberStatus m == GSMemPendingApproval -> pure [m] + _ -> liftIO $ shuffleMembers (filter memberCurrent members) let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} (toSendSeparate, toSendBatched, toPending, forwarded, _, dups) = foldr' addMember ([], [], [], [], S.empty, 0 :: Int) recipientMembers @@ -1691,7 +1825,7 @@ saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothi saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = do let itemTexts = ciContentTexts content - saveSndChatItems user cd [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case + saveSndChatItems user cd Nothing [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case [Right ci] -> pure ci _ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item" @@ -1710,11 +1844,12 @@ saveSndChatItems :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> + Maybe NotInHistory -> [Either ChatError (NewSndChatItemData c)] -> Maybe CITimed -> Bool -> CM [Either ChatError (ChatItem c 'MDSnd)] -saveSndChatItems user cd itemsData itemTimed live = do +saveSndChatItems user cd notInHistory_ itemsData itemTimed live = do createdAt <- liftIO getCurrentTime when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $ withStore' (\db -> updateChatTs db user cd createdAt) @@ -1722,7 +1857,7 @@ saveSndChatItems user cd itemsData itemTimed live = do where createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)) createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do - ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt + ciId <- createNewSndChatItem db user cd notInHistory_ msg content quotedItem itemForwarded itemTimed live createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt let ci = mkChatItem_ cd ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False createdAt Nothing createdAt Right <$> case cd of @@ -1734,13 +1869,13 @@ saveRcvChatItemNoParse user cd msg brokerTs = saveRcvChatItem user cd msg broker saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> CM (ChatItem c 'MDRcv) saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = - saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty + saveRcvChatItem' user cd Nothing msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) ciContentNoParse content = (content, (ciContentToText content, Nothing)) -saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv) -saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do +saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> Maybe NotInHistory -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv) +saveRcvChatItem' user cd notInHistory_ msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do createdAt <- liftIO getCurrentTime withStore' $ \db -> do when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt @@ -1753,7 +1888,7 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} shared userMention' = userReply || any (\CIMention {memberId} -> sameMemberId memberId membership) mentions' in pure (mentions', userMention') CDDirectRcv _ -> pure (M.empty, False) - (ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention brokerTs createdAt + (ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd notInHistory_ msg sharedMsgId_ content itemTimed live userMention brokerTs createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt let ci = mkChatItem_ cd ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention brokerTs forwardedByMember createdAt case cd of @@ -1999,7 +2134,7 @@ createLocalChatItems user cd itemsData createdAt = do where createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd) createItem db (content, ciFile, itemForwarded, ts) = do - ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False createdAt Nothing createdAt + ciId <- createNewChatItem_ db user cd Nothing Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False createdAt Nothing createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt pure $ mkChatItem_ cd ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False createdAt Nothing createdAt diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 087d49e49a..739ab25ea9 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -27,8 +27,8 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (lefts, partitionEithers, rights) import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (foldl', partition) -import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -36,8 +36,7 @@ import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) -import Data.Time (addUTCTime) -import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, diffUTCTime) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as V4 import Data.Word (Word32) @@ -47,7 +46,7 @@ import Simplex.Chat.Library.Internal import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events -import Simplex.Chat.ProfileGenerator (generateRandomProfile, isRandomName) +import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol import Simplex.Chat.Store import Simplex.Chat.Store.Connections @@ -60,14 +59,12 @@ import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared -import Simplex.Chat.Util (shuffle) import Simplex.FileTransfer.Description (ValidFileDescription) import qualified Simplex.FileTransfer.Description as FD import Simplex.FileTransfer.Protocol (FilePartyI) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId) import Simplex.Messaging.Agent as Agent -import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -296,17 +293,6 @@ agentFileError = \case SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion e -> srvErr . SrvErrOther $ tshow e -splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr -splitFileDescr partSize rfdText = splitParts 1 rfdText - where - splitParts partNo remText = - let (part, rest) = T.splitAt partSize remText - complete = T.null rest - fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete} - in if complete - then fileDescr :| [] - else fileDescr <| splitParts (partNo + 1) rest - processAgentMsgRcvFile :: ACorrId -> RcvFileId -> AEvent 'AERcvFile -> CM () processAgentMsgRcvFile _corrId aFileId msg = do (cRef_, fileId) <- withStore (`getXFTPRcvFileDBIds` AgentRcvFileId aFileId) @@ -592,14 +578,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withStore' $ \db -> resetContactConnInitiated db user conn' forM_ viaUserContactLink $ \userContactLinkId -> do ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {autoAccept}, groupId_, gLinkMemRole) = ucl + let (UserContactLink {autoAccept}, gli_) = ucl when (connChatVersion < batchSend2Version) $ sendAutoReply ct' autoAccept - forM_ groupId_ $ \groupId -> do + -- TODO REMOVE LEGACY vvv + forM_ gli_ $ \GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId subMode <- chatReadVar subscriptionMode groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode gVar <- asks random withStore $ \db -> createNewContactMemberAsync db gVar user groupInfo ct' gLinkMemRole groupConnIds connChatVersion peerChatVRange subMode + -- TODO REMOVE LEGACY ^^^ Just (gInfo, m@GroupMember {activeConn}) -> when (maybe False ((== ConnReady) . connStatus) activeConn) $ do notifyMemberConnected gInfo m $ Just ct @@ -658,7 +646,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CRContactSndReady user ct forM_ viaUserContactLink $ \userContactLinkId -> do ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {autoAccept}, _, _) = ucl + let (UserContactLink {autoAccept}, _) = ucl when (connChatVersion >= batchSend2Version) $ sendAutoReply ct autoAccept QCONT -> void $ continueSending connEntity conn @@ -703,6 +691,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = liftIO $ setConnConnReqInv db user connId cReq getHostConnId db user groupId sendXGrpMemInv hostConnId Nothing XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} + -- TODO REMOVE LEGACY vvv -- [async agent commands] group link auto-accept continuation on receiving INV CFCreateConnGrpInv -> do ct <- withStore $ \db -> getContactViaMember db vr user m @@ -728,6 +717,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (_msg, _) <- sendDirectContactMessage user ct $ XGrpInv groupInv -- we could link chat item with sent group invitation message (_msg) createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing + -- TODO REMOVE LEGACY ^^^ _ -> throwChatError $ CECommandError "unexpected cmdFunction" CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" CONF confId _pqSupport _ connInfo -> do @@ -765,7 +755,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" -- sent when connecting via group link XInfo _ -> - -- TODO [group rejection] Keep rejected member record and connection for ability to start dialogue. + -- TODO Keep rejected member to allow them to appeal against rejection. when (memberStatus m == GSMemRejected) $ do deleteMemberConnection' user m True withStore' $ \db -> deleteGroupMember db user m @@ -773,16 +763,20 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok" pure () CON _pqEnc -> unless (memberStatus m == GSMemRejected) $ do - withStore' $ \db -> do - updateGroupMemberStatus db userId m GSMemConnected - unless (memberActive membership) $ - updateGroupMemberStatus db userId membership GSMemConnected - -- possible improvement: check for each pending message, requires keeping track of connection state - unless (connDisabled conn) $ sendPendingGroupMessages user m conn + status' <- case memberStatus m of + GSMemPendingApproval -> pure GSMemPendingApproval + _ -> do + withStore' $ \db -> do + updateGroupMemberStatus db userId m GSMemConnected + unless (memberActive membership) $ + updateGroupMemberStatus db userId membership GSMemConnected + -- possible improvement: check for each pending message, requires keeping track of connection state + unless (connDisabled conn) $ sendPendingGroupMessages user m conn + pure GSMemConnected withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings case memberCategory m of GCHostMember -> do - toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} + toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = status'}} m {memberStatus = status'} let cd = CDGroupRcv gInfo m createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing createGroupFeatureItems user cd CIRcvGroupFeature gInfo @@ -793,125 +787,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = expectHistory = groupFeatureAllowed SGFHistory gInfo && m `supportsVersion` groupHistoryIncludeWelcomeVersion GCInviteeMember -> do memberConnectedChatItem gInfo m - toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected} + toView $ CRJoinedGroupMember user gInfo m {memberStatus = status'} let Connection {viaUserContactLink} = conn when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem - members <- withStore' $ \db -> getGroupMembers db vr user gInfo - void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m - sendIntroductions members - when (groupFeatureAllowed SGFHistory gInfo) sendHistory when (connChatVersion < batchSend2Version) sendGroupAutoReply + unless (status' == GSMemPendingApproval) $ introduceToGroup vr user gInfo m where sendXGrpLinkMem = do let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo profileToSend = profileToSendOnAccept user profileMode True void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId - sendIntroductions members = do - intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m - shuffledIntros <- liftIO $ shuffleIntros intros - if m `supportsVersion` batchSendVersion - then do - let events = map (memberIntro . reMember) shuffledIntros - forM_ (L.nonEmpty events) $ \events' -> - sendGroupMemberMessages user conn events' groupId - else forM_ shuffledIntros $ \intro -> - processIntro intro `catchChatError` (toView . CRChatError (Just user)) - memberIntro :: GroupMember -> ChatMsgEvent 'Json - memberIntro reMember = - let mInfo = memberInfo reMember - mRestrictions = memberRestrictions reMember - in XGrpMemIntro mInfo mRestrictions - shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] - shuffleIntros intros = do - let (admins, others) = partition isAdmin intros - (admPics, admNoPics) = partition hasPicture admins - (othPics, othNoPics) = partition hasPicture others - mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics] - where - isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin - hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image - processIntro intro@GroupMemberIntro {introId} = do - void $ sendDirectMemberMessage conn (memberIntro $ reMember intro) groupId - withStore' $ \db -> updateIntroStatus db introId GMIntroSent - sendHistory = - when (m `supportsVersion` batchSendVersion) $ do - (errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100) - (errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items - let errors = map ChatErrorStore errs <> errs' - unless (null errors) $ toView $ CRChatErrors (Just user) errors - let events' = maybe (concat events) (\x -> concat events <> [x]) descrEvent_ - forM_ (L.nonEmpty events') $ \events'' -> - sendGroupMemberMessages user conn events'' groupId - descrEvent_ :: Maybe (ChatMsgEvent 'Json) - descrEvent_ - | m `supportsVersion` groupHistoryIncludeWelcomeVersion = do - let GroupInfo {groupProfile = GroupProfile {description}} = gInfo - fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description - | otherwise = Nothing - itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] - itemForwardEvents cci = case cci of - (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) - | not (blockedByAdmin sender) -> do - fInvDescr_ <- join <$> forM file getRcvFileInvDescr - processContentItem sender ci mc fInvDescr_ - (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do - fInvDescr_ <- join <$> forM file getSndFileInvDescr - processContentItem membership ci mc fInvDescr_ - _ -> pure [] - where - getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText)) - getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do - expired <- fileExpired - if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired - then pure Nothing - else do - rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId - pure $ invCompleteDescr ciFile rfd - getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText)) - getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do - expired <- fileExpired - if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired - then pure Nothing - else do - -- can also lookup in extra_xftp_file_descriptions, though it can be empty; - -- would be best if snd file had a single rcv description for all members saved in files table - rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId - pure $ invCompleteDescr ciFile rfd - fileExpired :: CM Bool - fileExpired = do - ttl <- asks $ rcvFilesTTL . agentConfig . config - cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime - pure $ chatItemTs cci < cutoffTs - invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText) - invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete} - | fileDescrComplete = - let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} - fInv = xftpFileInvitation fileName fileSize fInvDescr - in Just (fInv, fileDescrText) - | otherwise = Nothing - processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] - processContentItem sender ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ = - if isNothing fInvDescr_ && not (msgContentHasText mc) - then pure [] - else do - let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta - quotedItemId_ = quoteItemId =<< quotedItem - fInv_ = fst <$> fInvDescr_ - (mc', _, mentions') = updatedMentionNames mc formattedText mentions - mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions' - (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False - let senderVRange = memberChatVRange' sender - xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent} - fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of - (Just fileDescrText, Just msgId) -> do - partSize <- asks $ xftpDescrPartSize . config - let parts = splitFileDescr partSize fileDescrText - pure . L.toList $ L.map (XMsgFileDescr msgId) parts - _ -> pure [] - let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents - GroupMember {memberId} = sender - msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) - pure msgForwardEvents _ -> do let memCategory = memberCategory m withStore' (\db -> getViaGroupContact db vr user m) >>= \case @@ -974,6 +859,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName XInfo p -> xInfoMember gInfo m' p brokerTs XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p + XGrpLinkAcpt role -> xGrpLinkAcpt gInfo m' role XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs XGrpMemIntro memInfo memRestrictions_ -> xGrpMemIntro gInfo m' memInfo memRestrictions_ XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv @@ -1294,13 +1180,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> pure () where profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> CM () - profileContactRequest invId chatVRange p@Profile {displayName, image} xContactId_ reqPQSup = do + profileContactRequest invId chatVRange p@Profile {displayName} xContactId_ reqPQSup = do withStore (\db -> createOrUpdateContactRequest db vr user userContactLinkId invId chatVRange p xContactId_ reqPQSup) >>= \case CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact CORGroup gInfo -> toView $ CRBusinessRequestAlreadyAccepted user gInfo CORRequest cReq -> do ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {connReqContact, autoAccept}, groupId_, gLinkMemRole) = ucl + let (UserContactLink {connReqContact, autoAccept}, gLinkInfo_) = ucl isSimplexTeam = sameConnReqContact connReqContact adminContactReq v = maxVersion chatVRange case autoAccept of @@ -1313,49 +1199,37 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = else do gInfo <- acceptBusinessJoinRequestAsync user cReq toView $ CRAcceptingBusinessRequest user gInfo - | otherwise -> case groupId_ of + | otherwise -> case gLinkInfo_ of Nothing -> do -- [incognito] generate profile to send, create connection with incognito profile incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing ct <- acceptContactRequestAsync user cReq incognitoProfile reqPQSup toView $ CRAcceptingContactRequest user ct - Just groupId -> do + Just gli@GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do gInfo <- withStore $ \db -> getGroupInfo db vr user groupId - cfg <- asks config - case rejectionReason cfg of - Nothing + acceptMember_ <- asks $ acceptMember . chatHooks . config + maybe (pure $ Right (GAAccepted, gLinkMemRole)) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case + Right (acceptance, useRole) | v < groupFastLinkJoinVersion -> messageError "processUserContactRequest: chat version range incompatible for accepting group join request" | otherwise -> do let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo - useRole = userMemberRole gLinkMemRole $ acceptAsObserver cfg - mem <- acceptGroupJoinRequestAsync user gInfo cReq useRole profileMode + mem <- acceptGroupJoinRequestAsync user gInfo cReq acceptance useRole profileMode createInternalChatItem user (CDGroupRcv gInfo mem) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing toView $ CRAcceptingGroupJoinRequestMember user gInfo mem - Just rjctReason + Left rjctReason | v < groupJoinRejectVersion -> messageWarning $ "processUserContactRequest (group " <> groupName' gInfo <> "): joining of " <> displayName <> " is blocked" | otherwise -> do mem <- acceptGroupJoinSendRejectAsync user gInfo cReq rjctReason toViewTE $ TERejectingGroupJoinRequestMember user gInfo mem rjctReason _ -> toView $ CRReceivedContactRequest user cReq - where - rejectionReason ChatConfig {profileNameLimit, allowedProfileName} - | T.length displayName > profileNameLimit = Just GRRLongName - | maybe False (\f -> not $ f displayName) allowedProfileName = Just GRRBlockedName - | otherwise = Nothing - userMemberRole linkRole = \case - Just AOAll -> GRObserver - Just AONameOnly | noImage -> GRObserver - Just AOIncognito | noImage && isRandomName displayName -> GRObserver - _ -> linkRole - where - noImage = maybe True (\(ImageData i) -> i == "") image + -- TODO [knocking] review memberCanSend :: GroupMember -> CM () -> CM () - memberCanSend GroupMember {memberRole} a - | memberRole <= GRObserver = messageError "member is not allowed to send messages" - | otherwise = a + memberCanSend GroupMember {memberRole, memberStatus} a + | memberRole > GRObserver || memberStatus == GSMemPendingApproval = a + | otherwise = messageError "member is not allowed to send messages" processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM () processConnMERR connEntity conn err = do @@ -1576,7 +1450,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = where brokerTs = metaBrokerTs msgMeta newChatItem content ciFile_ timed_ live = do - ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty + ci <- saveRcvChatItem' user (CDDirectRcv ct) Nothing msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_ toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}] @@ -1643,7 +1517,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- Chat item and update message which created it will have different sharedMsgId in this case... let timed_ = rcvContactCITimed ct ttl ts = ciContentTexts content - ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty + ci <- saveRcvChatItem' user (CDDirectRcv ct) Nothing msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty ci' <- withStore' $ \db -> do createChatItemVersion db (chatItemId' ci) brokerTs mc updateDirectChatItem' db user contactId ci content True live Nothing Nothing @@ -1760,10 +1634,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = live' = fromMaybe False live_ ExtMsgContent content mentions fInv_ itemTTL live_ = mcExtMsgContent mc ts@(_, ft_) = msgContentTexts content + saveRcvCI = saveRcvChatItem' user (CDGroupRcv gInfo m) (memberNotInHistory m) msg sharedMsgId_ brokerTs createBlockedByAdmin | groupFeatureAllowed SGFFullDelete gInfo = do -- ignores member role when blocked by admin - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvBlocked) Nothing timed' False M.empty + ci <- saveRcvCI (ciContentNoParse CIRcvBlocked) Nothing timed' False M.empty ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs groupMsgToView gInfo ci' | otherwise = do @@ -1775,7 +1650,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | moderatorRole < GRModerator || moderatorRole < memberRole = createContentItem | groupFeatureMemberAllowed SGFFullDelete moderator gInfo = do - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvModerated) Nothing timed' False M.empty + ci <- saveRcvCI (ciContentNoParse CIRcvModerated) Nothing timed' False M.empty ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt groupMsgToView gInfo ci' | otherwise = do @@ -1783,7 +1658,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ci <- createNonLive file_ toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt createNonLive file_ = - saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content, ts) (snd <$> file_) timed' False mentions + saveRcvCI (CIRcvMsgContent content, ts) (snd <$> file_) timed' False mentions createContentItem = do file_ <- processFileInv newChatItem (CIRcvMsgContent content, ts) (snd <$> file_) timed' live' @@ -1792,7 +1667,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m newChatItem ciContent ciFile_ timed_ live = do let mentions' = if showMessages (memberSettings m) then mentions else [] - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live mentions' + ci <- saveRcvCI ciContent ciFile_ timed_ live mentions' ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_ groupMsgToView gInfo ci' {reactions} @@ -1808,7 +1683,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- Chat item and update message which created it will have different sharedMsgId in this case... let timed_ = rcvGroupCITimed gInfo ttl_ mentions' = if showMessages (memberSettings m) then mentions else [] - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions' + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) (memberNotInHistory m) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions' ci' <- withStore' $ \db -> do createChatItemVersion db (chatItemId' ci) brokerTs mc ci' <- updateGroupChatItem db user groupId ci content True live Nothing @@ -1841,6 +1716,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = else messageError "x.msg.update: group member attempted to update a message of another member" _ -> messageError "x.msg.update: group member attempted invalid message update" + memberNotInHistory :: GroupMember -> Maybe NotInHistory + memberNotInHistory = \case + GroupMember {memberStatus = GSMemPendingApproval} -> Just NotInHistory + _ -> Nothing + groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> UTCTime -> CM () groupMessageDelete gInfo@GroupInfo {membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} brokerTs = do let msgMemberId = fromMaybe memberId sndMemberId_ @@ -1896,7 +1776,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} content = ciContentNoParse $ CIRcvMsgContent $ MCFile "" - ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty + ci <- saveRcvChatItem' user (CDDirectRcv ct) Nothing msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] where brokerTs = metaBrokerTs msgMeta @@ -1910,7 +1790,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} content = ciContentNoParse $ CIRcvMsgContent $ MCFile "" - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) Nothing msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci groupMsgToView gInfo ci' @@ -2173,16 +2053,27 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xInfoMember gInfo m p' brokerTs = void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs) xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM () - xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do + xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory, memberStatus} Connection {viaGroupLink} p' = do xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived then do m' <- processMemberProfileUpdate gInfo m p' False Nothing withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True - let connectedIncognito = memberIncognito membership - probeMatchingMemberContact m' connectedIncognito + unless (memberStatus == GSMemPendingApproval) $ do + let connectedIncognito = memberIncognito membership + probeMatchingMemberContact m' connectedIncognito else messageError "x.grp.link.mem error: invalid group link host profile update" + xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupMemberRole -> CM () + xGrpLinkAcpt gInfo@GroupInfo {membership} m role = do + membership' <- withStore' $ \db -> do + updateGroupMemberStatus db userId m GSMemConnected + updateGroupMemberAccepted db user membership role + let m' = m {memberStatus = GSMemConnected} + toView $ CRUserJoinedGroup user gInfo {membership = membership'} m' + let connectedIncognito = memberIncognito membership + probeMatchingMemberContact m' connectedIncognito + processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Bool -> Maybe UTCTime -> CM GroupMember processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} p' createItems itemTs_ | redactedMemberProfile (fromLocalProfile p) /= redactedMemberProfile p' = do @@ -2330,7 +2221,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = saveCallItem status = saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0) featureRejected f = do let content = ciContentNoParse $ CIRcvChatFeatureRejected f - ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty + ci <- saveRcvChatItem' user (CDDirectRcv ct) Nothing msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] -- to party initiating call diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 5562f016c9..ae88bc796b 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -162,6 +162,8 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem } deriving (Show) +data NotInHistory = NotInHistory + data CIMention = CIMention { memberId :: MemberId, -- member record can be created later than the mention is received diff --git a/src/Simplex/Chat/ProfileGenerator.hs b/src/Simplex/Chat/ProfileGenerator.hs index 8380bb58f1..5b6c9222cc 100644 --- a/src/Simplex/Chat/ProfileGenerator.hs +++ b/src/Simplex/Chat/ProfileGenerator.hs @@ -2,8 +2,6 @@ module Simplex.Chat.ProfileGenerator where -import qualified Data.Attoparsec.Text as A -import Data.Either (isRight) import Data.Text (Text) import Simplex.Chat.Types (Profile (..)) import System.Random (randomRIO) @@ -25,15 +23,6 @@ generateRandomProfile = do then pickNoun adjective (n - 1) else pure noun --- This function does not check for exact match with this disctionary, --- it only checks for the WordWord style. -isRandomName :: Text -> Bool -isRandomName = isRight . A.parseOnly randomNameP - where - randomNameP = A.satisfy upper >> A.takeWhile1 lower >> A.satisfy upper >> A.takeWhile1 lower >> A.endOfInput - upper c = c >= 'A' && c <= 'Z' - lower c = c >= 'a' && c <= 'z' - adjectives :: [Text] adjectives = [ "Abatic", @@ -1503,7 +1492,6 @@ adjectives = "Recommendable", "Rectangular", "Recuperative", - "Red", "Refined", "Reflecting", "Reflective", @@ -2940,7 +2928,6 @@ nouns = "Sister", "Size", "Skill", - "Skin", "Skipper", "Sleek", "Slick", diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 94e08a0897..a145914ce7 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -333,6 +333,7 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json XGrpLinkMem :: Profile -> ChatMsgEvent 'Json + XGrpLinkAcpt :: GroupMemberRole -> ChatMsgEvent 'Json XGrpMemNew :: MemberInfo -> ChatMsgEvent 'Json XGrpMemIntro :: MemberInfo -> Maybe MemberRestrictions -> ChatMsgEvent 'Json XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json @@ -823,6 +824,7 @@ data CMEventTag (e :: MsgEncoding) where XGrpLinkInv_ :: CMEventTag 'Json XGrpLinkReject_ :: CMEventTag 'Json XGrpLinkMem_ :: CMEventTag 'Json + XGrpLinkAcpt_ :: CMEventTag 'Json XGrpMemNew_ :: CMEventTag 'Json XGrpMemIntro_ :: CMEventTag 'Json XGrpMemInv_ :: CMEventTag 'Json @@ -875,6 +877,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where XGrpLinkInv_ -> "x.grp.link.inv" XGrpLinkReject_ -> "x.grp.link.reject" XGrpLinkMem_ -> "x.grp.link.mem" + XGrpLinkAcpt_ -> "x.grp.link.acpt" XGrpMemNew_ -> "x.grp.mem.new" XGrpMemIntro_ -> "x.grp.mem.intro" XGrpMemInv_ -> "x.grp.mem.inv" @@ -928,6 +931,7 @@ instance StrEncoding ACMEventTag where "x.grp.link.inv" -> XGrpLinkInv_ "x.grp.link.reject" -> XGrpLinkReject_ "x.grp.link.mem" -> XGrpLinkMem_ + "x.grp.link.acpt" -> XGrpLinkAcpt_ "x.grp.mem.new" -> XGrpMemNew_ "x.grp.mem.intro" -> XGrpMemIntro_ "x.grp.mem.inv" -> XGrpMemInv_ @@ -977,6 +981,7 @@ toCMEventTag msg = case msg of XGrpLinkInv _ -> XGrpLinkInv_ XGrpLinkReject _ -> XGrpLinkReject_ XGrpLinkMem _ -> XGrpLinkMem_ + XGrpLinkAcpt _ -> XGrpLinkAcpt_ XGrpMemNew _ -> XGrpMemNew_ XGrpMemIntro _ _ -> XGrpMemIntro_ XGrpMemInv _ _ -> XGrpMemInv_ @@ -1079,6 +1084,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation" XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection" XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" + XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "role" XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" <*> opt "memberRestrictions" XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro" @@ -1142,6 +1148,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @ XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv] XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct] XGrpLinkMem profile -> o ["profile" .= profile] + XGrpLinkAcpt role -> o ["role" .= role] XGrpMemNew memInfo -> o ["memberInfo" .= memInfo] XGrpMemIntro memInfo memRestrictions -> o $ ("memberRestrictions" .=? memRestrictions) ["memberInfo" .= memInfo] XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro] diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 03b4d7a640..a41641f88d 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -6,6 +6,7 @@ module Simplex.Chat.Store ChatLockEntity (..), UserMsgReceiptSettings (..), UserContactLink (..), + GroupLinkInfo (..), AutoAccept (..), createChatStore, migrations, -- used in tests diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index a1ce3ab269..0094e20cb8 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -78,6 +78,7 @@ module Simplex.Chat.Store.Groups createMemberConnectionAsync, updateGroupMemberStatus, updateGroupMemberStatusById, + updateGroupMemberAccepted, createNewGroupMember, checkGroupMemberHasItems, deleteGroupMember, @@ -520,9 +521,10 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile { DB.execute db "DELETE FROM contact_profiles WHERE contact_profile_id = ?" (Only profileId) createGroupInvitedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember) -createGroupInvitedViaLink db vr user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, business} = do +createGroupInvitedViaLink db vr user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do let fromMemberProfile = profileFromName fromMemberName - createGroupViaLink' db vr user conn fromMember fromMemberProfile invitedMember groupProfile business GSMemAccepted + initialStatus = maybe GSMemAccepted acceptanceToStatus accepted + createGroupViaLink' db vr user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus createGroupRejectedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember) createGroupRejectedViaLink db vr user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do @@ -1201,6 +1203,19 @@ updateGroupMemberStatusById db userId groupMemberId memStatus = do |] (memStatus, currentTs, userId, groupMemberId) +updateGroupMemberAccepted :: DB.Connection -> User -> GroupMember -> GroupMemberRole -> IO GroupMember +updateGroupMemberAccepted db User {userId} m@GroupMember {groupMemberId} role = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE group_members + SET member_status = ?, member_role = ?, updated_at = ? + WHERE user_id = ? AND group_member_id = ? + |] + (GSMemConnected, role, currentTs, userId, groupMemberId) + pure m {memberStatus = GSMemConnected, memberRole = role, updatedAt = currentTs} + -- | add new member with profile createNewGroupMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} memCategory memStatus = do diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 1902fd002e..00158e0054 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -142,7 +142,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.Ord (Down (..), comparing) import Data.Text (Text) import qualified Data.Text as T @@ -372,9 +372,9 @@ updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirecti (chatTs, userId, noteFolderId) _ -> pure () -createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId -createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live createdAt = - createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False createdAt Nothing createdAt +createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> Maybe NotInHistory -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId +createNewSndChatItem db user chatDirection notInHistory_ SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live createdAt = + createNewChatItem_ db user chatDirection notInHistory_ createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False createdAt Nothing createdAt where createdByMsgId = if msgId == 0 then Nothing else Just msgId quoteRow :: NewQuoteRow @@ -388,9 +388,9 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) CIQGroupRcv Nothing -> (Just False, Nothing) -createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom) -createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention itemTs createdAt = do - ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt +createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> Maybe NotInHistory -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom) +createNewRcvChatItem db user chatDirection notInHistory_ RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention itemTs createdAt = do + ciId <- createNewChatItem_ db user chatDirection notInHistory_ (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg pure (ciId, quotedItem, itemForwarded) where @@ -407,13 +407,13 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId createNewChatItemNoMsg db user chatDirection ciContent itemTs = - createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing Nothing False False itemTs Nothing + createNewChatItem_ db user chatDirection Nothing Nothing Nothing ciContent quoteRow Nothing Nothing False False itemTs Nothing where quoteRow :: NewQuoteRow quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) -createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId -createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt = do +createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe NotInHistory -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId +createNewChatItem_ db User {userId} chatDirection notInHistory_ msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt = do DB.execute db [sql| @@ -448,7 +448,7 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q includeInHistory :: Bool includeInHistory = let (_, groupId_, _, _) = idsRow - in isJust groupId_ && isJust (ciMsgContent ciContent) && ((msgContentTag <$> ciMsgContent ciContent) /= Just MCReport_) + in isJust groupId_ && isNothing notInHistory_ && isJust (ciMsgContent ciContent) && ((msgContentTag <$> ciMsgContent ciContent) /= Just MCReport_) forwardedFromRow :: (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64) forwardedFromRow = case itemForwarded of Nothing -> @@ -2319,9 +2319,9 @@ updateGroupCIMentions db g ci@ChatItem {mentions} mentions' unless (null mentions) $ deleteMentions if null mentions' then pure ci - -- This is a fallback for the error that should not happen in practice. + else -- This is a fallback for the error that should not happen in practice. -- In theory, it may happen in item mentions in database are different from item record. - else createMentions `E.catch` \e -> if constraintError e then deleteMentions >> createMentions else E.throwIO e + createMentions `E.catch` \e -> if constraintError e then deleteMentions >> createMentions else E.throwIO e where deleteMentions = DB.execute db "DELETE FROM chat_item_mentions WHERE chat_item_id = ?" (Only $ chatItemId' ci) createMentions = createGroupCIMentions db g ci mentions' @@ -3138,6 +3138,7 @@ getGroupSndStatusCounts db itemId = |] (Only itemId) +-- TODO [knocking] filter out messages sent to member only getGroupHistoryItems :: DB.Connection -> User -> GroupInfo -> GroupMember -> Int -> IO [Either StoreError (CChatItem 'CTGroup)] getGroupHistoryItems db user@User {userId} g@GroupInfo {groupId} m count = do ciIds <- getLastItemIds_ diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index a8d1c094d4..22d2a7b1f5 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -18,6 +18,7 @@ module Simplex.Chat.Store.Profiles ( AutoAccept (..), UserMsgReceiptSettings (..), UserContactLink (..), + GroupLinkInfo (..), createUserRecord, createUserRecordAt, getUsersInfo, @@ -47,6 +48,7 @@ module Simplex.Chat.Store.Profiles deleteUserAddress, getUserAddress, getUserContactLinkById, + getGroupLinkInfo, getUserContactLinkByConnReq, getContactWithoutConnViaAddress, updateUserAddressAutoAccept, @@ -453,6 +455,12 @@ data UserContactLink = UserContactLink } deriving (Show) +data GroupLinkInfo = GroupLinkInfo + { groupId :: GroupId, + memberRole :: GroupMemberRole + } + deriving (Show) + data AutoAccept = AutoAccept { businessAddress :: Bool, -- possibly, it can be wrapped together with acceptIncognito, or AutoAccept made sum type acceptIncognito :: IncognitoEnabled, @@ -481,18 +489,28 @@ getUserAddress db User {userId} = |] (Only userId) -getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupId, GroupMemberRole) +getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo) getUserContactLinkById db userId userContactLinkId = - ExceptT . firstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) SEUserContactLinkNotFound $ - DB.query - db - [sql| - SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role - FROM user_contact_links - WHERE user_id = ? - AND user_contact_link_id = ? - |] - (userId, userContactLinkId) + ExceptT . firstRow (\(ucl :. gli) -> (toUserContactLink ucl, toGroupLinkInfo gli)) SEUserContactLinkNotFound $ + DB.query db (groupLinkInfoQuery <> " AND user_contact_link_id = ?") (userId, userContactLinkId) + +groupLinkInfoQuery :: Query +groupLinkInfoQuery = + [sql| + SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role + FROM user_contact_links + WHERE user_id = ? + |] + +toGroupLinkInfo :: (Maybe GroupId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo +toGroupLinkInfo (groupId_, mRole_) = + (\groupId -> GroupLinkInfo {groupId, memberRole = fromMaybe GRMember mRole_}) + <$> groupId_ + +getGroupLinkInfo :: DB.Connection -> UserId -> GroupId -> IO (Maybe GroupLinkInfo) +getGroupLinkInfo db userId groupId = + fmap join $ maybeFirstRow toGroupLinkInfo $ + DB.query db (groupLinkInfoQuery <> " AND group_id = ?") (userId, groupId) getUserContactLinkByConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink) getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) = diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index 72f8e4b8fd..01f4cf3f68 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -4870,7 +4870,7 @@ Query: Plan: SCAN usage_conditions -Query: SELECT chat_item_id FROM chat_items WHERE ( user_id = ? AND group_id = ? AND item_ts < ? ) OR ( user_id = ? AND group_id = ? AND item_ts = ? AND chat_item_id < ? ) ORDER BY item_ts DESC, chat_item_id DESC LIMIT ? +Query: SELECT chat_item_id FROM chat_items WHERE (( user_id = ? AND group_id = ? AND item_ts < ? ) OR ( user_id = ? AND group_id = ? AND item_ts = ? AND chat_item_id < ? )) ORDER BY item_ts DESC, chat_item_id DESC LIMIT ? Plan: MULTI-INDEX OR INDEX 1 @@ -4879,7 +4879,7 @@ INDEX 2 SEARCH chat_items USING COVERING INDEX idx_chat_items_groups_item_ts (user_id=? AND group_id=? AND item_ts=? AND rowid ? ) OR ( user_id = ? AND group_id = ? AND item_ts = ? AND chat_item_id > ? ) ORDER BY item_ts ASC, chat_item_id ASC LIMIT ? +Query: SELECT chat_item_id FROM chat_items WHERE (( user_id = ? AND group_id = ? AND item_ts > ? ) OR ( user_id = ? AND group_id = ? AND item_ts = ? AND chat_item_id > ? )) ORDER BY item_ts ASC, chat_item_id ASC LIMIT ? Plan: MULTI-INDEX OR INDEX 1 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 94b67d8349..5ba7565611 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -668,6 +668,7 @@ data GroupLinkInvitation = GroupLinkInvitation fromMemberName :: ContactName, invitedMember :: MemberIdRole, groupProfile :: GroupProfile, + accepted :: Maybe GroupAcceptance, business :: Maybe BusinessChatInfo, groupSize :: Maybe Int } @@ -997,6 +998,7 @@ data GroupMemberStatus | GSMemGroupDeleted -- user member of the deleted group | GSMemUnknown -- unknown member, whose message was forwarded by an admin (likely member wasn't introduced due to not being a current member, but message was included in history) | GSMemInvited -- member is sent to or received invitation to join the group + | GSMemPendingApproval -- member is connected to host but pending host approval before connecting to other members ("knocking") | GSMemIntroduced -- user received x.grp.mem.intro for this member (only with GCPreMember) | GSMemIntroInvited -- member is sent to or received from intro invitation | GSMemAccepted -- member accepted invitation (only User and Invitee) @@ -1017,6 +1019,11 @@ instance ToJSON GroupMemberStatus where toJSON = J.String . textEncode toEncoding = JE.text . textEncode +acceptanceToStatus :: GroupAcceptance -> GroupMemberStatus +acceptanceToStatus = \case + GAAccepted -> GSMemAccepted + GAPending -> GSMemPendingApproval + memberActive :: GroupMember -> Bool memberActive m = case memberStatus m of GSMemRejected -> False @@ -1025,6 +1032,7 @@ memberActive m = case memberStatus m of GSMemGroupDeleted -> False GSMemUnknown -> False GSMemInvited -> False + GSMemPendingApproval -> True GSMemIntroduced -> False GSMemIntroInvited -> False GSMemAccepted -> False @@ -1045,6 +1053,7 @@ memberCurrent' = \case GSMemGroupDeleted -> False GSMemUnknown -> False GSMemInvited -> False + GSMemPendingApproval -> False GSMemIntroduced -> True GSMemIntroInvited -> True GSMemAccepted -> True @@ -1061,6 +1070,7 @@ memberRemoved m = case memberStatus m of GSMemGroupDeleted -> True GSMemUnknown -> False GSMemInvited -> False + GSMemPendingApproval -> False GSMemIntroduced -> False GSMemIntroInvited -> False GSMemAccepted -> False @@ -1077,6 +1087,7 @@ instance TextEncoding GroupMemberStatus where "deleted" -> Just GSMemGroupDeleted "unknown" -> Just GSMemUnknown "invited" -> Just GSMemInvited + "pending_approval" -> Just GSMemPendingApproval "introduced" -> Just GSMemIntroduced "intro-inv" -> Just GSMemIntroInvited "accepted" -> Just GSMemAccepted @@ -1092,6 +1103,7 @@ instance TextEncoding GroupMemberStatus where GSMemGroupDeleted -> "deleted" GSMemUnknown -> "unknown" GSMemInvited -> "invited" + GSMemPendingApproval -> "pending_approval" GSMemIntroduced -> "introduced" GSMemIntroInvited -> "intro-inv" GSMemAccepted -> "accepted" diff --git a/src/Simplex/Chat/Types/Shared.hs b/src/Simplex/Chat/Types/Shared.hs index d5c8f48776..e22610cfe5 100644 --- a/src/Simplex/Chat/Types/Shared.hs +++ b/src/Simplex/Chat/Types/Shared.hs @@ -48,3 +48,27 @@ instance FromJSON GroupMemberRole where instance ToJSON GroupMemberRole where toJSON = strToJSON toEncoding = strToJEncoding + +data GroupAcceptance = GAAccepted | GAPending deriving (Eq, Show) + +-- TODO [knocking] encoding doesn't match field type +instance FromField GroupAcceptance where fromField = blobFieldDecoder strDecode + +instance ToField GroupAcceptance where toField = toField . strEncode + +instance StrEncoding GroupAcceptance where + strEncode = \case + GAAccepted -> "accepted" + GAPending -> "pending" + strDecode = \case + "accepted" -> Right GAAccepted + "pending" -> Right GAPending + r -> Left $ "bad GroupAcceptance " <> B.unpack r + strP = strDecode <$?> A.takeByteString + +instance FromJSON GroupAcceptance where + parseJSON = strParseJSON "GroupAcceptance" + +instance ToJSON GroupAcceptance where + toJSON = strToJSON + toEncoding = strToJEncoding diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 7a20cb2fb0..1c4f4258d8 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1076,14 +1076,22 @@ viewNetworkStatuses = map viewStatuses . L.groupBy ((==) `on` netStatus) . sortO viewStatuses ss@(s :| _) = plain $ show (L.length ss) <> " connections " <> netStatusStr (netStatus s) viewUserJoinedGroup :: GroupInfo -> [StyledString] -viewUserJoinedGroup g = +viewUserJoinedGroup g@GroupInfo {membership} = case incognitoMembershipProfile g of - Just mp -> [ttyGroup' g <> ": you joined the group incognito as " <> incognitoProfile' (fromLocalProfile mp)] - Nothing -> [ttyGroup' g <> ": you joined the group"] + Just mp -> [ttyGroup' g <> ": you joined the group incognito as " <> incognitoProfile' (fromLocalProfile mp) <> pendingApproval_] + Nothing -> [ttyGroup' g <> ": you joined the group" <> pendingApproval_] + where + pendingApproval_ = case memberStatus membership of + GSMemPendingApproval -> ", pending approval" + _ -> "" viewJoinedGroupMember :: GroupInfo -> GroupMember -> [StyledString] -viewJoinedGroupMember g m = - [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "] +viewJoinedGroupMember g@GroupInfo {groupId} m@GroupMember {groupMemberId, memberStatus} = case memberStatus of + GSMemPendingApproval -> + [ (ttyGroup' g <> ": " <> ttyMember m <> " connected and pending approval, ") + <> ("use " <> highlight ("/_accept member #" <> show groupId <> " " <> show groupMemberId <> " ") <> " to accept member") + ] + _ -> [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "] viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString] viewReceivedGroupInvitation g c role = diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 2a9ad30dd2..31b36159fd 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -86,12 +86,13 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup = adminUsers = [], superUsers, ownersGroup, - directoryLog = Just $ ps "directory_service.log", + blockedFragmentsFile = Nothing, blockedWordsFile = Nothing, blockedExtensionRules = Nothing, nameSpellingFile = Nothing, profileNameLimit = maxBound, - acceptAsObserver = Nothing, + captchaGenerator = Nothing, + directoryLog = Just $ ps "directory_service.log", serviceName = "SimpleX-Directory", runCLI = False, searchResults = 3, @@ -182,6 +183,8 @@ testDirectoryService ps = superUser <## " Group approved!" bob <# "SimpleX-Directory> The group ID 1 (PSA) is approved and listed in directory!" 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." search bob "privacy" welcomeWithLink' search bob "security" welcomeWithLink' cath `connectVia` dsLink @@ -1045,6 +1048,8 @@ reapproveGroup count superUser bob = do superUser <## " Group approved!" bob <# "SimpleX-Directory> The group ID 1 (privacy) is approved and listed in directory!" 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." addCathAsOwner :: HasCallStack => TestCC -> TestCC -> IO () addCathAsOwner bob cath = do @@ -1114,7 +1119,9 @@ runDirectory cfg opts@DirectoryOpts {directoryLog} action = do threadDelay 500000 action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t) where - bot st = simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts + bot st = do + env <- newServiceState opts + simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts env registerGroup :: TestCC -> TestCC -> String -> String -> IO () registerGroup su u n fn = registerGroupId su u n fn 1 1 @@ -1187,6 +1194,8 @@ approveRegistrationId su u n gId ugId = do su <## " Group approved!" u <# ("SimpleX-Directory> The group ID " <> show ugId <> " (" <> n <> ") is approved and listed in directory!") 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.") connectVia :: TestCC -> String -> IO () u `connectVia` dsLink = do diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 14539ac219..7ec4033046 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -20,14 +20,14 @@ import qualified Data.ByteString.Char8 as B import Data.List (intercalate, isInfixOf) import qualified Data.Map.Strict as M import qualified Data.Text as T -import Simplex.Chat.Controller (ChatConfig (..)) +import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks) import Simplex.Chat.Library.Internal (uniqueMsgMentions, updatedMentionNames) import Simplex.Chat.Markdown (parseMaybeMarkdownList) import Simplex.Chat.Messages (CIMention (..), CIMentionMember (..), ChatItemId) import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgMention (..), MsgContent (..), msgContentText) import Simplex.Chat.Types -import Simplex.Chat.Types.Shared (GroupMemberRole (..)) +import Simplex.Chat.Types.Shared (GroupMemberRole (..), GroupAcceptance (..)) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.RetryInterval import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -98,7 +98,11 @@ chatGroupTests = do it "group link member role" testGroupLinkMemberRole it "host profile received" testGroupLinkHostProfileReceived it "existing contact merged" testGroupLinkExistingContactMerged - it "reject member joining via group link - blocked name" testGroupLinkRejectBlockedName + describe "group links - join rejection" $ do + it "reject member joining via group link - blocked name" testGLinkRejectBlockedName + describe "group links - manual acceptance" $ do + it "manually accept member joining via group link" testGLinkManualAcceptMember + it "delete pending member" testGLinkDeletePendingMember describe "group link connection plan" $ do it "ok to connect; known group" testPlanGroupLinkKnown it "own group link" testPlanGroupLinkOwn @@ -185,6 +189,8 @@ chatGroupTests = do it "should send updated mentions in history" testGroupHistoryWithMentions describe "uniqueMsgMentions" testUniqueMsgMentions describe "updatedMentionNames" testUpdatedMentionNames + describe "group direct messages" $ do + it "should send group direct messages" testGroupDirectMessages testGroupCheckMessages :: HasCallStack => TestParams -> IO () testGroupCheckMessages = @@ -2867,8 +2873,8 @@ testGroupLinkExistingContactMerged = bob #> "#team hi there" alice <# "#team bob> hi there" -testGroupLinkRejectBlockedName :: HasCallStack => TestParams -> IO () -testGroupLinkRejectBlockedName = +testGLinkRejectBlockedName :: HasCallStack => TestParams -> IO () +testGLinkRejectBlockedName = testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do alice ##> "/g team" @@ -2894,7 +2900,92 @@ testGroupLinkRejectBlockedName = bob <## "group link: known group #team" bob <## "use #team to send messages" where - cfg = testCfg {allowedProfileName = Just (const False)} + cfg = testCfg {chatHooks = defaultChatHooks {acceptMember = Just (\_ _ _ -> pure $ Left GRRBlockedName)}} + +testGLinkManualAcceptMember :: HasCallStack => TestParams -> IO () +testGLinkManualAcceptMember = + testChatCfg3 cfg aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup2 "team" alice bob + + alice ##> "/create link #team" + gLink <- getGroupLink alice "team" GRMember True + cath ##> ("/c " <> gLink) + cath <## "connection request sent!" + alice <## "cath (Catherine): accepting request to join group #team..." + concurrentlyN_ + [ alice <## "#team: cath connected and pending approval, use /_accept member #1 3 to accept member", + do + cath <## "#team: joining the group..." + cath <## "#team: you joined the group, pending approval" + ] + + -- pending approval member doesn't see messages sent in group + alice #> "#team hi group" + bob <# "#team alice> hi group" + + bob #> "#team hey" + alice <# "#team bob> hey" + + -- pending approval member and host can send messages to each other + alice ##> "/_send #1 @3 text send me proofs" + alice <# "#team send me proofs" + cath <# "#team alice> send me proofs" + + cath ##> "/_send #1 @1 text proofs" + cath <# "#team proofs" + alice <# "#team cath> proofs" + + -- accept member + alice ##> "/_accept member #1 3 member" + concurrentlyN_ + [ alice <## "#team: cath joined the group", + cath + <### [ "#team: you joined the group", + WithTime "#team alice> hi group [>>]", + WithTime "#team bob> hey [>>]", + "#team: member bob (Bob) is connected" + ], + do + bob <## "#team: alice added cath (Catherine) to the group (connecting...)" + bob <## "#team: new member cath is connected" + ] + + alice #> "#team welcome cath" + [bob, cath] *<# "#team alice> welcome cath" + + bob #> "#team hi cath" + [alice, cath] *<# "#team bob> hi cath" + + cath #> "#team hi group" + [alice, bob] *<# "#team cath> hi group" + where + cfg = testCfg {chatHooks = defaultChatHooks {acceptMember = Just (\_ _ _ -> pure $ Right (GAPending, GRObserver))}} + +testGLinkDeletePendingMember :: HasCallStack => TestParams -> IO () +testGLinkDeletePendingMember = + testChatCfg3 cfg aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup2 "team" alice bob + + alice ##> "/create link #team" + gLink <- getGroupLink alice "team" GRMember True + cath ##> ("/c " <> gLink) + cath <## "connection request sent!" + alice <## "cath (Catherine): accepting request to join group #team..." + concurrentlyN_ + [ alice <## "#team: cath connected and pending approval, use /_accept member #1 3 to accept member", + do + cath <## "#team: joining the group..." + cath <## "#team: you joined the group, pending approval" + ] + + alice ##> "/rm team cath" + alice <## "#team: you removed cath from the group" + cath <## "#team: alice removed you from the group" + cath <## "use /d #team to delete the group" + where + cfg = testCfg {chatHooks = defaultChatHooks {acceptMember = Just (\_ _ _ -> pure $ Right (GAPending, GRObserver))}} testPlanGroupLinkKnown :: HasCallStack => TestParams -> IO () testPlanGroupLinkKnown = @@ -6457,3 +6548,37 @@ testUpdatedMentionNames = do mentionedMember name_ = CIMention {memberId = MemberId "abcd", memberRef = ciMentionMember <$> name_} where ciMentionMember name = CIMentionMember {groupMemberId = 1, displayName = name, localAlias = Nothing, memberRole = GRMember} + +testGroupDirectMessages :: HasCallStack => TestParams -> IO () +testGroupDirectMessages = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice #> "#team 1" + [bob, cath] *<# "#team alice> 1" + + bob #> "#team 2" + [alice, cath] *<# "#team bob> 2" + + void $ withCCTransaction alice $ \db -> + DB.execute_ db "UPDATE group_members SET member_status='pending_approval' WHERE group_member_id = 2" + + alice ##> "/_send #1 @2 text 3" + alice <# "#team 3" + bob <# "#team alice> 3" + + void $ withCCTransaction bob $ \db -> + DB.execute_ db "UPDATE group_members SET member_status='pending_approval' WHERE group_member_id = 1" + + bob ##> "/_send #1 @1 text 4" + bob <# "#team 4" + alice <# "#team bob> 4" + + -- GSMemPendingApproval members don't receive messages sent to group. + -- Though in test we got here synthetically, in reality this status + -- means they are not yet part of group (not memberCurrent). + alice #> "#team 5" + cath <# "#team alice> 5" + + bob #> "#team 6" + cath <# "#team bob> 6" diff --git a/tests/SchemaDump.hs b/tests/SchemaDump.hs index 6c429e2a56..807fa4a0cb 100644 --- a/tests/SchemaDump.hs +++ b/tests/SchemaDump.hs @@ -125,7 +125,9 @@ skipComparisonForDownMigrations = -- indexes move down to the end of the file "20241125_indexes", -- indexes move down to the end of the file - "20250130_indexes" + "20250130_indexes", + -- index moves down to the end of the file + "20250227_member_acceptance" ] getSchema :: FilePath -> FilePath -> IO String