mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-28 07:14:40 +00:00
update chat protocol to use JSON encoding for chat messages (#182)
* started chat protocol * text message example * events json * same style comments * jsonc * num for rendering * try to fix comment rendering * revert num * chat protocol: make msg params closer to types * AppMessage type * combine new and old simplexmq dependencies * json parsers * version-compatible types for connection requests * more parsers * remove import * decode/encode from/to AppMessage * make group invitation a property in params * switch chat to the new agent * remove "compatibility" attempt * new JSON encoding for chat messages * simplexmq from github * update MsgContent name Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
44845ad563
commit
be537f3a24
+228
-371
@@ -1,35 +1,32 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Chat.Protocol where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Monad ((<=<), (>=>))
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Control.Monad ((<=<))
|
||||
import Data.Aeson (FromJSON, ToJSON, (.:), (.=))
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Aeson.Types as JT
|
||||
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 (find, findIndex)
|
||||
import qualified Data.HashMap.Strict as H
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import GHC.Generics
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
data ChatDirection (p :: AParty) where
|
||||
ReceivedDirectMessage :: Connection -> Maybe Contact -> ChatDirection 'Agent
|
||||
@@ -52,6 +49,23 @@ fromConnection = \case
|
||||
RcvFileConnection conn _ -> conn
|
||||
UserContactConnection conn _ -> conn
|
||||
|
||||
-- chat message is sent as JSON with these properties
|
||||
data AppMessage = AppMessage
|
||||
{ event :: Text,
|
||||
params :: J.Object
|
||||
}
|
||||
deriving (Generic, FromJSON)
|
||||
|
||||
instance ToJSON AppMessage where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
newtype ChatMessage = ChatMessage {chatMsgEvent :: ChatMsgEvent}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding ChatMessage where
|
||||
strEncode = LB.toStrict . J.encode . chatToAppMessage
|
||||
strDecode = appToChatMessage <=< J.eitherDecodeStrict'
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
|
||||
data ChatMsgEvent
|
||||
= XMsgNew MsgContent
|
||||
| XFile FileInvitation
|
||||
@@ -70,372 +84,215 @@ data ChatMsgEvent
|
||||
| XGrpMemDel MemberId
|
||||
| XGrpLeave
|
||||
| XGrpDel
|
||||
| XInfoProbe ByteString
|
||||
| XInfoProbeCheck ByteString
|
||||
| XInfoProbeOk ByteString
|
||||
| XInfoProbe Probe
|
||||
| XInfoProbeCheck ProbeHash
|
||||
| XInfoProbeOk Probe
|
||||
| XOk
|
||||
deriving (Eq, Show)
|
||||
|
||||
data MessageType = MTText | MTImage deriving (Eq, Show)
|
||||
data MsgContentType = MCText_ | MCUnknown_
|
||||
|
||||
data MsgContent = MsgContent
|
||||
{ messageType :: MessageType,
|
||||
files :: [(ContentType, Int)],
|
||||
content :: [MsgContentBody]
|
||||
}
|
||||
instance StrEncoding MsgContentType where
|
||||
strEncode = \case
|
||||
MCText_ -> "text"
|
||||
MCUnknown_ -> "text"
|
||||
strDecode = \case
|
||||
"text" -> Right MCText_
|
||||
_ -> Right MCUnknown_
|
||||
strP = strDecode <$?> A.takeTill (== ' ')
|
||||
|
||||
instance FromJSON MsgContentType where
|
||||
parseJSON = strParseJSON "MsgContentType"
|
||||
|
||||
instance ToJSON MsgContentType where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data MsgContent = MCText Text | MCUnknown
|
||||
deriving (Eq, Show)
|
||||
|
||||
toMsgType :: ByteString -> Either String MessageType
|
||||
toMsgType = \case
|
||||
"c.text" -> Right MTText
|
||||
"c.image" -> Right MTImage
|
||||
t -> Left $ "invalid message type " <> B.unpack t
|
||||
toMsgContentType :: MsgContent -> MsgContentType
|
||||
toMsgContentType = \case
|
||||
MCText _ -> MCText_
|
||||
MCUnknown -> MCUnknown_
|
||||
|
||||
rawMsgType :: MessageType -> ByteString
|
||||
rawMsgType = \case
|
||||
MTText -> "c.text"
|
||||
MTImage -> "c.image"
|
||||
instance FromJSON MsgContent where
|
||||
parseJSON (J.Object v) = do
|
||||
v .: "type" >>= \case
|
||||
MCText_ -> MCText <$> v .: "text"
|
||||
MCUnknown_ -> pure MCUnknown
|
||||
parseJSON invalid =
|
||||
JT.prependFailure "bad MsgContent, " (JT.typeMismatch "Object" invalid)
|
||||
|
||||
data ChatMessage = ChatMessage
|
||||
{ chatMsgId :: Maybe Int64,
|
||||
chatMsgEvent :: ChatMsgEvent,
|
||||
chatDAG :: Maybe ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
unknownMsgType :: Text
|
||||
unknownMsgType = "unknown message type"
|
||||
|
||||
toChatEventType :: ChatMsgEvent -> Text
|
||||
toChatEventType = \case
|
||||
XMsgNew _ -> "x.msg.new"
|
||||
XFile _ -> "x.file"
|
||||
XFileAcpt _ -> "x.file.acpt"
|
||||
XInfo _ -> "x.info"
|
||||
XContact _ _ -> "x.con"
|
||||
XGrpInv _ -> "x.grp.inv"
|
||||
XGrpAcpt _ -> "x.grp.acpt"
|
||||
XGrpMemNew _ -> "x.grp.mem.new"
|
||||
XGrpMemIntro _ -> "x.grp.mem.intro"
|
||||
XGrpMemInv _ _ -> "x.grp.mem.inv"
|
||||
XGrpMemFwd _ _ -> "x.grp.mem.fwd"
|
||||
XGrpMemInfo _ _ -> "x.grp.mem.info"
|
||||
XGrpMemCon _ -> "x.grp.mem.con"
|
||||
XGrpMemConAll _ -> "x.grp.mem.con.all"
|
||||
XGrpMemDel _ -> "x.grp.mem.del"
|
||||
XGrpLeave -> "x.grp.leave"
|
||||
XGrpDel -> "x.grp.del"
|
||||
XInfoProbe _ -> "x.info.probe"
|
||||
XInfoProbeCheck _ -> "x.info.probe.check"
|
||||
XInfoProbeOk _ -> "x.info.probe.ok"
|
||||
XOk -> "x.ok"
|
||||
instance ToJSON MsgContent where
|
||||
toJSON mc =
|
||||
J.object $
|
||||
("type" .= toMsgContentType mc) : case mc of
|
||||
MCText t -> ["text" .= t]
|
||||
MCUnknown -> ["text" .= unknownMsgType]
|
||||
toEncoding mc =
|
||||
J.pairs $
|
||||
("type" .= toMsgContentType mc) <> case mc of
|
||||
MCText t -> "text" .= t
|
||||
MCUnknown -> "text" .= unknownMsgType
|
||||
|
||||
toChatMessage :: RawChatMessage -> Either String ChatMessage
|
||||
toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do
|
||||
(chatDAG, body) <- getDAG <$> mapM toMsgBodyContent chatMsgBody
|
||||
let chatMsg msg = pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
case (chatMsgEvent, chatMsgParams) of
|
||||
("x.msg.new", mt : rawFiles) -> do
|
||||
t <- toMsgType mt
|
||||
files <- toFiles rawFiles
|
||||
chatMsg . XMsgNew $ MsgContent {messageType = t, files, content = body}
|
||||
("x.file", [name, size, cReq]) -> do
|
||||
let fileName = T.unpack $ safeDecodeUtf8 name
|
||||
fileSize <- parseAll A.decimal size
|
||||
fileConnReq <- parseAll connReqP' cReq
|
||||
chatMsg . XFile $ FileInvitation {fileName, fileSize, fileConnReq}
|
||||
("x.file.acpt", [name]) ->
|
||||
chatMsg . XFileAcpt . T.unpack $ safeDecodeUtf8 name
|
||||
("x.info", []) -> do
|
||||
profile <- getJSON body
|
||||
chatMsg $ XInfo profile
|
||||
("x.con", []) -> do
|
||||
profile <- getJSON body
|
||||
chatMsg $ XContact profile Nothing
|
||||
("x.con", mt : rawFiles) -> do
|
||||
(profile, body') <- extractJSON body
|
||||
t <- toMsgType mt
|
||||
files <- toFiles rawFiles
|
||||
chatMsg . XContact profile $ Just MsgContent {messageType = t, files, content = body'}
|
||||
("x.grp.inv", [fromMemId, fromRole, memId, role, cReq]) -> do
|
||||
fromMem <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole
|
||||
invitedMem <- (,) <$> B64.decode memId <*> toMemberRole role
|
||||
groupConnReq <- parseAll connReqP' cReq
|
||||
profile <- getJSON body
|
||||
chatMsg . XGrpInv $ GroupInvitation fromMem invitedMem groupConnReq 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, groupConnReq, directConnReq]) ->
|
||||
chatMsg =<< (XGrpMemInv <$> B64.decode memId <*> toIntroInv groupConnReq directConnReq)
|
||||
("x.grp.mem.fwd", [memId, role, groupConnReq, directConnReq]) -> do
|
||||
chatMsg =<< (XGrpMemFwd <$> toMemberInfo memId role body <*> toIntroInv groupConnReq directConnReq)
|
||||
("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.grp.mem.del", [memId]) ->
|
||||
chatMsg . XGrpMemDel =<< B64.decode memId
|
||||
("x.grp.leave", []) ->
|
||||
chatMsg XGrpLeave
|
||||
("x.grp.del", []) ->
|
||||
chatMsg XGrpDel
|
||||
("x.info.probe", [probe]) -> do
|
||||
chatMsg . XInfoProbe =<< B64.decode probe
|
||||
("x.info.probe.check", [probeHash]) -> do
|
||||
chatMsg . XInfoProbeCheck =<< B64.decode probeHash
|
||||
("x.info.probe.ok", [probe]) -> do
|
||||
chatMsg . XInfoProbeOk =<< B64.decode probe
|
||||
("x.ok", []) ->
|
||||
chatMsg XOk
|
||||
_ -> Left $ "bad syntax or unsupported event " <> B.unpack chatMsgEvent
|
||||
data CMEventTag
|
||||
= XMsgNew_
|
||||
| XFile_
|
||||
| XFileAcpt_
|
||||
| XInfo_
|
||||
| XContact_
|
||||
| XGrpInv_
|
||||
| XGrpAcpt_
|
||||
| XGrpMemNew_
|
||||
| XGrpMemIntro_
|
||||
| XGrpMemInv_
|
||||
| XGrpMemFwd_
|
||||
| XGrpMemInfo_
|
||||
| XGrpMemCon_
|
||||
| XGrpMemConAll_
|
||||
| XGrpMemDel_
|
||||
| XGrpLeave_
|
||||
| XGrpDel_
|
||||
| XInfoProbe_
|
||||
| XInfoProbeCheck_
|
||||
| XInfoProbeOk_
|
||||
| XOk_
|
||||
|
||||
instance StrEncoding CMEventTag where
|
||||
strEncode = \case
|
||||
XMsgNew_ -> "x.msg.new"
|
||||
XFile_ -> "x.file"
|
||||
XFileAcpt_ -> "x.file.acpt"
|
||||
XInfo_ -> "x.info"
|
||||
XContact_ -> "x.contact"
|
||||
XGrpInv_ -> "x.grp.inv"
|
||||
XGrpAcpt_ -> "x.grp.acpt"
|
||||
XGrpMemNew_ -> "x.grp.mem.new"
|
||||
XGrpMemIntro_ -> "x.grp.mem.intro"
|
||||
XGrpMemInv_ -> "x.grp.mem.inv"
|
||||
XGrpMemFwd_ -> "x.grp.mem.fwd"
|
||||
XGrpMemInfo_ -> "x.grp.mem.info"
|
||||
XGrpMemCon_ -> "x.grp.mem.con"
|
||||
XGrpMemConAll_ -> "x.grp.mem.con.all"
|
||||
XGrpMemDel_ -> "x.grp.mem.del"
|
||||
XGrpLeave_ -> "x.grp.leave"
|
||||
XGrpDel_ -> "x.grp.del"
|
||||
XInfoProbe_ -> "x.info.probe"
|
||||
XInfoProbeCheck_ -> "x.info.probe.check"
|
||||
XInfoProbeOk_ -> "x.info.probe.ok"
|
||||
XOk_ -> "x.ok"
|
||||
strDecode = \case
|
||||
"x.msg.new" -> Right XMsgNew_
|
||||
"x.file" -> Right XFile_
|
||||
"x.file.acpt" -> Right XFileAcpt_
|
||||
"x.info" -> Right XInfo_
|
||||
"x.contact" -> Right XContact_
|
||||
"x.grp.inv" -> Right XGrpInv_
|
||||
"x.grp.acpt" -> Right XGrpAcpt_
|
||||
"x.grp.mem.new" -> Right XGrpMemNew_
|
||||
"x.grp.mem.intro" -> Right XGrpMemIntro_
|
||||
"x.grp.mem.inv" -> Right XGrpMemInv_
|
||||
"x.grp.mem.fwd" -> Right XGrpMemFwd_
|
||||
"x.grp.mem.info" -> Right XGrpMemInfo_
|
||||
"x.grp.mem.con" -> Right XGrpMemCon_
|
||||
"x.grp.mem.con.all" -> Right XGrpMemConAll_
|
||||
"x.grp.mem.del" -> Right XGrpMemDel_
|
||||
"x.grp.leave" -> Right XGrpLeave_
|
||||
"x.grp.del" -> Right XGrpDel_
|
||||
"x.info.probe" -> Right XInfoProbe_
|
||||
"x.info.probe.check" -> Right XInfoProbeCheck_
|
||||
"x.info.probe.ok" -> Right XInfoProbeOk_
|
||||
"x.ok" -> Right XOk_
|
||||
_ -> Left "bad CMEventTag"
|
||||
strP = strDecode <$?> A.takeTill (== ' ')
|
||||
|
||||
toCMEventTag :: ChatMsgEvent -> CMEventTag
|
||||
toCMEventTag = \case
|
||||
XMsgNew _ -> XMsgNew_
|
||||
XFile _ -> XFile_
|
||||
XFileAcpt _ -> XFileAcpt_
|
||||
XInfo _ -> XInfo_
|
||||
XContact _ _ -> XContact_
|
||||
XGrpInv _ -> XGrpInv_
|
||||
XGrpAcpt _ -> XGrpAcpt_
|
||||
XGrpMemNew _ -> XGrpMemNew_
|
||||
XGrpMemIntro _ -> XGrpMemIntro_
|
||||
XGrpMemInv _ _ -> XGrpMemInv_
|
||||
XGrpMemFwd _ _ -> XGrpMemFwd_
|
||||
XGrpMemInfo _ _ -> XGrpMemInfo_
|
||||
XGrpMemCon _ -> XGrpMemCon_
|
||||
XGrpMemConAll _ -> XGrpMemConAll_
|
||||
XGrpMemDel _ -> XGrpMemDel_
|
||||
XGrpLeave -> XGrpLeave_
|
||||
XGrpDel -> XGrpDel_
|
||||
XInfoProbe _ -> XInfoProbe_
|
||||
XInfoProbeCheck _ -> XInfoProbeCheck_
|
||||
XInfoProbeOk _ -> XInfoProbeOk_
|
||||
XOk -> XOk_
|
||||
|
||||
toChatEventTag :: ChatMsgEvent -> Text
|
||||
toChatEventTag = decodeLatin1 . strEncode . toCMEventTag
|
||||
|
||||
appToChatMessage :: AppMessage -> Either String ChatMessage
|
||||
appToChatMessage AppMessage {event, params} = do
|
||||
eventTag <- strDecode $ encodeUtf8 event
|
||||
chatMsgEvent <- msg eventTag
|
||||
pure ChatMessage {chatMsgEvent}
|
||||
where
|
||||
getDAG :: [MsgContentBody] -> (Maybe ByteString, [MsgContentBody])
|
||||
getDAG body = case break (isContentType SimplexDAG) body of
|
||||
(b, MsgContentBody SimplexDAG dag : a) -> (Just dag, b <> a)
|
||||
_ -> (Nothing, body)
|
||||
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 groupConnReq directConnReq = IntroInvitation <$> parseAll connReqP' groupConnReq <*> parseAll connReqP' directConnReq
|
||||
toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int)
|
||||
toContentInfo (rawType, size) = (,size) <$> toContentType rawType
|
||||
toFiles :: [ByteString] -> Either String [(ContentType, Int)]
|
||||
toFiles = mapM $ toContentInfo <=< parseAll contentInfoP
|
||||
getJSON :: FromJSON a => [MsgContentBody] -> Either String a
|
||||
getJSON = J.eitherDecodeStrict' <=< getSimplexContentType XCJson
|
||||
extractJSON :: FromJSON a => [MsgContentBody] -> Either String (a, [MsgContentBody])
|
||||
extractJSON =
|
||||
extractSimplexContentType XCJson >=> \(a, bs) -> do
|
||||
j <- J.eitherDecodeStrict' a
|
||||
pure (j, bs)
|
||||
p :: FromJSON a => Text -> Either String a
|
||||
p key = JT.parseEither (.: key) params
|
||||
msg = \case
|
||||
XMsgNew_ -> XMsgNew <$> p "content"
|
||||
XFile_ -> XFile <$> p "file"
|
||||
XFileAcpt_ -> XFileAcpt <$> p "fileName"
|
||||
XInfo_ -> XInfo <$> p "profile"
|
||||
XContact_ -> XContact <$> p "profile" <*> p "content"
|
||||
XGrpInv_ -> XGrpInv <$> p "groupInvitation"
|
||||
XGrpAcpt_ -> XGrpAcpt <$> p "memberId"
|
||||
XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo"
|
||||
XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo"
|
||||
XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro"
|
||||
XGrpMemFwd_ -> XGrpMemFwd <$> p "memberInfo" <*> p "memberIntro"
|
||||
XGrpMemInfo_ -> XGrpMemInfo <$> p "memberId" <*> p "profile"
|
||||
XGrpMemCon_ -> XGrpMemCon <$> p "memberId"
|
||||
XGrpMemConAll_ -> XGrpMemConAll <$> p "memberId"
|
||||
XGrpMemDel_ -> XGrpMemDel <$> p "memberId"
|
||||
XGrpLeave_ -> pure XGrpLeave
|
||||
XGrpDel_ -> pure XGrpDel
|
||||
XInfoProbe_ -> XInfoProbe <$> p "probe"
|
||||
XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
|
||||
XInfoProbeOk_ -> XInfoProbeOk <$> p "probe"
|
||||
XOk_ -> pure XOk
|
||||
|
||||
isContentType :: ContentType -> MsgContentBody -> Bool
|
||||
isContentType t MsgContentBody {contentType = t'} = t == t'
|
||||
|
||||
isSimplexContentType :: XContentType -> MsgContentBody -> Bool
|
||||
isSimplexContentType = isContentType . SimplexContentType
|
||||
|
||||
getContentType :: ContentType -> [MsgContentBody] -> Either String ByteString
|
||||
getContentType t body = case find (isContentType t) body of
|
||||
Just MsgContentBody {contentData} -> Right contentData
|
||||
Nothing -> Left "no required content type"
|
||||
|
||||
extractContentType :: ContentType -> [MsgContentBody] -> Either String (ByteString, [MsgContentBody])
|
||||
extractContentType t body = case findIndex (isContentType t) body of
|
||||
Just i -> case splitAt i body of
|
||||
(b, el : a) -> Right (contentData (el :: MsgContentBody), b ++ a)
|
||||
(_, []) -> Left "no required content type" -- this can only happen if findIndex returns incorrect result
|
||||
Nothing -> Left "no required content type"
|
||||
|
||||
getSimplexContentType :: XContentType -> [MsgContentBody] -> Either String ByteString
|
||||
getSimplexContentType = getContentType . SimplexContentType
|
||||
|
||||
extractSimplexContentType :: XContentType -> [MsgContentBody] -> Either String (ByteString, [MsgContentBody])
|
||||
extractSimplexContentType = extractContentType . SimplexContentType
|
||||
|
||||
rawChatMessage :: ChatMessage -> RawChatMessage
|
||||
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
case chatMsgEvent of
|
||||
XMsgNew MsgContent {messageType = t, files, content} ->
|
||||
rawMsg (rawMsgType t : toRawFiles files) content
|
||||
XFile FileInvitation {fileName, fileSize, fileConnReq} ->
|
||||
rawMsg [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeConnReq' fileConnReq] []
|
||||
XFileAcpt fileName ->
|
||||
rawMsg [encodeUtf8 $ T.pack fileName] []
|
||||
XInfo profile ->
|
||||
rawMsg [] [jsonBody profile]
|
||||
XContact profile Nothing ->
|
||||
rawMsg [] [jsonBody profile]
|
||||
XContact profile (Just MsgContent {messageType = t, files, content}) ->
|
||||
rawMsg (rawMsgType t : toRawFiles files) (jsonBody profile : content)
|
||||
XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) cReq groupProfile) ->
|
||||
let params =
|
||||
[ B64.encode fromMemId,
|
||||
serializeMemberRole fromRole,
|
||||
B64.encode memId,
|
||||
serializeMemberRole role,
|
||||
serializeConnReq' cReq
|
||||
]
|
||||
in rawMsg params [jsonBody groupProfile]
|
||||
XGrpAcpt memId ->
|
||||
rawMsg [B64.encode memId] []
|
||||
XGrpMemNew (MemberInfo memId role profile) ->
|
||||
let params = [B64.encode memId, serializeMemberRole role]
|
||||
in rawMsg params [jsonBody profile]
|
||||
XGrpMemIntro (MemberInfo memId role profile) ->
|
||||
rawMsg [B64.encode memId, serializeMemberRole role] [jsonBody profile]
|
||||
XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} ->
|
||||
let params = [B64.encode memId, serializeConnReq' groupConnReq, serializeConnReq' directConnReq]
|
||||
in rawMsg params []
|
||||
XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupConnReq, directConnReq} ->
|
||||
let params =
|
||||
[ B64.encode memId,
|
||||
serializeMemberRole role,
|
||||
serializeConnReq' groupConnReq,
|
||||
serializeConnReq' directConnReq
|
||||
]
|
||||
in rawMsg params [jsonBody profile]
|
||||
XGrpMemInfo memId profile ->
|
||||
rawMsg [B64.encode memId] [jsonBody profile]
|
||||
XGrpMemCon memId ->
|
||||
rawMsg [B64.encode memId] []
|
||||
XGrpMemConAll memId ->
|
||||
rawMsg [B64.encode memId] []
|
||||
XGrpMemDel memId ->
|
||||
rawMsg [B64.encode memId] []
|
||||
XGrpLeave ->
|
||||
rawMsg [] []
|
||||
XGrpDel ->
|
||||
rawMsg [] []
|
||||
XInfoProbe probe ->
|
||||
rawMsg [B64.encode probe] []
|
||||
XInfoProbeCheck probeHash ->
|
||||
rawMsg [B64.encode probeHash] []
|
||||
XInfoProbeOk probe ->
|
||||
rawMsg [B64.encode probe] []
|
||||
XOk ->
|
||||
rawMsg [] []
|
||||
chatToAppMessage :: ChatMessage -> AppMessage
|
||||
chatToAppMessage ChatMessage {chatMsgEvent} = AppMessage {event, params}
|
||||
where
|
||||
rawMsg :: [ByteString] -> [MsgContentBody] -> RawChatMessage
|
||||
rawMsg chatMsgParams body = do
|
||||
let event = encodeUtf8 $ toChatEventType chatMsgEvent
|
||||
RawChatMessage {chatMsgId, chatMsgEvent = event, chatMsgParams, chatMsgBody = rawWithDAG body}
|
||||
rawContentInfo :: (ContentType, Int) -> (RawContentType, Int)
|
||||
rawContentInfo (t, size) = (rawContentType t, size)
|
||||
jsonBody :: ToJSON a => a -> MsgContentBody
|
||||
jsonBody x =
|
||||
let json = LB.toStrict $ J.encode x
|
||||
in MsgContentBody {contentType = SimplexContentType XCJson, contentData = json}
|
||||
rawWithDAG :: [MsgContentBody] -> [RawMsgBodyContent]
|
||||
rawWithDAG body = map rawMsgBodyContent $ case chatDAG of
|
||||
Nothing -> body
|
||||
Just dag -> MsgContentBody {contentType = SimplexDAG, contentData = dag} : body
|
||||
toRawFiles :: [(ContentType, Int)] -> [ByteString]
|
||||
toRawFiles = map $ serializeContentInfo . rawContentInfo
|
||||
|
||||
toMsgBodyContent :: RawMsgBodyContent -> Either String MsgContentBody
|
||||
toMsgBodyContent RawMsgBodyContent {contentType, contentData} = do
|
||||
cType <- toContentType contentType
|
||||
pure MsgContentBody {contentType = cType, contentData}
|
||||
|
||||
rawMsgBodyContent :: MsgContentBody -> RawMsgBodyContent
|
||||
rawMsgBodyContent MsgContentBody {contentType = t, contentData} =
|
||||
RawMsgBodyContent {contentType = rawContentType t, contentData}
|
||||
|
||||
data MsgContentBody = MsgContentBody
|
||||
{ contentType :: ContentType,
|
||||
contentData :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ContentType
|
||||
= SimplexContentType XContentType
|
||||
| MimeContentType MContentType
|
||||
| SimplexDAG
|
||||
deriving (Eq, Show)
|
||||
|
||||
data XContentType = XCText | XCImage | XCJson deriving (Eq, Show)
|
||||
|
||||
data MContentType = MCImageJPG | MCImagePNG deriving (Eq, Show)
|
||||
|
||||
toContentType :: RawContentType -> Either String ContentType
|
||||
toContentType (RawContentType ns cType) = case ns of
|
||||
"x" -> case cType of
|
||||
"text" -> Right $ SimplexContentType XCText
|
||||
"image" -> Right $ SimplexContentType XCImage
|
||||
"json" -> Right $ SimplexContentType XCJson
|
||||
"dag" -> Right SimplexDAG
|
||||
_ -> err
|
||||
"m" -> case cType of
|
||||
"image/jpg" -> Right $ MimeContentType MCImageJPG
|
||||
"image/png" -> Right $ MimeContentType MCImagePNG
|
||||
_ -> err
|
||||
_ -> err
|
||||
where
|
||||
err = Left . B.unpack $ "invalid content type " <> ns <> "." <> cType
|
||||
|
||||
rawContentType :: ContentType -> RawContentType
|
||||
rawContentType t = case t of
|
||||
SimplexContentType t' -> RawContentType "x" $ case t' of
|
||||
XCText -> "text"
|
||||
XCImage -> "image"
|
||||
XCJson -> "json"
|
||||
MimeContentType t' -> RawContentType "m" $ case t' of
|
||||
MCImageJPG -> "image/jpg"
|
||||
MCImagePNG -> "image/png"
|
||||
SimplexDAG -> RawContentType "x" "dag"
|
||||
|
||||
newtype ContentMsg = NewContentMsg ContentData
|
||||
|
||||
newtype ContentData = ContentText Text
|
||||
|
||||
data RawChatMessage = RawChatMessage
|
||||
{ chatMsgId :: Maybe Int64,
|
||||
chatMsgEvent :: ByteString,
|
||||
chatMsgParams :: [ByteString],
|
||||
chatMsgBody :: [RawMsgBodyContent]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RawMsgBodyContent = RawMsgBodyContent
|
||||
{ contentType :: RawContentType,
|
||||
contentData :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RawContentType = RawContentType NameSpace ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
type NameSpace = ByteString
|
||||
|
||||
newtype MsgData = MsgData ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
class DataLength a where
|
||||
dataLength :: a -> Int
|
||||
|
||||
rawChatMessageP :: Parser RawChatMessage
|
||||
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
|
||||
msgBodyContent :: [(RawContentType, Int)] -> Parser [RawMsgBodyContent]
|
||||
msgBodyContent [] = pure []
|
||||
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 RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} =
|
||||
B.unwords
|
||||
[ maybe "" bshow chatMsgId,
|
||||
chatMsgEvent,
|
||||
B.intercalate "," chatMsgParams,
|
||||
B.unwords $ map serializeBodyContentInfo chatMsgBody,
|
||||
B.unwords $ map msgContentData chatMsgBody
|
||||
]
|
||||
|
||||
serializeBodyContentInfo :: RawMsgBodyContent -> ByteString
|
||||
serializeBodyContentInfo RawMsgBodyContent {contentType = t, contentData} =
|
||||
serializeContentInfo (t, B.length contentData)
|
||||
|
||||
serializeContentInfo :: (RawContentType, Int) -> ByteString
|
||||
serializeContentInfo (RawContentType ns cType, size) = ns <> "." <> cType <> ":" <> bshow size
|
||||
|
||||
msgContentData :: RawMsgBodyContent -> ByteString
|
||||
msgContentData RawMsgBodyContent {contentData} = contentData <> " "
|
||||
event = toChatEventTag chatMsgEvent
|
||||
o :: [(Text, J.Value)] -> J.Object
|
||||
o = H.fromList
|
||||
params = case chatMsgEvent of
|
||||
XMsgNew content -> o ["content" .= content]
|
||||
XFile fileInv -> o ["file" .= fileInv]
|
||||
XFileAcpt fileName -> o ["fileName" .= fileName]
|
||||
XInfo profile -> o ["profile" .= profile]
|
||||
XContact profile content -> o ["profile" .= profile, "content" .= content]
|
||||
XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
|
||||
XGrpAcpt memId -> o ["memberId" .= memId]
|
||||
XGrpMemNew memInfo -> o ["memberInfo" .= memInfo]
|
||||
XGrpMemIntro memInfo -> o ["memberInfo" .= memInfo]
|
||||
XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro]
|
||||
XGrpMemFwd memInfo memIntro -> o ["memberInfo" .= memInfo, "memberIntro" .= memIntro]
|
||||
XGrpMemInfo memId profile -> o ["memberId" .= memId, "profile" .= profile]
|
||||
XGrpMemCon memId -> o ["memberId" .= memId]
|
||||
XGrpMemConAll memId -> o ["memberId" .= memId]
|
||||
XGrpMemDel memId -> o ["memberId" .= memId]
|
||||
XGrpLeave -> H.empty
|
||||
XGrpDel -> H.empty
|
||||
XInfoProbe probe -> o ["probe" .= probe]
|
||||
XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
|
||||
XInfoProbeOk probe -> o ["probe" .= probe]
|
||||
XOk -> H.empty
|
||||
|
||||
Reference in New Issue
Block a user