mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-06-07 06:42:35 +00:00
core chat groups protocol for adding members (#78)
* add category and local display name to group members, extend member status * additional chat commands, serialization * parse all chat messages * draft group protocol implementation * group protocol: connect new member to existing members (TODO fix race condition with contact connection) * send/receive group messages (race condition still there - the 3rd member cannot send either group or direct messages to the 2nd member - CONN SIMPLEX) * send x.grp.mem.info and x.ok in SMP confirmation * fix host user adding new member, update simplexmq to fix sqlite concurrency, remove logs, make # optional in chat commands * more precise view messages about members joining and connecting * track connection status; only send messages to active members (TODO change to current members); group name autocomplete after joining the group * track via which group the contact was added; show only one message when a contact fully connected; group tests * test sending messages to the new direct contacts created via the group * update simplexmq to include .cabal file * remove unused import
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
94f89ed8f7
commit
189cd7e09d
+123
-83
@@ -29,33 +29,43 @@ import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
|
||||
data ChatDirection (p :: AParty) where
|
||||
ReceivedDirectMessage :: ConnContact -> ChatDirection 'Agent
|
||||
ReceivedDMConnection :: Connection -> ChatDirection 'Agent
|
||||
ReceivedDMContact :: Contact -> ChatDirection 'Agent
|
||||
SentDirectMessage :: Contact -> ChatDirection 'Client
|
||||
ReceivedGroupMessage :: GroupName -> GroupMember -> ChatDirection 'Agent
|
||||
ReceivedGroupMessage :: Connection -> GroupName -> GroupMember -> ChatDirection 'Agent
|
||||
SentGroupMessage :: GroupName -> ChatDirection 'Client
|
||||
|
||||
deriving instance Eq (ChatDirection p)
|
||||
|
||||
deriving instance Show (ChatDirection p)
|
||||
|
||||
data ConnContact = CContact Contact | CConnection Connection
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ChatMsgEvent
|
||||
= XMsgNew
|
||||
{ messageType :: MessageType,
|
||||
files :: [(ContentType, Int)],
|
||||
content :: [MsgBodyContent]
|
||||
}
|
||||
= XMsgNew MsgContent
|
||||
| XInfo Profile
|
||||
| XGrpInv GroupInvitation
|
||||
| XGrpAcpt MemberId
|
||||
| XGrpMemNew MemberId GroupMemberRole Profile
|
||||
| XGrpMemIntro MemberId GroupMemberRole Profile
|
||||
| XGrpMemNew MemberInfo
|
||||
| XGrpMemIntro MemberInfo
|
||||
| XGrpMemInv MemberId IntroInvitation
|
||||
| XGrpMemFwd MemberInfo IntroInvitation
|
||||
| XGrpMemInfo MemberId Profile
|
||||
| XGrpMemCon MemberId
|
||||
| XGrpMemConAll MemberId
|
||||
| XInfoProbe ByteString
|
||||
| XInfoProbeCheck MemberId ByteString
|
||||
| XInfoProbeOk MemberId ByteString
|
||||
| XOk
|
||||
deriving (Eq, Show)
|
||||
|
||||
data MessageType = MTText | MTImage deriving (Eq, Show)
|
||||
|
||||
data MsgContent = MsgContent
|
||||
{ messageType :: MessageType,
|
||||
files :: [(ContentType, Int)],
|
||||
content :: [MsgContentBody]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
toMsgType :: ByteString -> Either String MessageType
|
||||
toMsgType = \case
|
||||
"c.text" -> Right MTText
|
||||
@@ -77,118 +87,148 @@ data ChatMessage = ChatMessage
|
||||
toChatMessage :: RawChatMessage -> Either String ChatMessage
|
||||
toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do
|
||||
(chatDAG, body) <- getDAG <$> mapM toMsgBodyContent chatMsgBody
|
||||
case chatMsgEvent of
|
||||
"x.msg.new" -> case chatMsgParams of
|
||||
mt : rawFiles -> do
|
||||
t <- toMsgType mt
|
||||
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
|
||||
let msg = XMsgNew {messageType = t, files, content = body}
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
[] -> Left "x.msg.new expects at least one parameter"
|
||||
"x.info" -> case chatMsgParams of
|
||||
[] -> do
|
||||
profile <- getJSON body
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = XInfo profile, chatDAG}
|
||||
_ -> Left "x.info expects no parameters"
|
||||
"x.grp.inv" -> case chatMsgParams of
|
||||
[fromMemId, fromRole, memId, role, qInfo] -> do
|
||||
fromMember <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole
|
||||
invitedMember <- (,) <$> B64.decode memId <*> toMemberRole role
|
||||
inv <- GroupInvitation fromMember invitedMember <$> parseAll smpQueueInfoP qInfo <*> getJSON body
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = XGrpInv inv, chatDAG}
|
||||
_ -> Left "x.grp.inv expects 5 parameters"
|
||||
"x.grp.acpt" -> case chatMsgParams of
|
||||
[memId] -> do
|
||||
msg <- XGrpAcpt <$> B64.decode memId
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
_ -> Left "x.grp.acpt expects one parameter"
|
||||
"x.grp.mem.new" -> memberMessage chatMsgParams XGrpMemNew body chatDAG
|
||||
"x.grp.mem.intro" -> memberMessage chatMsgParams XGrpMemIntro body chatDAG
|
||||
_ -> Left $ "unsupported event " <> B.unpack chatMsgEvent
|
||||
let chatMsg msg = pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
case (chatMsgEvent, chatMsgParams) of
|
||||
("x.msg.new", mt : rawFiles) -> do
|
||||
t <- toMsgType mt
|
||||
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
|
||||
chatMsg . XMsgNew $ MsgContent {messageType = t, files, content = body}
|
||||
("x.info", []) -> do
|
||||
profile <- getJSON body
|
||||
chatMsg $ XInfo profile
|
||||
("x.grp.inv", [fromMemId, fromRole, memId, role, qInfo]) -> do
|
||||
fromMem <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole
|
||||
invitedMem <- (,) <$> B64.decode memId <*> toMemberRole role
|
||||
groupQInfo <- parseAll smpQueueInfoP qInfo
|
||||
profile <- getJSON body
|
||||
chatMsg . XGrpInv $ GroupInvitation fromMem invitedMem groupQInfo profile
|
||||
("x.grp.acpt", [memId]) ->
|
||||
chatMsg . XGrpAcpt =<< B64.decode memId
|
||||
("x.grp.mem.new", [memId, role]) -> do
|
||||
chatMsg . XGrpMemNew =<< toMemberInfo memId role body
|
||||
("x.grp.mem.intro", [memId, role]) ->
|
||||
chatMsg . XGrpMemIntro =<< toMemberInfo memId role body
|
||||
("x.grp.mem.inv", [memId, groupQInfo, directQInfo]) ->
|
||||
chatMsg =<< (XGrpMemInv <$> B64.decode memId <*> toIntroInv groupQInfo directQInfo)
|
||||
("x.grp.mem.fwd", [memId, role, groupQInfo, directQInfo]) -> do
|
||||
chatMsg =<< (XGrpMemFwd <$> toMemberInfo memId role body <*> toIntroInv groupQInfo directQInfo)
|
||||
("x.grp.mem.info", [memId]) ->
|
||||
chatMsg =<< (XGrpMemInfo <$> B64.decode memId <*> getJSON body)
|
||||
("x.grp.mem.con", [memId]) ->
|
||||
chatMsg . XGrpMemCon =<< B64.decode memId
|
||||
("x.grp.mem.con.all", [memId]) ->
|
||||
chatMsg . XGrpMemConAll =<< B64.decode memId
|
||||
("x.info.probe", [probe]) -> do
|
||||
chatMsg . XInfoProbe =<< B64.decode probe
|
||||
("x.info.probe.check", [memId, probeHash]) -> do
|
||||
chatMsg =<< (XInfoProbeCheck <$> B64.decode memId <*> B64.decode probeHash)
|
||||
("x.info.probe.ok", [memId, probe]) -> do
|
||||
chatMsg =<< (XInfoProbeOk <$> B64.decode memId <*> B64.decode probe)
|
||||
("x.ok", []) ->
|
||||
chatMsg XOk
|
||||
_ -> Left $ "bad syntax or unsupported event " <> B.unpack chatMsgEvent
|
||||
where
|
||||
getDAG :: [MsgBodyContent] -> (Maybe ByteString, [MsgBodyContent])
|
||||
getDAG :: [MsgContentBody] -> (Maybe ByteString, [MsgContentBody])
|
||||
getDAG body = case break (isContentType SimplexDAG) body of
|
||||
(b, MsgBodyContent SimplexDAG dag : a) -> (Just dag, b <> a)
|
||||
(b, MsgContentBody SimplexDAG dag : a) -> (Just dag, b <> a)
|
||||
_ -> (Nothing, body)
|
||||
memberMessage ::
|
||||
FromJSON a => [ByteString] -> (MemberId -> GroupMemberRole -> a -> ChatMsgEvent) -> [MsgBodyContent] -> Maybe ByteString -> Either String ChatMessage
|
||||
memberMessage [memId, role] mkMsg body chatDAG = do
|
||||
msg <- mkMsg <$> B64.decode memId <*> toMemberRole role <*> getJSON body
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
memberMessage _ _ _ _ = Left "message expects 2 parameters"
|
||||
toMemberInfo :: ByteString -> ByteString -> [MsgContentBody] -> Either String MemberInfo
|
||||
toMemberInfo memId role body = MemberInfo <$> B64.decode memId <*> toMemberRole role <*> getJSON body
|
||||
toIntroInv :: ByteString -> ByteString -> Either String IntroInvitation
|
||||
toIntroInv groupQInfo directQInfo = IntroInvitation <$> parseAll smpQueueInfoP groupQInfo <*> parseAll smpQueueInfoP directQInfo
|
||||
toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int)
|
||||
toContentInfo (rawType, size) = (,size) <$> toContentType rawType
|
||||
getJSON :: FromJSON a => [MsgBodyContent] -> Either String a
|
||||
getJSON :: FromJSON a => [MsgContentBody] -> Either String a
|
||||
getJSON = J.eitherDecodeStrict' <=< getSimplexContentType XCJson
|
||||
|
||||
isContentType :: ContentType -> MsgBodyContent -> Bool
|
||||
isContentType t MsgBodyContent {contentType = t'} = t == t'
|
||||
isContentType :: ContentType -> MsgContentBody -> Bool
|
||||
isContentType t MsgContentBody {contentType = t'} = t == t'
|
||||
|
||||
isSimplexContentType :: XContentType -> MsgBodyContent -> Bool
|
||||
isSimplexContentType :: XContentType -> MsgContentBody -> Bool
|
||||
isSimplexContentType = isContentType . SimplexContentType
|
||||
|
||||
getContentType :: ContentType -> [MsgBodyContent] -> Either String ByteString
|
||||
getContentType :: ContentType -> [MsgContentBody] -> Either String ByteString
|
||||
getContentType t body = case find (isContentType t) body of
|
||||
Just MsgBodyContent {contentData} -> Right contentData
|
||||
Just MsgContentBody {contentData} -> Right contentData
|
||||
Nothing -> Left "no required content type"
|
||||
|
||||
getSimplexContentType :: XContentType -> [MsgBodyContent] -> Either String ByteString
|
||||
getSimplexContentType :: XContentType -> [MsgContentBody] -> Either String ByteString
|
||||
getSimplexContentType = getContentType . SimplexContentType
|
||||
|
||||
rawChatMessage :: ChatMessage -> RawChatMessage
|
||||
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
case chatMsgEvent of
|
||||
XMsgNew {messageType = t, files, content} ->
|
||||
XMsgNew MsgContent {messageType = t, files, content} ->
|
||||
let rawFiles = map (serializeContentInfo . rawContentInfo) files
|
||||
chatMsgParams = rawMsgType t : rawFiles
|
||||
chatMsgBody = rawWithDAG content
|
||||
in RawChatMessage {chatMsgId, chatMsgEvent = "x.msg.new", chatMsgParams, chatMsgBody}
|
||||
in rawMsg "x.msg.new" (rawMsgType t : rawFiles) content
|
||||
XInfo profile ->
|
||||
let chatMsgBody = rawWithDAG [jsonBody profile]
|
||||
in RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody}
|
||||
rawMsg "x.info" [] [jsonBody profile]
|
||||
XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) qInfo groupProfile) ->
|
||||
let chatMsgParams =
|
||||
let params =
|
||||
[ B64.encode fromMemId,
|
||||
serializeMemberRole fromRole,
|
||||
B64.encode memId,
|
||||
serializeMemberRole role,
|
||||
serializeSmpQueueInfo qInfo
|
||||
]
|
||||
chatMsgBody = rawWithDAG [jsonBody groupProfile]
|
||||
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.inv", chatMsgParams, chatMsgBody}
|
||||
in rawMsg "x.grp.inv" params [jsonBody groupProfile]
|
||||
XGrpAcpt memId ->
|
||||
let chatMsgParams = [B64.encode memId]
|
||||
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.acpt", chatMsgParams, chatMsgBody = []}
|
||||
XGrpMemNew memId role profile ->
|
||||
let chatMsgParams = [B64.encode memId, serializeMemberRole role]
|
||||
chatMsgBody = rawWithDAG [jsonBody profile]
|
||||
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.mem.new", chatMsgParams, chatMsgBody}
|
||||
XGrpMemIntro memId role profile ->
|
||||
let chatMsgParams = [B64.encode memId, serializeMemberRole role]
|
||||
chatMsgBody = rawWithDAG [jsonBody profile]
|
||||
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.mem.intro", chatMsgParams, chatMsgBody}
|
||||
rawMsg "x.grp.acpt" [B64.encode memId] []
|
||||
XGrpMemNew (MemberInfo memId role profile) ->
|
||||
let params = [B64.encode memId, serializeMemberRole role]
|
||||
in rawMsg "x.grp.mem.new" params [jsonBody profile]
|
||||
XGrpMemIntro (MemberInfo memId role profile) ->
|
||||
rawMsg "x.grp.mem.intro" [B64.encode memId, serializeMemberRole role] [jsonBody profile]
|
||||
XGrpMemInv memId IntroInvitation {groupQInfo, directQInfo} ->
|
||||
let params = [B64.encode memId, serializeSmpQueueInfo groupQInfo, serializeSmpQueueInfo directQInfo]
|
||||
in rawMsg "x.grp.mem.inv" params []
|
||||
XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupQInfo, directQInfo} ->
|
||||
let params =
|
||||
[ B64.encode memId,
|
||||
serializeMemberRole role,
|
||||
serializeSmpQueueInfo groupQInfo,
|
||||
serializeSmpQueueInfo directQInfo
|
||||
]
|
||||
in rawMsg "x.grp.mem.fwd" params [jsonBody profile]
|
||||
XGrpMemInfo memId profile ->
|
||||
rawMsg "x.grp.mem.info" [B64.encode memId] [jsonBody profile]
|
||||
XGrpMemCon memId ->
|
||||
rawMsg "x.grp.mem.con" [B64.encode memId] []
|
||||
XGrpMemConAll memId ->
|
||||
rawMsg "x.grp.mem.con.all" [B64.encode memId] []
|
||||
XInfoProbe probe ->
|
||||
rawMsg "x.info.probe" [B64.encode probe] []
|
||||
XInfoProbeCheck memId probeHash ->
|
||||
rawMsg "x.info.probe.check" [B64.encode memId, B64.encode probeHash] []
|
||||
XInfoProbeOk memId probe ->
|
||||
rawMsg "x.info.probe.ok" [B64.encode memId, B64.encode probe] []
|
||||
XOk ->
|
||||
rawMsg "x.ok" [] []
|
||||
where
|
||||
rawMsg :: ByteString -> [ByteString] -> [MsgContentBody] -> RawChatMessage
|
||||
rawMsg event chatMsgParams body =
|
||||
RawChatMessage {chatMsgId, chatMsgEvent = event, chatMsgParams, chatMsgBody = rawWithDAG body}
|
||||
rawContentInfo :: (ContentType, Int) -> (RawContentType, Int)
|
||||
rawContentInfo (t, size) = (rawContentType t, size)
|
||||
jsonBody :: ToJSON a => a -> MsgBodyContent
|
||||
jsonBody :: ToJSON a => a -> MsgContentBody
|
||||
jsonBody x =
|
||||
let json = LB.toStrict $ J.encode x
|
||||
in MsgBodyContent {contentType = SimplexContentType XCJson, contentData = json}
|
||||
rawWithDAG :: [MsgBodyContent] -> [RawMsgBodyContent]
|
||||
in MsgContentBody {contentType = SimplexContentType XCJson, contentData = json}
|
||||
rawWithDAG :: [MsgContentBody] -> [RawMsgBodyContent]
|
||||
rawWithDAG body = map rawMsgBodyContent $ case chatDAG of
|
||||
Nothing -> body
|
||||
Just dag -> MsgBodyContent {contentType = SimplexDAG, contentData = dag} : body
|
||||
Just dag -> MsgContentBody {contentType = SimplexDAG, contentData = dag} : body
|
||||
|
||||
toMsgBodyContent :: RawMsgBodyContent -> Either String MsgBodyContent
|
||||
toMsgBodyContent :: RawMsgBodyContent -> Either String MsgContentBody
|
||||
toMsgBodyContent RawMsgBodyContent {contentType, contentData} = do
|
||||
cType <- toContentType contentType
|
||||
pure MsgBodyContent {contentType = cType, contentData}
|
||||
pure MsgContentBody {contentType = cType, contentData}
|
||||
|
||||
rawMsgBodyContent :: MsgBodyContent -> RawMsgBodyContent
|
||||
rawMsgBodyContent MsgBodyContent {contentType = t, contentData} =
|
||||
rawMsgBodyContent :: MsgContentBody -> RawMsgBodyContent
|
||||
rawMsgBodyContent MsgContentBody {contentType = t, contentData} =
|
||||
RawMsgBodyContent {contentType = rawContentType t, contentData}
|
||||
|
||||
data MsgBodyContent = MsgBodyContent
|
||||
data MsgContentBody = MsgContentBody
|
||||
{ contentType :: ContentType,
|
||||
contentData :: ByteString
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user