core: don't create direct connections in group (#2996)
This commit is contained in:
parent
7a5d4a5a3d
commit
43e233f0eb
@ -3,24 +3,31 @@ sequenceDiagram
|
||||
participant A as Alice
|
||||
participant B as Bob
|
||||
participant C as Existing<br>contact
|
||||
|
||||
|
||||
note over A, B: 1. send and accept group invitation
|
||||
A ->> B: x.grp.inv<br>invite Bob to group<br>(via contact connection)
|
||||
B ->> A: x.grp.acpt<br>accept invitation<br>(via member connection)
|
||||
B ->> A: establish group member connection
|
||||
B ->> A: x.grp.acpt<br>accept invitation<br>(via member connection)<br>establish group member connection
|
||||
|
||||
note over M, B: 2. introduce new member Bob to all existing members
|
||||
A ->> M: x.grp.mem.new<br>"announce" Bob<br>to existing members<br>(via member connections)
|
||||
A ->> B: x.grp.mem.intro * N<br>"introduce" members<br>(via member connection)
|
||||
B ->> A: x.grp.mem.inv * N<br>"invitations" to connect<br>for all members<br>(via member connection)
|
||||
A ->> M: x.grp.mem.fwd<br>forward "invitations"<br>to all members<br>(via member connections)
|
||||
loop batched
|
||||
A ->> B: x.grp.mem.intro * N<br>"introduce" members and<br>their chat protocol versions<br>(via member connection)
|
||||
note over B: prepare group member connections
|
||||
opt chat protocol compatible version < 2
|
||||
note over B: prepare direct connections
|
||||
end
|
||||
B ->> A: x.grp.mem.inv * N<br>"invitations" to connect<br>for all members<br>(via member connection)
|
||||
end
|
||||
A ->> M: x.grp.mem.fwd<br>forward "invitations" and<br>Bob's chat protocol version<br>to all members<br>(via member connections)
|
||||
|
||||
note over M, B: 3. establish direct and group member connections
|
||||
M ->> B: establish group member connection
|
||||
M ->> B: establish direct connection
|
||||
|
||||
note over M, C: 4. deduplicate new contact
|
||||
B ->> M: x.info.probe<br>"probe" is sent to all new members
|
||||
B ->> C: x.info.probe.check<br>"probe" hash,<br>in case contact and<br>member profiles match
|
||||
C ->> B: x.info.probe.ok<br> original "probe",<br> in case contact and member<br>are the same user
|
||||
note over B: merge existing and new contacts if received and sent probe hashes match
|
||||
opt chat protocol compatible version < 2
|
||||
M ->> B: establish direct connection
|
||||
note over M, C: 4. deduplicate new contact
|
||||
B ->> M: x.info.probe<br>"probe" is sent to all new members
|
||||
B ->> C: x.info.probe.check<br>"probe" hash,<br>in case contact and<br>member profiles match
|
||||
C ->> B: x.info.probe.ok<br> original "probe",<br> in case contact and member<br>are the same user
|
||||
note over B: merge existing and new contacts if received and sent probe hashes match
|
||||
end
|
||||
|
File diff suppressed because one or more lines are too long
Before Width: | Height: | Size: 34 KiB After Width: | Height: | Size: 34 KiB |
@ -94,6 +94,7 @@ import qualified Simplex.Messaging.Protocol as SMP
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport.Client (defaultSocksProxy)
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import System.FilePath (combine, splitExtensions, takeFileName, (</>))
|
||||
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout)
|
||||
@ -104,7 +105,6 @@ import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay)
|
||||
import UnliftIO.Directory
|
||||
import UnliftIO.IO (hClose, hSeek, hTell, openFile)
|
||||
import UnliftIO.STM
|
||||
import Simplex.Messaging.Version
|
||||
|
||||
defaultChatConfig :: ChatConfig
|
||||
defaultChatConfig =
|
||||
@ -1431,12 +1431,16 @@ processChatCommand = \case
|
||||
Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName
|
||||
| otherwise -> throwChatError $ CEGroupDuplicateMember cName
|
||||
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} <- withStore $ \db -> getGroupInvitation db user groupId
|
||||
(invitation, ct) <- withStore $ \db -> do
|
||||
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db user groupId
|
||||
(inv,) <$> getContactViaMember db user fromMember
|
||||
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
|
||||
Contact {activeConn = Connection {connChatVRange}} = ct
|
||||
withChatLock "joinGroup" . procCmd $ do
|
||||
dm <- directMessage $ XGrpAcpt (memberId (membership :: GroupMember))
|
||||
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm
|
||||
withStore' $ \db -> do
|
||||
createMemberConnection db userId fromMember agentConnId
|
||||
createMemberConnection db userId fromMember agentConnId connChatVRange
|
||||
updateGroupMemberStatus db userId fromMember GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
updateCIGroupInvitationStatus user
|
||||
@ -1878,11 +1882,11 @@ processChatCommand = \case
|
||||
mergedProfile' = userProfileToSend user' Nothing $ Just ct'
|
||||
if mergedProfile' == mergedProfile
|
||||
then pure s {notChanged = notChanged + 1}
|
||||
else
|
||||
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
|
||||
else
|
||||
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
|
||||
in (notifyContact mergedProfile' ct' $> s {updateSuccesses = updateSuccesses + 1, changedContacts = cts'})
|
||||
`catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> s {updateFailures = updateFailures + 1, changedContacts = cts'}
|
||||
where
|
||||
where
|
||||
notifyContact mergedProfile' ct' = do
|
||||
void $ sendDirectContactMessage ct' (XInfo mergedProfile')
|
||||
when (directOrUsed ct') $ createSndFeatureItems user' ct ct'
|
||||
@ -2825,7 +2829,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
_ -> Nothing
|
||||
|
||||
processDirectMessage :: ACommand 'Agent e -> ConnectionEntity -> Connection -> Maybe Contact -> m ()
|
||||
processDirectMessage agentMsg connEntity conn@Connection {connId, viaUserContactLink, groupLinkId, customUserProfileId, connectionCode} = \case
|
||||
processDirectMessage agentMsg connEntity conn@Connection {connId, connChatVRange, viaUserContactLink, groupLinkId, customUserProfileId, connectionCode} = \case
|
||||
Nothing -> case agentMsg of
|
||||
CONF confId _ connInfo -> do
|
||||
-- [incognito] send saved profile
|
||||
@ -2866,7 +2870,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
setConnConnReqInv db user connId cReq
|
||||
getXGrpMemIntroContDirect db user ct
|
||||
forM_ contData $ \(hostConnId, xGrpMemIntroCont) ->
|
||||
sendXGrpMemInv hostConnId directConnReq xGrpMemIntroCont
|
||||
sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont
|
||||
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
|
||||
MSG msgMeta _msgFlags msgBody -> do
|
||||
cmdId <- createAckCmd conn
|
||||
@ -2948,7 +2952,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
forM_ groupId_ $ \groupId -> do
|
||||
gVar <- asks idsDrg
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation
|
||||
withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds
|
||||
withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds connChatVRange
|
||||
_ -> pure ()
|
||||
Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) ->
|
||||
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
|
||||
@ -3015,22 +3019,32 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
case cReq of
|
||||
groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of
|
||||
-- [async agent commands] XGrpMemIntro continuation on receiving INV
|
||||
CFCreateConnGrpMemInv -> do
|
||||
contData <- withStore' $ \db -> do
|
||||
setConnConnReqInv db user connId cReq
|
||||
getXGrpMemIntroContGroup db user m
|
||||
forM_ contData $ \(hostConnId, directConnReq) -> do
|
||||
let GroupMember {groupMemberId, memberId} = m
|
||||
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
|
||||
CFCreateConnGrpMemInv ->
|
||||
ifM
|
||||
(featureVersionSupported (connChatVRange conn) groupNoDirectVersion)
|
||||
sendWithoutDirectCReq
|
||||
sendWithDirectCReq
|
||||
where
|
||||
sendWithoutDirectCReq = do
|
||||
let GroupMember {groupMemberId, memberId} = m
|
||||
hostConnId <- withStore $ \db -> do
|
||||
liftIO $ setConnConnReqInv db user connId cReq
|
||||
getHostConnId db user groupId
|
||||
sendXGrpMemInv hostConnId Nothing XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
|
||||
sendWithDirectCReq = do
|
||||
let GroupMember {groupMemberId, memberId} = m
|
||||
contData <- withStore' $ \db -> do
|
||||
setConnConnReqInv db user connId cReq
|
||||
getXGrpMemIntroContGroup db user m
|
||||
forM_ contData $ \(hostConnId, directConnReq) ->
|
||||
sendXGrpMemInv hostConnId (Just directConnReq) XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
|
||||
-- [async agent commands] group link auto-accept continuation on receiving INV
|
||||
CFCreateConnGrpInv ->
|
||||
withStore' (\db -> getContactViaMember db user m) >>= \case
|
||||
Nothing -> messageError "implementation error: invitee does not have contact"
|
||||
Just ct -> do
|
||||
withStore' $ \db -> setNewContactMemberConnRequest db user m cReq
|
||||
groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo
|
||||
sendGrpInvitation ct m groupLinkId
|
||||
toView $ CRSentGroupInvitation user gInfo ct m
|
||||
CFCreateConnGrpInv -> do
|
||||
ct <- withStore $ \db -> getContactViaMember db user m
|
||||
withStore' $ \db -> setNewContactMemberConnRequest db user m cReq
|
||||
groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo
|
||||
sendGrpInvitation ct m groupLinkId
|
||||
toView $ CRSentGroupInvitation user gInfo ct m
|
||||
where
|
||||
sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> m ()
|
||||
sendGrpInvitation ct GroupMember {memberId, memberRole = memRole} groupLinkId = do
|
||||
@ -3106,7 +3120,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
processIntro intro `catchChatError` (toView . CRChatError (Just user))
|
||||
where
|
||||
processIntro intro@GroupMemberIntro {introId} = do
|
||||
void $ sendDirectMessage conn (XGrpMemIntro . memberInfo $ reMember intro) (GroupId groupId)
|
||||
void $ sendDirectMessage conn (XGrpMemIntro $ memberInfo (reMember intro)) (GroupId groupId)
|
||||
withStore' $ \db -> updateIntroStatus db introId GMIntroSent
|
||||
_ -> do
|
||||
-- TODO send probe and decide whether to use existing contact connection or the new contact connection
|
||||
@ -4006,7 +4020,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
|
||||
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processGroupInvitation ct inv msg msgMeta = do
|
||||
let Contact {localDisplayName = c, activeConn = Connection {customUserProfileId, groupLinkId = groupLinkId'}} = ct
|
||||
let Contact {localDisplayName = c, activeConn = Connection {connChatVRange, customUserProfileId, groupLinkId = groupLinkId'}} = ct
|
||||
GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
||||
@ -4017,7 +4031,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
then do
|
||||
connIds <- joinAgentConnectionAsync user True connRequest =<< directMessage (XGrpAcpt memberId)
|
||||
withStore' $ \db -> do
|
||||
createMemberConnectionAsync db user hostId connIds
|
||||
createMemberConnectionAsync db user hostId connIds connChatVRange
|
||||
updateGroupMemberStatusById db userId hostId GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
|
||||
@ -4230,7 +4244,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
_ -> pure conn'
|
||||
|
||||
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> MsgMeta -> m ()
|
||||
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole memberProfile) msg msgMeta = do
|
||||
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ memberProfile) msg msgMeta = do
|
||||
checkHostRole m memRole
|
||||
members <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
unless (sameMemberId memId $ membership gInfo) $
|
||||
@ -4243,7 +4257,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
|
||||
|
||||
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m ()
|
||||
xGrpMemIntro gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ _) = do
|
||||
xGrpMemIntro gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
|
||||
case memberCategory m of
|
||||
GCHostMember -> do
|
||||
members <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
@ -4252,14 +4266,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
else do
|
||||
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c)
|
||||
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation
|
||||
directConnIds <- createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation
|
||||
-- [incognito] direct connection with member has to be established using the same incognito profile [that was known to host and used for group membership]
|
||||
groupConnIds <- createConn
|
||||
directConnIds <- case memberChatVRange of
|
||||
Nothing -> Just <$> createConn
|
||||
Just mcvr ->
|
||||
ifM
|
||||
(featureVersionSupported (fromChatVRange mcvr) groupNoDirectVersion)
|
||||
(pure Nothing)
|
||||
(Just <$> createConn)
|
||||
let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
|
||||
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId
|
||||
_ -> messageError "x.grp.mem.intro can be only sent by host member"
|
||||
where
|
||||
createConn = createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation
|
||||
|
||||
sendXGrpMemInv :: Int64 -> ConnReqInvitation -> XGrpMemIntroCont -> m ()
|
||||
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> m ()
|
||||
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
|
||||
hostConn <- withStore $ \db -> getConnectionById db user hostConnId
|
||||
let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq}
|
||||
@ -4280,7 +4301,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
|
||||
|
||||
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
|
||||
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m memInfo@(MemberInfo memId memRole _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
|
||||
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
|
||||
checkHostRole m memRole
|
||||
members <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
toMember <- case find (sameMemberId memId) members of
|
||||
@ -4295,9 +4316,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
dm <- directMessage $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership)
|
||||
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
|
||||
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm
|
||||
directConnIds <- joinAgentConnectionAsync user enableNtfs directConnReq dm
|
||||
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm
|
||||
let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember groupConnIds directConnIds customUserProfileId
|
||||
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId
|
||||
|
||||
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> MsgMeta -> m ()
|
||||
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg msgMeta
|
||||
@ -4444,6 +4466,13 @@ updateConnChatVRange conn@Connection {connId, connChatVRange} msgChatVRange
|
||||
pure conn {connChatVRange = msgChatVRange}
|
||||
| otherwise = pure conn
|
||||
|
||||
featureVersionSupported :: ChatMonad' m => VersionRange -> Version -> m Bool
|
||||
featureVersionSupported peerVRange v = do
|
||||
ChatConfig {chatVRange} <- asks config
|
||||
case chatVRange `compatibleVersion` peerVRange of
|
||||
Just (Compatible v') -> pure $ v' >= v
|
||||
Nothing -> pure False
|
||||
|
||||
parseFileDescription :: (ChatMonad m, FilePartyI p) => Text -> m (ValidFileDescription p)
|
||||
parseFileDescription =
|
||||
liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8)
|
||||
|
@ -54,6 +54,10 @@ currentChatVersion = 2
|
||||
supportedChatVRange :: VersionRange
|
||||
supportedChatVRange = mkVersionRange 1 currentChatVersion
|
||||
|
||||
-- version that starts support for skipping establishing direct connections in a group
|
||||
groupNoDirectVersion :: Version
|
||||
groupNoDirectVersion = 2
|
||||
|
||||
data ConnectionEntity
|
||||
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
|
||||
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
|
||||
@ -107,18 +111,6 @@ data AppMessage (e :: MsgEncoding) where
|
||||
AMJson :: AppMessageJson -> AppMessage 'Json
|
||||
AMBinary :: AppMessageBinary -> AppMessage 'Binary
|
||||
|
||||
newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRange} deriving (Eq, Show)
|
||||
|
||||
chatInitialVRange :: VersionRange
|
||||
chatInitialVRange = versionToRange 1
|
||||
|
||||
instance FromJSON ChatVersionRange where
|
||||
parseJSON v = ChatVersionRange <$> strParseJSON "ChatVersionRange" v
|
||||
|
||||
instance ToJSON ChatVersionRange where
|
||||
toJSON (ChatVersionRange vr) = strToJSON vr
|
||||
toEncoding (ChatVersionRange vr) = strToJEncoding vr
|
||||
|
||||
-- chat message is sent as JSON with these properties
|
||||
data AppMessageJson = AppMessageJson
|
||||
{ v :: Maybe ChatVersionRange,
|
||||
|
@ -498,10 +498,10 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (Vers
|
||||
<$> DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE contact_requests
|
||||
SET agent_invitation_id = ?, chat_vrange_min_version = ?, chat_vrange_max_version = ?, updated_at = ?
|
||||
WHERE user_id = ? AND contact_request_id = ?
|
||||
|]
|
||||
UPDATE contact_requests
|
||||
SET agent_invitation_id = ?, chat_vrange_min_version = ?, chat_vrange_max_version = ?, updated_at = ?
|
||||
WHERE user_id = ? AND contact_request_id = ?
|
||||
|]
|
||||
(invId, minV, maxV, currentTs, userId, cReqId)
|
||||
else withLocalDisplayName db userId displayName $ \ldn ->
|
||||
Right <$> do
|
||||
|
@ -83,6 +83,7 @@ module Simplex.Chat.Store.Groups
|
||||
updateGroupSettings,
|
||||
getXGrpMemIntroContDirect,
|
||||
getXGrpMemIntroContGroup,
|
||||
getHostConnId,
|
||||
)
|
||||
where
|
||||
|
||||
@ -98,7 +99,6 @@ import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Store.Direct
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Protocol (chatInitialVRange)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
|
||||
@ -106,6 +106,7 @@ import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
import Simplex.Messaging.Version
|
||||
import UnliftIO.STM
|
||||
|
||||
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow
|
||||
@ -481,20 +482,21 @@ getUserGroupsWithSummary db user _contactId_ search_ =
|
||||
-- the statuses on non-current members should match memberCurrent' function
|
||||
getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary
|
||||
getGroupSummary db User {userId} groupId = do
|
||||
currentMembers_ <- maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT count (m.group_member_id)
|
||||
FROM groups g
|
||||
JOIN group_members m USING (group_id)
|
||||
WHERE g.user_id = ?
|
||||
AND g.group_id = ?
|
||||
AND m.member_status != ?
|
||||
AND m.member_status != ?
|
||||
AND m.member_status != ?
|
||||
|]
|
||||
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemInvited)
|
||||
currentMembers_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT count (m.group_member_id)
|
||||
FROM groups g
|
||||
JOIN group_members m USING (group_id)
|
||||
WHERE g.user_id = ?
|
||||
AND g.group_id = ?
|
||||
AND m.member_status != ?
|
||||
AND m.member_status != ?
|
||||
AND m.member_status != ?
|
||||
|]
|
||||
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemInvited)
|
||||
pure GroupSummary {currentMembers = fromMaybe 0 currentMembers_}
|
||||
|
||||
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
|
||||
@ -613,11 +615,11 @@ getGroupInvitation db user groupId =
|
||||
DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId)
|
||||
|
||||
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember
|
||||
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole agentConnId connRequest =
|
||||
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile, activeConn = Connection {connChatVRange}} memberRole agentConnId connRequest =
|
||||
createWithRandomId gVar $ \memId -> do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt
|
||||
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt
|
||||
void $ createMemberConnection_ db userId groupMemberId agentConnId connChatVRange Nothing 0 createdAt
|
||||
pure member
|
||||
where
|
||||
createMember_ memberId createdAt = do
|
||||
@ -652,13 +654,13 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
|
||||
:. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt)
|
||||
)
|
||||
|
||||
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> ExceptT StoreError IO ()
|
||||
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) =
|
||||
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionRange -> ExceptT StoreError IO ()
|
||||
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) connChatVRange =
|
||||
createWithRandomId gVar $ \memId -> do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
insertMember_ (MemberId memId) createdAt
|
||||
groupMemberId <- liftIO $ insertedRowId db
|
||||
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt
|
||||
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId connChatVRange Nothing 0 createdAt
|
||||
setCommandConnId db user cmdId connId
|
||||
where
|
||||
insertMember_ memberId createdAt =
|
||||
@ -674,31 +676,32 @@ createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Co
|
||||
:. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt)
|
||||
)
|
||||
|
||||
getContactViaMember :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact)
|
||||
getContactViaMember :: DB.Connection -> User -> GroupMember -> ExceptT StoreError IO Contact
|
||||
getContactViaMember db user@User {userId} GroupMember {groupMemberId} =
|
||||
maybeFirstRow (toContact user) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- Contact
|
||||
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
|
||||
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
|
||||
-- Connection
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
|
||||
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
|
||||
c.chat_vrange_min_version, c.chat_vrange_max_version
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
|
||||
JOIN connections c ON c.connection_id = (
|
||||
SELECT max(cc.connection_id)
|
||||
FROM connections cc
|
||||
where cc.contact_id = ct.contact_id
|
||||
)
|
||||
JOIN group_members m ON m.contact_id = ct.contact_id
|
||||
WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0
|
||||
|]
|
||||
(userId, groupMemberId)
|
||||
ExceptT $
|
||||
firstRow (toContact user) (SEContactNotFoundByMemberId groupMemberId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- Contact
|
||||
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
|
||||
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
|
||||
-- Connection
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
|
||||
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
|
||||
c.chat_vrange_min_version, c.chat_vrange_max_version
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
|
||||
JOIN connections c ON c.connection_id = (
|
||||
SELECT max(cc.connection_id)
|
||||
FROM connections cc
|
||||
where cc.contact_id = ct.contact_id
|
||||
)
|
||||
JOIN group_members m ON m.contact_id = ct.contact_id
|
||||
WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0
|
||||
|]
|
||||
(userId, groupMemberId)
|
||||
|
||||
setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO ()
|
||||
setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do
|
||||
@ -710,15 +713,15 @@ getMemberInvitation db User {userId} groupMemberId =
|
||||
fmap join . maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId)
|
||||
|
||||
createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> IO ()
|
||||
createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do
|
||||
createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> VersionRange -> IO ()
|
||||
createMemberConnection db userId GroupMember {groupMemberId} agentConnId connChatVRange = do
|
||||
currentTs <- getCurrentTime
|
||||
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs
|
||||
void $ createMemberConnection_ db userId groupMemberId agentConnId connChatVRange Nothing 0 currentTs
|
||||
|
||||
createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> IO ()
|
||||
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) = do
|
||||
createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> VersionRange -> IO ()
|
||||
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) connChatVRange = do
|
||||
currentTs <- getCurrentTime
|
||||
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs
|
||||
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId connChatVRange Nothing 0 currentTs
|
||||
setCommandConnId db user cmdId connId
|
||||
|
||||
updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO ()
|
||||
@ -738,25 +741,30 @@ updateGroupMemberStatusById db userId groupMemberId memStatus = do
|
||||
|
||||
-- | add new member with profile
|
||||
createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
|
||||
createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image, contactLink, preferences}) memCategory memStatus =
|
||||
ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do
|
||||
currentTs <- getCurrentTime
|
||||
createNewGroupMember db user gInfo memInfo memCategory memStatus = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memInfo currentTs
|
||||
let newMember =
|
||||
NewGroupMember
|
||||
{ memInfo,
|
||||
memCategory,
|
||||
memStatus,
|
||||
memInvitedBy = IBUnknown,
|
||||
localDisplayName,
|
||||
memContactId = Nothing,
|
||||
memProfileId
|
||||
}
|
||||
liftIO $ createNewMember_ db user gInfo newMember currentTs
|
||||
|
||||
createNewMemberProfile_ :: DB.Connection -> User -> MemberInfo -> UTCTime -> ExceptT StoreError IO (Text, ProfileId)
|
||||
createNewMemberProfile_ db User {userId} (MemberInfo _ _ _ Profile {displayName, fullName, image, contactLink, preferences}) createdAt =
|
||||
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
|
||||
(displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs)
|
||||
memProfileId <- insertedRowId db
|
||||
let newMember =
|
||||
NewGroupMember
|
||||
{ memInfo,
|
||||
memCategory,
|
||||
memStatus,
|
||||
memInvitedBy = IBUnknown,
|
||||
localDisplayName,
|
||||
memContactId = Nothing,
|
||||
memProfileId
|
||||
}
|
||||
Right <$> createNewMember_ db user gInfo newMember currentTs
|
||||
(displayName, fullName, image, contactLink, userId, preferences, createdAt, createdAt)
|
||||
profileId <- insertedRowId db
|
||||
pure $ Right (ldn, profileId)
|
||||
|
||||
createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember
|
||||
createNewMember_
|
||||
@ -764,7 +772,7 @@ createNewMember_
|
||||
User {userId, userContactId}
|
||||
GroupInfo {groupId}
|
||||
NewGroupMember
|
||||
{ memInfo = MemberInfo memberId memberRole memberProfile,
|
||||
{ memInfo = MemberInfo memberId memberRole _ memberProfile,
|
||||
memCategory = memberCategory,
|
||||
memStatus = memberStatus,
|
||||
memInvitedBy = invitedBy,
|
||||
@ -908,43 +916,41 @@ getIntroduction_ db reMember toMember = ExceptT $ do
|
||||
where
|
||||
toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
|
||||
toIntro [(introId, groupConnReq, directConnReq, introStatus)] =
|
||||
let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq
|
||||
let introInvitation = IntroInvitation <$> groupConnReq <*> pure directConnReq
|
||||
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
|
||||
toIntro _ = Left SEIntroNotFound
|
||||
|
||||
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember
|
||||
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do
|
||||
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
||||
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember
|
||||
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId = do
|
||||
let mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
|
||||
cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
||||
currentTs <- liftIO getCurrentTime
|
||||
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId chatInitialVRange memberContactId Nothing customUserProfileId cLevel currentTs
|
||||
liftIO $ setCommandConnId db user directCmdId directConnId
|
||||
(localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing
|
||||
newMember <- case directConnIds of
|
||||
Just (directCmdId, directAgentConnId) -> do
|
||||
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId mcvr memberContactId Nothing customUserProfileId cLevel currentTs
|
||||
liftIO $ setCommandConnId db user directCmdId directConnId
|
||||
(localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing
|
||||
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Just contactId, memProfileId}
|
||||
Nothing -> do
|
||||
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memInfo currentTs
|
||||
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Nothing, memProfileId}
|
||||
liftIO $ do
|
||||
let newMember =
|
||||
NewGroupMember
|
||||
{ memInfo,
|
||||
memCategory = GCPreMember,
|
||||
memStatus = GSMemIntroduced,
|
||||
memInvitedBy = IBUnknown,
|
||||
localDisplayName,
|
||||
memContactId = Just contactId,
|
||||
memProfileId
|
||||
}
|
||||
member <- createNewMember_ db user gInfo newMember currentTs
|
||||
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs
|
||||
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId mcvr memberContactId cLevel currentTs
|
||||
liftIO $ setCommandConnId db user groupCmdId groupConnId
|
||||
pure (member :: GroupMember) {activeConn = Just conn}
|
||||
|
||||
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> IO ()
|
||||
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do
|
||||
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionRange -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> IO ()
|
||||
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId = do
|
||||
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
||||
currentTs <- getCurrentTime
|
||||
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs
|
||||
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId mcvr viaContactId cLevel currentTs
|
||||
setCommandConnId db user groupCmdId groupConnId
|
||||
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId chatInitialVRange viaContactId Nothing customUserProfileId cLevel currentTs
|
||||
setCommandConnId db user directCmdId directConnId
|
||||
contactId <- createMemberContact_ directConnId currentTs
|
||||
updateMember_ contactId currentTs
|
||||
forM_ directConnIds $ \(directCmdId, directAgentConnId) -> do
|
||||
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId mcvr viaContactId Nothing customUserProfileId cLevel currentTs
|
||||
setCommandConnId db user directCmdId directConnId
|
||||
contactId <- createMemberContact_ directConnId currentTs
|
||||
updateMember_ contactId currentTs
|
||||
where
|
||||
createMemberContact_ :: Int64 -> UTCTime -> IO Int64
|
||||
createMemberContact_ connId ts = do
|
||||
@ -971,8 +977,8 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId =
|
||||
|]
|
||||
[":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId]
|
||||
|
||||
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection
|
||||
createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId chatInitialVRange viaContact Nothing Nothing
|
||||
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> Maybe Int64 -> Int -> UTCTime -> IO Connection
|
||||
createMemberConnection_ db userId groupMemberId agentConnId connChatVRange viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId connChatVRange viaContact Nothing Nothing
|
||||
|
||||
getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
|
||||
getViaGroupMember db User {userId, userContactId} Contact {contactId} =
|
||||
@ -1343,3 +1349,9 @@ getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do
|
||||
toCont (hostConnId, connReq_) = case connReq_ of
|
||||
Just connReq -> Just (hostConnId, connReq)
|
||||
_ -> Nothing
|
||||
|
||||
getHostConnId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId
|
||||
getHostConnId db user@User {userId} groupId = do
|
||||
hostMemberId <- getHostMemberId_ db user groupId
|
||||
ExceptT . firstRow fromOnly (SEConnectionNotFoundByMemberId hostMemberId) $
|
||||
DB.query db "SELECT connection_id FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, hostMemberId)
|
||||
|
@ -51,6 +51,7 @@ data StoreError
|
||||
| SEUserNotFoundByContactRequestId {contactRequestId :: Int64}
|
||||
| SEContactNotFound {contactId :: ContactId}
|
||||
| SEContactNotFoundByName {contactName :: ContactName}
|
||||
| SEContactNotFoundByMemberId {groupMemberId :: GroupMemberId}
|
||||
| SEContactNotReady {contactName :: ContactName}
|
||||
| SEDuplicateContactLink
|
||||
| SEUserContactLinkNotFound
|
||||
@ -78,6 +79,7 @@ data StoreError
|
||||
| SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId}
|
||||
| SEConnectionNotFound {agentConnId :: AgentConnId}
|
||||
| SEConnectionNotFoundById {connId :: Int64}
|
||||
| SEConnectionNotFoundByMemberId {groupMemberId :: GroupMemberId}
|
||||
| SEPendingConnectionNotFound {connId :: Int64}
|
||||
| SEIntroNotFound
|
||||
| SEUniqueID
|
||||
|
@ -347,11 +347,12 @@ data ChatSettings = ChatSettings
|
||||
instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
defaultChatSettings :: ChatSettings
|
||||
defaultChatSettings = ChatSettings
|
||||
{ enableNtfs = True,
|
||||
sendRcpts = Nothing,
|
||||
favorite = False
|
||||
}
|
||||
defaultChatSettings =
|
||||
ChatSettings
|
||||
{ enableNtfs = True,
|
||||
sendRcpts = Nothing,
|
||||
favorite = False
|
||||
}
|
||||
|
||||
pattern DisableNtfs :: ChatSettings
|
||||
pattern DisableNtfs <- ChatSettings {enableNtfs = False}
|
||||
@ -538,24 +539,31 @@ instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOpt
|
||||
|
||||
data IntroInvitation = IntroInvitation
|
||||
{ groupConnReq :: ConnReqInvitation,
|
||||
directConnReq :: ConnReqInvitation
|
||||
directConnReq :: Maybe ConnReqInvitation
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON IntroInvitation where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
instance ToJSON IntroInvitation where
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
data MemberInfo = MemberInfo
|
||||
{ memberId :: MemberId,
|
||||
memberRole :: GroupMemberRole,
|
||||
v :: Maybe ChatVersionRange,
|
||||
profile :: Profile
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON MemberInfo where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
instance ToJSON MemberInfo where
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
memberInfo :: GroupMember -> MemberInfo
|
||||
memberInfo GroupMember {memberId, memberRole, memberProfile} =
|
||||
MemberInfo memberId memberRole (fromLocalProfile memberProfile)
|
||||
memberInfo GroupMember {memberId, memberRole, memberProfile, activeConn} =
|
||||
MemberInfo memberId memberRole memberChatVRange (fromLocalProfile memberProfile)
|
||||
where
|
||||
memberChatVRange = ChatVersionRange . connChatVRange <$> activeConn
|
||||
|
||||
data ReceivedGroupInvitation = ReceivedGroupInvitation
|
||||
{ fromMember :: GroupMember,
|
||||
@ -1467,3 +1475,15 @@ instance ProtocolTypeI p => ToJSON (ServerCfg p) where
|
||||
|
||||
instance ProtocolTypeI p => FromJSON (ServerCfg p) where
|
||||
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRange} deriving (Eq, Show)
|
||||
|
||||
chatInitialVRange :: VersionRange
|
||||
chatInitialVRange = versionToRange 1
|
||||
|
||||
instance FromJSON ChatVersionRange where
|
||||
parseJSON v = ChatVersionRange <$> strParseJSON "ChatVersionRange" v
|
||||
|
||||
instance ToJSON ChatVersionRange where
|
||||
toJSON (ChatVersionRange vr) = strToJSON vr
|
||||
toEncoding (ChatVersionRange vr) = strToJEncoding vr
|
||||
|
@ -13,13 +13,14 @@ import Control.Monad (forM_)
|
||||
import Directory.Options
|
||||
import Directory.Service
|
||||
import Directory.Store
|
||||
import GHC.IO.Handle (hClose)
|
||||
import Simplex.Chat.Bot.KnownContacts
|
||||
import Simplex.Chat.Controller (ChatConfig (..))
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
|
||||
import Simplex.Chat.Types (GroupMemberRole (..), Profile (..))
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hspec
|
||||
import GHC.IO.Handle (hClose)
|
||||
|
||||
directoryServiceTests :: SpecWith FilePath
|
||||
directoryServiceTests = do
|
||||
@ -232,10 +233,10 @@ testJoinGroup tmp =
|
||||
dan <## "bob (Bob): contact is connected"
|
||||
dan <## "#privacy: you joined the group"
|
||||
dan <# ("#privacy bob> " <> welcomeMsg)
|
||||
dan <###
|
||||
[ "#privacy: member SimpleX-Directory is connected",
|
||||
"#privacy: member cath (Catherine) is connected"
|
||||
],
|
||||
dan
|
||||
<### [ "#privacy: member SimpleX-Directory is connected",
|
||||
"#privacy: member cath (Catherine) is connected"
|
||||
],
|
||||
do
|
||||
cath <## "#privacy: bob added dan (Daniel) to the group (connecting...)"
|
||||
cath <## "#privacy: new member dan is connected"
|
||||
@ -243,9 +244,9 @@ testJoinGroup tmp =
|
||||
|
||||
testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO ()
|
||||
testDelistedOwnerLeaves tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -259,9 +260,9 @@ testDelistedOwnerLeaves tmp =
|
||||
|
||||
testDelistedOwnerRemoved :: HasCallStack => FilePath -> IO ()
|
||||
testDelistedOwnerRemoved tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -274,9 +275,9 @@ testDelistedOwnerRemoved tmp =
|
||||
|
||||
testNotDelistedMemberLeaves :: HasCallStack => FilePath -> IO ()
|
||||
testNotDelistedMemberLeaves tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -286,10 +287,10 @@ testNotDelistedMemberLeaves tmp =
|
||||
groupFound cath "privacy"
|
||||
|
||||
testNotDelistedMemberRemoved :: HasCallStack => FilePath -> IO ()
|
||||
testNotDelistedMemberRemoved tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
testNotDelistedMemberRemoved tmp =
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -299,9 +300,9 @@ testNotDelistedMemberRemoved tmp =
|
||||
|
||||
testDelistedServiceRemoved :: HasCallStack => FilePath -> IO ()
|
||||
testDelistedServiceRemoved tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -316,9 +317,9 @@ testDelistedServiceRemoved tmp =
|
||||
|
||||
testDelistedRoleChanges :: HasCallStack => FilePath -> IO ()
|
||||
testDelistedRoleChanges tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -362,9 +363,9 @@ testDelistedRoleChanges tmp =
|
||||
|
||||
testNotDelistedMemberRoleChanged :: HasCallStack => FilePath -> IO ()
|
||||
testNotDelistedMemberRoleChanged tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -426,9 +427,9 @@ testNotApprovedBadRoles tmp =
|
||||
|
||||
testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
|
||||
testRegOwnerChangedProfile tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -445,9 +446,9 @@ testRegOwnerChangedProfile tmp =
|
||||
|
||||
testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
|
||||
testAnotherOwnerChangedProfile tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -464,9 +465,9 @@ testAnotherOwnerChangedProfile tmp =
|
||||
|
||||
testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
|
||||
testRegOwnerRemovedLink tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -497,9 +498,9 @@ testRegOwnerRemovedLink tmp =
|
||||
|
||||
testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
|
||||
testAnotherOwnerRemovedLink tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
@ -646,9 +647,9 @@ testDuplicateProhibitApproval tmp =
|
||||
|
||||
testListUserGroups :: HasCallStack => FilePath -> IO ()
|
||||
testListUserGroups tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
|
||||
withNewTestChatCfg tmp testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
cath `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
@ -686,15 +687,15 @@ testRestoreDirectory tmp = do
|
||||
withTestChat tmp "bob" $ \bob ->
|
||||
withTestChat tmp "cath" $ \cath -> do
|
||||
bob <## "2 contacts connected (use /cs for the list)"
|
||||
bob <###
|
||||
[ "#privacy (Privacy): connected to server(s)",
|
||||
"#security (Security): connected to server(s)"
|
||||
]
|
||||
bob
|
||||
<### [ "#privacy (Privacy): connected to server(s)",
|
||||
"#security (Security): connected to server(s)"
|
||||
]
|
||||
cath <## "2 contacts connected (use /cs for the list)"
|
||||
cath <###
|
||||
[ "#privacy (Privacy): connected to server(s)",
|
||||
"#anonymity (Anonymity): connected to server(s)"
|
||||
]
|
||||
cath
|
||||
<### [ "#privacy (Privacy): connected to server(s)",
|
||||
"#anonymity (Anonymity): connected to server(s)"
|
||||
]
|
||||
listGroups superUser bob cath
|
||||
groupFoundN 3 bob "privacy"
|
||||
groupFound bob "security"
|
||||
@ -784,10 +785,13 @@ addCathAsOwner bob cath = do
|
||||
cath <## "#privacy: member SimpleX-Directory is connected"
|
||||
|
||||
withDirectoryService :: HasCallStack => FilePath -> (TestCC -> String -> IO ()) -> IO ()
|
||||
withDirectoryService tmp test = do
|
||||
withDirectoryService tmp = withDirectoryServiceCfg tmp testCfg
|
||||
|
||||
withDirectoryServiceCfg :: HasCallStack => FilePath -> ChatConfig -> (TestCC -> String -> IO ()) -> IO ()
|
||||
withDirectoryServiceCfg tmp cfg test = do
|
||||
dsLink <-
|
||||
withNewTestChat tmp serviceDbPrefix directoryProfile $ \ds ->
|
||||
withNewTestChat tmp "super_user" aliceProfile $ \superUser -> do
|
||||
withNewTestChatCfg tmp cfg serviceDbPrefix directoryProfile $ \ds ->
|
||||
withNewTestChatCfg tmp cfg "super_user" aliceProfile $ \superUser -> do
|
||||
connectUsers ds superUser
|
||||
ds ##> "/ad"
|
||||
getContactLink ds True
|
||||
@ -800,7 +804,7 @@ restoreDirectoryService tmp ctCount grCount test = do
|
||||
ds <## (show ctCount <> " contacts connected (use /cs for the list)")
|
||||
ds <## "Your address is active! To show: /sa"
|
||||
ds <## (show grCount <> " group links active")
|
||||
forM_ [1..grCount] $ \_ -> ds <##. "#"
|
||||
forM_ [1 .. grCount] $ \_ -> ds <##. "#"
|
||||
ds ##> "/sa"
|
||||
dsLink <- getContactLink ds False
|
||||
ds <## "auto_accept on"
|
||||
|
@ -22,6 +22,7 @@ import Simplex.Chat
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..))
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Protocol (groupNoDirectVersion)
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Terminal
|
||||
@ -133,6 +134,16 @@ testAgentCfgV1 =
|
||||
testCfgV1 :: ChatConfig
|
||||
testCfgV1 = testCfg {agentConfig = testAgentCfgV1}
|
||||
|
||||
testCfgCreateGroupDirect :: ChatConfig
|
||||
testCfgCreateGroupDirect =
|
||||
mkCfgCreateGroupDirect testCfg
|
||||
|
||||
mkCfgCreateGroupDirect :: ChatConfig -> ChatConfig
|
||||
mkCfgCreateGroupDirect cfg = cfg {chatVRange = groupCreateDirectVRange}
|
||||
|
||||
groupCreateDirectVRange :: VersionRange
|
||||
groupCreateDirectVRange = mkVersionRange 1 (groupNoDirectVersion - 1)
|
||||
|
||||
createTestChat :: FilePath -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
|
||||
createTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefix profile = do
|
||||
Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp </> dbPrefix) dbKey MCError
|
||||
@ -249,7 +260,7 @@ getTermLine cc =
|
||||
Just s -> do
|
||||
-- remove condition to always echo virtual terminal
|
||||
when (printOutput cc) $ do
|
||||
-- when True $ do
|
||||
-- when True $ do
|
||||
name <- userName cc
|
||||
putStrLn $ name <> ": " <> s
|
||||
pure s
|
||||
@ -288,7 +299,10 @@ testChatCfgOpts3 cfg opts p1 p2 p3 test = testChatN cfg opts [p1, p2, p3] test_
|
||||
test_ _ = error "expected 3 chat clients"
|
||||
|
||||
testChat4 :: HasCallStack => Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
||||
testChat4 p1 p2 p3 p4 test = testChatN testCfg testOpts [p1, p2, p3, p4] test_
|
||||
testChat4 = testChatCfg4 testCfg
|
||||
|
||||
testChatCfg4 :: HasCallStack => ChatConfig -> Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
||||
testChatCfg4 cfg p1 p2 p3 p4 test = testChatN cfg testOpts [p1, p2, p3, p4] test_
|
||||
where
|
||||
test_ :: HasCallStack => [TestCC] -> IO ()
|
||||
test_ [tc1, tc2, tc3, tc4] = test tc1 tc2 tc3 tc4
|
||||
|
@ -46,7 +46,7 @@ chatFileTests = do
|
||||
it "files folder: sender deleted file during transfer" testFilesFoldersImageSndDelete
|
||||
it "files folder: recipient deleted file during transfer" testFilesFoldersImageRcvDelete
|
||||
it "send and receive image with text and quote" testSendImageWithTextAndQuote
|
||||
describe "send and receive image to group" testGroupSendImage
|
||||
it "send and receive image to group" testGroupSendImage
|
||||
it "send and receive image with text and quote to group" testGroupSendImageWithTextAndQuote
|
||||
describe "async sending and receiving files" $ do
|
||||
-- fails on CI
|
||||
@ -724,11 +724,10 @@ testSendImageWithTextAndQuote =
|
||||
(alice <## "completed sending file 3 (test.jpg) to bob")
|
||||
B.readFile "./tests/tmp/test_1.jpg" `shouldReturn` src
|
||||
|
||||
testGroupSendImage :: SpecWith FilePath
|
||||
testGroupSendImage = versionTestMatrix3 runTestGroupSendImage
|
||||
where
|
||||
runTestGroupSendImage :: HasCallStack => TestCC -> TestCC -> TestCC -> IO ()
|
||||
runTestGroupSendImage alice bob cath = do
|
||||
testGroupSendImage :: HasCallStack => FilePath -> IO ()
|
||||
testGroupSendImage =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
alice ##> "/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}"
|
||||
|
@ -10,8 +10,10 @@ import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Monad (when)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller (ChatConfig (..))
|
||||
import Simplex.Chat.Protocol (supportedChatVRange)
|
||||
import Simplex.Chat.Store (agentStoreFile, chatStoreFile)
|
||||
import Simplex.Chat.Types (GroupMemberRole (..))
|
||||
import Simplex.Messaging.Version
|
||||
import System.Directory (copyFile)
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hspec
|
||||
@ -19,7 +21,7 @@ import Test.Hspec
|
||||
chatGroupTests :: SpecWith FilePath
|
||||
chatGroupTests = do
|
||||
describe "chat groups" $ do
|
||||
describe "add contacts, create group and send/receive messages" testGroup
|
||||
it "add contacts, create group and send/receive messages" testGroup
|
||||
it "add contacts, create group and send/receive messages, check messages" testGroupCheckMessages
|
||||
it "create and join group with 4 members" testGroup2
|
||||
it "create and delete group" testGroupDelete
|
||||
@ -64,15 +66,54 @@ chatGroupTests = do
|
||||
describe "group delivery receipts" $ do
|
||||
it "should send delivery receipts in group" testSendGroupDeliveryReceipts
|
||||
it "should send delivery receipts in group depending on configuration" testConfigureGroupDeliveryReceipts
|
||||
|
||||
testGroup :: HasCallStack => SpecWith FilePath
|
||||
testGroup = versionTestMatrix3 runTestGroup
|
||||
describe "direct connections in group are not established based on chat protocol version" $ do
|
||||
describe "3 members group" $ do
|
||||
testNoDirect _0 _0 True
|
||||
testNoDirect _0 _1 False
|
||||
testNoDirect _1 _0 False
|
||||
testNoDirect _1 _1 False
|
||||
describe "4 members group" $ do
|
||||
testNoDirect4 _0 _0 _0 True True True
|
||||
testNoDirect4 _0 _0 _1 True False False
|
||||
testNoDirect4 _0 _1 _0 False True False
|
||||
testNoDirect4 _0 _1 _1 False False False
|
||||
testNoDirect4 _1 _0 _0 False False True
|
||||
testNoDirect4 _1 _0 _1 False False False
|
||||
testNoDirect4 _1 _1 _0 False False False
|
||||
testNoDirect4 _1 _1 _1 False False False
|
||||
where
|
||||
runTestGroup alice bob cath = testGroupShared alice bob cath False
|
||||
_0 = supportedChatVRange -- don't create direct connections
|
||||
_1 = groupCreateDirectVRange
|
||||
-- having host configured with older version doesn't have effect in tests
|
||||
-- because host uses current code and sends version in MemberInfo
|
||||
testNoDirect vrMem2 vrMem3 noConns =
|
||||
it
|
||||
( "host " <> vRangeStr supportedChatVRange
|
||||
<> (", 2nd mem " <> vRangeStr vrMem2)
|
||||
<> (", 3rd mem " <> vRangeStr vrMem3)
|
||||
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
|
||||
)
|
||||
$ testNoGroupDirectConns supportedChatVRange vrMem2 vrMem3 noConns
|
||||
testNoDirect4 vrMem2 vrMem3 vrMem4 noConns23 noConns24 noConns34 =
|
||||
it
|
||||
( "host " <> vRangeStr supportedChatVRange
|
||||
<> (", 2nd mem " <> vRangeStr vrMem2)
|
||||
<> (", 3rd mem " <> vRangeStr vrMem3)
|
||||
<> (", 4th mem " <> vRangeStr vrMem4)
|
||||
<> (if noConns23 then " : 2 <!!> 3" else " : 2 <##> 3")
|
||||
<> (if noConns24 then " : 2 <!!> 4" else " : 2 <##> 4")
|
||||
<> (if noConns34 then " : 3 <!!> 4" else " : 3 <##> 4")
|
||||
)
|
||||
$ testNoGroupDirectConns4Members supportedChatVRange vrMem2 vrMem3 vrMem4 noConns23 noConns24 noConns34
|
||||
|
||||
testGroup :: HasCallStack => FilePath -> IO ()
|
||||
testGroup =
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> testGroupShared alice bob cath False
|
||||
|
||||
testGroupCheckMessages :: HasCallStack => FilePath -> IO ()
|
||||
testGroupCheckMessages =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> testGroupShared alice bob cath True
|
||||
|
||||
testGroupShared :: HasCallStack => TestCC -> TestCC -> TestCC -> Bool -> IO ()
|
||||
@ -233,7 +274,7 @@ testGroupShared alice bob cath checkMessages = do
|
||||
|
||||
testGroup2 :: HasCallStack => FilePath -> IO ()
|
||||
testGroup2 =
|
||||
testChat4 aliceProfile bobProfile cathProfile danProfile $
|
||||
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
|
||||
\alice bob cath dan -> do
|
||||
connectUsers alice bob
|
||||
connectUsers alice cath
|
||||
@ -679,7 +720,7 @@ testDeleteGroupMemberProfileKept =
|
||||
|
||||
testGroupRemoveAdd :: HasCallStack => FilePath -> IO ()
|
||||
testGroupRemoveAdd =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
-- remove member
|
||||
@ -754,7 +795,7 @@ testGroupList =
|
||||
|
||||
testGroupMessageQuotedReply :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMessageQuotedReply =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
@ -1232,7 +1273,7 @@ testGroupDeleteUnusedContacts =
|
||||
cath <## "alice (Alice)"
|
||||
cath `hasContactProfiles` ["alice", "cath"]
|
||||
where
|
||||
cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0}
|
||||
cfg = mkCfgCreateGroupDirect $ testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0}
|
||||
deleteGroup :: HasCallStack => TestCC -> TestCC -> TestCC -> String -> IO ()
|
||||
deleteGroup alice bob cath group = do
|
||||
alice ##> ("/d #" <> group)
|
||||
@ -1321,7 +1362,7 @@ testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile
|
||||
|
||||
testGroupModerate :: HasCallStack => FilePath -> IO ()
|
||||
testGroupModerate =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
alice ##> "/mr team cath member"
|
||||
@ -1352,7 +1393,7 @@ testGroupModerate =
|
||||
|
||||
testGroupModerateFullDelete :: HasCallStack => FilePath -> IO ()
|
||||
testGroupModerateFullDelete =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
alice ##> "/mr team cath member"
|
||||
@ -1390,10 +1431,10 @@ testGroupModerateFullDelete =
|
||||
|
||||
testGroupDelayedModeration :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDelayedModeration tmp = do
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChatCfg tmp cfg "alice" aliceProfile $ \alice -> do
|
||||
withNewTestChatCfg tmp cfg "bob" bobProfile $ \bob -> do
|
||||
createGroup2 "team" alice bob
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withNewTestChatCfg tmp cfg "cath" cathProfile $ \cath -> do
|
||||
connectUsers alice cath
|
||||
addMember "team" alice cath GRMember
|
||||
cath ##> "/j team"
|
||||
@ -1407,11 +1448,11 @@ testGroupDelayedModeration tmp = do
|
||||
alice ##> "\\\\ #team @cath hi"
|
||||
alice <## "message marked deleted by you"
|
||||
cath <# "#team cath> [marked deleted by alice] hi"
|
||||
withTestChat tmp "bob" $ \bob -> do
|
||||
withTestChatCfg tmp cfg "bob" $ \bob -> do
|
||||
bob <## "1 contacts connected (use /cs for the list)"
|
||||
bob <## "#team: connected to server(s)"
|
||||
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
|
||||
withTestChat tmp "cath" $ \cath -> do
|
||||
withTestChatCfg tmp cfg "cath" $ \cath -> do
|
||||
cath <## "2 contacts connected (use /cs for the list)"
|
||||
cath <## "#team: connected to server(s)"
|
||||
cath <## "#team: member bob (Bob) is connected"
|
||||
@ -1424,13 +1465,15 @@ testGroupDelayedModeration tmp = do
|
||||
bob ##> "/_get chat #1 count=2"
|
||||
r <- chat <$> getTermLine bob
|
||||
r `shouldMatchList` [(0, "connected"), (0, "hi [marked deleted by alice]")]
|
||||
where
|
||||
cfg = testCfgCreateGroupDirect
|
||||
|
||||
testGroupDelayedModerationFullDelete :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDelayedModerationFullDelete tmp = do
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChatCfg tmp cfg "alice" aliceProfile $ \alice -> do
|
||||
withNewTestChatCfg tmp cfg "bob" bobProfile $ \bob -> do
|
||||
createGroup2 "team" alice bob
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
withNewTestChatCfg tmp cfg "cath" cathProfile $ \cath -> do
|
||||
connectUsers alice cath
|
||||
addMember "team" alice cath GRMember
|
||||
cath ##> "/j team"
|
||||
@ -1452,14 +1495,14 @@ testGroupDelayedModerationFullDelete tmp = do
|
||||
cath <## "alice updated group #team:"
|
||||
cath <## "updated group preferences:"
|
||||
cath <## "Full deletion: on"
|
||||
withTestChat tmp "bob" $ \bob -> do
|
||||
withTestChatCfg tmp cfg "bob" $ \bob -> do
|
||||
bob <## "1 contacts connected (use /cs for the list)"
|
||||
bob <## "#team: connected to server(s)"
|
||||
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
|
||||
bob <## "alice updated group #team:"
|
||||
bob <## "updated group preferences:"
|
||||
bob <## "Full deletion: on"
|
||||
withTestChat tmp "cath" $ \cath -> do
|
||||
withTestChatCfg tmp cfg "cath" $ \cath -> do
|
||||
cath <## "2 contacts connected (use /cs for the list)"
|
||||
cath <## "#team: connected to server(s)"
|
||||
cath <## "#team: member bob (Bob) is connected"
|
||||
@ -1472,6 +1515,8 @@ testGroupDelayedModerationFullDelete tmp = do
|
||||
bob ##> "/_get chat #1 count=3"
|
||||
r <- chat <$> getTermLine bob
|
||||
r `shouldMatchList` [(0, "Full deletion: on"), (0, "connected"), (0, "moderated [deleted by alice]")]
|
||||
where
|
||||
cfg = testCfgCreateGroupDirect
|
||||
|
||||
testGroupAsync :: HasCallStack => FilePath -> IO ()
|
||||
testGroupAsync tmp = do
|
||||
@ -2127,7 +2172,7 @@ testGroupLinkMemberRole =
|
||||
|
||||
testGroupLinkLeaveDelete :: HasCallStack => FilePath -> IO ()
|
||||
testGroupLinkLeaveDelete =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
connectUsers alice bob
|
||||
connectUsers cath bob
|
||||
@ -2562,7 +2607,7 @@ testConfigureGroupDeliveryReceipts tmp =
|
||||
receipt bob alice cath "team" "25"
|
||||
noReceipt bob alice cath "club" "26"
|
||||
where
|
||||
cfg = testCfg {showReceipts = True}
|
||||
cfg = mkCfgCreateGroupDirect $ testCfg {showReceipts = True}
|
||||
receipt cc1 cc2 cc3 gName msg = do
|
||||
name1 <- userName cc1
|
||||
cc1 #> ("#" <> gName <> " " <> msg)
|
||||
@ -2582,3 +2627,62 @@ testConfigureGroupDeliveryReceipts tmp =
|
||||
cc2 <# ("#" <> gName <> " " <> name1 <> "> " <> msg)
|
||||
cc3 <# ("#" <> gName <> " " <> name1 <> "> " <> msg)
|
||||
cc1 <// 50000
|
||||
|
||||
testNoGroupDirectConns :: HasCallStack => VersionRange -> VersionRange -> VersionRange -> Bool -> FilePath -> IO ()
|
||||
testNoGroupDirectConns hostVRange mem2VRange mem3VRange noDirectConns tmp =
|
||||
withNewTestChatCfg tmp testCfg {chatVRange = hostVRange} "alice" aliceProfile $ \alice -> do
|
||||
withNewTestChatCfg tmp testCfg {chatVRange = mem2VRange} "bob" bobProfile $ \bob -> do
|
||||
withNewTestChatCfg tmp testCfg {chatVRange = mem3VRange} "cath" cathProfile $ \cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
if noDirectConns
|
||||
then contactsDontExist bob cath
|
||||
else bob <##> cath
|
||||
where
|
||||
contactsDontExist bob cath = do
|
||||
bob ##> "@cath hi"
|
||||
bob <## "no contact cath"
|
||||
cath ##> "@bob hi"
|
||||
cath <## "no contact bob"
|
||||
|
||||
testNoGroupDirectConns4Members :: HasCallStack => VersionRange -> VersionRange -> VersionRange -> VersionRange -> Bool -> Bool -> Bool -> FilePath -> IO ()
|
||||
testNoGroupDirectConns4Members hostVRange mem2VRange mem3VRange mem4VRange noConns23 noConns24 noConns34 tmp =
|
||||
withNewTestChatCfg tmp testCfg {chatVRange = hostVRange} "alice" aliceProfile $ \alice -> do
|
||||
withNewTestChatCfg tmp testCfg {chatVRange = mem2VRange} "bob" bobProfile $ \bob -> do
|
||||
withNewTestChatCfg tmp testCfg {chatVRange = mem3VRange} "cath" cathProfile $ \cath -> do
|
||||
withNewTestChatCfg tmp testCfg {chatVRange = mem4VRange} "dan" danProfile $ \dan -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
connectUsers alice dan
|
||||
addMember "team" alice dan GRMember
|
||||
dan ##> "/j team"
|
||||
concurrentlyN_
|
||||
[ alice <## "#team: dan joined the group",
|
||||
do
|
||||
dan <## "#team: you joined the group"
|
||||
dan
|
||||
<### [ "#team: member bob (Bob) is connected",
|
||||
"#team: member cath (Catherine) is connected"
|
||||
],
|
||||
aliceAddedDan bob,
|
||||
aliceAddedDan cath
|
||||
]
|
||||
if noConns23
|
||||
then contactsDontExist bob cath
|
||||
else bob <##> cath
|
||||
if noConns24
|
||||
then contactsDontExist bob dan
|
||||
else bob <##> dan
|
||||
if noConns34
|
||||
then contactsDontExist cath dan
|
||||
else cath <##> dan
|
||||
where
|
||||
aliceAddedDan :: HasCallStack => TestCC -> IO ()
|
||||
aliceAddedDan cc = do
|
||||
cc <## "#team: alice added dan (Daniel) to the group (connecting...)"
|
||||
cc <## "#team: new member dan is connected"
|
||||
contactsDontExist cc1 cc2 = do
|
||||
name1 <- userName cc1
|
||||
name2 <- userName cc2
|
||||
cc1 ##> ("@" <> name2 <> " hi")
|
||||
cc1 <## ("no contact " <> name2)
|
||||
cc2 ##> ("@" <> name1 <> " hi")
|
||||
cc2 <## ("no contact " <> name1)
|
||||
|
@ -18,7 +18,7 @@ chatProfileTests = do
|
||||
it "update user profile and notify contacts" testUpdateProfile
|
||||
it "update user profile with image" testUpdateProfileImage
|
||||
describe "user contact link" $ do
|
||||
describe "create and connect via contact link" testUserContactLink
|
||||
it "create and connect via contact link" testUserContactLink
|
||||
it "add contact link to profile" testProfileLink
|
||||
it "auto accept contact requests" testUserContactLinkAutoAccept
|
||||
it "deduplicate contact requests" testDeduplicateContactRequests
|
||||
@ -57,7 +57,7 @@ chatProfileTests = do
|
||||
|
||||
testUpdateProfile :: HasCallStack => FilePath -> IO ()
|
||||
testUpdateProfile =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
alice ##> "/p"
|
||||
@ -117,33 +117,35 @@ testUpdateProfileImage =
|
||||
bob <## "use @alice2 <message> to send messages"
|
||||
(bob </)
|
||||
|
||||
testUserContactLink :: SpecWith FilePath
|
||||
testUserContactLink = versionTestMatrix3 $ \alice bob cath -> do
|
||||
alice ##> "/ad"
|
||||
cLink <- getContactLink alice True
|
||||
bob ##> ("/c " <> cLink)
|
||||
alice <#? bob
|
||||
alice @@@ [("<@bob", "")]
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob (Bob): accepting contact request..."
|
||||
concurrently_
|
||||
(bob <## "alice (Alice): contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
threadDelay 100000
|
||||
alice @@@ [("@bob", lastChatFeature)]
|
||||
alice <##> bob
|
||||
testUserContactLink :: HasCallStack => FilePath -> IO ()
|
||||
testUserContactLink =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
alice ##> "/ad"
|
||||
cLink <- getContactLink alice True
|
||||
bob ##> ("/c " <> cLink)
|
||||
alice <#? bob
|
||||
alice @@@ [("<@bob", "")]
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob (Bob): accepting contact request..."
|
||||
concurrently_
|
||||
(bob <## "alice (Alice): contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
threadDelay 100000
|
||||
alice @@@ [("@bob", lastChatFeature)]
|
||||
alice <##> bob
|
||||
|
||||
cath ##> ("/c " <> cLink)
|
||||
alice <#? cath
|
||||
alice @@@ [("<@cath", ""), ("@bob", "hey")]
|
||||
alice ##> "/ac cath"
|
||||
alice <## "cath (Catherine): accepting contact request..."
|
||||
concurrently_
|
||||
(cath <## "alice (Alice): contact is connected")
|
||||
(alice <## "cath (Catherine): contact is connected")
|
||||
threadDelay 100000
|
||||
alice @@@ [("@cath", lastChatFeature), ("@bob", "hey")]
|
||||
alice <##> cath
|
||||
cath ##> ("/c " <> cLink)
|
||||
alice <#? cath
|
||||
alice @@@ [("<@cath", ""), ("@bob", "hey")]
|
||||
alice ##> "/ac cath"
|
||||
alice <## "cath (Catherine): accepting contact request..."
|
||||
concurrently_
|
||||
(cath <## "alice (Alice): contact is connected")
|
||||
(alice <## "cath (Catherine): contact is connected")
|
||||
threadDelay 100000
|
||||
alice @@@ [("@cath", lastChatFeature), ("@bob", "hey")]
|
||||
alice <##> cath
|
||||
|
||||
testProfileLink :: HasCallStack => FilePath -> IO ()
|
||||
testProfileLink =
|
||||
@ -762,192 +764,193 @@ testSetResetSetConnectionIncognito = testChat2 aliceProfile bobProfile $
|
||||
bob `hasContactProfiles` ["bob", T.pack aliceIncognito]
|
||||
|
||||
testJoinGroupIncognito :: HasCallStack => FilePath -> IO ()
|
||||
testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfile $
|
||||
\alice bob cath dan -> do
|
||||
-- non incognito connections
|
||||
connectUsers alice bob
|
||||
connectUsers alice dan
|
||||
connectUsers bob cath
|
||||
connectUsers bob dan
|
||||
connectUsers cath dan
|
||||
-- cath connected incognito to alice
|
||||
alice ##> "/c"
|
||||
inv <- getInvitation alice
|
||||
cath ##> ("/c i " <> inv)
|
||||
cath <## "confirmation sent!"
|
||||
cathIncognito <- getTermLine cath
|
||||
concurrentlyN_
|
||||
[ do
|
||||
cath <## ("alice (Alice): contact is connected, your incognito profile for this contact is " <> cathIncognito)
|
||||
cath <## "use /i alice to print out this incognito profile again",
|
||||
alice <## (cathIncognito <> ": contact is connected")
|
||||
]
|
||||
-- alice creates group
|
||||
alice ##> "/g secret_club"
|
||||
alice <## "group #secret_club is created"
|
||||
alice <## "to add members use /a secret_club <name> or /create link #secret_club"
|
||||
-- alice invites bob
|
||||
alice ##> "/a secret_club bob admin"
|
||||
concurrentlyN_
|
||||
[ alice <## "invitation to join the group #secret_club sent to bob",
|
||||
do
|
||||
bob <## "#secret_club: alice invites you to join the group as admin"
|
||||
bob <## "use /j secret_club to accept"
|
||||
]
|
||||
bob ##> "/j secret_club"
|
||||
concurrently_
|
||||
(alice <## "#secret_club: bob joined the group")
|
||||
(bob <## "#secret_club: you joined the group")
|
||||
-- alice invites cath
|
||||
alice ##> ("/a secret_club " <> cathIncognito <> " admin")
|
||||
concurrentlyN_
|
||||
[ alice <## ("invitation to join the group #secret_club sent to " <> cathIncognito),
|
||||
do
|
||||
cath <## "#secret_club: alice invites you to join the group as admin"
|
||||
cath <## ("use /j secret_club to join incognito as " <> cathIncognito)
|
||||
]
|
||||
-- cath uses the same incognito profile when joining group, cath and bob don't merge contacts
|
||||
cath ##> "/j secret_club"
|
||||
concurrentlyN_
|
||||
[ alice <## ("#secret_club: " <> cathIncognito <> " joined the group"),
|
||||
do
|
||||
cath <## ("#secret_club: you joined the group incognito as " <> cathIncognito)
|
||||
cath <## "#secret_club: member bob_1 (Bob) is connected",
|
||||
do
|
||||
bob <## ("#secret_club: alice added " <> cathIncognito <> " to the group (connecting...)")
|
||||
bob <## ("#secret_club: new member " <> cathIncognito <> " is connected")
|
||||
]
|
||||
-- cath cannot invite to the group because her membership is incognito
|
||||
cath ##> "/a secret_club dan"
|
||||
cath <## "you've connected to this group using an incognito profile - prohibited to invite contacts"
|
||||
-- alice invites dan
|
||||
alice ##> "/a secret_club dan admin"
|
||||
concurrentlyN_
|
||||
[ alice <## "invitation to join the group #secret_club sent to dan",
|
||||
do
|
||||
dan <## "#secret_club: alice invites you to join the group as admin"
|
||||
dan <## "use /j secret_club to accept"
|
||||
]
|
||||
dan ##> "/j secret_club"
|
||||
-- cath and dan don't merge contacts
|
||||
concurrentlyN_
|
||||
[ alice <## "#secret_club: dan joined the group",
|
||||
do
|
||||
dan <## "#secret_club: you joined the group"
|
||||
dan
|
||||
<### [ ConsoleString $ "#secret_club: member " <> cathIncognito <> " is connected",
|
||||
"#secret_club: member bob_1 (Bob) is connected",
|
||||
"contact bob_1 is merged into bob",
|
||||
"use @bob <message> to send messages"
|
||||
],
|
||||
do
|
||||
bob <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
|
||||
bob <## "#secret_club: new member dan_1 is connected"
|
||||
bob <## "contact dan_1 is merged into dan"
|
||||
bob <## "use @dan <message> to send messages",
|
||||
do
|
||||
cath <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
|
||||
cath <## "#secret_club: new member dan_1 is connected"
|
||||
]
|
||||
-- send messages - group is incognito for cath
|
||||
alice #> "#secret_club hello"
|
||||
concurrentlyN_
|
||||
[ bob <# "#secret_club alice> hello",
|
||||
cath ?<# "#secret_club alice> hello",
|
||||
dan <# "#secret_club alice> hello"
|
||||
]
|
||||
bob #> "#secret_club hi there"
|
||||
concurrentlyN_
|
||||
[ alice <# "#secret_club bob> hi there",
|
||||
cath ?<# "#secret_club bob_1> hi there",
|
||||
dan <# "#secret_club bob> hi there"
|
||||
]
|
||||
cath ?#> "#secret_club hey"
|
||||
concurrentlyN_
|
||||
[ alice <# ("#secret_club " <> cathIncognito <> "> hey"),
|
||||
bob <# ("#secret_club " <> cathIncognito <> "> hey"),
|
||||
dan <# ("#secret_club " <> cathIncognito <> "> hey")
|
||||
]
|
||||
dan #> "#secret_club how is it going?"
|
||||
concurrentlyN_
|
||||
[ alice <# "#secret_club dan> how is it going?",
|
||||
bob <# "#secret_club dan> how is it going?",
|
||||
cath ?<# "#secret_club dan_1> how is it going?"
|
||||
]
|
||||
-- cath and bob can send messages via new direct connection, cath is incognito
|
||||
bob #> ("@" <> cathIncognito <> " hi, I'm bob")
|
||||
cath ?<# "bob_1> hi, I'm bob"
|
||||
cath ?#> "@bob_1 hey, I'm incognito"
|
||||
bob <# (cathIncognito <> "> hey, I'm incognito")
|
||||
-- cath and dan can send messages via new direct connection, cath is incognito
|
||||
dan #> ("@" <> cathIncognito <> " hi, I'm dan")
|
||||
cath ?<# "dan_1> hi, I'm dan"
|
||||
cath ?#> "@dan_1 hey, I'm incognito"
|
||||
dan <# (cathIncognito <> "> hey, I'm incognito")
|
||||
-- non incognito connections are separate
|
||||
bob <##> cath
|
||||
dan <##> cath
|
||||
-- list groups
|
||||
cath ##> "/gs"
|
||||
cath <## "i #secret_club (4 members)"
|
||||
-- list group members
|
||||
alice ##> "/ms secret_club"
|
||||
alice
|
||||
<### [ "alice (Alice): owner, you, created group",
|
||||
"bob (Bob): admin, invited, connected",
|
||||
ConsoleString $ cathIncognito <> ": admin, invited, connected",
|
||||
"dan (Daniel): admin, invited, connected"
|
||||
]
|
||||
bob ##> "/ms secret_club"
|
||||
bob
|
||||
<### [ "alice (Alice): owner, host, connected",
|
||||
"bob (Bob): admin, you, connected",
|
||||
ConsoleString $ cathIncognito <> ": admin, connected",
|
||||
"dan (Daniel): admin, connected"
|
||||
]
|
||||
cath ##> "/ms secret_club"
|
||||
cath
|
||||
<### [ "alice (Alice): owner, host, connected",
|
||||
"bob_1 (Bob): admin, connected",
|
||||
ConsoleString $ "i " <> cathIncognito <> ": admin, you, connected",
|
||||
"dan_1 (Daniel): admin, connected"
|
||||
]
|
||||
dan ##> "/ms secret_club"
|
||||
dan
|
||||
<### [ "alice (Alice): owner, host, connected",
|
||||
"bob (Bob): admin, connected",
|
||||
ConsoleString $ cathIncognito <> ": admin, connected",
|
||||
"dan (Daniel): admin, you, connected"
|
||||
]
|
||||
-- remove member
|
||||
bob ##> ("/rm secret_club " <> cathIncognito)
|
||||
concurrentlyN_
|
||||
[ bob <## ("#secret_club: you removed " <> cathIncognito <> " from the group"),
|
||||
alice <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"),
|
||||
dan <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"),
|
||||
do
|
||||
cath <## "#secret_club: bob_1 removed you from the group"
|
||||
cath <## "use /d #secret_club to delete the group"
|
||||
]
|
||||
bob #> "#secret_club hi"
|
||||
concurrentlyN_
|
||||
[ alice <# "#secret_club bob> hi",
|
||||
dan <# "#secret_club bob> hi",
|
||||
(cath </)
|
||||
]
|
||||
alice #> "#secret_club hello"
|
||||
concurrentlyN_
|
||||
[ bob <# "#secret_club alice> hello",
|
||||
dan <# "#secret_club alice> hello",
|
||||
(cath </)
|
||||
]
|
||||
cath ##> "#secret_club hello"
|
||||
cath <## "you are no longer a member of the group"
|
||||
-- cath can still message members directly
|
||||
bob #> ("@" <> cathIncognito <> " I removed you from group")
|
||||
cath ?<# "bob_1> I removed you from group"
|
||||
cath ?#> "@bob_1 ok"
|
||||
bob <# (cathIncognito <> "> ok")
|
||||
testJoinGroupIncognito =
|
||||
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
|
||||
\alice bob cath dan -> do
|
||||
-- non incognito connections
|
||||
connectUsers alice bob
|
||||
connectUsers alice dan
|
||||
connectUsers bob cath
|
||||
connectUsers bob dan
|
||||
connectUsers cath dan
|
||||
-- cath connected incognito to alice
|
||||
alice ##> "/c"
|
||||
inv <- getInvitation alice
|
||||
cath ##> ("/c i " <> inv)
|
||||
cath <## "confirmation sent!"
|
||||
cathIncognito <- getTermLine cath
|
||||
concurrentlyN_
|
||||
[ do
|
||||
cath <## ("alice (Alice): contact is connected, your incognito profile for this contact is " <> cathIncognito)
|
||||
cath <## "use /i alice to print out this incognito profile again",
|
||||
alice <## (cathIncognito <> ": contact is connected")
|
||||
]
|
||||
-- alice creates group
|
||||
alice ##> "/g secret_club"
|
||||
alice <## "group #secret_club is created"
|
||||
alice <## "to add members use /a secret_club <name> or /create link #secret_club"
|
||||
-- alice invites bob
|
||||
alice ##> "/a secret_club bob admin"
|
||||
concurrentlyN_
|
||||
[ alice <## "invitation to join the group #secret_club sent to bob",
|
||||
do
|
||||
bob <## "#secret_club: alice invites you to join the group as admin"
|
||||
bob <## "use /j secret_club to accept"
|
||||
]
|
||||
bob ##> "/j secret_club"
|
||||
concurrently_
|
||||
(alice <## "#secret_club: bob joined the group")
|
||||
(bob <## "#secret_club: you joined the group")
|
||||
-- alice invites cath
|
||||
alice ##> ("/a secret_club " <> cathIncognito <> " admin")
|
||||
concurrentlyN_
|
||||
[ alice <## ("invitation to join the group #secret_club sent to " <> cathIncognito),
|
||||
do
|
||||
cath <## "#secret_club: alice invites you to join the group as admin"
|
||||
cath <## ("use /j secret_club to join incognito as " <> cathIncognito)
|
||||
]
|
||||
-- cath uses the same incognito profile when joining group, cath and bob don't merge contacts
|
||||
cath ##> "/j secret_club"
|
||||
concurrentlyN_
|
||||
[ alice <## ("#secret_club: " <> cathIncognito <> " joined the group"),
|
||||
do
|
||||
cath <## ("#secret_club: you joined the group incognito as " <> cathIncognito)
|
||||
cath <## "#secret_club: member bob_1 (Bob) is connected",
|
||||
do
|
||||
bob <## ("#secret_club: alice added " <> cathIncognito <> " to the group (connecting...)")
|
||||
bob <## ("#secret_club: new member " <> cathIncognito <> " is connected")
|
||||
]
|
||||
-- cath cannot invite to the group because her membership is incognito
|
||||
cath ##> "/a secret_club dan"
|
||||
cath <## "you've connected to this group using an incognito profile - prohibited to invite contacts"
|
||||
-- alice invites dan
|
||||
alice ##> "/a secret_club dan admin"
|
||||
concurrentlyN_
|
||||
[ alice <## "invitation to join the group #secret_club sent to dan",
|
||||
do
|
||||
dan <## "#secret_club: alice invites you to join the group as admin"
|
||||
dan <## "use /j secret_club to accept"
|
||||
]
|
||||
dan ##> "/j secret_club"
|
||||
-- cath and dan don't merge contacts
|
||||
concurrentlyN_
|
||||
[ alice <## "#secret_club: dan joined the group",
|
||||
do
|
||||
dan <## "#secret_club: you joined the group"
|
||||
dan
|
||||
<### [ ConsoleString $ "#secret_club: member " <> cathIncognito <> " is connected",
|
||||
"#secret_club: member bob_1 (Bob) is connected",
|
||||
"contact bob_1 is merged into bob",
|
||||
"use @bob <message> to send messages"
|
||||
],
|
||||
do
|
||||
bob <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
|
||||
bob <## "#secret_club: new member dan_1 is connected"
|
||||
bob <## "contact dan_1 is merged into dan"
|
||||
bob <## "use @dan <message> to send messages",
|
||||
do
|
||||
cath <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
|
||||
cath <## "#secret_club: new member dan_1 is connected"
|
||||
]
|
||||
-- send messages - group is incognito for cath
|
||||
alice #> "#secret_club hello"
|
||||
concurrentlyN_
|
||||
[ bob <# "#secret_club alice> hello",
|
||||
cath ?<# "#secret_club alice> hello",
|
||||
dan <# "#secret_club alice> hello"
|
||||
]
|
||||
bob #> "#secret_club hi there"
|
||||
concurrentlyN_
|
||||
[ alice <# "#secret_club bob> hi there",
|
||||
cath ?<# "#secret_club bob_1> hi there",
|
||||
dan <# "#secret_club bob> hi there"
|
||||
]
|
||||
cath ?#> "#secret_club hey"
|
||||
concurrentlyN_
|
||||
[ alice <# ("#secret_club " <> cathIncognito <> "> hey"),
|
||||
bob <# ("#secret_club " <> cathIncognito <> "> hey"),
|
||||
dan <# ("#secret_club " <> cathIncognito <> "> hey")
|
||||
]
|
||||
dan #> "#secret_club how is it going?"
|
||||
concurrentlyN_
|
||||
[ alice <# "#secret_club dan> how is it going?",
|
||||
bob <# "#secret_club dan> how is it going?",
|
||||
cath ?<# "#secret_club dan_1> how is it going?"
|
||||
]
|
||||
-- cath and bob can send messages via new direct connection, cath is incognito
|
||||
bob #> ("@" <> cathIncognito <> " hi, I'm bob")
|
||||
cath ?<# "bob_1> hi, I'm bob"
|
||||
cath ?#> "@bob_1 hey, I'm incognito"
|
||||
bob <# (cathIncognito <> "> hey, I'm incognito")
|
||||
-- cath and dan can send messages via new direct connection, cath is incognito
|
||||
dan #> ("@" <> cathIncognito <> " hi, I'm dan")
|
||||
cath ?<# "dan_1> hi, I'm dan"
|
||||
cath ?#> "@dan_1 hey, I'm incognito"
|
||||
dan <# (cathIncognito <> "> hey, I'm incognito")
|
||||
-- non incognito connections are separate
|
||||
bob <##> cath
|
||||
dan <##> cath
|
||||
-- list groups
|
||||
cath ##> "/gs"
|
||||
cath <## "i #secret_club (4 members)"
|
||||
-- list group members
|
||||
alice ##> "/ms secret_club"
|
||||
alice
|
||||
<### [ "alice (Alice): owner, you, created group",
|
||||
"bob (Bob): admin, invited, connected",
|
||||
ConsoleString $ cathIncognito <> ": admin, invited, connected",
|
||||
"dan (Daniel): admin, invited, connected"
|
||||
]
|
||||
bob ##> "/ms secret_club"
|
||||
bob
|
||||
<### [ "alice (Alice): owner, host, connected",
|
||||
"bob (Bob): admin, you, connected",
|
||||
ConsoleString $ cathIncognito <> ": admin, connected",
|
||||
"dan (Daniel): admin, connected"
|
||||
]
|
||||
cath ##> "/ms secret_club"
|
||||
cath
|
||||
<### [ "alice (Alice): owner, host, connected",
|
||||
"bob_1 (Bob): admin, connected",
|
||||
ConsoleString $ "i " <> cathIncognito <> ": admin, you, connected",
|
||||
"dan_1 (Daniel): admin, connected"
|
||||
]
|
||||
dan ##> "/ms secret_club"
|
||||
dan
|
||||
<### [ "alice (Alice): owner, host, connected",
|
||||
"bob (Bob): admin, connected",
|
||||
ConsoleString $ cathIncognito <> ": admin, connected",
|
||||
"dan (Daniel): admin, you, connected"
|
||||
]
|
||||
-- remove member
|
||||
bob ##> ("/rm secret_club " <> cathIncognito)
|
||||
concurrentlyN_
|
||||
[ bob <## ("#secret_club: you removed " <> cathIncognito <> " from the group"),
|
||||
alice <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"),
|
||||
dan <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"),
|
||||
do
|
||||
cath <## "#secret_club: bob_1 removed you from the group"
|
||||
cath <## "use /d #secret_club to delete the group"
|
||||
]
|
||||
bob #> "#secret_club hi"
|
||||
concurrentlyN_
|
||||
[ alice <# "#secret_club bob> hi",
|
||||
dan <# "#secret_club bob> hi",
|
||||
(cath </)
|
||||
]
|
||||
alice #> "#secret_club hello"
|
||||
concurrentlyN_
|
||||
[ bob <# "#secret_club alice> hello",
|
||||
dan <# "#secret_club alice> hello",
|
||||
(cath </)
|
||||
]
|
||||
cath ##> "#secret_club hello"
|
||||
cath <## "you are no longer a member of the group"
|
||||
-- cath can still message members directly
|
||||
bob #> ("@" <> cathIncognito <> " I removed you from group")
|
||||
cath ?<# "bob_1> I removed you from group"
|
||||
cath ?#> "@bob_1 ok"
|
||||
bob <# (cathIncognito <> "> ok")
|
||||
|
||||
testCantInviteContactIncognito :: HasCallStack => FilePath -> IO ()
|
||||
testCantInviteContactIncognito = testChat2 aliceProfile bobProfile $
|
||||
@ -1356,54 +1359,55 @@ testAllowFullDeletionGroup =
|
||||
|
||||
testProhibitDirectMessages :: HasCallStack => FilePath -> IO ()
|
||||
testProhibitDirectMessages =
|
||||
testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
alice ##> "/set direct #team off"
|
||||
alice <## "updated group preferences:"
|
||||
alice <## "Direct messages: off"
|
||||
directProhibited bob
|
||||
directProhibited cath
|
||||
threadDelay 1000000
|
||||
-- still can send direct messages to direct contacts
|
||||
alice #> "@bob hello again"
|
||||
bob <# "alice> hello again"
|
||||
alice #> "@cath hello again"
|
||||
cath <# "alice> hello again"
|
||||
bob ##> "@cath hello again"
|
||||
bob <## "direct messages to indirect contact cath are prohibited"
|
||||
(cath </)
|
||||
connectUsers cath dan
|
||||
addMember "team" cath dan GRMember
|
||||
dan ##> "/j #team"
|
||||
concurrentlyN_
|
||||
[ cath <## "#team: dan joined the group",
|
||||
do
|
||||
dan <## "#team: you joined the group"
|
||||
dan
|
||||
<### [ "#team: member alice (Alice) is connected",
|
||||
"#team: member bob (Bob) is connected"
|
||||
],
|
||||
do
|
||||
alice <## "#team: cath added dan (Daniel) to the group (connecting...)"
|
||||
alice <## "#team: new member dan is connected",
|
||||
do
|
||||
bob <## "#team: cath added dan (Daniel) to the group (connecting...)"
|
||||
bob <## "#team: new member dan is connected"
|
||||
]
|
||||
alice ##> "@dan hi"
|
||||
alice <## "direct messages to indirect contact dan are prohibited"
|
||||
bob ##> "@dan hi"
|
||||
bob <## "direct messages to indirect contact dan are prohibited"
|
||||
(dan </)
|
||||
dan ##> "@alice hi"
|
||||
dan <## "direct messages to indirect contact alice are prohibited"
|
||||
dan ##> "@bob hi"
|
||||
dan <## "direct messages to indirect contact bob are prohibited"
|
||||
dan #> "@cath hi"
|
||||
cath <# "dan> hi"
|
||||
cath #> "@dan hi"
|
||||
dan <# "cath> hi"
|
||||
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
|
||||
\alice bob cath dan -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
alice ##> "/set direct #team off"
|
||||
alice <## "updated group preferences:"
|
||||
alice <## "Direct messages: off"
|
||||
directProhibited bob
|
||||
directProhibited cath
|
||||
threadDelay 1000000
|
||||
-- still can send direct messages to direct contacts
|
||||
alice #> "@bob hello again"
|
||||
bob <# "alice> hello again"
|
||||
alice #> "@cath hello again"
|
||||
cath <# "alice> hello again"
|
||||
bob ##> "@cath hello again"
|
||||
bob <## "direct messages to indirect contact cath are prohibited"
|
||||
(cath </)
|
||||
connectUsers cath dan
|
||||
addMember "team" cath dan GRMember
|
||||
dan ##> "/j #team"
|
||||
concurrentlyN_
|
||||
[ cath <## "#team: dan joined the group",
|
||||
do
|
||||
dan <## "#team: you joined the group"
|
||||
dan
|
||||
<### [ "#team: member alice (Alice) is connected",
|
||||
"#team: member bob (Bob) is connected"
|
||||
],
|
||||
do
|
||||
alice <## "#team: cath added dan (Daniel) to the group (connecting...)"
|
||||
alice <## "#team: new member dan is connected",
|
||||
do
|
||||
bob <## "#team: cath added dan (Daniel) to the group (connecting...)"
|
||||
bob <## "#team: new member dan is connected"
|
||||
]
|
||||
alice ##> "@dan hi"
|
||||
alice <## "direct messages to indirect contact dan are prohibited"
|
||||
bob ##> "@dan hi"
|
||||
bob <## "direct messages to indirect contact dan are prohibited"
|
||||
(dan </)
|
||||
dan ##> "@alice hi"
|
||||
dan <## "direct messages to indirect contact alice are prohibited"
|
||||
dan ##> "@bob hi"
|
||||
dan <## "direct messages to indirect contact bob are prohibited"
|
||||
dan #> "@cath hi"
|
||||
cath <# "dan> hi"
|
||||
cath #> "@dan hi"
|
||||
dan <# "cath> hi"
|
||||
where
|
||||
directProhibited :: HasCallStack => TestCC -> IO ()
|
||||
directProhibited cc = do
|
||||
|
@ -67,9 +67,9 @@ versionTestMatrix2 runTest = do
|
||||
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
|
||||
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
|
||||
|
||||
versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
||||
versionTestMatrix3 runTest = do
|
||||
it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
|
||||
-- versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
||||
-- versionTestMatrix3 runTest = do
|
||||
-- it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
|
||||
|
||||
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest
|
||||
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest
|
||||
|
@ -230,16 +230,28 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
||||
#==# XGrpAcpt (MemberId "\1\2\3\4")
|
||||
it "x.grp.mem.new" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
|
||||
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, profile = testProfile}
|
||||
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile}
|
||||
it "x.grp.mem.new with member chat version range" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-2\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
|
||||
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile}
|
||||
it "x.grp.mem.intro" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
|
||||
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, profile = testProfile}
|
||||
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile}
|
||||
it "x.grp.mem.intro with member chat version range" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-2\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
|
||||
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile}
|
||||
it "x.grp.mem.inv" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"directConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}"
|
||||
#==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = testConnReq}
|
||||
#==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq}
|
||||
it "x.grp.mem.inv w/t directConnReq" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"groupConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}"
|
||||
#==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing}
|
||||
it "x.grp.mem.fwd" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"directConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
|
||||
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = testConnReq}
|
||||
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq}
|
||||
it "x.grp.mem.fwd with member chat version range and w/t directConnReq" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-2\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
|
||||
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing}
|
||||
it "x.grp.mem.info" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.mem.info\",\"params\":{\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
|
||||
#==# XGrpMemInfo (MemberId "\1\2\3\4") testProfile
|
||||
|
Loading…
Reference in New Issue
Block a user