dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-07-20 15:41:31 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: public groups - roster of privileged members (#7017)

Browse Source
This commit is contained in:
spaced4ndy
2026-06-22 10:15:41 +00:00
committed by GitHub
parent 5d3f016627
commit 0e09b38ea6
33 changed files with 2902 additions and 411 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Library/Commands.hs
+78 -56
View File
@@ -1289,6 +1289,8 @@ processChatCommand cxt nm = \case
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
withGroupLock "deleteChat group" chatId $ do
deleteCIFiles user filesInfo
-- the roster blob file has no chat item, so it is missed by getGroupFileInfo above
cleanupGroupRosterFile user gInfo
(members, recipients) <- getRecipients gInfo
let doSendDel = memberActive membership && isOwner
msgSigned <-
@@ -2050,9 +2052,9 @@ processChatCommand cxt nm = \case
gVar <- asks random
(gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar cxt user groupProfile True ccLink welcomeSharedMsgId False GRMember Nothing
hostMember <- maybe (throwCmdError "no host member") pure hostMember_
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = CDGroupRcv gInfo Nothing hostMember
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing Nothing
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent) message
@@ -2062,9 +2064,9 @@ processChatCommand cxt nm = \case
pure $ CRNewPreparedChat user $ AChat SCTGroup chat
ACCL _ (CCLink cReq _) -> do
ct <- withStore $ \db -> createPreparedContact db cxt user profile accLink welcomeSharedMsgId
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = CDDirectRcv ct
createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing
createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing Nothing
cInfo = DirectChat ct
void $ createItem Nothing $ CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ connRequestPQEncryption cReq
void $ createFeatureEnabledItems_ user ct
@@ -2081,11 +2083,11 @@ processChatCommand cxt nm = \case
subRole <- if useRelays then asks $ channelSubscriberRole . config else pure GRMember
gVar <- asks random
(gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar cxt user gp False ccLink welcomeSharedMsgId useRelays subRole publicMemberCount_
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = maybe (CDChannelRcv gInfo Nothing) (CDGroupRcv gInfo Nothing) hostMember_
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- forM description $ \descr -> createChatItem user cd True (CIRcvMsgContent $ MCText descr) welcomeSharedMsgId Nothing
aci <- forM description $ \descr -> createChatItem user cd True (CIRcvMsgContent $ MCText descr) welcomeSharedMsgId Nothing Nothing
let chat = case aci of
Just (AChatItem SCTGroup dir _ ci) -> Chat cInfo [CChatItem dir ci] emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci}
_ -> Chat cInfo [] emptyChatStats
@@ -2153,7 +2155,7 @@ processChatCommand cxt nm = \case
-- create changed feature items (connecting incognito sends default preferences, instead of user preferences)
lift . when incognito $ createContactChangedFeatureItems user ct ct'
forM_ msg_ $ \(sharedMsgId, mc) -> do
ci <- createChatItem user (CDDirectSnd ct') False (CISndMsgContent mc) (Just sharedMsgId) Nothing
ci <- createChatItem user (CDDirectSnd ct') False (CISndMsgContent mc) (Just sharedMsgId) Nothing Nothing
toView $ CEvtNewChatItems user [ci]
pure $ CRStartedConnectionToContact user ct' customUserProfile
CVRConnectedContact ct' -> pure $ CRContactAlreadyExists user ct'
@@ -2246,7 +2248,7 @@ processChatCommand cxt nm = \case
liftIO $ setPreparedGroupStartedConnection db groupId
getGroupInfo db cxt user groupId
forM_ msg_ $ \(sharedMsgId, mc) -> do
ci <- createChatItem user (CDGroupSnd gInfo' Nothing) False (CISndMsgContent mc) (Just sharedMsgId) Nothing
ci <- createChatItem user (CDGroupSnd gInfo' Nothing) False (CISndMsgContent mc) (Just sharedMsgId) Nothing Nothing
toView $ CEvtNewChatItems user [ci]
pure $ CRStartedConnectionToGroup user gInfo' customUserProfile []
CVRConnectedContact _ct -> throwChatError $ CEException "contact already exists when connecting to group"
@@ -2756,34 +2758,45 @@ processChatCommand cxt nm = \case
-- TODO [relays] possible optimization is to read only required members + relays
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db cxt user groupId
when (selfSelected gInfo) $ throwCmdError "can't change role for self"
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending, anyPrivilegedTarget, finalPrivilegedCount) = selectMembers members
when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && (anyAdmin || newRole >= GRAdmin)) $
throwCmdError "can't change role of multiple members when admins selected, or new role is admin"
when anyPending $ throwCmdError "can't change role of members pending approval"
assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole])
-- in relay groups the roster has a single signer, so only the owner may change moderator/admin roles
when (useRelays' gInfo && (isRosterRole newRole || anyPrivilegedTarget) && memberRole' (membership gInfo) /= GROwner) $
throwCmdError "only the group owner can change moderator and admin roles"
when (useRelays' gInfo && isRosterRole newRole && finalPrivilegedCount > maxGroupRosterSize) $
throwCmdError $ "the number of members, moderators and admins would exceed the limit of " <> show maxGroupRosterSize
(errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g currentMems
let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && (isRosterRole newRole || anyPrivilegedTarget)
rosterVer <- if doBumpRoster then Just <$> reserveRosterVersion gInfo else pure Nothing
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g rosterVer currentMems
forM_ rosterVer $ \v -> broadcastRoster user gInfo v `catchAllErrors` eToView
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, msgSigned} -- same order is not guaranteed
where
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
selectMembers = foldr' addMember ([], [], [], GRObserver, False, False)
-- anyPrivilegedTarget: a target currently moderator/admin; finalPrivilegedCount:
-- moderators + admins after the change (targets take newRole, others keep their role).
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool, Bool, Int)
selectMembers = foldr' addMember ([], [], [], GRObserver, False, False, False, 0)
where
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending)
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending, anyPrivTarget, privCount)
| groupMemberId `elem` memberIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
anyPending' = anyPending || memberPending m
in
if
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending')
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending')
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending')
| otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending)
anyPrivTarget' = anyPrivTarget || isRosterRole memberRole
privCount' = if isRosterRole newRole then privCount + 1 else privCount
in if
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending, anyPrivTarget, if isRosterRole memberRole then privCount + 1 else privCount)
changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember])
changeRoleInvitedMems user gInfo memsToChange = do
-- not batched, as we need to send different invitations to different connections anyway
@@ -2798,19 +2811,20 @@ processChatCommand cxt 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], Bool)
changeRoleCurrentMems user (Group gInfo members) memsToChange = case L.nonEmpty memsToChange of
changeRoleCurrentMems :: User -> Group -> Maybe VersionRoster -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
changeRoleCurrentMems user (Group gInfo members) rosterVer memsToChange = case L.nonEmpty memsToChange of
Nothing -> pure ([], [], [], False)
Just memsToChange' -> do
let events = L.map (\GroupMember {memberId} -> XGrpMemRole memberId newRole) memsToChange'
let mKey m = if isJust rosterVer then MemberKey <$> memberPubKey m else Nothing
events = L.map (\m@GroupMember {memberId} -> XGrpMemRole memberId newRole (mKey m) rosterVer) memsToChange'
recipients = filter memberCurrent members
(msgs_, _gsr) <- sendGroupMessages user gInfo Nothing False recipients events
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_
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
pure (errs, changed, acis, signed)
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
@@ -2874,20 +2888,25 @@ processChatCommand cxt nm = \case
withGroupLock "removeMembers" groupId $ do
-- TODO [relays] possible optimization is to read only required members + relays
Group gInfo members <- withFastStore $ \db -> getGroup db cxt user groupId
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin) = selectMembers gmIds members
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin, anyPrivilegedRemoved) = selectMembers gmIds members
gmIds = S.fromList $ L.toList groupMemberIds
memCount = length groupMemberIds
when (count /= memCount) $ throwChatError CEGroupMemberNotFound
when (memCount > 1 && anyAdmin) $ throwCmdError "can't remove multiple members when admins selected"
assertUserGroupRole gInfo $ max GRAdmin maxRole
when (useRelays' gInfo && anyPrivilegedRemoved && memberRole' (membership gInfo) /= GROwner) $
throwCmdError "only the group owner can remove members, moderators and admins"
(errs1, deleted1) <- deleteInvitedMems user invitedMems
let recipients = filter memberCurrent members
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing recipients currentMems
let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && anyPrivilegedRemoved
rosterVer <- if doBumpRoster then Just <$> reserveRosterVersion gInfo else pure Nothing
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing rosterVer 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, signed4) <-
foldM (\acc m -> deletePendingMember acc user gInfo (m : moderators) m) ([], [], [], False) pendingRvwMems
forM_ rosterVer $ \v -> broadcastRoster user gInfo v `catchAllErrors` eToView
let acis = acis2 <> acis3 <> acis4
errs = errs1 <> errs2 <> errs3 <> errs4
deleted = deleted1 <> deleted2 <> deleted3 <> deleted4
@@ -2902,19 +2921,20 @@ processChatCommand cxt nm = \case
unless (null errs) $ toView $ CEvtChatErrors errs
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)
selectMembers :: S.Set GroupMemberId -> [GroupMember] -> (Int, [GroupMember], [GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
selectMembers gmIds = foldl' addMember (0, [], [], [], [], GRObserver, False, False)
where
addMember acc@(n, invited, pendingApprv, pendingRvw, current, maxRole, anyAdmin) m@GroupMember {groupMemberId, memberStatus, memberRole}
addMember acc@(n, invited, pendingApprv, pendingRvw, current, maxRole, anyAdmin, anyPrivRemoved) m@GroupMember {groupMemberId, memberStatus, memberRole}
| groupMemberId `S.member` gmIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
anyPrivRemoved' = anyPrivRemoved || isRosterRole memberRole
n' = n + 1
in case memberStatus of
GSMemInvited -> (n', m : invited, pendingApprv, pendingRvw, current, maxRole', anyAdmin')
GSMemPendingApproval -> (n', invited, m : pendingApprv, pendingRvw, current, maxRole', anyAdmin')
GSMemPendingReview -> (n', invited, pendingApprv, m : pendingRvw, current, maxRole', anyAdmin')
_ -> (n', invited, pendingApprv, pendingRvw, m : current, maxRole', anyAdmin')
GSMemInvited -> (n', m : invited, pendingApprv, pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
GSMemPendingApproval -> (n', invited, m : pendingApprv, pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
GSMemPendingReview -> (n', invited, pendingApprv, m : pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
_ -> (n', invited, pendingApprv, pendingRvw, m : current, maxRole', anyAdmin', anyPrivRemoved')
| otherwise = acc
deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember])
deleteInvitedMems user memsToDelete = do
@@ -2927,14 +2947,14 @@ processChatCommand cxt nm = \case
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, signed) <- deleteMemsSend user gInfo (Just scopeInfo) recipients [m']
(errs, deleted, acis, signed) <- deleteMemsSend user gInfo (Just scopeInfo) Nothing 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
deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe VersionRoster -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deleteMemsSend user gInfo chatScopeInfo rosterVer recipients memsToDelete = case L.nonEmpty memsToDelete of
Nothing -> pure ([], [], [], False)
Just memsToDelete' -> do
let chatScope = toChatScope <$> chatScopeInfo
events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages) memsToDelete'
events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages rosterVer) memsToDelete'
(msgs_, _gsr) <- sendGroupMessages user gInfo chatScope False recipients events
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
@@ -3134,7 +3154,7 @@ processChatCommand cxt nm = \case
(connId, CCLink cReq _) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation Nothing Nothing IKPQOff subMode
-- [incognito] reuse membership incognito profile
ct <- withFastStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart)
-- TODO not sure it is correct to set connections status here?
pure $ CRNewMemberContact user ct g m
_ -> throwChatError CEGroupMemberNotActive
@@ -3613,13 +3633,18 @@ processChatCommand cxt nm = \case
where
cReqHash1 = contactCReqHash $ CRContactUri crData {crScheme = SSSimplex}
cReqHash2 = contactCReqHash $ CRContactUri crData {crScheme = simplexChat}
-- relay-group joins (only via connectToRelay) carry the target relay member in preparedEntity_;
-- its memberId binds the join signature so a sibling relay can't replay it
relayMemberId_ = case preparedEntity_ of
Just (PCEGroup gInfo m) | useRelays' gInfo -> Just (memberId' m)
_ -> Nothing
joinPreparedConn' xContactId_ conn@Connection {customUserProfileId} gInfo_ = do
when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection"
-- TODO [relays] member: refactor joinContact and up avoiding parallel ifs, xContactId is not used
xContactId <- mkXContactId xContactId_
localIncognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ PQSupportOn
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn
pure $ CVRSentInvitation conn' incognitoProfile
connect' groupLinkId xContactId_ gInfo_ = do
let inGroup = isJust groupLinkId
@@ -3634,7 +3659,7 @@ processChatCommand cxt nm = \case
subMode <- chatReadVar subscriptionMode
let sLnk' = serverShortLink <$> sLnk
conn <- withFastStore' $ \db -> createConnReqConnection db userId connId preparedEntity_ cReq cReqHash1 sLnk' xContactId incognitoProfile_ groupLinkId subMode chatV pqSup
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ pqSup
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup
pure $ CVRSentInvitation conn' incognitoProfile
connectContactViaAddress :: User -> IncognitoEnabled -> Contact -> CreatedLinkContact -> CM ChatResponse
connectContactViaAddress user@User {userId} incognito ct@Contact {contactId, activeConn} (CCLink cReq shortLink) =
@@ -3649,7 +3674,7 @@ processChatCommand cxt nm = \case
subMode <- chatReadVar subscriptionMode
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
conn <- withFastStore' $ \db -> createConnReqConnection db userId connId (Just $ PCEContact ct) cReq cReqHash shortLink newXContactId (NewIncognito <$> incognitoProfile) Nothing subMode chatV pqSup
void $ joinContact user conn cReq incognitoProfile newXContactId Nothing Nothing Nothing pqSup
void $ joinContact user conn cReq incognitoProfile newXContactId Nothing Nothing Nothing Nothing pqSup
ct' <- withStore $ \db -> getContact db cxt user contactId
pure $ CRSentInvitationToContact user ct' incognitoProfile
Just conn@Connection {connStatus, xContactId = xContactId_, customUserProfileId} -> case connStatus of
@@ -3658,7 +3683,7 @@ processChatCommand cxt nm = \case
xContactId <- mkXContactId xContactId_
localIncognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
void $ joinContact user conn cReq incognitoProfile xContactId Nothing Nothing Nothing PQSupportOn
void $ joinContact user conn cReq incognitoProfile xContactId Nothing Nothing Nothing Nothing PQSupportOn
ct' <- withStore $ \db -> getContact db cxt user contactId
pure $ CRSentInvitationToContact user ct' incognitoProfile
_ -> throwCmdError "contact already has connection"
@@ -3670,13 +3695,14 @@ processChatCommand cxt nm = \case
r <- tryAllErrors $ do
(fd@FixedLinkData {rootKey = relayKey, linkEntityId}, cData) <- getShortLinkConnReq nm user relayLink
relayLinkData_ <- liftIO $ decodeLinkUserData cData
case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) ->
relayMemberId <- case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) -> do
withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) p
pure $ MemberId entityId
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
let cReq = linkConnReq fd
relayLinkToConnect = CCLink cReq (Just relayLink)
void $ connectViaContact user (Just $ PCEGroup gInfo relayMember) (incognitoMembership gInfo) relayLinkToConnect Nothing Nothing
void $ connectViaContact user (Just $ PCEGroup gInfo (relayMember {memberId = relayMemberId})) (incognitoMembership gInfo) relayLinkToConnect Nothing Nothing
relayMember' <- withFastStore $ \db -> getGroupMember db cxt user (groupId' gInfo) (groupMemberId' relayMember)
pure (relayLink, relayMember', r)
syncSubscriberRelays :: User -> GroupInfo -> [ShortLinkContact] -> CM ()
@@ -3712,8 +3738,8 @@ processChatCommand cxt nm = \case
pure (connId, chatV)
mkXContactId :: Maybe XContactId -> CM XContactId
mkXContactId = maybe (XContactId <$> drgRandomBytes 16) pure
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfo) -> PQSupport -> CM Connection
joinContact user conn@Connection {connChatVersion = chatV} cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ pqSup = do
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfo) -> Maybe MemberId -> PQSupport -> CM Connection
joinContact user conn@Connection {connChatVersion = chatV} cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup = do
-- gInfo_ is Maybe (Maybe GroupInfo), where Just Nothing means "some unknown group", e.g. when joining via link without profile
profileToSend <-
presentUserBadge user incognitoProfile $ case gInfo_ of
@@ -3721,15 +3747,11 @@ processChatCommand cxt nm = \case
let allowSimplexLinks = maybe True groupUserAllowSimplexLinks gInfo_'
in userProfileInGroup' user allowSimplexLinks incognitoProfile
Nothing -> userProfileDirect user incognitoProfile Nothing True
chatEvent <- case gInfo_ of
Just (Just gInfo) | useRelays' gInfo -> do
let GroupInfo {membership = GroupMember {memberId}} = gInfo
memberPubKey <- case groupKeys gInfo of
Just GroupKeys {memberPrivKey} -> pure $ C.publicKey memberPrivKey
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
pure $ XMember profileToSend memberId (MemberKey memberPubKey)
_ -> pure $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
dm <- encodeConnInfoPQ pqSup chatV chatEvent
dm <- case gInfo_ of
Just (Just gInfo) | useRelays' gInfo -> case relayMemberId_ of
Just relayMemberId -> encodeXMemberConnInfo gInfo relayMemberId profileToSend
Nothing -> throwChatError $ CEInternalError "relay group join without target relay memberId"
_ -> encodeConnInfoPQ pqSup chatV $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
subMode <- chatReadVar subscriptionMode
void $ withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup subMode
withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared ConnJoined
@@ -4914,7 +4936,7 @@ runRelayGroupLinkChecks user = do
then do
-- TODO [relays] emit event to UI when relay own status promoted to RSActive
-- CEvtGroupRelayUpdated requires GroupRelay (owner-side), not available on relay side
void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSAccepted RSActive
void $ withStore' $ \db -> updateRelayOwnStatus_ db gInfo RSActive
else void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSActive RSInactive
_ -> pure ()
_ -> pure ()
src/Simplex/Chat/Library/Internal.hs
+216 -38
View File
@@ -59,7 +59,7 @@ import Simplex.Chat.Controller
import Simplex.Chat.Files
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (BatchMode (..), MsgBatch (..), batchMessages, encodeBinaryBatch, encodeFwdElement)
import Simplex.Chat.Messages.Batch (BatchMode (..), MsgBatch (..), batchMessages, encodeBatchElement, encodeBinaryBatch, encodeFwdElement)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Operators
@@ -80,6 +80,7 @@ import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (encryptFile, shuffle)
import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription)
import qualified Simplex.FileTransfer.Description as FD
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
import Simplex.Messaging.Agent
@@ -935,9 +936,9 @@ acceptContactRequestAsync
liftIO $ setCommandConnId db user cmdId connId
getContact db cxt user contactId
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> CM GroupMember
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
acceptGroupJoinRequestAsync
user
user@User {userId}
uclId
gInfo@GroupInfo {groupProfile, membership, businessChat}
cReqInvId
@@ -949,12 +950,22 @@ acceptGroupJoinRequestAsync
gAccepted
gLinkMemRole
incognitoProfile
memberKey_ = do
memberKey_
existingMem_ = do
gVar <- asks random
let initialStatus = acceptanceToStatus (memberAdmission groupProfile) gAccepted
-- a roster-established privileged member attaches a connection to its existing record (keeping
-- owner-authoritative role + key); everyone else is created fresh with the group-link role
cxt <- chatStoreCxt
(groupMemberId, memberId) <- withStore $ \db ->
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_
(groupMemberId, memberId) <- case existingMem_ of
Just m -> do
-- refresh the hash placeholder name from the authenticated join profile; role + key stay roster-authoritative
withStore $ \db -> do
liftIO $ updateGroupMemberStatus db userId m initialStatus
void $ updateMemberProfile db cxt user m cReqProfile
pure (groupMemberId' m, memberId' m)
Nothing -> withStore $ \db ->
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_
let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo
let Profile {displayName} = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile)
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
@@ -1169,21 +1180,47 @@ memberIntroEvt gInfo reMember =
mRestrictions = memberRestrictions reMember
in XGrpMemIntro mInfo mRestrictions
-- Forward the saved owner-signed roster verbatim (reusing its signed shared_msg_id), then the
-- blob chunks, so the recipient verifies the owner signature.
serveRoster :: User -> GroupInfo -> GroupMember -> CM ()
serveRoster user gInfo member =
when (member `supportsVersion` groupRosterVersion) $ do
cxt <- chatStoreCxt
withStore' (\db -> getGroupRoster db gInfo) >>= \case
Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}, blob_) ->
case J.eitherDecodeStrict' signedBody :: Either String (ChatMessage 'Json) of
Left e -> logError $ "serveRoster: cannot decode saved roster message: " <> tshow e
Right chatMsg@ChatMessage {msgId} ->
withStore' (\db -> runExceptT $ getGroupMemberById db cxt user ownerGMId) >>= \case
Right owner -> do
let fwd = GrpMsgForward {fwdSender = FwdMember (memberId' owner) (memberShortenedName owner), fwdBrokerTs = brokerTs}
sendFwdMemberMessage member fwd (VMSigned MSSVerified sm chatMsg)
forM_ ((,) <$> msgId <*> blob_) $ \(sid, blob) ->
sendInlineBlobChunks user gInfo [member] sid blob
Left e -> logError $ "serveRoster: roster owner not found: " <> tshow e
Nothing -> pure ()
-- Used in groups with relays to introduce moderators and above to a new member,
-- and to announce the new member to moderators and above.
-- This doesn't create introduction records in db, compared to above methods.
introduceInChannel :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceInChannel _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
(owners, adminsMods) <- withStore' $ \db ->
(,) <$> getGroupOwners db cxt user gInfo <*> getGroupAdminsMods db cxt user gInfo
let modMs = owners <> adminsMods
void $ sendGroupMessage' user gInfo modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
withStore' $ \db ->
setMemberVectorNewRelations db subscriber [(indexInGroup m, (IDSubjectIntroduced, MRIntroduced)) | m <- modMs]
let introEvts = map (memberIntroEvt gInfo) modMs
forM_ (L.nonEmpty introEvts) $ \introEvts' ->
sendGroupMemberMessages user gInfo conn introEvts'
-- owner intros first so the joiner has the owner profile loaded before applying the saved roster (signed by the owner)
sendIntros owners
serveRoster user gInfo subscriber
sendIntros adminsMods
withStore' $ \db ->
setMembersVectorsNewRelation db modMs subscriberIdx IDSubjectIntroduced MRIntroduced
where
sendIntros ms = forM_ (L.nonEmpty $ map (memberIntroEvt gInfo) ms) $ \evts ->
sendGroupMemberMessages user gInfo conn evts
userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup user = userProfileInGroup' user . groupUserAllowSimplexLinks
@@ -1215,6 +1252,29 @@ redactedMemberProfile allowSimplexLinks Profile {displayName, fullName, shortDes
| hasObfuscatedSimplexLink s = Nothing
| otherwise = maybe (Just s) (\fts -> if any ftIsSimplexLink fts then Nothing else Just s) $ parseMaybeMarkdownList s
-- Roles carried by the roster; owners are on the link, not the roster.
isRosterRole :: GroupMemberRole -> Bool
isRosterRole r = r == GRMember || r == GRModerator || r == GRAdmin
-- Drop non-privileged-role entries and de-duplicate by memberId, keeping the first.
-- Runs on the parsed roster blob.
validateGroupRoster :: [RosterMember] -> [RosterMember]
validateGroupRoster entries =
dedup S.empty $ filter (\RosterMember {role} -> isRosterRole role) entries
where
dedup _ [] = []
dedup seen (rm@RosterMember {memberId} : rms)
| memberId `S.member` seen = dedup seen rms
| otherwise = rm : dedup (S.insert memberId seen) rms
-- Privileged members without a known key are skipped (recipients can't verify them).
buildGroupRoster :: [GroupMember] -> [RosterMember]
buildGroupRoster mods = take maxGroupRosterSize $ mapMaybe rosterMember mods
where
rosterMember GroupMember {memberId, memberPubKey, memberRole}
| isRosterRole memberRole = (\k -> RosterMember {memberId, key = MemberKey k, role = memberRole, privileges = 0}) <$> memberPubKey
| otherwise = Nothing
sendHistory :: User -> GroupInfo -> GroupMember -> CM ()
sendHistory _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just conn} =
@@ -1341,7 +1401,7 @@ setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM G
setGroupLinkData nm user gInfo gLink = do
cxt <- chatStoreCxt
(conn, groupRelays) <- withFastStore $ \db ->
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
linkType = if useRelays' gInfo then CCTChannel else CCTGroup
sLnk <- shortenShortLink' . setShortLinkType_ linkType =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData))
@@ -1351,7 +1411,7 @@ setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
setGroupLinkDataAsync user gInfo gLink = do
cxt <- chatStoreCxt
(conn, groupRelays) <- withStore $ \db ->
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
setAgentConnShortLinkAsync user conn userLinkData (Just crClientData)
@@ -1628,13 +1688,16 @@ sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg =
chSize = fromIntegral chunkSize
parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage conn s = do
parseChatMessage conn s = snd <$> parseChatMessage' conn s
{-# INLINE parseChatMessage #-}
parseChatMessage' :: Connection -> ByteString -> CM (Maybe SignedMsg, ChatMessage 'Json)
parseChatMessage' conn s =
case parseChatMessages s of
[msg] -> liftEither . first (ChatError . errType) $ (\(APMsg _ (ParsedMsg _ _ m)) -> checkEncoding m) =<< msg
[msg] -> liftEither . first (ChatError . errType) $ (\(APMsg _ (ParsedMsg _ sm m)) -> (sm,) <$> checkEncoding m) =<< msg
_ -> throwChatError $ CEException "parseChatMessage: single message is expected"
where
errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s)
{-# INLINE parseChatMessage #-}
getChatScopeInfo :: StoreCxt -> User -> GroupChatScope -> CM GroupChatScopeInfo
getChatScopeInfo cxt user = \case
@@ -1831,6 +1894,51 @@ closeFileHandle fileId files = do
h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
liftIO $ mapM_ hClose h_ `catchAll_` pure ()
-- The roster file has no chat item, so chat-item file enumeration misses it; clean it up by group.
cleanupGroupRosterFile :: User -> GroupInfo -> CM ()
cleanupGroupRosterFile User {userId} GroupInfo {groupId} = do
infos <- withStore' $ \db -> getGroupRosterFileInfo db userId groupId
forM_ infos $ \(fileId, filePath_) -> do
lift $ closeFileHandle fileId rcvFiles
forM_ filePath_ removeFsFile
withStore' $ \db -> do
deleteGroupRosterFile db userId groupId
deleteGroupRosterTransfers db groupId
-- Supersede/cancel one source relay's in-flight roster transfer: remove its on-disk file + cached
-- handle first (the cascade only does rows), then the files + transfer rows.
cleanupRosterTransfer :: GroupInfo -> GroupMemberId -> CM ()
cleanupRosterTransfer gInfo fromMemberId =
withStore' (\db -> getRosterTransferId db gInfo fromMemberId) >>= mapM_ cleanupRosterTransferById
cleanupRosterTransferById :: Int64 -> CM ()
cleanupRosterTransferById transferId = do
file_ <- withStore' $ \db -> getRosterTransferFile db transferId
forM_ file_ $ \(fileId, filePath_) -> do
lift $ closeFileHandle fileId rcvFiles
forM_ filePath_ removeFsFile
withStore' $ \db -> do
deleteRosterTransferFile db transferId
deleteRosterTransfer db transferId
-- MUST evict the cached AppendMode handle before deleting chunks, else re-driven bytes append
-- after the stale prefix and corrupt the blob.
resetRosterPartialChunks :: RcvFileTransfer -> CM ()
resetRosterPartialChunks ft@RcvFileTransfer {fileId, fileStatus} = do
lift $ closeFileHandle fileId rcvFiles
forM_ (rcvFilePath fileStatus) removeFsFile
withStore' $ \db -> deleteRcvFileChunks db ft
where
rcvFilePath = \case
RFSAccepted p -> Just p
RFSConnected p -> Just p
_ -> Nothing
removeFsFile :: FilePath -> CM ()
removeFsFile fp = do
p <- lift $ toFSFilePath fp
removeFile p `catchAllErrors` \_ -> pure ()
deleteMembersConnections :: User -> [GroupMember] -> CM ()
deleteMembersConnections user members = deleteMembersConnections' user members False
@@ -2063,6 +2171,26 @@ encodeConnInfoPQ pqSup v chatMsgEvent = do
_ -> pure connInfo
ECMLarge -> throwChatError $ CEException "large info"
-- conn-info wrapped as a signed element, so the receiver can verify the signature over the body
encodeSignedConnInfo :: MsgEncodingI e => MsgSigning -> ChatMsgEvent e -> CM ByteString
encodeSignedConnInfo signing chatMsgEvent = do
vr <- chatVersionRange
let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent}
case encodeChatMessage maxEncodedInfoLength info of
ECMEncoded body -> pure $ encodeBatchElement (Just $ signChatMsgBody signing body) body
ECMLarge -> throwChatError $ CEException "large signed info"
-- signed XMember for a relay-group join: proves the joiner holds the member key it asserts, and carries
-- viaRelay = the target relay's memberId inside the signed body so a sibling relay can't accept a replay
encodeXMemberConnInfo :: GroupInfo -> MemberId -> Profile -> CM ByteString
encodeXMemberConnInfo GroupInfo {membership = GroupMember {memberId}, groupKeys} relayMemberId profileToSend =
case groupKeys of
Just GroupKeys {publicGroupId, memberPrivKey} ->
let xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey) (Just relayMemberId)
signing = MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
in encodeSignedConnInfo signing xMemberEvt
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
deliverMessage conn cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
@@ -2136,6 +2264,52 @@ sendGroupMessage' user gInfo members chatMsgEvent =
((Right msg) :| [], _) -> pure msg
_ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message"
-- TODO [relays] improvement: publish roster_version in link data so the owner can recover the latest version
-- TODO after restoring from a stale backup (relays accept only strictly-greater versions)
-- Persist the next roster version before sending the events that carry it (so a recipient never advances
-- past a version the owner hasn't recorded). The matching blob is broadcast separately, by broadcastRoster,
-- after the change is applied to the owner's members - so the served roster excludes demoted/removed members.
reserveRosterVersion :: GroupInfo -> CM VersionRoster
reserveRosterVersion gInfo = do
let rosterVer = maybe (VersionRoster 0) (\(VersionRoster n) -> VersionRoster (n + 1)) (rosterVersion gInfo)
withStore' $ \db -> setGroupRosterVersion db gInfo rosterVer
pure rosterVer
broadcastRoster :: User -> GroupInfo -> VersionRoster -> CM ()
broadcastRoster user gInfo rosterVer = do
cxt <- chatStoreCxt
(relays, rosterMems) <- withStore' $ \db ->
(,) <$> getGroupRelayMembers db cxt user gInfo <*> getGroupRosterMembers db cxt user gInfo
forM_ (L.nonEmpty relays) $ \relays' ->
sendRoster user gInfo (L.toList relays') rosterVer (buildGroupRoster rosterMems)
-- Send the current roster (no version bump) to a newly added relay so it can serve joiners.
sendGroupRosterToRelay :: User -> GroupInfo -> GroupMember -> CM ()
sendGroupRosterToRelay user gInfo relayMember =
forM_ (rosterVersion gInfo) $ \rosterVer -> do
cxt <- chatStoreCxt
rosterMems <- withStore' $ \db -> getGroupRosterMembers db cxt user gInfo
sendRoster user gInfo [relayMember] rosterVer (buildGroupRoster rosterMems)
-- Row-less send (no files/snd_files rows, so no send-side cleanup); redelivery is the agent's.
sendRoster :: User -> GroupInfo -> [GroupMember] -> VersionRoster -> [RosterMember] -> CM ()
sendRoster user gInfo members rosterVer roster = do
let blob = encodeRosterBlob roster
fileInv = InlineFileInvitation {fileSize = fromIntegral (B.length blob), fileDigest = FD.FileDigest $ LC.sha512Hash $ LB.fromStrict blob}
SndMessage {sharedMsgId} <- sendGroupMessage' user gInfo members (XGrpRoster GroupRoster {version = rosterVer, fileInv})
sendInlineBlobChunks user gInfo members sharedMsgId blob
-- Send a binary blob as BFileChunks under a shared_msg_id to the given members (chunked by fileChunkSize).
sendInlineBlobChunks :: User -> GroupInfo -> [GroupMember] -> SharedMsgId -> ByteString -> CM ()
sendInlineBlobChunks user gInfo members sharedMsgId blob = do
chSize <- fromIntegral <$> asks (fileChunkSize . config)
go chSize 1 blob
where
go chSize chunkNo bytes = do
let (chunk, rest) = B.splitAt chSize bytes
void $ sendGroupMessage' user gInfo members (BFileChunk sharedMsgId (FileChunk chunkNo chunk))
unless (B.null rest) $ go chSize (chunkNo + 1) rest
-- Relay advertises its current web preview capability to channel owners.
-- Idempotent: sends only when the configured web domain differs from what was last sent, and only to
-- owners whose recorded chat version supports relayWebCapVersion (older apps can't parse XGrpRelayCap).
@@ -2372,10 +2546,14 @@ saveDirectRcvMSG conn@Connection {connId} agentMsgMeta chatMsg@ChatMessage {chat
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
pure (conn', msg)
saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> VerifiedMsg e -> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg :: forall e. 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
-- binary messages (file chunks) carry only the initial-version sentinel, not the sender's range;
-- applying it would downgrade the member's negotiated version and suppress version-gated delivery
(am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- case encoding @e of
SBinary -> pure (authorMember, conn)
SJson -> updateMemberChatVRange authorMember conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
brokerTs = metaBrokerTs agentMsgMeta
newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs}
@@ -2513,11 +2691,11 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem
_ -> Nothing
-- TODO [mentions] optimize by avoiding unnecessary parsing
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember msgSigned 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 Nothing currentTs
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned 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 -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs =
@@ -2679,7 +2857,7 @@ createFeatureEnabledItems_ :: User -> Contact -> CM [AChatItem]
createFeatureEnabledItems_ user ct@Contact {mergedPreferences} =
forM allChatFeatures $ \(ACF f) -> do
let state = featureState $ getContactUserPreference f mergedPreferences
createChatItem user (CDDirectRcv ct) False (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing Nothing
createChatItem user (CDDirectRcv ct) False (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing Nothing Nothing
createFeatureItems ::
MsgDirectionI d =>
@@ -2709,15 +2887,15 @@ createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do
unless (null errs) $ toView' $ CEvtChatErrors errs
toView' $ CEvtNewChatItems user acis
where
contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])
contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)])
contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do
let contents = mapMaybe (\(ACF f) -> featureCIContent_ f) allChatFeatures
(chatDir ct', False, contents)
where
featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId)
featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)
featureCIContent_ f
| state /= state' = Just (fContent ciFeature state', Nothing)
| prefState /= prefState' = Just (fContent ciOffer prefState', Nothing)
| state /= state' = Just (fContent ciFeature state', Nothing, Nothing)
| prefState /= prefState' = Just (fContent ciOffer prefState', Nothing, Nothing)
| otherwise = Nothing
where
fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d
@@ -2750,16 +2928,16 @@ createGroupFeatureItems_ user cd showGroupAsSender ciContent GroupInfo {fullGrou
forM allGroupFeatures $ \(AGF f) -> do
let p = getGroupPreference f fullGroupPreferences
(_, param, role) = groupFeatureState p
createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing
createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing Nothing
createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem user cd content itemTs_ = do
ci <- createChatItem user cd False content Nothing itemTs_
ci <- createChatItem user cd False content Nothing Nothing itemTs_
toView $ CEvtNewChatItems user [ci]
createChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Maybe UTCTime -> CM AChatItem
createChatItem user cd showGroupAsSender content sharedMsgId itemTs_ =
lift (createChatItems user itemTs_ [(cd, showGroupAsSender, [(content, sharedMsgId)])]) >>= \case
createChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Maybe MsgSigStatus -> Maybe UTCTime -> CM AChatItem
createChatItem user cd showGroupAsSender content sharedMsgId msgSigned itemTs_ =
lift (createChatItems user itemTs_ [(cd, showGroupAsSender, [(content, sharedMsgId, msgSigned)])]) >>= \case
[Right ci] -> pure ci
[Left e] -> throwError e
rs -> throwChatError $ CEInternalError $ "createInternalChatItem: expected 1 result, got " <> show (length rs)
@@ -2771,7 +2949,7 @@ createChatItems ::
(ChatTypeI c, MsgDirectionI d) =>
User ->
Maybe UTCTime ->
[(ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])] ->
[(ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)])] ->
CM' [Either ChatError AChatItem]
createChatItems user itemTs_ dirsCIContents = do
createdAt <- liftIO getCurrentTime
@@ -2780,24 +2958,24 @@ createChatItems user itemTs_ dirsCIContents = do
void . withStoreBatch' $ \db -> map (updateChat db cxt createdAt) dirsCIContents
withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents
where
updateChat :: DB.Connection -> StoreCxt -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO ()
updateChat :: DB.Connection -> StoreCxt -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)]) -> IO ()
updateChat db cxt createdAt (cd, _, contents)
| any (ciRequiresAttention . fst) contents || contactChatDeleted cd = void $ updateChatTsStats db cxt user cd createdAt memberChatStats
| any (\(content, _, _) -> ciRequiresAttention content) contents || contactChatDeleted cd = void $ updateChatTsStats db cxt user cd createdAt memberChatStats
| otherwise = pure ()
where
memberChatStats :: Maybe (Int, MemberAttention, Int)
memberChatStats = case cd of
CDGroupRcv _g (Just scope) m -> do
let unread = length $ filter (ciRequiresAttention . fst) contents
let unread = length $ filter (\(content, _, _) -> ciRequiresAttention content) contents
in Just (unread, memberAttentionChange unread itemTs_ (Just m) scope, 0)
_ -> Nothing
createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> [IO AChatItem]
createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)]) -> [IO AChatItem]
createACIs db itemTs createdAt (cd, showGroupAsSender, contents) = map createACI contents
where
createACI (content, sharedMsgId) = do
createACI (content, sharedMsgId, msgSigned) = do
let hasLink_ = ciContentHasLink content Nothing
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ itemTs createdAt
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ msgSigned itemTs createdAt
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing msgSigned createdAt
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
-- rcvMem_ Nothing means message from channel - treated same as message from moderator,
src/Simplex/Chat/Library/Subscriber.hs
+448 -135
View File
@@ -24,6 +24,7 @@ import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Either (lefts, partitionEithers, rights)
import Data.Foldable (foldr', foldrM)
import Data.Functor (($>))
@@ -40,12 +41,14 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as V4
import Data.Word (Word32)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Delivery
import Simplex.Chat.Files (getChatTempDirectory)
import Simplex.Chat.Library.Internal
import Simplex.Chat.Web (channelContentChanged, channelProfileUpdated, channelRemoved)
import Simplex.Chat.Messages
@@ -77,7 +80,7 @@ import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Client (getAgentWorker, temporaryOrHostError, waitForUserNetwork, waitForWork, waitWhileSuspended, withWorkItems, withWork_)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Worker (..))
import Simplex.Messaging.Agent.Env.SQLite (Worker (..))
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay)
@@ -87,8 +90,10 @@ 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 qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding (smpEncode)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..), ServiceSub (..), ServiceSubError (..), ServiceSubResult (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
@@ -106,6 +111,13 @@ import UnliftIO.STM
smallGroupsRcptsMemLimit :: Int
smallGroupsRcptsMemLimit = 20
-- Verifies member signatures over CBGroup <> (publicGroupId, memberId) <> signedBody under the given key.
-- signatures is NonEmpty so the verification can't be vacuously true.
verifyGroupSig :: C.PublicKeyEd25519 -> B64UrlByteString -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
verifyGroupSig key publicGroupId memberId signatures signedBody =
let prefix = smpEncode CBGroup <> smpEncode (publicGroupId, memberId)
in all (\case (MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 key) sig (prefix <> signedBody)) signatures
processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessage _ _ (DEL_RCVQS delQs) =
toView $ CEvtAgentRcvQueuesDeleted $ L.map rcvQ delQs
@@ -576,7 +588,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
(gInfo, host) <- withStore $ \db -> do
liftIO $ deleteContactCardKeepConn db connId ct
createGroupInvitedViaLink db cxt user conn'' glInv
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
-- [incognito] send saved profile
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
@@ -901,8 +913,21 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
GCInviteeMember
| isRelay m -> do
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected
gLink <- withStore $ \db -> getGroupLink db user gInfo
setGroupLinkDataAsync user gInfo gLink
if m `supportsVersion` groupRosterVersion
then do
-- send the relay a roster (materializing version 0 for old channels with NULL roster_version);
-- the relay stays RSInvited (unpublishable) until it acks, so no joiner can impersonate a privileged member
gInfo' <- case rosterVersion gInfo of
Just _ -> pure gInfo
Nothing -> do
withStore' $ \db -> setGroupRosterVersion db gInfo (VersionRoster 0)
pure gInfo {rosterVersion = Just (VersionRoster 0)}
sendGroupRosterToRelay user gInfo' m
else do
-- a relay below groupRosterVersion can't ack a roster; publish it on connect as before
-- the handshake (getPublishableGroupRelays and the LINK handler include/activate it by version)
gLink <- withStore $ \db -> getGroupLink db user gInfo
setGroupLinkDataAsync user gInfo gLink
| otherwise -> do
(gInfo', mStatus) <-
if not (memberPending m)
@@ -1024,8 +1049,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
pure newDeliveryTasks
processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> VerifiedMsg e -> CM (Maybe NewMessageDeliveryTask)
processEvent gInfo' m' verifiedMsg = do
(m'', conn', msg@RcvMessage {msgId, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta verifiedMsg
cc <- ask
(m'', conn', msg@RcvMessage {msgId, sharedMsgId_, 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
@@ -1064,23 +1089,25 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_
XGrpMemInv memId introInv -> Nothing <$ xGrpMemInv gInfo' m'' memId introInv
XGrpMemFwd memInfo introInv -> Nothing <$ xGrpMemFwd gInfo' m'' memInfo introInv
XGrpMemRole memId memRole -> fmap ctx <$> xGrpMemRole gInfo' m'' memId memRole msg brokerTs
XGrpMemRole memId memRole memberKey rosterVer -> fmap ctx <$> xGrpMemRole gInfo' m'' memId memRole memberKey rosterVer msg brokerTs
XGrpMemRestrict memId memRestrictions -> fmap ctx <$> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs
XGrpMemCon memId -> Nothing <$ xGrpMemCon gInfo' m'' memId
XGrpMemDel memId withMessages -> case encoding @e of
SJson -> fmap ctx <$> xGrpMemDel gInfo' m'' memId withMessages verifiedMsg msg brokerTs False
XGrpMemDel memId withMessages rosterVer -> case encoding @e of
SJson -> fmap ctx <$> xGrpMemDel gInfo' m'' memId withMessages rosterVer verifiedMsg msg brokerTs False
SBinary -> pure Nothing
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' msg
XGrpRoster gr -> fmap ctx <$> xGrpRoster gInfo' m'' m'' gr verifiedMsg sharedMsgId_ brokerTs
XGrpRosterAck ackVer ackErr -> Nothing <$ xGrpRosterAck gInfo' m'' ackVer ackErr
-- 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 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
BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup gInfo' sharedMsgId chunk msgMeta
BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup gInfo' m'' sharedMsgId chunk msgMeta
_ -> Nothing <$ messageError ("unsupported message: " <> tshow event)
forM deliveryTaskContext_ $ \taskContext -> do
let contentChanged :: CM ()
@@ -1143,7 +1170,9 @@ processAgentMessageConn cxt 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 gInfo m conn
when continued $ do
when (isUserGrpFwdRelay gInfo) $ serveRoster user gInfo m -- roster ahead of the resumed backlog
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
@@ -1195,9 +1224,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
CFGetRelayDataJoin -> do
-- Update relay member with key, memberId and profile from link
relayLinkData_ <- liftIO $ decodeLinkUserData cData
case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) ->
relayMemberId <- case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) -> do
withStore $ \db -> updateRelayMemberData db cxt user m (MemberId entityId) (MemberKey relayKey) p
pure $ MemberId entityId
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
case cReq of
CRContactUri crData@ConnReqUriData {crClientData} -> do
@@ -1210,13 +1240,9 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
cReqHash = contactCReqHash $ CRContactUri crData {crScheme = SSSimplex}
-- Update connection with data derived from cReq, now available after getConnShortLinkAsync
withStore' $ \db -> updateConnLinkData db user conn cReq cReqHash groupLinkId chatV pqSup
let GroupMember {memberId = membershipMemId} = membership
incognitoProfile = incognitoMembershipProfile gInfo
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
memberPubKey <- case groupKeys gInfo of
Just GroupKeys {memberPrivKey} -> pure $ C.publicKey memberPrivKey
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
dm <- encodeConnInfo $ XMember profileToSend membershipMemId (MemberKey memberPubKey)
let incognitoProfile = fromLocalProfile <$> incognitoMembershipProfile gInfo
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo incognitoProfile
dm <- encodeXMemberConnInfo gInfo relayMemberId profileToSend
subMode <- chatReadVar subscriptionMode
void $ joinAgentConnectionAsync user (Just conn) True cReq dm subMode
CFGetRelayDataAccept -> do
@@ -1226,7 +1252,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
relayProfile <- liftIO (decodeLinkUserData cData) >>= \case
Just RelayShortLinkData {relayProfile = p} -> pure p
Nothing -> throwChatError $ CEException "relay link: no relay link data"
(confId, m', relay) <- withStore $ \db -> do
(confId, m', relay) <- withStore $ \db -> do
confId <- getRelayConfId db m
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
@@ -1239,7 +1265,9 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
QCONT -> do
continued <- continueSending connEntity conn
when continued $ sendPendingGroupMessages user gInfo m conn
when continued $ do
when (isUserGrpFwdRelay gInfo) $ serveRoster user gInfo m -- roster ahead of the resumed backlog
sendPendingGroupMessages user gInfo m conn
MWARN msgId err -> do
withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSWarning $ agentSndError err)
processConnMWARN connEntity conn err
@@ -1312,13 +1340,18 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
r n'' = Just (ci, CIRcvDecryptionError mde n'')
mdeUpdatedCI _ _ = Nothing
receiveFileChunk :: RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
receiveFileChunk ft@RcvFileTransfer {fileId, chunkSize} conn_ meta@MsgMeta {recipient = (msgId, _), integrity} = \case
FileChunkCancel ->
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft
ci <- withStore $ \db -> getChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileSndCancelled user ci ft
receiveFileChunk :: Maybe GroupInfo -> RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
receiveFileChunk gInfo_ ft@RcvFileTransfer {fileId, fileType, chunkSize} conn_ MsgMeta {recipient = (msgId, _), integrity} = \case
FileChunkCancel -> case fileType of
-- cancel only this source's transfer; other relays' in-flight transfers are independent
FTRoster -> do
t_ <- withStore' $ \db -> getRosterTransfer db fileId
forM_ t_ $ \RcvRosterTransfer {rosterTransferId} -> cleanupRosterTransferById rosterTransferId
FTNormal ->
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft
ci <- withStore $ \db -> getChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileSndCancelled user ci ft
FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of
MsgOk -> pure ()
@@ -1329,30 +1362,33 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
RcvChunkOk ->
if B.length chunk /= fromInteger chunkSize
then badRcvFileChunk ft "incorrect chunk size"
else withAckMessage' "file msg" agentConnId meta $ appendFileChunk ft chunkNo chunk False
else appendFileChunk ft chunkNo chunk False
RcvChunkFinal ->
if B.length chunk > fromInteger chunkSize
then badRcvFileChunk ft "incorrect chunk size"
else do
appendFileChunk ft chunkNo chunk True
ci <- withStore $ \db -> do
liftIO $ do
updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete
deleteRcvFileChunks db ft
getChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileComplete user ci
mapM_ (deleteAgentConnectionAsync . aConnId) conn_
RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure ()
case fileType of
FTRoster -> forM_ gInfo_ $ \gInfo -> rosterCompletion gInfo ft
FTNormal -> do
ci <- withStore $ \db -> do
liftIO $ do
updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete
deleteRcvFileChunks db ft
getChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileComplete user ci
mapM_ (deleteAgentConnectionAsync . aConnId) conn_
RcvChunkDuplicate -> pure ()
RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
processContactConnMessage :: AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM ()
processContactConnMessage agentMsg connEntity conn UserContact {userContactLinkId = uclId, groupId = ucGroupId_} = case agentMsg of
REQ invId pqSupport _ connInfo -> do
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
(signedMsg_, 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 joiningMemberKey -> memberJoinRequestViaRelay invId chatVRange p joiningMemberId joiningMemberKey
XMember p joiningMemberId joiningMemberKey viaRelay -> memberJoinRequestViaRelay invId chatVRange signedMsg_ p joiningMemberId joiningMemberKey viaRelay
XInfo p -> profileContactRequest invId chatVRange p Nothing Nothing Nothing pqSupport
XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv
XGrpRelayTest challenge _ -> xGrpRelayTest invId chatVRange challenge
@@ -1364,13 +1400,13 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
CFSetShortLink ->
case (ucGroupId_, auData) of
(Just groupId, UserContactLinkData UserContactData {relays = relayLinks}) -> do
(gInfo, gLink, relays, relaysChanged, newlyActiveLinks) <- withStore $ \db -> do
(gInfo, gLink, relays, relaysChanged, newlyActiveLinks, newlyActiveGMIds) <- withStore $ \db -> do
gInfo <- getGroupInfo db cxt user groupId
gLink <- getGroupLink db user gInfo
relays <- liftIO $ getGroupRelays db gInfo
(relays', changed, newlyActive) <- liftIO $ foldrM (updateRelay db) ([], False, []) relays
(relays', changed, newlyActiveLinks, newlyActiveGMIds) <- liftIO $ foldrM (updateRelay db) ([], False, [], []) relays
liftIO $ setGroupInProgressDone db gInfo
pure (gInfo, gLink, relays', changed, newlyActive)
pure (gInfo, gLink, relays', changed, newlyActiveLinks, newlyActiveGMIds)
toView $ CEvtGroupLinkDataUpdated user gInfo gLink relays relaysChanged
let GroupSummary {publicMemberCount} = groupSummary gInfo
-- Owner is counted in publicMemberCount; > 1 means at least one subscriber.
@@ -1388,14 +1424,16 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
unless (null recipients) $
void $ sendGroupMessages user gInfo Nothing False recipients events
where
updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool, [ShortLinkContact]) -> IO ([GroupRelay], Bool, [ShortLinkContact])
updateRelay db relay@GroupRelay {relayLink, relayStatus} (acc, changed, newlyActive) =
updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool, [ShortLinkContact], [GroupMemberId]) -> IO ([GroupRelay], Bool, [ShortLinkContact], [GroupMemberId])
updateRelay db relay@GroupRelay {groupMemberId, relayLink, relayStatus} (acc, changed, newlyActiveLinks, newlyActiveGMIds) =
case relayLink of
Just rLink
| rLink `elem` relayLinks && relayStatus == RSAccepted -> do
-- version is gated upstream at publish (getPublishableGroupRelays): an RSAccepted relay
-- whose link is in the published data is necessarily pre-roster, so activate it too
| rLink `elem` relayLinks && (relayStatus == RSAcknowledgedRoster || relayStatus == RSAccepted) -> do
relay' <- updateRelayStatus db relay RSActive
pure (relay' : acc, True, rLink : newlyActive)
| rLink `elem` relayLinks -> pure (relay : acc, changed, newlyActive)
pure (relay' : acc, True, rLink : newlyActiveLinks, groupMemberId : newlyActiveGMIds)
| rLink `elem` relayLinks -> pure (relay : acc, changed, newlyActiveLinks, newlyActiveGMIds)
| relayStatus == RSActive -> do
-- Relay link absent from link data — deactivate.
-- RSAccepted relays are not deactivated: their own link data update
@@ -1404,8 +1442,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
-- TODO the SMP server, but this owner won't receive a LINK callback for it
-- TODO (LINK only fires in response to own setConnShortLink calls).
relay' <- updateRelayStatus db relay RSInactive
pure (relay' : acc, True, newlyActive)
_ -> pure (relay : acc, changed, newlyActive)
pure (relay' : acc, True, newlyActiveLinks, newlyActiveGMIds)
_ -> pure (relay : acc, changed, newlyActiveLinks, newlyActiveGMIds)
_ -> throwChatError $ CECommandError "LINK event expected for a group link only"
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
MERR _ err -> do
@@ -1446,12 +1484,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
-- they will be updated after connection is accepted.
upsertDirectRequestItem cd (requestMsg_, prevSharedMsgId_)
Nothing -> do
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart)
let e2eContent = CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ Just $ CR.pqSupportToEnc $ reqPQSup
void $ createChatItem user cd False e2eContent Nothing Nothing
void $ createChatItem user cd False e2eContent Nothing Nothing Nothing
void $ createFeatureEnabledItems_ user ct
forM_ (autoReply addressSettings) $ \mc -> forM_ welcomeSharedMsgId $ \sharedMsgId ->
createChatItem user (CDDirectSnd ct) False (CISndMsgContent mc) (Just sharedMsgId) Nothing
createChatItem user (CDDirectSnd ct) False (CISndMsgContent mc) (Just sharedMsgId) Nothing Nothing
mapM (createRequestItem cd) requestMsg_
case autoAccept of
Nothing -> do
@@ -1476,13 +1514,13 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
-- they will be updated after connection is accepted.
upsertBusinessRequestItem cd (requestMsg_, prevSharedMsgId_)
Nothing -> do
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
-- TODO [short links] possibly, we can just keep them created where they are created on the business side due to auto-accept
-- let e2eContent = CIRcvGroupE2EEInfo $ E2EInfo $ Just False -- no PQ encryption in groups
-- void $ createChatItem user cd False e2eContent Nothing Nothing
-- void $ createChatItem user cd False e2eContent Nothing Nothing Nothing
-- void $ createFeatureEnabledItems_ user ct
forM_ (autoReply addressSettings) $ \arMC -> forM_ welcomeSharedMsgId $ \sharedMsgId ->
createChatItem user (CDGroupSnd gInfo Nothing) False (CISndMsgContent arMC) (Just sharedMsgId) Nothing
createChatItem user (CDGroupSnd gInfo Nothing) False (CISndMsgContent arMC) (Just sharedMsgId) Nothing Nothing
mapM (createRequestItem cd) requestMsg_
toView $ CEvtAcceptingBusinessRequest user gInfo
where
@@ -1546,7 +1584,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
upsertBusinessRequestItem (CDChannelRcv _ _) = const $ pure Nothing
createRequestItem :: ChatTypeI c => ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
createRequestItem cd (sharedMsgId, mc) = do
aci <- createChatItem user cd False (CIRcvMsgContent mc) (Just sharedMsgId) Nothing
aci <- createChatItem user cd False (CIRcvMsgContent mc) (Just sharedMsgId) Nothing Nothing
toView $ CEvtNewChatItems user [aci]
pure aci
upsertRequestItem :: ChatTypeI c => ChatDirection c 'MDRcv -> ((SharedMsgId, MsgContent) -> CM (Maybe AChatItem)) -> (SharedMsgId -> CM ()) -> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId) -> CM (Maybe AChatItem)
@@ -1574,7 +1612,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
messageError "processContactConnMessage: chat version range incompatible for accepting group join request"
| otherwise -> do
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode Nothing
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode Nothing Nothing
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem'
@@ -1613,19 +1651,37 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
where
User {userChatRelay} = user
-- 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 -> MemberKey -> CM ()
memberJoinRequestViaRelay invId chatVRange p joiningMemberId joiningMemberKey = do
memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Maybe SignedMsg -> Profile -> MemberId -> MemberKey -> Maybe MemberId -> CM ()
memberJoinRequestViaRelay invId chatVRange signedMsg_ p joiningMemberId joiningMemberKey@(MemberKey joiningKey) viaRelay = do
(_ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId
case gLinkInfo_ of
Just GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p Nothing (Just joiningMemberId) Nothing GAAccepted gLinkMemRole Nothing (Just joiningMemberKey)
existing_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberByMemberId db cxt user gInfo joiningMemberId)
case existing_ of
Just rosterMem
-- a privileged memberId's key is owner-authoritative (the roster); the joiner must prove
-- possession of that exact key, otherwise this is an attempt to impersonate it
| isRosterRole (memberRole' rosterMem) ->
if verifyKey gInfo rosterMem
then acceptJoin gInfo (Just rosterMem) (memberRole' rosterMem)
else messageError "memberJoinRequestViaRelay: rejected join claiming privileged memberId (key mismatch or invalid signature)"
_ -> acceptJoin gInfo Nothing gLinkMemRole
Nothing ->
messageError "memberJoinRequestViaRelay: no group link info for relay link"
where
-- replay defense: the viaRelay == own memberId check (viaRelay is in the signed body); without it a sibling relay could replay a privileged member's signed join
verifyKey gInfo rosterMem = case (signedMsg_, groupKeys gInfo) of
(Just SignedMsg {chatBinding = CBGroup, signatures, signedBody}, Just GroupKeys {publicGroupId}) ->
memberPubKey rosterMem == Just joiningKey
&& verifyGroupSig joiningKey publicGroupId joiningMemberId signatures signedBody
&& viaRelay == Just (memberId' (membership gInfo))
_ -> False
acceptJoin gInfo existingMem_ acceptRole = do
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p Nothing (Just joiningMemberId) Nothing GAAccepted acceptRole Nothing (Just joiningMemberKey) existingMem_
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem'
Nothing ->
messageError "memberJoinRequestViaRelay: no group link info for relay link"
muteEventInChannel :: GroupInfo -> GroupMember -> Bool
muteEventInChannel gInfo@GroupInfo {membership} m =
@@ -2157,7 +2213,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
unless (maybe False memberBlocked m') $ autoAcceptFile file_
processFileInv gInfo' m' =
let fileMember_ = if sentAsGroup then Nothing else m'
in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_
in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_ FTNormal sharedMsgId_
newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed live = do
let mentions' = if maybe False memberBlocked m' then M.empty else mentions
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed live mentions'
@@ -2365,7 +2421,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
ChatConfig {fileChunkSize} <- asks config
fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv
inline <- receiveInlineMode fInv' Nothing fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) fInv' inline fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) FTNormal sharedMsgId_ fInv' inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
@@ -2461,10 +2517,17 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
ft <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId >>= getRcvFileTransfer db user
receiveInlineChunk ft chunk meta
bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunkGroup GroupInfo {groupId} sharedMsgId chunk meta = do
ft <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId >>= getRcvFileTransfer db user
receiveInlineChunk ft chunk meta
-- A group BFileChunk is a normal inline file chunk or a roster blob chunk, both located by
-- (group_id, shared_msg_id). A chunk matching no in-flight transfer (an orphaned re-served roster
-- chunk, or a missing normal file) is ignored; the outer withAckMessage acks it.
bFileChunkGroup :: GroupInfo -> GroupMember -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunkGroup gInfo@GroupInfo {groupId} fromMember sharedMsgId chunk meta = do
fileId_ <- withStore' $ \db -> getGroupRcvFileId db userId groupId (groupMemberId' fromMember) sharedMsgId
forM_ fileId_ $ \fileId -> do
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
case fileType ft of
FTRoster -> receiveRosterChunk gInfo ft meta chunk
FTNormal -> receiveInlineChunk ft chunk meta
receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> CM ()
receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _
@@ -2474,7 +2537,18 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
case chunk of
FileChunk {chunkNo} -> when (chunkNo == 1) $ startReceivingFile user fileId
_ -> pure ()
receiveFileChunk ft Nothing meta chunk
receiveFileChunk Nothing ft Nothing meta chunk
-- A roster re-serve re-sends the blob from chunk 1; discard any partial first, else chunk 1 over a
-- partial is out-of-order (RcvChunkError) and appending after the stale prefix corrupts the blob.
receiveRosterChunk :: GroupInfo -> RcvFileTransfer -> MsgMeta -> FileChunk -> CM ()
receiveRosterChunk gInfo ft meta chunk = do
case chunk of
FileChunk {chunkNo} | chunkNo == 1 -> do
last_ <- withStore' $ \db -> getRcvFileLastChunkNo db ft
when (isJust last_) $ resetRosterPartialChunks ft
_ -> pure ()
receiveFileChunk (Just gInfo) ft Nothing meta chunk
xFileCancelGroup :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> CM (Maybe DeliveryTaskContext)
xFileCancelGroup g@GroupInfo {groupId} m_ sharedMsgId = do
@@ -2532,7 +2606,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
if sameGroupLinkId groupLinkId groupLinkId'
then do
@@ -2996,40 +3070,63 @@ processAgentMessageConn cxt 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
if useRelays' gInfo && isRelay m
then when (memRole > GRMember) $ throwChatError $ CEException "x.grp.mem.new: relay cannot introduce role above member in channel"
else checkHostRole m memRole
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _ assertedKey_) msgScope_ msg brokerTs = do
let fromRelay = useRelays' gInfo && isRelay m
unless fromRelay $ checkHostRole m memRole
if sameMemberId memId (membership gInfo)
then pure Nothing
else do
else
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do
(updatedMember, gInfo') <- withStore $ \db -> do
updatedMember <- updateUnknownMemberAnnounced db cxt user m unknownMember memInfo initialStatus
gInfo' <-
if memberPending updatedMember
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
else pure gInfo
pure (updatedMember, gInfo')
gInfo'' <- updatePublicGroupData user gInfo'
toView $ CEvtUnknownMemberAnnounced user gInfo'' m unknownMember updatedMember
memberAnnouncedToView updatedMember gInfo''
pure $ deliveryJobScope updatedMember
Right unknownMember@GroupMember {memberStatus = GSMemUnknown}
-- roster-established privileged member: the relay may update the profile only,
-- never the role or key (those are owner-authoritative via the roster, and
-- XGrpMemNew is unsigned)
| fromRelay && isRosterRole (memberRole' unknownMember) -> do
-- a member's key is immutable per memberId and identical across relays; mismatch
-- is unambiguous relay misbehavior (role can legitimately differ across relays
-- under multi-relay skew, so we deliberately don't warn on role)
let assertedKey = (\(MemberKey k) -> k) <$> assertedKey_
-- TODO [relays] member: surface relay-key-mismatch as a dedicated event / chat item / relay state
when (assertedKey /= memberPubKey unknownMember) $
messageWarning $ "x.grp.mem.new: relay asserted key differs from roster-established key, keeping roster key, memberId=" <> safeDecodeUtf8 (strEncode memId)
updatedMember <- withStore $ \db -> updateRosterMemberAnnounced db cxt user m unknownMember memInfo initialStatus
-- roster members can't be pending, so no members-require-attention update
gInfo' <- updatePublicGroupData user gInfo
toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember
memberAnnouncedToView updatedMember gInfo'
pure $ deliveryJobScope updatedMember
-- asserted privileged but NOT roster-established: relay conjuring a moderator
| fromRelay && isRosterRole memRole ->
messageError "x.grp.mem.new: privileged role not established by roster" $> Nothing
| otherwise -> do
(updatedMember, gInfo') <- withStore $ \db -> do
updatedMember <- updateUnknownMemberAnnounced db cxt user m unknownMember memInfo initialStatus
gInfo' <-
if memberPending updatedMember
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
else pure gInfo
pure (updatedMember, gInfo')
gInfo'' <- updatePublicGroupData user gInfo'
toView $ CEvtUnknownMemberAnnounced user gInfo'' m unknownMember updatedMember
memberAnnouncedToView updatedMember gInfo''
pure $ deliveryJobScope updatedMember
Right _
| useRelays' gInfo -> logInfo "x.grp.mem.new: member already created via another relay" $> Nothing
| otherwise -> messageError "x.grp.mem.new error: member already exists" $> Nothing
Left _ -> do
(newMember, gInfo') <- withStore $ \db -> do
newMember <- createNewGroupMember db cxt user gInfo m memInfo GCPostMember initialStatus
gInfo' <-
if memberPending newMember
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
else pure gInfo
pure (newMember, gInfo')
gInfo'' <- updatePublicGroupData user gInfo'
memberAnnouncedToView newMember gInfo''
pure $ deliveryJobScope newMember
Left _
-- a privileged member absent from the roster is a relay conjuring a moderator
| fromRelay && isRosterRole memRole -> messageError "x.grp.mem.new: privileged member not established by roster" $> Nothing
| otherwise -> do
(newMember, gInfo') <- withStore $ \db -> do
newMember <- createNewGroupMember db cxt user gInfo m memInfo GCPostMember initialStatus
gInfo' <-
if memberPending newMember
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
else pure gInfo
pure (newMember, gInfo')
gInfo'' <- updatePublicGroupData user gInfo'
memberAnnouncedToView newMember gInfo''
pure $ deliveryJobScope newMember
where
initialStatus = case msgScope_ of
Just (MSMember _) -> GSMemPendingReview
@@ -3068,10 +3165,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
messageError "x.grp.mem.intro ignored: member already exists"
Left _
| useRelays' gInfo -> do
-- owner key must only come from link data, not from relay intro
-- role + key are owner-authoritative (roster); an intro establishes neither - a privileged
-- claim is created at the channel default with no key until the owner-signed roster confirms it
defaultRole <- unknownMemberRole gInfo
let memInfo' = case memInfo of
MemberInfo mId mRole v p _
| mRole == GROwner -> MemberInfo mId mRole v p Nothing
| mRole >= GRMember -> MemberInfo mId defaultRole v p Nothing
_ -> memInfo
void $ withStore $ \db -> createIntroReMember db cxt user gInfo memInfo' memRestrictions
| otherwise -> do
@@ -3141,28 +3240,241 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
chatV = vr cxt `peerConnChatVersion` mcvr
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@RcvMessage {msgSigned} brokerTs
-- rollback defense (channels): apply an owner-signed role/removal only at a version >= the persisted
-- roster_version (not the batch-constant gInfo, which a relay can stale by reordering events in one
-- batch), then advance it in the same transaction; a strictly lower version is a replay and is ignored.
-- Only an owner sender may advance it: a non-owner signed event is rejected by the action that follows,
-- but must not bump roster_version first, or every later owner roster at a lower version is dropped.
applyAtRosterVersion :: GroupInfo -> GroupMember -> Maybe VersionRoster -> CM (Maybe DeliveryJobScope) -> CM (Maybe DeliveryJobScope)
applyAtRosterVersion gInfo sender rosterVer_ action
| not (useRelays' gInfo) = action
| otherwise = case rosterVer_ of
Nothing -> action
Just _ | memberRole' sender /= GROwner -> action
Just v -> do
accept <- withStore' $ \db -> do
cur <- getGroupRosterVersion db gInfo
let fresh = maybe True (v >=) cur
when fresh $ setGroupRosterVersion db gInfo v
pure fresh
if accept
then action
else messageWarning "x.grp.mem: roster version not newer than current, ignoring" $> Nothing
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> Maybe MemberKey -> Maybe VersionRoster -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole memberKey_ rosterVer_ msg@RcvMessage {msgSigned} brokerTs
| membershipMemId == memId =
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
in changeMemberRole gInfo' membership $ RGEUserRole memRole
| otherwise =
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
Left _ -> messageError "x.grp.mem.role with unknown member ID" $> Nothing
applyAtRosterVersion gInfo m rosterVer_ $
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
in changeMemberRole gInfo' membership False (\db -> updateGroupMemberRole db user membership memRole) $ RGEUserRole memRole
| otherwise = applyAtRosterVersion gInfo m rosterVer_ $ do
defaultRole <- unknownMemberRole gInfo
-- an owner-signed event with a key TOFU-creates an unknown member only for a roster role; else a plain lookup
let allowCreate = useRelays' gInfo && senderRole == GROwner && isRosterRole memRole && isJust memberKey_
withStore' (\db -> runExceptT $ getCreateUnknownGMByMemberId db cxt user gInfo memId (nameFromMemberId memId) defaultRole allowCreate) >>= \case
Right (Just (member, created))
-- just created (keyless, and allowCreate ensured the event carries its key): pin key + role
| created, Just (MemberKey pubKey) <- memberKey_ ->
let gEvent = RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
in changeMemberRole gInfo member created (\db -> void $ applyMemberKeyRole db member pubKey memRole) gEvent
-- known member: apply the role (its key is established via roster/intro; the event's key is ignored)
| otherwise ->
let gEvent = RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
in changeMemberRole gInfo member created (\db -> updateGroupMemberRole db user member memRole) gEvent
-- in relay groups the roster may deliver role update for previously-unknown privileged members
_ | useRelays' gInfo -> pure Nothing
| otherwise -> messageError "x.grp.mem.role with unknown member ID" $> Nothing
where
GroupMember {memberId = membershipMemId} = membership
changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent
-- applyMember writes the change (role, or role + pinned key for a freshly TOFU-created member);
-- the delivery scope (relay forwarding) is computed on the pre-change role
changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} created applyMember gEvent
| senderRole < maximum ([GRAdmin, fromRole, memRole] :: [GroupMemberRole]) =
messageError "x.grp.mem.role with insufficient member permissions" $> Nothing
| useRelays' gInfo && (isRosterRole memRole || isRosterRole fromRole) && senderRole /= GROwner =
messageError "x.grp.mem.role: only the owner can change member, moderator and admin roles in relay groups" $> Nothing
-- a forwarded role event the roster already applied is a no-op; suppress it.
-- a just-created member is keyless here, so fall through to pin its owner-attested key.
| useRelays' gInfo && not created && fromRole == memRole = pure $ memberEventDeliveryScope member
| otherwise = do
withStore' $ \db -> updateGroupMemberRole db user member memRole
withStore' applyMember
(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, msgSigned}
pure $ memberEventDeliveryScope member
-- The header only starts the transfer; the roster is applied and the version bumped only at
-- blob completion, so a withheld or corrupted blob leaves the last good roster intact.
-- fromMember is the relay that delivered THIS roster copy (the owner on a relay receiving directly,
-- a relay on a member receiving a forward); author is the owner who signed it.
xGrpRoster :: GroupInfo -> GroupMember -> GroupMember -> GroupRoster -> VerifiedMsg e -> Maybe SharedMsgId -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpRoster gInfo fromMember author GroupRoster {version = newVer, fileInv = InlineFileInvitation {fileSize, fileDigest}} verifiedMsg sharedMsgId_ brokerTs
-- only an owner may sign a roster; otherwise a relay could route it as a member whose key it controls
| memberRole' author /= GROwner = messageError "x.grp.roster: not signed by an owner" $> Nothing
| fileSize > maxGroupRosterBytes = messageError "x.grp.roster: roster blob size exceeds limit" $> Nothing
| otherwise = case verifiedMsg of
-- unreachable: XGrpRoster is in requiresSignature, so withVerifiedMsg rejected unsigned
VMUnsigned _ -> pure Nothing
VMSigned _ sm _ -> case sharedMsgId_ of
Nothing -> Nothing <$ messageWarning "x.grp.roster: missing shared message id"
Just sharedMsgId -> do
-- per-source pending version (THIS relay's own in-flight transfer), not a single group slot
pendingVer_ <- withStore' $ \db -> getRosterTransferVersion db gInfo (groupMemberId' fromMember)
-- accept a version not below BOTH applied and this source's pending (>=, Nothing below 0): a preceding
-- signed event may have already advanced rosterVersion to this blob's version; a lower one is a downgrade.
if newVer `notBelowRoster` rosterVersion gInfo && newVer `notBelowRoster` pendingVer_
then startRosterTransfer sm sharedMsgId
else pure Nothing
where
startRosterTransfer sm sharedMsgId = do
-- supersede THIS source's own in-flight transfer (older version or a restart); other relays' transfers are independent
cleanupRosterTransfer gInfo (groupMemberId' fromMember)
let relayHdr = if isUserGrpFwdRelay gInfo then Just sm else Nothing
chSize <- asks $ fileChunkSize . config
let rosterFInv = FileInvitation {fileName = "roster", fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Just IFMSent, fileDescr = Nothing}
-- transfer record + its scratch file in one transaction (file owned by the transfer, keyed per source)
rft@RcvFileTransfer {fileId} <- withStore $ \db -> do
transferId <- liftIO $ createRosterTransfer db gInfo (groupMemberId' fromMember) newVer fileDigest (groupMemberId' author) brokerTs relayHdr
createRosterRcvFile db userId gInfo fromMember transferId sharedMsgId rosterFInv (Just IFMSent) (fromIntegral chSize)
-- accept the chat-item-free file before chunk 1 (FIFO before it) so chunk 1 isn't rejected on RFSNew
-- transient scratch file (consumed into roster_blob, then deleted): temp folder, not the user's files folder / Downloads
tmpDir <- lift getChatTempDirectory
rosterTs <- liftIO getCurrentTime
let GroupInfo {groupId = gId} = gInfo
rosterFile = "roster_" <> show gId <> "_" <> show (groupMemberId' fromMember) <> "_" <> formatTime defaultTimeLocale "%Y%m%d_%H%M%S" rosterTs
filePath <- getRcvFilePath fileId (Just tmpDir) rosterFile False
withStore' $ \db -> startRcvInlineFT db user rft filePath (Just IFMSent)
pure Nothing
-- Roster version comparison treating Nothing (un-materialized) as below 0. Non-strict (>=) so a relay
-- accepts the owner's blob at the version a preceding signed event already advanced rosterVersion to.
notBelowRoster :: VersionRoster -> Maybe VersionRoster -> Bool
notBelowRoster v = maybe True (v >=)
-- Blob arrived: verify the owner-attested digest over the plaintext and guard against
-- downgrade before applying; on a relay, ack the owner and re-serve to members.
rosterCompletion :: GroupInfo -> RcvFileTransfer -> CM ()
rosterCompletion gInfo RcvFileTransfer {fileId, fileStatus} =
withStore' (\db -> getRosterTransfer db fileId) >>= \case
-- defensive: the file always has its transfer (created together, deleted together)
Nothing -> lift (closeFileHandle fileId rcvFiles) >> forM_ (rosterFilePath fileStatus) removeFsFile
Just RcvRosterTransfer {rosterTransferId = transferId, rosterTransferVersion = pendingVer, rosterTransferDigest = pendingDigest, rosterTransferOwnerGMId = ownerGMId, rosterTransferBrokerTs = rosterBrokerTs, rosterTransferHeader = header_} -> do
owner_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberById db cxt user ownerGMId)
blob <- readAssembledRoster
let isRelay = isUserGrpFwdRelay gInfo
ackErr err = do
cleanupRosterTransferById transferId
when isRelay $ forM_ owner_ $ \owner -> sendRosterAck gInfo owner pendingVer (Just err)
if FD.FileDigest (LC.sha512Hash (LB.fromStrict blob)) /= pendingDigest
then ackErr "relay could not verify the roster blob"
else case parseAll rosterBlobP blob of
Left _ -> ackErr "relay could not parse the roster blob"
Right entries -> case owner_ of
Nothing -> cleanupRosterTransferById transferId
Just author -> do
defaultRole <- unknownMemberRole gInfo
-- gate against the persisted roster_version inside the apply transaction: a roster from another
-- relay (or a preceding signed event) may already have advanced it past this one; a stale
-- completion (e.g. relay1 sent v5 then v6, relay2's v5 completes after v6) is rejected.
results_ <- withStore $ \db -> do
cur <- liftIO $ getGroupRosterVersion db gInfo
if maybe False (pendingVer <) cur
then pure Nothing
else do
res <- processRosterEntries db gInfo defaultRole (validateGroupRoster entries)
liftIO $ setGroupLiveRoster db gInfo pendingVer ownerGMId rosterBrokerTs header_ blob
pure (Just res)
cleanupRosterTransferById transferId
forM_ results_ $ \results -> do
emitRosterResults gInfo author rosterBrokerTs results
-- ack while setting up (own status accepted/acknowledged); a serving (active) relay must not ack broadcasts.
when (isRelay && (relayOwnStatus gInfo == Just RSAccepted || relayOwnStatus gInfo == Just RSAcknowledgedRoster)) $ do
sendRosterAck gInfo author pendingVer Nothing
withStore' $ \db -> void $ updateRelayOwnStatusFromTo db gInfo RSAccepted RSAcknowledgedRoster
where
rosterFilePath = \case
RFSAccepted p -> Just p
RFSConnected p -> Just p
RFSComplete p -> Just p
_ -> Nothing
readAssembledRoster = case rosterFilePath fileStatus of
Just fp -> readAt fp
Nothing -> throwChatError $ CEInternalError "roster file not in progress"
readAt fp = lift (toFSFilePath fp) >>= liftIO . B.readFile
-- TOFU-apply an owner-signed (key, role) to a resolved member: pin the key if absent; for a keyed
-- member keep the trusted key (Left = reject a different one), else update the role. Right
-- (Just (member-at-new-role, fromRole)) when the role changed, Right Nothing when already current.
applyMemberKeyRole :: DB.Connection -> GroupMember -> C.PublicKeyEd25519 -> GroupMemberRole -> IO (Either MemberId (Maybe (GroupMember, GroupMemberRole)))
applyMemberKeyRole db m pubKey role = case memberPubKey m of
Just k
| k /= pubKey -> pure (Left (memberId' m))
| memberRole' m == role -> pure (Right Nothing)
| otherwise -> updateGroupMemberRole db user m role $> Right (Just (m {memberRole = role}, memberRole' m))
Nothing -> setGroupMemberKeyRole db m pubKey role $> Right (Just (m {memberRole = role}, memberRole' m))
-- TOFU apply: pin each member's key on first use, then update roles.
processRosterEntries :: DB.Connection -> GroupInfo -> GroupMemberRole -> [RosterMember] -> ExceptT StoreError IO ([MemberId], [(GroupMember, GroupMemberRole, Bool)])
processRosterEntries db gInfo defaultRole entries = do
let rosterIds = map (\RosterMember {memberId} -> memberId) entries
(cs, as) <- foldrM applyRosterEntry ([], []) entries
currentPriv <- liftIO $ getGroupRosterMembers db cxt user gInfo
reverted <- liftIO $ fmap catMaybes $ forM currentPriv $ \m ->
if memberId' m `notElem` rosterIds
then updateGroupMemberRole db user m defaultRole $> Just ((m :: GroupMember) {memberRole = defaultRole}, memberRole' m, False)
else pure Nothing
pure (cs, as <> reverted)
where
-- entry-level failure (StoreError or IO exception) is muted; the entry is dropped
applyRosterEntry RosterMember {memberId, key = MemberKey pubKey, role} (cs, as) =
( getCreateUnknownGMByMemberId db cxt user gInfo memberId (nameFromMemberId memberId) defaultRole True >>= \case
Nothing -> pure (cs, as)
Just (m, created) -> liftIO (applyMemberKeyRole db m pubKey role) >>= \case
Left mid -> pure (mid : cs, as)
Right Nothing -> pure (cs, as)
Right (Just (rm, fromR)) -> pure (cs, (rm, fromR, created) : as)
)
`catchAllErrors` \_ -> pure (cs, as)
emitRosterResults :: GroupInfo -> GroupMember -> UTCTime -> ([MemberId], [(GroupMember, GroupMemberRole, Bool)]) -> CM ()
emitRosterResults gInfo author rosterBrokerTs (conflicts, applied) = do
forM_ conflicts $ \mid' ->
messageWarning $ "x.grp.roster: member key conflict, keeping trusted key, memberId=" <> safeDecodeUtf8 (strEncode mid')
forM_ applied $ \(member, fromRole, created) ->
unless created $ createItems member fromRole
where
createItems member fromRole = do
let toRole = memberRole' member
gEvent = RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) toRole
(gInfo', author', scopeInfo) <- mkGroupChatScope gInfo author
ci <- createChatItem user (CDGroupRcv gInfo' scopeInfo author') False (CIRcvGroupEvent gEvent) Nothing (Just MSSVerified) (Just rosterBrokerTs)
toView $ CEvtNewChatItems user [ci]
toView CEvtMemberRole {user, groupInfo = gInfo', byMember = author', member, fromRole, toRole, msgSigned = Just MSSVerified}
sendRosterAck :: GroupInfo -> GroupMember -> VersionRoster -> Maybe Text -> CM ()
sendRosterAck gInfo owner ackVer err = void $ sendGroupMessage' user gInfo [owner] (XGrpRosterAck ackVer err)
xGrpRosterAck :: GroupInfo -> GroupMember -> VersionRoster -> Maybe Text -> CM ()
xGrpRosterAck gInfo m ackVer err = do
relay_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupRelayByGMId db (groupMemberId' m))
case relay_ of
Just relay@GroupRelay {relayStatus = RSAccepted} -> case err of
Nothing
| rosterVersion gInfo == Just ackVer -> do
(relay', gLink) <- withStore $ \db -> do
relay' <- liftIO $ updateRelayStatus db relay RSAcknowledgedRoster
gLink <- getGroupLink db user gInfo
pure (relay', gLink)
setGroupLinkDataAsync user gInfo gLink
toView $ CEvtGroupRelayUpdated user gInfo m relay'
| otherwise -> messageWarning "x.grp.roster.ack: stale version, awaiting ack for the current roster"
Just e -> do
relay' <- withStore' $ \db -> updateRelayStatusFromTo db relay RSAccepted RSRejected
toView $ CEvtGroupRelayUpdated user gInfo m relay'
messageError $ "x.grp.roster.ack: relay could not save roster, marked rejected: " <> e
_ -> pure ()
checkHostRole :: GroupMember -> GroupMemberRole -> CM ()
checkHostRole GroupMember {memberRole, localDisplayName} memRole =
when (memberRole < GRAdmin || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName)
@@ -3207,11 +3519,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
withStore $ \db -> setMemberVectorRelationConnected db sendingMem refMem MRSubjectConnected
withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> Maybe VersionRoster -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages rosterVer_ verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do
let GroupMember {memberId = membershipMemId} = membership
if membershipMemId == memId
then checkRole membership $ do
then applyAtRosterVersion gInfo m rosterVer_ $ checkRole membership $ do
deleteGroupLinkIfExists user gInfo
-- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False
@@ -3223,7 +3535,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
deleteMemberItem msg gInfo RGEUserDeleted
toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned
pure $ Just DJSGroup {jobSpec = DJRelayRemoved}
else
else applyAtRosterVersion gInfo m rosterVer_ $
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Left _ -> do
messageError "x.grp.mem.del with unknown member ID"
@@ -3474,7 +3786,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
processForwardedMsg :: VerifiedMsg 'Json -> Maybe GroupMember -> CM ()
processForwardedMsg verifiedMsg author_ = do
rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ verifiedMsg brokerTs
forM_ rcvMsg_ $ \rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} -> case event of
forM_ rcvMsg_ $ \rcvMsg@RcvMessage {sharedMsgId_, chatMsgEvent = ACME _ event} -> case event of
XMsgNew mc ->
void $ memberCanSend author_ scope $ newGroupContentMessage gInfo author_ mc rcvMsg msgTs True
where
@@ -3489,13 +3801,14 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
XInfo p -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p rcvMsg msgTs
XGrpRelayNew rl -> withAuthor XGrpRelayNew_ $ \author -> void $ xGrpRelayNew gInfo author rl
XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs
XGrpMemRole memId memRole -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo author memId memRole rcvMsg msgTs
XGrpMemRole memId memRole memberKey rosterVer -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo author memId memRole memberKey rosterVer rcvMsg msgTs
XGrpMemRestrict memId memRestrictions -> withAuthor XGrpMemRestrict_ $ \author -> void $ xGrpMemRestrict gInfo author memId memRestrictions rcvMsg msgTs
XGrpMemDel memId withMessages -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel gInfo author memId withMessages verifiedMsg rcvMsg msgTs True
XGrpMemDel memId withMessages rosterVer -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel gInfo author memId withMessages rosterVer verifiedMsg rcvMsg msgTs True
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' rcvMsg
XGrpRoster gr -> withAuthor XGrpRoster_ $ \author -> void $ xGrpRoster gInfo m author gr verifiedMsg sharedMsgId_ msgTs
_ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event)
where
withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM ()
@@ -3515,12 +3828,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
Just sm@SignedMsg {chatBinding, signatures, signedBody}
| GroupMember {memberPubKey = Just pubKey, memberId} <- member ->
case chatBinding of
CBGroup ->
let prefix = smpEncode chatBinding <> bindingData
bindingData = case groupKeys gInfo of
Just GroupKeys {publicGroupId} -> smpEncode (publicGroupId, memberId)
Nothing -> smpEncode (memberId, pubKey) -- forward compatibility for verifying signed messages in p2p groups
in signed MSSVerified <$ guard (all (\(MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (prefix <> signedBody)) signatures)
CBGroup
| Just GroupKeys {publicGroupId} <- groupKeys gInfo ->
signed MSSVerified <$ guard (verifyGroupSig pubKey publicGroupId memberId signatures signedBody)
| otherwise ->
let prefix = smpEncode chatBinding <> smpEncode (memberId, pubKey) -- forward compatibility for verifying signed messages in p2p groups
in signed MSSVerified <$ guard (all (\case (MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (prefix <> signedBody)) signatures)
_ -> signed MSSSignedNoKey <$ guard signatureOptional
| otherwise -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag)
where
@@ -3782,10 +4095,15 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
bucketSize <- asks $ deliveryBucketSize . config
senders <- withStore' $ \db ->
fmap catMaybes . forM senderGMIds $ \sId ->
fmap eitherToMaybe . runExceptT $ do
fmap (join . eitherToMaybe) . runExceptT $ do
sender <- getNonRemovedMemberById db cxt user sId
vec <- getMemberRelationsVector db sender
pure (sender, vec)
-- owners are already known to every member (group link + owner-intro in introduceInChannel),
-- so we never disseminate their profile (redundant, and races with joins re-announcing the owner)
if memberRole' sender == GROwner
then pure Nothing
else do
vec <- getMemberRelationsVector db sender
pure $ Just (sender, vec)
let missingSenders = length senderGMIds - length senders
when (missingSenders > 0) $
logInfo $ "delivery job " <> tshow jobId <> ": " <> tshow missingSenders <> " senders missing; skipping their profile prepend"
@@ -3795,13 +4113,8 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
if null senders
then pure (body, [], [], [])
else do
-- Skip role > GRMember (mirrors xGrpMemNew gate).
-- TODO [relays] public groups: revisit if mods/admins are introduced via this sidecar.
let (encoderErrs, validLabeled) =
partitionEithers
[ (\bs -> (s, bs)) <$> encodeMemberNew (vr cxt) gInfo s
| (s, _) <- senders, memberRole' s <= GRMember
]
-- all members' profiles disseminate; privileged key/role come from the roster, not here
let (encoderErrs, validLabeled) = partitionEithers [(\bs -> (s, bs)) <$> encodeMemberNew (vr cxt) gInfo s | (s, _) <- senders]
(extBody', inBody, overflowLabeled, large1) = batchProfilesWithBody maxEncodedMsgLength body validLabeled
(overflowBatches', large2) = batchProfiles maxEncodedMsgLength overflowLabeled
packerErrs = [ChatError (CEInternalError $ "oversized profile element for member " <> show (groupMemberId' s)) | s <- large1 <> large2]