core: don't create direct connections in group (#2996)

This commit is contained in:
spaced4ndy 2023-09-05 20:15:50 +04:00 committed by GitHub
parent 7a5d4a5a3d
commit 43e233f0eb
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
15 changed files with 723 additions and 524 deletions

View File

@ -3,24 +3,31 @@ sequenceDiagram
participant A as Alice
participant B as Bob
participant C as Existing<br>contact
note over A, B: 1. send and accept group invitation
A ->> B: x.grp.inv<br>invite Bob to group<br>(via contact connection)
B ->> A: x.grp.acpt<br>accept invitation<br>(via member connection)
B ->> A: establish group member connection
B ->> A: x.grp.acpt<br>accept invitation<br>(via member connection)<br>establish group member connection
note over M, B: 2. introduce new member Bob to all existing members
A ->> M: x.grp.mem.new<br>"announce" Bob<br>to existing members<br>(via member connections)
A ->> B: x.grp.mem.intro * N<br>"introduce" members<br>(via member connection)
B ->> A: x.grp.mem.inv * N<br>"invitations" to connect<br>for all members<br>(via member connection)
A ->> M: x.grp.mem.fwd<br>forward "invitations"<br>to all members<br>(via member connections)
loop batched
A ->> B: x.grp.mem.intro * N<br>"introduce" members and<br>their chat protocol versions<br>(via member connection)
note over B: prepare group member connections
opt chat protocol compatible version < 2
note over B: prepare direct connections
end
B ->> A: x.grp.mem.inv * N<br>"invitations" to connect<br>for all members<br>(via member connection)
end
A ->> M: x.grp.mem.fwd<br>forward "invitations" and<br>Bob's chat protocol version<br>to all members<br>(via member connections)
note over M, B: 3. establish direct and group member connections
M ->> B: establish group member connection
M ->> B: establish direct connection
note over M, C: 4. deduplicate new contact
B ->> M: x.info.probe<br>"probe" is sent to all new members
B ->> C: x.info.probe.check<br>"probe" hash,<br>in case contact and<br>member profiles match
C ->> B: x.info.probe.ok<br> original "probe",<br> in case contact and member<br>are the same user
note over B: merge existing and new contacts if received and sent probe hashes match
opt chat protocol compatible version < 2
M ->> B: establish direct connection
note over M, C: 4. deduplicate new contact
B ->> M: x.info.probe<br>"probe" is sent to all new members
B ->> C: x.info.probe.check<br>"probe" hash,<br>in case contact and<br>member profiles match
C ->> B: x.info.probe.ok<br> original "probe",<br> in case contact and member<br>are the same user
note over B: merge existing and new contacts if received and sent probe hashes match
end

File diff suppressed because one or more lines are too long

Before

Width:  |  Height:  |  Size: 34 KiB

After

Width:  |  Height:  |  Size: 34 KiB

View File

@ -94,6 +94,7 @@ import qualified Simplex.Messaging.Protocol as SMP
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport.Client (defaultSocksProxy)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Exit (exitFailure, exitSuccess)
import System.FilePath (combine, splitExtensions, takeFileName, (</>))
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout)
@ -104,7 +105,6 @@ import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay)
import UnliftIO.Directory
import UnliftIO.IO (hClose, hSeek, hTell, openFile)
import UnliftIO.STM
import Simplex.Messaging.Version
defaultChatConfig :: ChatConfig
defaultChatConfig =
@ -1431,12 +1431,16 @@ processChatCommand = \case
Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName
| otherwise -> throwChatError $ CEGroupDuplicateMember cName
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} <- withStore $ \db -> getGroupInvitation db user groupId
(invitation, ct) <- withStore $ \db -> do
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db user groupId
(inv,) <$> getContactViaMember db user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
Contact {activeConn = Connection {connChatVRange}} = ct
withChatLock "joinGroup" . procCmd $ do
dm <- directMessage $ XGrpAcpt (memberId (membership :: GroupMember))
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm
withStore' $ \db -> do
createMemberConnection db userId fromMember agentConnId
createMemberConnection db userId fromMember agentConnId connChatVRange
updateGroupMemberStatus db userId fromMember GSMemAccepted
updateGroupMemberStatus db userId membership GSMemAccepted
updateCIGroupInvitationStatus user
@ -1878,11 +1882,11 @@ processChatCommand = \case
mergedProfile' = userProfileToSend user' Nothing $ Just ct'
if mergedProfile' == mergedProfile
then pure s {notChanged = notChanged + 1}
else
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
else
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
in (notifyContact mergedProfile' ct' $> s {updateSuccesses = updateSuccesses + 1, changedContacts = cts'})
`catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> s {updateFailures = updateFailures + 1, changedContacts = cts'}
where
where
notifyContact mergedProfile' ct' = do
void $ sendDirectContactMessage ct' (XInfo mergedProfile')
when (directOrUsed ct') $ createSndFeatureItems user' ct ct'
@ -2825,7 +2829,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> Nothing
processDirectMessage :: ACommand 'Agent e -> ConnectionEntity -> Connection -> Maybe Contact -> m ()
processDirectMessage agentMsg connEntity conn@Connection {connId, viaUserContactLink, groupLinkId, customUserProfileId, connectionCode} = \case
processDirectMessage agentMsg connEntity conn@Connection {connId, connChatVRange, viaUserContactLink, groupLinkId, customUserProfileId, connectionCode} = \case
Nothing -> case agentMsg of
CONF confId _ connInfo -> do
-- [incognito] send saved profile
@ -2866,7 +2870,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
setConnConnReqInv db user connId cReq
getXGrpMemIntroContDirect db user ct
forM_ contData $ \(hostConnId, xGrpMemIntroCont) ->
sendXGrpMemInv hostConnId directConnReq xGrpMemIntroCont
sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
MSG msgMeta _msgFlags msgBody -> do
cmdId <- createAckCmd conn
@ -2948,7 +2952,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
forM_ groupId_ $ \groupId -> do
gVar <- asks idsDrg
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation
withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds
withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds connChatVRange
_ -> pure ()
Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) ->
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
@ -3015,22 +3019,32 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
case cReq of
groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of
-- [async agent commands] XGrpMemIntro continuation on receiving INV
CFCreateConnGrpMemInv -> do
contData <- withStore' $ \db -> do
setConnConnReqInv db user connId cReq
getXGrpMemIntroContGroup db user m
forM_ contData $ \(hostConnId, directConnReq) -> do
let GroupMember {groupMemberId, memberId} = m
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
CFCreateConnGrpMemInv ->
ifM
(featureVersionSupported (connChatVRange conn) groupNoDirectVersion)
sendWithoutDirectCReq
sendWithDirectCReq
where
sendWithoutDirectCReq = do
let GroupMember {groupMemberId, memberId} = m
hostConnId <- withStore $ \db -> do
liftIO $ setConnConnReqInv db user connId cReq
getHostConnId db user groupId
sendXGrpMemInv hostConnId Nothing XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
sendWithDirectCReq = do
let GroupMember {groupMemberId, memberId} = m
contData <- withStore' $ \db -> do
setConnConnReqInv db user connId cReq
getXGrpMemIntroContGroup db user m
forM_ contData $ \(hostConnId, directConnReq) ->
sendXGrpMemInv hostConnId (Just directConnReq) XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
-- [async agent commands] group link auto-accept continuation on receiving INV
CFCreateConnGrpInv ->
withStore' (\db -> getContactViaMember db user m) >>= \case
Nothing -> messageError "implementation error: invitee does not have contact"
Just ct -> do
withStore' $ \db -> setNewContactMemberConnRequest db user m cReq
groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo
sendGrpInvitation ct m groupLinkId
toView $ CRSentGroupInvitation user gInfo ct m
CFCreateConnGrpInv -> do
ct <- withStore $ \db -> getContactViaMember db user m
withStore' $ \db -> setNewContactMemberConnRequest db user m cReq
groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo
sendGrpInvitation ct m groupLinkId
toView $ CRSentGroupInvitation user gInfo ct m
where
sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> m ()
sendGrpInvitation ct GroupMember {memberId, memberRole = memRole} groupLinkId = do
@ -3106,7 +3120,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
processIntro intro `catchChatError` (toView . CRChatError (Just user))
where
processIntro intro@GroupMemberIntro {introId} = do
void $ sendDirectMessage conn (XGrpMemIntro . memberInfo $ reMember intro) (GroupId groupId)
void $ sendDirectMessage conn (XGrpMemIntro $ memberInfo (reMember intro)) (GroupId groupId)
withStore' $ \db -> updateIntroStatus db introId GMIntroSent
_ -> do
-- TODO send probe and decide whether to use existing contact connection or the new contact connection
@ -4006,7 +4020,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
processGroupInvitation ct inv msg msgMeta = do
let Contact {localDisplayName = c, activeConn = Connection {customUserProfileId, groupLinkId = groupLinkId'}} = ct
let Contact {localDisplayName = c, activeConn = Connection {connChatVRange, customUserProfileId, groupLinkId = groupLinkId'}} = ct
GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
@ -4017,7 +4031,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
then do
connIds <- joinAgentConnectionAsync user True connRequest =<< directMessage (XGrpAcpt memberId)
withStore' $ \db -> do
createMemberConnectionAsync db user hostId connIds
createMemberConnectionAsync db user hostId connIds connChatVRange
updateGroupMemberStatusById db userId hostId GSMemAccepted
updateGroupMemberStatus db userId membership GSMemAccepted
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
@ -4230,7 +4244,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> pure conn'
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> MsgMeta -> m ()
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole memberProfile) msg msgMeta = do
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ memberProfile) msg msgMeta = do
checkHostRole m memRole
members <- withStore' $ \db -> getGroupMembers db user gInfo
unless (sameMemberId memId $ membership gInfo) $
@ -4243,7 +4257,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ _) = do
xGrpMemIntro gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
case memberCategory m of
GCHostMember -> do
members <- withStore' $ \db -> getGroupMembers db user gInfo
@ -4252,14 +4266,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
else do
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c)
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation
directConnIds <- createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation
-- [incognito] direct connection with member has to be established using the same incognito profile [that was known to host and used for group membership]
groupConnIds <- createConn
directConnIds <- case memberChatVRange of
Nothing -> Just <$> createConn
Just mcvr ->
ifM
(featureVersionSupported (fromChatVRange mcvr) groupNoDirectVersion)
(pure Nothing)
(Just <$> createConn)
let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId
_ -> messageError "x.grp.mem.intro can be only sent by host member"
where
createConn = createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation
sendXGrpMemInv :: Int64 -> ConnReqInvitation -> XGrpMemIntroCont -> m ()
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> m ()
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
hostConn <- withStore $ \db -> getConnectionById db user hostConnId
let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq}
@ -4280,7 +4301,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m memInfo@(MemberInfo memId memRole _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
checkHostRole m memRole
members <- withStore' $ \db -> getGroupMembers db user gInfo
toMember <- case find (sameMemberId memId) members of
@ -4295,9 +4316,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
dm <- directMessage $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership)
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm
directConnIds <- joinAgentConnectionAsync user enableNtfs directConnReq dm
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm
let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
withStore' $ \db -> createIntroToMemberContact db user m toMember groupConnIds directConnIds customUserProfileId
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> MsgMeta -> m ()
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg msgMeta
@ -4444,6 +4466,13 @@ updateConnChatVRange conn@Connection {connId, connChatVRange} msgChatVRange
pure conn {connChatVRange = msgChatVRange}
| otherwise = pure conn
featureVersionSupported :: ChatMonad' m => VersionRange -> Version -> m Bool
featureVersionSupported peerVRange v = do
ChatConfig {chatVRange} <- asks config
case chatVRange `compatibleVersion` peerVRange of
Just (Compatible v') -> pure $ v' >= v
Nothing -> pure False
parseFileDescription :: (ChatMonad m, FilePartyI p) => Text -> m (ValidFileDescription p)
parseFileDescription =
liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8)

View File

@ -54,6 +54,10 @@ currentChatVersion = 2
supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion
-- version that starts support for skipping establishing direct connections in a group
groupNoDirectVersion :: Version
groupNoDirectVersion = 2
data ConnectionEntity
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
@ -107,18 +111,6 @@ data AppMessage (e :: MsgEncoding) where
AMJson :: AppMessageJson -> AppMessage 'Json
AMBinary :: AppMessageBinary -> AppMessage 'Binary
newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRange} deriving (Eq, Show)
chatInitialVRange :: VersionRange
chatInitialVRange = versionToRange 1
instance FromJSON ChatVersionRange where
parseJSON v = ChatVersionRange <$> strParseJSON "ChatVersionRange" v
instance ToJSON ChatVersionRange where
toJSON (ChatVersionRange vr) = strToJSON vr
toEncoding (ChatVersionRange vr) = strToJEncoding vr
-- chat message is sent as JSON with these properties
data AppMessageJson = AppMessageJson
{ v :: Maybe ChatVersionRange,

View File

@ -498,10 +498,10 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (Vers
<$> DB.execute
db
[sql|
UPDATE contact_requests
SET agent_invitation_id = ?, chat_vrange_min_version = ?, chat_vrange_max_version = ?, updated_at = ?
WHERE user_id = ? AND contact_request_id = ?
|]
UPDATE contact_requests
SET agent_invitation_id = ?, chat_vrange_min_version = ?, chat_vrange_max_version = ?, updated_at = ?
WHERE user_id = ? AND contact_request_id = ?
|]
(invId, minV, maxV, currentTs, userId, cReqId)
else withLocalDisplayName db userId displayName $ \ldn ->
Right <$> do

View File

@ -83,6 +83,7 @@ module Simplex.Chat.Store.Groups
updateGroupSettings,
getXGrpMemIntroContDirect,
getXGrpMemIntroContGroup,
getHostConnId,
)
where
@ -98,7 +99,6 @@ import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
import Simplex.Chat.Protocol (chatInitialVRange)
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
@ -106,6 +106,7 @@ import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version
import UnliftIO.STM
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow
@ -481,20 +482,21 @@ getUserGroupsWithSummary db user _contactId_ search_ =
-- the statuses on non-current members should match memberCurrent' function
getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary
getGroupSummary db User {userId} groupId = do
currentMembers_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT count (m.group_member_id)
FROM groups g
JOIN group_members m USING (group_id)
WHERE g.user_id = ?
AND g.group_id = ?
AND m.member_status != ?
AND m.member_status != ?
AND m.member_status != ?
|]
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemInvited)
currentMembers_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT count (m.group_member_id)
FROM groups g
JOIN group_members m USING (group_id)
WHERE g.user_id = ?
AND g.group_id = ?
AND m.member_status != ?
AND m.member_status != ?
AND m.member_status != ?
|]
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemInvited)
pure GroupSummary {currentMembers = fromMaybe 0 currentMembers_}
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
@ -613,11 +615,11 @@ getGroupInvitation db user groupId =
DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId)
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole agentConnId connRequest =
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile, activeConn = Connection {connChatVRange}} memberRole agentConnId connRequest =
createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime
member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt
void $ createMemberConnection_ db userId groupMemberId agentConnId connChatVRange Nothing 0 createdAt
pure member
where
createMember_ memberId createdAt = do
@ -652,13 +654,13 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
:. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt)
)
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> ExceptT StoreError IO ()
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) =
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionRange -> ExceptT StoreError IO ()
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) connChatVRange =
createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime
insertMember_ (MemberId memId) createdAt
groupMemberId <- liftIO $ insertedRowId db
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId connChatVRange Nothing 0 createdAt
setCommandConnId db user cmdId connId
where
insertMember_ memberId createdAt =
@ -674,31 +676,32 @@ createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Co
:. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt)
)
getContactViaMember :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact)
getContactViaMember :: DB.Connection -> User -> GroupMember -> ExceptT StoreError IO Contact
getContactViaMember db user@User {userId} GroupMember {groupMemberId} =
maybeFirstRow (toContact user) $
DB.query
db
[sql|
SELECT
-- Contact
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.chat_vrange_min_version, c.chat_vrange_max_version
FROM contacts ct
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.contact_id = ct.contact_id
)
JOIN group_members m ON m.contact_id = ct.contact_id
WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0
|]
(userId, groupMemberId)
ExceptT $
firstRow (toContact user) (SEContactNotFoundByMemberId groupMemberId) $
DB.query
db
[sql|
SELECT
-- Contact
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.chat_vrange_min_version, c.chat_vrange_max_version
FROM contacts ct
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.contact_id = ct.contact_id
)
JOIN group_members m ON m.contact_id = ct.contact_id
WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0
|]
(userId, groupMemberId)
setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO ()
setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do
@ -710,15 +713,15 @@ getMemberInvitation db User {userId} groupMemberId =
fmap join . maybeFirstRow fromOnly $
DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId)
createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> IO ()
createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do
createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> VersionRange -> IO ()
createMemberConnection db userId GroupMember {groupMemberId} agentConnId connChatVRange = do
currentTs <- getCurrentTime
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs
void $ createMemberConnection_ db userId groupMemberId agentConnId connChatVRange Nothing 0 currentTs
createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> IO ()
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) = do
createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> VersionRange -> IO ()
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) connChatVRange = do
currentTs <- getCurrentTime
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId connChatVRange Nothing 0 currentTs
setCommandConnId db user cmdId connId
updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO ()
@ -738,25 +741,30 @@ updateGroupMemberStatusById db userId groupMemberId memStatus = do
-- | add new member with profile
createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image, contactLink, preferences}) memCategory memStatus =
ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do
currentTs <- getCurrentTime
createNewGroupMember db user gInfo memInfo memCategory memStatus = do
currentTs <- liftIO getCurrentTime
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memInfo currentTs
let newMember =
NewGroupMember
{ memInfo,
memCategory,
memStatus,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Nothing,
memProfileId
}
liftIO $ createNewMember_ db user gInfo newMember currentTs
createNewMemberProfile_ :: DB.Connection -> User -> MemberInfo -> UTCTime -> ExceptT StoreError IO (Text, ProfileId)
createNewMemberProfile_ db User {userId} (MemberInfo _ _ _ Profile {displayName, fullName, image, contactLink, preferences}) createdAt =
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
DB.execute
db
"INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs)
memProfileId <- insertedRowId db
let newMember =
NewGroupMember
{ memInfo,
memCategory,
memStatus,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Nothing,
memProfileId
}
Right <$> createNewMember_ db user gInfo newMember currentTs
(displayName, fullName, image, contactLink, userId, preferences, createdAt, createdAt)
profileId <- insertedRowId db
pure $ Right (ldn, profileId)
createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember
createNewMember_
@ -764,7 +772,7 @@ createNewMember_
User {userId, userContactId}
GroupInfo {groupId}
NewGroupMember
{ memInfo = MemberInfo memberId memberRole memberProfile,
{ memInfo = MemberInfo memberId memberRole _ memberProfile,
memCategory = memberCategory,
memStatus = memberStatus,
memInvitedBy = invitedBy,
@ -908,43 +916,41 @@ getIntroduction_ db reMember toMember = ExceptT $ do
where
toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
toIntro [(introId, groupConnReq, directConnReq, introStatus)] =
let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq
let introInvitation = IntroInvitation <$> groupConnReq <*> pure directConnReq
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
toIntro _ = Left SEIntroNotFound
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId = do
let mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
currentTs <- liftIO getCurrentTime
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId chatInitialVRange memberContactId Nothing customUserProfileId cLevel currentTs
liftIO $ setCommandConnId db user directCmdId directConnId
(localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing
newMember <- case directConnIds of
Just (directCmdId, directAgentConnId) -> do
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId mcvr memberContactId Nothing customUserProfileId cLevel currentTs
liftIO $ setCommandConnId db user directCmdId directConnId
(localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Just contactId, memProfileId}
Nothing -> do
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memInfo currentTs
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Nothing, memProfileId}
liftIO $ do
let newMember =
NewGroupMember
{ memInfo,
memCategory = GCPreMember,
memStatus = GSMemIntroduced,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Just contactId,
memProfileId
}
member <- createNewMember_ db user gInfo newMember currentTs
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId mcvr memberContactId cLevel currentTs
liftIO $ setCommandConnId db user groupCmdId groupConnId
pure (member :: GroupMember) {activeConn = Just conn}
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> IO ()
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionRange -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> IO ()
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId = do
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
currentTs <- getCurrentTime
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId mcvr viaContactId cLevel currentTs
setCommandConnId db user groupCmdId groupConnId
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId chatInitialVRange viaContactId Nothing customUserProfileId cLevel currentTs
setCommandConnId db user directCmdId directConnId
contactId <- createMemberContact_ directConnId currentTs
updateMember_ contactId currentTs
forM_ directConnIds $ \(directCmdId, directAgentConnId) -> do
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId mcvr viaContactId Nothing customUserProfileId cLevel currentTs
setCommandConnId db user directCmdId directConnId
contactId <- createMemberContact_ directConnId currentTs
updateMember_ contactId currentTs
where
createMemberContact_ :: Int64 -> UTCTime -> IO Int64
createMemberContact_ connId ts = do
@ -971,8 +977,8 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId =
|]
[":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId]
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection
createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId chatInitialVRange viaContact Nothing Nothing
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> Maybe Int64 -> Int -> UTCTime -> IO Connection
createMemberConnection_ db userId groupMemberId agentConnId connChatVRange viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId connChatVRange viaContact Nothing Nothing
getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db User {userId, userContactId} Contact {contactId} =
@ -1343,3 +1349,9 @@ getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do
toCont (hostConnId, connReq_) = case connReq_ of
Just connReq -> Just (hostConnId, connReq)
_ -> Nothing
getHostConnId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId
getHostConnId db user@User {userId} groupId = do
hostMemberId <- getHostMemberId_ db user groupId
ExceptT . firstRow fromOnly (SEConnectionNotFoundByMemberId hostMemberId) $
DB.query db "SELECT connection_id FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, hostMemberId)

View File

@ -51,6 +51,7 @@ data StoreError
| SEUserNotFoundByContactRequestId {contactRequestId :: Int64}
| SEContactNotFound {contactId :: ContactId}
| SEContactNotFoundByName {contactName :: ContactName}
| SEContactNotFoundByMemberId {groupMemberId :: GroupMemberId}
| SEContactNotReady {contactName :: ContactName}
| SEDuplicateContactLink
| SEUserContactLinkNotFound
@ -78,6 +79,7 @@ data StoreError
| SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId}
| SEConnectionNotFound {agentConnId :: AgentConnId}
| SEConnectionNotFoundById {connId :: Int64}
| SEConnectionNotFoundByMemberId {groupMemberId :: GroupMemberId}
| SEPendingConnectionNotFound {connId :: Int64}
| SEIntroNotFound
| SEUniqueID

View File

@ -347,11 +347,12 @@ data ChatSettings = ChatSettings
instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions
defaultChatSettings :: ChatSettings
defaultChatSettings = ChatSettings
{ enableNtfs = True,
sendRcpts = Nothing,
favorite = False
}
defaultChatSettings =
ChatSettings
{ enableNtfs = True,
sendRcpts = Nothing,
favorite = False
}
pattern DisableNtfs :: ChatSettings
pattern DisableNtfs <- ChatSettings {enableNtfs = False}
@ -538,24 +539,31 @@ instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOpt
data IntroInvitation = IntroInvitation
{ groupConnReq :: ConnReqInvitation,
directConnReq :: ConnReqInvitation
directConnReq :: Maybe ConnReqInvitation
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON IntroInvitation where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON IntroInvitation where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data MemberInfo = MemberInfo
{ memberId :: MemberId,
memberRole :: GroupMemberRole,
v :: Maybe ChatVersionRange,
profile :: Profile
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON MemberInfo where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON MemberInfo where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
memberInfo :: GroupMember -> MemberInfo
memberInfo GroupMember {memberId, memberRole, memberProfile} =
MemberInfo memberId memberRole (fromLocalProfile memberProfile)
memberInfo GroupMember {memberId, memberRole, memberProfile, activeConn} =
MemberInfo memberId memberRole memberChatVRange (fromLocalProfile memberProfile)
where
memberChatVRange = ChatVersionRange . connChatVRange <$> activeConn
data ReceivedGroupInvitation = ReceivedGroupInvitation
{ fromMember :: GroupMember,
@ -1467,3 +1475,15 @@ instance ProtocolTypeI p => ToJSON (ServerCfg p) where
instance ProtocolTypeI p => FromJSON (ServerCfg p) where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRange} deriving (Eq, Show)
chatInitialVRange :: VersionRange
chatInitialVRange = versionToRange 1
instance FromJSON ChatVersionRange where
parseJSON v = ChatVersionRange <$> strParseJSON "ChatVersionRange" v
instance ToJSON ChatVersionRange where
toJSON (ChatVersionRange vr) = strToJSON vr
toEncoding (ChatVersionRange vr) = strToJEncoding vr

View File

@ -13,13 +13,14 @@ import Control.Monad (forM_)
import Directory.Options
import Directory.Service
import Directory.Store
import GHC.IO.Handle (hClose)
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Chat.Core
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
import Simplex.Chat.Types (GroupMemberRole (..), Profile (..))
import System.FilePath ((</>))
import Test.Hspec
import GHC.IO.Handle (hClose)
directoryServiceTests :: SpecWith FilePath
directoryServiceTests = do
@ -232,10 +233,10 @@ testJoinGroup tmp =
dan <## "bob (Bob): contact is connected"
dan <## "#privacy: you joined the group"
dan <# ("#privacy bob> " <> welcomeMsg)
dan <###
[ "#privacy: member SimpleX-Directory is connected",
"#privacy: member cath (Catherine) is connected"
],
dan
<### [ "#privacy: member SimpleX-Directory is connected",
"#privacy: member cath (Catherine) is connected"
],
do
cath <## "#privacy: bob added dan (Daniel) to the group (connecting...)"
cath <## "#privacy: new member dan is connected"
@ -243,9 +244,9 @@ testJoinGroup tmp =
testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO ()
testDelistedOwnerLeaves tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -259,9 +260,9 @@ testDelistedOwnerLeaves tmp =
testDelistedOwnerRemoved :: HasCallStack => FilePath -> IO ()
testDelistedOwnerRemoved tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -274,9 +275,9 @@ testDelistedOwnerRemoved tmp =
testNotDelistedMemberLeaves :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberLeaves tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -286,10 +287,10 @@ testNotDelistedMemberLeaves tmp =
groupFound cath "privacy"
testNotDelistedMemberRemoved :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberRemoved tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
testNotDelistedMemberRemoved tmp =
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -299,9 +300,9 @@ testNotDelistedMemberRemoved tmp =
testDelistedServiceRemoved :: HasCallStack => FilePath -> IO ()
testDelistedServiceRemoved tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -316,9 +317,9 @@ testDelistedServiceRemoved tmp =
testDelistedRoleChanges :: HasCallStack => FilePath -> IO ()
testDelistedRoleChanges tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -362,9 +363,9 @@ testDelistedRoleChanges tmp =
testNotDelistedMemberRoleChanged :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberRoleChanged tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -426,9 +427,9 @@ testNotApprovedBadRoles tmp =
testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
testRegOwnerChangedProfile tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -445,9 +446,9 @@ testRegOwnerChangedProfile tmp =
testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
testAnotherOwnerChangedProfile tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -464,9 +465,9 @@ testAnotherOwnerChangedProfile tmp =
testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
testRegOwnerRemovedLink tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -497,9 +498,9 @@ testRegOwnerRemovedLink tmp =
testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
testAnotherOwnerRemovedLink tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -646,9 +647,9 @@ testDuplicateProhibitApproval tmp =
testListUserGroups :: HasCallStack => FilePath -> IO ()
testListUserGroups tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
cath `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -686,15 +687,15 @@ testRestoreDirectory tmp = do
withTestChat tmp "bob" $ \bob ->
withTestChat tmp "cath" $ \cath -> do
bob <## "2 contacts connected (use /cs for the list)"
bob <###
[ "#privacy (Privacy): connected to server(s)",
"#security (Security): connected to server(s)"
]
bob
<### [ "#privacy (Privacy): connected to server(s)",
"#security (Security): connected to server(s)"
]
cath <## "2 contacts connected (use /cs for the list)"
cath <###
[ "#privacy (Privacy): connected to server(s)",
"#anonymity (Anonymity): connected to server(s)"
]
cath
<### [ "#privacy (Privacy): connected to server(s)",
"#anonymity (Anonymity): connected to server(s)"
]
listGroups superUser bob cath
groupFoundN 3 bob "privacy"
groupFound bob "security"
@ -784,10 +785,13 @@ addCathAsOwner bob cath = do
cath <## "#privacy: member SimpleX-Directory is connected"
withDirectoryService :: HasCallStack => FilePath -> (TestCC -> String -> IO ()) -> IO ()
withDirectoryService tmp test = do
withDirectoryService tmp = withDirectoryServiceCfg tmp testCfg
withDirectoryServiceCfg :: HasCallStack => FilePath -> ChatConfig -> (TestCC -> String -> IO ()) -> IO ()
withDirectoryServiceCfg tmp cfg test = do
dsLink <-
withNewTestChat tmp serviceDbPrefix directoryProfile $ \ds ->
withNewTestChat tmp "super_user" aliceProfile $ \superUser -> do
withNewTestChatCfg tmp cfg serviceDbPrefix directoryProfile $ \ds ->
withNewTestChatCfg tmp cfg "super_user" aliceProfile $ \superUser -> do
connectUsers ds superUser
ds ##> "/ad"
getContactLink ds True
@ -800,7 +804,7 @@ restoreDirectoryService tmp ctCount grCount test = do
ds <## (show ctCount <> " contacts connected (use /cs for the list)")
ds <## "Your address is active! To show: /sa"
ds <## (show grCount <> " group links active")
forM_ [1..grCount] $ \_ -> ds <##. "#"
forM_ [1 .. grCount] $ \_ -> ds <##. "#"
ds ##> "/sa"
dsLink <- getContactLink ds False
ds <## "auto_accept on"

View File

@ -22,6 +22,7 @@ import Simplex.Chat
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..))
import Simplex.Chat.Core
import Simplex.Chat.Options
import Simplex.Chat.Protocol (groupNoDirectVersion)
import Simplex.Chat.Store
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Terminal
@ -133,6 +134,16 @@ testAgentCfgV1 =
testCfgV1 :: ChatConfig
testCfgV1 = testCfg {agentConfig = testAgentCfgV1}
testCfgCreateGroupDirect :: ChatConfig
testCfgCreateGroupDirect =
mkCfgCreateGroupDirect testCfg
mkCfgCreateGroupDirect :: ChatConfig -> ChatConfig
mkCfgCreateGroupDirect cfg = cfg {chatVRange = groupCreateDirectVRange}
groupCreateDirectVRange :: VersionRange
groupCreateDirectVRange = mkVersionRange 1 (groupNoDirectVersion - 1)
createTestChat :: FilePath -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
createTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefix profile = do
Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp </> dbPrefix) dbKey MCError
@ -249,7 +260,7 @@ getTermLine cc =
Just s -> do
-- remove condition to always echo virtual terminal
when (printOutput cc) $ do
-- when True $ do
-- when True $ do
name <- userName cc
putStrLn $ name <> ": " <> s
pure s
@ -288,7 +299,10 @@ testChatCfgOpts3 cfg opts p1 p2 p3 test = testChatN cfg opts [p1, p2, p3] test_
test_ _ = error "expected 3 chat clients"
testChat4 :: HasCallStack => Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
testChat4 p1 p2 p3 p4 test = testChatN testCfg testOpts [p1, p2, p3, p4] test_
testChat4 = testChatCfg4 testCfg
testChatCfg4 :: HasCallStack => ChatConfig -> Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
testChatCfg4 cfg p1 p2 p3 p4 test = testChatN cfg testOpts [p1, p2, p3, p4] test_
where
test_ :: HasCallStack => [TestCC] -> IO ()
test_ [tc1, tc2, tc3, tc4] = test tc1 tc2 tc3 tc4

View File

@ -46,7 +46,7 @@ chatFileTests = do
it "files folder: sender deleted file during transfer" testFilesFoldersImageSndDelete
it "files folder: recipient deleted file during transfer" testFilesFoldersImageRcvDelete
it "send and receive image with text and quote" testSendImageWithTextAndQuote
describe "send and receive image to group" testGroupSendImage
it "send and receive image to group" testGroupSendImage
it "send and receive image with text and quote to group" testGroupSendImageWithTextAndQuote
describe "async sending and receiving files" $ do
-- fails on CI
@ -724,11 +724,10 @@ testSendImageWithTextAndQuote =
(alice <## "completed sending file 3 (test.jpg) to bob")
B.readFile "./tests/tmp/test_1.jpg" `shouldReturn` src
testGroupSendImage :: SpecWith FilePath
testGroupSendImage = versionTestMatrix3 runTestGroupSendImage
where
runTestGroupSendImage :: HasCallStack => TestCC -> TestCC -> TestCC -> IO ()
runTestGroupSendImage alice bob cath = do
testGroupSendImage :: HasCallStack => FilePath -> IO ()
testGroupSendImage =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
threadDelay 1000000
alice ##> "/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}"

View File

@ -10,8 +10,10 @@ import Control.Concurrent.Async (concurrently_)
import Control.Monad (when)
import qualified Data.Text as T
import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Chat.Protocol (supportedChatVRange)
import Simplex.Chat.Store (agentStoreFile, chatStoreFile)
import Simplex.Chat.Types (GroupMemberRole (..))
import Simplex.Messaging.Version
import System.Directory (copyFile)
import System.FilePath ((</>))
import Test.Hspec
@ -19,7 +21,7 @@ import Test.Hspec
chatGroupTests :: SpecWith FilePath
chatGroupTests = do
describe "chat groups" $ do
describe "add contacts, create group and send/receive messages" testGroup
it "add contacts, create group and send/receive messages" testGroup
it "add contacts, create group and send/receive messages, check messages" testGroupCheckMessages
it "create and join group with 4 members" testGroup2
it "create and delete group" testGroupDelete
@ -64,15 +66,54 @@ chatGroupTests = do
describe "group delivery receipts" $ do
it "should send delivery receipts in group" testSendGroupDeliveryReceipts
it "should send delivery receipts in group depending on configuration" testConfigureGroupDeliveryReceipts
testGroup :: HasCallStack => SpecWith FilePath
testGroup = versionTestMatrix3 runTestGroup
describe "direct connections in group are not established based on chat protocol version" $ do
describe "3 members group" $ do
testNoDirect _0 _0 True
testNoDirect _0 _1 False
testNoDirect _1 _0 False
testNoDirect _1 _1 False
describe "4 members group" $ do
testNoDirect4 _0 _0 _0 True True True
testNoDirect4 _0 _0 _1 True False False
testNoDirect4 _0 _1 _0 False True False
testNoDirect4 _0 _1 _1 False False False
testNoDirect4 _1 _0 _0 False False True
testNoDirect4 _1 _0 _1 False False False
testNoDirect4 _1 _1 _0 False False False
testNoDirect4 _1 _1 _1 False False False
where
runTestGroup alice bob cath = testGroupShared alice bob cath False
_0 = supportedChatVRange -- don't create direct connections
_1 = groupCreateDirectVRange
-- having host configured with older version doesn't have effect in tests
-- because host uses current code and sends version in MemberInfo
testNoDirect vrMem2 vrMem3 noConns =
it
( "host " <> vRangeStr supportedChatVRange
<> (", 2nd mem " <> vRangeStr vrMem2)
<> (", 3rd mem " <> vRangeStr vrMem3)
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
)
$ testNoGroupDirectConns supportedChatVRange vrMem2 vrMem3 noConns
testNoDirect4 vrMem2 vrMem3 vrMem4 noConns23 noConns24 noConns34 =
it
( "host " <> vRangeStr supportedChatVRange
<> (", 2nd mem " <> vRangeStr vrMem2)
<> (", 3rd mem " <> vRangeStr vrMem3)
<> (", 4th mem " <> vRangeStr vrMem4)
<> (if noConns23 then " : 2 <!!> 3" else " : 2 <##> 3")
<> (if noConns24 then " : 2 <!!> 4" else " : 2 <##> 4")
<> (if noConns34 then " : 3 <!!> 4" else " : 3 <##> 4")
)
$ testNoGroupDirectConns4Members supportedChatVRange vrMem2 vrMem3 vrMem4 noConns23 noConns24 noConns34
testGroup :: HasCallStack => FilePath -> IO ()
testGroup =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> testGroupShared alice bob cath False
testGroupCheckMessages :: HasCallStack => FilePath -> IO ()
testGroupCheckMessages =
testChat3 aliceProfile bobProfile cathProfile $
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> testGroupShared alice bob cath True
testGroupShared :: HasCallStack => TestCC -> TestCC -> TestCC -> Bool -> IO ()
@ -233,7 +274,7 @@ testGroupShared alice bob cath checkMessages = do
testGroup2 :: HasCallStack => FilePath -> IO ()
testGroup2 =
testChat4 aliceProfile bobProfile cathProfile danProfile $
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
connectUsers alice bob
connectUsers alice cath
@ -679,7 +720,7 @@ testDeleteGroupMemberProfileKept =
testGroupRemoveAdd :: HasCallStack => FilePath -> IO ()
testGroupRemoveAdd =
testChat3 aliceProfile bobProfile cathProfile $
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
-- remove member
@ -754,7 +795,7 @@ testGroupList =
testGroupMessageQuotedReply :: HasCallStack => FilePath -> IO ()
testGroupMessageQuotedReply =
testChat3 aliceProfile bobProfile cathProfile $
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
threadDelay 1000000
@ -1232,7 +1273,7 @@ testGroupDeleteUnusedContacts =
cath <## "alice (Alice)"
cath `hasContactProfiles` ["alice", "cath"]
where
cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0}
cfg = mkCfgCreateGroupDirect $ testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0}
deleteGroup :: HasCallStack => TestCC -> TestCC -> TestCC -> String -> IO ()
deleteGroup alice bob cath group = do
alice ##> ("/d #" <> group)
@ -1321,7 +1362,7 @@ testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile
testGroupModerate :: HasCallStack => FilePath -> IO ()
testGroupModerate =
testChat3 aliceProfile bobProfile cathProfile $
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
alice ##> "/mr team cath member"
@ -1352,7 +1393,7 @@ testGroupModerate =
testGroupModerateFullDelete :: HasCallStack => FilePath -> IO ()
testGroupModerateFullDelete =
testChat3 aliceProfile bobProfile cathProfile $
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
alice ##> "/mr team cath member"
@ -1390,10 +1431,10 @@ testGroupModerateFullDelete =
testGroupDelayedModeration :: HasCallStack => FilePath -> IO ()
testGroupDelayedModeration tmp = do
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChatCfg tmp cfg "alice" aliceProfile $ \alice -> do
withNewTestChatCfg tmp cfg "bob" bobProfile $ \bob -> do
createGroup2 "team" alice bob
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withNewTestChatCfg tmp cfg "cath" cathProfile $ \cath -> do
connectUsers alice cath
addMember "team" alice cath GRMember
cath ##> "/j team"
@ -1407,11 +1448,11 @@ testGroupDelayedModeration tmp = do
alice ##> "\\\\ #team @cath hi"
alice <## "message marked deleted by you"
cath <# "#team cath> [marked deleted by alice] hi"
withTestChat tmp "bob" $ \bob -> do
withTestChatCfg tmp cfg "bob" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
withTestChat tmp "cath" $ \cath -> do
withTestChatCfg tmp cfg "cath" $ \cath -> do
cath <## "2 contacts connected (use /cs for the list)"
cath <## "#team: connected to server(s)"
cath <## "#team: member bob (Bob) is connected"
@ -1424,13 +1465,15 @@ testGroupDelayedModeration tmp = do
bob ##> "/_get chat #1 count=2"
r <- chat <$> getTermLine bob
r `shouldMatchList` [(0, "connected"), (0, "hi [marked deleted by alice]")]
where
cfg = testCfgCreateGroupDirect
testGroupDelayedModerationFullDelete :: HasCallStack => FilePath -> IO ()
testGroupDelayedModerationFullDelete tmp = do
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChatCfg tmp cfg "alice" aliceProfile $ \alice -> do
withNewTestChatCfg tmp cfg "bob" bobProfile $ \bob -> do
createGroup2 "team" alice bob
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withNewTestChatCfg tmp cfg "cath" cathProfile $ \cath -> do
connectUsers alice cath
addMember "team" alice cath GRMember
cath ##> "/j team"
@ -1452,14 +1495,14 @@ testGroupDelayedModerationFullDelete tmp = do
cath <## "alice updated group #team:"
cath <## "updated group preferences:"
cath <## "Full deletion: on"
withTestChat tmp "bob" $ \bob -> do
withTestChatCfg tmp cfg "bob" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "alice updated group #team:"
bob <## "updated group preferences:"
bob <## "Full deletion: on"
withTestChat tmp "cath" $ \cath -> do
withTestChatCfg tmp cfg "cath" $ \cath -> do
cath <## "2 contacts connected (use /cs for the list)"
cath <## "#team: connected to server(s)"
cath <## "#team: member bob (Bob) is connected"
@ -1472,6 +1515,8 @@ testGroupDelayedModerationFullDelete tmp = do
bob ##> "/_get chat #1 count=3"
r <- chat <$> getTermLine bob
r `shouldMatchList` [(0, "Full deletion: on"), (0, "connected"), (0, "moderated [deleted by alice]")]
where
cfg = testCfgCreateGroupDirect
testGroupAsync :: HasCallStack => FilePath -> IO ()
testGroupAsync tmp = do
@ -2127,7 +2172,7 @@ testGroupLinkMemberRole =
testGroupLinkLeaveDelete :: HasCallStack => FilePath -> IO ()
testGroupLinkLeaveDelete =
testChat3 aliceProfile bobProfile cathProfile $
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> do
connectUsers alice bob
connectUsers cath bob
@ -2562,7 +2607,7 @@ testConfigureGroupDeliveryReceipts tmp =
receipt bob alice cath "team" "25"
noReceipt bob alice cath "club" "26"
where
cfg = testCfg {showReceipts = True}
cfg = mkCfgCreateGroupDirect $ testCfg {showReceipts = True}
receipt cc1 cc2 cc3 gName msg = do
name1 <- userName cc1
cc1 #> ("#" <> gName <> " " <> msg)
@ -2582,3 +2627,62 @@ testConfigureGroupDeliveryReceipts tmp =
cc2 <# ("#" <> gName <> " " <> name1 <> "> " <> msg)
cc3 <# ("#" <> gName <> " " <> name1 <> "> " <> msg)
cc1 <// 50000
testNoGroupDirectConns :: HasCallStack => VersionRange -> VersionRange -> VersionRange -> Bool -> FilePath -> IO ()
testNoGroupDirectConns hostVRange mem2VRange mem3VRange noDirectConns tmp =
withNewTestChatCfg tmp testCfg {chatVRange = hostVRange} "alice" aliceProfile $ \alice -> do
withNewTestChatCfg tmp testCfg {chatVRange = mem2VRange} "bob" bobProfile $ \bob -> do
withNewTestChatCfg tmp testCfg {chatVRange = mem3VRange} "cath" cathProfile $ \cath -> do
createGroup3 "team" alice bob cath
if noDirectConns
then contactsDontExist bob cath
else bob <##> cath
where
contactsDontExist bob cath = do
bob ##> "@cath hi"
bob <## "no contact cath"
cath ##> "@bob hi"
cath <## "no contact bob"
testNoGroupDirectConns4Members :: HasCallStack => VersionRange -> VersionRange -> VersionRange -> VersionRange -> Bool -> Bool -> Bool -> FilePath -> IO ()
testNoGroupDirectConns4Members hostVRange mem2VRange mem3VRange mem4VRange noConns23 noConns24 noConns34 tmp =
withNewTestChatCfg tmp testCfg {chatVRange = hostVRange} "alice" aliceProfile $ \alice -> do
withNewTestChatCfg tmp testCfg {chatVRange = mem2VRange} "bob" bobProfile $ \bob -> do
withNewTestChatCfg tmp testCfg {chatVRange = mem3VRange} "cath" cathProfile $ \cath -> do
withNewTestChatCfg tmp testCfg {chatVRange = mem4VRange} "dan" danProfile $ \dan -> do
createGroup3 "team" alice bob cath
connectUsers alice dan
addMember "team" alice dan GRMember
dan ##> "/j team"
concurrentlyN_
[ alice <## "#team: dan joined the group",
do
dan <## "#team: you joined the group"
dan
<### [ "#team: member bob (Bob) is connected",
"#team: member cath (Catherine) is connected"
],
aliceAddedDan bob,
aliceAddedDan cath
]
if noConns23
then contactsDontExist bob cath
else bob <##> cath
if noConns24
then contactsDontExist bob dan
else bob <##> dan
if noConns34
then contactsDontExist cath dan
else cath <##> dan
where
aliceAddedDan :: HasCallStack => TestCC -> IO ()
aliceAddedDan cc = do
cc <## "#team: alice added dan (Daniel) to the group (connecting...)"
cc <## "#team: new member dan is connected"
contactsDontExist cc1 cc2 = do
name1 <- userName cc1
name2 <- userName cc2
cc1 ##> ("@" <> name2 <> " hi")
cc1 <## ("no contact " <> name2)
cc2 ##> ("@" <> name1 <> " hi")
cc2 <## ("no contact " <> name1)

View File

@ -18,7 +18,7 @@ chatProfileTests = do
it "update user profile and notify contacts" testUpdateProfile
it "update user profile with image" testUpdateProfileImage
describe "user contact link" $ do
describe "create and connect via contact link" testUserContactLink
it "create and connect via contact link" testUserContactLink
it "add contact link to profile" testProfileLink
it "auto accept contact requests" testUserContactLinkAutoAccept
it "deduplicate contact requests" testDeduplicateContactRequests
@ -57,7 +57,7 @@ chatProfileTests = do
testUpdateProfile :: HasCallStack => FilePath -> IO ()
testUpdateProfile =
testChat3 aliceProfile bobProfile cathProfile $
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
alice ##> "/p"
@ -117,33 +117,35 @@ testUpdateProfileImage =
bob <## "use @alice2 <message> to send messages"
(bob </)
testUserContactLink :: SpecWith FilePath
testUserContactLink = versionTestMatrix3 $ \alice bob cath -> do
alice ##> "/ad"
cLink <- getContactLink alice True
bob ##> ("/c " <> cLink)
alice <#? bob
alice @@@ [("<@bob", "")]
alice ##> "/ac bob"
alice <## "bob (Bob): accepting contact request..."
concurrently_
(bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected")
threadDelay 100000
alice @@@ [("@bob", lastChatFeature)]
alice <##> bob
testUserContactLink :: HasCallStack => FilePath -> IO ()
testUserContactLink =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
alice ##> "/ad"
cLink <- getContactLink alice True
bob ##> ("/c " <> cLink)
alice <#? bob
alice @@@ [("<@bob", "")]
alice ##> "/ac bob"
alice <## "bob (Bob): accepting contact request..."
concurrently_
(bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected")
threadDelay 100000
alice @@@ [("@bob", lastChatFeature)]
alice <##> bob
cath ##> ("/c " <> cLink)
alice <#? cath
alice @@@ [("<@cath", ""), ("@bob", "hey")]
alice ##> "/ac cath"
alice <## "cath (Catherine): accepting contact request..."
concurrently_
(cath <## "alice (Alice): contact is connected")
(alice <## "cath (Catherine): contact is connected")
threadDelay 100000
alice @@@ [("@cath", lastChatFeature), ("@bob", "hey")]
alice <##> cath
cath ##> ("/c " <> cLink)
alice <#? cath
alice @@@ [("<@cath", ""), ("@bob", "hey")]
alice ##> "/ac cath"
alice <## "cath (Catherine): accepting contact request..."
concurrently_
(cath <## "alice (Alice): contact is connected")
(alice <## "cath (Catherine): contact is connected")
threadDelay 100000
alice @@@ [("@cath", lastChatFeature), ("@bob", "hey")]
alice <##> cath
testProfileLink :: HasCallStack => FilePath -> IO ()
testProfileLink =
@ -762,192 +764,193 @@ testSetResetSetConnectionIncognito = testChat2 aliceProfile bobProfile $
bob `hasContactProfiles` ["bob", T.pack aliceIncognito]
testJoinGroupIncognito :: HasCallStack => FilePath -> IO ()
testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
-- non incognito connections
connectUsers alice bob
connectUsers alice dan
connectUsers bob cath
connectUsers bob dan
connectUsers cath dan
-- cath connected incognito to alice
alice ##> "/c"
inv <- getInvitation alice
cath ##> ("/c i " <> inv)
cath <## "confirmation sent!"
cathIncognito <- getTermLine cath
concurrentlyN_
[ do
cath <## ("alice (Alice): contact is connected, your incognito profile for this contact is " <> cathIncognito)
cath <## "use /i alice to print out this incognito profile again",
alice <## (cathIncognito <> ": contact is connected")
]
-- alice creates group
alice ##> "/g secret_club"
alice <## "group #secret_club is created"
alice <## "to add members use /a secret_club <name> or /create link #secret_club"
-- alice invites bob
alice ##> "/a secret_club bob admin"
concurrentlyN_
[ alice <## "invitation to join the group #secret_club sent to bob",
do
bob <## "#secret_club: alice invites you to join the group as admin"
bob <## "use /j secret_club to accept"
]
bob ##> "/j secret_club"
concurrently_
(alice <## "#secret_club: bob joined the group")
(bob <## "#secret_club: you joined the group")
-- alice invites cath
alice ##> ("/a secret_club " <> cathIncognito <> " admin")
concurrentlyN_
[ alice <## ("invitation to join the group #secret_club sent to " <> cathIncognito),
do
cath <## "#secret_club: alice invites you to join the group as admin"
cath <## ("use /j secret_club to join incognito as " <> cathIncognito)
]
-- cath uses the same incognito profile when joining group, cath and bob don't merge contacts
cath ##> "/j secret_club"
concurrentlyN_
[ alice <## ("#secret_club: " <> cathIncognito <> " joined the group"),
do
cath <## ("#secret_club: you joined the group incognito as " <> cathIncognito)
cath <## "#secret_club: member bob_1 (Bob) is connected",
do
bob <## ("#secret_club: alice added " <> cathIncognito <> " to the group (connecting...)")
bob <## ("#secret_club: new member " <> cathIncognito <> " is connected")
]
-- cath cannot invite to the group because her membership is incognito
cath ##> "/a secret_club dan"
cath <## "you've connected to this group using an incognito profile - prohibited to invite contacts"
-- alice invites dan
alice ##> "/a secret_club dan admin"
concurrentlyN_
[ alice <## "invitation to join the group #secret_club sent to dan",
do
dan <## "#secret_club: alice invites you to join the group as admin"
dan <## "use /j secret_club to accept"
]
dan ##> "/j secret_club"
-- cath and dan don't merge contacts
concurrentlyN_
[ alice <## "#secret_club: dan joined the group",
do
dan <## "#secret_club: you joined the group"
dan
<### [ ConsoleString $ "#secret_club: member " <> cathIncognito <> " is connected",
"#secret_club: member bob_1 (Bob) is connected",
"contact bob_1 is merged into bob",
"use @bob <message> to send messages"
],
do
bob <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
bob <## "#secret_club: new member dan_1 is connected"
bob <## "contact dan_1 is merged into dan"
bob <## "use @dan <message> to send messages",
do
cath <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
cath <## "#secret_club: new member dan_1 is connected"
]
-- send messages - group is incognito for cath
alice #> "#secret_club hello"
concurrentlyN_
[ bob <# "#secret_club alice> hello",
cath ?<# "#secret_club alice> hello",
dan <# "#secret_club alice> hello"
]
bob #> "#secret_club hi there"
concurrentlyN_
[ alice <# "#secret_club bob> hi there",
cath ?<# "#secret_club bob_1> hi there",
dan <# "#secret_club bob> hi there"
]
cath ?#> "#secret_club hey"
concurrentlyN_
[ alice <# ("#secret_club " <> cathIncognito <> "> hey"),
bob <# ("#secret_club " <> cathIncognito <> "> hey"),
dan <# ("#secret_club " <> cathIncognito <> "> hey")
]
dan #> "#secret_club how is it going?"
concurrentlyN_
[ alice <# "#secret_club dan> how is it going?",
bob <# "#secret_club dan> how is it going?",
cath ?<# "#secret_club dan_1> how is it going?"
]
-- cath and bob can send messages via new direct connection, cath is incognito
bob #> ("@" <> cathIncognito <> " hi, I'm bob")
cath ?<# "bob_1> hi, I'm bob"
cath ?#> "@bob_1 hey, I'm incognito"
bob <# (cathIncognito <> "> hey, I'm incognito")
-- cath and dan can send messages via new direct connection, cath is incognito
dan #> ("@" <> cathIncognito <> " hi, I'm dan")
cath ?<# "dan_1> hi, I'm dan"
cath ?#> "@dan_1 hey, I'm incognito"
dan <# (cathIncognito <> "> hey, I'm incognito")
-- non incognito connections are separate
bob <##> cath
dan <##> cath
-- list groups
cath ##> "/gs"
cath <## "i #secret_club (4 members)"
-- list group members
alice ##> "/ms secret_club"
alice
<### [ "alice (Alice): owner, you, created group",
"bob (Bob): admin, invited, connected",
ConsoleString $ cathIncognito <> ": admin, invited, connected",
"dan (Daniel): admin, invited, connected"
]
bob ##> "/ms secret_club"
bob
<### [ "alice (Alice): owner, host, connected",
"bob (Bob): admin, you, connected",
ConsoleString $ cathIncognito <> ": admin, connected",
"dan (Daniel): admin, connected"
]
cath ##> "/ms secret_club"
cath
<### [ "alice (Alice): owner, host, connected",
"bob_1 (Bob): admin, connected",
ConsoleString $ "i " <> cathIncognito <> ": admin, you, connected",
"dan_1 (Daniel): admin, connected"
]
dan ##> "/ms secret_club"
dan
<### [ "alice (Alice): owner, host, connected",
"bob (Bob): admin, connected",
ConsoleString $ cathIncognito <> ": admin, connected",
"dan (Daniel): admin, you, connected"
]
-- remove member
bob ##> ("/rm secret_club " <> cathIncognito)
concurrentlyN_
[ bob <## ("#secret_club: you removed " <> cathIncognito <> " from the group"),
alice <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"),
dan <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"),
do
cath <## "#secret_club: bob_1 removed you from the group"
cath <## "use /d #secret_club to delete the group"
]
bob #> "#secret_club hi"
concurrentlyN_
[ alice <# "#secret_club bob> hi",
dan <# "#secret_club bob> hi",
(cath </)
]
alice #> "#secret_club hello"
concurrentlyN_
[ bob <# "#secret_club alice> hello",
dan <# "#secret_club alice> hello",
(cath </)
]
cath ##> "#secret_club hello"
cath <## "you are no longer a member of the group"
-- cath can still message members directly
bob #> ("@" <> cathIncognito <> " I removed you from group")
cath ?<# "bob_1> I removed you from group"
cath ?#> "@bob_1 ok"
bob <# (cathIncognito <> "> ok")
testJoinGroupIncognito =
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
-- non incognito connections
connectUsers alice bob
connectUsers alice dan
connectUsers bob cath
connectUsers bob dan
connectUsers cath dan
-- cath connected incognito to alice
alice ##> "/c"
inv <- getInvitation alice
cath ##> ("/c i " <> inv)
cath <## "confirmation sent!"
cathIncognito <- getTermLine cath
concurrentlyN_
[ do
cath <## ("alice (Alice): contact is connected, your incognito profile for this contact is " <> cathIncognito)
cath <## "use /i alice to print out this incognito profile again",
alice <## (cathIncognito <> ": contact is connected")
]
-- alice creates group
alice ##> "/g secret_club"
alice <## "group #secret_club is created"
alice <## "to add members use /a secret_club <name> or /create link #secret_club"
-- alice invites bob
alice ##> "/a secret_club bob admin"
concurrentlyN_
[ alice <## "invitation to join the group #secret_club sent to bob",
do
bob <## "#secret_club: alice invites you to join the group as admin"
bob <## "use /j secret_club to accept"
]
bob ##> "/j secret_club"
concurrently_
(alice <## "#secret_club: bob joined the group")
(bob <## "#secret_club: you joined the group")
-- alice invites cath
alice ##> ("/a secret_club " <> cathIncognito <> " admin")
concurrentlyN_
[ alice <## ("invitation to join the group #secret_club sent to " <> cathIncognito),
do
cath <## "#secret_club: alice invites you to join the group as admin"
cath <## ("use /j secret_club to join incognito as " <> cathIncognito)
]
-- cath uses the same incognito profile when joining group, cath and bob don't merge contacts
cath ##> "/j secret_club"
concurrentlyN_
[ alice <## ("#secret_club: " <> cathIncognito <> " joined the group"),
do
cath <## ("#secret_club: you joined the group incognito as " <> cathIncognito)
cath <## "#secret_club: member bob_1 (Bob) is connected",
do
bob <## ("#secret_club: alice added " <> cathIncognito <> " to the group (connecting...)")
bob <## ("#secret_club: new member " <> cathIncognito <> " is connected")
]
-- cath cannot invite to the group because her membership is incognito
cath ##> "/a secret_club dan"
cath <## "you've connected to this group using an incognito profile - prohibited to invite contacts"
-- alice invites dan
alice ##> "/a secret_club dan admin"
concurrentlyN_
[ alice <## "invitation to join the group #secret_club sent to dan",
do
dan <## "#secret_club: alice invites you to join the group as admin"
dan <## "use /j secret_club to accept"
]
dan ##> "/j secret_club"
-- cath and dan don't merge contacts
concurrentlyN_
[ alice <## "#secret_club: dan joined the group",
do
dan <## "#secret_club: you joined the group"
dan
<### [ ConsoleString $ "#secret_club: member " <> cathIncognito <> " is connected",
"#secret_club: member bob_1 (Bob) is connected",
"contact bob_1 is merged into bob",
"use @bob <message> to send messages"
],
do
bob <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
bob <## "#secret_club: new member dan_1 is connected"
bob <## "contact dan_1 is merged into dan"
bob <## "use @dan <message> to send messages",
do
cath <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
cath <## "#secret_club: new member dan_1 is connected"
]
-- send messages - group is incognito for cath
alice #> "#secret_club hello"
concurrentlyN_
[ bob <# "#secret_club alice> hello",
cath ?<# "#secret_club alice> hello",
dan <# "#secret_club alice> hello"
]
bob #> "#secret_club hi there"
concurrentlyN_
[ alice <# "#secret_club bob> hi there",
cath ?<# "#secret_club bob_1> hi there",
dan <# "#secret_club bob> hi there"
]
cath ?#> "#secret_club hey"
concurrentlyN_
[ alice <# ("#secret_club " <> cathIncognito <> "> hey"),
bob <# ("#secret_club " <> cathIncognito <> "> hey"),
dan <# ("#secret_club " <> cathIncognito <> "> hey")
]
dan #> "#secret_club how is it going?"
concurrentlyN_
[ alice <# "#secret_club dan> how is it going?",
bob <# "#secret_club dan> how is it going?",
cath ?<# "#secret_club dan_1> how is it going?"
]
-- cath and bob can send messages via new direct connection, cath is incognito
bob #> ("@" <> cathIncognito <> " hi, I'm bob")
cath ?<# "bob_1> hi, I'm bob"
cath ?#> "@bob_1 hey, I'm incognito"
bob <# (cathIncognito <> "> hey, I'm incognito")
-- cath and dan can send messages via new direct connection, cath is incognito
dan #> ("@" <> cathIncognito <> " hi, I'm dan")
cath ?<# "dan_1> hi, I'm dan"
cath ?#> "@dan_1 hey, I'm incognito"
dan <# (cathIncognito <> "> hey, I'm incognito")
-- non incognito connections are separate
bob <##> cath
dan <##> cath
-- list groups
cath ##> "/gs"
cath <## "i #secret_club (4 members)"
-- list group members
alice ##> "/ms secret_club"
alice
<### [ "alice (Alice): owner, you, created group",
"bob (Bob): admin, invited, connected",
ConsoleString $ cathIncognito <> ": admin, invited, connected",
"dan (Daniel): admin, invited, connected"
]
bob ##> "/ms secret_club"
bob
<### [ "alice (Alice): owner, host, connected",
"bob (Bob): admin, you, connected",
ConsoleString $ cathIncognito <> ": admin, connected",
"dan (Daniel): admin, connected"
]
cath ##> "/ms secret_club"
cath
<### [ "alice (Alice): owner, host, connected",
"bob_1 (Bob): admin, connected",
ConsoleString $ "i " <> cathIncognito <> ": admin, you, connected",
"dan_1 (Daniel): admin, connected"
]
dan ##> "/ms secret_club"
dan
<### [ "alice (Alice): owner, host, connected",
"bob (Bob): admin, connected",
ConsoleString $ cathIncognito <> ": admin, connected",
"dan (Daniel): admin, you, connected"
]
-- remove member
bob ##> ("/rm secret_club " <> cathIncognito)
concurrentlyN_
[ bob <## ("#secret_club: you removed " <> cathIncognito <> " from the group"),
alice <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"),
dan <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"),
do
cath <## "#secret_club: bob_1 removed you from the group"
cath <## "use /d #secret_club to delete the group"
]
bob #> "#secret_club hi"
concurrentlyN_
[ alice <# "#secret_club bob> hi",
dan <# "#secret_club bob> hi",
(cath </)
]
alice #> "#secret_club hello"
concurrentlyN_
[ bob <# "#secret_club alice> hello",
dan <# "#secret_club alice> hello",
(cath </)
]
cath ##> "#secret_club hello"
cath <## "you are no longer a member of the group"
-- cath can still message members directly
bob #> ("@" <> cathIncognito <> " I removed you from group")
cath ?<# "bob_1> I removed you from group"
cath ?#> "@bob_1 ok"
bob <# (cathIncognito <> "> ok")
testCantInviteContactIncognito :: HasCallStack => FilePath -> IO ()
testCantInviteContactIncognito = testChat2 aliceProfile bobProfile $
@ -1356,54 +1359,55 @@ testAllowFullDeletionGroup =
testProhibitDirectMessages :: HasCallStack => FilePath -> IO ()
testProhibitDirectMessages =
testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do
createGroup3 "team" alice bob cath
threadDelay 1000000
alice ##> "/set direct #team off"
alice <## "updated group preferences:"
alice <## "Direct messages: off"
directProhibited bob
directProhibited cath
threadDelay 1000000
-- still can send direct messages to direct contacts
alice #> "@bob hello again"
bob <# "alice> hello again"
alice #> "@cath hello again"
cath <# "alice> hello again"
bob ##> "@cath hello again"
bob <## "direct messages to indirect contact cath are prohibited"
(cath </)
connectUsers cath dan
addMember "team" cath dan GRMember
dan ##> "/j #team"
concurrentlyN_
[ cath <## "#team: dan joined the group",
do
dan <## "#team: you joined the group"
dan
<### [ "#team: member alice (Alice) is connected",
"#team: member bob (Bob) is connected"
],
do
alice <## "#team: cath added dan (Daniel) to the group (connecting...)"
alice <## "#team: new member dan is connected",
do
bob <## "#team: cath added dan (Daniel) to the group (connecting...)"
bob <## "#team: new member dan is connected"
]
alice ##> "@dan hi"
alice <## "direct messages to indirect contact dan are prohibited"
bob ##> "@dan hi"
bob <## "direct messages to indirect contact dan are prohibited"
(dan </)
dan ##> "@alice hi"
dan <## "direct messages to indirect contact alice are prohibited"
dan ##> "@bob hi"
dan <## "direct messages to indirect contact bob are prohibited"
dan #> "@cath hi"
cath <# "dan> hi"
cath #> "@dan hi"
dan <# "cath> hi"
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
createGroup3 "team" alice bob cath
threadDelay 1000000
alice ##> "/set direct #team off"
alice <## "updated group preferences:"
alice <## "Direct messages: off"
directProhibited bob
directProhibited cath
threadDelay 1000000
-- still can send direct messages to direct contacts
alice #> "@bob hello again"
bob <# "alice> hello again"
alice #> "@cath hello again"
cath <# "alice> hello again"
bob ##> "@cath hello again"
bob <## "direct messages to indirect contact cath are prohibited"
(cath </)
connectUsers cath dan
addMember "team" cath dan GRMember
dan ##> "/j #team"
concurrentlyN_
[ cath <## "#team: dan joined the group",
do
dan <## "#team: you joined the group"
dan
<### [ "#team: member alice (Alice) is connected",
"#team: member bob (Bob) is connected"
],
do
alice <## "#team: cath added dan (Daniel) to the group (connecting...)"
alice <## "#team: new member dan is connected",
do
bob <## "#team: cath added dan (Daniel) to the group (connecting...)"
bob <## "#team: new member dan is connected"
]
alice ##> "@dan hi"
alice <## "direct messages to indirect contact dan are prohibited"
bob ##> "@dan hi"
bob <## "direct messages to indirect contact dan are prohibited"
(dan </)
dan ##> "@alice hi"
dan <## "direct messages to indirect contact alice are prohibited"
dan ##> "@bob hi"
dan <## "direct messages to indirect contact bob are prohibited"
dan #> "@cath hi"
cath <# "dan> hi"
cath #> "@dan hi"
dan <# "cath> hi"
where
directProhibited :: HasCallStack => TestCC -> IO ()
directProhibited cc = do

View File

@ -67,9 +67,9 @@ versionTestMatrix2 runTest = do
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
versionTestMatrix3 runTest = do
it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
-- versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
-- versionTestMatrix3 runTest = do
-- it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest

View File

@ -230,16 +230,28 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
#==# XGrpAcpt (MemberId "\1\2\3\4")
it "x.grp.mem.new" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, profile = testProfile}
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile}
it "x.grp.mem.new with member chat version range" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-2\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile}
it "x.grp.mem.intro" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, profile = testProfile}
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile}
it "x.grp.mem.intro with member chat version range" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-2\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile}
it "x.grp.mem.inv" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"directConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}"
#==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = testConnReq}
#==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq}
it "x.grp.mem.inv w/t directConnReq" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"groupConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}"
#==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing}
it "x.grp.mem.fwd" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"directConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = testConnReq}
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq}
it "x.grp.mem.fwd with member chat version range and w/t directConnReq" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-2\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing}
it "x.grp.mem.info" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.info\",\"params\":{\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
#==# XGrpMemInfo (MemberId "\1\2\3\4") testProfile