dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-10 23:47:11 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: group member/owner keys for signing important messages (#6597)

Browse Source 
* rfc: member keys

* update plan

* new encoding for message batches

* send new batch encoding in relay-based groups

* mvp launch plan

* update plan

* core: verify group member keys (#6669)

* core: verify group member keys

* refactor, process forwards

* refactor parsing

* refactor parsing 2

* refactor parser 3

* update rfc

* simplify

* simplify

* log tag

* refactor tag logging

* refactor withVerifiedSig

* simplify

* refactor more

* comment

* fix encoding

* fix sending as group for the new binary batch encoding

* unify types

* update api docs

* clean up

---------

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>

* core: signing messages with member keys (#6675)

* core: signing messages with member keys (types)

* sign messages

* refactor batching

* better

* refactor

* remove unused Eq

---------

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>

* core: forward signed messages as unchanged binary strings (#6678)

* core: forward signed messages as unchanged binary strings

* refactor

* consolidate types

* refactor VerifiedMsg

* refactor more

* undo rename

Co-authored-by: Evgeny <evgeny@poberezkin.com>

* update schema and plans

* add signed status to chat items and events

* test signed chat items

* unify parser

* PostgreSQL fix, remove unused fields, option to send inline files in the tests

* change inline files config

* revert inline config change

* use different characters in batch encoding, to avoid conflict with inline files

* fix test, api docs, query plans

---------

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny
2026-03-16 10:46:35 +00:00
committed by GitHub
parent 4e16792ddc
commit 2db92ff6ed
35 changed files with 2325 additions and 443 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Controller.hs
+11 -11
View File
@@ -705,7 +705,7 @@ data ChatResponse
| CRUserContactLinkUpdated {user :: User, contactLink :: UserContactLink}
| CRContactRequestRejected {user :: User, contactRequest :: UserContactRequest, contact_ :: Maybe Contact}
| CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
| CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool}
| CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool}
| CRGroupsList {user :: User, groups :: [GroupInfo]}
| CRSentGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember}
| CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus
@@ -734,7 +734,7 @@ data ChatResponse
| CRAcceptingContactRequest {user :: User, contact :: Contact}
| CRContactAlreadyExists {user :: User, contact :: Contact}
| CRLeftMemberUser {user :: User, groupInfo :: GroupInfo}
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo}
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool}
| CRForwardPlan {user :: User, itemsCount :: Int, chatItemIds :: [ChatItemId], forwardConfirmation :: Maybe ForwardConfirmation}
| CRRcvFileAccepted {user :: User, chatItem :: AChatItem}
-- TODO add chatItem :: AChatItem
@@ -754,9 +754,9 @@ data ChatResponse
| CRMemberAccepted {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRMemberSupportChatRead {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRMemberSupportChatDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRMembersRoleUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], toRole :: GroupMemberRole}
| CRMembersBlockedForAllUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], blocked :: Bool}
| CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember}
| CRMembersRoleUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], toRole :: GroupMemberRole, msgSigned :: Bool}
| CRMembersBlockedForAllUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], blocked :: Bool, msgSigned :: Bool}
| CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember, msgSigned :: Bool}
| CRGroupProfile {user :: User, groupInfo :: GroupInfo}
| CRGroupDescription {user :: User, groupInfo :: GroupInfo} -- only used in CLI
| CRGroupLinkCreated {user :: User, groupInfo :: GroupInfo, groupLink :: GroupLink}
@@ -858,17 +858,17 @@ data ChatEvent
| CEvtJoinedGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} -- there is the same command response
| CEvtJoinedGroupMemberConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember}
| CEvtMemberAcceptedByOther {user :: User, groupInfo :: GroupInfo, acceptingMember :: GroupMember, member :: GroupMember}
| CEvtMemberRole {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole}
| CEvtMemberBlockedForAll {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, blocked :: Bool}
| CEvtMemberRole {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole, msgSigned :: Bool}
| CEvtMemberBlockedForAll {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, blocked :: Bool, msgSigned :: Bool}
| CEvtConnectedToGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember, memberContact :: Maybe Contact}
| CEvtDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember, withMessages :: Bool}
| CEvtDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, withMessages :: Bool}
| CEvtDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember, withMessages :: Bool, msgSigned :: Bool}
| CEvtDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, withMessages :: Bool, msgSigned :: Bool}
| CEvtLeftMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CEvtUnknownMemberCreated {user :: User, groupInfo :: GroupInfo, forwardedByMember :: GroupMember, member :: GroupMember}
| CEvtUnknownMemberBlocked {user :: User, groupInfo :: GroupInfo, blockedByMember :: GroupMember, member :: GroupMember}
| CEvtUnknownMemberAnnounced {user :: User, groupInfo :: GroupInfo, announcingMember :: GroupMember, unknownMember :: GroupMember, announcedMember :: GroupMember}
| CEvtGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CEvtGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember} -- there is the same command response
| CEvtGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, msgSigned :: Bool}
| CEvtGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember, msgSigned :: Bool} -- there is the same command response
| CEvtAcceptingGroupJoinRequestMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CEvtNoMemberContactCreating {user :: User, groupInfo :: GroupInfo, member :: GroupMember} -- only used in CLI
| CEvtNewMemberContactReceivedInv {user :: User, contact :: Contact, groupInfo :: GroupInfo, member :: GroupMember}
src/Simplex/Chat/Delivery.hs
+1 -7
View File
@@ -125,20 +125,14 @@ data NewMessageDeliveryTask = NewMessageDeliveryTask
}
deriving (Show)
data FwdSender
= FwdMember MemberId ContactName
| FwdChannel
deriving (Show)
data MessageDeliveryTask = MessageDeliveryTask
{ taskId :: Int64,
jobScope :: DeliveryJobScope,
senderGMId :: GroupMemberId,
fwdSender :: FwdSender,
brokerTs :: UTCTime,
chatMessage :: ChatMessage 'Json
verifiedMsg :: VerifiedMsg 'Json
}
deriving (Show)
deliveryTaskId :: MessageDeliveryTask -> Int64
deliveryTaskId = taskId
src/Simplex/Chat/Library/Commands.hs
+44 -34
View File
@@ -1200,7 +1200,10 @@ processChatCommand vr nm = \case
deleteCIFiles user filesInfo
(members, recipients) <- getRecipients gInfo
let doSendDel = memberActive membership && isOwner
when doSendDel . void $ sendGroupMessage' user gInfo recipients XGrpDel
msgSigned <-
if doSendDel
then isJust . signedMsg_ <$> sendGroupMessage' user gInfo recipients XGrpDel
else pure False
deleteGroupLinkIfExists user gInfo
deleteMembersConnections' user members doSendDel
updateCIGroupInvitationStatus user gInfo CIGISRejected `catchAllErrors` \_ -> pure ()
@@ -1208,7 +1211,7 @@ processChatCommand vr nm = \case
withFastStore' $ \db -> cleanupHostGroupLinkConn db user gInfo
withFastStore' $ \db -> deleteGroupMembers db user gInfo
withFastStore' $ \db -> deleteGroup db user gInfo
pure $ CRGroupDeletedUser user gInfo
pure $ CRGroupDeletedUser user gInfo msgSigned
where
getRecipients gInfo
| useRelays' gInfo = do
@@ -2293,8 +2296,8 @@ processChatCommand vr nm = \case
addContactConn ct ctConns = case contactSendConn_ ct of
Right conn | directOrUsed ct -> (ct, conn) : ctConns
_ -> ctConns
ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, ChatMsgEvent 'Json)
ctSndEvent (_, Connection {connId}) = (ConnectionId connId, XMsgNew $ MCSimple (extMsgContent mc Nothing))
ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
ctSndEvent (_, Connection {connId}) = (ConnectionId connId, Nothing, XMsgNew $ MCSimple (extMsgContent mc Nothing))
ctMsgReq :: (Contact, Connection) -> SndMessage -> ChatMsgReq
ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, (vrValue msgBody, [msgId]))
combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError ([Int64], PQEncryption) -> Either ChatError (Contact, SndMessage)
@@ -2529,11 +2532,11 @@ processChatCommand vr nm = \case
when anyPending $ throwCmdError "can't change role of members pending approval"
assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole])
(errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems
(errs2, changed2, acis) <- changeRoleCurrentMems user g currentMems
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g currentMems
unless (null acis) $ toView $ CEvtNewChatItems user acis
let errs = errs1 <> errs2
unless (null errs) $ toView $ CEvtChatErrors errs
pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole} -- same order is not guaranteed
pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole, msgSigned} -- same order is not guaranteed
where
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
@@ -2564,19 +2567,20 @@ processChatCommand vr nm = \case
withFastStore' $ \db -> updateGroupMemberRole db user m newRole
pure (m :: GroupMember) {memberRole = newRole}
_ -> throwChatError $ CEGroupCantResendInvitation gInfo cName
changeRoleCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem])
changeRoleCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
changeRoleCurrentMems user (Group gInfo members) memsToChange = case L.nonEmpty memsToChange of
Nothing -> pure ([], [], [])
Nothing -> pure ([], [], [], False)
Just memsToChange' -> do
let events = L.map (\GroupMember {memberId} -> XGrpMemRole memberId newRole) memsToChange'
recipients = filter memberCurrent members
(msgs_, _gsr) <- sendGroupMessages user gInfo Nothing recipients events
let itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch"
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
pure (errs, changed, acis)
pure (errs, changed, acis, signed)
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
sndItemData GroupMember {groupMemberId, memberProfile} msg =
@@ -2618,7 +2622,8 @@ processChatCommand vr nm = \case
events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems'
recipients = filter memberCurrent remainingMems
(msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients events
let itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_)
let msgSigned = any (either (const False) (isJust . signedMsg_)) msgs_
itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch"
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
@@ -2627,7 +2632,7 @@ processChatCommand vr nm = \case
unless (null errs) $ toView $ CEvtChatErrors errs
-- TODO not batched - requires agent batch api
forM_ blocked $ \m -> toggleNtf m (not blockFlag)
pure CRMembersBlockedForAllUser {user, groupInfo = gInfo, members = blocked, blocked = blockFlag}
pure CRMembersBlockedForAllUser {user, groupInfo = gInfo, members = blocked, blocked = blockFlag, msgSigned}
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
sndItemData GroupMember {groupMemberId, memberProfile} msg =
@@ -2646,22 +2651,23 @@ processChatCommand vr nm = \case
assertUserGroupRole gInfo $ max GRAdmin maxRole
(errs1, deleted1) <- deleteInvitedMems user invitedMems
let recipients = filter memberCurrent members
(errs2, deleted2, acis2) <- deleteMemsSend user gInfo Nothing recipients currentMems
(errs3, deleted3, acis3) <-
foldM (\acc m -> deletePendingMember acc user gInfo [m] m) ([], [], []) pendingApprvMems
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing recipients currentMems
(errs3, deleted3, acis3, signed3) <-
foldM (\acc m -> deletePendingMember acc user gInfo [m] m) ([], [], [], False) pendingApprvMems
let moderators = filter (\GroupMember {memberRole} -> memberRole >= GRModerator) members
(errs4, deleted4, acis4) <-
foldM (\acc m -> deletePendingMember acc user gInfo (m : moderators) m) ([], [], []) pendingRvwMems
(errs4, deleted4, acis4, signed4) <-
foldM (\acc m -> deletePendingMember acc user gInfo (m : moderators) m) ([], [], [], False) pendingRvwMems
let acis = acis2 <> acis3 <> acis4
errs = errs1 <> errs2 <> errs3 <> errs4
deleted = deleted1 <> deleted2 <> deleted3 <> deleted4
msgSigned = signed2 || signed3 || signed4
-- Read group info with updated membersRequireAttention
gInfo' <- withFastStore $ \db -> getGroupInfo db vr user groupId
let acis' = map (updateACIGroupInfo gInfo') acis
unless (null acis') $ toView $ CEvtNewChatItems user acis'
unless (null errs) $ toView $ CEvtChatErrors errs
when withMessages $ deleteMessages user gInfo' deleted
pure $ CRUserDeletedMembers user gInfo' deleted withMessages -- same order is not guaranteed
pure $ CRUserDeletedMembers user gInfo' deleted withMessages msgSigned -- same order is not guaranteed
where
selectMembers :: S.Set GroupMemberId -> [GroupMember] -> (Int, [GroupMember], [GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool)
selectMembers gmIds = foldl' addMember (0, [], [], [], [], GRObserver, False)
@@ -2685,19 +2691,20 @@ processChatCommand vr nm = \case
delMember db m = do
deleteGroupMember db user m
pure m {memberStatus = GSMemRemoved}
deletePendingMember :: ([ChatError], [GroupMember], [AChatItem]) -> User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ([ChatError], [GroupMember], [AChatItem])
deletePendingMember (accErrs, accDeleted, accACIs) user gInfo recipients m = do
deletePendingMember :: ([ChatError], [GroupMember], [AChatItem], Bool) -> User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deletePendingMember (accErrs, accDeleted, accACIs, accSigned) user gInfo recipients m = do
(m', scopeInfo) <- mkMemberSupportChatInfo m
(errs, deleted, acis) <- deleteMemsSend user gInfo (Just scopeInfo) recipients [m']
pure (errs <> accErrs, deleted <> accDeleted, acis <> accACIs)
deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem])
(errs, deleted, acis, signed) <- deleteMemsSend user gInfo (Just scopeInfo) recipients [m']
pure (errs <> accErrs, deleted <> accDeleted, acis <> accACIs, accSigned || signed)
deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deleteMemsSend user gInfo chatScopeInfo recipients memsToDelete = case L.nonEmpty memsToDelete of
Nothing -> pure ([], [], [])
Nothing -> pure ([], [], [], False)
Just memsToDelete' -> do
let chatScope = toChatScope <$> chatScopeInfo
events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages) memsToDelete'
(msgs_, _gsr) <- sendGroupMessages user gInfo chatScope recipients events
let itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
skipUnwantedItem = \case
Right Nothing -> Nothing
Right (Just a) -> Just $ Right a
@@ -2707,7 +2714,7 @@ processChatCommand vr nm = \case
deleteMembersConnections' user memsToDelete True
(errs, deleted) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete)
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo chatScopeInfo)) $ rights cis_
pure (errs, deleted, acis)
pure (errs, deleted, acis, signed)
where
sndItemData :: GroupMember -> SndMessage -> Maybe (NewSndChatItemData c)
sndItemData GroupMember {groupMemberId, memberProfile, memberStatus} msg
@@ -3409,11 +3416,14 @@ processChatCommand vr nm = \case
let allowSimplexLinks = maybe True (groupFeatureUserAllowed SGFSimplexLinks) gInfo_'
in userProfileInGroup' user allowSimplexLinks incognitoProfile
Nothing -> userProfileDirect user incognitoProfile Nothing True
chatEvent = case gInfo_ of
Just (Just gInfo) | useRelays' gInfo ->
let GroupInfo {membership = GroupMember {memberId}} = gInfo
in XMember profileToSend memberId
_ -> XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
g <- asks random
chatEvent <- case gInfo_ of
Just (Just gInfo) | useRelays' gInfo -> do
let GroupInfo {membership = GroupMember {memberId}} = gInfo
(memberPubKey, _memberPrivKey) <- atomically $ C.generateKeyPair g
-- TODO: store memberPrivKey in groups.member_priv_key, memberPubKey in group_members.member_pub_key
pure $ XMember profileToSend memberId (MemberKey memberPubKey)
_ -> pure $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
dm <- encodeConnInfoPQ pqSup chatV chatEvent
subMode <- chatReadVar subscriptionMode
void $ withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup subMode
@@ -3481,8 +3491,8 @@ processChatCommand vr nm = \case
mergedProfile = userProfileDirect user Nothing (Just ct) False
ct' = updateMergedPreferences user' ct
mergedProfile' = userProfileDirect user' Nothing (Just ct') False
ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, ChatMsgEvent 'Json)
ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, XInfo mergedProfile')
ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, Nothing, XInfo mergedProfile')
ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq
ctMsgReq ChangedProfileContact {conn} =
fmap $ \SndMessage {msgId, msgBody} ->
@@ -3548,7 +3558,7 @@ processChatCommand vr nm = \case
ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p')
toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo' Nothing) ci]
createGroupFeatureChangedItems user cd CISndGroupFeature gInfo gInfo'
pure $ CRGroupUpdated user gInfo gInfo' Nothing
pure $ CRGroupUpdated user gInfo gInfo' Nothing (isJust $ signedMsg_ msg)
checkValidName :: GroupName -> CM ()
checkValidName displayName = do
when (T.null displayName) $ throwChatError CEInvalidDisplayName {displayName, validName = ""}
src/Simplex/Chat/Library/Internal.hs
+68 -54
View File
@@ -58,7 +58,7 @@ import Simplex.Chat.Controller
import Simplex.Chat.Files
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages)
import Simplex.Chat.Messages.Batch (BatchMode (..), MsgBatch (..), batchMessages)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Operators
@@ -95,6 +95,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding (smpEncode)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (MsgBody, MsgFlags (..), ProtoServerWithAuth (..), ProtocolServer, ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer)
import qualified Simplex.Messaging.Protocol as SMP
@@ -1104,7 +1105,7 @@ introduceMember user gInfo@GroupInfo {groupId} toMember@GroupMember {activeConn
then do
let events = map (memberIntroEvt gInfo) shuffledReMembers
forM_ (L.nonEmpty events) $ \events' ->
sendGroupMemberMessages user conn events' groupId
sendGroupMemberMessages user gInfo conn events'
else forM_ shuffledReMembers $ \reMember ->
void $ sendDirectMemberMessage conn (memberIntroEvt gInfo reMember) groupId
updateToMemberVector :: [GroupMember] -> CM ()
@@ -1139,11 +1140,11 @@ memberIntroEvt gInfo reMember =
-- This doesn't create introduction records in db, compared to above methods.
introduceModerators :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceModerators _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
introduceModerators vr user gInfo@GroupInfo {groupId} GroupMember {activeConn = Just conn} = do
introduceModerators vr user gInfo GroupMember {activeConn = Just conn} = do
modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo
let events = map (memberIntroEvt gInfo) modMs
forM_ (L.nonEmpty events) $ \events' ->
sendGroupMemberMessages user conn events' groupId
sendGroupMemberMessages user gInfo conn events'
userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup user = userProfileInGroup' user . groupFeatureUserAllowed SGFSimplexLinks
@@ -1160,7 +1161,8 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, activeConn} =
{ memberId,
memberRole,
v = ChatVersionRange . peerChatVRange <$> activeConn,
profile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile memberProfile
profile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile memberProfile,
memberKey = Nothing -- TODO: get from GroupMember when stored in database
}
where
allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m g
@@ -1175,7 +1177,7 @@ redactedMemberProfile allowSimplexLinks Profile {displayName, fullName, shortDes
sendHistory :: User -> GroupInfo -> GroupMember -> CM ()
sendHistory _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn = Just conn} =
sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just conn} =
when (m `supportsVersion` batchSendVersion) $ do
(errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100)
(errs', events) <- partitionEithers <$> mapM (tryAllErrors . itemForwardEvents) items
@@ -1190,7 +1192,7 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn
_ -> events' <> [descr]
Nothing -> pure events'
forM_ (L.nonEmpty events_) $ \events'' ->
sendGroupMemberMessages user conn events'' groupId
sendGroupMemberMessages user gInfo conn events''
where
descrEvent_ :: Maybe (ChatMsgEvent 'Json)
descrEvent_
@@ -1264,9 +1266,9 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn
pure . L.toList $ L.map (XMsgFileDescr msgId) parts
_ -> pure []
let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents
memberId_ = memberId' <$> sender_
memberName_ = memberShortenedName <$> sender_
msgForwardEvents = map (\cm -> XGrpMsgForward memberId_ memberName_ cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs)
fwdSender = maybe FwdChannel (\s -> FwdMember (memberId' s) (memberShortenedName s)) sender_
fwd = GrpMsgForward {fwdSender, fwdBrokerTs = itemTs}
msgForwardEvents = map (XGrpMsgForward fwd) (xMsgNewChatMsg : fileDescrChatMsgs)
pure msgForwardEvents
memberShortenedName :: GroupMember -> ContactName
@@ -1549,7 +1551,7 @@ sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg =
parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage conn s = do
case parseChatMessages s of
[msg] -> liftEither . first (ChatError . errType) $ (\(ACMsg _ m) -> checkEncoding m) =<< msg
[msg] -> liftEither . first (ChatError . errType) $ (\(APMsg _ (ParsedMsg _ _ m)) -> checkEncoding m) =<< msg
_ -> throwChatError $ CEException "parseChatMessage: single message is expected"
where
errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s)
@@ -1810,10 +1812,10 @@ sendDirectContactMessages user ct events = do
sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage]
sendDirectContactMessages' user ct events = do
conn@Connection {connId} <- liftEither $ contactSendConn_ ct
let idsEvts = L.map (ConnectionId connId,) events
let idsEvts = L.map (ConnectionId connId,Nothing,) events
msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events}
sndMsgs_ <- lift $ createSndMessages idsEvts
(sndMsgs', pqEnc_) <- batchSendConnMessagesB user conn msgFlags sndMsgs_
(sndMsgs', pqEnc_) <- batchSendConnMessagesB BMJson user conn msgFlags sndMsgs_
forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc'
pure sndMsgs'
@@ -1851,37 +1853,44 @@ sendDirectMessage_ conn chatMsgEvent connOrGroupId = do
createSndMessage :: MsgEncodingI e => ChatMsgEvent e -> ConnOrGroupId -> CM SndMessage
createSndMessage chatMsgEvent connOrGroupId =
liftEither . runIdentity =<< lift (createSndMessages $ Identity (connOrGroupId, chatMsgEvent))
liftEither . runIdentity =<< lift (createSndMessages $ Identity (connOrGroupId, Nothing, chatMsgEvent))
createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage))
createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage))
createSndMessages idsEvents = do
g <- asks random
vr <- chatVersionRange'
withStoreBatch $ \db -> fmap (createMsg db g vr) idsEvents
where
createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, ChatMsgEvent e) -> IO (Either ChatError SndMessage)
createMsg db g vr (connOrGroupId, evnt) = runExceptT $ do
withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId evnt encodeMessage
createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e) -> IO (Either ChatError SndMessage)
createMsg db g vr (connOrGroupId, msgSigning_, evnt) = runExceptT $ do
withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId evnt msgSigning_ encodeMessage
where
encodeMessage sharedMsgId =
encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> CM ()
sendGroupMemberMessages user conn events groupId = do
groupMsgSigning :: GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning
groupMsgSigning gInfo@GroupInfo {membership = GroupMember {memberId}, groupKeys = Just GroupKeys {groupRootKey, memberPrivKey}} evt
| useRelays' gInfo && requiresSignature (toCMEventTag evt) =
Just $ MsgSigning CBGroup (smpEncode (groupRootPubKey groupRootKey, memberId)) KRMember memberPrivKey
groupMsgSigning _ _ = Nothing
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfo -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
let idsEvts = L.map (GroupId groupId,) events
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning gInfo evt, evt)) events
mode = if useRelays' gInfo then BMBinary else BMJson
(errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts
unless (null errs) $ toView $ CEvtChatErrors errs
forM_ (L.nonEmpty msgs) $ \msgs' ->
batchSendConnMessages user conn MsgFlags {notification = True} msgs'
batchSendConnMessages mode user conn MsgFlags {notification = True} msgs'
batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessages user conn msgFlags msgs =
batchSendConnMessagesB user conn msgFlags $ L.map Right msgs
batchSendConnMessages :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessages mode user conn msgFlags msgs =
batchSendConnMessagesB mode user conn msgFlags $ L.map Right msgs
batchSendConnMessagesB :: User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessagesB _user conn msgFlags msgs_ = do
let batched_ = batchSndMessagesJSON msgs_
batchSendConnMessagesB :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessagesB mode _user conn msgFlags msgs_ = do
let batched_ = batchSndMessagesJSON mode msgs_
case L.nonEmpty batched_ of
Just batched' -> do
let msgReqs = L.map (fmap msgBatchReq_) batched'
@@ -1902,8 +1911,8 @@ batchSendConnMessagesB _user conn msgFlags msgs_ = do
findLastPQEnc :: NonEmpty (Either ChatError ([Int64], PQEncryption)) -> Maybe PQEncryption
findLastPQEnc = foldr' (\x acc -> case x of Right (_, pqEnc) -> Just pqEnc; Left _ -> acc) Nothing
batchSndMessagesJSON :: NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch]
batchSndMessagesJSON = batchMessages maxEncodedMsgLength . L.toList
batchSndMessagesJSON :: BatchMode -> NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch]
batchSndMessagesJSON mode = batchMessages mode maxEncodedMsgLength . L.toList
encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString
encodeConnInfo chatMsgEvent = do
@@ -2029,7 +2038,7 @@ data GroupSndResult = GroupSndResult
sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages_ _user gInfo@GroupInfo {groupId} recipientMembers events = do
let idsEvts = L.map (GroupId groupId,) events
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning gInfo evt, evt)) events
sndMsgs_ <- lift $ createSndMessages idsEvts
recipientMembers' <- liftIO $ shuffleMembers recipientMembers
let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events}
@@ -2071,7 +2080,8 @@ sendGroupMessages_ _user gInfo@GroupInfo {groupId} recipientMembers events = do
mIds' = S.insert mId mIds
prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
prepareMsgReqs msgFlags msgs toSendSeparate toSendBatched = do
let batched_ = batchSndMessagesJSON msgs
let mode = if useRelays' gInfo then BMBinary else BMJson
batched_ = batchSndMessagesJSON mode msgs
case L.nonEmpty batched_ of
Just batched' -> do
let lenMsgs = length msgs
@@ -2188,29 +2198,31 @@ sendGroupMemberMessage gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} c
MSAForwarded -> pure ()
-- TODO ensure order - pending messages interleave with user input messages
sendPendingGroupMessages :: User -> GroupMember -> Connection -> CM ()
sendPendingGroupMessages user GroupMember {groupMemberId} conn = do
sendPendingGroupMessages :: User -> GroupInfo -> GroupMember -> Connection -> CM ()
sendPendingGroupMessages user gInfo GroupMember {groupMemberId} conn = do
let mode = if useRelays' gInfo then BMBinary else BMJson
msgs <- withStore' $ \db -> getPendingGroupMessages db groupMemberId
forM_ (L.nonEmpty msgs) $ \msgs' -> do
void $ batchSendConnMessages user conn MsgFlags {notification = True} msgs'
void $ batchSendConnMessages mode user conn MsgFlags {notification = True} msgs'
lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs'
saveDirectRcvMSG :: MsgEncodingI e => Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (Connection, RcvMessage)
saveDirectRcvMSG conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do
saveDirectRcvMSG :: forall e. MsgEncodingI e => Connection -> MsgMeta -> ChatMessage e -> CM (Connection, RcvMessage)
saveDirectRcvMSG conn@Connection {connId} agentMsgMeta chatMsg@ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do
conn' <- updatePeerChatVRange conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
brokerTs = metaBrokerTs agentMsgMeta
newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs}
newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg = VMUnsigned chatMsg, brokerTs}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta}
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
pure (conn', msg)
saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do
saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> VerifiedMsg e -> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta verifiedMsg = do
let ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = verifiedChatMsg verifiedMsg
(am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
brokerTs = metaBrokerTs agentMsgMeta
newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs}
newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta}
msg <-
withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId)
@@ -2224,9 +2236,10 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta
_ -> throwError e
pure (am', conn', msg)
saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> Maybe GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM (Maybe RcvMessage)
saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMember_ msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} brokerTs = do
let newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs}
saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> Maybe GroupMember -> VerifiedMsg e -> UTCTime -> CM (Maybe RcvMessage)
saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMember_ verifiedMsg brokerTs = do
let ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = verifiedChatMsg verifiedMsg
newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs}
fwdMemberId = Just $ groupMemberId' forwardingMember
refAuthorId = groupMemberId' <$> refAuthorMember_
-- TODO [relays] TBC highlighting difference between deduplicated messages (useRelays branch)
@@ -2285,11 +2298,12 @@ saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do
lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData)
where
createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do
createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId, signedMsg_}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do
let hasLink_ = ciContentHasLink content (snd itemTexts)
signed = isJust signedMsg_
ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing createdAt
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing signed createdAt
Right <$> case cd of
CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions
_ -> pure ci
@@ -2305,7 +2319,7 @@ ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe Markdown
ciContentNoParse content = (content, (ciContentToText content, Nothing))
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
createdAt <- liftIO getCurrentTime
vr <- chatVersionRange
withStore' $ \db -> do
@@ -2320,7 +2334,7 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} shared
hasLink_ = ciContentHasLink content ft_
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention hasLink_ brokerTs createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember createdAt
let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember msgSigned createdAt
ci' <- case toChatInfo cd of
GroupChat g _ | not (null mentions') -> createGroupCIMentions db g ci mentions'
_ -> pure ci
@@ -2348,12 +2362,12 @@ mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAs
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
let ts@(_, ft_) = ciContentTexts content
hasLink_ = ciContentHasLink content ft_
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember currentTs
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember False currentTs
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember currentTs =
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Bool -> UTCTime -> ChatItem c d
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs =
let itemStatus = ciCreateStatus content
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender currentTs currentTs
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned currentTs currentTs
in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file}
ciContentHasLink :: CIContent d -> Maybe MarkdownList -> Bool
@@ -2661,9 +2675,9 @@ createLocalChatItems user cd itemsData createdAt = do
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
createItem db (content, ciFile, itemForwarded, ts@(_, ft_)) = do
let hasLink_ = ciContentHasLink content ft_
ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing createdAt
ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing False createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing createdAt
pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing False createdAt
withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
withUser' action =
src/Simplex/Chat/Library/Subscriber.hs
+113 -87
View File
@@ -46,7 +46,7 @@ import Simplex.Chat.Controller
import Simplex.Chat.Delivery
import Simplex.Chat.Library.Internal
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (batchDeliveryTasks1)
import Simplex.Chat.Messages.Batch (batchDeliveryTasks1, encodeBinaryBatch, encodeFwdElement)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
@@ -84,6 +84,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding (smpEncode)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..))
import qualified Simplex.Messaging.Protocol as SMP
@@ -258,13 +259,13 @@ processAgentMsgSndFile _corrId aFileId msg = do
unless (null errs') $ toView $ CEvtChatErrors errs'
pure delivered
where
connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json))
connDescrEvents partSize = L.fromList $ concatMap splitText (L.toList connsTransfersDescrs)
where
splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json))]
splitText (conn, _, rfdText) =
map (\fileDescr -> (conn, (connOrGroupId, XMsgFileDescr {msgId = sharedMsgId, fileDescr}))) (L.toList $ splitFileDescr partSize rfdText)
toMsgReq :: (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq
map (\fileDescr -> (conn, (connOrGroupId, Nothing, XMsgFileDescr {msgId = sharedMsgId, fileDescr}))) (L.toList $ splitFileDescr partSize rfdText)
toMsgReq :: (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq
toMsgReq (conn, _) SndMessage {msgId, msgBody} =
(conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, (vrValue msgBody, [msgId]))
sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
@@ -461,7 +462,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(ct', conn') <- updateContactPQRcv user ct conn pqEncryption
checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchAllErrors` \_ -> pure ()
forM_ aChatMsgs $ \case
Right (ACMsg _ chatMsg) ->
Right (APMsg _ (ParsedMsg _ _ chatMsg)) ->
processEvent ct' conn' tags eInfo chatMsg `catchAllErrors` \e -> eToView e
Left e -> do
atomically $ modifyTVar' tags ("error" :)
@@ -476,8 +477,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let tag = toCMEventTag chatMsgEvent
atomically $ modifyTVar' tags (tshow tag :)
logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo
let body = chatMsgToBody chatMsg
(conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta body chatMsg
(conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta chatMsg
let ct'' = ct' {activeConn = Just conn''} :: Contact
case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
@@ -502,12 +502,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
XCallEnd callId -> xCallEnd ct'' callId msg
BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta
_ -> messageError $ "unsupported message: " <> T.pack (show event)
checkSendRcpt :: Contact -> [AChatMessage] -> CM Bool
checkSendRcpt :: Contact -> [AParsedMsg] -> CM Bool
checkSendRcpt ct' aMsgs = do
let Contact {chatSettings = ChatSettings {sendRcpts}} = ct'
pure $ fromMaybe (sendRcptsContacts user) sendRcpts && any aChatMsgHasReceipt aMsgs
where
aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) =
aChatMsgHasReceipt (APMsg _ (ParsedMsg _ _ ChatMessage {chatMsgEvent})) =
hasDeliveryReceipt (toCMEventTag chatMsgEvent)
RCVD msgMeta msgRcpt ->
withAckMessage' "contact rcvd" agentConnId msgMeta $
@@ -792,7 +792,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
CON _pqEnc -> unless (memberStatus m == GSMemRejected || memberStatus membership == GSMemRejected) $ do
-- TODO [knocking] send pending messages after accepting?
-- possible improvement: check for each pending message, requires keeping track of connection state
unless (connDisabled conn) $ sendPendingGroupMessages user m conn
unless (connDisabled conn) $ sendPendingGroupMessages user gInfo m conn
withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings
case memberCategory m of
GCHostMember -> do
@@ -868,7 +868,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
sendXGrpLinkMem gInfo'' = do
let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo''
profileToSend = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile)
void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId
void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend Nothing) groupId -- TODO: send member key
_ -> do
unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected
notifyMemberConnected gInfo m Nothing
@@ -897,7 +897,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- possible improvement is to choose scope based on event (some events specify scope)
(gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m
checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchAllErrors` \_ -> pure ()
newDeliveryTasks <- reverse <$> foldM (processAChatMsg gInfo' m' tags eInfo) [] aChatMsgs
newDeliveryTasks <- reverse <$> foldM (processAChatMsg gInfo' scopeInfo m' tags eInfo) [] aChatMsgs
shouldDelConns <-
if isUserGrpFwdRelay gInfo' && not (blockedByAdmin m)
then createDeliveryTasks gInfo' m' newDeliveryTasks
@@ -909,31 +909,38 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
brokerTs = metaBrokerTs msgMeta
processAChatMsg ::
GroupInfo ->
Maybe GroupChatScopeInfo ->
GroupMember ->
TVar [Text] ->
Text ->
[NewMessageDeliveryTask] ->
Either String AChatMessage ->
Either String AParsedMsg ->
CM [NewMessageDeliveryTask]
processAChatMsg gInfo' m' tags eInfo newDeliveryTasks = \case
Right (ACMsg SJson chatMsg) -> do
newTask_ <- processEvent gInfo' m' tags eInfo chatMsg `catchAllErrors` \e -> eToView e $> Nothing
pure $ maybe newDeliveryTasks (: newDeliveryTasks) newTask_
Right (ACMsg SBinary chatMsg) -> do
void (processEvent gInfo' m' tags eInfo chatMsg) `catchAllErrors` \e -> eToView e
pure newDeliveryTasks
processAChatMsg gInfo' scopeInfo m' tags eInfo newDeliveryTasks = \case
Right (APMsg enc (parsedMsg@(ParsedMsg fwd_ _ ChatMessage {chatMsgEvent}))) -> do
let tag = toCMEventTag chatMsgEvent
atomically $ modifyTVar' tags (tshow tag :)
case fwd_ of
Just fwd | SJson <- enc -> do
logInfo $ "group fwd=" <> tshow tag <> " " <> eInfo
xGrpMsgForward gInfo' scopeInfo m' fwd parsedMsg brokerTs
`catchAllErrors` \e -> eToView e
pure newDeliveryTasks
-- direct JSON and binary messages; binary events don't produce delivery tasks
_ -> do
logInfo $ "group msg=" <> tshow tag <> " " <> eInfo
newTask_ <- join <$> withVerifiedMsg gInfo' scopeInfo m' parsedMsg brokerTs
(\verifiedMsg -> processEvent gInfo' m' verifiedMsg `catchAllErrors` \e -> eToView e $> Nothing)
pure $ maybe id (:) newTask_ newDeliveryTasks
Left e -> do
atomically $ modifyTVar' tags ("error" :)
logInfo $ "group msg=error " <> eInfo <> " " <> tshow e
eToView (ChatError . CEException $ "error parsing chat message: " <> e)
pure newDeliveryTasks
processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> TVar [Text] -> Text -> ChatMessage e -> CM (Maybe NewMessageDeliveryTask)
processEvent gInfo' m' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do
let tag = toCMEventTag chatMsgEvent
atomically $ modifyTVar' tags (tshow tag :)
logInfo $ "group msg=" <> tshow tag <> " " <> eInfo
let body = chatMsgToBody chatMsg
(m'', conn', msg@RcvMessage {msgId, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta body chatMsg
processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> VerifiedMsg e -> CM (Maybe NewMessageDeliveryTask)
processEvent gInfo' m' verifiedMsg = do
let chatMsg = verifiedChatMsg verifiedMsg
(m'', conn', msg@RcvMessage {msgId, msgSigned, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta verifiedMsg
let ctx js = DeliveryTaskContext js False
checkSendAsGroup :: Maybe Bool -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext)
checkSendAsGroup asGroup_ a
@@ -960,7 +967,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
XFileCancel sharedMsgId -> xFileCancelGroup gInfo' (Just m'') sharedMsgId
XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName
XInfo p -> fmap ctx <$> xInfoMember gInfo' m'' p brokerTs
XGrpLinkMem p -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p
XGrpLinkMem p memberKey -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p memberKey
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs
XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs
XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_
@@ -975,10 +982,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
XGrpLeave -> fmap ctx <$> xGrpLeave gInfo' m'' msg brokerTs
XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs
XGrpInfo p' -> fmap ctx <$> xGrpInfo gInfo' m'' p' msg brokerTs
XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps'
XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs msgSigned gInfo' m'' ps'
-- TODO [knocking] why don't we forward these messages?
XGrpDirectInv connReq mContent_ msgScope -> memberCanSend (Just m'') msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs
XGrpMsgForward memberId memberName msg' msgTs -> Nothing <$ xGrpMsgForward gInfo' m'' memberId memberName msg' msgTs brokerTs
XGrpMsgForward fwd msg' -> Nothing <$ xGrpMsgForward gInfo' Nothing m'' fwd (ParsedMsg Nothing Nothing msg') brokerTs
XInfoProbe probe -> Nothing <$ xInfoProbe (COMGroupMember m'') probe
XInfoProbeCheck probeHash -> Nothing <$ xInfoProbeCheck (COMGroupMember m'') probeHash
XInfoProbeOk probe -> Nothing <$ xInfoProbeOk (COMGroupMember m'') probe
@@ -986,7 +993,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
_ -> Nothing <$ messageError ("unsupported message: " <> tshow event)
forM deliveryTaskContext_ $ \taskContext ->
pure $ NewMessageDeliveryTask {messageId = msgId, taskContext}
checkSendRcpt :: [AChatMessage] -> CM Bool
checkSendRcpt :: [AParsedMsg] -> CM Bool
checkSendRcpt aMsgs = do
let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo
GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo
@@ -995,7 +1002,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
&& any aChatMsgHasReceipt aMsgs
&& currentMemCount <= smallGroupsRcptsMemLimit
where
aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) =
aChatMsgHasReceipt (APMsg _ (ParsedMsg _ _ ChatMessage {chatMsgEvent})) =
hasDeliveryReceipt (toCMEventTag chatMsgEvent)
createDeliveryTasks :: GroupInfo -> GroupMember -> [NewMessageDeliveryTask] -> CM ShouldDeleteGroupConns
createDeliveryTasks gInfo'@GroupInfo {groupId = gId} m' newDeliveryTasks = do
@@ -1033,7 +1040,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
updateGroupItemsStatus gInfo m conn msgId GSSSent (Just $ isJust proxy)
when continued $ sendPendingGroupMessages user m conn
when continued $ sendPendingGroupMessages user gInfo m conn
SWITCH qd phase cStats -> do
toView $ CEvtGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
(gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m
@@ -1098,13 +1105,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let GroupMember {memberId = membershipMemId} = membership
incognitoProfile = fromLocalProfile <$> incognitoMembershipProfile gInfo
profileToSend = userProfileInGroup user gInfo incognitoProfile
dm <- encodeConnInfo $ XMember profileToSend membershipMemId
g <- asks random
(memberPubKey, _memberPrivKey) <- atomically $ C.generateKeyPair g
-- TODO: store memberPrivKey in groups.member_priv_key, memberPubKey in group_members.member_pub_key
dm <- encodeConnInfo $ XMember profileToSend membershipMemId (MemberKey memberPubKey)
subMode <- chatReadVar subscriptionMode
void $ joinAgentConnectionAsync user (Just conn) True cReq dm subMode
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
QCONT -> do
continued <- continueSending connEntity conn
when continued $ sendPendingGroupMessages user m conn
when continued $ sendPendingGroupMessages user gInfo m conn
MWARN msgId err -> do
withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSWarning $ agentSndError err)
processConnMWARN connEntity conn err
@@ -1211,7 +1221,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
case chatMsgEvent of
XContact p xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ pqSupport
XMember p joiningMemberId -> memberJoinRequestViaRelay invId chatVRange p joiningMemberId
XMember p joiningMemberId joiningMemberKey -> memberJoinRequestViaRelay invId chatVRange p joiningMemberId joiningMemberKey
XInfo p -> profileContactRequest invId chatVRange p Nothing Nothing Nothing pqSupport
XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv
-- TODO show/log error, other events in contact request
@@ -1422,8 +1432,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
lift $ void $ getRelayRequestWorker True
-- TODO [relays] owner, relays: TBC how to communicate member rejection rules from owner to relays
-- TODO [relays] relay: TBC communicate rejection when memberId already exists (currently checked in createJoiningMember)
memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Profile -> MemberId -> CM ()
memberJoinRequestViaRelay invId chatVRange p joiningMemberId = do
memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Profile -> MemberId -> MemberKey -> CM ()
memberJoinRequestViaRelay invId chatVRange p joiningMemberId _joiningMemberKey = do -- TODO: store memberKey in group_members.member_pub_key
(_ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId
case gLinkInfo_ of
Just GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
@@ -2387,8 +2397,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs)
pure $ memberEventDeliveryScope m
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> Maybe MemberKey -> CM ()
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' _memberKey = do -- TODO: store memberKey
xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId
if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived
then do
@@ -2489,7 +2499,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of
Just bc | isMainBusinessMember bc m -> do
g' <- withStore $ \db -> updateGroupProfileFromMember db user g p'
toView $ CEvtGroupUpdated user g g' (Just m)
toView $ CEvtGroupUpdated user g g' (Just m) False
_ -> pure ()
isMainBusinessMember BusinessChatInfo {chatType, businessId, customerId} GroupMember {memberId} = case chatType of
BCBusiness -> businessId == memberId
@@ -2733,7 +2743,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
_ -> pure (conn', Nothing)
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _) msgScope_ msg brokerTs = do
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _ _) msgScope_ msg brokerTs = do
checkHostRole m memRole
if sameMemberId memId (membership gInfo)
then pure Nothing
@@ -2786,7 +2796,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
pure (announcedMember', Just scopeInfo)
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM ()
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) memRestrictions = do
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ _) memRestrictions = do
case memberCategory m of
GCHostMember ->
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
@@ -2831,7 +2841,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) IntroInvitation {groupConnReq, directConnReq} = do
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _ _) IntroInvitation {groupConnReq, directConnReq} = do
let GroupMember {memberId = membershipMemId} = membership
checkHostRole m memRole
toMember <- withStore $ \db -> do
@@ -2864,7 +2874,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg@RcvMessage {msgSigned} brokerTs
| membershipMemId == memId =
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
in changeMemberRole gInfo' membership $ RGEUserRole memRole
@@ -2882,7 +2892,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo' m
(ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent gEvent)
groupMsgToView cInfo ci
toView CEvtMemberRole {user, groupInfo = gInfo'', byMember = m', member = member {memberRole = memRole}, fromRole, toRole = memRole}
toView CEvtMemberRole {user, groupInfo = gInfo'', byMember = m', member = member {memberRole = memRole}, fromRole, toRole = memRole, msgSigned}
pure $ memberEventDeliveryScope member
checkHostRole :: GroupMember -> GroupMemberRole -> CM ()
@@ -2895,12 +2905,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
m@GroupMember {memberRole = senderRole}
memId
MemberRestrictions {restriction}
msg
msg@RcvMessage {msgSigned}
brokerTs
| membershipMemId == memId = pure Nothing -- ignore - XGrpMemRestrict can be sent to restricted member for efficiency
| otherwise = do
unknownRole <- unknownMemberRole gInfo
(bm, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memId Nothing unknownRole
(bm, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memId "" unknownRole
let GroupMember {groupMemberId = bmId, memberRole, blockedByAdmin, memberProfile = bmp} = bm
if
| blockedByAdmin == mrsBlocked restriction -> pure Nothing
@@ -2914,7 +2924,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs ciContent
when unknown $ toView $ CEvtUnknownMemberBlocked user gInfo m bm'
groupMsgToView cInfo ci
toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm', blocked}
toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm', blocked, msgSigned}
pure $ memberEventDeliveryScope bm
where
setMemberBlocked bm = withStore' $ \db -> updateGroupMemberBlocked db user gInfo restriction bm
@@ -2928,7 +2938,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> ChatMessage 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages chatMsg msg brokerTs forwarded = do
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages chatMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do
let GroupMember {memberId = membershipMemId} = membership
if membershipMemId == memId
then checkRole membership $ do
@@ -2939,7 +2949,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let membership' = membership {memberStatus = GSMemRemoved}
when withMessages $ deleteMessages gInfo membership' SMDSnd
deleteMemberItem gInfo RGEUserDeleted
toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages
toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned
pure $ Just DJSGroup {jobSpec = DJRelayRemoved}
else
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
@@ -2966,7 +2976,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
deletedMember' = deletedMember {memberStatus = GSMemRemoved}
when withMessages $ deleteMessages gInfo' deletedMember' SMDRcv
unless wasDeleted $ deleteMemberItem gInfo' $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)
toView $ CEvtDeletedMember user gInfo' m deletedMember' withMessages
toView $ CEvtDeletedMember user gInfo' m deletedMember' withMessages msgSigned
pure deliveryScope
where
checkRole GroupMember {memberRole} a
@@ -2983,9 +2993,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| otherwise = markGroupMemberCIsDeleted user gInfo' delMem m
forwardToMember :: GroupMember -> CM ()
forwardToMember member = do
let GroupMember {memberId} = m
memberName = Just $ memberShortenedName m
event = XGrpMsgForward (Just memberId) memberName chatMsg brokerTs
let fwd = GrpMsgForward {fwdSender = FwdMember (memberId' m) (memberShortenedName m), fwdBrokerTs = brokerTs}
event = XGrpMsgForward fwd chatMsg
sendGroupMemberMessage gInfo member event
isUserGrpFwdRelay :: GroupInfo -> Bool
@@ -3015,7 +3024,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
pure $ memberEventDeliveryScope m
xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do
xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg@RcvMessage {msgSigned} brokerTs = do
when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted
-- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
@@ -3023,36 +3032,36 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo m
(ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEGroupDeleted)
groupMsgToView cInfo ci
toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m'
toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m' msgSigned
xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg brokerTs
xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg@RcvMessage {msgSigned} brokerTs
| memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" $> Nothing
| otherwise = do
case businessChat of
Nothing -> unless (p == p') $ do
g' <- withStore $ \db -> updateGroupProfile db user g p'
(g'', m', scopeInfo) <- mkGroupChatScope g' m
toView $ CEvtGroupUpdated user g g'' (Just m')
toView $ CEvtGroupUpdated user g g'' (Just m') msgSigned
let cd = CDGroupRcv g'' scopeInfo m'
unless (sameGroupProfileInfo p p') $ do
(ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p')
groupMsgToView cInfo ci
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g''
void $ forkIO $ void $ setGroupLinkData' NRMBackground user g''
Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
Just _ -> updateGroupPrefs_ msgSigned g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM (Maybe DeliveryJobScope)
xGrpPrefs g m@GroupMember {memberRole} ps'
xGrpPrefs :: Bool -> GroupInfo -> GroupMember -> GroupPreferences -> CM (Maybe DeliveryJobScope)
xGrpPrefs msgSigned g m@GroupMember {memberRole} ps'
| memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" $> Nothing
| otherwise = updateGroupPrefs_ g m ps' $> Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
| otherwise = updateGroupPrefs_ msgSigned g m ps' $> Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM ()
updateGroupPrefs_ g@GroupInfo {groupProfile = p} m ps' =
updateGroupPrefs_ :: Bool -> GroupInfo -> GroupMember -> GroupPreferences -> CM ()
updateGroupPrefs_ msgSigned g@GroupInfo {groupProfile = p} m ps' =
unless (groupPreferences p == Just ps') $ do
g' <- withStore' $ \db -> updateGroupPreferences db user g ps'
toView $ CEvtGroupUpdated user g g' (Just m)
toView $ CEvtGroupUpdated user g g' (Just m) msgSigned
(g'', m', scopeInfo) <- mkGroupChatScope g' m
let cd = CDGroupRcv g'' scopeInfo m'
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g''
@@ -3146,23 +3155,23 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toViewTE $ TEContactVerificationReset user ct
createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing
xGrpMsgForward :: GroupInfo -> GroupMember -> Maybe MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> UTCTime -> CM ()
xGrpMsgForward gInfo m@GroupMember {localDisplayName} memberId_ memberName_ chatMsg msgTs brokerTs = do
xGrpMsgForward :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> GrpMsgForward -> ParsedMsg 'Json -> UTCTime -> CM ()
xGrpMsgForward gInfo scopeInfo m@GroupMember {localDisplayName} GrpMsgForward {fwdSender, fwdBrokerTs = msgTs} parsedMsg@(ParsedMsg _ _ chatMsg@ChatMessage {chatMsgEvent}) brokerTs = do
unless (isMemberGrpFwdRelay gInfo m) $ throwChatError (CEGroupContactRole localDisplayName)
case memberId_ of
Just memberId -> do
case fwdSender of
FwdMember memberId memberName -> do
unknownRole <- unknownMemberRole gInfo
(author, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName_ unknownRole
(author, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownRole
when unknown $ toView $ CEvtUnknownMemberCreated user gInfo m author
processForwardedMsg (Just author)
Nothing -> processForwardedMsg Nothing
void $ withVerifiedMsg gInfo scopeInfo author parsedMsg msgTs $
(`processForwardedMsg` Just author)
FwdChannel -> processForwardedMsg (VMUnsigned chatMsg) Nothing
where
-- ! see isForwardedGroupMsg: forwarded group events should include msgId to be deduplicated
processForwardedMsg :: Maybe GroupMember -> CM ()
processForwardedMsg author_ = do
let body = chatMsgToBody chatMsg
rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ body chatMsg brokerTs
forM_ rcvMsg_ $ \rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} -> case event of
processForwardedMsg :: VerifiedMsg 'Json -> Maybe GroupMember -> CM ()
processForwardedMsg verifiedMsg author_ = do
rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ verifiedMsg brokerTs
forM_ rcvMsg_ $ \rcvMsg@RcvMessage {msgSigned, chatMsgEvent = ACME _ event} -> case event of
XMsgNew mc ->
void $ memberCanSend author_ scope $ newGroupContentMessage gInfo author_ mc rcvMsg msgTs True
where
@@ -3181,7 +3190,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave gInfo author rcvMsg msgTs
XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs
XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo gInfo author p' rcvMsg msgTs
XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps'
XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs msgSigned gInfo author ps'
_ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event)
where
withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM ()
@@ -3189,6 +3198,27 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
Just author -> action author
Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author"
withVerifiedMsg :: MsgEncodingI e => GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a)
withVerifiedMsg gInfo scopeInfo member (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action
| verified = Just <$> action verifiedMsg
| otherwise = do
createInternalChatItem user (CDGroupRcv gInfo scopeInfo member) (CIRcvGroupEvent RGEMsgBadSignature) (Just ts)
pure Nothing
where
verifiedMsg = case signedMsg_ of
Nothing -> VMUnsigned chatMsg
Just sm -> VMSigned sm chatMsg
verified = case signedMsg_ of
Just SignedMsg {chatBinding, signatures, signedBody}
| GroupMember {memberPubKey = Just pubKey, memberId} <- member ->
case chatBinding of
CBGroup | Just GroupKeys {groupRootKey} <- groupKeys gInfo ->
let prefix = smpEncode chatBinding <> smpEncode (groupRootPubKey groupRootKey, memberId)
in all (\(MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (prefix <> signedBody)) signatures
_ -> True -- can't reconstruct binding → accept (enforcement in Step 5)
| otherwise -> True
Nothing -> not (useRelays' gInfo && requiresSignature (toCMEventTag chatMsgEvent))
directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta `catchAllErrors` \_ -> pure ()
@@ -3342,13 +3372,9 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
| workerScope /= DWSGroup ->
throwChatError $ CEInternalError "delivery task worker: relay removed task in wrong worker scope"
| otherwise -> do
let MessageDeliveryTask {senderGMId, fwdSender, brokerTs, chatMessage} = task
(memberId_, memberName_) = case fwdSender of
FwdMember mid mname -> (Just mid, Just mname)
FwdChannel -> (Nothing, Nothing)
fwdEvt = XGrpMsgForward memberId_ memberName_ chatMessage brokerTs
cm = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = fwdEvt}
body = chatMsgToBody cm
let MessageDeliveryTask {senderGMId, fwdSender, brokerTs = fwdBrokerTs, verifiedMsg} = task
fwd = GrpMsgForward {fwdSender, fwdBrokerTs}
body = encodeBinaryBatch [encodeFwdElement fwd verifiedMsg]
withStore' $ \db -> do
createMsgDeliveryJob db gInfo jobScope (Just senderGMId) body
updateDeliveryTaskStatus db (deliveryTaskId task) DTSProcessed
src/Simplex/Chat/Messages.hs
+9 -8
View File
@@ -512,6 +512,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
editable :: Bool,
forwardedByMember :: Maybe GroupMemberId,
showGroupAsSender :: ShowGroupAsSender,
msgSigned :: Bool,
createdAt :: UTCTime,
updatedAt :: UTCTime
}
@@ -519,12 +520,12 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
type ShowGroupAsSender = Bool
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender createdAt updatedAt =
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> Bool -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt =
let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs
editable = deletable && isNothing itemForwarded
hasLink = BoolDef hasLink_
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, createdAt, updatedAt}
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, msgSigned, createdAt, updatedAt}
deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool
deletable' itemContent itemDeleted itemTs allowedInterval currentTs =
@@ -555,6 +556,7 @@ dummyMeta itemId ts itemText =
editable = False,
forwardedByMember = Nothing,
showGroupAsSender = False,
msgSigned = False,
createdAt = ts,
updatedAt = ts
}
@@ -1149,23 +1151,22 @@ type ChatItemTs = UTCTime
data SndMessage = SndMessage
{ msgId :: MessageId,
sharedMsgId :: SharedMsgId,
msgBody :: MsgBody
msgBody :: MsgBody,
signedMsg_ :: Maybe SignedMsg
}
deriving (Show)
data NewRcvMessage e = NewRcvMessage
{ chatMsgEvent :: ChatMsgEvent e,
msgBody :: MsgBody,
verifiedMsg :: VerifiedMsg e,
brokerTs :: UTCTime
}
deriving (Show)
data RcvMessage = RcvMessage
{ msgId :: MessageId,
chatMsgEvent :: AChatMsgEvent,
sharedMsgId_ :: Maybe SharedMsgId,
msgBody :: MsgBody,
authorMember :: Maybe GroupMemberId,
msgSigned :: Bool,
forwardedByMember :: Maybe GroupMemberId
}
src/Simplex/Chat/Messages/Batch.hs
+75 -51
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -6,6 +7,10 @@
module Simplex.Chat.Messages.Batch
( MsgBatch (..),
BatchMode (..),
encodeBatchElement,
encodeFwdElement,
encodeBinaryBatch,
batchMessages,
batchDeliveryTasks1,
)
@@ -22,75 +27,94 @@ import Simplex.Chat.Delivery
import Simplex.Chat.Messages
import Simplex.Chat.Protocol
import Simplex.Chat.Types (VersionRangeChat)
import Simplex.Messaging.Encoding (Large (..), smpEncode, smpEncodeList)
data BatchMode = BMJson | BMBinary
deriving (Eq, Show)
-- | Encode a batch element with optional signature prefix.
-- Dual of elementP's '/'/'{'cases.
encodeBatchElement :: Maybe SignedMsg -> ByteString -> ByteString
encodeBatchElement Nothing body = body
encodeBatchElement (Just SignedMsg {chatBinding, signatures}) body =
"/" <> smpEncode (chatBinding, signatures) <> body
data MsgBatch = MsgBatch ByteString [SndMessage]
-- | Batches SndMessages in [Either ChatError SndMessage] into batches of ByteStrings in form of JSON arrays.
-- | Batches SndMessages in [Either ChatError SndMessage] into batches of ByteStrings.
-- BMJson mode: JSON arrays like [msg1,msg2,...]
-- BMBinary mode: Binary format =<count>(<len:2><body>)*
-- Preserves original errors in the list.
-- Does not check if the resulting batch is a valid JSON.
-- If a single element is passed, it is returned as is (a JSON string).
-- If a single element is passed, it is returned as is.
-- If an element exceeds maxLen, it is returned as ChatError.
batchMessages :: Int -> [Either ChatError SndMessage] -> [Either ChatError MsgBatch]
batchMessages maxLen = addBatch . foldr addToBatch ([], [], 0, 0)
-- Elements are encoded with signature prefix via encodeBatchElement.
batchMessages :: BatchMode -> Int -> [Either ChatError SndMessage] -> [Either ChatError MsgBatch]
batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
where
msgBatch batch = Right (MsgBatch (encodeMessages batch) batch)
addToBatch :: Either ChatError SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int, Int)
addToBatch (Left err) acc = (Left err : addBatch acc, [], 0, 0) -- step over original error
addToBatch (Right msg@SndMessage {msgBody}) acc@(batches, batch, len, n)
| batchLen <= maxLen = (batches, msg : batch, len', n + 1)
| msgLen <= maxLen = (addBatch acc, [msg], msgLen, 1)
| otherwise = (errLarge msg : addBatch acc, [], 0, 0)
addToBatch :: Either ChatError SndMessage -> ([Either ChatError MsgBatch], [ByteString], [SndMessage], Int, Int) -> ([Either ChatError MsgBatch], [ByteString], [SndMessage], Int, Int)
addToBatch (Left err) acc = (Left err : addBatch acc, [], [], 0, 0) -- step over original error
addToBatch (Right msg@SndMessage {msgBody, signedMsg_}) acc@(batches, bodies, msgs, len, n)
| batchLen mode len' n' <= maxLen = (batches, body : bodies, msg : msgs, len', n')
| msgLen <= maxLen = (addBatch acc, [body], [msg], msgLen, 1)
| otherwise = (errLarge msg : addBatch acc, [], [], 0, 0)
where
msgLen = B.length msgBody
len'
| n == 0 = msgLen
| otherwise = msgLen + len + 1 -- 1 accounts for comma
batchLen
| n == 0 = len'
| otherwise = len' + 2 -- 2 accounts for opening and closing brackets
body = encodeBatchElement signedMsg_ msgBody
msgLen = B.length body
len' = len + msgLen
n' = n + 1
errLarge SndMessage {msgId} = Left $ ChatError $ CEInternalError ("large message " <> show msgId)
addBatch :: ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> [Either ChatError MsgBatch]
addBatch (batches, batch, _, n) = if n == 0 then batches else msgBatch batch : batches
encodeMessages :: [SndMessage] -> ByteString
encodeMessages = \case
[] -> mempty
[msg] -> body msg
msgs -> B.concat ["[", B.intercalate "," (map body msgs), "]"]
body SndMessage {msgBody} = msgBody
addBatch :: ([Either ChatError MsgBatch], [ByteString], [SndMessage], Int, Int) -> [Either ChatError MsgBatch]
addBatch (batches, bodies, msgs, _, n)
| n == 0 = batches
| otherwise =
let encoded = encodeBatch mode bodies
in Right (MsgBatch encoded msgs) : batches
-- | Batches delivery tasks into (batch, [taskIds], [largeTaskIds]).
-- Always uses binary batch format for relay groups.
batchDeliveryTasks1 :: VersionRangeChat -> Int -> NonEmpty MessageDeliveryTask -> (ByteString, [Int64], [Int64])
batchDeliveryTasks1 vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0) . L.toList
batchDeliveryTasks1 _vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0) . L.toList
where
addToBatch :: ([ByteString], [Int64], [Int64], Int, Int) -> MessageDeliveryTask -> ([ByteString], [Int64], [Int64], Int, Int)
addToBatch (msgBodies, taskIds, largeTaskIds, len, n) task
-- too large: skip msgBody, record taskId in largeTaskIds
-- too large: skip, record taskId in largeTaskIds
| msgLen > maxLen = (msgBodies, taskIds, taskId : largeTaskIds, len, n)
-- fits: include in batch
| batchLen <= maxLen = (msgBody : msgBodies, taskId : taskIds, largeTaskIds, len', n + 1)
-- doesn’t fit: stop adding further messages
-- batch overhead: '=' + count (2) + 2-byte length prefix per element
| len' + (n + 1) * 2 + 2 <= maxLen = (msgBody : msgBodies, taskId : taskIds, largeTaskIds, len', n + 1)
-- doesn't fit: stop adding further messages
| otherwise = (msgBodies, taskIds, largeTaskIds, len, n)
where
MessageDeliveryTask {taskId, fwdSender, brokerTs, chatMessage} = task
msgBody =
let (memberId_, memberName_) = case fwdSender of
FwdMember mid mname -> (Just mid, Just mname)
FwdChannel -> (Nothing, Nothing)
fwdEvt = XGrpMsgForward memberId_ memberName_ chatMessage brokerTs
cm = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = fwdEvt}
in chatMsgToBody cm
MessageDeliveryTask {taskId, fwdSender, brokerTs = fwdBrokerTs, verifiedMsg} = task
msgBody = encodeFwdElement GrpMsgForward {fwdSender, fwdBrokerTs} verifiedMsg
msgLen = B.length msgBody
len'
| n == 0 = msgLen
| otherwise = msgLen + len + 1 -- 1 accounts for comma
batchLen
| n == 0 = len'
| otherwise = len' + 2 -- 2 accounts for opening and closing brackets
len' = len + msgLen
toResult :: ([ByteString], [Int64], [Int64], Int, Int) -> (ByteString, [Int64], [Int64])
toResult (msgBodies, taskIds, largeTaskIds, _, _) =
(encodeMessages (reverse msgBodies), reverse taskIds, reverse largeTaskIds)
encodeMessages :: [ByteString] -> ByteString
encodeMessages = \case
[] -> mempty
[msg] -> msg
msgs -> B.concat ["[", B.intercalate "," msgs, "]"]
let encoded = encodeBinaryBatch (reverse msgBodies)
in (encoded, reverse taskIds, reverse largeTaskIds)
-- | Encode a batch element for relay groups: ><GrpMsgForward>[/<sigs>]<body>.
encodeFwdElement :: GrpMsgForward -> VerifiedMsg 'Json -> ByteString
encodeFwdElement fwd verifiedMsg = ">" <> smpEncode fwd <> encodeBatchElement signedMsg_ msgBody
where
(signedMsg_, msgBody) = verifiedMsgParts verifiedMsg
encodeBatch :: BatchMode -> [ByteString] -> ByteString
encodeBatch _ [] = mempty
encodeBatch _ [msg] = msg
encodeBatch BMJson msgs = B.concat ["[", B.intercalate "," msgs, "]"]
encodeBatch BMBinary msgs = B.cons '=' $ smpEncodeList (map Large msgs)
-- Always uses batch format (no single-element shortcut) since elements may have F prefix.
encodeBinaryBatch :: [ByteString] -> ByteString
encodeBinaryBatch [] = mempty
encodeBinaryBatch msgs = B.cons '=' $ smpEncodeList (map Large msgs)
-- Returns length the batch would have if encoded.
-- `len` - the total length of all `n` encoded elements (including signature prefixes)
batchLen :: BatchMode -> Int -> Int -> Int
batchLen _ _ 0 = 0
batchLen _ len 1 = len
batchLen BMJson len n = len + n + 1 -- (n - 1) commas + 2 brackets
batchLen BMBinary len n = len + n * 2 + 2 -- 2-byte length prefix per element + '=' + count
src/Simplex/Chat/Messages/CIContent.hs
+2
View File
@@ -227,6 +227,7 @@ ciRequiresAttention content = case msgDirection @d of
RGEMemberCreatedContact -> False
RGEMemberProfileUpdated {} -> False
RGENewMemberPendingReview -> True
RGEMsgBadSignature -> False
CIRcvConnEvent _ -> True
CIRcvChatFeature {} -> False
CIRcvChatPreference {} -> False
@@ -349,6 +350,7 @@ rcvGroupEventToText = \case
RGEMemberCreatedContact -> "started direct connection with you"
RGEMemberProfileUpdated {} -> "updated profile"
RGENewMemberPendingReview -> "new member wants to join the group"
RGEMsgBadSignature -> "message rejected: bad signature"
sndGroupEventToText :: SndGroupEvent -> Text
sndGroupEventToText = \case
src/Simplex/Chat/Messages/CIContent/Events.hs
+1
View File
@@ -32,6 +32,7 @@ data RcvGroupEvent
| RGEMemberCreatedContact -- CRNewMemberContactReceivedInv
| RGEMemberProfileUpdated {fromProfile :: Profile, toProfile :: Profile} -- CRGroupMemberUpdated
| RGENewMemberPendingReview
| RGEMsgBadSignature
deriving (Show)
data SndGroupEvent
src/Simplex/Chat/Protocol.hs
+182 -19
View File
@@ -3,6 +3,7 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
@@ -21,7 +22,7 @@
module Simplex.Chat.Protocol where
import Control.Applicative ((<|>))
import Control.Monad ((<=<))
import Control.Monad (when, (<=<))
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
@@ -37,12 +38,13 @@ import Data.Either (fromRight)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, isJust)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32)
@@ -54,6 +56,7 @@ import Simplex.Chat.Types.Shared
import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion)
import Simplex.Messaging.Agent.Store.DB (blobFieldDecoder, fromTextField_)
import Simplex.Messaging.Compression (Compressed, compress1, decompress1)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
@@ -310,6 +313,105 @@ data ChatMessage e = ChatMessage
data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e)
-- Can be extended to support profile identity keys (e.g., secp256k1 for Nostr)
data KeyRef = KRMember
deriving (Eq, Show)
data ChatBinding = CBGroup
deriving (Eq, Show)
data MsgSignature = MsgSignature KeyRef C.ASignature
deriving (Show)
data SignedMsg = SignedMsg
{ chatBinding :: ChatBinding,
signatures :: L.NonEmpty MsgSignature,
signedBody :: ByteString -- exact bytes that were signed
}
deriving (Show)
-- | Post-verification message. Encodes the invariant that signature
-- has been checked (or wasn't required). Store and forward functions
-- accept only VerifiedMsg, preventing unverified messages from being persisted.
data VerifiedMsg e
= VMUnsigned (ChatMessage e)
| VMSigned SignedMsg (ChatMessage e)
data ParsedMsg e = ParsedMsg (Maybe GrpMsgForward) (Maybe SignedMsg) (ChatMessage e)
data AParsedMsg = forall e. MsgEncodingI e => APMsg (SMsgEncoding e) (ParsedMsg e)
data FwdSender
= FwdMember MemberId ContactName
| FwdChannel
deriving (Eq, Show)
data GrpMsgForward = GrpMsgForward
{ fwdSender :: FwdSender,
fwdBrokerTs :: UTCTime
}
deriving (Eq, Show)
instance Encoding FwdSender where
smpEncode = \case
FwdMember memberId memberName -> smpEncode ('M', memberId, memberName)
FwdChannel -> "C"
smpP =
A.anyChar >>= \case
'M' -> uncurry FwdMember <$> smpP
'C' -> pure FwdChannel
c -> fail $ "invalid FwdSender tag: " <> show c
instance Encoding GrpMsgForward where
smpEncode GrpMsgForward {fwdSender, fwdBrokerTs} =
smpEncode (fwdSender, utcToSystemTime fwdBrokerTs)
smpP = do
fwdSender <- smpP
fwdBrokerTs <- systemToUTCTime <$> smpP
pure GrpMsgForward {fwdSender, fwdBrokerTs}
instance Encoding KeyRef where
smpEncode = \case
KRMember -> "M"
smpP =
A.anyChar >>= \case
'M' -> pure KRMember
c -> fail $ "invalid KeyRef tag: " <> show c
instance Encoding ChatBinding where
smpEncode CBGroup = "G"
smpP =
A.anyChar >>= \case
'G' -> pure CBGroup
c -> fail $ "invalid ChatBinding: " <> show c
instance ToField ChatBinding where toField = toField . decodeLatin1 . smpEncode
instance FromField ChatBinding where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
instance Encoding MsgSignature where
smpEncode (MsgSignature keyRef sig) = smpEncode (keyRef, C.signatureBytes sig)
smpP = MsgSignature <$> smpP <*> (C.decodeSignature <$?> smpP)
-- Wire format: <binding:1> <sigCount:1> (<keyRef><sig:64>)* <body>
instance Encoding SignedMsg where
smpEncode SignedMsg {chatBinding, signatures, signedBody} = smpEncode (chatBinding, signatures, Tail signedBody)
smpP = do
(chatBinding, signatures, Tail signedBody) <- smpP
pure SignedMsg {chatBinding, signatures, signedBody}
-- | Generic signing context — data, not function.
-- Callers construct per-event; createSndMessages uses mechanically.
data MsgSigning = MsgSigning
{ bindingTag :: ChatBinding,
bindingData :: ByteString,
keyRef :: KeyRef,
privKey :: C.PrivateKeyEd25519
}
data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
@@ -323,13 +425,13 @@ data ChatMsgEvent (e :: MsgEncoding) where
XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
XInfo :: Profile -> ChatMsgEvent 'Json
XContact :: {profile :: Profile, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
XMember :: {profile :: Profile, newMemberId :: MemberId} -> ChatMsgEvent 'Json
XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey} -> ChatMsgEvent 'Json
XDirectDel :: ChatMsgEvent 'Json
XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json
XGrpAcpt :: MemberId -> ChatMsgEvent 'Json
XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json
XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json
XGrpLinkMem :: Profile -> ChatMsgEvent 'Json
XGrpLinkMem :: Profile -> Maybe MemberKey -> ChatMsgEvent 'Json
XGrpLinkAcpt :: GroupAcceptance -> GroupMemberRole -> MemberId -> ChatMsgEvent 'Json
XGrpRelayInv :: GroupRelayInvitation -> ChatMsgEvent 'Json
XGrpRelayAcpt :: ShortLinkContact -> ChatMsgEvent 'Json
@@ -348,7 +450,7 @@ data ChatMsgEvent (e :: MsgEncoding) where
XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json
XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json
XGrpMsgForward :: Maybe MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json
XGrpMsgForward :: GrpMsgForward -> ChatMessage 'Json -> ChatMsgEvent 'Json
XInfoProbe :: Probe -> ChatMsgEvent 'Json
XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
XInfoProbeOk :: Probe -> ChatMsgEvent 'Json
@@ -673,26 +775,52 @@ encodeChatMessage maxSize msg = do
else ECMEncoded body
AMBinary m -> ECMEncoded $ strEncode m
parseChatMessages :: ByteString -> [Either String AChatMessage]
parseChatMessages :: ByteString -> [Either String AParsedMsg]
parseChatMessages "" = [Left "empty string"]
parseChatMessages msg = case B.head msg of
'X' -> decodeCompressed (B.tail msg)
c -> parseUncompressed c msg
where
parseUncompressed c s = case c of
'{' -> [ACMsg SJson <$> J.eitherDecodeStrict' s]
'[' -> case J.eitherDecodeStrict' s of
Right v -> map parseItem v
Right v -> map (fmap plainMsg . parseItem) v
Left e -> [Left e]
_ -> [ACMsg SBinary <$> (appBinaryToCM =<< strDecode s)]
'=' -> decodeBinaryBatch (B.tail s)
_ -> [parseAll (elementP Nothing) s]
plainMsg = aParsedMsg Nothing Nothing
aParsedMsg fwd sm (ACMsg enc cm) = APMsg enc (ParsedMsg fwd sm cm)
parseMsg s = ACMsg SJson <$> J.eitherDecodeStrict' s
msgP :: A.Parser AChatMessage
msgP = parseMsg <$?> A.takeByteString
parseItem :: J.Value -> Either String AChatMessage
parseItem v = ACMsg SJson <$> JT.parseEither parseJSON v
decodeCompressed :: ByteString -> [Either String AChatMessage]
decodeCompressed s' = case smpDecode s' of
decodeCompressed :: ByteString -> [Either String AParsedMsg]
decodeCompressed s = case smpDecode s of
Left e -> [Left e]
Right (compressed :: L.NonEmpty Compressed) -> concatMap (either (pure . Left) parseUncompressed' . decompress1 maxDecompressedMsgLength) compressed
Right (compressed :: L.NonEmpty Compressed) -> concatMap (either (\e -> [Left e]) parseUncompressed' . decompress1 maxDecompressedMsgLength) compressed
parseUncompressed' "" = [Left "empty string"]
parseUncompressed' s = parseUncompressed (B.head s) s
-- Binary batch format: '=' <count:1> (<len:2> <body>)*
decodeBinaryBatch :: ByteString -> [Either String AParsedMsg]
decodeBinaryBatch s = case parseAll smpListP s of
Left e -> [Left e]
Right msgs -> map parseBatchElement msgs
parseBatchElement :: Large -> Either String AParsedMsg
parseBatchElement (Large s) = parseAll (elementP Nothing) s
elementP :: Maybe GrpMsgForward -> A.Parser AParsedMsg
elementP fwd = A.peekChar' >>= \case
'/' -> A.char '/' *> do
tag <- smpP
sigs <- smpP
(body, acm) <- A.match msgP
pure $ aParsedMsg fwd (Just $ SignedMsg tag sigs body) acm
'>' -> A.char '>' *> do
when (isJust fwd) $ fail "nested forward elements not supported"
elementP . Just =<< smpP
'{' -> aParsedMsg fwd Nothing <$> msgP
-- 'F' must match BFileChunk_ tag encoding
'F' -> aParsedMsg fwd Nothing . ACMsg SBinary <$> (appBinaryToCM <$?> strP)
c -> fail $ "invalid element prefix: " <> show c
compressedBatchMsgBody_ :: MsgBody -> ByteString
compressedBatchMsgBody_ = markCompressedBatch . smpEncode . (L.:| []) . compress1
@@ -997,7 +1125,7 @@ toCMEventTag msg = case msg of
XGrpAcpt _ -> XGrpAcpt_
XGrpLinkInv _ -> XGrpLinkInv_
XGrpLinkReject _ -> XGrpLinkReject_
XGrpLinkMem _ -> XGrpLinkMem_
XGrpLinkMem _ _ -> XGrpLinkMem_
XGrpLinkAcpt {} -> XGrpLinkAcpt_
XGrpRelayInv _ -> XGrpRelayInv_
XGrpRelayAcpt _ -> XGrpRelayAcpt_
@@ -1063,6 +1191,17 @@ hasDeliveryReceipt = \case
XCallInv_ -> True
_ -> False
-- | Admin events that must have a valid signature in relay groups.
requiresSignature :: CMEventTag e -> Bool
requiresSignature = \case
XGrpDel_ -> True
XGrpInfo_ -> True
XGrpPrefs_ -> True
XGrpMemDel_ -> True
XGrpMemRole_ -> True
XGrpMemRestrict_ -> True
_ -> False
appBinaryToCM :: AppMessageBinary -> Either String (ChatMessage 'Binary)
appBinaryToCM AppMessageBinary {msgId, tag, body} = do
eventTag <- strDecode $ B.singleton tag
@@ -1112,13 +1251,13 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
reqContent <- opt "content"
let requestMsg = (,) <$> reqMsgId <*> reqContent
pure XContact {profile, contactReqId, welcomeMsgId, requestMsg}
XMember_ -> XMember <$> p "profile" <*> p "newMemberId"
XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey"
XDirectDel_ -> pure XDirectDel
XGrpInv_ -> XGrpInv <$> p "groupInvitation"
XGrpAcpt_ -> XGrpAcpt <$> p "memberId"
XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation"
XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection"
XGrpLinkMem_ -> XGrpLinkMem <$> p "profile"
XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" <*> opt "memberKey"
XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "acceptance" <*> p "role" <*> p "memberId"
XGrpRelayInv_ -> XGrpRelayInv <$> p "groupRelayInvitation"
XGrpRelayAcpt_ -> XGrpRelayAcpt <$> p "relayLink"
@@ -1137,7 +1276,12 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences"
XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope"
XGrpMsgForward_ -> XGrpMsgForward <$> opt "memberId" <*> opt "memberName" <*> p "msg" <*> p "msgTs"
XGrpMsgForward_ -> do
fwdSender <- opt "memberId" >>= \case
Just memberId -> FwdMember memberId . fromMaybe "" <$> opt "memberName"
Nothing -> pure FwdChannel
fwdBrokerTs <- p "msgTs"
XGrpMsgForward (GrpMsgForward {fwdSender, fwdBrokerTs}) <$> p "msg"
XInfoProbe_ -> XInfoProbe <$> p "probe"
XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
XInfoProbeOk_ -> XInfoProbeOk <$> p "probe"
@@ -1174,13 +1318,13 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId]
XInfo profile -> o ["profile" .= profile]
XContact {profile, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ["profile" .= profile]
XMember {profile, newMemberId} -> o ["profile" .= profile, "newMemberId" .= newMemberId]
XMember {profile, newMemberId, newMemberKey} -> o ["profile" .= profile, "newMemberId" .= newMemberId, "newMemberKey" .= newMemberKey]
XDirectDel -> JM.empty
XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
XGrpAcpt memId -> o ["memberId" .= memId]
XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv]
XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct]
XGrpLinkMem profile -> o ["profile" .= profile]
XGrpLinkMem profile memberKey -> o $ ("memberKey" .=? memberKey) ["profile" .= profile]
XGrpLinkAcpt acceptance role memberId -> o ["acceptance" .= acceptance, "role" .= role, "memberId" .= memberId]
XGrpRelayInv groupRelayInv -> o ["groupRelayInvitation" .= groupRelayInv]
XGrpRelayAcpt relayLink -> o ["relayLink" .= relayLink]
@@ -1199,7 +1343,11 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
XGrpInfo p -> o ["groupProfile" .= p]
XGrpPrefs p -> o ["groupPreferences" .= p]
XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq]
XGrpMsgForward memberId memberName msg msgTs -> o $ ("memberId" .=? memberId) $ ("memberName" .=? memberName) ["msg" .= msg, "msgTs" .= msgTs]
XGrpMsgForward GrpMsgForward {fwdSender, fwdBrokerTs} msg -> o $ encodeFwdSender fwdSender ["msg" .= msg, "msgTs" .= fwdBrokerTs]
where
encodeFwdSender = \case
FwdMember memberId memberName -> (["memberId" .= memberId, "memberName" .= memberName] ++)
FwdChannel -> id
XInfoProbe probe -> o ["probe" .= probe]
XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
XInfoProbeOk probe -> o ["probe" .= probe]
@@ -1220,6 +1368,20 @@ chatMsgToBody chatMsg = case encoding @e of
SBinary -> chatMsgBinaryToBody chatMsg
SJson -> LB.toStrict $ J.encode chatMsg
verifiedChatMsg :: VerifiedMsg e -> ChatMessage e
verifiedChatMsg = \case
VMUnsigned cm -> cm
VMSigned _ cm -> cm
-- | Canonical bytes to store/forward, with optional signature.
-- Signed: original bytes (re-encoding would invalidate signature).
-- Unsigned: re-encoded from parsed ChatMessage (sanitizes stored content).
verifiedMsgParts :: MsgEncodingI e => VerifiedMsg e -> (Maybe SignedMsg, ByteString)
verifiedMsgParts = \case
VMUnsigned chatMsg -> (Nothing, chatMsgToBody chatMsg)
VMSigned sm@SignedMsg {signedBody} _ -> (Just sm, signedBody)
instance ToJSON (ChatMessage 'Json) where
toJSON = (\(AMJson msg) -> toJSON msg) . chatToAppMessage
@@ -1244,3 +1406,4 @@ data GroupShortLinkData = GroupShortLinkData
$(JQ.deriveJSON defaultJSON ''ContactShortLinkData)
$(JQ.deriveJSON defaultJSON ''GroupShortLinkData)
src/Simplex/Chat/Store/Delivery.hs
+20 -8
View File
@@ -29,8 +29,10 @@ module Simplex.Chat.Store.Delivery
)
where
import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import qualified Data.List.NonEmpty as L
import Data.Text (Text)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Simplex.Chat.Delivery
@@ -40,7 +42,8 @@ import Simplex.Chat.Types
import Simplex.Messaging.Agent.Store.AgentStore (getWorkItem, getWorkItems, maybeFirstRow)
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Util (firstRow')
import Simplex.Messaging.Encoding (smpDecode)
import Simplex.Messaging.Util (eitherToMaybe, firstRow')
#if defined(dbPostgres)
import Database.PostgreSQL.Simple (In (..), Only (..), (:.) (..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
@@ -125,7 +128,7 @@ getNextDeliveryTask db deliveryKey = do
|]
(groupId, workerScope, DTSNew)
type MessageDeliveryTaskRow = (Only Int64) :. DeliveryJobScopeRow :. (GroupMemberId, MemberId, ContactName, UTCTime, ChatMessage 'Json, BoolInt)
type MessageDeliveryTaskRow = (Only Int64) :. DeliveryJobScopeRow :. (GroupMemberId, MemberId, ContactName, UTCTime, Binary ByteString, Maybe ChatBinding, Maybe (Binary ByteString), BoolInt)
getMsgDeliveryTask_ :: DB.Connection -> Int64 -> IO (Either StoreError MessageDeliveryTask)
getMsgDeliveryTask_ db taskId =
@@ -136,7 +139,7 @@ getMsgDeliveryTask_ db taskId =
SELECT
t.delivery_task_id,
t.worker_scope, t.job_scope_spec_tag, t.job_scope_include_pending, t.job_scope_support_gm_id,
m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, t.message_from_channel
m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, msg.msg_chat_binding, msg.msg_signatures, t.message_from_channel
FROM delivery_tasks t
JOIN messages msg ON msg.message_id = t.message_id
JOIN group_members m ON m.group_member_id = t.sender_group_member_id
@@ -146,12 +149,21 @@ getMsgDeliveryTask_ db taskId =
(Only taskId)
where
toTask :: MessageDeliveryTaskRow -> Either StoreError MessageDeliveryTask
toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, BI showGroupAsSender)) =
case toJobScope_ jobScopeRow of
Just jobScope ->
toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, Binary msgBody, chatBinding_, sigs_, BI showGroupAsSender)) =
case (toJobScope_ jobScopeRow, J.eitherDecodeStrict' msgBody) of
(Just jobScope, Right chatMsg) ->
let fwdSender = if showGroupAsSender then FwdChannel else FwdMember senderMemberId senderMemberName
in Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, fwdSender, brokerTs, chatMessage}
Nothing -> Left $ SEInvalidDeliveryTask taskId'
-- Re-parsed from msg_body: validates stored content against current code.
-- Signed: original bytes preserved (re-encoding would invalidate signature).
-- Unsigned: re-encoded from parsed ChatMessage on forward (sanitizes content).
verifiedMsg = case (chatBinding_, decodeSigs sigs_) of
(Just cb, Just sigs) -> VMSigned (SignedMsg cb sigs msgBody) chatMsg
_ -> VMUnsigned chatMsg
in Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, fwdSender, brokerTs, verifiedMsg}
(Nothing, _) -> Left $ SEInvalidDeliveryTask taskId'
(_, Left _) -> Left $ SEInvalidDeliveryTask taskId'
decodeSigs :: Maybe (Binary ByteString) -> Maybe (L.NonEmpty MsgSignature)
decodeSigs = (>>= eitherToMaybe . smpDecode . (\(Binary bs) -> bs))
markDeliveryTaskFailed_ :: DB.Connection -> Int64 -> IO ()
markDeliveryTaskFailed_ db taskId =
src/Simplex/Chat/Store/Groups.hs
+6 -6
View File
@@ -1087,12 +1087,12 @@ getGroupMemberByMemberId db vr user GroupInfo {groupId} memberId =
(groupMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ?")
(groupId, memberId)
getCreateUnknownGMByMemberId :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> Maybe ContactName -> GroupMemberRole -> ExceptT StoreError IO (GroupMember, Bool)
getCreateUnknownGMByMemberId :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> ContactName -> GroupMemberRole -> ExceptT StoreError IO (GroupMember, Bool)
getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownMemberRole = do
liftIO (runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case
Right m -> pure (m, False)
Left (SEGroupMemberNotFoundByMemberId _) -> do
let name = fromMaybe (nameFromMemberId memberId) memberName
let name = if T.null memberName then nameFromMemberId memberId else memberName
m <- createNewUnknownGroupMember db vr user gInfo memberId name unknownMemberRole
pure (m, True)
Left e -> throwError e
@@ -1701,7 +1701,7 @@ updateGroupMemberKeys db groupId sharedGroupId rootPubKey memberPrivKey membersh
DB.execute
db
"UPDATE groups SET shared_group_id = ?, root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?"
(sharedGroupId, rootPubKey, memberPrivKey, currentTs, groupId)
(Binary sharedGroupId, rootPubKey, memberPrivKey, currentTs, groupId)
DB.execute
db
"UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?"
@@ -1838,7 +1838,7 @@ createNewMember_
User {userId, userContactId}
GroupInfo {groupId}
NewGroupMember
{ memInfo = MemberInfo memberId memberRole memChatVRange memberProfile,
{ memInfo = MemberInfo memberId memberRole memChatVRange memberProfile _memKey,
memCategory = memberCategory,
memStatus = memberStatus,
memRestriction,
@@ -2004,7 +2004,7 @@ createIntroReMember
db
user
gInfo
memInfo@(MemberInfo _ _ _ memberProfile)
memInfo@(MemberInfo _ _ _ memberProfile _)
memRestrictions_ = do
currentTs <- liftIO getCurrentTime
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memberProfile currentTs
@@ -2019,7 +2019,7 @@ createIntroReMemberConn
_host@GroupMember {memberContactId, activeConn}
reMember@GroupMember {groupMemberId}
chatV
(MemberInfo _ _ memChatVRange _)
(MemberInfo _ _ memChatVRange _ _)
(groupCmdId, groupAgentConnId)
subMode = do
let mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
src/Simplex/Chat/Store/Messages.hs
+44 -36
View File
@@ -151,7 +151,7 @@ import Data.Char (toLower)
import Data.Either (fromRight, rights)
import Data.Int (Int64)
import Data.List (foldl', sortBy)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
@@ -179,6 +179,7 @@ import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
import Simplex.Messaging.Util (eitherToMaybe)
import UnliftIO.STM
#if defined(dbPostgres)
@@ -218,24 +219,29 @@ deleteGroupChatItemsMessages db User {userId} GroupInfo {groupId} = do
DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId)
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND item_content_tag != 'chatBanner'" (userId, groupId)
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId chatMsgEvent encodeMessage =
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> Maybe MsgSigning -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage =
createWithRandomId' db gVar $ \sharedMsgId ->
case encodeMessage (SharedMsgId sharedMsgId) of
ECMLarge -> pure $ Left SELargeMsg
ECMEncoded msgBody -> do
let signedMsg_ = signBody <$> msgSigning_
signBody MsgSigning {bindingTag, bindingData, keyRef, privKey} =
let sig = C.ASignature C.SEd25519 $ C.sign' privKey (smpEncode bindingTag <> bindingData <> msgBody)
in SignedMsg {chatBinding = bindingTag, signatures = MsgSignature keyRef sig :| [], signedBody = msgBody}
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages (
msg_sent, chat_msg_event, msg_body, connection_id, group_id,
msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, connection_id, group_id,
shared_msg_id, shared_msg_id_user, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
|]
(MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, connId_, groupId_, DB.Binary sharedMsgId, Just (BI True), createdAt, createdAt)
((MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, chatBinding <$> signedMsg_, smpEncode . signatures <$> signedMsg_, connId_, groupId_)
:. (DB.Binary sharedMsgId, Just (BI True), createdAt, createdAt))
msgId <- insertedRowId db
pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody}
pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody, signedMsg_}
where
(connId_, groupId_) = case connOrGroupId of
ConnectionId connId -> (Just connId, Nothing)
@@ -287,7 +293,7 @@ getLastRcvMsgInfo db connId =
RcvMsgInfo {msgId, msgDeliveryId, msgDeliveryStatus, agentMsgId, agentMsgMeta}
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody, brokerTs} sharedMsgId_ authorMember forwardedByMember =
createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs} sharedMsgId_ authorMember forwardedByMember =
case connOrGroupId of
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
GroupId groupId -> case sharedMsgId_ of
@@ -315,14 +321,15 @@ createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody, broke
db
[sql|
INSERT INTO messages
(msg_sent, chat_msg_event, msg_body, broker_ts, created_at, updated_at, connection_id, group_id,
(msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, broker_ts, created_at, updated_at, connection_id, group_id,
shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, brokerTs, currentTs, currentTs, connId_, groupId_)
((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, chatBinding <$> signedMsg_, smpEncode . signatures <$> signedMsg_, brokerTs, currentTs, currentTs, connId_, groupId_)
:. (sharedMsgId_, authorMember, forwardedByMember))
msgId <- insertedRowId db
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgSigned = isJust signedMsg_, forwardedByMember}
(signedMsg_, msgBody) = verifiedMsgParts verifiedMsg
updateSndMsgDeliveryStatus :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> IO ()
updateSndMsgDeliveryStatus db connId agentMsgId sndMsgDeliveryStatus = do
@@ -353,7 +360,7 @@ getPendingGroupMessages db groupMemberId =
<$> DB.query
db
[sql|
SELECT pgm.message_id, m.shared_msg_id, m.msg_body
SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures
FROM pending_group_messages pgm
JOIN messages m USING (message_id)
WHERE pgm.group_member_id = ?
@@ -361,8 +368,9 @@ getPendingGroupMessages db groupMemberId =
|]
(Only groupMemberId)
where
pendingGroupMessage (msgId, sharedMsgId, msgBody) =
SndMessage {msgId, sharedMsgId, msgBody}
pendingGroupMessage (msgId, sharedMsgId, msgBody, chatBinding_ :: Maybe ChatBinding, sigs_ :: Maybe ByteString) =
let signedMsg_ = SignedMsg <$> chatBinding_ <*> (sigs_ >>= eitherToMaybe . smpDecode) <*> pure msgBody
in SndMessage {msgId, sharedMsgId, msgBody, signedMsg_}
deletePendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> IO ()
deletePendingGroupMessage db groupMemberId messageId =
@@ -526,8 +534,8 @@ setSupportChatMemberAttention db vr user g m memberAttention = do
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live hasLink createdAt =
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing createdAt
createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId, signedMsg_} ciContent quotedItem itemForwarded timed live hasLink createdAt =
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing (isJust signedMsg_) createdAt
where
createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow
@@ -542,9 +550,9 @@ createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId,
CIQGroupRcv Nothing -> (Just False, Nothing)
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention hasLink itemTs createdAt = do
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ ciContent timed live userMention hasLink itemTs createdAt = do
let showAsGroup = case chatDirection of CDChannelRcv {} -> True; _ -> False
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember createdAt
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
pure (ciId, quotedItem, itemForwarded)
where
@@ -563,13 +571,13 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink itemTs =
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing False
where
quoteRow :: NewQuoteRow
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember createdAt = do
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Bool -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt = do
DB.execute
db
[sql|
@@ -578,20 +586,20 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id,
-- meta
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, show_group_as_sender, timed_ttl, timed_delete_at,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, show_group_as_sender, msg_signed, timed_ttl, timed_delete_at,
-- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id,
-- forwarded from
fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
((userId, msgId_) :. idsRow :. groupScopeRow :. itemRow :. quoteRow' :. forwardedFromRow)
ciId <- insertedRowId db
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
pure ciId
where
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt) :. (Maybe Int, Maybe UTCTime)
itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, msgContentTag <$> ciMsgContent ciContent, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> justTrue live, BI userMention, BI hasLink, BI showGroupAsSender) :. ciTimedRow timed
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt, BoolInt) :. (Maybe Int, Maybe UTCTime)
itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, msgContentTag <$> ciMsgContent ciContent, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> justTrue live, BI userMention, BI hasLink, BI showGroupAsSender, BI msgSigned) :. ciTimedRow timed
quoteRow' = let (a, b, c, d, e) = quoteRow in (a, b, c, BI <$> d, e)
idsRow :: (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId, Maybe NoteFolderId)
idsRow = case chatDirection of
@@ -1056,7 +1064,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
-- this function can be changed so it never fails, not only avoid failure on invalid json
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal)
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, BI msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -1089,7 +1097,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
_ -> Just (CIDeleted @'CTLocal deletedTs)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -2210,7 +2218,7 @@ updateLocalChatItemsRead db User {userId} noteFolderId = do
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt)
type ChatItemForwardedFromRow = (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64)
@@ -2234,7 +2242,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
-- this function can be changed so it never fails, not only avoid failure on invalid json
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, BI msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -2267,7 +2275,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
_ -> Just (CIDeleted @'CTDirect deletedTs)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -2305,7 +2313,7 @@ toGroupChatItem
( ( (itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId)
:. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt)
:. forwardedFromRow
:. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink)
:. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, BI msgSigned)
:. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)
)
:. (forwardedByMember, BI showGroupAsSender)
@@ -2356,7 +2364,7 @@ toGroupChatItem
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -2629,7 +2637,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- 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,
-- DirectQuote
@@ -2984,7 +2992,7 @@ 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.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- 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 forwardedByMember, showGroupAsSender
@@ -3093,7 +3101,7 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- 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
FROM chat_items i
src/Simplex/Chat/Store/Postgres/Migrations/M20260222_chat_relays.hs
+10
View File
@@ -63,6 +63,11 @@ CREATE INDEX idx_group_relays_chat_relay_id ON group_relays(chat_relay_id);
ALTER TABLE group_members
ADD COLUMN relay_link BYTEA,
ADD COLUMN member_pub_key BYTEA;
ALTER TABLE messages ADD COLUMN msg_chat_binding TEXT;
ALTER TABLE messages ADD COLUMN msg_signatures BYTEA;
ALTER TABLE chat_items ADD COLUMN msg_signed SMALLINT NOT NULL DEFAULT 0;
|]
down_m20260222_chat_relays :: Text
@@ -101,4 +106,9 @@ DROP TABLE chat_relays;
ALTER TABLE group_members
DROP COLUMN relay_link,
DROP COLUMN member_pub_key;
ALTER TABLE messages DROP COLUMN msg_chat_binding;
ALTER TABLE messages DROP COLUMN msg_signatures;
ALTER TABLE chat_items DROP COLUMN msg_signed;
|]
src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql
+5 -2
View File
@@ -343,7 +343,8 @@ CREATE TABLE test_chat_schema.chat_items (
group_scope_tag text,
group_scope_group_member_id bigint,
show_group_as_sender smallint DEFAULT 0 NOT NULL,
has_link smallint DEFAULT 0 NOT NULL
has_link smallint DEFAULT 0 NOT NULL,
msg_signed smallint DEFAULT 0 NOT NULL
);
@@ -1002,7 +1003,9 @@ CREATE TABLE test_chat_schema.messages (
shared_msg_id_user smallint,
author_group_member_id bigint,
forwarded_by_group_member_id bigint,
broker_ts timestamp with time zone
broker_ts timestamp with time zone,
msg_chat_binding text,
msg_signatures bytea
);
src/Simplex/Chat/Store/SQLite/Migrations/M20260222_chat_relays.hs
+10
View File
@@ -75,6 +75,11 @@ CREATE INDEX idx_group_relays_chat_relay_id ON group_relays(chat_relay_id);
ALTER TABLE group_members ADD COLUMN relay_link BLOB;
ALTER TABLE group_members ADD COLUMN member_pub_key BLOB;
ALTER TABLE messages ADD COLUMN msg_chat_binding TEXT;
ALTER TABLE messages ADD COLUMN msg_signatures BLOB;
ALTER TABLE chat_items ADD COLUMN msg_signed INTEGER NOT NULL DEFAULT 0;
|]
down_m20260222_chat_relays :: Query
@@ -113,4 +118,9 @@ DROP TABLE chat_relays;
ALTER TABLE group_members DROP COLUMN relay_link;
ALTER TABLE group_members DROP COLUMN member_pub_key;
ALTER TABLE messages DROP COLUMN msg_chat_binding;
ALTER TABLE messages DROP COLUMN msg_signatures;
ALTER TABLE chat_items DROP COLUMN msg_signed;
|]
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+11 -17
View File
@@ -652,9 +652,9 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
Query:
INSERT INTO messages (
msg_sent, chat_msg_event, msg_body, connection_id, group_id,
msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, connection_id, group_id,
shared_msg_id, shared_msg_id_user, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
Plan:
@@ -1231,9 +1231,9 @@ Plan:
Query:
INSERT INTO messages
(msg_sent, chat_msg_event, msg_body, broker_ts, created_at, updated_at, connection_id, group_id,
(msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, broker_ts, created_at, updated_at, connection_id, group_id,
shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
@@ -1257,7 +1257,7 @@ Query:
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- 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
FROM chat_items i
@@ -1274,7 +1274,7 @@ Query:
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- 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 forwardedByMember, showGroupAsSender
@@ -1327,7 +1327,7 @@ Query:
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- 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,
-- DirectQuote
@@ -3224,7 +3224,7 @@ Query:
SELECT
t.delivery_task_id,
t.worker_scope, t.job_scope_spec_tag, t.job_scope_include_pending, t.job_scope_support_gm_id,
m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, t.message_from_channel
m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, msg.msg_chat_binding, msg.msg_signatures, t.message_from_channel
FROM delivery_tasks t
JOIN messages msg ON msg.message_id = t.message_id
JOIN group_members m ON m.group_member_id = t.sender_group_member_id
@@ -3664,7 +3664,7 @@ SEARCH m USING INDEX idx_group_members_user_id (user_id=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT pgm.message_id, m.shared_msg_id, m.msg_body
SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures
FROM pending_group_messages pgm
JOIN messages m USING (message_id)
WHERE pgm.group_member_id = ?
@@ -4464,12 +4464,12 @@ Query:
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id,
-- meta
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, show_group_as_sender, timed_ttl, timed_delete_at,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, show_group_as_sender, msg_signed, timed_ttl, timed_delete_at,
-- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id,
-- forwarded from
fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
@@ -5877,9 +5877,6 @@ SEARCH chat_items USING COVERING INDEX idx_chat_items_notes_created_at (user_id=
Query: CREATE TABLE temp_delete_members (contact_profile_id INTEGER, member_profile_id INTEGER, local_display_name TEXT)
Error: SQLite3 returned ErrorError while attempting to perform prepare "explain query plan CREATE TABLE temp_delete_members (contact_profile_id INTEGER, member_profile_id INTEGER, local_display_name TEXT)": table temp_delete_members already exists
Query: DELETE FROM app_settings
Plan:
Query: DELETE FROM calls WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH calls USING INDEX idx_calls_contact_id (contact_id=?)
@@ -6300,9 +6297,6 @@ Plan:
Query: DROP TABLE temp_delete_members
Plan:
Query: INSERT INTO app_settings (app_settings) VALUES (?)
Plan:
Query: INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?)
Plan:
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+5 -2
View File
@@ -404,7 +404,9 @@ CREATE TABLE messages(
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,
broker_ts TEXT
broker_ts TEXT,
msg_chat_binding TEXT,
msg_signatures BLOB
) STRICT;
CREATE TABLE pending_group_messages(
pending_group_message_id INTEGER PRIMARY KEY,
@@ -458,7 +460,8 @@ CREATE TABLE chat_items(
group_scope_tag TEXT,
group_scope_group_member_id INTEGER REFERENCES group_members(group_member_id) ON DELETE CASCADE,
show_group_as_sender INTEGER NOT NULL DEFAULT 0,
has_link INTEGER NOT NULL DEFAULT 0
has_link INTEGER NOT NULL DEFAULT 0,
msg_signed INTEGER NOT NULL DEFAULT 0
) STRICT;
CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE chat_item_messages(
src/Simplex/Chat/Terminal/Input.hs
+1 -1
View File
@@ -79,7 +79,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g
CRGroupDeletedUser u g _ -> whenCurrUser cc u $ unsetActiveGroup ct g
CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
CRCmdOk _ -> case cmd of
Right APIDeleteUser {} -> setActive ct ""
src/Simplex/Chat/Types.hs
+15 -2
View File
@@ -57,6 +57,7 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), blobFieldDecoder, fromText
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport, pattern PQEncOff)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
import Simplex.Messaging.Util (decodeJSON, encodeJSON, safeDecodeUtf8)
@@ -891,11 +892,23 @@ data IntroInvitation = IntroInvitation
}
deriving (Eq, Show)
newtype MemberKey = MemberKey C.PublicKeyEd25519
deriving (Eq, Show)
deriving newtype (StrEncoding)
instance FromJSON MemberKey where
parseJSON = strParseJSON "MemberKey"
instance ToJSON MemberKey where
toJSON = strToJSON
toEncoding = strToJEncoding
data MemberInfo = MemberInfo
{ memberId :: MemberId,
memberRole :: GroupMemberRole,
v :: Maybe ChatVersionRange,
profile :: Profile
profile :: Profile,
memberKey :: Maybe MemberKey
}
deriving (Eq, Show)
@@ -1084,7 +1097,7 @@ data NewGroupMember = NewGroupMember
newtype MemberId = MemberId {unMemberId :: ByteString}
deriving (Eq, Ord, Show)
deriving newtype (FromField)
deriving newtype (Encoding, FromField)
instance ToField MemberId where toField (MemberId m) = toField $ Binary m
src/Simplex/Chat/View.hs
+38 -35
View File
@@ -215,11 +215,11 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
CRUserContactLinkCreated u ccLink -> ttyUser u $ connReqContact_ "Your new chat address is created!" ccLink
CRUserContactLinkDeleted u -> ttyUser u viewUserContactLinkDeleted
CRUserAcceptedGroupSent u _g _ -> ttyUser u [] -- [ttyGroup' g <> ": joining the group..."]
CRUserDeletedMembers u g members wm -> case members of
[m] -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group" <> withMessages wm]
mems' -> ttyUser u [ttyGroup' g <> ": you removed " <> sShow (length mems') <> " members from the group" <> withMessages wm]
CRUserDeletedMembers u g members wm signed -> case members of
[m] -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group" <> withMessages wm <> signedStr signed]
mems' -> ttyUser u [ttyGroup' g <> ": you removed " <> sShow (length mems') <> " members from the group" <> withMessages wm <> signedStr signed]
CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
CRGroupDeletedUser u g -> ttyUser u [ttyGroup' g <> ": you deleted the group"]
CRGroupDeletedUser u g signed -> ttyUser u [ttyGroup' g <> ": you deleted the group" <> signedStr signed]
CRForwardPlan u count itemIds fc -> ttyUser u $ viewForwardPlan count itemIds fc
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
@@ -238,9 +238,9 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
CRMemberAccepted u g m -> ttyUser u $ viewMemberAccepted g m
CRMemberSupportChatRead u g m -> ttyUser u $ viewSupportChatRead g m
CRMemberSupportChatDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " support chat deleted"]
CRMembersRoleUser u g members r' -> ttyUser u $ viewMemberRoleUserChanged g members r'
CRMembersBlockedForAllUser u g members blocked -> ttyUser u $ viewMembersBlockedForAllUser g members blocked
CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m
CRMembersRoleUser u g members r' signed -> ttyUser u $ viewMemberRoleUserChanged g members r' signed
CRMembersBlockedForAllUser u g members blocked signed -> ttyUser u $ viewMembersBlockedForAllUser g members blocked signed
CRGroupUpdated u g g' m signed -> ttyUser u $ viewGroupUpdated g g' m signed
CRGroupProfile u g -> ttyUser u $ viewGroupProfile g
CRGroupDescription u g -> ttyUser u $ viewGroupDescription g
CRGroupLinkCreated u g gLink -> ttyUser u $ groupLink_ "Group link is created!" g gLink
@@ -358,9 +358,9 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
_ -> Nothing
testViewItem :: CChatItem c -> Maybe GroupMember -> Text
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ =
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText, msgSigned}}) membership_ =
let deleted_ = maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci membership_)
in itemText <> deleted_
in itemText <> signedStr msgSigned <> deleted_
unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isUserMention ci
unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
@@ -372,6 +372,9 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
| otherwise = []
withMessages wm = if wm then " with all messages" else ""
signedStr :: IsString a => Bool -> a
signedStr signed = if signed then " (signed)" else ""
ttyUserPrefix :: (Maybe RemoteHostId, Maybe User) -> Maybe RemoteHostId -> User -> [StyledString] -> [StyledString]
ttyUserPrefix _ _ _ [] = []
ttyUserPrefix (currentRH, user_) outputRH User {userId, localDisplayName = u} ss
@@ -469,13 +472,13 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
CEvtJoinedGroupMemberConnecting u g host m -> ttyUser u $ viewJoinedGroupMemberConnecting g host m
CEvtConnectedToGroupMember u g m _ -> ttyUser u $ viewConnectedToGroupMember g m
CEvtMemberAcceptedByOther u g acceptingMember m -> ttyUser u $ viewMemberAcceptedByOther g acceptingMember m
CEvtMemberRole u g by m r r' -> ttyUser u $ viewMemberRoleChanged g by m r r'
CEvtMemberBlockedForAll u g by m blocked -> ttyUser u $ viewMemberBlockedForAll g by m blocked
CEvtDeletedMemberUser u g by wm -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group" <> withMessages wm] <> groupPreserved g
CEvtDeletedMember u g by m wm -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group" <> withMessages wm]
CEvtMemberRole u g by m r r' signed -> ttyUser u $ viewMemberRoleChanged g by m r r' signed
CEvtMemberBlockedForAll u g by m blocked signed -> ttyUser u $ viewMemberBlockedForAll g by m blocked signed
CEvtDeletedMemberUser u g by wm signed -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group" <> withMessages wm <> signedStr signed] <> groupPreserved g
CEvtDeletedMember u g by m wm signed -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group" <> withMessages wm <> signedStr signed]
CEvtLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"]
CEvtGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the local copy of the group"]
CEvtGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m
CEvtGroupDeleted u g m signed -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group" <> signedStr signed, "use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the local copy of the group"]
CEvtGroupUpdated u g g' m signed -> ttyUser u $ viewGroupUpdated g g' m signed
CEvtAcceptingGroupJoinRequestMember _ g m -> [ttyFullMember m <> ": accepting request to join group " <> ttyGroup' g <> "..."]
CEvtNoMemberContactCreating u g m -> ttyUser u ["member " <> ttyGroup' g <> " " <> ttyMember m <> " does not have direct connection, creating"]
CEvtNewMemberContactReceivedInv u ct g m -> ttyUser u $ viewNewMemberContactReceivedInv u ct g m
@@ -644,7 +647,7 @@ viewChatItems ttyUser unmuted u chatItems ts tz
| otherwise = ttyUser u [sShow (length chatItems) <> " new messages created"]
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention}, content, quotedItem, file} doShow ts tz =
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention, msgSigned}, content, quotedItem, file} doShow ts tz =
withGroupMsgForwarded . withItemDeleted <$> viewCI
where
viewCI = case chat of
@@ -727,8 +730,8 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
("", Just _, []) -> []
("", Just CIFile {fileName}, _) -> view dir context (MCText $ T.pack fileName) ts tz meta
_ -> view dir context mc ts tz meta
showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content] meta
showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content] False
showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> signedStr msgSigned] meta
showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content <> signedStr msgSigned] False
showSndItemProhibited to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> " " <> prohibited] meta
showRcvItemProhibited from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content <> " " <> prohibited] False
showItem ss = if doShow then ss else []
@@ -1299,29 +1302,29 @@ connectedMember m = case memberCategory m of
GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting
_ -> "member " <> ttyMember m -- these case is not used
viewMemberRoleChanged :: GroupInfo -> GroupMember -> GroupMember -> GroupMemberRole -> GroupMemberRole -> [StyledString]
viewMemberRoleChanged g@GroupInfo {membership} by m r r'
viewMemberRoleChanged :: GroupInfo -> GroupMember -> GroupMember -> GroupMemberRole -> GroupMemberRole -> Bool -> [StyledString]
viewMemberRoleChanged g@GroupInfo {membership} by m r r' signed
| r == r' = [ttyGroup' g <> ": member role did not change"]
| groupMemberId' membership == memId = view "your role"
| groupMemberId' by == memId = view "the role"
| otherwise = view $ "the role of " <> ttyMember m
where
memId = groupMemberId' m
view s = [ttyGroup' g <> ": " <> ttyMember by <> " changed " <> s <> " from " <> showRole r <> " to " <> showRole r']
view s = [ttyGroup' g <> ": " <> ttyMember by <> " changed " <> s <> " from " <> showRole r <> " to " <> showRole r' <> signedStr signed]
viewMemberRoleUserChanged :: GroupInfo -> [GroupMember] -> GroupMemberRole -> [StyledString]
viewMemberRoleUserChanged g members r = case members of
[m] -> [ttyGroup' g <> ": you changed the role of " <> ttyMember m <> " to " <> showRole r]
mems' -> [ttyGroup' g <> ": you changed the role of " <> sShow (length mems') <> " members to " <> showRole r]
viewMemberRoleUserChanged :: GroupInfo -> [GroupMember] -> GroupMemberRole -> Bool -> [StyledString]
viewMemberRoleUserChanged g members r signed = case members of
[m] -> [ttyGroup' g <> ": you changed the role of " <> ttyMember m <> " to " <> showRole r <> signedStr signed]
mems' -> [ttyGroup' g <> ": you changed the role of " <> sShow (length mems') <> " members to " <> showRole r <> signedStr signed]
viewMemberBlockedForAll :: GroupInfo -> GroupMember -> GroupMember -> Bool -> [StyledString]
viewMemberBlockedForAll g by m blocked =
[ttyGroup' g <> ": " <> ttyMember by <> " " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m]
viewMemberBlockedForAll :: GroupInfo -> GroupMember -> GroupMember -> Bool -> Bool -> [StyledString]
viewMemberBlockedForAll g by m blocked signed =
[ttyGroup' g <> ": " <> ttyMember by <> " " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m <> signedStr signed]
viewMembersBlockedForAllUser :: GroupInfo -> [GroupMember] -> Bool -> [StyledString]
viewMembersBlockedForAllUser g members blocked = case members of
[m] -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m]
mems' -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> sShow (length mems') <> " members"]
viewMembersBlockedForAllUser :: GroupInfo -> [GroupMember] -> Bool -> Bool -> [StyledString]
viewMembersBlockedForAllUser g members blocked signed = case members of
[m] -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m <> signedStr signed]
mems' -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> sShow (length mems') <> " members" <> signedStr signed]
showRole :: GroupMemberRole -> StyledString
showRole = plain . textEncode
@@ -1884,17 +1887,17 @@ countactUserPrefText cup = case cup of
CUPUser p -> "default (" <> preferenceText p <> ")"
CUPContact p -> preferenceText p
viewGroupUpdated :: GroupInfo -> GroupInfo -> Maybe GroupMember -> [StyledString]
viewGroupUpdated :: GroupInfo -> GroupInfo -> Maybe GroupMember -> Bool -> [StyledString]
viewGroupUpdated
GroupInfo {localDisplayName = n, groupProfile = GroupProfile {fullName, shortDescr, description, image, groupPreferences = gps, memberAdmission = ma}}
g'@GroupInfo {localDisplayName = n', groupProfile = GroupProfile {fullName = fullName', shortDescr = shortDescr', description = description', image = image', groupPreferences = gps', memberAdmission = ma'}}
m = do
m signed = do
let update = groupProfileUpdated <> groupPrefsUpdated <> memberAdmissionUpdated
if null update
then []
else memberUpdated <> update
where
memberUpdated = maybe [] (\m' -> [ttyMember m' <> " updated group " <> ttyGroup n <> ":"]) m
memberUpdated = maybe [] (\m' -> [ttyMember m' <> " updated group " <> ttyGroup n <> ":" <> signedStr signed]) m
groupProfileUpdated =
["changed to " <> ttyFullGroup g' | n /= n']
<> ["full name " <> if T.null fullName' || fullName' == n' then "removed" else "changed to: " <> plain fullName' | n == n' && fullName /= fullName']