From 79064e149a0191ddf49e11c1209f33dfb48500e0 Mon Sep 17 00:00:00 2001 From: Stanislav Dmitrenko <7953703+avently@users.noreply.github.com> Date: Sat, 18 Nov 2023 02:19:38 +0800 Subject: [PATCH 1/2] desktop: enabled smooth scrolling again (#3388) --- .../src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt | 4 ---- 1 file changed, 4 deletions(-) diff --git a/apps/multiplatform/common/src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt b/apps/multiplatform/common/src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt index 6b81209d4..2931e0e01 100644 --- a/apps/multiplatform/common/src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt +++ b/apps/multiplatform/common/src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt @@ -29,10 +29,6 @@ import java.io.File val simplexWindowState = SimplexWindowState() fun showApp() = application { - // TODO: remove after update to compose 1.5.0+ - // See: https://github.com/JetBrains/compose-multiplatform/issues/3366#issuecomment-1643799976 - System.setProperty("compose.scrolling.smooth.enabled", "false") - // For some reason on Linux actual width will be 10.dp less after specifying it here. If we specify 1366, // it will show 1356. But after that we can still update it to 1366 by changing window state. Just making it +10 now here val width = if (desktopPlatform.isLinux()) 1376.dp else 1366.dp From c0e8740f5079a9a7b713b3519fbb69d840f16ca0 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Sat, 18 Nov 2023 21:52:01 +0400 Subject: [PATCH 2/2] core: group message forwarding (#3360) * 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> --- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 519 ++++++++++++------ src/Simplex/Chat/Controller.hs | 3 +- src/Simplex/Chat/Messages.hs | 13 +- .../Migrations/M20231113_group_forward.hs | 53 ++ src/Simplex/Chat/Migrations/chat_schema.sql | 32 +- src/Simplex/Chat/Mobile.hs | 3 +- src/Simplex/Chat/Options.hs | 11 +- src/Simplex/Chat/Protocol.hs | 57 +- src/Simplex/Chat/Store/Connections.hs | 8 +- src/Simplex/Chat/Store/Groups.hs | 241 +++++--- src/Simplex/Chat/Store/Messages.hs | 139 +++-- src/Simplex/Chat/Store/Migrations.hs | 4 +- src/Simplex/Chat/Store/Shared.hs | 12 + src/Simplex/Chat/Types.hs | 21 +- src/Simplex/Chat/View.hs | 7 +- tests/ChatClient.hs | 3 +- tests/ChatTests/Groups.hs | 134 ++++- tests/ProtocolTests.hs | 14 +- 19 files changed, 936 insertions(+), 339 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20231113_group_forward.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 622226a0c..d379203ca 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 12936b325..524fae2bd 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index d2e81f96f..7c67cd9e5 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -126,7 +126,8 @@ data ChatConfig = ChatConfig cleanupManagerInterval :: NominalDiffTime, cleanupManagerStepDelay :: Int64, ciExpirationInterval :: Int64, -- microseconds - coreApi :: Bool + coreApi :: Bool, + highlyAvailable :: Bool } data DefaultAgentServers = DefaultAgentServers diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 2ddb1e7bc..d35ed8818 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -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 diff --git a/src/Simplex/Chat/Migrations/M20231113_group_forward.hs b/src/Simplex/Chat/Migrations/M20231113_group_forward.hs new file mode 100644 index 000000000..f23387f01 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20231113_group_forward.hs @@ -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; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 875ee91de..6f576a75e 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -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 +); diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index b44488814..8888ed13e 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -152,7 +152,8 @@ mobileChatOpts dbFilePrefix dbKey = logServerHosts = True, logAgent = Nothing, logFile = Nothing, - tbqSize = 1024 + tbqSize = 1024, + highlyAvailable = False }, chatCmd = "", chatCmdDelay = 3, diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index 0b39b8dd4..04aef29df 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -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 diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 43ca5913f..d1a2e476e 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index b5b377ea5..53c7d249a 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 40294dc14..673ef4d80 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 0136ac660..d98023ad8 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index f5a442620..e261d97e2 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index c51fcf1eb..260c91e0e 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -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 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index c92b25fb2..064cf7808 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index f7992571a..982c5208a 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index ea455a0fc..aaf812f00 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -71,7 +71,8 @@ testOpts = logServerHosts = False, logAgent = Nothing, logFile = Nothing, - tbqSize = 16 + tbqSize = 16, + highlyAvailable = False }, chatCmd = "", chatCmdDelay = 3, diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 36b5cf4ea..edf3d2fab 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -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 [/ | ] to receive it", + do + cath <# "#team bob> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + cath <## "use /fr 1 [/ | ] 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"} diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index f5c1bf856..884d2b873 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -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")