mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
Merge branch 'master' into master-ghc8107
This commit is contained in:
Evgeny Poberezkin
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -17,7 +18,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
|
||||
@@ -49,7 +50,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
|
||||
@@ -66,6 +67,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}
|
||||
@@ -126,7 +131,7 @@ data AppMessageJson = AppMessageJson
|
||||
event :: Text,
|
||||
params :: J.Object
|
||||
}
|
||||
deriving (Generic, FromJSON)
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
data AppMessageBinary = AppMessageBinary
|
||||
{ msgId :: Maybe SharedMsgId,
|
||||
@@ -206,7 +211,6 @@ instance StrEncoding AChatMessage where
|
||||
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
|
||||
@@ -228,13 +232,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
|
||||
@@ -255,6 +260,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)
|
||||
|
||||
@@ -549,7 +578,6 @@ instance FromField MsgContent where
|
||||
data CMEventTag (e :: MsgEncoding) where
|
||||
XMsgNew_ :: CMEventTag 'Json
|
||||
XMsgFileDescr_ :: CMEventTag 'Json
|
||||
XMsgFileCancel_ :: CMEventTag 'Json
|
||||
XMsgUpdate_ :: CMEventTag 'Json
|
||||
XMsgDel_ :: CMEventTag 'Json
|
||||
XMsgDeleted_ :: CMEventTag 'Json
|
||||
@@ -578,6 +606,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
|
||||
@@ -598,7 +627,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"
|
||||
@@ -627,6 +655,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"
|
||||
@@ -648,7 +677,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_
|
||||
@@ -677,6 +705,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_
|
||||
@@ -694,7 +723,6 @@ toCMEventTag :: ChatMsgEvent e -> CMEventTag e
|
||||
toCMEventTag msg = case msg of
|
||||
XMsgNew _ -> XMsgNew_
|
||||
XMsgFileDescr _ _ -> XMsgFileDescr_
|
||||
XMsgFileCancel _ -> XMsgFileCancel_
|
||||
XMsgUpdate {} -> XMsgUpdate_
|
||||
XMsgDel {} -> XMsgDel_
|
||||
XMsgDeleted -> XMsgDeleted_
|
||||
@@ -723,6 +751,7 @@ toCMEventTag msg = case msg of
|
||||
XGrpDel -> XGrpDel_
|
||||
XGrpInfo _ -> XGrpInfo_
|
||||
XGrpDirectInv _ _ -> XGrpDirectInv_
|
||||
XGrpMsgForward {} -> XGrpMsgForward_
|
||||
XInfoProbe _ -> XInfoProbe_
|
||||
XInfoProbeCheck _ -> XInfoProbeCheck_
|
||||
XInfoProbeOk _ -> XInfoProbeOk_
|
||||
@@ -793,7 +822,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
|
||||
@@ -822,6 +850,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"
|
||||
@@ -853,7 +882,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
|
||||
@@ -882,6 +910,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]
|
||||
@@ -892,3 +921,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