IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
spaced4ndy
2023-09-05 20:15:50 +04:00
committed by GitHub
parent 7a5d4a5a3d
commit 43e233f0eb
15 changed files with 723 additions and 524 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
docs/protocol/diagrams/group.mmd
View File

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

2
docs/protocol/diagrams/group.svg
View File

File diff suppressed because one or more lines are too long
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 34 KiB

After

Width:  |  Height:  |  Size: 34 KiB

81
src/Simplex/Chat.hs
View File

@@ -94,6 +94,7 @@ import qualified Simplex.Messaging.Protocol as SMP
import qualified Simplex.Messaging.TMap as TM import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport.Client (defaultSocksProxy) import Simplex.Messaging.Transport.Client (defaultSocksProxy)
import Simplex.Messaging.Util import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Exit (exitFailure, exitSuccess) import System.Exit (exitFailure, exitSuccess)
import System.FilePath (combine, splitExtensions, takeFileName, (</>)) import System.FilePath (combine, splitExtensions, takeFileName, (</>))
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout)
@@ -104,7 +105,6 @@ import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay)
import UnliftIO.Directory import UnliftIO.Directory
import UnliftIO.IO (hClose, hSeek, hTell, openFile) import UnliftIO.IO (hClose, hSeek, hTell, openFile)
import UnliftIO.STM import UnliftIO.STM
import Simplex.Messaging.Version
defaultChatConfig :: ChatConfig defaultChatConfig :: ChatConfig
defaultChatConfig = defaultChatConfig =
@@ -1431,12 +1431,16 @@ processChatCommand = \case
Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName
| otherwise -> throwChatError $ CEGroupDuplicateMember cName | otherwise -> throwChatError $ CEGroupDuplicateMember cName
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do 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 withChatLock "joinGroup" . procCmd $ do
dm <- directMessage $ XGrpAcpt (memberId (membership :: GroupMember)) dm <- directMessage $ XGrpAcpt (memberId (membership :: GroupMember))
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm
withStore' $ \db -> do withStore' $ \db -> do
createMemberConnection db userId fromMember agentConnId createMemberConnection db userId fromMember agentConnId connChatVRange
updateGroupMemberStatus db userId fromMember GSMemAccepted updateGroupMemberStatus db userId fromMember GSMemAccepted
updateGroupMemberStatus db userId membership GSMemAccepted updateGroupMemberStatus db userId membership GSMemAccepted
updateCIGroupInvitationStatus user updateCIGroupInvitationStatus user
@@ -2825,7 +2829,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> Nothing _ -> Nothing
processDirectMessage :: ACommand 'Agent e -> ConnectionEntity -> Connection -> Maybe Contact -> m () 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 Nothing -> case agentMsg of
CONF confId _ connInfo -> do CONF confId _ connInfo -> do
-- [incognito] send saved profile -- [incognito] send saved profile
@@ -2866,7 +2870,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
setConnConnReqInv db user connId cReq setConnConnReqInv db user connId cReq
getXGrpMemIntroContDirect db user ct getXGrpMemIntroContDirect db user ct
forM_ contData $ \(hostConnId, xGrpMemIntroCont) -> forM_ contData $ \(hostConnId, xGrpMemIntroCont) ->
sendXGrpMemInv hostConnId directConnReq xGrpMemIntroCont sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
MSG msgMeta _msgFlags msgBody -> do MSG msgMeta _msgFlags msgBody -> do
cmdId <- createAckCmd conn cmdId <- createAckCmd conn
@@ -2948,7 +2952,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
forM_ groupId_ $ \groupId -> do forM_ groupId_ $ \groupId -> do
gVar <- asks idsDrg gVar <- asks idsDrg
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation 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 () _ -> pure ()
Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) -> Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) ->
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
@@ -3015,18 +3019,28 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
case cReq of case cReq of
groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of
-- [async agent commands] XGrpMemIntro continuation on receiving INV -- [async agent commands] XGrpMemIntro continuation on receiving INV
CFCreateConnGrpMemInv -> do 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 contData <- withStore' $ \db -> do
setConnConnReqInv db user connId cReq setConnConnReqInv db user connId cReq
getXGrpMemIntroContGroup db user m getXGrpMemIntroContGroup db user m
forM_ contData $ \(hostConnId, directConnReq) -> do forM_ contData $ \(hostConnId, directConnReq) ->
let GroupMember {groupMemberId, memberId} = m sendXGrpMemInv hostConnId (Just directConnReq) XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
-- [async agent commands] group link auto-accept continuation on receiving INV -- [async agent commands] group link auto-accept continuation on receiving INV
CFCreateConnGrpInv -> CFCreateConnGrpInv -> do
withStore' (\db -> getContactViaMember db user m) >>= \case ct <- withStore $ \db -> getContactViaMember db user m
Nothing -> messageError "implementation error: invitee does not have contact"
Just ct -> do
withStore' $ \db -> setNewContactMemberConnRequest db user m cReq withStore' $ \db -> setNewContactMemberConnRequest db user m cReq
groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo
sendGrpInvitation ct m groupLinkId sendGrpInvitation ct m groupLinkId
@@ -3106,7 +3120,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
processIntro intro `catchChatError` (toView . CRChatError (Just user)) processIntro intro `catchChatError` (toView . CRChatError (Just user))
where where
processIntro intro@GroupMemberIntro {introId} = do 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 withStore' $ \db -> updateIntroStatus db introId GMIntroSent
_ -> do _ -> do
-- TODO send probe and decide whether to use existing contact connection or the new contact connection -- 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 :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
processGroupInvitation ct inv msg msgMeta = do 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 GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
@@ -4017,7 +4031,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
then do then do
connIds <- joinAgentConnectionAsync user True connRequest =<< directMessage (XGrpAcpt memberId) connIds <- joinAgentConnectionAsync user True connRequest =<< directMessage (XGrpAcpt memberId)
withStore' $ \db -> do withStore' $ \db -> do
createMemberConnectionAsync db user hostId connIds createMemberConnectionAsync db user hostId connIds connChatVRange
updateGroupMemberStatusById db userId hostId GSMemAccepted updateGroupMemberStatusById db userId hostId GSMemAccepted
updateGroupMemberStatus db userId membership GSMemAccepted updateGroupMemberStatus db userId membership GSMemAccepted
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct) toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
@@ -4230,7 +4244,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> pure conn' _ -> pure conn'
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> MsgMeta -> m () 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 checkHostRole m memRole
members <- withStore' $ \db -> getGroupMembers db user gInfo members <- withStore' $ \db -> getGroupMembers db user gInfo
unless (sameMemberId memId $ membership gInfo) $ unless (sameMemberId memId $ membership gInfo) $
@@ -4243,7 +4257,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m () 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 case memberCategory m of
GCHostMember -> do GCHostMember -> do
members <- withStore' $ \db -> getGroupMembers db user gInfo members <- withStore' $ \db -> getGroupMembers db user gInfo
@@ -4252,14 +4266,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
else do else do
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c) 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 -- [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 groupConnIds <- createConn
directConnIds <- createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation directConnIds <- case memberChatVRange of
-- [incognito] direct connection with member has to be established using the same incognito profile [that was known to host and used for group membership] 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 let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId
_ -> messageError "x.grp.mem.intro can be only sent by host member" _ -> 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 sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
hostConn <- withStore $ \db -> getConnectionById db user hostConnId hostConn <- withStore $ \db -> getConnectionById db user hostConnId
let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq} 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" _ -> messageError "x.grp.mem.inv can be only sent by invitee member"
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m () 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 checkHostRole m memRole
members <- withStore' $ \db -> getGroupMembers db user gInfo members <- withStore' $ \db -> getGroupMembers db user gInfo
toMember <- case find (sameMemberId memId) members of 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) dm <- directMessage $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership)
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability -- [async agent commands] no continuation needed, but commands should be asynchronous for stability
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm 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 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 :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> MsgMeta -> m ()
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg msgMeta 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} pure conn {connChatVRange = msgChatVRange}
| otherwise = pure conn | 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 :: (ChatMonad m, FilePartyI p) => Text -> m (ValidFileDescription p)
parseFileDescription = parseFileDescription =
liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8) liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8)

16
src/Simplex/Chat/Protocol.hs
View File

@@ -54,6 +54,10 @@ currentChatVersion = 2
supportedChatVRange :: VersionRange supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion supportedChatVRange = mkVersionRange 1 currentChatVersion
-- version that starts support for skipping establishing direct connections in a group
groupNoDirectVersion :: Version
groupNoDirectVersion = 2
data ConnectionEntity data ConnectionEntity
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact} = RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember} | RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
@@ -107,18 +111,6 @@ data AppMessage (e :: MsgEncoding) where
AMJson :: AppMessageJson -> AppMessage 'Json AMJson :: AppMessageJson -> AppMessage 'Json
AMBinary :: AppMessageBinary -> AppMessage 'Binary 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 -- chat message is sent as JSON with these properties
data AppMessageJson = AppMessageJson data AppMessageJson = AppMessageJson
{ v :: Maybe ChatVersionRange, { v :: Maybe ChatVersionRange,

106
src/Simplex/Chat/Store/Groups.hs
View File

@@ -83,6 +83,7 @@ module Simplex.Chat.Store.Groups
updateGroupSettings, updateGroupSettings,
getXGrpMemIntroContDirect, getXGrpMemIntroContDirect,
getXGrpMemIntroContGroup, getXGrpMemIntroContGroup,
getHostConnId,
) )
where where
@@ -98,7 +99,6 @@ import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages import Simplex.Chat.Messages
import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared import Simplex.Chat.Store.Shared
import Simplex.Chat.Protocol (chatInitialVRange)
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (ConnId, UserId) 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.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Util (eitherToMaybe) import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version
import UnliftIO.STM 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 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,7 +482,8 @@ getUserGroupsWithSummary db user _contactId_ search_ =
-- the statuses on non-current members should match memberCurrent' function -- the statuses on non-current members should match memberCurrent' function
getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary
getGroupSummary db User {userId} groupId = do getGroupSummary db User {userId} groupId = do
currentMembers_ <- maybeFirstRow fromOnly $ currentMembers_ <-
maybeFirstRow fromOnly $
DB.query DB.query
db db
[sql| [sql|
@@ -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) 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.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 createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime createdAt <- liftIO getCurrentTime
member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt 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 pure member
where where
createMember_ memberId createdAt = do 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) :. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt)
) )
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> ExceptT StoreError IO () 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) = createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) connChatVRange =
createWithRandomId gVar $ \memId -> do createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime createdAt <- liftIO getCurrentTime
insertMember_ (MemberId memId) createdAt insertMember_ (MemberId memId) createdAt
groupMemberId <- liftIO $ insertedRowId db 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 setCommandConnId db user cmdId connId
where where
insertMember_ memberId createdAt = insertMember_ memberId createdAt =
@@ -674,9 +676,10 @@ createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Co
:. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt) :. (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} = getContactViaMember db user@User {userId} GroupMember {groupMemberId} =
maybeFirstRow (toContact user) $ ExceptT $
firstRow (toContact user) (SEContactNotFoundByMemberId groupMemberId) $
DB.query DB.query
db db
[sql| [sql|
@@ -710,15 +713,15 @@ getMemberInvitation db User {userId} groupMemberId =
fmap join . maybeFirstRow fromOnly $ fmap join . maybeFirstRow fromOnly $
DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId) 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.Connection -> UserId -> GroupMember -> ConnId -> VersionRange -> IO ()
createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do createMemberConnection db userId GroupMember {groupMemberId} agentConnId connChatVRange = do
currentTs <- getCurrentTime 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.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> VersionRange -> IO ()
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) = do createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) connChatVRange = do
currentTs <- getCurrentTime 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 setCommandConnId db user cmdId connId
updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO () updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO ()
@@ -738,14 +741,9 @@ updateGroupMemberStatusById db userId groupMemberId memStatus = do
-- | add new member with profile -- | add new member with profile
createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember 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 = createNewGroupMember db user gInfo memInfo memCategory memStatus = do
ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do currentTs <- liftIO getCurrentTime
currentTs <- getCurrentTime (localDisplayName, memProfileId) <- createNewMemberProfile_ db user memInfo currentTs
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 = let newMember =
NewGroupMember NewGroupMember
{ memInfo, { memInfo,
@@ -756,7 +754,17 @@ createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile
memContactId = Nothing, memContactId = Nothing,
memProfileId memProfileId
} }
Right <$> createNewMember_ db user gInfo newMember currentTs 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, createdAt, createdAt)
profileId <- insertedRowId db
pure $ Right (ldn, profileId)
createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember
createNewMember_ createNewMember_
@@ -764,7 +772,7 @@ createNewMember_
User {userId, userContactId} User {userId, userContactId}
GroupInfo {groupId} GroupInfo {groupId}
NewGroupMember NewGroupMember
{ memInfo = MemberInfo memberId memberRole memberProfile, { memInfo = MemberInfo memberId memberRole _ memberProfile,
memCategory = memberCategory, memCategory = memberCategory,
memStatus = memberStatus, memStatus = memberStatus,
memInvitedBy = invitedBy, memInvitedBy = invitedBy,
@@ -908,40 +916,38 @@ getIntroduction_ db reMember toMember = ExceptT $ do
where where
toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
toIntro [(introId, groupConnReq, directConnReq, introStatus)] = toIntro [(introId, groupConnReq, directConnReq, introStatus)] =
let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq let introInvitation = IntroInvitation <$> groupConnReq <*> pure directConnReq
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation} in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
toIntro _ = Left SEIntroNotFound toIntro _ = Left SEIntroNotFound
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember 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 _ _ memberProfile) (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId = do
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn let mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId chatInitialVRange memberContactId Nothing customUserProfileId cLevel currentTs 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 liftIO $ setCommandConnId db user directCmdId directConnId
(localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing (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 liftIO $ do
let newMember =
NewGroupMember
{ memInfo,
memCategory = GCPreMember,
memStatus = GSMemIntroduced,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Just contactId,
memProfileId
}
member <- createNewMember_ db user gInfo newMember currentTs 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 liftIO $ setCommandConnId db user groupCmdId groupConnId
pure (member :: GroupMember) {activeConn = Just conn} pure (member :: GroupMember) {activeConn = Just conn}
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> IO () 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} (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do 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 let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
currentTs <- getCurrentTime 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 setCommandConnId db user groupCmdId groupConnId
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId chatInitialVRange viaContactId Nothing customUserProfileId cLevel 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 setCommandConnId db user directCmdId directConnId
contactId <- createMemberContact_ directConnId currentTs contactId <- createMemberContact_ directConnId currentTs
updateMember_ contactId currentTs updateMember_ contactId currentTs
@@ -971,8 +977,8 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId =
|] |]
[":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId] [":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId]
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> 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 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.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db User {userId, userContactId} Contact {contactId} = getViaGroupMember db User {userId, userContactId} Contact {contactId} =
@@ -1343,3 +1349,9 @@ getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do
toCont (hostConnId, connReq_) = case connReq_ of toCont (hostConnId, connReq_) = case connReq_ of
Just connReq -> Just (hostConnId, connReq) Just connReq -> Just (hostConnId, connReq)
_ -> Nothing _ -> 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)

2
src/Simplex/Chat/Store/Shared.hs
View File

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

32
src/Simplex/Chat/Types.hs
View File

@@ -347,7 +347,8 @@ data ChatSettings = ChatSettings
instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions
defaultChatSettings :: ChatSettings defaultChatSettings :: ChatSettings
defaultChatSettings = ChatSettings defaultChatSettings =
ChatSettings
{ enableNtfs = True, { enableNtfs = True,
sendRcpts = Nothing, sendRcpts = Nothing,
favorite = False favorite = False
@@ -538,24 +539,31 @@ instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOpt
data IntroInvitation = IntroInvitation data IntroInvitation = IntroInvitation
{ groupConnReq :: ConnReqInvitation, { groupConnReq :: ConnReqInvitation,
directConnReq :: ConnReqInvitation directConnReq :: Maybe ConnReqInvitation
} }
deriving (Eq, Show, Generic, FromJSON) 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 data MemberInfo = MemberInfo
{ memberId :: MemberId, { memberId :: MemberId,
memberRole :: GroupMemberRole, memberRole :: GroupMemberRole,
v :: Maybe ChatVersionRange,
profile :: Profile profile :: Profile
} }
deriving (Eq, Show, Generic, FromJSON) 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 -> MemberInfo
memberInfo GroupMember {memberId, memberRole, memberProfile} = memberInfo GroupMember {memberId, memberRole, memberProfile, activeConn} =
MemberInfo memberId memberRole (fromLocalProfile memberProfile) MemberInfo memberId memberRole memberChatVRange (fromLocalProfile memberProfile)
where
memberChatVRange = ChatVersionRange . connChatVRange <$> activeConn
data ReceivedGroupInvitation = ReceivedGroupInvitation data ReceivedGroupInvitation = ReceivedGroupInvitation
{ fromMember :: GroupMember, { fromMember :: GroupMember,
@@ -1467,3 +1475,15 @@ instance ProtocolTypeI p => ToJSON (ServerCfg p) where
instance ProtocolTypeI p => FromJSON (ServerCfg p) where instance ProtocolTypeI p => FromJSON (ServerCfg p) where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} 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

96
tests/Bots/DirectoryTests.hs
View File

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

16
tests/ChatClient.hs
View File

@@ -22,6 +22,7 @@ import Simplex.Chat
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..)) import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..))
import Simplex.Chat.Core import Simplex.Chat.Core
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Protocol (groupNoDirectVersion)
import Simplex.Chat.Store import Simplex.Chat.Store
import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Profiles
import Simplex.Chat.Terminal import Simplex.Chat.Terminal
@@ -133,6 +134,16 @@ testAgentCfgV1 =
testCfgV1 :: ChatConfig testCfgV1 :: ChatConfig
testCfgV1 = testCfg {agentConfig = testAgentCfgV1} 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 :: FilePath -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
createTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefix profile = do createTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefix profile = do
Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp </> dbPrefix) dbKey MCError Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp </> dbPrefix) dbKey MCError
@@ -288,7 +299,10 @@ testChatCfgOpts3 cfg opts p1 p2 p3 test = testChatN cfg opts [p1, p2, p3] test_
test_ _ = error "expected 3 chat clients" test_ _ = error "expected 3 chat clients"
testChat4 :: HasCallStack => Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> IO () 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 where
test_ :: HasCallStack => [TestCC] -> IO () test_ :: HasCallStack => [TestCC] -> IO ()
test_ [tc1, tc2, tc3, tc4] = test tc1 tc2 tc3 tc4 test_ [tc1, tc2, tc3, tc4] = test tc1 tc2 tc3 tc4

11
tests/ChatTests/Files.hs
View File

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

152
tests/ChatTests/Groups.hs
View File

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

16
tests/ChatTests/Profiles.hs
View File

@@ -18,7 +18,7 @@ chatProfileTests = do
it "update user profile and notify contacts" testUpdateProfile it "update user profile and notify contacts" testUpdateProfile
it "update user profile with image" testUpdateProfileImage it "update user profile with image" testUpdateProfileImage
describe "user contact link" $ do 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 "add contact link to profile" testProfileLink
it "auto accept contact requests" testUserContactLinkAutoAccept it "auto accept contact requests" testUserContactLinkAutoAccept
it "deduplicate contact requests" testDeduplicateContactRequests it "deduplicate contact requests" testDeduplicateContactRequests
@@ -57,7 +57,7 @@ chatProfileTests = do
testUpdateProfile :: HasCallStack => FilePath -> IO () testUpdateProfile :: HasCallStack => FilePath -> IO ()
testUpdateProfile = testUpdateProfile =
testChat3 aliceProfile bobProfile cathProfile $ testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> do \alice bob cath -> do
createGroup3 "team" alice bob cath createGroup3 "team" alice bob cath
alice ##> "/p" alice ##> "/p"
@@ -117,8 +117,10 @@ testUpdateProfileImage =
bob <## "use @alice2 <message> to send messages" bob <## "use @alice2 <message> to send messages"
(bob </) (bob </)
testUserContactLink :: SpecWith FilePath testUserContactLink :: HasCallStack => FilePath -> IO ()
testUserContactLink = versionTestMatrix3 $ \alice bob cath -> do testUserContactLink =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
alice ##> "/ad" alice ##> "/ad"
cLink <- getContactLink alice True cLink <- getContactLink alice True
bob ##> ("/c " <> cLink) bob ##> ("/c " <> cLink)
@@ -762,7 +764,8 @@ testSetResetSetConnectionIncognito = testChat2 aliceProfile bobProfile $
bob `hasContactProfiles` ["bob", T.pack aliceIncognito] bob `hasContactProfiles` ["bob", T.pack aliceIncognito]
testJoinGroupIncognito :: HasCallStack => FilePath -> IO () testJoinGroupIncognito :: HasCallStack => FilePath -> IO ()
testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfile $ testJoinGroupIncognito =
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do \alice bob cath dan -> do
-- non incognito connections -- non incognito connections
connectUsers alice bob connectUsers alice bob
@@ -1356,7 +1359,8 @@ testAllowFullDeletionGroup =
testProhibitDirectMessages :: HasCallStack => FilePath -> IO () testProhibitDirectMessages :: HasCallStack => FilePath -> IO ()
testProhibitDirectMessages = testProhibitDirectMessages =
testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
createGroup3 "team" alice bob cath createGroup3 "team" alice bob cath
threadDelay 1000000 threadDelay 1000000
alice ##> "/set direct #team off" alice ##> "/set direct #team off"

6
tests/ChatTests/Utils.hs
View File

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

20
tests/ProtocolTests.hs
View File

@@ -230,16 +230,28 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
#==# XGrpAcpt (MemberId "\1\2\3\4") #==# XGrpAcpt (MemberId "\1\2\3\4")
it "x.grp.mem.new" $ 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\"}}}}}}" "{\"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" $ 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\"}}}}}}" "{\"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" $ 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\"}}}" "{\"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" $ 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\"}}}}}}" "{\"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" $ 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\"}}}}}" "{\"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 #==# XGrpMemInfo (MemberId "\1\2\3\4") testProfile