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:
parent
d21abbdec1
commit
24c62584fc
@ -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,
|
||||
|
@ -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.*
|
||||
|
@ -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"
|
||||
|
@ -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 <> " "
|
||||
|
@ -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,
|
||||
|
@ -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`
|
||||
|
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChatTests where
|
||||
|
@ -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\"}"]
|
||||
|
Loading…
Reference in New Issue
Block a user