mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
Merge branch 'master' into remote-desktop
This commit is contained in:
Evgeny Poberezkin
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -19,7 +20,7 @@ module Simplex.Chat.Protocol where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad ((<=<))
|
||||
import Data.Aeson (FromJSON, ToJSON, (.:), (.:?), (.=))
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
import qualified Data.Aeson.KeyMap as JM
|
||||
@@ -51,7 +52,7 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
import Simplex.Messaging.Version hiding (version)
|
||||
|
||||
currentChatVersion :: Version
|
||||
currentChatVersion = 3
|
||||
currentChatVersion = 4
|
||||
|
||||
supportedChatVRange :: VersionRange
|
||||
supportedChatVRange = mkVersionRange 1 currentChatVersion
|
||||
@@ -68,6 +69,10 @@ xGrpDirectInvVRange = mkVersionRange 2 currentChatVersion
|
||||
groupLinkNoContactVRange :: VersionRange
|
||||
groupLinkNoContactVRange = mkVersionRange 3 currentChatVersion
|
||||
|
||||
-- version range that supports group forwarding
|
||||
groupForwardVRange :: VersionRange
|
||||
groupForwardVRange = mkVersionRange 4 currentChatVersion
|
||||
|
||||
data ConnectionEntity
|
||||
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
|
||||
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
|
||||
@@ -208,7 +213,6 @@ data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMess
|
||||
data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
|
||||
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
|
||||
XMsgFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
|
||||
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
|
||||
XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json
|
||||
XMsgDeleted :: ChatMsgEvent 'Json
|
||||
@@ -230,13 +234,14 @@ data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XGrpMemFwd :: MemberInfo -> IntroInvitation -> ChatMsgEvent 'Json
|
||||
XGrpMemInfo :: MemberId -> Profile -> ChatMsgEvent 'Json
|
||||
XGrpMemRole :: MemberId -> GroupMemberRole -> ChatMsgEvent 'Json
|
||||
XGrpMemCon :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
|
||||
XGrpMemCon :: MemberId -> ChatMsgEvent 'Json
|
||||
XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
|
||||
XGrpMemDel :: MemberId -> ChatMsgEvent 'Json
|
||||
XGrpLeave :: ChatMsgEvent 'Json
|
||||
XGrpDel :: ChatMsgEvent 'Json
|
||||
XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
|
||||
XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> ChatMsgEvent 'Json
|
||||
XGrpMsgForward :: MemberId -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json
|
||||
XInfoProbe :: Probe -> ChatMsgEvent 'Json
|
||||
XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
|
||||
XInfoProbeOk :: Probe -> ChatMsgEvent 'Json
|
||||
@@ -257,6 +262,30 @@ data AChatMsgEvent = forall e. MsgEncodingI e => ACME (SMsgEncoding e) (ChatMsgE
|
||||
|
||||
deriving instance Show AChatMsgEvent
|
||||
|
||||
isForwardedGroupMsg :: ChatMsgEvent e -> Bool
|
||||
isForwardedGroupMsg ev = case ev of
|
||||
XMsgNew mc -> case mcExtMsgContent mc of
|
||||
ExtMsgContent {file = Just FileInvitation {fileInline = Just _}} -> False
|
||||
_ -> True
|
||||
XMsgFileDescr _ _ -> True
|
||||
XMsgUpdate {} -> True
|
||||
XMsgDel _ _ -> True
|
||||
XMsgReact {} -> True
|
||||
XFileCancel _ -> True
|
||||
XInfo _ -> True
|
||||
XGrpMemNew _ -> True
|
||||
XGrpMemRole {} -> True
|
||||
XGrpMemDel _ -> True -- TODO there should be a special logic when deleting host member (e.g., host forwards it before deleting connections)
|
||||
XGrpLeave -> True
|
||||
XGrpDel -> True -- TODO there should be a special logic - host should forward before deleting connections
|
||||
XGrpInfo _ -> True
|
||||
_ -> False
|
||||
|
||||
forwardedGroupMsg :: forall e. MsgEncodingI e => ChatMessage e -> Maybe (ChatMessage 'Json)
|
||||
forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of
|
||||
SJson | isForwardedGroupMsg chatMsgEvent -> Just msg
|
||||
_ -> Nothing
|
||||
|
||||
data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -536,7 +565,6 @@ data ACMEventTag = forall e. MsgEncodingI e => ACMEventTag (SMsgEncoding e) (CME
|
||||
data CMEventTag (e :: MsgEncoding) where
|
||||
XMsgNew_ :: CMEventTag 'Json
|
||||
XMsgFileDescr_ :: CMEventTag 'Json
|
||||
XMsgFileCancel_ :: CMEventTag 'Json
|
||||
XMsgUpdate_ :: CMEventTag 'Json
|
||||
XMsgDel_ :: CMEventTag 'Json
|
||||
XMsgDeleted_ :: CMEventTag 'Json
|
||||
@@ -565,6 +593,7 @@ data CMEventTag (e :: MsgEncoding) where
|
||||
XGrpDel_ :: CMEventTag 'Json
|
||||
XGrpInfo_ :: CMEventTag 'Json
|
||||
XGrpDirectInv_ :: CMEventTag 'Json
|
||||
XGrpMsgForward_ :: CMEventTag 'Json
|
||||
XInfoProbe_ :: CMEventTag 'Json
|
||||
XInfoProbeCheck_ :: CMEventTag 'Json
|
||||
XInfoProbeOk_ :: CMEventTag 'Json
|
||||
@@ -585,7 +614,6 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where
|
||||
strEncode = \case
|
||||
XMsgNew_ -> "x.msg.new"
|
||||
XMsgFileDescr_ -> "x.msg.file.descr"
|
||||
XMsgFileCancel_ -> "x.msg.file.cancel"
|
||||
XMsgUpdate_ -> "x.msg.update"
|
||||
XMsgDel_ -> "x.msg.del"
|
||||
XMsgDeleted_ -> "x.msg.deleted"
|
||||
@@ -614,6 +642,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where
|
||||
XGrpDel_ -> "x.grp.del"
|
||||
XGrpInfo_ -> "x.grp.info"
|
||||
XGrpDirectInv_ -> "x.grp.direct.inv"
|
||||
XGrpMsgForward_ -> "x.grp.msg.forward"
|
||||
XInfoProbe_ -> "x.info.probe"
|
||||
XInfoProbeCheck_ -> "x.info.probe.check"
|
||||
XInfoProbeOk_ -> "x.info.probe.ok"
|
||||
@@ -635,7 +664,6 @@ instance StrEncoding ACMEventTag where
|
||||
('x', t) -> pure . ACMEventTag SJson $ case t of
|
||||
"x.msg.new" -> XMsgNew_
|
||||
"x.msg.file.descr" -> XMsgFileDescr_
|
||||
"x.msg.file.cancel" -> XMsgFileCancel_
|
||||
"x.msg.update" -> XMsgUpdate_
|
||||
"x.msg.del" -> XMsgDel_
|
||||
"x.msg.deleted" -> XMsgDeleted_
|
||||
@@ -664,6 +692,7 @@ instance StrEncoding ACMEventTag where
|
||||
"x.grp.del" -> XGrpDel_
|
||||
"x.grp.info" -> XGrpInfo_
|
||||
"x.grp.direct.inv" -> XGrpDirectInv_
|
||||
"x.grp.msg.forward" -> XGrpMsgForward_
|
||||
"x.info.probe" -> XInfoProbe_
|
||||
"x.info.probe.check" -> XInfoProbeCheck_
|
||||
"x.info.probe.ok" -> XInfoProbeOk_
|
||||
@@ -681,7 +710,6 @@ toCMEventTag :: ChatMsgEvent e -> CMEventTag e
|
||||
toCMEventTag msg = case msg of
|
||||
XMsgNew _ -> XMsgNew_
|
||||
XMsgFileDescr _ _ -> XMsgFileDescr_
|
||||
XMsgFileCancel _ -> XMsgFileCancel_
|
||||
XMsgUpdate {} -> XMsgUpdate_
|
||||
XMsgDel {} -> XMsgDel_
|
||||
XMsgDeleted -> XMsgDeleted_
|
||||
@@ -710,6 +738,7 @@ toCMEventTag msg = case msg of
|
||||
XGrpDel -> XGrpDel_
|
||||
XGrpInfo _ -> XGrpInfo_
|
||||
XGrpDirectInv _ _ -> XGrpDirectInv_
|
||||
XGrpMsgForward {} -> XGrpMsgForward_
|
||||
XInfoProbe _ -> XInfoProbe_
|
||||
XInfoProbeCheck _ -> XInfoProbeCheck_
|
||||
XInfoProbeOk _ -> XInfoProbeOk_
|
||||
@@ -780,7 +809,6 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
msg = \case
|
||||
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
|
||||
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr"
|
||||
XMsgFileCancel_ -> XMsgFileCancel <$> p "msgId"
|
||||
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live"
|
||||
XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId"
|
||||
XMsgDeleted_ -> pure XMsgDeleted
|
||||
@@ -809,6 +837,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
XGrpDel_ -> pure XGrpDel
|
||||
XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
|
||||
XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content"
|
||||
XGrpMsgForward_ -> XGrpMsgForward <$> p "memberId" <*> p "msg" <*> p "msgTs"
|
||||
XInfoProbe_ -> XInfoProbe <$> p "probe"
|
||||
XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
|
||||
XInfoProbeOk_ -> XInfoProbeOk <$> p "probe"
|
||||
@@ -840,7 +869,6 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
|
||||
params = \case
|
||||
XMsgNew container -> msgContainerJSON container
|
||||
XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr]
|
||||
XMsgFileCancel msgId' -> o ["msgId" .= msgId']
|
||||
XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content]
|
||||
XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId']
|
||||
XMsgDeleted -> JM.empty
|
||||
@@ -869,6 +897,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
|
||||
XGrpDel -> JM.empty
|
||||
XGrpInfo p -> o ["groupProfile" .= p]
|
||||
XGrpDirectInv connReq content -> o $ ("content" .=? content) ["connReq" .= connReq]
|
||||
XGrpMsgForward memberId msg msgTs -> o ["memberId" .= memberId, "msg" .= msg, "msgTs" .= msgTs]
|
||||
XInfoProbe probe -> o ["probe" .= probe]
|
||||
XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
|
||||
XInfoProbeOk probe -> o ["probe" .= probe]
|
||||
@@ -879,3 +908,9 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
|
||||
XCallEnd callId -> o ["callId" .= callId]
|
||||
XOk -> JM.empty
|
||||
XUnknown _ ps -> ps
|
||||
|
||||
instance ToJSON (ChatMessage 'Json) where
|
||||
toJSON = (\(AMJson msg) -> toJSON msg) . chatToAppMessage
|
||||
|
||||
instance FromJSON (ChatMessage 'Json) where
|
||||
parseJSON v = appJsonToCM <$?> parseJSON v
|
||||
|
||||
Reference in New Issue
Block a user