mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
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:
parent
27bf19c2b1
commit
b2de37a9fb
32 changed files with 1188 additions and 525 deletions
|
@ -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)))
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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 |
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -112,9 +112,6 @@ defaultChatConfig =
|
|||
ntf = _defaultNtfServers,
|
||||
netCfg = defaultNetworkConfig
|
||||
},
|
||||
allowedProfileName = Nothing,
|
||||
profileNameLimit = maxBound,
|
||||
acceptAsObserver = Nothing,
|
||||
tbqSize = 1024,
|
||||
fileChunkSize = 15780, -- do not change
|
||||
xftpDescrPartSize = 14000,
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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) ->
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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",
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -6,6 +6,7 @@ module Simplex.Chat.Store
|
|||
ChatLockEntity (..),
|
||||
UserMsgReceiptSettings (..),
|
||||
UserContactLink (..),
|
||||
GroupLinkInfo (..),
|
||||
AutoAccept (..),
|
||||
createChatStore,
|
||||
migrations, -- used in tests
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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_
|
||||
|
|
|
@ -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) =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Reference in a new issue