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

core: group message forwarding (#3360)

Browse Source 
* core: group message forwarding types

* xgrpmemcon

* rework xgrpmemcon to use intros table

* only forward w/t error

* forward msg

* xGrpMsgForward, check integrity outside

* deduplicate group messages

* test

* change error

* item forwarded flag

* intro_chat_protocol_version, bump version

* comment

* highly available client option

* more comments

* notify xgrpmemcon on deduplication

* member vrange

* encoding

* remove MsgForward

* remove import

* exclude files from forwarding

* refactor

* rename to align with protocol

* forward more message types

* add events

* remove unused error, function

* add x.file.cancel, x.info and x.grp.mem.new to forwarded messages

* remove unused x.msg.file.cancel

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
spaced4ndy 2023-11-18 21:52:01 +04:00 committed by GitHub
parent 79064e149a
commit c0e8740f50
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
19 changed files with 936 additions and 339 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
simplex-chat.cabal
View File

@ -120,6 +120,7 @@ library
Simplex.Chat.Migrations.M20231019_indexes
Simplex.Chat.Migrations.M20231030_xgrplinkmem_received
Simplex.Chat.Migrations.M20231107_indexes
Simplex.Chat.Migrations.M20231113_group_forward
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared

519
src/Simplex/Chat.hs
View File

@ -32,6 +32,7 @@ import Data.Bifunctor (bimap, first)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char
import Data.Constraint (Dict (..))
import Data.Either (fromRight, rights)
@ -144,7 +145,8 @@ defaultChatConfig =
cleanupManagerInterval = 30 * 60, -- 30 minutes
cleanupManagerStepDelay = 3 * 1000000, -- 3 seconds
ciExpirationInterval = 30 * 60 * 1000000, -- 30 minutes
coreApi = False
coreApi = False,
highlyAvailable = False
}
_defaultSMPServers :: NonEmpty SMPServerWithAuth
@ -188,9 +190,9 @@ createChatDatabase filePrefix key confirmMigrations = runExceptT $ do
pure ChatDatabase {chatStore, agentStore}
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> IO ChatController
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} = do
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable}
firstTime = dbNew chatStore
currentUser <- newTVarIO user
servers <- agentServers config
@ -1571,7 +1573,7 @@ processChatCommand = \case
gVar <- asks idsDrg
subMode <- chatReadVar subscriptionMode
(agentConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing subMode
member <- withStore $ \db -> createNewContactMember db gVar user groupId contact memRole agentConnId cReq subMode
member <- withStore $ \db -> createNewContactMember db gVar user gInfo contact memRole agentConnId cReq subMode
sendInvitation member cReq
pure $ CRSentGroupInvitation user gInfo contact member
Just member@GroupMember {groupMemberId, memberStatus, memberRole = mRole}
@ -3227,7 +3229,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
MSG meta _msgFlags msgBody -> do
cmdId <- createAckCmd conn
withAckMessage agentConnId cmdId meta $ do
(_conn', _) <- saveRcvMSG conn (ConnectionId connId) meta msgBody cmdId
(_conn', _) <- saveDirectRcvMSG conn meta cmdId msgBody
pure False
SENT msgId ->
sentMsgDeliveryEvent conn msgId
@ -3258,14 +3260,13 @@ 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}) <- saveRcvMSG conn (ConnectionId connId) msgMeta msgBody cmdId
(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
XMsgFileCancel sharedMsgId -> cancelMessageFile ct' sharedMsgId 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
@ -3342,10 +3343,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
forM_ groupId_ $ \groupId -> do
groupInfo <- withStore $ \db -> getGroupInfo db user groupId
subMode <- chatReadVar subscriptionMode
gVar <- asks idsDrg
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds (fromJVersionRange peerChatVRange) subMode
gVar <- asks idsDrg
withStore $ \db -> createNewContactMemberAsync db gVar user groupInfo ct gLinkMemRole groupConnIds (fromJVersionRange peerChatVRange) subMode
_ -> pure ()
Just (gInfo, m@GroupMember {activeConn}) ->
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
@ -3515,62 +3517,118 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
withStore' $ \db -> updateIntroStatus db introId GMIntroSent
_ -> do
-- TODO notify member who forwarded introduction - question - where it is stored? There is via_contact but probably there should be via_member in group_members table
let memCategory = memberCategory m
withStore' (\db -> getViaGroupContact db user m) >>= \case
Nothing -> do
notifyMemberConnected gInfo m Nothing
let connectedIncognito = memberIncognito membership
when (memberCategory m == GCPreMember) $ probeMatchingMemberContact m connectedIncognito
when (memCategory == GCPreMember) $ probeMatchingMemberContact m connectedIncognito
Just ct@Contact {activeConn} ->
forM_ activeConn $ \Connection {connStatus} ->
when (connStatus == ConnReady) $ do
notifyMemberConnected gInfo m $ Just ct
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
when (memCategory == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
sendXGrpMemCon memCategory
where
sendXGrpMemCon = \case
GCPreMember ->
forM_ (invitedByGroupMemberId membership) $ \hostId -> do
host <- withStore $ \db -> getGroupMember db user groupId hostId
forM_ (memberConn host) $ \hostConn ->
void $ sendDirectMessage hostConn (XGrpMemCon m.memberId) (GroupId groupId)
GCPostMember ->
forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do
im <- withStore $ \db -> getGroupMember db user groupId invitingMemberId
forM_ (memberConn im) $ \imConn ->
void $ sendDirectMessage imConn (XGrpMemCon m.memberId) (GroupId groupId)
_ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected"
MSG msgMeta _msgFlags msgBody -> do
cmdId <- createAckCmd conn
withAckMessage agentConnId cmdId msgMeta $ do
(conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveRcvMSG conn (GroupId groupId) msgMeta msgBody cmdId
let m' = m {activeConn = Just conn'} :: GroupMember
updateChatLock "groupMessage" event
case event of
XMsgNew mc -> canSend m' $ newGroupContentMessage gInfo m' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr -> canSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr msgMeta
XMsgFileCancel sharedMsgId -> cancelGroupMessageFile gInfo m' sharedMsgId msgMeta
XMsgUpdate sharedMsgId mContent ttl live -> canSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg msgMeta ttl live
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg msgMeta
XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg msgMeta
-- TODO discontinue XFile
XFile fInv -> processGroupFileInvitation' gInfo m' fInv msg msgMeta
XFileCancel sharedMsgId -> xFileCancelGroup gInfo m' sharedMsgId msgMeta
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName msgMeta
-- XInfo p -> xInfoMember gInfo m' p -- TODO use for member profile update
XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p
XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg msgMeta
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 msgMeta
XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg msgMeta
XGrpLeave -> xGrpLeave gInfo m' msg msgMeta
XGrpDel -> xGrpDel gInfo m' msg msgMeta
XGrpInfo p' -> xGrpInfo gInfo m' p' msg msgMeta
XGrpDirectInv connReq mContent_ -> canSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg msgMeta
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)
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
let GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo
pure $
fromMaybe (sendRcptsSmallGroups user) sendRcpts
&& hasDeliveryReceipt (toCMEventTag event)
&& currentMemCount <= smallGroupsRcptsMemLimit
tryChatError (processChatMessage cmdId) >>= \case
Right (ACMsg _ chatMsg, withRcpt) -> do
ackMsg agentConnId cmdId msgMeta $ if withRcpt then Just "" else Nothing
when (membership.memberRole >= GRAdmin) $ forwardMsg_ chatMsg
Left e -> ackMsg agentConnId cmdId msgMeta Nothing >> throwError e
where
canSend :: GroupMember -> m () -> m ()
canSend mem a
| mem.memberRole <= GRObserver = messageError "member is not allowed to send messages"
| otherwise = a
processChatMessage :: Int64 -> m (AChatMessage, Bool)
processChatMessage cmdId = do
msg@(ACMsg _ chatMsg) <- parseAChatMessage conn msgMeta msgBody
checkIntegrity chatMsg `catchChatError` \_ -> pure ()
(msg,) <$> processEvent cmdId chatMsg
brokerTs = metaBrokerTs msgMeta
checkIntegrity :: ChatMessage e -> m ()
checkIntegrity ChatMessage {chatMsgEvent} = 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
_ -> 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
checkSendRcpt :: ChatMsgEvent e -> m Bool
checkSendRcpt event = do
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
let GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo
pure $
fromMaybe (sendRcptsSmallGroups user) sendRcpts
&& hasDeliveryReceipt (toCMEventTag event)
&& currentMemCount <= smallGroupsRcptsMemLimit
forwardMsg_ :: MsgEncodingI e => ChatMessage e -> m ()
forwardMsg_ chatMsg =
forM_ (forwardedGroupMsg chatMsg) $ \chatMsg' -> do
ChatConfig {highlyAvailable} <- asks config
-- members introduced to this invited member
introducedMembers <- if memberCategory m == GCInviteeMember
then withStore' $ \db -> getForwardIntroducedMembers db user m highlyAvailable
else pure []
-- invited members to which this member was introduced
invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db user m highlyAvailable
let ms = introducedMembers <> invitedMembers
msg = XGrpMsgForward m.memberId chatMsg' brokerTs
unless (null ms) $
void $ sendGroupMessage user gInfo ms msg
RCVD msgMeta msgRcpt ->
withAckMessage' agentConnId conn msgMeta $
groupMsgReceived gInfo m conn msgMeta msgRcpt
@ -3829,6 +3887,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> toView $ CRReceivedContactRequest user cReq
_ -> pure ()
memberCanSend :: GroupMember -> m () -> m ()
memberCanSend mem a
| mem.memberRole <= GRObserver = messageError "member is not allowed to send messages"
| otherwise = a
incAuthErrCounter :: ConnectionEntity -> Connection -> AgentErrorType -> m ()
incAuthErrCounter connEntity conn err = do
case err of
@ -3872,7 +3935,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
withAckMessage cId cmdId msgMeta $ action $> False
withAckMessage :: ConnId -> CommandId -> MsgMeta -> m Bool -> m ()
withAckMessage cId cmdId MsgMeta {recipient = (msgId, _)} action = do
withAckMessage cId cmdId msgMeta action = do
-- [async agent commands] command should be asynchronous, continuation is ackMsgDeliveryEvent
-- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user).
-- Possible solutions are:
@ -3880,10 +3943,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- 2) stabilize database
-- 3) show screen of death to the user asking to restart
tryChatError action >>= \case
Right withRcpt -> ack $ if withRcpt then Just "" else Nothing
Left e -> ack Nothing >> throwError e
where
ack rcpt = withAgent $ \a -> ackMessageAsync a (aCorrId cmdId) cId msgId rcpt
Right withRcpt -> ackMsg cId cmdId msgMeta $ if withRcpt then Just "" else Nothing
Left e -> ackMsg cId cmdId msgMeta Nothing >> throwError e
ackMsg :: ConnId -> CommandId -> MsgMeta -> Maybe MsgReceiptInfo -> m ()
ackMsg cId cmdId MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a (aCorrId cmdId) cId msgId rcpt
ackMsgDeliveryEvent :: Connection -> CommandId -> m ()
ackMsgDeliveryEvent Connection {connId} ackCmdId =
@ -4003,8 +4067,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
autoAcceptFile file_
where
brokerTs = metaBrokerTs msgMeta
newChatItem ciContent ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions})
@ -4019,8 +4084,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId
processFDMessage fileId fileDescr
groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> MsgMeta -> m ()
groupMessageFileDescription GroupInfo {groupId} _m sharedMsgId fileDescr _msgMeta = do
groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> m ()
groupMessageFileDescription GroupInfo {groupId} _m sharedMsgId fileDescr = do
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
processFDMessage fileId fileDescr
@ -4038,17 +4103,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
(RFSAccepted _, Just XFTPRcvFile {}) -> receiveViaCompleteFD user fileId rfd cryptoArgs
_ -> pure ()
cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m ()
cancelMessageFile ct _sharedMsgId msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
-- find the original chat item and file
-- mark file as cancelled, remove description if exists
pure ()
cancelGroupMessageFile :: GroupInfo -> GroupMember -> SharedMsgId -> MsgMeta -> m ()
cancelGroupMessageFile _gInfo _m _sharedMsgId _msgMeta = do
pure ()
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> m (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv@FileInvitation {fileName, fileSize} -> do
ChatConfig {fileChunkSize} <- asks config
@ -4075,13 +4129,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvContactCITimed ct ttl
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta content Nothing timed_ live
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs content Nothing timed_ live
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
updateDirectChatItem' db user contactId ci content live Nothing
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
where
MsgMeta {broker = (_, brokerTs)} = msgMeta
brokerTs = metaBrokerTs msgMeta
content = CIRcvMsgContent mc
live = fromMaybe False live_
updateRcvChatItem = do
@ -4136,8 +4190,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
else pure Nothing
mapM_ toView cr_
groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> MsgReaction -> Bool -> RcvMessage -> MsgMeta -> m ()
groupMsgReaction g@GroupInfo {groupId} m sharedMsgId itemMemberId reaction add RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do
groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> m ()
groupMsgReaction g@GroupInfo {groupId} m sharedMsgId itemMemberId reaction add RcvMessage {msgId} brokerTs = do
when (groupFeatureAllowed SGFReactions g) $ do
rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False
when (reactionAllowed add reaction rs) $ do
@ -4166,8 +4220,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId
e -> throwError e
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> m ()
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
| otherwise = do
@ -4187,38 +4241,37 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
| moderatorRole < GRAdmin || moderatorRole < memberRole =
createItem timed_ live
| groupFeatureAllowed SGFFullDelete gInfo = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed_ False
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci'
| otherwise = do
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed_ False
toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt
createItem timed_ live = do
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
when (showMessages $ memberSettings m) $ autoAcceptFile file_
newChatItem ciContent ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
groupMsgToView gInfo m ci' {reactions} msgMeta
groupMsgToView gInfo ci' {reactions}
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> m ()
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} brokerTs ttl_ live_ =
updateRcvChatItem `catchCINotFound` \_ -> do
-- This patches initial sharedMsgId into chat item when locally deleted chat item
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs content Nothing timed_ live
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
ci' <- updateGroupChatItem db user groupId ci content live Nothing
blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci'
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
where
MsgMeta {broker = (_, brokerTs)} = msgMeta
content = CIRcvMsgContent mc
live = fromMaybe False live_
updateRcvChatItem = do
@ -4241,8 +4294,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
else messageError "x.msg.update: group member attempted to update a message of another member"
_ -> messageError "x.msg.update: group member attempted invalid message update"
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> MsgMeta -> m ()
groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> UTCTime -> m ()
groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} brokerTs = do
let msgMemberId = fromMaybe memberId sndMemberId_
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case
Right (CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of
@ -4279,20 +4332,22 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
where
brokerTs = metaBrokerTs msgMeta
-- TODO remove once XFile is discontinued
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> m ()
processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} brokerTs = do
ChatConfig {fileChunkSize} <- asks config
inline <- receiveInlineMode fInv Nothing fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
groupMsgToView gInfo m ci' msgMeta
groupMsgToView gInfo ci'
blockedMember :: Monad m' => GroupMember -> ChatItem c d -> m' (ChatItem c d) -> m' (ChatItem c d)
blockedMember m ci blockedCI
@ -4399,9 +4454,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> pure ()
receiveFileChunk ft Nothing meta chunk
xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> MsgMeta -> m ()
xFileCancelGroup g@GroupInfo {groupId} mem@GroupMember {groupMemberId, memberId} sharedMsgId msgMeta = do
checkIntegrityCreateItem (CDGroupRcv g mem) msgMeta
xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> m ()
xFileCancelGroup GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId = do
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
CChatItem msgDir ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
case (msgDir, chatDir) of
@ -4416,9 +4470,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id
(SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel"
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInvGroup g@GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName msgMeta = do
checkIntegrityCreateItem (CDGroupRcv g m) msgMeta
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> m ()
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId
assertSMPAcceptNotProhibited ci
@ -4447,9 +4500,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> messageError "x.file.acpt.inv: member connection is not active"
else messageError "x.file.acpt.inv: fileName is different from expected"
groupMsgToView :: GroupInfo -> GroupMember -> ChatItem 'CTGroup 'MDRcv -> MsgMeta -> m ()
groupMsgToView gInfo m ci msgMeta = do
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta
groupMsgToView :: GroupInfo -> ChatItem 'CTGroup 'MDRcv -> m ()
groupMsgToView gInfo ci =
toView $ CRNewChatItem user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
@ -4475,11 +4527,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
else do
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content
ci <- saveRcvChatItem user (CDDirectRcv ct) msg brokerTs content
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
where
brokerTs = metaBrokerTs msgMeta
sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
sameGroupLinkId (Just gli) (Just gli') = gli == gli'
sameGroupLinkId _ _ = False
@ -4503,13 +4556,15 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted}
let ct'' = ct' {activeConn = activeConn'} :: Contact
ci <- saveRcvChatItem user (CDDirectRcv ct'') msg msgMeta (CIRcvDirectEvent RDEContactDeleted)
ci <- saveRcvChatItem user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci)
toView $ CRContactDeletedByContact user ct''
else do
contactConns <- withStore' $ \db -> getContactConnections db userId c
deleteAgentConnectionsAsync user $ map aConnId contactConns
withStore' $ \db -> deleteContact db user c
where
brokerTs = metaBrokerTs msgMeta
processContactProfileUpdate :: Contact -> Profile -> Bool -> m Contact
processContactProfileUpdate c@Contact {profile = p} p' createItems
@ -4540,9 +4595,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
| otherwise -> Nothing
in setPreference_ SCFTimedMessages ctUserTMPref' ctUserPrefs
-- TODO use for member profile update
-- xInfoMember :: GroupInfo -> GroupMember -> Profile -> m ()
-- xInfoMember gInfo m p' = void $ processMemberProfileUpdate gInfo m p'
xInfoMember :: GroupInfo -> GroupMember -> Profile -> m ()
xInfoMember gInfo m p' = void $ processMemberProfileUpdate gInfo m p'
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> m ()
xGrpLinkMem gInfo@GroupInfo {membership} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do
@ -4674,9 +4728,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRNewChatItem user $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
else featureRejected CFCalls
where
saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvCall status 0)
brokerTs = metaBrokerTs msgMeta
saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0)
featureRejected f = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvChatFeatureRejected f) Nothing Nothing False
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvChatFeatureRejected f) Nothing Nothing False
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
-- to party initiating call
@ -4835,21 +4890,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- TODO show/log error, other events in SMP confirmation
_ -> pure conn'
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> MsgMeta -> m ()
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ memberProfile) msg msgMeta = do
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> UTCTime -> m ()
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ memberProfile) msg brokerTs = do
checkHostRole m memRole
members <- withStore' $ \db -> getGroupMembers db user gInfo
unless (sameMemberId memId $ membership gInfo) $
if isMember memId gInfo members
then messageError "x.grp.mem.new error: member already exists"
else do
newMember@GroupMember {groupMemberId} <- withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile)
groupMsgToView gInfo m ci msgMeta
newMember@GroupMember {groupMemberId} <- withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile)
groupMsgToView gInfo ci
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) = do
case memberCategory m of
GCHostMember -> do
members <- withStore' $ \db -> getGroupMembers db user gInfo
@ -4860,7 +4915,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
subMode <- chatReadVar subscriptionMode
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
groupConnIds <- createConn subMode
directConnIds <- case memberChatVRange of
directConnIds <- case memChatVRange of
Nothing -> Just <$> createConn subMode
Just mcvr
| isCompatibleRange (fromChatVRange mcvr) groupNoDirectVRange -> pure Nothing
@ -4892,7 +4947,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
checkHostRole m memRole
members <- withStore' $ \db -> getGroupMembers db user gInfo
toMember <- case find (sameMemberId memId) members of
@ -4900,7 +4955,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- the situation when member does not exist is an error
-- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
-- For now, this branch compensates for the lack of delayed message delivery.
Nothing -> withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced
Nothing -> withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced
Just m' -> pure m'
withStore' $ \db -> saveMemberInvitation db toMember introInv
subMode <- chatReadVar subscriptionMode
@ -4910,11 +4965,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
groupConnIds <- joinAgentConnectionAsync user (chatHasNtfs chatSettings) groupConnReq dm subMode
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user True dcr dm subMode
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId subMode
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> MsgMeta -> m ()
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg msgMeta
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> m ()
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs
| membership.memberId == memId =
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
in changeMemberRole gInfo' membership $ RGEUserRole memRole
@ -4928,16 +4983,54 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
| senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions"
| otherwise = do
withStore' $ \db -> updateGroupMemberRole db user member memRole
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent)
groupMsgToView gInfo m ci msgMeta
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
groupMsgToView gInfo ci
toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole}
checkHostRole :: GroupMember -> GroupMemberRole -> m ()
checkHostRole GroupMember {memberRole, localDisplayName} memRole =
when (memberRole < GRAdmin || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName)
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> MsgMeta -> m ()
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg msgMeta = do
xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> m ()
xGrpMemCon gInfo sendingMember memId = do
refMember <- withStore $ \db -> getGroupMemberByMemberId db user gInfo memId
case (memberCategory sendingMember, memberCategory refMember) of
(GCInviteeMember, GCInviteeMember) ->
withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case
Right intro -> inviteeXGrpMemCon intro
Left _ -> withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case
Right intro -> forwardMemberXGrpMemCon intro
Left _ -> messageWarning "x.grp.mem.con: no introduction"
(GCInviteeMember, _) ->
withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case
Right intro -> inviteeXGrpMemCon intro
Left _ -> messageWarning "x.grp.mem.con: no introduction"
(_, GCInviteeMember) ->
withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case
Right intro -> forwardMemberXGrpMemCon intro
Left _ -> messageWarning "x.grp.mem.con: no introductiosupportn"
-- Note: we can allow XGrpMemCon to all member categories if we decide to support broader group forwarding,
-- deduplication (see saveGroupRcvMsg, saveGroupFwdRcvMsg) already supports sending XGrpMemCon
-- to any forwarding member, not only host/inviting member;
-- database would track all members connections then
-- (currently it's done via group_member_intros for introduced connections only)
_ ->
messageWarning "x.grp.mem.con: neither member is invitee"
where
inviteeXGrpMemCon :: GroupMemberIntro -> m ()
inviteeXGrpMemCon GroupMemberIntro {introId, introStatus}
| introStatus == GMIntroReConnected = updateStatus introId GMIntroConnected
| introStatus `elem` [GMIntroToConnected, GMIntroConnected] = pure ()
| otherwise = updateStatus introId GMIntroToConnected
forwardMemberXGrpMemCon :: GroupMemberIntro -> m ()
forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus}
| introStatus == GMIntroToConnected = updateStatus introId GMIntroConnected
| introStatus `elem` [GMIntroReConnected, GMIntroConnected] = pure ()
| otherwise = updateStatus introId GMIntroReConnected
updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> m ()
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg brokerTs = do
members <- withStore' $ \db -> getGroupMembers db user gInfo
if membership.memberId == memId
then checkRole membership $ do
@ -4963,23 +5056,20 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
messageError "x.grp.mem.del with insufficient member permissions"
| otherwise = a
deleteMemberItem gEvent = do
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent)
groupMsgToView gInfo m ci msgMeta
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
groupMsgToView gInfo ci
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> MsgMeta -> m ()
xGrpLeave gInfo m msg msgMeta = do
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> m ()
xGrpLeave gInfo m msg brokerTs = do
deleteMemberConnection user m
-- member record is not deleted to allow creation of "member left" chat item
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEMemberLeft)
groupMsgToView gInfo m ci msgMeta
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEMemberLeft)
groupMsgToView gInfo ci
toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft}
xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> MsgMeta -> m ()
xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg msgMeta = do
xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> m ()
xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do
when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner
ms <- withStore' $ \db -> do
members <- getGroupMembers db user gInfo
@ -4987,24 +5077,24 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
pure members
-- member records are not deleted to keep history
deleteMembersConnections user ms
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEGroupDeleted)
groupMsgToView gInfo m ci msgMeta
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEGroupDeleted)
groupMsgToView gInfo ci
toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m
xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> MsgMeta -> m ()
xGrpInfo g@GroupInfo {groupProfile = p} m@GroupMember {memberRole} p' msg msgMeta
xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> m ()
xGrpInfo g@GroupInfo {groupProfile = p} m@GroupMember {memberRole} p' msg brokerTs
| memberRole < GROwner = messageError "x.grp.info with insufficient member permissions"
| otherwise = unless (p == p') $ do
g' <- withStore $ \db -> updateGroupProfile db user g p'
toView $ CRGroupUpdated user g g' (Just m)
let cd = CDGroupRcv g' m
unless (sameGroupProfileInfo p p') $ do
ci <- saveRcvChatItem user cd msg msgMeta (CIRcvGroupEvent $ RGEGroupUpdated p')
groupMsgToView g' m ci msgMeta
ci <- saveRcvChatItem user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p')
groupMsgToView g' ci
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'
xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> MsgMeta -> m ()
xGrpDirectInv g m mConn connReq mContent_ msg msgMeta = do
xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> m ()
xGrpDirectInv g m mConn connReq mContent_ msg brokerTs = do
unless (groupFeatureAllowed SGFDirectMessages g) $ messageError "x.grp.direct.inv: direct messages not allowed"
let GroupMember {memberContactId} = m
subMode <- chatReadVar subscriptionMode
@ -5040,11 +5130,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
dm <- directMessage $ XInfo p
joinAgentConnectionAsync user True connReq dm subMode
createItems mCt' m' = do
checkIntegrityCreateItem (CDGroupRcv g m') msgMeta
createInternalChatItem user (CDGroupRcv g m') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing
toView $ CRNewMemberContactReceivedInv user mCt' g m'
forM_ mContent_ $ \mc -> do
ci <- saveRcvChatItem user (CDDirectRcv mCt') msg msgMeta (CIRcvMsgContent mc)
ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat mCt') ci)
securityCodeChanged :: Contact -> m ()
@ -5052,6 +5141,33 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRContactVerificationReset user ct
createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing
xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> m ()
xGrpMsgForward gInfo@GroupInfo {groupId} m memberId msg msgTs = do
when (m.memberRole < GRAdmin) $ throwChatError (CEGroupContactRole m.localDisplayName)
author <- withStore $ \db -> getGroupMemberByMemberId db user gInfo memberId
processForwardedMsg author msg
where
-- Note: forwarded group events (see forwardedGroupMsg) should include msgId to be deduplicated
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)
directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> m ()
directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
@ -5100,6 +5216,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRChatItemStatusUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) chatItem)
_ -> pure ()
metaBrokerTs :: MsgMeta -> UTCTime
metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
updatePeerChatVRange :: ChatMonad m => Connection -> VersionRange -> m Connection
updatePeerChatVRange conn@Connection {connId, peerChatVRange} msgChatVRange = do
let jMsgChatVRange = JVersionRange msgChatVRange
@ -5109,6 +5231,18 @@ updatePeerChatVRange conn@Connection {connId, peerChatVRange} msgChatVRange = do
pure conn {peerChatVRange = jMsgChatVRange}
else pure conn
updateMemberChatVRange :: ChatMonad m => GroupMember -> Connection -> VersionRange -> m (GroupMember, Connection)
updateMemberChatVRange mem@GroupMember {groupMemberId} conn@Connection {connId, peerChatVRange} msgChatVRange = do
let jMsgChatVRange = JVersionRange msgChatVRange
if jMsgChatVRange /= peerChatVRange
then do
withStore' $ \db -> do
setPeerChatVRange db connId msgChatVRange
setMemberChatVRange db groupMemberId msgChatVRange
let conn' = conn {peerChatVRange = jMsgChatVRange}
pure (mem {memberChatVRange = jMsgChatVRange, activeConn = Just conn'}, conn')
else pure (mem, conn)
parseFileDescription :: (ChatMonad m, FilePartyI p) => Text -> m (ValidFileDescription p)
parseFileDescription =
liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8)
@ -5357,18 +5491,36 @@ sendGroupMessage' user members chatMsgEvent groupId introId_ postDeliver = do
where
messageMember :: GroupMember -> SndMessage -> m (Maybe GroupMember)
messageMember m@GroupMember {groupMemberId} SndMessage {msgId, msgBody} = case memberConn m of
Nothing -> do
withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_
pure $ Just m
Nothing -> pendingOrForwarded
Just conn@Connection {connStatus}
| connDisabled conn || connStatus == ConnDeleted -> pure Nothing
| connStatus == ConnSndReady || connStatus == ConnReady -> do
let tag = toCMEventTag chatMsgEvent
deliverMessage conn tag msgBody msgId >> postDeliver
pure $ Just m
| otherwise -> do
withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_
pure $ Just m
| otherwise -> pendingOrForwarded
where
pendingOrForwarded
| forwardSupported && isForwardedGroupMsg chatMsgEvent = pure Nothing
| isXGrpMsgForward chatMsgEvent = pure Nothing
| otherwise = do
withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_
pure $ Just m
forwardSupported = do
let mcvr = memberChatVRange' m
isCompatibleRange mcvr groupForwardVRange && invitingMemberSupportsForward
invitingMemberSupportsForward = case m.invitedByGroupMemberId of
Just invMemberId ->
-- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember
case find (\m' -> groupMemberId' m' == invMemberId) members of
Just invitingMember -> do
let mcvr = memberChatVRange' invitingMember
isCompatibleRange mcvr groupForwardVRange
Nothing -> False
Nothing -> False
isXGrpMsgForward ev = case ev of
XGrpMsgForward {} -> True
_ -> False
sendPendingGroupMessages :: ChatMonad m => User -> GroupMember -> Connection -> m ()
sendPendingGroupMessages user GroupMember {groupMemberId, localDisplayName} conn = do
@ -5386,18 +5538,49 @@ sendPendingGroupMessages user GroupMember {groupMemberId, localDisplayName} conn
_ -> throwChatError $ CEGroupMemberIntroNotFound localDisplayName
_ -> pure ()
saveRcvMSG :: ChatMonad m => Connection -> ConnOrGroupId -> MsgMeta -> MsgBody -> CommandId -> m (Connection, RcvMessage)
saveRcvMSG conn@Connection {connId} connOrGroupId agentMsgMeta msgBody agentAckCmdId = do
saveDirectRcvMSG :: ChatMonad m => Connection -> MsgMeta -> CommandId -> MsgBody -> m (Connection, RcvMessage)
saveDirectRcvMSG conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody = do
ACMsg _ ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} <- parseAChatMessage conn agentMsgMeta msgBody
conn' <- updatePeerChatVRange conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
newMsg = NewMessage {chatMsgEvent, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
msg <- withStoreCtx'
(Just $ "createNewMessageAndRcvMsgDelivery, rcvMsgDelivery: " <> show rcvMsgDelivery <> ", sharedMsgId_: " <> show sharedMsgId_ <> ", msgDeliveryStatus: MDSRcvAgent")
$ \db -> createNewMessageAndRcvMsgDelivery db connOrGroupId newMsg sharedMsgId_ rcvMsgDelivery
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
pure (conn', msg)
saveGroupRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> CommandId -> MsgBody -> ChatMessage e -> m (GroupMember, Connection, RcvMessage)
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}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
amId = Just am'.groupMemberId
msg <- withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery amId)
`catchChatError` \e -> case e of
ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do
fm <- withStore $ \db -> getGroupMember db user groupId forwardedByGroupMemberId
forM_ (memberConn fm) $ \fmConn ->
void $ sendDirectMessage fmConn (XGrpMemCon am'.memberId) (GroupId groupId)
throwError e
_ -> throwError e
pure (am', conn', msg)
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}
fwdMemberId = Just $ groupMemberId' forwardingMember
refAuthorId = Just $ groupMemberId' refAuthorMember
withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId)
`catchChatError` \e -> case e of
ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do
am <- withStore $ \db -> getGroupMember db user groupId authorGroupMemberId
if sameMemberId refAuthorMember.memberId am
then forM_ (memberConn forwardingMember) $ \fmConn ->
void $ sendDirectMessage fmConn (XGrpMemCon am.memberId) (GroupId groupId)
else toView $ CRMessageError user "error" "saveGroupFwdRcvMsg: referenced author member id doesn't match message member id"
throwError e
_ -> throwError e
saveSndChatItem :: ChatMonad m => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> m (ChatItem c 'MDSnd)
saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing False
@ -5409,27 +5592,27 @@ saveSndChatItem' user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem
ciId <- createNewSndChatItem db user cd msg content quotedItem itemTimed live createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure ciId
liftIO $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemTimed live createdAt createdAt
liftIO $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemTimed live createdAt Nothing createdAt
saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv)
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} msgMeta content =
saveRcvChatItem' user cd msg sharedMsgId_ msgMeta content Nothing Nothing False
saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv)
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False
saveRcvChatItem' :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> m (ChatItem c 'MDRcv)
saveRcvChatItem' user cd msg sharedMsgId_ MsgMeta {broker = (_, brokerTs)} content ciFile itemTimed live = do
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 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) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure (ciId, quotedItem)
liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs createdAt
liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs msg.forwardedByGroupMemberId createdAt
mkChatItem :: forall c d. MsgDirectionI d => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CITimed -> Bool -> ChatItemTs -> UTCTime -> IO (ChatItem c d)
mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs currentTs = do
mkChatItem :: forall c d. MsgDirectionI d => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> IO (ChatItem c d)
mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs forwardedByGroupMemberId currentTs = do
let itemText = ciContentToText content
itemStatus = ciCreateStatus content
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs currentTs currentTs
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByGroupMemberId currentTs currentTs
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
deleteDirectCI :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> m ChatResponse
@ -5592,7 +5775,7 @@ createInternalChatItem user cd content itemTs_ = do
ciId <- withStore' $ \db -> do
when (ciRequiresAttention content) $ updateChatTs db user cd createdAt
createNewChatItemNoMsg db user cd content itemTs createdAt
ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs createdAt
ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs Nothing createdAt
toView $ CRNewChatItem user (AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci)
getCreateActiveUser :: SQLiteStore -> Bool -> IO User

3
src/Simplex/Chat/Controller.hs
View File

@ -126,7 +126,8 @@ data ChatConfig = ChatConfig
cleanupManagerInterval :: NominalDiffTime,
cleanupManagerStepDelay :: Int64,
ciExpirationInterval :: Int64, -- microseconds
coreApi :: Bool
coreApi :: Bool,
highlyAvailable :: Bool
}
data DefaultAgentServers = DefaultAgentServers

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

@ -162,7 +162,7 @@ isMention ChatItem {chatDir, quotedItem} = case chatDir of
CIQDirectSnd -> True
CIQGroupSnd -> True
_ -> False
data CIDirection (c :: ChatType) (d :: MsgDirection) where
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
@ -341,17 +341,18 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
itemTimed :: Maybe CITimed,
itemLive :: Maybe Bool,
editable :: Bool,
forwardedByGroupMemberId :: Maybe GroupMemberId,
createdAt :: UTCTime,
updatedAt :: UTCTime
}
deriving (Show, Generic)
mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive currentTs itemTs createdAt updatedAt =
mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByGroupMemberId createdAt updatedAt =
let editable = case itemContent of
CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted
_ -> False
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, createdAt, updatedAt}
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, forwardedByGroupMemberId, createdAt, updatedAt}
instance ToJSON (CIMeta c d) where toEncoding = J.genericToEncoding J.defaultOptions
@ -814,7 +815,9 @@ data RcvMessage = RcvMessage
{ msgId :: MessageId,
chatMsgEvent :: AChatMsgEvent,
sharedMsgId_ :: Maybe SharedMsgId,
msgBody :: MsgBody
msgBody :: MsgBody,
authorGroupMemberId :: Maybe GroupMemberId,
forwardedByGroupMemberId :: Maybe GroupMemberId
}
data PendingGroupMessage = PendingGroupMessage

53
src/Simplex/Chat/Migrations/M20231113_group_forward.hs Normal file
View File

@ -0,0 +1,53 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20231113_group_forward where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20231113_group_forward :: Query
m20231113_group_forward =
[sql|
ALTER TABLE group_member_intros ADD COLUMN intro_chat_protocol_version INTEGER NOT NULL DEFAULT 3;
CREATE INDEX idx_group_member_intros_re_group_member_id ON group_member_intros(re_group_member_id);
ALTER TABLE group_members ADD COLUMN invited_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL;
ALTER TABLE group_members ADD COLUMN peer_chat_min_version INTEGER NOT NULL DEFAULT 1;
ALTER TABLE group_members ADD COLUMN peer_chat_max_version INTEGER NOT NULL DEFAULT 1;
CREATE INDEX idx_group_members_invited_by_group_member_id ON group_members(invited_by_group_member_id);
UPDATE group_members
SET (peer_chat_min_version, peer_chat_max_version) = (c.peer_chat_min_version, c.peer_chat_max_version)
FROM connections c
WHERE c.group_member_id = group_members.group_member_id;
ALTER TABLE messages ADD COLUMN author_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL;
ALTER TABLE messages ADD COLUMN forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL;
CREATE INDEX idx_messages_author_group_member_id ON messages(author_group_member_id);
CREATE INDEX idx_messages_forwarded_by_group_member_id ON messages(forwarded_by_group_member_id);
CREATE INDEX idx_messages_group_id_shared_msg_id ON messages(group_id, shared_msg_id);
ALTER TABLE chat_items ADD COLUMN forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL;
CREATE INDEX idx_chat_items_forwarded_by_group_member_id ON chat_items(forwarded_by_group_member_id);
|]
down_m20231113_group_forward :: Query
down_m20231113_group_forward =
[sql|
DROP INDEX idx_chat_items_forwarded_by_group_member_id;
ALTER TABLE chat_items DROP COLUMN forwarded_by_group_member_id;
DROP INDEX idx_messages_group_id_shared_msg_id;
DROP INDEX idx_messages_forwarded_by_group_member_id;
DROP INDEX idx_messages_author_group_member_id;
ALTER TABLE messages DROP COLUMN forwarded_by_group_member_id;
ALTER TABLE messages DROP COLUMN author_group_member_id;
DROP INDEX idx_group_members_invited_by_group_member_id;
ALTER TABLE group_members DROP COLUMN peer_chat_max_version;
ALTER TABLE group_members DROP COLUMN peer_chat_min_version;
ALTER TABLE group_members DROP COLUMN invited_by_group_member_id;
DROP INDEX idx_group_member_intros_re_group_member_id;
ALTER TABLE group_member_intros DROP COLUMN intro_chat_protocol_version;
|]

32
src/Simplex/Chat/Migrations/chat_schema.sql
View File

@ -147,6 +147,9 @@ CREATE TABLE group_members(
member_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL,
show_messages INTEGER NOT NULL DEFAULT 1,
xgrplinkmem_received INTEGER NOT NULL DEFAULT 0,
invited_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
peer_chat_min_version INTEGER NOT NULL DEFAULT 1,
peer_chat_max_version INTEGER NOT NULL DEFAULT 1,
FOREIGN KEY(user_id, local_display_name)
REFERENCES display_names(user_id, local_display_name)
ON DELETE CASCADE
@ -161,7 +164,8 @@ CREATE TABLE group_member_intros(
direct_queue_info BLOB,
intro_status TEXT NOT NULL,
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL), -- see GroupMemberIntroStatus
updated_at TEXT CHECK(updated_at NOT NULL),
intro_chat_protocol_version INTEGER NOT NULL DEFAULT 3, -- see GroupMemberIntroStatus
UNIQUE(re_group_member_id, to_group_member_id)
);
CREATE TABLE files(
@ -322,7 +326,9 @@ CREATE TABLE messages(
connection_id INTEGER DEFAULT NULL REFERENCES connections ON DELETE CASCADE,
group_id INTEGER DEFAULT NULL REFERENCES groups ON DELETE CASCADE,
shared_msg_id BLOB,
shared_msg_id_user INTEGER
shared_msg_id_user INTEGER,
author_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL
);
CREATE TABLE msg_deliveries(
msg_delivery_id INTEGER PRIMARY KEY,
@ -372,7 +378,8 @@ CREATE TABLE chat_items(
timed_delete_at TEXT,
item_live INTEGER,
item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
item_deleted_ts TEXT
item_deleted_ts TEXT,
forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL
);
CREATE TABLE chat_item_messages(
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
@ -752,3 +759,22 @@ CREATE INDEX idx_contact_profiles_contact_link ON contact_profiles(
user_id,
contact_link
);
CREATE INDEX idx_group_member_intros_re_group_member_id ON group_member_intros(
re_group_member_id
);
CREATE INDEX idx_group_members_invited_by_group_member_id ON group_members(
invited_by_group_member_id
);
CREATE INDEX idx_messages_author_group_member_id ON messages(
author_group_member_id
);
CREATE INDEX idx_messages_forwarded_by_group_member_id ON messages(
forwarded_by_group_member_id
);
CREATE INDEX idx_messages_group_id_shared_msg_id ON messages(
group_id,
shared_msg_id
);
CREATE INDEX idx_chat_items_forwarded_by_group_member_id ON chat_items(
forwarded_by_group_member_id
);

3
src/Simplex/Chat/Mobile.hs
View File

@ -152,7 +152,8 @@ mobileChatOpts dbFilePrefix dbKey =
logServerHosts = True,
logAgent = Nothing,
logFile = Nothing,
tbqSize = 1024
tbqSize = 1024,
highlyAvailable = False
},
chatCmd = "",
chatCmdDelay = 3,

11
src/Simplex/Chat/Options.hs
View File

@ -54,7 +54,8 @@ data CoreChatOpts = CoreChatOpts
logServerHosts :: Bool,
logAgent :: Maybe LogLevel,
logFile :: Maybe FilePath,
tbqSize :: Natural
tbqSize :: Natural,
highlyAvailable :: Bool
}
agentLogLevel :: ChatLogLevel -> LogLevel
@ -172,6 +173,11 @@ coreChatOptsP appDir defaultDbFileName = do
<> value 1024
<> showDefault
)
highlyAvailable <-
switch
( long "ha"
<> help "Run as a highly available client (this may increase traffic in groups)"
)
pure
CoreChatOpts
{ dbFilePrefix,
@ -184,7 +190,8 @@ coreChatOptsP appDir defaultDbFileName = do
logServerHosts = logServerHosts || logLevel <= CLLInfo,
logAgent = if logAgent || logLevel == CLLDebug then Just $ agentLogLevel logLevel else Nothing,
logFile,
tbqSize
tbqSize,
highlyAvailable
}
where
useTcpTimeout p t = 1000000 * if t > 0 then t else maybe 5 (const 10) p

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

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
@ -19,7 +20,7 @@ module Simplex.Chat.Protocol where
import Control.Applicative ((<|>))
import Control.Monad ((<=<))
import Data.Aeson (FromJSON, ToJSON, (.:), (.:?), (.=))
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.KeyMap as JM
@ -51,7 +52,7 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)
currentChatVersion :: Version
currentChatVersion = 3
currentChatVersion = 4
supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion
@ -68,6 +69,10 @@ xGrpDirectInvVRange = mkVersionRange 2 currentChatVersion
groupLinkNoContactVRange :: VersionRange
groupLinkNoContactVRange = mkVersionRange 3 currentChatVersion
-- version range that supports group forwarding
groupForwardVRange :: VersionRange
groupForwardVRange = mkVersionRange 4 currentChatVersion
data ConnectionEntity
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
@ -128,7 +133,7 @@ data AppMessageJson = AppMessageJson
event :: Text,
params :: J.Object
}
deriving (Generic, FromJSON)
deriving (Eq, Show, Generic, FromJSON)
data AppMessageBinary = AppMessageBinary
{ msgId :: Maybe SharedMsgId,
@ -208,7 +213,6 @@ instance StrEncoding AChatMessage where
data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
XMsgFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json
XMsgDeleted :: ChatMsgEvent 'Json
@ -230,13 +234,14 @@ data ChatMsgEvent (e :: MsgEncoding) where
XGrpMemFwd :: MemberInfo -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemInfo :: MemberId -> Profile -> ChatMsgEvent 'Json
XGrpMemRole :: MemberId -> GroupMemberRole -> ChatMsgEvent 'Json
XGrpMemCon :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
XGrpMemCon :: MemberId -> ChatMsgEvent 'Json
XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
XGrpMemDel :: MemberId -> ChatMsgEvent 'Json
XGrpLeave :: ChatMsgEvent 'Json
XGrpDel :: ChatMsgEvent 'Json
XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> ChatMsgEvent 'Json
XGrpMsgForward :: MemberId -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json
XInfoProbe :: Probe -> ChatMsgEvent 'Json
XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
XInfoProbeOk :: Probe -> ChatMsgEvent 'Json
@ -257,6 +262,30 @@ data AChatMsgEvent = forall e. MsgEncodingI e => ACME (SMsgEncoding e) (ChatMsgE
deriving instance Show AChatMsgEvent
isForwardedGroupMsg :: ChatMsgEvent e -> Bool
isForwardedGroupMsg ev = case ev of
XMsgNew mc -> case mcExtMsgContent mc of
ExtMsgContent {file = Just FileInvitation {fileInline = Just _}} -> False
_ -> True
XMsgFileDescr _ _ -> True
XMsgUpdate {} -> True
XMsgDel _ _ -> True
XMsgReact {} -> True
XFileCancel _ -> True
XInfo _ -> True
XGrpMemNew _ -> True
XGrpMemRole {} -> True
XGrpMemDel _ -> True -- TODO there should be a special logic when deleting host member (e.g., host forwards it before deleting connections)
XGrpLeave -> True
XGrpDel -> True -- TODO there should be a special logic - host should forward before deleting connections
XGrpInfo _ -> True
_ -> False
forwardedGroupMsg :: forall e. MsgEncodingI e => ChatMessage e -> Maybe (ChatMessage 'Json)
forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of
SJson | isForwardedGroupMsg chatMsgEvent -> Just msg
_ -> Nothing
data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object}
deriving (Eq, Show)
@ -551,7 +580,6 @@ instance FromField MsgContent where
data CMEventTag (e :: MsgEncoding) where
XMsgNew_ :: CMEventTag 'Json
XMsgFileDescr_ :: CMEventTag 'Json
XMsgFileCancel_ :: CMEventTag 'Json
XMsgUpdate_ :: CMEventTag 'Json
XMsgDel_ :: CMEventTag 'Json
XMsgDeleted_ :: CMEventTag 'Json
@ -580,6 +608,7 @@ data CMEventTag (e :: MsgEncoding) where
XGrpDel_ :: CMEventTag 'Json
XGrpInfo_ :: CMEventTag 'Json
XGrpDirectInv_ :: CMEventTag 'Json
XGrpMsgForward_ :: CMEventTag 'Json
XInfoProbe_ :: CMEventTag 'Json
XInfoProbeCheck_ :: CMEventTag 'Json
XInfoProbeOk_ :: CMEventTag 'Json
@ -600,7 +629,6 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where
strEncode = \case
XMsgNew_ -> "x.msg.new"
XMsgFileDescr_ -> "x.msg.file.descr"
XMsgFileCancel_ -> "x.msg.file.cancel"
XMsgUpdate_ -> "x.msg.update"
XMsgDel_ -> "x.msg.del"
XMsgDeleted_ -> "x.msg.deleted"
@ -629,6 +657,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where
XGrpDel_ -> "x.grp.del"
XGrpInfo_ -> "x.grp.info"
XGrpDirectInv_ -> "x.grp.direct.inv"
XGrpMsgForward_ -> "x.grp.msg.forward"
XInfoProbe_ -> "x.info.probe"
XInfoProbeCheck_ -> "x.info.probe.check"
XInfoProbeOk_ -> "x.info.probe.ok"
@ -650,7 +679,6 @@ instance StrEncoding ACMEventTag where
('x', t) -> pure . ACMEventTag SJson $ case t of
"x.msg.new" -> XMsgNew_
"x.msg.file.descr" -> XMsgFileDescr_
"x.msg.file.cancel" -> XMsgFileCancel_
"x.msg.update" -> XMsgUpdate_
"x.msg.del" -> XMsgDel_
"x.msg.deleted" -> XMsgDeleted_
@ -679,6 +707,7 @@ instance StrEncoding ACMEventTag where
"x.grp.del" -> XGrpDel_
"x.grp.info" -> XGrpInfo_
"x.grp.direct.inv" -> XGrpDirectInv_
"x.grp.msg.forward" -> XGrpMsgForward_
"x.info.probe" -> XInfoProbe_
"x.info.probe.check" -> XInfoProbeCheck_
"x.info.probe.ok" -> XInfoProbeOk_
@ -696,7 +725,6 @@ toCMEventTag :: ChatMsgEvent e -> CMEventTag e
toCMEventTag msg = case msg of
XMsgNew _ -> XMsgNew_
XMsgFileDescr _ _ -> XMsgFileDescr_
XMsgFileCancel _ -> XMsgFileCancel_
XMsgUpdate {} -> XMsgUpdate_
XMsgDel {} -> XMsgDel_
XMsgDeleted -> XMsgDeleted_
@ -725,6 +753,7 @@ toCMEventTag msg = case msg of
XGrpDel -> XGrpDel_
XGrpInfo _ -> XGrpInfo_
XGrpDirectInv _ _ -> XGrpDirectInv_
XGrpMsgForward {} -> XGrpMsgForward_
XInfoProbe _ -> XInfoProbe_
XInfoProbeCheck _ -> XInfoProbeCheck_
XInfoProbeOk _ -> XInfoProbeOk_
@ -795,7 +824,6 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
msg = \case
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr"
XMsgFileCancel_ -> XMsgFileCancel <$> p "msgId"
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live"
XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId"
XMsgDeleted_ -> pure XMsgDeleted
@ -824,6 +852,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
XGrpDel_ -> pure XGrpDel
XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content"
XGrpMsgForward_ -> XGrpMsgForward <$> p "memberId" <*> p "msg" <*> p "msgTs"
XInfoProbe_ -> XInfoProbe <$> p "probe"
XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
XInfoProbeOk_ -> XInfoProbeOk <$> p "probe"
@ -855,7 +884,6 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
params = \case
XMsgNew container -> msgContainerJSON container
XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr]
XMsgFileCancel msgId' -> o ["msgId" .= msgId']
XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId']
XMsgDeleted -> JM.empty
@ -884,6 +912,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
XGrpDel -> JM.empty
XGrpInfo p -> o ["groupProfile" .= p]
XGrpDirectInv connReq content -> o $ ("content" .=? content) ["connReq" .= connReq]
XGrpMsgForward memberId msg msgTs -> o ["memberId" .= memberId, "msg" .= msg, "msgTs" .= msgTs]
XInfoProbe probe -> o ["probe" .= probe]
XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
XInfoProbeOk probe -> o ["probe" .= probe]
@ -894,3 +923,9 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
XCallEnd callId -> o ["callId" .= callId]
XOk -> JM.empty
XUnknown _ ps -> ps
instance ToJSON (ChatMessage 'Json) where
toJSON = (\(AMJson msg) -> toJSON msg) . chatToAppMessage
instance FromJSON (ChatMessage 'Json) where
parseJSON v = appJsonToCM <$?> parseJSON v

8
src/Simplex/Chat/Store/Connections.hs
View File

@ -98,13 +98,13 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
-- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- from GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences
m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
JOIN groups g ON g.group_id = m.group_id

241
src/Simplex/Chat/Store/Groups.hs
View File

@ -45,6 +45,7 @@ module Simplex.Chat.Store.Groups
getGroupInfoByName,
getGroupMember,
getGroupMemberById,
getGroupMemberByMemberId,
getGroupMembers,
getGroupMembersForExpiration,
getGroupCurrentMembersCount,
@ -77,6 +78,9 @@ module Simplex.Chat.Store.Groups
createIntroductions,
updateIntroStatus,
saveIntroInvitation,
getIntroduction,
getForwardIntroducedMembers,
getForwardInvitedMembers,
createIntroReMember,
createIntroToMemberContact,
saveMemberInvitation,
@ -125,6 +129,7 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages
import Simplex.Chat.Protocol (currentChatVersion, groupForwardVRange, supportedChatVRange)
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
@ -140,9 +145,9 @@ import UnliftIO.STM
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe MsgFilter, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow
type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences))
type GroupMemberRow = ((Int64, Int64, MemberId, Version, Version, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences))
type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences))
type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe Version, Maybe Version, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences))
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
@ -153,16 +158,17 @@ toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, de
in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs}
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) =
toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) =
let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
memberSettings = GroupMemberSettings {showMessages}
invitedBy = toInvitedBy userContactId invitedById
activeConn = Nothing
memberChatVRange = JVersionRange $ fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer
in GroupMember {..}
toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember
toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages) :. (invitedById, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) =
Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences))
toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just minVer, Just maxVer, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages) :. (invitedById, invitedByGroupMemberId, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) =
Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences))
toMaybeGroupMember _ _ = Nothing
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO ()
@ -257,13 +263,13 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
-- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- from GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
@ -308,14 +314,14 @@ createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = Except
(ldn, userId, profileId, True, currentTs, currentTs, currentTs)
insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12
membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser customUserProfileId currentTs
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser customUserProfileId currentTs supportedChatVRange
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}
-- | creates a new group record for the group the current user was invited to, or returns an existing one
createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Just Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_
Just gId -> do
@ -353,8 +359,9 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
"INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?,?)"
(profileId, localDisplayName, connRequest, customUserProfileId, userId, True, currentTs, currentTs, currentTs)
insertedRowId db
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs
membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs
let JVersionRange hostVRange = hostConn.peerChatVRange
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs hostVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs supportedChatVRange
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId)
@ -363,8 +370,8 @@ getHostMemberId_ db User {userId} groupId =
ExceptT . firstRow fromOnly (SEHostMemberIdNotFound groupId) $
DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_category = ?" (userId, groupId, GCHostMember)
createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ProfileId -> UTCTime -> ExceptT StoreError IO GroupMember
createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfileId createdAt = do
createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> Maybe GroupMemberId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ProfileId -> UTCTime -> VersionRange -> ExceptT StoreError IO GroupMember
createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMemberId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfileId createdAt memberChatVRange@(VersionRange minV maxV) = do
incognitoProfile <- forM incognitoProfileId $ \profileId -> getProfileById db userId profileId
(localDisplayName, memberProfile) <- case (incognitoProfile, incognitoProfileId) of
(Just profile@LocalProfile {displayName}, Just profileId) ->
@ -381,11 +388,13 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
memberStatus,
memberSettings = defaultMemberSettings,
invitedBy,
invitedByGroupMemberId,
localDisplayName,
memberProfile,
memberContactId = Just $ contactId' userOrContact,
memberContactProfileId = localProfileId (profile' userOrContact),
activeConn = Nothing
activeConn = Nothing,
memberChatVRange = JVersionRange memberChatVRange
}
where
insertMember_ :: IO ContactName
@ -395,12 +404,14 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy)
( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy, invitedByGroupMemberId)
:. (userId, localDisplayName' userOrContact, contactId' userOrContact, localProfileId $ profile' userOrContact, createdAt, createdAt)
:. (minV, maxV)
)
pure localDisplayName
insertMemberIncognitoProfile_ :: ContactName -> ProfileId -> ExceptT StoreError IO ContactName
@ -410,12 +421,14 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, member_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, member_profile_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy)
( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy, invitedByGroupMemberId)
:. (userId, incognitoLdn, contactId' userOrContact, localProfileId $ profile' userOrContact, customUserProfileId, createdAt, createdAt)
:. (minV, maxV)
)
pure $ Right incognitoLdn
@ -430,7 +443,7 @@ createGroupInvitedViaLink
hostMemberId <- insertHost_ currentTs groupId
liftIO $ DB.execute db "UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ?" (ConnMember, hostMemberId, currentTs, connId)
-- using IBUnknown since host is created without contact
void $ createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange
liftIO $ setViaGroupLinkHash db groupId connId
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId
where
@ -552,8 +565,8 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
db
[sql|
SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.show_messages,
mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences
mu.group_member_id, g.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages,
mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences
FROM groups g
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members mu USING (group_id)
@ -617,8 +630,8 @@ groupMemberQuery :: Query
groupMemberQuery =
[sql|
SELECT
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
@ -647,6 +660,14 @@ getGroupMemberById db user@User {userId} groupMemberId =
(groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?")
(userId, groupMemberId, userId)
getGroupMemberByMemberId :: DB.Connection -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId db user@User {userId} GroupInfo {groupId} memberId =
ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFoundByMemberId memberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ?")
(userId, groupId, memberId)
getGroupMembers :: DB.Connection -> User -> GroupInfo -> IO [GroupMember]
getGroupMembers db user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember user)
@ -705,15 +726,17 @@ getGroupInvitation db user groupId =
firstRow fromOnly (SEGroupNotFound groupId) $
DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId)
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createNewContactMember _ _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ _ _ = throwError $ SEContactNotReady localDisplayName
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile, activeConn = Just Connection {peerChatVRange}} memberRole agentConnId connRequest subMode =
createNewContactMember db gVar User {userId, userContactId} GroupInfo {groupId, membership} Contact {contactId, localDisplayName, profile, activeConn = Just Connection {peerChatVRange}} memberRole agentConnId connRequest subMode =
createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime
member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt
void $ createMemberConnection_ db userId groupMemberId agentConnId (fromJVersionRange peerChatVRange) Nothing 0 createdAt subMode
pure member
where
JVersionRange (VersionRange minV maxV) = peerChatVRange
invitedByGroupMemberId = groupMemberId' membership
createMember_ memberId createdAt = do
insertMember_
groupMemberId <- liftIO $ insertedRowId db
@ -727,11 +750,13 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
memberStatus = GSMemInvited,
memberSettings = defaultMemberSettings,
invitedBy = IBUser,
invitedByGroupMemberId = Just invitedByGroupMemberId,
localDisplayName,
memberProfile = profile,
memberContactId = Just contactId,
memberContactProfileId = localProfileId profile,
activeConn = Nothing
activeConn = Nothing,
memberChatVRange = peerChatVRange
}
where
insertMember_ =
@ -739,16 +764,18 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, sent_inv_queue_info, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, sent_inv_queue_info, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser)
( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser, invitedByGroupMemberId)
:. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt)
:. (minV, maxV)
)
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionRange -> SubscriptionMode -> ExceptT StoreError IO ()
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) peerChatVRange subMode =
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionRange -> SubscriptionMode -> ExceptT StoreError IO ()
createNewContactMemberAsync db gVar user@User {userId, userContactId} GroupInfo {groupId, membership} Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) peerChatVRange subMode =
createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime
insertMember_ (MemberId memId) createdAt
@ -756,17 +783,20 @@ createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Co
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 createdAt subMode
setCommandConnId db user cmdId connId
where
VersionRange minV maxV = peerChatVRange
insertMember_ memberId createdAt =
DB.execute
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser)
( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser, groupMemberId' membership)
:. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt)
:. (minV, maxV)
)
createAcceptedMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> UserContactRequest -> GroupMemberRole -> ExceptT StoreError IO (GroupMemberId, MemberId)
@ -774,8 +804,8 @@ createAcceptedMember
db
gVar
User {userId, userContactId}
GroupInfo {groupId}
UserContactRequest {localDisplayName, profileId}
GroupInfo {groupId, membership}
UserContactRequest {cReqChatVRange, localDisplayName, profileId}
memberRole = do
liftIO $
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
@ -785,17 +815,20 @@ createAcceptedMember
groupMemberId <- liftIO $ insertedRowId db
pure (groupMemberId, MemberId memId)
where
JVersionRange (VersionRange minV maxV) = cReqChatVRange
insertMember_ memberId createdAt =
DB.execute
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser)
( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt)
:. (minV, maxV)
)
createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO ()
@ -864,8 +897,8 @@ updateGroupMemberStatusById db userId groupMemberId memStatus = do
(memStatus, currentTs, userId, groupMemberId)
-- | add new member with profile
createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
createNewGroupMember db user gInfo memInfo@MemberInfo {profile} memCategory memStatus = do
createNewGroupMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} memCategory memStatus = do
currentTs <- liftIO getCurrentTime
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user profile currentTs
let newMember =
@ -874,6 +907,7 @@ createNewGroupMember db user gInfo memInfo@MemberInfo {profile} memCategory memS
memCategory,
memStatus,
memInvitedBy = IBUnknown,
memInvitedByGroupMemberId = Just $ groupMemberId' invitingMember,
localDisplayName,
memContactId = Nothing,
memProfileId
@ -896,10 +930,11 @@ createNewMember_
User {userId, userContactId}
GroupInfo {groupId}
NewGroupMember
{ memInfo = MemberInfo memberId memberRole _ memberProfile,
{ memInfo = MemberInfo memberId memberRole memChatVRange memberProfile,
memCategory = memberCategory,
memStatus = memberStatus,
memInvitedBy = invitedBy,
memInvitedByGroupMemberId,
localDisplayName,
memContactId = memberContactId,
memProfileId = memberContactProfileId
@ -907,18 +942,38 @@ createNewMember_
createdAt = do
let invitedById = fromInvitedBy userContactId invitedBy
activeConn = Nothing
mcvr@(VersionRange minV maxV) = maybe chatInitialVRange fromChatVRange memChatVRange
DB.execute
db
[sql|
INSERT INTO group_members
(group_id, member_id, member_role, member_category, member_status,
invited_by, user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
(group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
(groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt)
( (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, memInvitedByGroupMemberId)
:. (userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt)
:. (minV, maxV)
)
groupMemberId <- insertedRowId db
let memberSettings = defaultMemberSettings
pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, memberSettings, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile "", memberContactId, memberContactProfileId, activeConn}
pure GroupMember {
groupMemberId,
groupId,
memberId,
memberRole,
memberCategory,
memberStatus,
memberSettings = defaultMemberSettings,
invitedBy,
invitedByGroupMemberId = memInvitedByGroupMemberId,
localDisplayName,
memberProfile = toLocalProfile memberContactProfileId memberProfile "",
memberContactId,
memberContactProfileId,
activeConn,
memberChatVRange = JVersionRange mcvr
}
checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId)
checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} =
@ -965,10 +1020,10 @@ createIntroductions db members toMember = do
db
[sql|
INSERT INTO group_member_intros
(re_group_member_id, to_group_member_id, intro_status, created_at, updated_at)
VALUES (?,?,?,?,?)
(re_group_member_id, to_group_member_id, intro_status, intro_chat_protocol_version, created_at, updated_at)
VALUES (?,?,?,?,?,?)
|]
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, ts, ts)
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, currentChatVersion, ts, ts)
introId <- insertedRowId db
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
@ -986,7 +1041,7 @@ updateIntroStatus db introId introStatus = do
saveIntroInvitation :: DB.Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro
saveIntroInvitation db reMember toMember introInv = do
intro <- getIntroduction_ db reMember toMember
intro <- getIntroduction db reMember toMember
liftIO $ do
currentTs <- getCurrentTime
DB.executeNamed
@ -1027,8 +1082,8 @@ saveMemberInvitation db GroupMember {groupMemberId} IntroInvitation {groupConnRe
":group_member_id" := groupMemberId
]
getIntroduction_ :: DB.Connection -> GroupMember -> GroupMember -> ExceptT StoreError IO GroupMemberIntro
getIntroduction_ db reMember toMember = ExceptT $ do
getIntroduction :: DB.Connection -> GroupMember -> GroupMember -> ExceptT StoreError IO GroupMemberIntro
getIntroduction db reMember toMember = ExceptT $ do
toIntro
<$> DB.query
db
@ -1045,9 +1100,49 @@ getIntroduction_ db reMember toMember = ExceptT $ do
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
toIntro _ = Left SEIntroNotFound
getForwardIntroducedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember]
getForwardIntroducedMembers db user invitee highlyAvailable = do
memberIds <- map fromOnly <$> query
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds
where
mId = groupMemberId' invitee
query
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
| otherwise =
DB.query
db
(q <> " AND intro_chat_protocol_version >= ?")
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
q =
[sql|
SELECT re_group_member_id
FROM group_member_intros
WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?)
|]
getForwardInvitedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember]
getForwardInvitedMembers db user forwardMember highlyAvailable = do
memberIds <- map fromOnly <$> query
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds
where
mId = groupMemberId' forwardMember
query
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
| otherwise =
DB.query
db
(q <> " AND intro_chat_protocol_version >= ?")
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
q =
[sql|
SELECT to_group_member_id
FROM group_member_intros
WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?)
|]
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
let mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
let mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn
currentTs <- liftIO getCurrentTime
newMember <- case directConnIds of
@ -1056,10 +1151,10 @@ createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupM
liftIO $ setCommandConnId db user directCmdId directConnId
(localDisplayName, contactId, memProfileId) <- createContact_ db userId memberProfile "" (Just groupId) currentTs Nothing
liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, directConnId)
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Just contactId, memProfileId}
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Just contactId, memProfileId}
Nothing -> do
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memberProfile currentTs
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Nothing, memProfileId}
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId}
liftIO $ do
member <- createNewMember_ db user gInfo newMember currentTs
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId mcvr memberContactId cLevel currentTs subMode
@ -1116,13 +1211,13 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
-- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- via GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
@ -1209,8 +1304,8 @@ getGroupInfo db User {userId, userContactId} groupId =
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupMember - membership
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences
FROM groups g
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id

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

@ -23,6 +23,7 @@ module Simplex.Chat.Store.Messages
createNewSndMessage,
createSndMsgDelivery,
createNewMessageAndRcvMsgDelivery,
createNewRcvMessage,
createSndMsgDeliveryEvent,
createRcvMsgDeliveryEvent,
createPendingGroupMessage,
@ -185,25 +186,53 @@ createSndMsgDelivery db sndMsgDelivery messageId = do
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs
pure msgDeliveryId
createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage
createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO messages (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id) VALUES (?,?,?,?,?,?,?,?)"
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_)
msgId <- insertedRowId db
DB.execute
db
"INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs)
msgDeliveryId <- insertedRowId db
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody}
where
(connId_, groupId_) = case connOrGroupId of
ConnectionId connId' -> (Just connId', Nothing)
GroupId groupId -> (Nothing, Just groupId)
createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} authorGroupMemberId_ = do
msg@RcvMessage {msgId} <- createNewRcvMessage db connOrGroupId newMessage sharedMsgId_ authorGroupMemberId_ Nothing
liftIO $ do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs)
msgDeliveryId <- insertedRowId db
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
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_ authorGroupMemberId forwardedByGroupMemberId =
case connOrGroupId of
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
GroupId groupId -> case sharedMsgId_ of
Just sharedMsgId -> liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
Just (duplAuthorId, duplFwdMemberId) ->
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
where
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
duplicateGroupMsgMemberIds groupId sharedMsgId =
maybeFirstRow id
$ DB.query
db
[sql|
SELECT author_group_member_id, forwarded_by_group_member_id
FROM messages
WHERE group_id = ? AND shared_msg_id = ? LIMIT 1
|]
(groupId, sharedMsgId)
insertRcvMsg connId_ groupId_ = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages
(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_, authorGroupMemberId, forwardedByGroupMemberId)
msgId <- insertedRowId db
pure RcvMessage{msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorGroupMemberId, forwardedByGroupMemberId}
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
@ -322,7 +351,7 @@ updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirecti
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem timed live createdAt =
createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow timed live createdAt createdAt
createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow timed live createdAt Nothing createdAt
where
createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow
@ -337,8 +366,8 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
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} sharedMsgId_ ciContent timed live itemTs createdAt = do
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs createdAt
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByGroupMemberId} sharedMsgId_ ciContent timed live itemTs createdAt = do
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs forwardedByGroupMemberId createdAt
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
pure (ciId, quotedItem)
where
@ -353,14 +382,14 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} shar
(Just $ Just userMemberId == memberId, memberId)
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection ciContent =
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False
createNewChatItemNoMsg db user chatDirection ciContent itemTs =
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False itemTs Nothing
where
quoteRow :: NewQuoteRow
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs createdAt = do
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs forwardedByGroupMemberId createdAt = do
DB.execute
db
[sql|
@ -368,18 +397,18 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
-- user and IDs
user_id, created_by_msg_id, contact_id, group_id, group_member_id,
-- meta
item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, forwarded_by_group_member_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
-- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
((userId, msgId_) :. idsRow :. itemRow :. quoteRow)
ciId <- insertedRowId db
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
pure ciId
where
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime)
itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId, Maybe GroupMemberId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime)
itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId, forwardedByGroupMemberId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64)
idsRow = case chatDirection of
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing)
@ -440,8 +469,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
[sql|
SELECT i.chat_item_id,
-- GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
m.member_status, m.show_messages, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category,
m.member_status, m.show_messages, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
@ -556,8 +585,8 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupMember - membership
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- ChatStats
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat,
@ -565,19 +594,21 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- CIMeta forwardedByGroupMemberId
i.forwarded_by_group_member_id,
-- Maybe GroupMember - sender
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
m.member_status, m.show_messages, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category,
m.member_status, m.show_messages, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
-- quoted ChatItem
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
-- quoted GroupMember
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
rm.member_status, rm.show_messages, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
rm.group_member_id, rm.group_id, rm.member_id, rm.peer_chat_min_version, rm.peer_chat_max_version, rm.member_role, rm.member_category,
rm.member_status, rm.show_messages, rm.invited_by, rm.invited_by_group_member_id, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences,
-- deleted by GroupMember
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category,
dbm.member_status, dbm.show_messages, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.peer_chat_min_version, dbm.peer_chat_max_version, dbm.member_role, dbm.member_category,
dbm.member_status, dbm.show_messages, dbm.invited_by, dbm.invited_by_group_member_id, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences
FROM groups g
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
@ -1020,7 +1051,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
DBCINotDeleted -> Nothing
_ -> Just (CIDeleted @'CTDirect deletedTs)
itemEdited' = fromMaybe False itemEdited
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@ -1031,7 +1062,7 @@ toDirectChatItemList _ _ = []
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow
type MaybeGroupChatItemRow = MaybeChatItemRow :. Only (Maybe GroupMemberId) :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow
toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup)
toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_
@ -1042,8 +1073,8 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
direction _ _ = Nothing
-- this function can be changed so it never fails, not only avoid failure on invalid json
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. Only (Maybe GroupMemberId) :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByGroupMemberId :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
member_ = toMaybeGroupMember userContactId memberRow_
@ -1079,13 +1110,13 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
DBCIBlocked -> Just (CIBlocked @'CTGroup deletedTs)
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = fromMaybe False itemEdited
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByGroupMemberId createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
toGroupChatItemList :: UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup]
toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) =
either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_)
toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. forwardedByGroupMemberId :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) =
either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. forwardedByGroupMemberId :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_)
toGroupChatItemList _ _ _ = []
getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
@ -1529,19 +1560,21 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- CIMeta forwardedByGroupMemberId
i.forwarded_by_group_member_id,
-- GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
m.member_status, m.show_messages, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category,
m.member_status, m.show_messages, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
-- quoted ChatItem
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
-- quoted GroupMember
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
rm.member_status, rm.show_messages, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
rm.group_member_id, rm.group_id, rm.member_id, rm.peer_chat_min_version, rm.peer_chat_max_version, rm.member_role, rm.member_category,
rm.member_status, rm.show_messages, rm.invited_by, rm.invited_by_group_member_id, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences,
-- deleted by GroupMember
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category,
dbm.member_status, dbm.show_messages, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.peer_chat_min_version, dbm.peer_chat_max_version, dbm.member_role, dbm.member_category,
dbm.member_status, dbm.show_messages, dbm.invited_by, dbm.invited_by_group_member_id, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id

4
src/Simplex/Chat/Store/Migrations.hs
View File

@ -88,6 +88,7 @@ import Simplex.Chat.Migrations.M20231010_member_settings
import Simplex.Chat.Migrations.M20231019_indexes
import Simplex.Chat.Migrations.M20231030_xgrplinkmem_received
import Simplex.Chat.Migrations.M20231107_indexes
import Simplex.Chat.Migrations.M20231113_group_forward
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@ -175,7 +176,8 @@ schemaMigrations =
("20231010_member_settings", m20231010_member_settings, Just down_m20231010_member_settings),
("20231019_indexes", m20231019_indexes, Just down_m20231019_indexes),
("20231030_xgrplinkmem_received", m20231030_xgrplinkmem_received, Just down_m20231030_xgrplinkmem_received),
("20231107_indexes", m20231107_indexes, Just down_m20231107_indexes)
("20231107_indexes", m20231107_indexes, Just down_m20231107_indexes),
("20231113_group_forward", m20231113_group_forward, Just down_m20231113_group_forward)
]
-- | The list of migrations in ascending order by date

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

@ -100,6 +100,7 @@ data StoreError
| SEHostMemberIdNotFound {groupId :: Int64}
| SEContactNotFoundByFileId {fileId :: FileTransferId}
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
| SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
deriving (Show, Exception, Generic)
instance ToJSON StoreError where
@ -206,6 +207,17 @@ setPeerChatVRange db connId (VersionRange minVer maxVer) =
|]
(minVer, maxVer, connId)
setMemberChatVRange :: DB.Connection -> GroupMemberId -> VersionRange -> IO ()
setMemberChatVRange db mId (VersionRange minVer maxVer) =
DB.execute
db
[sql|
UPDATE group_members
SET peer_chat_min_version = ?, peer_chat_max_version = ?
WHERE group_member_id = ?
|]
(minVer, maxVer, mId)
setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO ()
setCommandConnId db User {userId} cmdId connId = do
updatedAt <- getCurrentTime

21
src/Simplex/Chat/Types.hs
View File

@ -668,9 +668,9 @@ instance ToJSON MemberInfo where
memberInfo :: GroupMember -> MemberInfo
memberInfo GroupMember {memberId, memberRole, memberProfile, activeConn} =
MemberInfo memberId memberRole memberChatVRange (fromLocalProfile memberProfile)
MemberInfo memberId memberRole cvr (fromLocalProfile memberProfile)
where
memberChatVRange = ChatVersionRange . fromJVersionRange . peerChatVRange <$> activeConn
cvr = ChatVersionRange . fromJVersionRange . peerChatVRange <$> activeConn
data ReceivedGroupInvitation = ReceivedGroupInvitation
{ fromMember :: GroupMember,
@ -692,6 +692,7 @@ data GroupMember = GroupMember
memberStatus :: GroupMemberStatus,
memberSettings :: GroupMemberSettings,
invitedBy :: InvitedBy,
invitedByGroupMemberId :: Maybe GroupMemberId,
localDisplayName :: ContactName,
-- for membership, memberProfile can be either user's profile or incognito profile, based on memberIncognito test.
-- for other members it's whatever profile the local user can see (there is no info about whether it's main or incognito profile for remote users).
@ -701,7 +702,10 @@ data GroupMember = GroupMember
-- for membership it would always point to user's contact
-- it is used to test for incognito status by comparing with ID in memberProfile
memberContactProfileId :: ProfileId,
activeConn :: Maybe Connection
activeConn :: Maybe Connection,
-- member chat protocol version range; if member has active connection, its version range is preferred;
-- for membership current supportedChatVRange is set, it's not updated on protocol version increase
memberChatVRange :: JVersionRange
}
deriving (Eq, Show, Generic)
@ -719,11 +723,17 @@ groupMemberRef GroupMember {groupMemberId, memberProfile = p} =
GroupMemberRef {groupMemberId, profile = fromLocalProfile p}
memberConn :: GroupMember -> Maybe Connection
memberConn GroupMember{activeConn} = activeConn
memberConn GroupMember {activeConn} = activeConn
memberConnId :: GroupMember -> Maybe ConnId
memberConnId GroupMember {activeConn} = aConnId <$> activeConn
memberChatVRange' :: GroupMember -> VersionRange
memberChatVRange' GroupMember {activeConn, memberChatVRange} =
fromJVersionRange $ case activeConn of
Just Connection {peerChatVRange} -> peerChatVRange
Nothing -> memberChatVRange
groupMemberId' :: GroupMember -> GroupMemberId
groupMemberId' GroupMember {groupMemberId} = groupMemberId
@ -747,6 +757,7 @@ data NewGroupMember = NewGroupMember
memCategory :: GroupMemberCategory,
memStatus :: GroupMemberStatus,
memInvitedBy :: InvitedBy,
memInvitedByGroupMemberId :: Maybe GroupMemberId,
localDisplayName :: ContactName,
memProfileId :: Int64,
memContactId :: Maybe Int64
@ -1471,7 +1482,7 @@ data GroupMemberIntroStatus
| GMIntroReConnected
| GMIntroToConnected
| GMIntroConnected
deriving (Show)
deriving (Eq, Show)
instance FromField GroupMemberIntroStatus where fromField = fromTextField_ introStatusT

7
src/Simplex/Chat/View.hs
View File

@ -450,7 +450,7 @@ viewChats ts tz = concatMap chatPreview . reverse
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file} doShow ts tz =
withItemDeleted <$> case chat of
withGroupMsgForwarded . withItemDeleted <$> (case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
@ -484,11 +484,14 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file}
from = ttyFromGroup g m
where
quote = maybe [] (groupQuote g) quotedItem
_ -> []
_ -> [])
where
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
Nothing -> item
Just t -> item <> styled (colored Red) (" [" <> t <> "]")
withGroupMsgForwarded item = case meta.forwardedByGroupMemberId of
Nothing -> item
Just _ -> item <> styled (colored Yellow) (" [>>]" :: String)
withSndFile = withFile viewSentFileInvitation
withRcvFile = withFile viewReceivedFileInvitation
withFile view dir l = maybe l (\f -> l <> view dir f ts tz meta) file

3
tests/ChatClient.hs
View File

@ -71,7 +71,8 @@ testOpts =
logServerHosts = False,
logAgent = Nothing,
logFile = Nothing,
tbqSize = 16
tbqSize = 16,
highlyAvailable = False
},
chatCmd = "",
chatCmdDelay = 3,

134
tests/ChatTests/Groups.hs
View File

@ -7,12 +7,14 @@ import ChatClient
import ChatTests.Utils
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_)
import Control.Monad (when)
import Control.Monad (when, void)
import qualified Data.ByteString as B
import qualified Data.Text as T
import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..))
import Simplex.Chat.Protocol (supportedChatVRange)
import Simplex.Chat.Store (agentStoreFile, chatStoreFile)
import Simplex.Chat.Types (GroupMemberRole (..))
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Version
import System.Directory (copyFile)
import System.FilePath ((</>))
@ -103,6 +105,8 @@ chatGroupTests = do
it "invited member replaces member contact reference if it already exists" testMemberContactInvitedConnectionReplaced
it "share incognito profile" testMemberContactIncognito
it "sends and updates profile when creating contact" testMemberContactProfileUpdate
describe "forwarding messages" $ do
it "admin should forward messages between invitee and introduced" testGroupMsgForward
where
_0 = supportedChatVRange -- don't create direct connections
_1 = groupCreateDirectVRange
@ -1522,6 +1526,13 @@ testGroupDelayedModeration tmp = do
cath <## "#team: you joined the group"
]
threadDelay 1000000
-- imitate not implemented group forwarding
-- (real client wouldn't have forwarding code, but tests use "current code" with configured version,
-- and forwarding client doesn't check compatibility)
void $ withCCTransaction alice $ \db ->
DB.execute_ db "UPDATE group_member_intros SET intro_status='con'"
cath #> "#team hi" -- message is pending for bob
alice <# "#team cath> hi"
alice ##> "\\\\ #team @cath hi"
@ -1561,6 +1572,13 @@ testGroupDelayedModerationFullDelete tmp = do
cath <## "#team: you joined the group"
]
threadDelay 1000000
-- imitate not implemented group forwarding
-- (real client wouldn't have forwarding code, but tests use "current code" with configured version,
-- and forwarding client doesn't check compatibility)
void $ withCCTransaction alice $ \db ->
DB.execute_ db "UPDATE group_member_intros SET intro_status='con'"
cath #> "#team hi" -- message is pending for bob
alice <# "#team cath> hi"
alice ##> "\\\\ #team @cath hi"
@ -3644,9 +3662,9 @@ testMemberContactProhibitedRepeatInv =
testMemberContactInvitedConnectionReplaced :: HasCallStack => FilePath -> IO ()
testMemberContactInvitedConnectionReplaced tmp = do
withNewTestChat tmp "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \b -> withTestOutput b $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \c -> withTestOutput c $ \cath -> do
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
createGroup3 "team" alice bob cath
alice ##> "/d bob"
@ -3881,3 +3899,109 @@ testMemberContactProfileUpdate =
cath #> "#team hello there"
alice <# "#team kate> hello there"
bob <# "#team kate> hello there" -- updated profile
testGroupMsgForward :: HasCallStack => FilePath -> IO ()
testGroupMsgForward =
testChatCfg4 cfg aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> withXFTPServer $ do
createGroup3 "team" alice bob cath
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
void $ withCCTransaction bob $ \db ->
DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3"
void $ withCCTransaction cath $ \db ->
DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3"
void $ withCCTransaction alice $ \db ->
DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'"
bob #> "#team hi there"
alice <# "#team bob> hi there"
cath <# "#team bob> hi there [>>]"
threadDelay 1000000
cath #> "#team hey team"
alice <# "#team cath> hey team"
bob <# "#team cath> hey team [>>]"
alice ##> "/tail #team 2"
alice <# "#team bob> hi there"
alice <# "#team cath> hey team"
bob ##> "/tail #team 2"
bob <# "#team hi there"
bob <# "#team cath> hey team [>>]"
cath ##> "/tail #team 2"
cath <# "#team bob> hi there [>>]"
cath <# "#team hey team"
bob ##> "! #team hello there"
bob <# "#team [edited] hello there"
alice <# "#team bob> [edited] hello there"
cath <# "#team bob> [edited] hello there" -- TODO show as forwarded
cath ##> "+1 #team hello there"
cath <## "added 👍"
alice <# "#team cath> > bob hello there"
alice <## " + 👍"
bob <# "#team cath> > bob hello there"
bob <## " + 👍"
bob ##> "\\ #team hello there"
bob <## "message marked deleted"
alice <# "#team bob> [marked deleted] hello there"
cath <# "#team bob> [marked deleted] hello there" -- TODO show as forwarded
bob #> "/f #team ./tests/fixtures/test.jpg"
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (test.jpg) for #team"
concurrentlyN_
[ do
alice <# "#team bob> sends file test.jpg (136.5 KiB / 139737 bytes)"
alice <## "use /fr 1 [<dir>/ | <path>] to receive it",
do
cath <# "#team bob> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]"
]
cath ##> "/fr 1 ./tests/tmp"
cath <## "saving file 1 from bob to ./tests/tmp/test.jpg"
cath <## "started receiving file 1 (test.jpg) from bob"
cath <## "completed receiving file 1 (test.jpg) from bob"
src <- B.readFile "./tests/fixtures/test.jpg"
dest <- B.readFile "./tests/tmp/test.jpg"
dest `shouldBe` src
cath ##> "/mr #team bob member"
cath <## "#team: you changed the role of bob from admin to member"
alice <## "#team: cath changed the role of bob from admin to member"
bob <## "#team: cath changed your role from admin to member" -- TODO show as forwarded
connectUsers cath dan
cath ##> "/a #team dan"
cath <## "invitation to join the group #team sent to dan"
dan <## "#team: cath invites you to join the group as member"
dan <## "use /j team to accept"
dan ##> "/j #team"
dan <## "#team: you joined the group"
concurrentlyN_
[ cath <## "#team: dan joined the group",
do
alice <## "#team: cath added dan (Daniel) to the group (connecting...)"
alice <## "#team: new member dan is connected",
-- bob will not connect to dan, as introductions are not forwarded (yet?)
bob <## "#team: cath added dan (Daniel) to the group (connecting...)", -- TODO show as forwarded
dan <## "#team: member alice (Alice) is connected"
]
dan #> "#team hello all"
alice <# "#team dan> hello all"
-- bob <# "#team dan> hello all [>>]"
cath <# "#team dan> hello all"
bob #> "#team hi all"
alice <# "#team bob> hi all"
cath <# "#team bob> hi all [>>]"
-- dan <# "#team bob> hi all"
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}

14
tests/ProtocolTests.hs
View File

@ -122,7 +122,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
"{\"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)))
it "x.msg.new chat message with chat version range" $
"{\"v\":\"1-3\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
"{\"v\":\"1-4\",\"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)))
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\"}}}}"
@ -232,13 +232,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile}
it "x.grp.mem.new with member chat version range" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-3\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
"{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-4\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile}
it "x.grp.mem.intro" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile}
it "x.grp.mem.intro with member chat version range" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-3\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
"{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-4\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile}
it "x.grp.mem.inv" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}"
@ -250,7 +250,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq}
it "x.grp.mem.fwd with member chat version range and w/t directConnReq" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-3\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
"{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-4\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
#==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing}
it "x.grp.mem.info" $
"{\"v\":\"1\",\"event\":\"x.grp.mem.info\",\"params\":{\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
@ -276,6 +276,12 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
it "x.grp.direct.inv without content" $
"{\"v\":\"1\",\"event\":\"x.grp.direct.inv\",\"params\":{\"connReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}"
#==# XGrpDirectInv testConnReq Nothing
-- it "x.grp.msg.forward"
-- $ "{\"v\":\"1\",\"event\":\"x.grp.msg.forward\",\"params\":{\"msgForward\":{\"memberId\":\"AQIDBA==\",\"msg\":\"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}\",\"msgTs\":\"1970-01-01T00:00:01.000000001Z\"}}}"
-- #==# XGrpMsgForward
-- (MemberId "\1\2\3\4")
-- (ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))))
-- (systemToUTCTime $ MkSystemTime 1 1)
it "x.info.probe" $
"{\"v\":\"1\",\"event\":\"x.info.probe\",\"params\":{\"probe\":\"AQIDBA==\"}}"
#==# XInfoProbe (Probe "\1\2\3\4")