IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

multiple events in ChatMessage and supporting types

Browse Source
This commit is contained in:
spaced4ndy 2023-12-06 13:01:59 +04:00
parent 420d8537cb
commit 9b239b26ba
6 changed files with 193 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

247
src/Simplex/Chat.hs
View File

@ -3307,35 +3307,38 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
MSG msgMeta _msgFlags msgBody -> do MSG msgMeta _msgFlags msgBody -> do
cmdId <- createAckCmd conn cmdId <- createAckCmd conn
withAckMessage agentConnId cmdId msgMeta $ do withAckMessage agentConnId cmdId msgMeta $ do
(conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn msgMeta cmdId msgBody (conn', msg@RcvMessage {chatMsgEvents}) <- saveDirectRcvMSG conn msgMeta cmdId msgBody
let ct' = ct {activeConn = Just conn'} :: Contact case chatMsgEvents of
assertDirectAllowed user MDRcv ct' $ toCMEventTag event [ACME _ event] -> do
updateChatLock "directMessage" event let ct' = ct {activeConn = Just conn'} :: Contact
case event of assertDirectAllowed user MDRcv ct' $ toCMEventTag event
XMsgNew mc -> newContentMessage ct' mc msg msgMeta updateChatLock "directMessage" event
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct' sharedMsgId fileDescr msgMeta case event of
XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct' sharedMsgId mContent msg msgMeta ttl live XMsgNew mc -> newContentMessage ct' mc msg msgMeta
XMsgDel sharedMsgId _ -> messageDelete ct' sharedMsgId msg msgMeta XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct' sharedMsgId fileDescr msgMeta
XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct' sharedMsgId reaction add msg msgMeta XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct' sharedMsgId mContent msg msgMeta ttl live
-- TODO discontinue XFile XMsgDel sharedMsgId _ -> messageDelete ct' sharedMsgId msg msgMeta
XFile fInv -> processFileInvitation' ct' fInv msg msgMeta XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct' sharedMsgId reaction add msg msgMeta
XFileCancel sharedMsgId -> xFileCancel ct' sharedMsgId msgMeta -- TODO discontinue XFile
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct' sharedMsgId fileConnReq_ fName msgMeta XFile fInv -> processFileInvitation' ct' fInv msg msgMeta
XInfo p -> xInfo ct' p XFileCancel sharedMsgId -> xFileCancel ct' sharedMsgId msgMeta
XDirectDel -> xDirectDel ct' msg msgMeta XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct' sharedMsgId fileConnReq_ fName msgMeta
XGrpInv gInv -> processGroupInvitation ct' gInv msg msgMeta XInfo p -> xInfo ct' p
XInfoProbe probe -> xInfoProbe (COMContact ct') probe XDirectDel -> xDirectDel ct' msg msgMeta
XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct') probeHash XGrpInv gInv -> processGroupInvitation ct' gInv msg msgMeta
XInfoProbeOk probe -> xInfoProbeOk (COMContact ct') probe XInfoProbe probe -> xInfoProbe (COMContact ct') probe
XCallInv callId invitation -> xCallInv ct' callId invitation msg msgMeta XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct') probeHash
XCallOffer callId offer -> xCallOffer ct' callId offer msg msgMeta XInfoProbeOk probe -> xInfoProbeOk (COMContact ct') probe
XCallAnswer callId answer -> xCallAnswer ct' callId answer msg msgMeta XCallInv callId invitation -> xCallInv ct' callId invitation msg msgMeta
XCallExtra callId extraInfo -> xCallExtra ct' callId extraInfo msg msgMeta XCallOffer callId offer -> xCallOffer ct' callId offer msg msgMeta
XCallEnd callId -> xCallEnd ct' callId msg msgMeta XCallAnswer callId answer -> xCallAnswer ct' callId answer msg msgMeta
BFileChunk sharedMsgId chunk -> bFileChunk ct' sharedMsgId chunk msgMeta XCallExtra callId extraInfo -> xCallExtra ct' callId extraInfo msg msgMeta
_ -> messageError $ "unsupported message: " <> T.pack (show event) XCallEnd callId -> xCallEnd ct' callId msg msgMeta
let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' BFileChunk sharedMsgId chunk -> bFileChunk ct' sharedMsgId chunk msgMeta
pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt (toCMEventTag event) _ -> 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 -> RCVD msgMeta msgRcpt ->
withAckMessage' agentConnId conn msgMeta $ withAckMessage' agentConnId conn msgMeta $
directMsgReceived ct conn msgMeta msgRcpt directMsgReceived ct conn msgMeta msgRcpt
@ -3344,12 +3347,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
conn' <- updatePeerChatVRange conn chatVRange conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of case chatMsgEvent of
-- confirming direct connection with a member -- confirming direct connection with a member
XGrpMemInfo _memId _memProfile -> do [XGrpMemInfo _memId _memProfile] -> do
-- TODO check member ID -- TODO check member ID
-- TODO update member profile -- TODO update member profile
-- [async agent commands] no continuation needed, but command should be asynchronous for stability -- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId XOk allowAgentConnectionAsync user conn' confId XOk
XInfo profile -> do [XInfo profile] -> do
ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct) ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct)
-- [incognito] send incognito profile -- [incognito] send incognito profile
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId 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 ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
_conn' <- updatePeerChatVRange conn chatVRange _conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of case chatMsgEvent of
XGrpMemInfo _memId _memProfile -> do [XGrpMemInfo _memId _memProfile] -> do
-- TODO check member ID -- TODO check member ID
-- TODO update member profile -- TODO update member profile
pure () pure ()
XInfo profile -> [XInfo profile] ->
void $ processContactProfileUpdate ct profile False 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" _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
CON -> CON ->
withStore' (\db -> getViaGroupMember db user ct) >>= \case withStore' (\db -> getViaGroupMember db user ct) >>= \case
@ -3500,7 +3503,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
case memberCategory m of case memberCategory m of
GCInviteeMember -> GCInviteeMember ->
case chatMsgEvent of case chatMsgEvent of
XGrpAcpt memId [XGrpAcpt memId]
| sameMemberId memId m -> do | sameMemberId memId m -> do
withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
-- [async agent commands] no continuation needed, but command should be asynchronous for stability -- [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" _ -> messageError "CONF from invited member must have x.grp.acpt"
_ -> _ ->
case chatMsgEvent of case chatMsgEvent of
XGrpMemInfo memId _memProfile [XGrpMemInfo memId _memProfile]
| sameMemberId memId m -> do | sameMemberId memId m -> do
-- TODO update member profile -- TODO update member profile
-- [async agent commands] no continuation needed, but command should be asynchronous for stability -- [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 ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
_conn' <- updatePeerChatVRange conn chatVRange _conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of case chatMsgEvent of
XGrpMemInfo memId _memProfile [XGrpMemInfo memId _memProfile]
| sameMemberId memId m -> do | sameMemberId memId m -> do
-- TODO update member profile -- TODO update member profile
pure () pure ()
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected" | otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
XInfo _ -> pure () -- sent when connecting via group link [XInfo _] -> pure () -- sent when connecting via group link
XOk -> pure () [XOk] -> pure ()
_ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok" _ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok"
pure () pure ()
CON -> do CON -> do
@ -3639,51 +3642,58 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
when checkForEvent $ checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta when checkForEvent $ checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta
where where
checkForEvent = case chatMsgEvent of checkForEvent = case chatMsgEvent of
XMsgNew _ -> True [cme] -> case cme of
XFileCancel _ -> True XMsgNew _ -> True
XFileAcptInv {} -> True XFileCancel _ -> True
XGrpMemNew _ -> True XFileAcptInv {} -> True
XGrpMemRole {} -> True XGrpMemNew _ -> True
XGrpMemDel _ -> True XGrpMemRole {} -> True
XGrpLeave -> True XGrpMemDel _ -> True
XGrpDel -> True XGrpLeave -> True
XGrpInfo _ -> True XGrpDel -> True
XGrpDirectInv {} -> True XGrpInfo _ -> True
XGrpDirectInv {} -> True
_ -> False
_ -> False _ -> False
processEvent :: MsgEncodingI e => CommandId -> ChatMessage e -> m Bool processEvent :: MsgEncodingI e => CommandId -> ChatMessage e -> m Bool
processEvent cmdId chatMsg = do processEvent cmdId chatMsg = do
(m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta cmdId msgBody chatMsg (m', conn', msg@RcvMessage {chatMsgEvents}) <- saveGroupRcvMsg user groupId m conn msgMeta cmdId msgBody chatMsg
updateChatLock "groupMessage" event case chatMsgEvents of
case event of [ACME _ event] -> do
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs updateChatLock "groupMessage" event
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr case event of
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr
XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live
-- TODO discontinue XFile XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs
XFile fInv -> processGroupFileInvitation' gInfo m' fInv msg brokerTs XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs
XFileCancel sharedMsgId -> xFileCancelGroup gInfo m' sharedMsgId -- TODO discontinue XFile
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName XFile fInv -> processGroupFileInvitation' gInfo m' fInv msg brokerTs
XInfo p -> xInfoMember gInfo m' p XFileCancel sharedMsgId -> xFileCancelGroup gInfo m' sharedMsgId
XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName
XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs XInfo p -> xInfoMember gInfo m' p
XGrpMemIntro memInfo -> xGrpMemIntro gInfo m' memInfo XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p
XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs
XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m' memInfo introInv XGrpMemIntro memInfo -> xGrpMemIntro gInfo m' memInfo
XGrpMemRole memId memRole -> xGrpMemRole gInfo m' memId memRole msg brokerTs XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv
XGrpMemCon memId -> xGrpMemCon gInfo m' memId XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m' memInfo introInv
XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs XGrpMemRole memId memRole -> xGrpMemRole gInfo m' memId memRole msg brokerTs
XGrpLeave -> xGrpLeave gInfo m' msg brokerTs XGrpMemCon memId -> xGrpMemCon gInfo m' memId
XGrpDel -> xGrpDel gInfo m' msg brokerTs XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs
XGrpInfo p' -> xGrpInfo gInfo m' p' msg brokerTs XGrpLeave -> xGrpLeave gInfo m' msg brokerTs
XGrpDirectInv connReq mContent_ -> memberCanSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg brokerTs XGrpDel -> xGrpDel gInfo m' msg brokerTs
XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo m' memberId msg' msgTs XGrpInfo p' -> xGrpInfo gInfo m' p' msg brokerTs
XInfoProbe probe -> xInfoProbe (COMGroupMember m') probe XGrpDirectInv connReq mContent_ -> memberCanSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg brokerTs
XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo m' memberId msg' msgTs
XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe XInfoProbe probe -> xInfoProbe (COMGroupMember m') probe
BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash
_ -> messageError $ "unsupported message: " <> T.pack (show event) XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe
checkSendRcpt event 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 :: ChatMsgEvent e -> m Bool
checkSendRcpt event = do checkSendRcpt event = do
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
@ -3796,7 +3806,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
conn' <- updatePeerChatVRange conn chatVRange conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of case chatMsgEvent of
-- TODO save XFileAcpt message -- TODO save XFileAcpt message
XFileAcpt name [XFileAcpt name]
| name == fileName -> do | name == fileName -> do
withStore' $ \db -> updateSndFileStatus db ft FSAccepted withStore' $ \db -> updateSndFileStatus db ft FSAccepted
-- [async agent commands] no continuation needed, but command should be asynchronous for stability -- [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 ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
conn' <- updatePeerChatVRange conn chatVRange conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of 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 () _ -> pure ()
CON -> startReceivingFile user fileId CON -> startReceivingFile user fileId
MSG meta _ msgBody -> do MSG meta _ msgBody -> do
@ -3924,8 +3934,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
REQ invId _ connInfo -> do REQ invId _ connInfo -> do
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
case chatMsgEvent of case chatMsgEvent of
XContact p xContactId_ -> profileContactRequest invId chatVRange p xContactId_ [XContact p xContactId_] -> profileContactRequest invId chatVRange p xContactId_
XInfo p -> profileContactRequest invId chatVRange p Nothing [XInfo p] -> profileContactRequest invId chatVRange p Nothing
-- TODO show/log error, other events in contact request -- TODO show/log error, other events in contact request
_ -> pure () _ -> pure ()
MERR _ err -> do MERR _ err -> do
@ -4958,11 +4968,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
conn' <- updatePeerChatVRange activeConn chatVRange conn' <- updatePeerChatVRange activeConn chatVRange
case chatMsgEvent of case chatMsgEvent of
XInfo p -> do [XInfo p] -> do
ct <- withStore $ \db -> createDirectContact db user conn' p ct <- withStore $ \db -> createDirectContact db user conn' p
toView $ CRContactConnecting user ct toView $ CRContactConnecting user ct
pure conn' pure conn'
XGrpLinkInv glInv -> do [XGrpLinkInv glInv] -> do
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db user conn' glInv (gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db user conn' glInv
toView $ CRGroupLinkConnecting user gInfo host toView $ CRGroupLinkConnecting user gInfo host
pure conn' pure conn'
@ -5229,22 +5239,24 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
processForwardedMsg :: GroupMember -> ChatMessage 'Json -> m () processForwardedMsg :: GroupMember -> ChatMessage 'Json -> m ()
processForwardedMsg author chatMsg = do processForwardedMsg author chatMsg = do
let body = LB.toStrict $ J.encode msg let body = LB.toStrict $ J.encode msg
rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg rcvMsg@RcvMessage {chatMsgEvents} <- saveGroupFwdRcvMsg user groupId m author body chatMsg
case event of case chatMsgEvents of
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs [ACME _ event] -> case event of
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live
XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs
XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs
XInfo p -> xInfoMember gInfo author p XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId
XGrpMemNew memInfo -> xGrpMemNew gInfo author memInfo rcvMsg msgTs XInfo p -> xInfoMember gInfo author p
XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs XGrpMemNew memInfo -> xGrpMemNew gInfo author memInfo rcvMsg msgTs
XGrpMemDel memId -> xGrpMemDel gInfo author memId rcvMsg msgTs XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs
XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs XGrpMemDel memId -> xGrpMemDel gInfo author memId rcvMsg msgTs
XGrpDel -> xGrpDel gInfo author rcvMsg msgTs XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs
XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs XGrpDel -> xGrpDel gInfo author rcvMsg msgTs
_ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) 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 :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> m ()
directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do
@ -5532,12 +5544,12 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do
(msg,) <$> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId (msg,) <$> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
createSndMessage chatMsgEvent connOrGroupId = do createSndMessage cme connOrGroupId = do
gVar <- asks idsDrg gVar <- asks idsDrg
ChatConfig {chatVRange} <- asks config ChatConfig {chatVRange} <- asks config
withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId -> withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId ->
let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent = [cme]}
in NewMessage {chatMsgEvent, msgBody} in NewMessage {chatMsgEvents = [cme], msgBody}
sendBatchedDirectMessages :: (MsgEncodingI e, ChatMonad m) => Connection -> [ChatMsgEvent e] -> ConnOrGroupId -> m (SndMessage, Int64) sendBatchedDirectMessages :: (MsgEncodingI e, ChatMonad m) => Connection -> [ChatMsgEvent e] -> ConnOrGroupId -> m (SndMessage, Int64)
sendBatchedDirectMessages conn events connOrGroupId = do sendBatchedDirectMessages conn events connOrGroupId = do
@ -5558,17 +5570,16 @@ createBatchedSndMessage events connOrGroupId = do
-- - ChatMessage encoding should support list of ChatMsgEvents -- - ChatMessage encoding should support list of ChatMsgEvents
-- - * return list of SndMessages? it's not necessary for current use cases -- - * return list of SndMessages? it's not necessary for current use cases
withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId -> withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId ->
let chatMsgEvent = XOk -- dummy let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent = events}
msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} in NewMessage {chatMsgEvents = events, msgBody}
in NewMessage {chatMsgEvent, msgBody}
directMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString directMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
directMessage chatMsgEvent = do directMessage cme = do
ChatConfig {chatVRange} <- asks config 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 :: 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} let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
deliverMessage' conn msgFlags msgBody msgId 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 ACMsg _ ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} <- parseAChatMessage conn agentMsgMeta msgBody
conn' <- updatePeerChatVRange conn chatVRange conn' <- updatePeerChatVRange conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta let agentMsgId = fst $ recipient agentMsgMeta
newMsg = NewMessage {chatMsgEvent, msgBody} newMsg = NewMessage {chatMsgEvents = chatMsgEvent, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
pure (conn', msg) 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 saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do
(am', conn') <- updateMemberChatVRange authorMember conn chatVRange (am', conn') <- updateMemberChatVRange authorMember conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta let agentMsgId = fst $ recipient agentMsgMeta
newMsg = NewMessage {chatMsgEvent, msgBody} newMsg = NewMessage {chatMsgEvents = chatMsgEvent, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
amId = Just am'.groupMemberId amId = Just am'.groupMemberId
msg <- 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 :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage
saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do 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 fwdMemberId = Just $ groupMemberId' forwardingMember
refAuthorId = Just $ groupMemberId' refAuthorMember refAuthorId = Just $ groupMemberId' refAuthorMember
withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) 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' :: 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 saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do
createdAt <- liftIO getCurrentTime createdAt <- liftIO getCurrentTime
(ciId, quotedItem) <- withStore' $ \db -> do (ciId, quotedItem) <- withStore $ \db -> do
when (ciRequiresAttention content) $ updateChatTs db user cd createdAt when (ciRequiresAttention content) $ liftIO $ updateChatTs db user cd createdAt
(ciId, quotedItem) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs 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) pure (ciId, quotedItem)
liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs forwardedByMember createdAt liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs forwardedByMember createdAt

4
src/Simplex/Chat/Messages.hs
View File

@ -767,7 +767,7 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
Nothing -> Left "bad chat type" Nothing -> Left "bad chat type"
data NewMessage e = NewMessage data NewMessage e = NewMessage
{ chatMsgEvent :: ChatMsgEvent e, { chatMsgEvents :: [ChatMsgEvent e],
msgBody :: MsgBody msgBody :: MsgBody
} }
deriving (Show) deriving (Show)
@ -780,7 +780,7 @@ data SndMessage = SndMessage
data RcvMessage = RcvMessage data RcvMessage = RcvMessage
{ msgId :: MessageId, { msgId :: MessageId,
chatMsgEvent :: AChatMsgEvent, chatMsgEvents :: [AChatMsgEvent],
sharedMsgId_ :: Maybe SharedMsgId, sharedMsgId_ :: Maybe SharedMsgId,
msgBody :: MsgBody, msgBody :: MsgBody,
authorMember :: Maybe GroupMemberId, authorMember :: Maybe GroupMemberId,

40
src/Simplex/Chat/Protocol.hs
View File

@ -133,6 +133,14 @@ data AppMessageJson = AppMessageJson
params :: J.Object params :: J.Object
} }
-- TODO [batch send] AppBatchMessageJson?
-- data AppMessageJson = AppMessageJson
-- { v :: Maybe ChatVersionRange,
-- msgId :: Maybe SharedMsgId,
-- event :: Text,
-- params :: J.Object
-- }
data AppMessageBinary = AppMessageBinary data AppMessageBinary = AppMessageBinary
{ msgId :: Maybe SharedMsgId, { msgId :: Maybe SharedMsgId,
tag :: Char, tag :: Char,
@ -207,7 +215,7 @@ $(JQ.deriveJSON defaultJSON ''LinkPreview)
data ChatMessage e = ChatMessage data ChatMessage e = ChatMessage
{ chatVRange :: VersionRange, { chatVRange :: VersionRange,
msgId :: Maybe SharedMsgId, msgId :: Maybe SharedMsgId,
chatMsgEvent :: ChatMsgEvent e chatMsgEvent :: [ChatMsgEvent e]
} }
deriving (Eq, Show) deriving (Eq, Show)
@ -285,8 +293,10 @@ isForwardedGroupMsg ev = case ev of
_ -> False _ -> False
forwardedGroupMsg :: forall e. MsgEncodingI e => ChatMessage e -> Maybe (ChatMessage 'Json) forwardedGroupMsg :: forall e. MsgEncodingI e => ChatMessage e -> Maybe (ChatMessage 'Json)
forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case chatMsgEvent of
SJson | isForwardedGroupMsg chatMsgEvent -> Just msg [cme] -> case encoding @e of
SJson | isForwardedGroupMsg cme -> Just msg
_ -> Nothing
_ -> Nothing _ -> Nothing
data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} 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 -> Either String (ChatMessage 'Binary)
appBinaryToCM AppMessageBinary {msgId, tag, body} = do appBinaryToCM AppMessageBinary {msgId, tag, body} = do
eventTag <- strDecode $ B.singleton tag eventTag <- strDecode $ B.singleton tag
chatMsgEvent <- parseAll (msg eventTag) body cme <- parseAll (msg eventTag) body
pure ChatMessage {chatVRange = chatInitialVRange, msgId, chatMsgEvent} pure ChatMessage {chatVRange = chatInitialVRange, msgId, chatMsgEvent = [cme]}
where where
msg :: CMEventTag 'Binary -> A.Parser (ChatMsgEvent 'Binary) msg :: CMEventTag 'Binary -> A.Parser (ChatMsgEvent 'Binary)
msg = \case msg = \case
@ -801,8 +811,8 @@ appBinaryToCM AppMessageBinary {msgId, tag, body} = do
appJsonToCM :: AppMessageJson -> Either String (ChatMessage 'Json) appJsonToCM :: AppMessageJson -> Either String (ChatMessage 'Json)
appJsonToCM AppMessageJson {v, msgId, event, params} = do appJsonToCM AppMessageJson {v, msgId, event, params} = do
eventTag <- strDecode $ encodeUtf8 event eventTag <- strDecode $ encodeUtf8 event
chatMsgEvent <- msg eventTag cme <- msg eventTag
pure ChatMessage {chatVRange = maybe chatInitialVRange fromChatVRange v, msgId, chatMsgEvent} pure ChatMessage {chatVRange = maybe chatInitialVRange fromChatVRange v, msgId, chatMsgEvent = [cme]}
where where
p :: FromJSON a => J.Key -> Either String a p :: FromJSON a => J.Key -> Either String a
p key = JT.parseEither (.: key) params 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)] (.=?) :: ToJSON v => JT.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)]
key .=? value = maybe id ((:) . (key .=)) value key .=? value = maybe id ((:) . (key .=)) value
-- TODO [batch send]
chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e
chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @e of chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case chatMsgEvent of
SBinary -> [cme] -> case encoding @e of
let (binaryMsgId, body) = toBody chatMsgEvent SBinary ->
in AMBinary AppMessageBinary {msgId = binaryMsgId, tag = B.head $ strEncode tag, body} let (binaryMsgId, body) = toBody cme
SJson -> AMJson AppMessageJson {v = Just $ ChatVersionRange chatVRange, msgId, event = textEncode tag, params = params chatMsgEvent} 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 where
tag = toCMEventTag chatMsgEvent
o :: [(J.Key, J.Value)] -> J.Object o :: [(J.Key, J.Value)] -> J.Object
o = JM.fromList o = JM.fromList
toBody :: ChatMsgEvent 'Binary -> (Maybe SharedMsgId, ByteString) toBody :: ChatMsgEvent 'Binary -> (Maybe SharedMsgId, ByteString)

29
src/Simplex/Chat/Store/Messages.hs
View File

@ -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 :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId mkMessage = createNewSndMessage db gVar connOrGroupId mkMessage =
createWithRandomId gVar $ \sharedMsgId -> do createWithRandomId gVar $ \sharedMsgId -> do
let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId let NewMessage {chatMsgEvents, msgBody} = mkMessage $ SharedMsgId sharedMsgId
tag = eventsTag chatMsgEvents
createdAt <- getCurrentTime createdAt <- getCurrentTime
DB.execute DB.execute
db db
@ -170,10 +171,15 @@ createNewSndMessage db gVar connOrGroupId mkMessage =
shared_msg_id, shared_msg_id_user, created_at, updated_at shared_msg_id, shared_msg_id_user, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?) ) 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 msgId <- insertedRowId db
pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody} pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody}
where 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 (connId_, groupId_) = case connOrGroupId of
ConnectionId connId -> (Just connId, Nothing) ConnectionId connId -> (Just connId, Nothing)
GroupId groupId -> (Nothing, Just groupId) GroupId groupId -> (Nothing, Just groupId)
@ -199,7 +205,7 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs
pure msg pure msg
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage 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 case connOrGroupId of
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
GroupId groupId -> case sharedMsgId_ of GroupId groupId -> case sharedMsgId_ of
@ -222,6 +228,7 @@ createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMs
|] |]
(groupId, sharedMsgId) (groupId, sharedMsgId)
insertRcvMsg connId_ groupId_ = do insertRcvMsg connId_ groupId_ = do
let tag = eventsTag chatMsgEvents
currentTs <- getCurrentTime currentTs <- getCurrentTime
DB.execute DB.execute
db 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) (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 (?,?,?,?,?,?,?,?,?,?) 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 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.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do 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 (Just GroupMember {memberId}) -> (Just False, Just memberId)
CIQGroupRcv Nothing -> (Just False, Nothing) 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.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, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = do 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 ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs forwardedByMember createdAt
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
pure (ciId, quotedItem) pure (ciId, quotedItem)
where where
quotedMsg = cmToQuotedMsg chatMsgEvent quotedMsg = cmToQuotedMsg cme
quoteRow :: NewQuoteRow quoteRow :: NewQuoteRow
quoteRow = case quotedMsg of quoteRow = case quotedMsg of
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
@ -380,6 +392,7 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw
CDDirectRcv _ -> (Just $ not sent, Nothing) CDDirectRcv _ -> (Just $ not sent, Nothing)
CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ ->
(Just $ Just userMemberId == memberId, memberId) (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 :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection ciContent itemTs = createNewChatItemNoMsg db user chatDirection ciContent itemTs =

1
src/Simplex/Chat/Store/Shared.hs
View File

@ -93,6 +93,7 @@ data StoreError
| SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId} | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
| SEChatItemNotFoundByFileId {fileId :: FileTransferId} | SEChatItemNotFoundByFileId {fileId :: FileTransferId}
| SEChatItemNotFoundByGroupId {groupId :: GroupId} | SEChatItemNotFoundByGroupId {groupId :: GroupId}
| SECantCreateBatchedEventsChatItem
| SEProfileNotFound {profileId :: Int64} | SEProfileNotFound {profileId :: Int64}
| SEDuplicateGroupLink {groupInfo :: GroupInfo} | SEDuplicateGroupLink {groupInfo :: GroupInfo}
| SEGroupLinkNotFound {groupInfo :: GroupInfo} | SEGroupLinkNotFound {groupInfo :: GroupInfo}

26
tests/ProtocolTests.hs
View File

@ -76,10 +76,10 @@ s ##==## msg = do
s ==## msg s ==## msg
(==#) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation (==#) :: 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 (#==) :: 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 (#==#) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation
s #==# msg = do 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)) #==# 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" $ it "x.msg.new chat message" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" "{\"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" $ 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\"}}}" "{\"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" $ 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\"}}}}" "{\"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 ##==## ChatMessage
chatInitialVRange chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4") (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" $ 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}}" "{\"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 ##==## ChatMessage
chatInitialVRange chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4") (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" $ 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}}" "{\"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 ##==## ChatMessage
chatInitialVRange chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4") (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" $ it "x.msg.new forward" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}" "{\"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" $ 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}}" "{\"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" $ 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}}" "{\"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" $ 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\"}}}" "{\"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}))) #==# 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 ##==## ChatMessage
chatInitialVRange chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4") (Just $ SharedMsgId "\1\2\3\4")
( XMsgNew [ XMsgNew
( MCQuote ( MCQuote
quotedMsg quotedMsg
( extMsgContent ( 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}) (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})
) )
) )
) ]
it "x.msg.new forward with file" $ 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\"}}}" "{\"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" $ it "x.msg.update" $
"{\"v\":\"1\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" "{\"v\":\"1\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing Nothing #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing Nothing