From 43e233f0eb9100d9610e05ac50e855c47c8dc86c Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Tue, 5 Sep 2023 20:15:50 +0400
Subject: [PATCH] core: don't create direct connections in group (#2996)
---
docs/protocol/diagrams/group.mmd | 31 +-
docs/protocol/diagrams/group.svg | 2 +-
src/Simplex/Chat.hs | 101 +++---
src/Simplex/Chat/Protocol.hs | 16 +-
src/Simplex/Chat/Store/Direct.hs | 8 +-
src/Simplex/Chat/Store/Groups.hs | 200 ++++++------
src/Simplex/Chat/Store/Shared.hs | 2 +
src/Simplex/Chat/Types.hs | 40 ++-
tests/Bots/DirectoryTests.hs | 112 +++----
tests/ChatClient.hs | 18 +-
tests/ChatTests/Files.hs | 11 +-
tests/ChatTests/Groups.hs | 152 +++++++--
tests/ChatTests/Profiles.hs | 528 ++++++++++++++++---------------
tests/ChatTests/Utils.hs | 6 +-
tests/ProtocolTests.hs | 20 +-
15 files changed, 723 insertions(+), 524 deletions(-)
diff --git a/docs/protocol/diagrams/group.mmd b/docs/protocol/diagrams/group.mmd
index c331b4610..18d392caa 100644
--- a/docs/protocol/diagrams/group.mmd
+++ b/docs/protocol/diagrams/group.mmd
@@ -3,24 +3,31 @@ sequenceDiagram
participant A as Alice
participant B as Bob
participant C as Existing
contact
-
+
note over A, B: 1. send and accept group invitation
A ->> B: x.grp.inv
invite Bob to group
(via contact connection)
- B ->> A: x.grp.acpt
accept invitation
(via member connection)
- B ->> A: establish group member connection
+ B ->> A: x.grp.acpt
accept invitation
(via member connection)
establish group member connection
note over M, B: 2. introduce new member Bob to all existing members
A ->> M: x.grp.mem.new
"announce" Bob
to existing members
(via member connections)
- A ->> B: x.grp.mem.intro * N
"introduce" members
(via member connection)
- B ->> A: x.grp.mem.inv * N
"invitations" to connect
for all members
(via member connection)
- A ->> M: x.grp.mem.fwd
forward "invitations"
to all members
(via member connections)
+ loop batched
+ A ->> B: x.grp.mem.intro * N
"introduce" members and
their chat protocol versions
(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
"invitations" to connect
for all members
(via member connection)
+ end
+ A ->> M: x.grp.mem.fwd
forward "invitations" and
Bob's chat protocol version
to all members
(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
"probe" is sent to all new members
- B ->> C: x.info.probe.check
"probe" hash,
in case contact and
member profiles match
- C ->> B: x.info.probe.ok
original "probe",
in case contact and member
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
"probe" is sent to all new members
+ B ->> C: x.info.probe.check
"probe" hash,
in case contact and
member profiles match
+ C ->> B: x.info.probe.ok
original "probe",
in case contact and member
are the same user
+ note over B: merge existing and new contacts if received and sent probe hashes match
+ end
diff --git a/docs/protocol/diagrams/group.svg b/docs/protocol/diagrams/group.svg
index d66b560b2..8c1b65dee 100644
--- a/docs/protocol/diagrams/group.svg
+++ b/docs/protocol/diagrams/group.svg
@@ -1 +1 @@
-
\ No newline at end of file
+
\ No newline at end of file
diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs
index 1c353f7e8..1165a2947 100644
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -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)
diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs
index 5c33eb06c..2f93ab13d 100644
--- a/src/Simplex/Chat/Protocol.hs
+++ b/src/Simplex/Chat/Protocol.hs
@@ -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,
diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs
index 00d3d55c9..3b56e57b7 100644
--- a/src/Simplex/Chat/Store/Direct.hs
+++ b/src/Simplex/Chat/Store/Direct.hs
@@ -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
diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs
index 6c2f32f76..40c21d616 100644
--- a/src/Simplex/Chat/Store/Groups.hs
+++ b/src/Simplex/Chat/Store/Groups.hs
@@ -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)
diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs
index 5bae79d80..48e2e5692 100644
--- a/src/Simplex/Chat/Store/Shared.hs
+++ b/src/Simplex/Chat/Store/Shared.hs
@@ -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
diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs
index ac19cbc36..4981b225b 100644
--- a/src/Simplex/Chat/Types.hs
+++ b/src/Simplex/Chat/Types.hs
@@ -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
diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs
index 21bdb6577..a0d69d195 100644
--- a/tests/Bots/DirectoryTests.hs
+++ b/tests/Bots/DirectoryTests.hs
@@ -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"
diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs
index e612f3d09..43760c99b 100644
--- a/tests/ChatClient.hs
+++ b/tests/ChatClient.hs
@@ -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
diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs
index 4343b547c..9c277e00e 100644
--- a/tests/ChatTests/Files.hs
+++ b/tests/ChatTests/Files.hs
@@ -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=\"}}"
diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs
index 7a4bb2061..e533a55da 100644
--- a/tests/ChatTests/Groups.hs
+++ b/tests/ChatTests/Groups.hs
@@ -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 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)
diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs
index c51202340..1a2b74f76 100644
--- a/tests/ChatTests/Profiles.hs
+++ b/tests/ChatTests/Profiles.hs
@@ -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 to send messages"
(bob 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 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 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 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 "#secret_club hello"
- concurrentlyN_
- [ bob <# "#secret_club alice> hello",
- dan <# "#secret_club alice> hello",
- (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 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 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 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 "#secret_club hello"
+ concurrentlyN_
+ [ bob <# "#secret_club alice> hello",
+ dan <# "#secret_club alice> hello",
+ (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 "/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 "@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 "/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 "@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
diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs
index b525bf333..72cb99c97 100644
--- a/tests/ChatTests/Utils.hs
+++ b/tests/ChatTests/Utils.hs
@@ -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
diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs
index 98c592fa7..3acc78e7d 100644
--- a/tests/ProtocolTests.hs
+++ b/tests/ProtocolTests.hs
@@ -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