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>
This commit is contained in:
Evgeny 2025-03-03 18:57:29 +00:00 committed by GitHub
parent 27bf19c2b1
commit b2de37a9fb
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
32 changed files with 1188 additions and 525 deletions

View file

@ -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)))

View file

@ -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"

View file

@ -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)

View file

@ -1632,6 +1632,8 @@
<string name="group_member_status_group_deleted">group deleted</string>
<string name="group_member_status_unknown">unknown status</string>
<string name="group_member_status_invited">invited</string>
<string name="group_member_status_pending_approval">pending approval</string>
<string name="group_member_status_pending_approval_short">pending</string>
<string name="group_member_status_introduced">connecting (introduced)</string>
<string name="group_member_status_intro_invitation">connecting (introduction invitation)</string>
<string name="group_member_status_accepted">connecting (accepted)</string>

View file

@ -0,0 +1 @@
<svg xmlns="http://www.w3.org/2000/svg" height="24px" viewBox="0 -960 960 960" width="24px" fill="#000000"><path d="M484.41-250.5q15.33 0 25.96-10.54T521-286.91q0-15.33-10.54-25.96t-25.87-10.63q-15.33 0-25.96 10.54T448-287.09q0 15.33 10.54 25.96t25.87 10.63ZM450-394h57q0-25.5 6.75-46.75t39.75-48.75q31-25.5 43.5-50.25T609.5-594q0-52.28-33.49-83.89-33.48-31.61-89.81-31.61-48.32 0-85.18 23.84-36.86 23.84-54.02 66.16l51.61 19q10.89-28 32.89-43 22.01-15 51.5-15 34 0 55 18.5t21 47.5q0 22-12.96 41.2-12.96 19.19-37.77 40.36Q479-486 464.5-459.93 450-433.85 450-394Zm30.06 309q-80.97 0-153.13-31.26-72.15-31.27-125.79-85Q147.5-255 116.25-327.02 85-399.05 85-479.94q0-81.97 31.26-154.13 31.27-72.15 85-125.54Q255-813 327.02-844q72.03-31 152.92-31 81.97 0 154.13 31.13 72.17 31.13 125.55 84.5Q813-706 844-633.98q31 72.03 31 153.92 0 80.97-31.01 153.13-31.02 72.15-84.5 125.79Q706-147.5 633.98-116.25 561.95-85 480.06-85Z"/></svg>

After

Width:  |  Height:  |  Size: 923 B

View file

@ -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

View file

@ -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

View file

@ -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"

View file

@ -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"

View file

@ -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 <> " <level>* 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

View file

@ -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]

View file

@ -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

View file

@ -112,9 +112,6 @@ defaultChatConfig =
ntf = _defaultNtfServers,
netCfg = defaultNetworkConfig
},
allowedProfileName = Nothing,
profileNameLimit = maxBound,
acceptAsObserver = Nothing,
tbqSize = 1024,
fileChunkSize = 15780, -- do not change
xftpDescrPartSize = 14000,

View file

@ -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 ()

View file

@ -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) ->

View file

@ -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 =

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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",

View file

@ -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]

View file

@ -6,6 +6,7 @@ module Simplex.Chat.Store
ChatLockEntity (..),
UserMsgReceiptSettings (..),
UserContactLink (..),
GroupLinkInfo (..),
AutoAccept (..),
createChatStore,
migrations, -- used in tests

View file

@ -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

View file

@ -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_

View file

@ -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) =

View file

@ -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<?)
USE TEMP B-TREE FOR ORDER BY
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 ?
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

View file

@ -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"

View file

@ -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

View file

@ -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 <> " <role>") <> " to accept member")
]
_ -> [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "]
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
viewReceivedGroupInvitation g c role =

View file

@ -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

View file

@ -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 <message> 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 <role> 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 <role> 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"

View file

@ -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