simplify chat protocol (#74)

* groups protocol and some group commands

* simplify chat message format, refactor types to include parsed message body

* disable chat test
This commit is contained in:
Evgeny Poberezkin 2021-07-11 12:22:22 +01:00 committed by GitHub
parent d21abbdec1
commit 24c62584fc
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 280 additions and 185 deletions

View File

@ -34,14 +34,6 @@ CREATE TABLE known_servers(
UNIQUE (user_id, host, port)
) WITHOUT ROWID;
-- CREATE TABLE contact_invitations (
-- invitation_id INTEGER PRIMARY KEY,
-- agent_inv_id BLOB UNIQUE,
-- invitation TEXT,
-- contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT,
-- invitation_status TEXT NOT NULL DEFAULT ''
-- );
CREATE TABLE group_profiles ( -- shared group profiles
group_profile_id INTEGER PRIMARY KEY,
group_ref TEXT NOT NULL, -- this name must not contain spaces
@ -54,7 +46,6 @@ CREATE TABLE groups (
invited_by INTEGER REFERENCES contacts ON DELETE RESTRICT,
external_group_id BLOB NOT NULL,
local_group_ref TEXT NOT NULL UNIQUE, -- local group name without spaces
local_properties TEXT NOT NULL, -- local JSON group properties
group_profile_id INTEGER REFERENCES group_profiles, -- shared group profile
user_id INTEGER NOT NULL REFERENCES users,
UNIQUE (invited_by, external_group_id)
@ -64,7 +55,7 @@ CREATE TABLE group_members ( -- group members, excluding the local user
group_member_id INTEGER PRIMARY KEY,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE RESTRICT,
member_id BLOB NOT NULL, -- shared member ID, unique per group
member_role TEXT NOT NULL DEFAULT '', -- owner, admin, moderator, ''
member_role TEXT NOT NULL DEFAULT '', -- owner, admin, member
member_status TEXT NOT NULL DEFAULT '', -- inv | con | full | off
invited_by INTEGER REFERENCES contacts (contact_id) ON DELETE RESTRICT, -- NULL for the members who joined before the current user and for the group creator
contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT,

View File

@ -16,6 +16,7 @@ dependencies:
- ansi-terminal == 0.10.*
- attoparsec == 0.13.*
- base >= 4.7 && < 5
- base64-bytestring >= 1.0 && < 1.3
- bytestring == 0.10.*
- containers == 0.6.*
- directory == 1.3.*

View File

@ -15,12 +15,11 @@ import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import qualified Data.Aeson as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List (find)
import Data.Maybe (isJust)
@ -58,6 +57,14 @@ data ChatCommand
| Connect SMPQueueInfo
| DeleteContact ContactRef
| SendMessage ContactRef ByteString
| NewGroup GroupRef
| AddMember GroupRef ContactRef GroupMemberRole
| RemoveMember GroupRef ContactRef
| MemberRole GroupRef ContactRef GroupMemberRole
| LeaveGroup GroupRef
| DeleteGroup GroupRef
| ListMembers GroupRef
| SendGroupMessage GroupRef ByteString
deriving (Show)
cfg :: AgentConfig
@ -142,10 +149,18 @@ processChatCommand User {userId, profile} = \case
showContactDeleted cRef
SendMessage cRef msg -> do
Connection {agentConnId} <- withStore $ \st -> getContactConnection st userId cRef
let body = MsgBodyContent {contentType = SimplexContentType XCText, contentHash = Nothing, contentData = MBFull $ MsgData msg}
rawMsg = rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent = XMsgNew MTText, chatMsgBody = [body], chatDAGIdx = Nothing}
let body = MsgBodyContent {contentType = SimplexContentType XCText, contentData = msg}
rawMsg = rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent = XMsgNew MTText [] [body], chatDAG = Nothing}
void . withAgent $ \smp -> sendMessage smp agentConnId $ serializeRawChatMessage rawMsg
setActive $ ActiveC cRef
NewGroup _gRef -> pure ()
AddMember _gRef _cRef _mRole -> pure ()
MemberRole _gRef _cRef _mRole -> pure ()
RemoveMember _gRef _cRef -> pure ()
LeaveGroup _gRef -> pure ()
DeleteGroup _gRef -> pure ()
ListMembers _gRef -> pure ()
SendGroupMessage _gRef _msg -> pure ()
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
agentSubscriber = do
@ -163,10 +178,10 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do
ReceivedDirectMessage Contact {localContactRef = c} ->
case agentMessage of
MSG meta msgBody -> do
ChatMessage {chatMsgEvent, chatMsgBody} <- liftEither $ parseChatMessage msgBody
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
case chatMsgEvent of
XMsgNew MTText -> newTextMessage c meta $ find (isSimplexContentType XCText) chatMsgBody
XInfo -> pure () -- TODO profile update
XMsgNew MTText [] body -> newTextMessage c meta $ find (isSimplexContentType XCText) body
XInfo _ -> pure () -- TODO profile update
_ -> pure ()
CON -> do
-- TODO update connection status
@ -191,7 +206,7 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do
where
newTextMessage :: ContactRef -> MsgMeta -> Maybe MsgBodyContent -> m ()
newTextMessage c meta = \case
Just MsgBodyContent {contentData = MBFull (MsgData bs)} -> do
Just MsgBodyContent {contentData = bs} -> do
let text = safeDecodeUtf8 bs
showReceivedMessage c (snd $ broker meta) text (integrity meta)
showToast ("@" <> c) text
@ -203,21 +218,15 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do
saveConnInfo :: Connection -> ConnInfo -> m ()
saveConnInfo activeConn connInfo = do
ChatMessage {chatMsgEvent, chatMsgBody} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
case chatMsgEvent of
XInfo ->
case find (isSimplexContentType XCJson) chatMsgBody of
Just MsgBodyContent {contentData = MBFull (MsgData bs)} -> do
p <- liftEither . first (ChatErrorContact . CEProfile) $ J.eitherDecodeStrict' bs
withStore $ \st -> createDirectContact st userId activeConn p
_ -> pure () -- TODO show/log error?
XInfo p ->
withStore $ \st -> createDirectContact st userId activeConn p
_ -> pure () -- TODO show/log error, other events in SMP confirmation
encodeProfile :: Profile -> ByteString
encodeProfile profile =
let json = LB.toStrict $ J.encode profile
body = MsgBodyContent {contentType = SimplexContentType XCJson, contentHash = Nothing, contentData = MBFull $ MsgData json}
chatMsg = ChatMessage {chatMsgId = Nothing, chatMsgEvent = XInfo, chatMsgBody = [body], chatDAGIdx = Nothing}
let chatMsg = ChatMessage {chatMsgId = Nothing, chatMsgEvent = XInfo profile, chatDAG = Nothing}
in serializeRawChatMessage $ rawChatMessage chatMsg
getCreateActiveUser :: SQLiteStore -> IO User
@ -314,10 +323,23 @@ withStore action = do
chatCommandP :: Parser ChatCommand
chatCommandP =
("/help" <|> "/h") $> ChatHelp
<|> ("/group #" <|> "/g #") *> (NewGroup <$> groupRef)
<|> ("/add #" <|> "/a #") *> (AddMember <$> groupRef <* A.space <*> contactRef <* A.space <*> memberRole)
<|> ("/remove #" <|> "/rm #") *> (RemoveMember <$> groupRef <* A.space <*> contactRef)
<|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> groupRef)
<|> ("/members #" <|> "/ms #") *> (ListMembers <$> groupRef)
<|> A.char '#' *> (SendGroupMessage <$> groupRef <* A.space <*> A.takeByteString)
<|> ("/add" <|> "/a") $> AddContact
<|> ("/connect " <|> "/c ") *> (Connect <$> smpQueueInfoP)
<|> ("/delete " <|> "/d ") *> (DeleteContact <$> contactRef)
<|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> contactRef)
<|> A.char '@' *> (SendMessage <$> contactRef <*> (A.space *> A.takeByteString))
<|> ("/markdown" <|> "/m") $> MarkdownHelp
where
contactRef = safeDecodeUtf8 <$> A.takeTill (== ' ')
contactRef = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' '))
refChar c = c > ' ' && c /= '#' && c /= '@'
groupRef = contactRef
memberRole =
("owner" $> GROwner)
<|> ("admin" $> GRAdmin)
<|> ("normal" $> GRMember)
<?> "memberRole"

View File

@ -6,21 +6,27 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Chat.Protocol where
import Control.Applicative (optional, (<|>))
import Control.Applicative (optional)
import Control.Monad ((<=<))
import Control.Monad.Except (throwError)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Data.List (findIndex)
import Data.List (find)
import Data.Text (Text)
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Parsers (base64P)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (bshow)
data ChatDirection (p :: AParty) where
@ -34,12 +40,34 @@ deriving instance Eq (ChatDirection p)
deriving instance Show (ChatDirection p)
data ChatMsgEvent
= XMsgNew MessageType
| XInfo
= XMsgNew {messageType :: MessageType, files :: [(ContentType, Int)], content :: [MsgBodyContent]}
| XInfo Profile
| XGrpInv InvitationId MemberId GroupMemberRole GroupProfile
| XGrpAcpt InvitationId SMPQueueInfo
| XGrpMemNew MemberId GroupMemberRole Profile
| XGrpMemIntro MemberId GroupMemberRole Profile
deriving (Eq, Show)
type MemberId = ByteString
data MessageType = MTText | MTImage deriving (Eq, Show)
data GroupMemberRole = GROwner | GRAdmin | GRMember
deriving (Eq, Show)
toMemberRole :: ByteString -> Either String GroupMemberRole
toMemberRole = \case
"owner" -> Right GROwner
"admin" -> Right GRAdmin
"member" -> Right GRMember
r -> Left $ "invalid group member role " <> B.unpack r
serializeMemberRole :: GroupMemberRole -> ByteString
serializeMemberRole = \case
GROwner -> "owner"
GRAdmin -> "admin"
GRMember -> "member"
toMsgType :: ByteString -> Either String MessageType
toMsgType = \case
"c.text" -> Right MTText
@ -54,29 +82,59 @@ rawMsgType = \case
data ChatMessage = ChatMessage
{ chatMsgId :: Maybe Int64,
chatMsgEvent :: ChatMsgEvent,
chatMsgBody :: [MsgBodyContent],
chatDAGIdx :: Maybe Int
chatDAG :: Maybe ByteString
}
deriving (Eq, Show)
toChatMessage :: RawChatMessage -> Either String ChatMessage
toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do
body <- mapM toMsgBodyContent chatMsgBody
let chatDAGIdx = findDAG body
(chatDAG, body) <- getDAG <$> mapM toMsgBodyContent chatMsgBody
case chatMsgEvent of
"x.msg.new" -> case chatMsgParams of
[mt] -> do
mt : rawFiles -> do
t <- toMsgType mt
pure ChatMessage {chatMsgId, chatMsgEvent = XMsgNew t, chatMsgBody = body, chatDAGIdx}
_ -> throwError "x.msg.new expects one parameter"
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
let msg = XMsgNew {messageType = t, files, content = body}
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
[] -> throwError "x.msg.new expects at least one parameter"
"x.info" -> case chatMsgParams of
[] -> pure ChatMessage {chatMsgId, chatMsgEvent = XInfo, chatMsgBody = body, chatDAGIdx}
[] -> do
profile <- getJSON body
pure ChatMessage {chatMsgId, chatMsgEvent = XInfo profile, chatDAG}
_ -> throwError "x.info expects no parameters"
"x.grp.inv" -> case chatMsgParams of
[invId', memId', role'] -> do
invId <- B64.decode invId'
memId <- B64.decode memId'
role <- toMemberRole role'
groupProfile <- getJSON body
pure ChatMessage {chatMsgId, chatMsgEvent = XGrpInv invId memId role groupProfile, chatDAG}
_ -> throwError "x.grp.inv expects 3 parameters"
"x.grp.acpt" -> case chatMsgParams of
[invId, qInfo] -> do
msg <- XGrpAcpt <$> B64.decode invId <*> parseAll smpQueueInfoP qInfo
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
_ -> throwError "x.grp.acpt expects 2 parameters"
"x.grp.mem.new" -> case chatMsgParams of
[memId, role] -> do
msg <- XGrpMemNew <$> B64.decode memId <*> toMemberRole role <*> getJSON body
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
_ -> throwError "x.grp.acpt expects 2 parameters"
"x.grp.mem.intro" -> case chatMsgParams of
[memId, role] -> do
msg <- XGrpMemIntro <$> B64.decode memId <*> toMemberRole role <*> getJSON body
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
_ -> throwError "x.grp.acpt expects 2 parameters"
_ -> throwError $ "unsupported event " <> B.unpack chatMsgEvent
toChatMessage _ = Left "message continuation"
findDAG :: [MsgBodyContent] -> Maybe Int
findDAG = findIndex $ isContentType SimplexDAG
where
getDAG :: [MsgBodyContent] -> (Maybe ByteString, [MsgBodyContent])
getDAG body = case break (isContentType SimplexDAG) body of
(b, MsgBodyContent SimplexDAG dag : a) -> (Just dag, b <> a)
_ -> (Nothing, body)
toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int)
toContentInfo (rawType, size) = (,size) <$> toContentType rawType
getJSON :: FromJSON a => [MsgBodyContent] -> Either String a
getJSON = J.eitherDecodeStrict' <=< getSimplexContentType XCJson
isContentType :: ContentType -> MsgBodyContent -> Bool
isContentType t MsgBodyContent {contentType = t'} = t == t'
@ -84,27 +142,64 @@ isContentType t MsgBodyContent {contentType = t'} = t == t'
isSimplexContentType :: XContentType -> MsgBodyContent -> Bool
isSimplexContentType = isContentType . SimplexContentType
getContentType :: ContentType -> [MsgBodyContent] -> Either String ByteString
getContentType t body = case find (isContentType t) body of
Just MsgBodyContent {contentData} -> Right contentData
Nothing -> Left "no required content type"
getSimplexContentType :: XContentType -> [MsgBodyContent] -> Either String ByteString
getSimplexContentType = getContentType . SimplexContentType
rawChatMessage :: ChatMessage -> RawChatMessage
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent = event, chatMsgBody = body} =
case event of
XMsgNew t -> RawChatMessage {chatMsgId, chatMsgEvent = "x.msg.new", chatMsgParams = [rawMsgType t], chatMsgBody}
XInfo -> RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody}
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
case chatMsgEvent of
XMsgNew {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}
XInfo profile ->
let chatMsgBody = rawWithDAG [jsonBody profile]
in RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody}
XGrpInv invId memId role groupProfile ->
let chatMsgParams = [B64.encode invId, B64.encode memId, serializeMemberRole role]
chatMsgBody = rawWithDAG [jsonBody groupProfile]
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.inv", chatMsgParams, chatMsgBody}
XGrpAcpt invId qInfo ->
let chatMsgParams = [B64.encode invId, serializeSmpQueueInfo qInfo]
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}
where
chatMsgBody = map rawMsgBodyContent body
rawContentInfo :: (ContentType, Int) -> (RawContentType, Int)
rawContentInfo (t, size) = (rawContentType t, size)
jsonBody :: ToJSON a => a -> MsgBodyContent
jsonBody x =
let json = LB.toStrict $ J.encode x
in MsgBodyContent {contentType = SimplexContentType XCJson, contentData = json}
rawWithDAG :: [MsgBodyContent] -> [RawMsgBodyContent]
rawWithDAG body = map rawMsgBodyContent $ case chatDAG of
Nothing -> body
Just dag -> MsgBodyContent {contentType = SimplexDAG, contentData = dag} : body
toMsgBodyContent :: RawMsgBodyContent -> Either String MsgBodyContent
toMsgBodyContent RawMsgBodyContent {contentType, contentHash, contentData} = do
toMsgBodyContent RawMsgBodyContent {contentType, contentData} = do
cType <- toContentType contentType
pure MsgBodyContent {contentType = cType, contentHash, contentData}
pure MsgBodyContent {contentType = cType, contentData}
rawMsgBodyContent :: MsgBodyContent -> RawMsgBodyContent
rawMsgBodyContent MsgBodyContent {contentType = t, contentHash, contentData} =
RawMsgBodyContent {contentType = rawContentType t, contentHash, contentData}
rawMsgBodyContent MsgBodyContent {contentType = t, contentData} =
RawMsgBodyContent {contentType = rawContentType t, contentData}
data MsgBodyContent = MsgBodyContent
{ contentType :: ContentType,
contentHash :: Maybe ByteString,
contentData :: MsgBodyPartData
contentData :: ByteString
}
deriving (Eq, Show)
@ -149,24 +244,17 @@ newtype ContentMsg = NewContentMsg ContentData
newtype ContentData = ContentText Text
data RawChatMessage
= RawChatMessage
{ chatMsgId :: Maybe Int64,
chatMsgEvent :: ByteString,
chatMsgParams :: [ByteString],
chatMsgBody :: [RawMsgBodyContent]
}
| RawChatMsgContinuation
{ prevChatMsgId :: Int64,
continuationId :: Int,
continuationData :: ByteString
}
data RawChatMessage = RawChatMessage
{ chatMsgId :: Maybe Int64,
chatMsgEvent :: ByteString,
chatMsgParams :: [ByteString],
chatMsgBody :: [RawMsgBodyContent]
}
deriving (Eq, Show)
data RawMsgBodyContent = RawMsgBodyContent
{ contentType :: RawContentType,
contentHash :: Maybe ByteString,
contentData :: MsgBodyPartData
contentData :: ByteString
}
deriving (Eq, Show)
@ -175,82 +263,51 @@ data RawContentType = RawContentType NameSpace ByteString
type NameSpace = ByteString
data MsgBodyPartData
= -- | fully loaded
MBFull MsgData
| -- | partially loaded
MBPartial Int MsgData
| -- | not loaded yet
MBEmpty Int
deriving (Eq, Show)
data MsgData
= MsgData ByteString
| MsgDataRec {dataId :: Int64, dataSize :: Int}
newtype MsgData = MsgData ByteString
deriving (Eq, Show)
class DataLength a where
dataLength :: a -> Int
instance DataLength MsgBodyPartData where
dataLength (MBFull d) = dataLength d
dataLength (MBPartial l _) = l
dataLength (MBEmpty l) = l
instance DataLength MsgData where
dataLength (MsgData s) = B.length s
dataLength MsgDataRec {dataSize} = dataSize
rawChatMessageP :: Parser RawChatMessage
rawChatMessageP = A.char '#' *> chatMsgContP <|> chatMsgP
rawChatMessageP = do
chatMsgId <- optional A.decimal <* A.space
chatMsgEvent <- B.intercalate "." <$> identifierP `A.sepBy1'` A.char '.' <* A.space
chatMsgParams <- A.takeWhile1 (not . A.inClass ", ") `A.sepBy'` A.char ',' <* A.space
chatMsgBody <- msgBodyContent =<< contentInfoP `A.sepBy'` A.char ',' <* A.space
pure RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody}
where
chatMsgContP :: Parser RawChatMessage
chatMsgContP = do
prevChatMsgId <- A.decimal <* A.char '.'
continuationId <- A.decimal <* A.space
continuationData <- A.takeByteString
pure RawChatMsgContinuation {prevChatMsgId, continuationId, continuationData}
chatMsgP :: Parser RawChatMessage
chatMsgP = do
chatMsgId <- optional A.decimal <* A.space
chatMsgEvent <- B.intercalate "." <$> identifier `A.sepBy1'` A.char '.' <* A.space
chatMsgParams <- A.takeWhile1 (not . A.inClass ", ") `A.sepBy'` A.char ',' <* A.space
chatMsgBody <- msgBodyContent =<< contentInfo `A.sepBy'` A.char ',' <* A.space
pure RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody}
identifier :: Parser ByteString
identifier = B.cons <$> A.letter_ascii <*> A.takeWhile (\c -> A.isAlpha_ascii c || A.isDigit c)
contentInfo :: Parser RawMsgBodyContent
contentInfo = do
contentType <- RawContentType <$> identifier <* A.char '.' <*> A.takeTill (A.inClass ":, ")
contentSize <- A.char ':' *> A.decimal
contentHash <- optional (A.char ':' *> base64P)
pure RawMsgBodyContent {contentType, contentHash, contentData = MBEmpty contentSize}
msgBodyContent :: [RawMsgBodyContent] -> Parser [RawMsgBodyContent]
msgBodyContent :: [(RawContentType, Int)] -> Parser [RawMsgBodyContent]
msgBodyContent [] = pure []
msgBodyContent (p@RawMsgBodyContent {contentData = MBEmpty size} : ps) = do
s <- A.take size <* A.space <|> A.takeByteString
if B.length s == size
then ((p {contentData = MBFull $ MsgData s} :: RawMsgBodyContent) :) <$> msgBodyContent ps
else pure $ (if B.null s then p else p {contentData = MBPartial size $ MsgData s} :: RawMsgBodyContent) : ps
msgBodyContent _ = fail "expected contentData = MBEmpty"
msgBodyContent ((contentType, size) : ps) = do
contentData <- A.take size <* A.space
((RawMsgBodyContent {contentType, contentData}) :) <$> msgBodyContent ps
contentInfoP :: Parser (RawContentType, Int)
contentInfoP = do
contentType <- RawContentType <$> identifierP <* A.char '.' <*> A.takeTill (A.inClass ":, ")
size <- A.char ':' *> A.decimal
pure (contentType, size)
identifierP :: Parser ByteString
identifierP = B.cons <$> A.letter_ascii <*> A.takeWhile (\c -> A.isAlpha_ascii c || A.isDigit c)
serializeRawChatMessage :: RawChatMessage -> ByteString
serializeRawChatMessage = \case
RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} ->
B.unwords
[ maybe "" bshow chatMsgId,
chatMsgEvent,
B.intercalate "," chatMsgParams,
B.unwords $ map serializeContentInfo chatMsgBody,
B.unwords $ map serializeContentData chatMsgBody
]
RawChatMsgContinuation {prevChatMsgId, continuationId, continuationData} ->
bshow prevChatMsgId <> "." <> bshow continuationId <> " " <> continuationData
serializeRawChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} =
B.unwords
[ maybe "" bshow chatMsgId,
chatMsgEvent,
B.intercalate "," chatMsgParams,
B.unwords $ map serializeBodyContentInfo chatMsgBody,
B.unwords $ map msgContentData chatMsgBody
]
serializeContentInfo :: RawMsgBodyContent -> ByteString
serializeContentInfo RawMsgBodyContent {contentType = RawContentType ns cType, contentHash, contentData} =
ns <> "." <> cType <> ":" <> bshow (dataLength contentData) <> maybe "" (":" <>) contentHash
serializeBodyContentInfo :: RawMsgBodyContent -> ByteString
serializeBodyContentInfo RawMsgBodyContent {contentType = t, contentData} =
serializeContentInfo (t, B.length contentData)
serializeContentData :: RawMsgBodyContent -> ByteString
serializeContentData RawMsgBodyContent {contentData = MBFull (MsgData s)} = s
serializeContentData _ = ""
serializeContentInfo :: (RawContentType, Int) -> ByteString
serializeContentInfo (RawContentType ns cType, size) = ns <> "." <> cType <> ":" <> bshow size
msgContentData :: RawMsgBodyContent -> ByteString
msgContentData RawMsgBodyContent {contentData} = contentData <> " "

View File

@ -38,6 +38,8 @@ data Contact
type ContactRef = Text
type GroupRef = Text
data Group = Group
{ groupId :: Int64,
localGroupRef :: Text
@ -54,6 +56,16 @@ instance ToJSON Profile where toEncoding = J.genericToEncoding J.defaultOptions
instance FromJSON Profile
data GroupProfile = GroupProfile
{ groupRef :: GroupRef,
displayName :: Text
}
deriving (Generic, Eq, Show)
instance ToJSON GroupProfile where toEncoding = J.genericToEncoding J.defaultOptions
instance FromJSON GroupProfile
data Connection = Connection
{ connId :: Int64,
agentConnId :: ConnId,

View File

@ -2,17 +2,17 @@
## Design constraints
- the transport message has a fixed size (8 or 16kb)
- the chat message can have multiple parts/attachments
- the chat message including attachments can be of any size
- if the message is partially received, it should be possible to parse and display the received parts
- the transport message has a fixed size (8 or 16kb), but the SMP agent will be updated to support sending messages up to maximum configured size (TBC - 64-256kb) in 8-16Kb blocks.
- the chat message can have multiple content parts, but it should fit the agent message of the variable size.
- one of the chat message types should support transmitting large binaries in chunks that could potentially be interleaved with other messages. For example, image preview would fit the message, but the full size image will be transmitted in chunks later - same for large files.
- using object storage can be effective for large groups, but we will postpone it until content channels are implemented.
## Questions
- should content types be:
- limited to MIME-types
- separate content types vocabulary
- both MIME types and extensions
- both MIME types and extensions (currently we support MIME (m.) and Simplex (x.) namespaces)
- allow additional content types namespaces
## Message syntax
@ -20,8 +20,7 @@
The syntax of the message inside agent MSG:
```abnf
agentMessageBody = message / msgContinuation
message = [chatMsgId] SP msgEvent SP [parameters] SP [contentParts [SP msgBodyParts]]
agentMessageBody = [chatMsgId] SP msgEvent SP [parameters] SP [contentParts [SP msgBodyParts]]
chatMsgId = 1*DIGIT ; used to refer to previous message;
; in the group should only be used in messages sent to all members,
; which is the main reason not to use external agent ID -
@ -43,28 +42,52 @@ msgEventParent = memberId refMsgId refMsgHash
memberId = 8*8(OCTET) ; shared member ID
refMsgId = 8*8(OCTET) ; sequential message number - external agent message ID
refMsgHash = 16*16(OCTET) ; SHA256 of agent message body
msgContinuation = "#" prevMsgId "." continuationId continuationData
```
### Example: messages, updates, groups
```
"3 x.msg.new c.text c.text:5 hello "
"3 x.msg.new c.text x.text:5 hello "
"4 x.msg.new c.image i.image/jpg:256,i.image/png:4096 abcd abcd "
"4 x.msg.new c.image x.dag:32,i.image/jpg:8000:hash1,i.image/png:16000:hash2 binary1"
"#4.1 binary1end binary2"
"#4.2 binary2continued"
"#4.3 binary2end "
"5 x.msg.new c.image i.image/jpg:256,i.image/url:160 abcd https://media.example.com/asdf#abcd "
'6 x.msg.update 3 c.text:11,x.dag:16 hello there abcd '
'7 x.msg.delete 3'
'8 x.msg.new app/v1 i.text/html:NNN,i.text/css:NNN,c.js:NNN,c.json:NNN ... ... ... {...} '
'9 x.msg.eval 8 c.json:NNN {...} '
'10 x.msg.new c.text 2 c.text:16,x.dag:32 hello there @123 abcd '
' x.grp.mem.inv 23456,123 1 c.json NNN {...} '
' x.grp.mem.acpt 23456 1 c.text NNN <invitation> '
' x.grp.mem.intro 23456,234 1 c.json NNN {...} '
' x.grp.mem.inv 23456,234 1 c.text NNN <invitation> '
' x.grp.mem.req 23456,123 1 c.json NNN {...} '
' x.grp.mem.direct.inv 23456,234 1 text NNN <invitation> '
"4 x.msg.new c.image x.dag:32,i.image/jpg:8000,i.image/png:16000 binary1"
"5 x.msg.new c.image,i.image/jpg:150000 i.image/jpg:256 abcd "
"6 x.msg.file 5,1.1 x.file:60000 abcd "
"7 x.msg.file 5,1.2 x.file:60000 abcd "
"8 x.msg.file 5,1.3 x.file:30000 abcd "
'8 x.msg.update 3 x.text:11,x.dag:16 hello there abcd '
'9 x.msg.delete 3'
'10 x.msg.new app/v1 i.text/html:NNN,i.text/css:NNN,c.js:NNN,c.json:NNN ... ... ... {...} '
'11 x.msg.eval 8 c.json:NNN {...} '
'12 x.msg.new c.text x.text:16,x.dag:32 hello there @123 abcd '
' x.grp.mem.inv 23456,123 x.json:NNN {...} '
' x.grp.mem.acpt 23456 x.text:NNN <invitation> '
' x.grp.mem.intro 23456,234 x.json:NNN {...} '
' x.grp.mem.inv 23456,234 x.text:NNN <invitation> '
' x.grp.mem.req 23456,123 x.json:NNN {...} '
' x.grp.mem.direct.inv 23456,234 x.text:NNN <invitation> '
```
### Group protocol
A -> B: invite to group - `MSG: x.grp.inv G_INV_ID,G_MEM_ID_B,G_MEM_ROLE x.json:NNN <group_profile>`
user B confirms
B -> A: join group - `MSG: x.grp.acpt G_INV_ID,<invitation>`
A -> Bg: establish group connection (A: JOIN, B: LET)
A -> group (including B)): announce group member: `MSG: N x.grp.mem.new G_MEM_ID_B,G_MEM_ROLE x.json:NNN <B_profile>`
subsequent messages between A and B are via group connection
A -> Bg: intro member - `MSG: x.grp.mem.intro G_MEM_ID_M,G_MEM_ROLE x.json:NNN <M_profile>`
B -> Ag: inv for mem - `MSG: x.grp.mem.inv G_MEM_ID_M,<gr_invitation>,<dm_invitation>,<probe>`
M is an existing member, messages are via group connection
A -> Mg: fwd inv - `MSG: x.grp.mem.fwd G_MEM_ID_B,<gr_invitation>,<dm_invitation>,<probe>`
M -> Bg: establish group connection (M: JOIN, B: LET)
M -> B: establish direct connection (M: JOIN, B: LET)
M -> Bg: confirm profile and role - `MSG: x.grp.mem.info G_MEM_ID_M,G_MEM_ROLE x.json:NNN <M_profile>`
if M is a known contact (profile match) send probe to M:
B -> M (via old DM conn): profile match probe: `MSG: x.grp.mem.probe G_MEM_ID_B,<probe_hash>`
M -> B (via old DM conn): probe confirm: `MSG: x.grp.mem.probe.ok G_MEM_ID_M,<probe>`
link to the same contact
B -> Ag: connected to M: `MSG: x.grp.mem.con G_MEM_ID_M`
M -> Ag: connected to M: `MSG: x.grp.mem.con G_MEM_ID_B`
once all members connected
A -> group: `MSG: N x.grp.mem.ok G_MEM_ID_B`

View File

@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module ChatTests where

View File

@ -21,37 +21,27 @@ parseChatMessageTest = describe "Raw chat message format" $ do
"5 x.grp.mem.leave " #== RawChatMessage (Just 5) "x.grp.mem.leave" [] []
it "one parameter, no content" $
"6 x.msg.del 3 " #== RawChatMessage (Just 6) "x.msg.del" ["3"] []
it "with content that fits the message and optional trailing space" $
"7 x.msg.new c.text c.text:11 hello there "
it "with content that fits the message" $
"7 x.msg.new c.text x.text:11 hello there "
#== RawChatMessage
(Just 7)
"x.msg.new"
["c.text"]
[RawMsgBodyContent (RawContentType "c" "text") Nothing $ MBFull (MsgData "hello there")]
it "with content that fits the message, without trailing space" $
"7 x.msg.new c.text c.text:11 hello there"
#== RawChatMessage
(Just 7)
"x.msg.new"
["c.text"]
[RawMsgBodyContent (RawContentType "c" "text") Nothing $ MBFull (MsgData "hello there")]
[RawMsgBodyContent (RawContentType "x" "text") "hello there"]
it "with DAG reference and partial content" $
"8 x.msg.new c.image x.dag:16,c.text:7,m.image/jpg:64:MDEyMzQ1Njc=,m.image/png:4000:MDEyMzQ1Njc= 0123456789012345 picture abcdef"
"8 x.msg.new c.image x.dag:16,x.text:7,m.image/jpg:6 0123456789012345 picture abcdef "
#== RawChatMessage
(Just 8)
"x.msg.new"
["c.image"]
[ RawMsgBodyContent (RawContentType "x" "dag") Nothing $ MBFull (MsgData "0123456789012345"),
RawMsgBodyContent (RawContentType "c" "text") Nothing $ MBFull (MsgData "picture"),
RawMsgBodyContent (RawContentType "m" "image/jpg") (Just "01234567") $ MBPartial 64 (MsgData "abcdef"),
RawMsgBodyContent (RawContentType "m" "image/png") (Just "01234567") $ MBEmpty 4000
[ RawMsgBodyContent (RawContentType "x" "dag") "0123456789012345",
RawMsgBodyContent (RawContentType "x" "text") "picture",
RawMsgBodyContent (RawContentType "m" "image/jpg") "abcdef"
]
it "message continuation" $
"#8.1 abcdef" #== RawChatMsgContinuation 8 1 "abcdef"
it "without message id" $
" x.grp.mem.inv 23456,123 c.json:46 {\"contactRef\":\"john\",\"displayName\":\"John Doe\"}"
" x.grp.mem.inv 23456,123 x.json:46 {\"contactRef\":\"john\",\"displayName\":\"John Doe\"} "
#== RawChatMessage
Nothing
"x.grp.mem.inv"
["23456", "123"]
[RawMsgBodyContent (RawContentType "c" "json") Nothing $ MBFull (MsgData "{\"contactRef\":\"john\",\"displayName\":\"John Doe\"}")]
[RawMsgBodyContent (RawContentType "x" "json") "{\"contactRef\":\"john\",\"displayName\":\"John Doe\"}"]