From 9b239b26ba5c8fdec41c6689a6421baf7ffcc27d Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Wed, 6 Dec 2023 13:01:59 +0400 Subject: [PATCH] multiple events in ChatMessage and supporting types --- src/Simplex/Chat.hs | 247 +++++++++++++++-------------- src/Simplex/Chat/Messages.hs | 4 +- src/Simplex/Chat/Protocol.hs | 40 +++-- src/Simplex/Chat/Store/Messages.hs | 29 +++- src/Simplex/Chat/Store/Shared.hs | 1 + tests/ProtocolTests.hs | 26 +-- 6 files changed, 193 insertions(+), 154 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 475845c74..95879a40b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -3307,35 +3307,38 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do MSG msgMeta _msgFlags msgBody -> do cmdId <- createAckCmd conn withAckMessage agentConnId cmdId msgMeta $ do - (conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn msgMeta cmdId msgBody - let ct' = ct {activeConn = Just conn'} :: Contact - assertDirectAllowed user MDRcv ct' $ toCMEventTag event - updateChatLock "directMessage" event - case event of - XMsgNew mc -> newContentMessage ct' mc msg msgMeta - XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct' sharedMsgId fileDescr msgMeta - XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct' sharedMsgId mContent msg msgMeta ttl live - XMsgDel sharedMsgId _ -> messageDelete ct' sharedMsgId msg msgMeta - XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct' sharedMsgId reaction add msg msgMeta - -- TODO discontinue XFile - XFile fInv -> processFileInvitation' ct' fInv msg msgMeta - XFileCancel sharedMsgId -> xFileCancel ct' sharedMsgId msgMeta - XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct' sharedMsgId fileConnReq_ fName msgMeta - XInfo p -> xInfo ct' p - XDirectDel -> xDirectDel ct' msg msgMeta - XGrpInv gInv -> processGroupInvitation ct' gInv msg msgMeta - XInfoProbe probe -> xInfoProbe (COMContact ct') probe - XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct') probeHash - XInfoProbeOk probe -> xInfoProbeOk (COMContact ct') probe - XCallInv callId invitation -> xCallInv ct' callId invitation msg msgMeta - XCallOffer callId offer -> xCallOffer ct' callId offer msg msgMeta - XCallAnswer callId answer -> xCallAnswer ct' callId answer msg msgMeta - XCallExtra callId extraInfo -> xCallExtra ct' callId extraInfo msg msgMeta - XCallEnd callId -> xCallEnd ct' callId msg msgMeta - BFileChunk sharedMsgId chunk -> bFileChunk ct' sharedMsgId chunk msgMeta - _ -> messageError $ "unsupported message: " <> T.pack (show event) - let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' - pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt (toCMEventTag event) + (conn', msg@RcvMessage {chatMsgEvents}) <- saveDirectRcvMSG conn msgMeta cmdId msgBody + case chatMsgEvents of + [ACME _ event] -> do + let ct' = ct {activeConn = Just conn'} :: Contact + assertDirectAllowed user MDRcv ct' $ toCMEventTag event + updateChatLock "directMessage" event + case event of + XMsgNew mc -> newContentMessage ct' mc msg msgMeta + XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct' sharedMsgId fileDescr msgMeta + XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct' sharedMsgId mContent msg msgMeta ttl live + XMsgDel sharedMsgId _ -> messageDelete ct' sharedMsgId msg msgMeta + XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct' sharedMsgId reaction add msg msgMeta + -- TODO discontinue XFile + XFile fInv -> processFileInvitation' ct' fInv msg msgMeta + XFileCancel sharedMsgId -> xFileCancel ct' sharedMsgId msgMeta + XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct' sharedMsgId fileConnReq_ fName msgMeta + XInfo p -> xInfo ct' p + XDirectDel -> xDirectDel ct' msg msgMeta + XGrpInv gInv -> processGroupInvitation ct' gInv msg msgMeta + XInfoProbe probe -> xInfoProbe (COMContact ct') probe + XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct') probeHash + XInfoProbeOk probe -> xInfoProbeOk (COMContact ct') probe + XCallInv callId invitation -> xCallInv ct' callId invitation msg msgMeta + XCallOffer callId offer -> xCallOffer ct' callId offer msg msgMeta + XCallAnswer callId answer -> xCallAnswer ct' callId answer msg msgMeta + XCallExtra callId extraInfo -> xCallExtra ct' callId extraInfo msg msgMeta + XCallEnd callId -> xCallEnd ct' callId msg msgMeta + BFileChunk sharedMsgId chunk -> bFileChunk ct' sharedMsgId chunk msgMeta + _ -> messageError $ "unsupported message: " <> T.pack (show event) + let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' + pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt (toCMEventTag event) + _ -> messageError "processDirectMessage: unsupported batched events" $> False RCVD msgMeta msgRcpt -> withAckMessage' agentConnId conn msgMeta $ directMsgReceived ct conn msgMeta msgRcpt @@ -3344,12 +3347,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do conn' <- updatePeerChatVRange conn chatVRange case chatMsgEvent of -- confirming direct connection with a member - XGrpMemInfo _memId _memProfile -> do + [XGrpMemInfo _memId _memProfile] -> do -- TODO check member ID -- TODO update member profile -- [async agent commands] no continuation needed, but command should be asynchronous for stability allowAgentConnectionAsync user conn' confId XOk - XInfo profile -> do + [XInfo profile] -> do ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct) -- [incognito] send incognito profile incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId @@ -3361,13 +3364,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo _conn' <- updatePeerChatVRange conn chatVRange case chatMsgEvent of - XGrpMemInfo _memId _memProfile -> do + [XGrpMemInfo _memId _memProfile] -> do -- TODO check member ID -- TODO update member profile pure () - XInfo profile -> + [XInfo profile] -> void $ processContactProfileUpdate ct profile False - XOk -> pure () + [XOk] -> pure () _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok" CON -> withStore' (\db -> getViaGroupMember db user ct) >>= \case @@ -3500,7 +3503,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do case memberCategory m of GCInviteeMember -> case chatMsgEvent of - XGrpAcpt memId + [XGrpAcpt memId] | sameMemberId memId m -> do withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted -- [async agent commands] no continuation needed, but command should be asynchronous for stability @@ -3509,7 +3512,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do _ -> messageError "CONF from invited member must have x.grp.acpt" _ -> case chatMsgEvent of - XGrpMemInfo memId _memProfile + [XGrpMemInfo memId _memProfile] | sameMemberId memId m -> do -- TODO update member profile -- [async agent commands] no continuation needed, but command should be asynchronous for stability @@ -3520,13 +3523,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo _conn' <- updatePeerChatVRange conn chatVRange case chatMsgEvent of - XGrpMemInfo memId _memProfile + [XGrpMemInfo memId _memProfile] | sameMemberId memId m -> do -- TODO update member profile pure () | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" - XInfo _ -> pure () -- sent when connecting via group link - XOk -> pure () + [XInfo _] -> pure () -- sent when connecting via group link + [XOk] -> pure () _ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok" pure () CON -> do @@ -3639,51 +3642,58 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do when checkForEvent $ checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta where checkForEvent = case chatMsgEvent of - XMsgNew _ -> True - XFileCancel _ -> True - XFileAcptInv {} -> True - XGrpMemNew _ -> True - XGrpMemRole {} -> True - XGrpMemDel _ -> True - XGrpLeave -> True - XGrpDel -> True - XGrpInfo _ -> True - XGrpDirectInv {} -> True + [cme] -> case cme of + XMsgNew _ -> True + XFileCancel _ -> True + XFileAcptInv {} -> True + XGrpMemNew _ -> True + XGrpMemRole {} -> True + XGrpMemDel _ -> True + XGrpLeave -> True + XGrpDel -> True + XGrpInfo _ -> True + XGrpDirectInv {} -> True + _ -> False _ -> False processEvent :: MsgEncodingI e => CommandId -> ChatMessage e -> m Bool processEvent cmdId chatMsg = do - (m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta cmdId msgBody chatMsg - updateChatLock "groupMessage" event - case event of - XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs - XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live - XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs - XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs - -- TODO discontinue XFile - XFile fInv -> processGroupFileInvitation' gInfo m' fInv msg brokerTs - XFileCancel sharedMsgId -> xFileCancelGroup gInfo m' sharedMsgId - XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName - XInfo p -> xInfoMember gInfo m' p - XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p - XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs - XGrpMemIntro memInfo -> xGrpMemIntro gInfo m' memInfo - XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv - XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m' memInfo introInv - XGrpMemRole memId memRole -> xGrpMemRole gInfo m' memId memRole msg brokerTs - XGrpMemCon memId -> xGrpMemCon gInfo m' memId - XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs - XGrpLeave -> xGrpLeave gInfo m' msg brokerTs - XGrpDel -> xGrpDel gInfo m' msg brokerTs - XGrpInfo p' -> xGrpInfo gInfo m' p' msg brokerTs - XGrpDirectInv connReq mContent_ -> memberCanSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg brokerTs - XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo m' memberId msg' msgTs - XInfoProbe probe -> xInfoProbe (COMGroupMember m') probe - XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash - XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe - BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta - _ -> messageError $ "unsupported message: " <> T.pack (show event) - checkSendRcpt event + (m', conn', msg@RcvMessage {chatMsgEvents}) <- saveGroupRcvMsg user groupId m conn msgMeta cmdId msgBody chatMsg + case chatMsgEvents of + [ACME _ event] -> do + updateChatLock "groupMessage" event + case event of + XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs + XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live + XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs + XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs + -- TODO discontinue XFile + XFile fInv -> processGroupFileInvitation' gInfo m' fInv msg brokerTs + XFileCancel sharedMsgId -> xFileCancelGroup gInfo m' sharedMsgId + XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName + XInfo p -> xInfoMember gInfo m' p + XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p + XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs + XGrpMemIntro memInfo -> xGrpMemIntro gInfo m' memInfo + XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv + XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m' memInfo introInv + XGrpMemRole memId memRole -> xGrpMemRole gInfo m' memId memRole msg brokerTs + XGrpMemCon memId -> xGrpMemCon gInfo m' memId + XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs + XGrpLeave -> xGrpLeave gInfo m' msg brokerTs + XGrpDel -> xGrpDel gInfo m' msg brokerTs + XGrpInfo p' -> xGrpInfo gInfo m' p' msg brokerTs + XGrpDirectInv connReq mContent_ -> memberCanSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg brokerTs + XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo m' memberId msg' msgTs + XInfoProbe probe -> xInfoProbe (COMGroupMember m') probe + XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash + XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe + BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta + _ -> messageError $ "unsupported message: " <> T.pack (show event) + checkSendRcpt event + _ -> + -- TODO [batch send] process events in loop + messageError "processGroupMessage: unsupported batched events" $> False checkSendRcpt :: ChatMsgEvent e -> m Bool checkSendRcpt event = do currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo @@ -3796,7 +3806,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do conn' <- updatePeerChatVRange conn chatVRange case chatMsgEvent of -- TODO save XFileAcpt message - XFileAcpt name + [XFileAcpt name] | name == fileName -> do withStore' $ \db -> updateSndFileStatus db ft FSAccepted -- [async agent commands] no continuation needed, but command should be asynchronous for stability @@ -3864,7 +3874,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo conn' <- updatePeerChatVRange conn chatVRange case chatMsgEvent of - XOk -> allowAgentConnectionAsync user conn' confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability + [XOk] -> allowAgentConnectionAsync user conn' confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability _ -> pure () CON -> startReceivingFile user fileId MSG meta _ msgBody -> do @@ -3924,8 +3934,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do REQ invId _ connInfo -> do ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo case chatMsgEvent of - XContact p xContactId_ -> profileContactRequest invId chatVRange p xContactId_ - XInfo p -> profileContactRequest invId chatVRange p Nothing + [XContact p xContactId_] -> profileContactRequest invId chatVRange p xContactId_ + [XInfo p] -> profileContactRequest invId chatVRange p Nothing -- TODO show/log error, other events in contact request _ -> pure () MERR _ err -> do @@ -4958,11 +4968,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo conn' <- updatePeerChatVRange activeConn chatVRange case chatMsgEvent of - XInfo p -> do + [XInfo p] -> do ct <- withStore $ \db -> createDirectContact db user conn' p toView $ CRContactConnecting user ct pure conn' - XGrpLinkInv glInv -> do + [XGrpLinkInv glInv] -> do (gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db user conn' glInv toView $ CRGroupLinkConnecting user gInfo host pure conn' @@ -5229,22 +5239,24 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do processForwardedMsg :: GroupMember -> ChatMessage 'Json -> m () processForwardedMsg author chatMsg = do let body = LB.toStrict $ J.encode msg - rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg - case event of - XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs - XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live - XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs - XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs - XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId - XInfo p -> xInfoMember gInfo author p - XGrpMemNew memInfo -> xGrpMemNew gInfo author memInfo rcvMsg msgTs - XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs - XGrpMemDel memId -> xGrpMemDel gInfo author memId rcvMsg msgTs - XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs - XGrpDel -> xGrpDel gInfo author rcvMsg msgTs - XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs - _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) + rcvMsg@RcvMessage {chatMsgEvents} <- saveGroupFwdRcvMsg user groupId m author body chatMsg + case chatMsgEvents of + [ACME _ event] -> case event of + XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs + XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live + XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs + XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs + XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId + XInfo p -> xInfoMember gInfo author p + XGrpMemNew memInfo -> xGrpMemNew gInfo author memInfo rcvMsg msgTs + XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs + XGrpMemDel memId -> xGrpMemDel gInfo author memId rcvMsg msgTs + XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs + XGrpDel -> xGrpDel gInfo author rcvMsg msgTs + XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs + _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) + _ -> messageError "x.grp.msg.forward: unsupported batched events" directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> m () directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do @@ -5532,12 +5544,12 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do (msg,) <$> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage -createSndMessage chatMsgEvent connOrGroupId = do +createSndMessage cme connOrGroupId = do gVar <- asks idsDrg ChatConfig {chatVRange} <- asks config withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId -> - let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} - in NewMessage {chatMsgEvent, msgBody} + let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent = [cme]} + in NewMessage {chatMsgEvents = [cme], msgBody} sendBatchedDirectMessages :: (MsgEncodingI e, ChatMonad m) => Connection -> [ChatMsgEvent e] -> ConnOrGroupId -> m (SndMessage, Int64) sendBatchedDirectMessages conn events connOrGroupId = do @@ -5558,17 +5570,16 @@ createBatchedSndMessage events connOrGroupId = do -- - ChatMessage encoding should support list of ChatMsgEvents -- - * return list of SndMessages? it's not necessary for current use cases withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId -> - let chatMsgEvent = XOk -- dummy - msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} - in NewMessage {chatMsgEvent, msgBody} + let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent = events} + in NewMessage {chatMsgEvents = events, msgBody} directMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString -directMessage chatMsgEvent = do +directMessage cme = do ChatConfig {chatVRange} <- asks config - pure $ strEncode ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent} + pure $ strEncode ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent = [cme]} deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> MsgBody -> MessageId -> m Int64 -deliverMessage conn@Connection {connId} cmEventTag msgBody msgId = do +deliverMessage conn cmEventTag msgBody msgId = do let msgFlags = MsgFlags {notification = hasNotification cmEventTag} deliverMessage' conn msgFlags msgBody msgId @@ -5655,7 +5666,7 @@ saveDirectRcvMSG conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody = d ACMsg _ ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} <- parseAChatMessage conn agentMsgMeta msgBody conn' <- updatePeerChatVRange conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewMessage {chatMsgEvent, msgBody} + newMsg = NewMessage {chatMsgEvents = chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing pure (conn', msg) @@ -5664,7 +5675,7 @@ saveGroupRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMemb saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do (am', conn') <- updateMemberChatVRange authorMember conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewMessage {chatMsgEvent, msgBody} + newMsg = NewMessage {chatMsgEvents = chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} amId = Just am'.groupMemberId msg <- @@ -5680,7 +5691,7 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta saveGroupFwdRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do - let newMsg = NewMessage {chatMsgEvent, msgBody} + let newMsg = NewMessage {chatMsgEvents = chatMsgEvent, msgBody} fwdMemberId = Just $ groupMemberId' forwardingMember refAuthorId = Just $ groupMemberId' refAuthorMember withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) @@ -5714,10 +5725,10 @@ saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = saveRcvChatItem' :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> m (ChatItem c 'MDRcv) saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do createdAt <- liftIO getCurrentTime - (ciId, quotedItem) <- withStore' $ \db -> do - when (ciRequiresAttention content) $ updateChatTs db user cd createdAt + (ciId, quotedItem) <- withStore $ \db -> do + when (ciRequiresAttention content) $ liftIO $ updateChatTs db user cd createdAt (ciId, quotedItem) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt - forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt + forM_ ciFile $ \CIFile {fileId} -> liftIO $ updateFileTransferChatItemId db fileId ciId createdAt pure (ciId, quotedItem) liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs forwardedByMember createdAt diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 77c053fdf..4d29b0ece 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -767,7 +767,7 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of Nothing -> Left "bad chat type" data NewMessage e = NewMessage - { chatMsgEvent :: ChatMsgEvent e, + { chatMsgEvents :: [ChatMsgEvent e], msgBody :: MsgBody } deriving (Show) @@ -780,7 +780,7 @@ data SndMessage = SndMessage data RcvMessage = RcvMessage { msgId :: MessageId, - chatMsgEvent :: AChatMsgEvent, + chatMsgEvents :: [AChatMsgEvent], sharedMsgId_ :: Maybe SharedMsgId, msgBody :: MsgBody, authorMember :: Maybe GroupMemberId, diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 30248f612..52bc1b26e 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -133,6 +133,14 @@ data AppMessageJson = AppMessageJson params :: J.Object } +-- TODO [batch send] AppBatchMessageJson? +-- data AppMessageJson = AppMessageJson +-- { v :: Maybe ChatVersionRange, +-- msgId :: Maybe SharedMsgId, +-- event :: Text, +-- params :: J.Object +-- } + data AppMessageBinary = AppMessageBinary { msgId :: Maybe SharedMsgId, tag :: Char, @@ -207,7 +215,7 @@ $(JQ.deriveJSON defaultJSON ''LinkPreview) data ChatMessage e = ChatMessage { chatVRange :: VersionRange, msgId :: Maybe SharedMsgId, - chatMsgEvent :: ChatMsgEvent e + chatMsgEvent :: [ChatMsgEvent e] } deriving (Eq, Show) @@ -285,8 +293,10 @@ isForwardedGroupMsg ev = case ev of _ -> False forwardedGroupMsg :: forall e. MsgEncodingI e => ChatMessage e -> Maybe (ChatMessage 'Json) -forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of - SJson | isForwardedGroupMsg chatMsgEvent -> Just msg +forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case chatMsgEvent of + [cme] -> case encoding @e of + SJson | isForwardedGroupMsg cme -> Just msg + _ -> Nothing _ -> Nothing data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} @@ -791,8 +801,8 @@ hasDeliveryReceipt = \case appBinaryToCM :: AppMessageBinary -> Either String (ChatMessage 'Binary) appBinaryToCM AppMessageBinary {msgId, tag, body} = do eventTag <- strDecode $ B.singleton tag - chatMsgEvent <- parseAll (msg eventTag) body - pure ChatMessage {chatVRange = chatInitialVRange, msgId, chatMsgEvent} + cme <- parseAll (msg eventTag) body + pure ChatMessage {chatVRange = chatInitialVRange, msgId, chatMsgEvent = [cme]} where msg :: CMEventTag 'Binary -> A.Parser (ChatMsgEvent 'Binary) msg = \case @@ -801,8 +811,8 @@ appBinaryToCM AppMessageBinary {msgId, tag, body} = do appJsonToCM :: AppMessageJson -> Either String (ChatMessage 'Json) appJsonToCM AppMessageJson {v, msgId, event, params} = do eventTag <- strDecode $ encodeUtf8 event - chatMsgEvent <- msg eventTag - pure ChatMessage {chatVRange = maybe chatInitialVRange fromChatVRange v, msgId, chatMsgEvent} + cme <- msg eventTag + pure ChatMessage {chatVRange = maybe chatInitialVRange fromChatVRange v, msgId, chatMsgEvent = [cme]} where p :: FromJSON a => J.Key -> Either String a p key = JT.parseEither (.: key) params @@ -855,14 +865,18 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do (.=?) :: ToJSON v => JT.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)] key .=? value = maybe id ((:) . (key .=)) value +-- TODO [batch send] 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} - SJson -> AMJson AppMessageJson {v = Just $ ChatVersionRange chatVRange, msgId, event = textEncode tag, params = params chatMsgEvent} +chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case chatMsgEvent of + [cme] -> case encoding @e of + SBinary -> + let (binaryMsgId, body) = toBody cme + in AMBinary AppMessageBinary {msgId = binaryMsgId, tag = B.head $ strEncode $ toCMEventTag cme, body} + SJson -> AMJson AppMessageJson {v = Just $ ChatVersionRange chatVRange, msgId, event = textEncode $ toCMEventTag cme, params = params cme} + _ -> + -- encode list of events + error "bad ChatMessage" where - tag = toCMEventTag chatMsgEvent o :: [(J.Key, J.Value)] -> J.Object o = JM.fromList toBody :: ChatMsgEvent 'Binary -> (Maybe SharedMsgId, ByteString) diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 102612b4e..656621e7f 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -160,7 +160,8 @@ deleteGroupCIs db User {userId} GroupInfo {groupId} = do createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage createNewSndMessage db gVar connOrGroupId mkMessage = createWithRandomId gVar $ \sharedMsgId -> do - let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId + let NewMessage {chatMsgEvents, msgBody} = mkMessage $ SharedMsgId sharedMsgId + tag = eventsTag chatMsgEvents createdAt <- getCurrentTime DB.execute db @@ -170,10 +171,15 @@ createNewSndMessage db gVar connOrGroupId mkMessage = shared_msg_id, shared_msg_id_user, created_at, updated_at ) VALUES (?,?,?,?,?,?,?,?,?) |] - (MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt) + (MDSnd, tag, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt) msgId <- insertedRowId db pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody} where + eventsTag :: [ChatMsgEvent e] -> CMEventTag e + eventsTag events = case events of + [chatMsgEvent] -> toCMEventTag chatMsgEvent + (chatMsgEvent : _) -> toCMEventTag chatMsgEvent + [] -> error "createNewSndMessage: empty chatMsgEvents" (connId_, groupId_) = case connOrGroupId of ConnectionId connId -> (Just connId, Nothing) GroupId groupId -> (Nothing, Just groupId) @@ -199,7 +205,7 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs pure msg createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage -createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = +createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvents, msgBody} sharedMsgId_ authorMember forwardedByMember = case connOrGroupId of ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing GroupId groupId -> case sharedMsgId_ of @@ -222,6 +228,7 @@ createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMs |] (groupId, sharedMsgId) insertRcvMsg connId_ groupId_ = do + let tag = eventsTag chatMsgEvents currentTs <- getCurrentTime DB.execute db @@ -230,9 +237,14 @@ createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMs (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) VALUES (?,?,?,?,?,?,?,?,?,?) |] - (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember) + (MDRcv, tag, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember) msgId <- insertedRowId db - pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember} + pure RcvMessage {msgId, chatMsgEvents = map (ACME (encoding @e)) chatMsgEvents, sharedMsgId_, msgBody, authorMember, forwardedByMember} + eventsTag :: [ChatMsgEvent e] -> CMEventTag e + eventsTag events = case events of + [chatMsgEvent] -> toCMEventTag chatMsgEvent + (chatMsgEvent : _) -> toCMEventTag chatMsgEvent + [] -> error "createNewRcvMessage: empty chatMsgEvents" createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do @@ -365,13 +377,13 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) CIQGroupRcv Nothing -> (Just False, Nothing) -createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) -createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = do +createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> ExceptT StoreError IO (ChatItemId, Maybe (CIQuote c)) +createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvents = [cme], forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = liftIO $ do ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs forwardedByMember createdAt quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg pure (ciId, quotedItem) where - quotedMsg = cmToQuotedMsg chatMsgEvent + quotedMsg = cmToQuotedMsg cme quoteRow :: NewQuoteRow quoteRow = case quotedMsg of Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) @@ -380,6 +392,7 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw CDDirectRcv _ -> (Just $ not sent, Nothing) CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> (Just $ Just userMemberId == memberId, memberId) +createNewRcvChatItem _ _ _ RcvMessage {chatMsgEvents = _} _ _ _ _ _ _ = throwError SECantCreateBatchedEventsChatItem createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId createNewChatItemNoMsg db user chatDirection ciContent itemTs = diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 93c3ab197..c2644f54a 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -93,6 +93,7 @@ data StoreError | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId} | SEChatItemNotFoundByFileId {fileId :: FileTransferId} | SEChatItemNotFoundByGroupId {groupId :: GroupId} + | SECantCreateBatchedEventsChatItem | SEProfileNotFound {profileId :: Int64} | SEDuplicateGroupLink {groupInfo :: GroupInfo} | SEGroupLinkNotFound {groupInfo :: GroupInfo} diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 28de26e38..321d49835 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -76,10 +76,10 @@ s ##==## msg = do s ==## msg (==#) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation -s ==# msg = s ==## ChatMessage chatInitialVRange Nothing msg +s ==# msg = s ==## ChatMessage chatInitialVRange Nothing [msg] (#==) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation -s #== msg = s ##== ChatMessage chatInitialVRange Nothing msg +s #== msg = s ##== ChatMessage chatInitialVRange Nothing [msg] (#==#) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation s #==# msg = do @@ -120,37 +120,37 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XMsgNew (MCSimple (extMsgContent (MCImage "here's an image" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=") Nothing)) it "x.msg.new chat message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))] it "x.msg.new chat message with chat version range" $ "{\"v\":\"1-5\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" - ##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))) + ##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))] it "x.msg.new quote" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}}}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing))) + [XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing))] it "x.msg.new quote - timed message TTL" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"ttl\":3600}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing))) + [XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing))] it "x.msg.new quote - live message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"live\":true}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True)))) + [XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True)))] it "x.msg.new forward" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing)] it "x.msg.new forward - timed message TTL" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing)] it "x.msg.new forward - live message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))] it "x.msg.new simple text with file" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) @@ -162,7 +162,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - ( XMsgNew + [ XMsgNew ( MCQuote quotedMsg ( extMsgContent @@ -170,10 +170,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}) ) ) - ) + ] it "x.msg.new forward with file" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))] it "x.msg.update" $ "{\"v\":\"1\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing Nothing