diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 8e166d1940..3312e928de 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -22,9 +22,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader -import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (lefts, partitionEithers, rights) import Data.Functor (($>)) import Data.Int (Int64) @@ -488,7 +486,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let tag = toCMEventTag chatMsgEvent atomically $ modifyTVar' tags (tshow tag :) logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo - (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta msgBody chatMsg + let body = chatMsgToBody chatMsg + (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta body chatMsg let ct'' = ct' {activeConn = Just conn''} :: Contact case event of XMsgNew mc -> newContentMessage ct'' mc msg msgMeta @@ -933,7 +932,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let tag = toCMEventTag chatMsgEvent atomically $ modifyTVar' tags (tshow tag :) logInfo $ "group msg=" <> tshow tag <> " " <> eInfo - (m'', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta msgBody chatMsg + let body = chatMsgToBody chatMsg + (m'', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta body chatMsg -- ! see isForwardedGroupMsg: processing functions should return GroupForwardScope for same events case event of XMsgNew mc -> memberCanSend m'' scope $ newGroupContentMessage gInfo' m'' mc msg brokerTs False @@ -3154,20 +3154,20 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> CM () - xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId msg msgTs = do + xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId chatMsg msgTs = do when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole localDisplayName) withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case - Right author -> processForwardedMsg author msg + Right author -> processForwardedMsg author Left (SEGroupMemberNotFoundByMemberId _) -> do unknownAuthor <- createUnknownMember gInfo memberId toView $ CEvtUnknownMemberCreated user gInfo m unknownAuthor - processForwardedMsg unknownAuthor msg + processForwardedMsg unknownAuthor Left e -> throwError $ ChatErrorStore e where -- ! see isForwardedGroupMsg: forwarded group events should include msgId to be deduplicated - processForwardedMsg :: GroupMember -> ChatMessage 'Json -> CM () - processForwardedMsg author chatMsg = do - let body = LB.toStrict $ J.encode msg + processForwardedMsg :: GroupMember -> CM () + processForwardedMsg author = do + let body = chatMsgToBody chatMsg rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg case event of XMsgNew mc -> void $ memberCanSend author scope $ newGroupContentMessage gInfo author mc rcvMsg msgTs True diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 84d5cc8c3d..830a4e27b0 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -1152,18 +1152,13 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do key .=? value = maybe id ((:) . (key .=)) value chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e -chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @e of - SBinary -> - let (binaryMsgId, body) = toBody chatMsgEvent - in AMBinary AppMessageBinary {msgId = binaryMsgId, tag = B.head $ strEncode tag, body} +chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @e of + SBinary -> AMBinary AppMessageBinary {msgId = Nothing, tag = B.head $ strEncode tag, body = chatMsgBinaryToBody chatMsg} SJson -> AMJson AppMessageJson {v = Just $ ChatVersionRange chatVRange, msgId, event = textEncode tag, params = params chatMsgEvent} where tag = toCMEventTag chatMsgEvent o :: [(J.Key, J.Value)] -> J.Object o = JM.fromList - toBody :: ChatMsgEvent 'Binary -> (Maybe SharedMsgId, ByteString) - toBody = \case - BFileChunk (SharedMsgId msgId') chunk -> (Nothing, smpEncode (msgId', IFC chunk)) params :: ChatMsgEvent 'Json -> J.Object params = \case XMsgNew container -> msgContainerJSON container @@ -1212,6 +1207,15 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @ XOk -> JM.empty XUnknown _ ps -> ps +chatMsgBinaryToBody :: ChatMessage 'Binary -> ByteString +chatMsgBinaryToBody ChatMessage {chatMsgEvent} = case chatMsgEvent of + BFileChunk (SharedMsgId msgId) chunk -> smpEncode (msgId, IFC chunk) + +chatMsgToBody :: forall e. MsgEncodingI e => ChatMessage e -> ByteString +chatMsgToBody chatMsg = case encoding @e of + SBinary -> chatMsgBinaryToBody chatMsg + SJson -> LB.toStrict $ J.encode chatMsg + instance ToJSON (ChatMessage 'Json) where toJSON = (\(AMJson msg) -> toJSON msg) . chatToAppMessage