mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-10-06 09:58:26 +00:00
core: refactor groups (#7503)
* core: refactor groups * refactor * refactor * refactor * refactor * refactor * rename * refactor * remove * rename * diff * simplify * relay requests * bot types * check useRelays * refactor * query plans --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny
co-authored by
Evgeny @ SimpleX Chat
Evgeny @ SimpleX Chat
parent
c7b3e362ec
commit
c8466b2010
@@ -4,8 +4,7 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Chat.Bot.Store
|
||||
( storeCxt,
|
||||
withDB,
|
||||
( withDB,
|
||||
withDB',
|
||||
)
|
||||
where
|
||||
@@ -20,10 +19,6 @@ import Simplex.Messaging.Agent.Store.Common (withTransaction)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Util (catchAll)
|
||||
|
||||
storeCxt :: ChatController -> StoreCxt
|
||||
storeCxt ChatController {config} = mkStoreCxt config
|
||||
{-# INLINE storeCxt #-}
|
||||
|
||||
withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Either String a)
|
||||
withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
|
||||
|
||||
|
||||
@@ -228,9 +228,9 @@ newWebPreviewState = do
|
||||
|
||||
-- | Builds the read-only context threaded through store functions from chat config.
|
||||
-- The single construction point, so new store-wide config (e.g. server keys) is added in one place.
|
||||
mkStoreCxt :: ChatConfig -> StoreCxt
|
||||
mkStoreCxt ChatConfig {chatVRange, badgePublicKeys} = StoreCxt chatVRange badgePublicKeys
|
||||
{-# INLINE mkStoreCxt #-}
|
||||
storeCxt :: ChatController -> StoreCxt
|
||||
storeCxt ChatController {config = ChatConfig {chatVRange, badgePublicKeys}, random} = StoreCxt chatVRange badgePublicKeys random
|
||||
{-# INLINE storeCxt #-}
|
||||
|
||||
data RandomAgentServers = RandomAgentServers
|
||||
{ smpServers :: NonEmpty (ServerCfg 'PSMP),
|
||||
|
||||
@@ -753,8 +753,8 @@ processChatCommand cxt nm = \case
|
||||
Nothing -> pure ()
|
||||
withGroupLock "sendMessage" chatId $ do
|
||||
(gInfo, cmrs) <- withFastStore $ \db -> do
|
||||
g <- getGroupInfo db cxt user chatId
|
||||
(g,) <$> mapM (composedMessageReqMentions db user g) cms
|
||||
gik@(GIK g _) <- getGroupInfoKeys db cxt user chatId
|
||||
(gik,) <$> mapM (composedMessageReqMentions db user g) cms
|
||||
sendGroupContentMessages user gInfo gsScope asGroup live itemTTL sign cmrs
|
||||
APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do
|
||||
_ <- createChatTag db user emoji text
|
||||
@@ -783,7 +783,7 @@ processChatCommand cxt nm = \case
|
||||
createNoteFolderContentItems user folderId (L.map composedMessageReq cms)
|
||||
APIReportMessage gId reportedItemId reportReason reportText -> withUser $ \user ->
|
||||
withGroupLock "reportMessage" gId $ do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user gId
|
||||
gInfo <- withFastStore $ \db -> getGroupInfoKeys db cxt user gId
|
||||
let mc = MCReport reportText reportReason
|
||||
cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc, mentions = M.empty}
|
||||
sendGroupContentMessages user gInfo (Just $ GCSMemberSupport Nothing) False False Nothing False [composedMessageReq cm]
|
||||
@@ -818,7 +818,7 @@ processChatCommand cxt nm = \case
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
|
||||
CTGroup -> withGroupLock "updateChatItem" chatId $ do
|
||||
gInfo@GroupInfo {groupId, membership} <- withFastStore $ \db -> getGroupInfo db cxt user chatId
|
||||
g@(GIK gInfo@GroupInfo {groupId, membership} _) <- withFastStore $ \db -> getGroupInfoKeys db cxt user chatId
|
||||
when (isNothing scope) $ assertUserGroupRole gInfo GRAuthor
|
||||
let (_, ft_) = msgContentTexts mc
|
||||
if prohibitedSimplexLinks gInfo membership mc ft_
|
||||
@@ -840,7 +840,7 @@ processChatCommand cxt nm = \case
|
||||
mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
|
||||
event = XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) msgScope (Just showGroupAsSender)
|
||||
reuseSign = case msgVerified of Just (MVSigned _) -> True; _ -> False
|
||||
SndMessage {msgId} <- sendGroupMessage user gInfo scope recipients reuseSign event
|
||||
SndMessage {msgId} <- sendGroupMessage user g scope recipients reuseSign event
|
||||
ci' <- withFastStore' $ \db -> do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
when changed $
|
||||
@@ -886,7 +886,7 @@ processChatCommand cxt nm = \case
|
||||
else markDirectCIsDeleted user ct items =<< liftIO getCurrentTime
|
||||
pure $ CRChatItemsDeleted user deletions True False
|
||||
CTGroup -> withGroupLock "deleteChatItem" chatId $ do
|
||||
(gInfo, items) <- getCommandGroupChatItems user chatId itemIds
|
||||
(g@(GIK gInfo _), items) <- getCommandGroupChatItems user chatId itemIds
|
||||
-- TODO [knocking] check scope for all items?
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
deletions <- case mode of
|
||||
@@ -899,14 +899,14 @@ processChatCommand cxt nm = \case
|
||||
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo groupKnockingVersion
|
||||
assertDeletable items
|
||||
assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier
|
||||
let signedEvents = L.nonEmpty $ mapMaybe (delEventSigned gInfo chatScopeInfo False) items
|
||||
mapM_ (sendGroupSignedMessages user gInfo Nothing False recipients) signedEvents
|
||||
let signedEvents = L.nonEmpty $ mapMaybe (delEventSigned g chatScopeInfo False) items
|
||||
mapM_ (sendGroupSignedMessages user g Nothing False recipients) signedEvents
|
||||
delGroupChatItems user gInfo chatScopeInfo items False
|
||||
CIDMHistory -> do
|
||||
unless (publicGroupEditor gInfo (membership gInfo)) $ throwChatError CEInvalidChatItemDelete
|
||||
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo groupKnockingVersion
|
||||
let signedEvents = L.nonEmpty $ mapMaybe (delEventSigned gInfo chatScopeInfo True) items
|
||||
mapM_ (sendGroupSignedMessages user gInfo Nothing False recipients) signedEvents
|
||||
let signedEvents = L.nonEmpty $ mapMaybe (delEventSigned g chatScopeInfo True) items
|
||||
mapM_ (sendGroupSignedMessages user g Nothing False recipients) signedEvents
|
||||
delGroupChatItems user gInfo chatScopeInfo items False
|
||||
pure $ CRChatItemsDeleted user deletions True False
|
||||
CTLocal -> do
|
||||
@@ -929,20 +929,20 @@ processChatCommand cxt nm = \case
|
||||
itemsMsgIds :: [CChatItem c] -> [SharedMsgId]
|
||||
itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId)
|
||||
-- history delete always signs (attributable owner action); self-delete signs iff the target was held signed (deniability)
|
||||
delEventSigned :: GroupInfo -> Maybe GroupChatScopeInfo -> Bool -> CChatItem 'CTGroup -> Maybe (Maybe MsgSigning, ChatMsgEvent 'Json)
|
||||
delEventSigned gInfo chatScopeInfo onlyHistory (CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId, msgVerified}}) =
|
||||
delEventSigned :: GroupInfoKeys -> Maybe GroupChatScopeInfo -> Bool -> CChatItem 'CTGroup -> Maybe (Maybe MsgSigning, ChatMsgEvent 'Json)
|
||||
delEventSigned g@(GIK gInfo _) chatScopeInfo onlyHistory (CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId, msgVerified}}) =
|
||||
delEvent <$> itemSharedMsgId
|
||||
where
|
||||
delEvent msgId =
|
||||
let evt = XMsgDel msgId Nothing (toMsgScope gInfo <$> chatScopeInfo) onlyHistory
|
||||
in (groupMsgSigning (onlyHistory || itemSigned) gInfo evt, evt)
|
||||
in (groupMsgSigning (onlyHistory || itemSigned) g evt, evt)
|
||||
itemSigned = case msgVerified of Just (MVSigned _) -> True; _ -> False
|
||||
APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do
|
||||
(gInfo, items) <- getCommandGroupChatItems user gId itemIds
|
||||
(g@(GIK gInfo _), items) <- getCommandGroupChatItems user gId itemIds
|
||||
-- TODO [knocking] check scope is Nothing for all items? (prohibit moderation in support chats?)
|
||||
ms <- withFastStore' $ \db -> getGroupMembers db cxt user gInfo
|
||||
let recipients = filter memberCurrent ms
|
||||
deletions <- delGroupChatItemsForMembers user gInfo Nothing recipients items
|
||||
deletions <- delGroupChatItemsForMembers user g Nothing recipients items
|
||||
pure $ CRChatItemsDeleted user deletions True False
|
||||
APIArchiveReceivedReports gId -> withUser $ \user -> withFastStore $ \db -> do
|
||||
g <- getGroupInfo db cxt user gId
|
||||
@@ -950,7 +950,7 @@ processChatCommand cxt nm = \case
|
||||
ciIds <- liftIO $ markReceivedGroupReportsDeleted db user g deleteTs
|
||||
pure $ CRGroupChatItemsDeleted user g ciIds True (Just $ membership g)
|
||||
APIDeleteReceivedReports gId itemIds mode -> withUser $ \user -> withGroupLock "deleteReports" gId $ do
|
||||
(gInfo, items) <- getCommandGroupChatItems user gId itemIds
|
||||
(g@(GIK gInfo _), items) <- getCommandGroupChatItems user gId itemIds
|
||||
unless (all isRcvReport items) $ throwCmdError "some items are not received reports"
|
||||
-- TODO [knocking] scope can be different for each item if reports are from different members
|
||||
-- TODO (currently we pass Nothing as scope which is wrong)
|
||||
@@ -961,7 +961,7 @@ processChatCommand cxt nm = \case
|
||||
CIDMBroadcast -> do
|
||||
ms <- withFastStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
let recipients = filter memberCurrent ms
|
||||
delGroupChatItemsForMembers user gInfo Nothing recipients items
|
||||
delGroupChatItemsForMembers user g Nothing recipients items
|
||||
pure $ CRChatItemsDeleted user deletions True False
|
||||
where
|
||||
isRcvReport = \case
|
||||
@@ -990,9 +990,9 @@ processChatCommand cxt nm = \case
|
||||
CTGroup ->
|
||||
withGroupLock "chatItemReaction" chatId $ do
|
||||
-- TODO [knocking] check chat item scope?
|
||||
(g@GroupInfo {membership}, CChatItem md ci) <- withFastStore $ \db -> do
|
||||
g <- getGroupInfo db cxt user chatId
|
||||
(g,) <$> getGroupCIWithReactions db user g itemId
|
||||
(gik@(GIK g@GroupInfo {membership} _), CChatItem md ci) <- withFastStore $ \db -> do
|
||||
gik@(GIK g _) <- getGroupInfoKeys db cxt user chatId
|
||||
(gik,) <$> getGroupCIWithReactions db user g itemId
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
recipients <- getGroupRecipients cxt user g chatScopeInfo groupKnockingVersion
|
||||
case ci of
|
||||
@@ -1004,7 +1004,7 @@ processChatCommand cxt nm = \case
|
||||
let itemMemberId = memberId' <$> chatItemMember g ci
|
||||
rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True
|
||||
checkReactionAllowed rs
|
||||
SndMessage {msgId} <- sendGroupMessage user g scope recipients False (XMsgReact itemSharedMId itemMemberId (toMsgScope g <$> chatScopeInfo) reaction add)
|
||||
SndMessage {msgId} <- sendGroupMessage user gik scope recipients False (XMsgReact itemSharedMId itemMemberId (toMsgScope g <$> chatScopeInfo) reaction add)
|
||||
createdAt <- liftIO getCurrentTime
|
||||
reactions <- withFastStore' $ \db -> do
|
||||
setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt
|
||||
@@ -1089,7 +1089,7 @@ processChatCommand cxt nm = \case
|
||||
case L.nonEmpty cmrs of
|
||||
Just cmrs' ->
|
||||
withGroupLock "forwardChatItem, to group" toChatId $ do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user toChatId
|
||||
gInfo <- withFastStore $ \db -> getGroupInfoKeys db cxt user toChatId
|
||||
sendGroupContentMessages user gInfo toScope sendAsGroup False itemTTL False cmrs'
|
||||
Nothing -> pure $ CRNewChatItems user []
|
||||
CTLocal -> do
|
||||
@@ -1119,7 +1119,7 @@ processChatCommand cxt nm = \case
|
||||
| otherwise = displayName
|
||||
-- TODO [knocking] from scope?
|
||||
CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do
|
||||
(gInfo, items) <- getCommandGroupChatItems user fromChatId itemIds
|
||||
(GIK gInfo _, items) <- getCommandGroupChatItems user fromChatId itemIds
|
||||
catMaybes <$> mapM (\ci -> ciComposeMsgReq gInfo ci <$$> prepareMsgReq ci) items
|
||||
where
|
||||
ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
|
||||
@@ -1226,16 +1226,16 @@ processChatCommand cxt nm = \case
|
||||
let ext = takeExtension fileName
|
||||
pure $ prefix <> formattedDate <> ext
|
||||
APIShareChatMsgContent (ChatRef CTGroup groupId _) toSendRef -> withUser $ \user -> do
|
||||
GroupInfo {groupProfile = gp@GroupProfile {publicGroup}, membership = GroupMember {memberId, memberRole}, groupKeys} <-
|
||||
withFastStore $ \db -> getGroupInfo db cxt user groupId
|
||||
GIK GroupInfo {groupProfile = gp@GroupProfile {publicGroup}, membership = GroupMember {memberId, memberRole}} gks <-
|
||||
withFastStore $ \db -> getGroupInfoKeys db cxt user groupId
|
||||
case publicGroup of
|
||||
Nothing -> throwCmdError "not a public group"
|
||||
Just PublicGroupProfile {groupLink} -> do
|
||||
let signingKeys = case (memberRole, groupKeys) of
|
||||
(GROwner, Just gk@GroupKeys {publicGroupKeys = Just PublicGroupKeys {groupRootKey = GRKPrivate _}}) -> Just gk
|
||||
let signingKeys = case (memberRole, gks) of
|
||||
(GROwner, GKPublicGroup {groupRootKey = GRKPrivate _, memberPrivKey}) -> Just memberPrivKey
|
||||
_ -> Nothing
|
||||
ownerSig <-
|
||||
pure signingKeys $>>= \GroupKeys {memberPrivKey} ->
|
||||
pure signingKeys $>>= \memberPrivKey ->
|
||||
mkLinkOwnerSig memberPrivKey groupLink (Just memberId) <$$> shareChatBinding user toSendRef
|
||||
let text = safeDecodeUtf8 $ strEncode groupLink
|
||||
pure $ CRChatMsgContent user MCChat {text, chatLink = MCLGroup groupLink gp, ownerSig}
|
||||
@@ -1378,7 +1378,7 @@ processChatCommand cxt nm = \case
|
||||
withFastStore' $ \db -> deletePendingContactConnection db userId chatId
|
||||
pure $ CRContactConnectionDeleted user conn
|
||||
CTGroup | isNothing scope -> do
|
||||
gInfo@GroupInfo {membership} <- withFastStore $ \db -> getGroupInfo db cxt user chatId
|
||||
g@(GIK gInfo@GroupInfo {membership} _) <- withFastStore $ \db -> getGroupInfoKeys db cxt user chatId
|
||||
let isOwner = memberRole' membership == GROwner
|
||||
canDelete = isOwner || not (memberCurrent membership)
|
||||
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
|
||||
@@ -1391,7 +1391,7 @@ processChatCommand cxt nm = \case
|
||||
let doSendDel = memberActive membership && isOwner
|
||||
msgSigned <-
|
||||
if doSendDel
|
||||
then (\SndMessage {signedMsg_} -> isJust signedMsg_) <$> sendGroupMessage' user gInfo recipients XGrpDel
|
||||
then (\SndMessage {signedMsg_} -> isJust signedMsg_) <$> sendGroupMessage' user g recipients XGrpDel
|
||||
else pure False
|
||||
deleteGroupLinkIfExists user gInfo
|
||||
deleteMembersConnections' user members doSendDel
|
||||
@@ -2293,7 +2293,7 @@ processChatCommand cxt nm = \case
|
||||
pure $ CRStartedConnectionToContact user ct' customUserProfile
|
||||
CVRConnectedContact ct' -> pure $ CRContactAlreadyExists user ct'
|
||||
APIConnectPreparedGroup {groupId, incognito, ownerContact, msgContent_} -> withUser $ \user -> do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user groupId
|
||||
g@(GIK gInfo _) <- withFastStore $ \db -> getGroupInfoKeys db cxt user groupId
|
||||
case gInfo of
|
||||
GroupInfo {preparedGroup = Nothing} -> throwCmdError "group doesn't have link to connect"
|
||||
GroupInfo {useRelays = BoolDef True, preparedGroup = Just PreparedGroup {connLinkToConnect}} -> do
|
||||
@@ -2313,9 +2313,8 @@ processChatCommand cxt nm = \case
|
||||
-- set group link info and incognito profile, generate and store membership keys
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
let cReqHash = contactCReqHash $ CRContactUri crData {crScheme = SSSimplex} e2e
|
||||
(_, memberPrivKey) <- atomically . C.generateKeyPair =<< asks random
|
||||
gInfo' <- withFastStore $ \db -> do
|
||||
gInfo' <- updatePreparedRelayedGroup db cxt user gInfo mainCReq cReqHash incognitoProfile rootKey memberPrivKey publicMemberCount_
|
||||
g'@(GIK gInfo' _) <- withFastStore $ \db -> do
|
||||
g'@(GIK gInfo' _) <- updatePreparedRelayedGroup db cxt user gInfo mainCReq cReqHash incognitoProfile rootKey publicMemberCount_
|
||||
-- Pre-emptively create owner members with trusted keys from link data
|
||||
forM_ owners $ \OwnerAuth {ownerId, ownerKey} -> do
|
||||
let ctId_ = case ownerContact of
|
||||
@@ -2323,9 +2322,9 @@ processChatCommand cxt nm = \case
|
||||
| memberId == MemberId ownerId -> Just contactId
|
||||
_ -> Nothing
|
||||
void $ createLinkOwnerMember db cxt user gInfo' ctId_ (MemberId ownerId) ownerKey
|
||||
pure gInfo'
|
||||
pure g'
|
||||
rs <- withGroupLock "connectPreparedGroup" groupId $
|
||||
mapConcurrently (connectToRelay user gInfo') relays
|
||||
mapConcurrently (connectToRelay user g') relays
|
||||
let relayFailed = \case (_, _, Left _) -> True; _ -> False
|
||||
(failed, succeeded) = partition relayFailed rs
|
||||
if null succeeded
|
||||
@@ -2367,7 +2366,7 @@ processChatCommand cxt nm = \case
|
||||
smId <- getSharedMsgId
|
||||
withFastStore' $ \db -> setRequestSharedMsgIdForGroup db groupId smId
|
||||
pure (smId, mc)
|
||||
r <- connectViaContact user (Just $ PCEGroup gInfo hostMember) incognito connLinkToConnect welcomeSharedMsgId msg_ `catchAllErrors` \e -> do
|
||||
r <- connectViaContact user (Just $ PCEGroup g hostMember) incognito connLinkToConnect welcomeSharedMsgId msg_ `catchAllErrors` \e -> do
|
||||
-- get updated group info, in case connection was started (connLinkPreparedConnection) - in UI it would lock ability to change
|
||||
-- user or incognito profile for group or business chat, in case server received request while client got network error
|
||||
gInfo' <- withFastStore $ \db -> getGroupInfo db cxt user groupId
|
||||
@@ -2699,14 +2698,14 @@ processChatCommand cxt nm = \case
|
||||
g <- asks random
|
||||
memberId <- liftIO $ MemberId <$> encodedRandomBytes g 12
|
||||
(_, memberPrivKey) <- atomically $ C.generateKeyPair g
|
||||
gInfo <- newGroup user incognito gProfile False memberId (Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey}) Nothing
|
||||
gInfo <- newGroup user incognito gProfile memberId GKGroup {memberPrivKey} Nothing
|
||||
createNewGroupItems user gInfo
|
||||
pure $ CRGroupCreated user gInfo
|
||||
NewGroup incognito gProfile -> withUser $ \User {userId} ->
|
||||
processChatCommand cxt nm $ APINewGroup userId incognito gProfile
|
||||
APINewPublicGroup userId incognito relayIds groupProfile -> withUserId userId $ \user -> do
|
||||
(gProfile', memberId, groupKeys, setupLink) <- prepareGroupLink user
|
||||
gInfo <- newGroup user incognito gProfile' True memberId (Just groupKeys) (Just 1)
|
||||
gInfo <- newGroup user incognito gProfile' memberId groupKeys (Just 1)
|
||||
(gLink, results) <- setupLink gInfo `catchAllErrors` \e -> do
|
||||
deleteInProgressGroup user gInfo
|
||||
throwError e
|
||||
@@ -2753,8 +2752,7 @@ processChatCommand cxt nm = \case
|
||||
userLinkData = UserContactLinkData UserContactData {direct = False, owners = [ownerAuth], relays = [], userData, ratchetKeys = Nothing}
|
||||
-- create connection with prepared link (single network call)
|
||||
connId <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True ccLink preparedParams userLinkData subMode
|
||||
let groupKeys = GroupKeys {publicGroupKeys, memberPrivKey}
|
||||
publicGroupKeys = Just PublicGroupKeys {publicGroupId = B64UrlByteString entityId, groupRootKey = GRKPrivate rootPrivKey}
|
||||
let groupKeys = GKPublicGroup {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey}
|
||||
setupLink gInfo = do
|
||||
-- TODO [relays] starting role should be communicated in protocol from owner to relays
|
||||
subRole <- asks $ channelSubscriberRole . config
|
||||
@@ -2804,7 +2802,7 @@ processChatCommand cxt nm = \case
|
||||
_ -> False
|
||||
APIAddMember groupId contactId memRole -> withUser $ \user -> withGroupLock "addMember" groupId $ do
|
||||
-- TODO for large groups: no need to load all members to determine if contact is a member
|
||||
(group, contact) <- withFastStore $ \db -> (,) <$> getGroup db cxt user groupId <*> getContact db cxt user contactId
|
||||
((group, gks), contact) <- withFastStore $ \db -> (,) <$> getGroupKeys_ db cxt user groupId <*> getContact db cxt user contactId
|
||||
let Group gInfo members = group
|
||||
Contact {localDisplayName = cName} = contact
|
||||
when (useRelays' gInfo) $ throwCmdError "can't invite contact to channel"
|
||||
@@ -2814,7 +2812,7 @@ processChatCommand cxt nm = \case
|
||||
when (contactConnIncognito contact) $ throwChatError CEContactIncognitoCantInvite
|
||||
-- [incognito] forbid to invite contacts if user joined the group using an incognito profile
|
||||
when (incognitoMembership gInfo) $ throwChatError CEGroupIncognitoCantInvite
|
||||
let sendInvitation = sendGrpInvitation user contact gInfo
|
||||
let sendInvitation = sendGrpInvitation user contact (GIK gInfo gks)
|
||||
case contactMember contact members of
|
||||
Nothing -> do
|
||||
gVar <- asks random
|
||||
@@ -2837,13 +2835,13 @@ processChatCommand cxt nm = \case
|
||||
(invitation, ct) <- withFastStore $ \db -> do
|
||||
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db cxt user groupId
|
||||
(inv,) <$> getContactViaMember db cxt user fromMember
|
||||
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership, chatSettings}} = invitation
|
||||
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership, chatSettings}, groupKeys = gks} = invitation
|
||||
GroupMember {memberId = membershipMemId} = membership
|
||||
Contact {activeConn} = ct
|
||||
case activeConn of
|
||||
Just Connection {peerChatVRange} -> do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (groupMemberKey g)
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (Just $ groupMemberKey gks)
|
||||
agentConnId <- case memberConn fromMember of
|
||||
Nothing -> do
|
||||
agentConnId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff
|
||||
@@ -2866,7 +2864,7 @@ processChatCommand cxt nm = \case
|
||||
pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APIAcceptMember groupId gmId role -> withUser $ \user@User {userId} -> do
|
||||
(gInfo, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user gmId
|
||||
(g@(GIK gInfo _), m) <- withFastStore $ \db -> (,) <$> getGroupInfoKeys db cxt user groupId <*> getGroupMemberById db cxt user gmId
|
||||
assertUserGroupRole gInfo $ max GRModerator role
|
||||
case memberStatus m of
|
||||
GSMemPendingApproval | memberCategory m == GCInviteeMember -> do -- only host can approve
|
||||
@@ -2875,14 +2873,14 @@ processChatCommand cxt nm = \case
|
||||
Just mConn ->
|
||||
case memberAdmission >>= review of
|
||||
Just MCAll -> do
|
||||
introduceToModerators cxt user gInfo m
|
||||
introduceToModerators cxt user g m
|
||||
withFastStore' $ \db -> updateGroupMemberStatus db userId m GSMemPendingReview
|
||||
let m' = m {memberStatus = GSMemPendingReview}
|
||||
pure $ CRMemberAccepted user gInfo m'
|
||||
Nothing -> do
|
||||
let msg = XGrpLinkAcpt GAAccepted role (memberId' m)
|
||||
void $ sendDirectMemberMessage mConn msg groupId
|
||||
introduceToRemaining cxt user gInfo m {memberRole = role}
|
||||
introduceToRemaining cxt user g m {memberRole = role}
|
||||
when (groupFeatureAllowed SGFHistory gInfo) $ sendHistory user gInfo m
|
||||
(m', gInfo') <- withFastStore' $ \db -> do
|
||||
m' <- updateGroupMemberAccepted db user m GSMemConnected role
|
||||
@@ -2900,13 +2898,13 @@ processChatCommand cxt nm = \case
|
||||
modMs <- withFastStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
let rcpModMs' = filter memberCurrent modMs
|
||||
msg = XGrpLinkAcpt GAAccepted role (memberId' m)
|
||||
void $ sendGroupMessage user gInfo scope ([m] <> rcpModMs') False msg
|
||||
void $ sendGroupMessage user g scope ([m] <> rcpModMs') False msg
|
||||
when (maxVersion (memberChatVRange m) < groupKnockingVersion) $
|
||||
forM_ (memberConn m) $ \mConn -> do
|
||||
let msg2 = XMsgNew $ mcSimple (MCText acceptedToGroupMessage)
|
||||
void $ sendDirectMemberMessage mConn msg2 groupId
|
||||
when (memberCategory m == GCInviteeMember) $ do
|
||||
introduceToRemaining cxt user gInfo m {memberRole = role}
|
||||
introduceToRemaining cxt user g m {memberRole = role}
|
||||
when (groupFeatureAllowed SGFHistory gInfo) $ sendHistory user gInfo m
|
||||
(m', gInfo') <- withFastStore' $ \db -> do
|
||||
m' <- updateGroupMemberAccepted db user m newMemberStatus role
|
||||
@@ -2938,7 +2936,7 @@ processChatCommand cxt nm = \case
|
||||
APIMembersRole groupId memberIds newRole -> withUser $ \user ->
|
||||
withGroupLock "memberRole" groupId $ do
|
||||
-- TODO [relays] possible optimization is to read only required members + relays
|
||||
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db cxt user groupId
|
||||
(g@(Group gInfo members), gks) <- withFastStore $ \db -> getGroupKeys_ db cxt user groupId
|
||||
when (selfSelected gInfo) $ throwCmdError "can't change role for self"
|
||||
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending, anyPrivilegedTarget, anyRelay, anyRosterChange, finalPrivilegedCount) = selectMembers members
|
||||
when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
|
||||
@@ -2954,11 +2952,11 @@ processChatCommand cxt nm = \case
|
||||
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
|
||||
(errs1, changed1) <- changeRoleInvitedMems user (GIK gInfo gks) invitedMems
|
||||
let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && anyRosterChange
|
||||
-- roster (with the change projected in) before the delta, so a relay stores the blob at this version before forwarding the delta
|
||||
rosterVer <- if doBumpRoster then Just <$> broadcastRoster user gInfo (RDRoleChanged newRole currentMems) else pure Nothing
|
||||
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g rosterVer currentMems
|
||||
rosterVer <- if doBumpRoster then Just <$> broadcastRoster user (GIK gInfo gks) (RDRoleChanged newRole currentMems) else pure Nothing
|
||||
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g gks rosterVer currentMems
|
||||
unless (null acis) $ toView $ CEvtNewChatItems user acis
|
||||
let errs = errs1 <> errs2
|
||||
unless (null errs) $ toView $ CEvtChatErrors errs
|
||||
@@ -2985,8 +2983,8 @@ processChatCommand cxt nm = \case
|
||||
-- a current member's role actually changes here; it alters the roster iff the old or new role is on it
|
||||
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', anyRelay', anyRosterChange || isRosterRole newRole || isRosterRole memberRole, privCount')
|
||||
| otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending, anyPrivTarget, anyRelay, anyRosterChange, if isRosterRole memberRole then privCount + 1 else privCount)
|
||||
changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember])
|
||||
changeRoleInvitedMems user gInfo memsToChange = do
|
||||
changeRoleInvitedMems :: User -> GroupInfoKeys -> [GroupMember] -> CM ([ChatError], [GroupMember])
|
||||
changeRoleInvitedMems user gInfo@(GIK g _) memsToChange = do
|
||||
-- not batched, as we need to send different invitations to different connections anyway
|
||||
mems_ <- forM memsToChange $ \m -> (Right <$> changeRole m) `catchAllErrors` (pure . Left)
|
||||
pure $ partitionEithers mems_
|
||||
@@ -2998,15 +2996,15 @@ processChatCommand cxt nm = \case
|
||||
sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = newRole} cReq
|
||||
withFastStore' $ \db -> updateGroupMemberRole db user m newRole
|
||||
pure (m :: GroupMember) {memberRole = newRole}
|
||||
_ -> throwChatError $ CEGroupCantResendInvitation gInfo cName
|
||||
changeRoleCurrentMems :: User -> Group -> Maybe VersionRoster -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
|
||||
changeRoleCurrentMems user (Group gInfo members) rosterVer memsToChange = case L.nonEmpty memsToChange of
|
||||
_ -> throwChatError $ CEGroupCantResendInvitation g cName
|
||||
changeRoleCurrentMems :: User -> Group -> GroupKeys -> Maybe VersionRoster -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
|
||||
changeRoleCurrentMems user (Group gInfo members) gks rosterVer memsToChange = case L.nonEmpty memsToChange of
|
||||
Nothing -> pure ([], [], [], False)
|
||||
Just memsToChange' -> do
|
||||
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 False events
|
||||
(msgs_, _gsr) <- sendGroupMessages user (GIK gInfo gks) Nothing False recipients False events
|
||||
let signed = any (either (const False) (\SndMessage {signedMsg_} -> isJust signedMsg_)) msgs_
|
||||
itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
|
||||
@@ -3026,7 +3024,7 @@ processChatCommand cxt nm = \case
|
||||
APIBlockMembersForAll groupId memberIds blockFlag -> withUser $ \user ->
|
||||
withGroupLock "blockForAll" groupId $ do
|
||||
-- TODO [relays] possible optimization is to read only required members + relays
|
||||
Group gInfo members <- withFastStore $ \db -> getGroup db cxt user groupId
|
||||
(Group gInfo members, gks) <- withFastStore $ \db -> getGroupKeys_ db cxt user groupId
|
||||
when (selfSelected gInfo) $ throwCmdError "can't block/unblock self"
|
||||
-- TODO [relays] consider sending restriction to all members (remove filtering), as we do in delivery jobs
|
||||
let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members
|
||||
@@ -3034,7 +3032,7 @@ processChatCommand cxt nm = \case
|
||||
when (length memberIds > 1 && anyAdmin) $ throwCmdError "can't block/unblock multiple members when admins selected"
|
||||
when anyPending $ throwCmdError "can't block/unblock members pending approval"
|
||||
assertUserGroupRole gInfo $ max GRModerator maxRole
|
||||
blockMembers user gInfo blockMems remainingMems
|
||||
blockMembers user (GIK gInfo gks) blockMems remainingMems
|
||||
where
|
||||
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
|
||||
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
|
||||
@@ -3047,14 +3045,14 @@ processChatCommand cxt nm = \case
|
||||
anyPending' = anyPending || memberPending m
|
||||
in (m : block, remaining, maxRole', anyAdmin', anyPending')
|
||||
| otherwise = (block, m : remaining, maxRole, anyAdmin, anyPending)
|
||||
blockMembers :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ChatResponse
|
||||
blockMembers user gInfo blockMems remainingMems = case L.nonEmpty blockMems of
|
||||
blockMembers :: User -> GroupInfoKeys -> [GroupMember] -> [GroupMember] -> CM ChatResponse
|
||||
blockMembers user g@(GIK gInfo _) blockMems remainingMems = case L.nonEmpty blockMems of
|
||||
Nothing -> throwCmdError "no members to block/unblock"
|
||||
Just blockMems' -> do
|
||||
let mrs = if blockFlag then MRSBlocked else MRSUnrestricted
|
||||
events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems'
|
||||
recipients = filter memberCurrent remainingMems
|
||||
(msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients False events
|
||||
(msgs_, _gsr) <- sendGroupMessages_ user g recipients False events
|
||||
let msgSigned = any (either (const False) (\SndMessage {signedMsg_} -> isJust signedMsg_)) msgs_
|
||||
itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
|
||||
@@ -3075,7 +3073,7 @@ processChatCommand cxt nm = \case
|
||||
APIRemoveMembers {groupId, groupMemberIds, withMessages} -> withUser $ \user ->
|
||||
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
|
||||
(Group gInfo members, gks) <- withFastStore $ \db -> getGroupKeys_ db cxt user groupId
|
||||
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin, anyPrivilegedRemoved, anyRosterRemoved) = selectMembers gmIds members
|
||||
gmIds = S.fromList $ L.toList groupMemberIds
|
||||
memCount = length groupMemberIds
|
||||
@@ -3088,13 +3086,13 @@ processChatCommand cxt nm = \case
|
||||
let recipients = filter memberCurrent members
|
||||
let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && anyRosterRemoved
|
||||
-- roster (excluding the removed members) before the delta, so a relay stores the blob at this version before forwarding the delta
|
||||
rosterVer <- if doBumpRoster then Just <$> broadcastRoster user gInfo (RDRemoved currentMems) else pure Nothing
|
||||
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing rosterVer recipients currentMems
|
||||
rosterVer <- if doBumpRoster then Just <$> broadcastRoster user (GIK gInfo gks) (RDRemoved currentMems) else pure Nothing
|
||||
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user (GIK gInfo gks) Nothing rosterVer recipients currentMems
|
||||
(errs3, deleted3, acis3, signed3) <-
|
||||
foldM (\acc m -> deletePendingMember acc user gInfo [m] m) ([], [], [], False) pendingApprvMems
|
||||
foldM (\acc m -> deletePendingMember acc user (GIK gInfo gks) [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
|
||||
foldM (\acc m -> deletePendingMember acc user (GIK gInfo gks) (m : moderators) m) ([], [], [], False) pendingRvwMems
|
||||
let acis = acis2 <> acis3 <> acis4
|
||||
errs = errs1 <> errs2 <> errs3 <> errs4
|
||||
deleted = deleted1 <> deleted2 <> deleted3 <> deleted4
|
||||
@@ -3102,7 +3100,7 @@ processChatCommand cxt nm = \case
|
||||
-- Read group info with updated membersRequireAttention and publicMemberCount
|
||||
gInfo' <-
|
||||
if useRelays' gInfo
|
||||
then updatePublicGroupData user gInfo
|
||||
then updatePublicGroupData user gInfo gks
|
||||
else withFastStore $ \db -> getGroupInfo db cxt user groupId
|
||||
let acis' = map (updateACIGroupInfo gInfo') acis
|
||||
unless (null acis') $ toView $ CEvtNewChatItems user acis'
|
||||
@@ -3136,18 +3134,18 @@ processChatCommand cxt nm = \case
|
||||
delMember db m = do
|
||||
deleteGroupMember db user m
|
||||
pure m {memberStatus = GSMemRemoved}
|
||||
deletePendingMember :: ([ChatError], [GroupMember], [AChatItem], Bool) -> User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
|
||||
deletePendingMember :: ([ChatError], [GroupMember], [AChatItem], Bool) -> User -> GroupInfoKeys -> [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) Nothing recipients [m']
|
||||
pure (errs <> accErrs, deleted <> accDeleted, acis <> accACIs, accSigned || signed)
|
||||
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
|
||||
deleteMemsSend :: User -> GroupInfoKeys -> Maybe GroupChatScopeInfo -> Maybe VersionRoster -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
|
||||
deleteMemsSend user g@(GIK 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 rosterVer) memsToDelete'
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo chatScope False recipients False events
|
||||
(msgs_, _gsr) <- sendGroupMessages user g chatScope False recipients False events
|
||||
let signed = any (either (const False) (\SndMessage {signedMsg_} -> isJust signedMsg_)) msgs_
|
||||
itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
|
||||
skipUnwantedItem = \case
|
||||
@@ -3184,14 +3182,14 @@ processChatCommand cxt nm = \case
|
||||
| groupFeatureUserAllowed SGFFullDelete gInfo = deleteGroupMembersCIs user gInfo ms
|
||||
| otherwise = markGroupMembersCIsDeleted user gInfo ms membership
|
||||
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
gInfo@GroupInfo {membership} <- withFastStore $ \db -> getGroupInfo db cxt user groupId
|
||||
g@(GIK gInfo@GroupInfo {membership} _) <- withFastStore $ \db -> getGroupInfoKeys db cxt user groupId
|
||||
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
withGroupLock "leaveGroup" groupId $ do
|
||||
cancelFilesInProgress user filesInfo
|
||||
msg <-
|
||||
if useRelays' gInfo && isRelay membership
|
||||
then leaveChannelRelay gInfo
|
||||
else leaveGroupSendMsg user gInfo
|
||||
then leaveChannelRelay g
|
||||
else leaveGroupSendMsg user g
|
||||
(gInfo', scopeInfo) <- mkLocalGroupChatScope gInfo
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo' scopeInfo) msg (CISndGroupEvent SGEUserLeft)
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo' scopeInfo) ci]
|
||||
@@ -3206,9 +3204,9 @@ processChatCommand cxt nm = \case
|
||||
pure $ CRLeftMemberUser user gInfo' {membership = membership {memberStatus = GSMemLeft}, relayOwnStatus = relayOwnStatus'}
|
||||
where
|
||||
-- Relay leaving channel: create delivery job for cursor-based sending and async connection cleanup.
|
||||
leaveChannelRelay gInfo = do
|
||||
leaveChannelRelay g@(GIK gInfo _) = do
|
||||
msg@SndMessage {msgBody, signedMsg_} <-
|
||||
liftEither . runIdentity =<< lift (createSndMessages $ Identity (GroupId groupId, groupMsgSigning False gInfo XGrpLeave, XGrpLeave))
|
||||
liftEither . runIdentity =<< lift (createSndMessages $ Identity (GroupId groupId, groupMsgSigning False g XGrpLeave, XGrpLeave))
|
||||
let body = encodeBatchElement signedMsg_ msgBody
|
||||
withFastStore' $ \db -> do
|
||||
deleteGroupDeliveryTasks db gInfo
|
||||
@@ -3216,9 +3214,9 @@ processChatCommand cxt nm = \case
|
||||
createMsgDeliveryJob db gInfo (DJSGroup {jobSpec = DJRelayRemoved}) [] body
|
||||
lift . void $ getDeliveryJobWorker True (groupId, DWSGroup)
|
||||
pure msg
|
||||
leaveGroupSendMsg user gInfo = do
|
||||
leaveGroupSendMsg user g@(GIK gInfo _) = do
|
||||
(members, recipients) <- getRecipients user gInfo
|
||||
msg <- sendGroupMessage' user gInfo recipients XGrpLeave
|
||||
msg <- sendGroupMessage' user g recipients XGrpLeave
|
||||
deleteMembersConnections' user members True
|
||||
pure msg
|
||||
getRecipients user gInfo
|
||||
@@ -3278,7 +3276,7 @@ processChatCommand cxt nm = \case
|
||||
ct_ <- forM cName_ $ \cName -> withFastStore $ \db -> getContactByName db cxt user cName
|
||||
processChatCommand cxt nm $ APIListGroups userId (contactId' <$> ct_) search_
|
||||
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user groupId
|
||||
gInfo <- withFastStore $ \db -> getGroupInfoKeys db cxt user groupId
|
||||
runUpdateGroupProfile user gInfo p' False
|
||||
UpdateGroupNames gName GroupProfile {displayName, fullName, shortDescr} ->
|
||||
updateGroupProfileByName gName $ \p -> p {displayName, fullName, shortDescr}
|
||||
@@ -3289,7 +3287,7 @@ processChatCommand cxt nm = \case
|
||||
ShowGroupDescription gName -> withUser $ \user ->
|
||||
CRGroupDescription user <$> withFastStore (\db -> getGroupInfoByName db cxt user gName)
|
||||
APISetPublicGroupAccess gId access@PublicGroupAccess {groupDomainClaim = newClaim} -> withUser $ \user -> do
|
||||
gInfo@GroupInfo {groupProfile = p@GroupProfile {publicGroup}} <- withStore $ \db -> getGroupInfo db cxt user gId
|
||||
gInfo@(GIK GroupInfo {groupProfile = p@GroupProfile {publicGroup}} _) <- withStore $ \db -> getGroupInfoKeys db cxt user gId
|
||||
case publicGroup of
|
||||
Just pg@PublicGroupProfile {groupLink, publicGroupAccess = existingAccess} -> do
|
||||
let domainChanged = (claimDomain <$> newClaim) /= (claimDomain <$> (existingAccess >>= groupDomainClaim))
|
||||
@@ -3332,11 +3330,11 @@ processChatCommand cxt nm = \case
|
||||
gLnk <- withFastStore $ \db -> getGroupLink db user gInfo
|
||||
pure $ CRGroupLink user gInfo gLnk
|
||||
APIAddGroupShortLink groupId -> withUser $ \user -> do
|
||||
(gInfo, gLink) <- withFastStore $ \db -> do
|
||||
gInfo <- getGroupInfo db cxt user groupId
|
||||
(g@(GIK gInfo _), gLink) <- withFastStore $ \db -> do
|
||||
g@(GIK gInfo _) <- getGroupInfoKeys db cxt user groupId
|
||||
gLink <- getGroupLink db user gInfo
|
||||
pure (gInfo, gLink)
|
||||
gLink' <- setGroupLinkData nm user gInfo gLink
|
||||
pure (g, gLink)
|
||||
gLink' <- setGroupLinkData nm user g gLink
|
||||
pure $ CRGroupLink user gInfo gLink'
|
||||
APICreateMemberContact gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db cxt user gId <*> getGroupMember db cxt user gId gMemberId
|
||||
@@ -3522,10 +3520,10 @@ processChatCommand cxt nm = \case
|
||||
void . sendDirectContactMessage user contact $ XFileCancel sharedMsgId
|
||||
pure $ CRSndFileCancelled user (Just aci) ftm fts
|
||||
(Just (ChatRef CTGroup groupId scope), Just aci) -> do
|
||||
(gInfo, sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroupInfo db cxt user groupId <*> getSharedMsgIdByFileId db userId fileId
|
||||
(g@(GIK gInfo _), sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroupInfoKeys db cxt user groupId <*> getSharedMsgIdByFileId db userId fileId
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo groupKnockingVersion
|
||||
void . sendGroupMessage user gInfo scope recipients False $ XFileCancel sharedMsgId
|
||||
void . sendGroupMessage user g scope recipients False $ XFileCancel sharedMsgId
|
||||
pure $ CRSndFileCancelled user (Just aci) ftm fts
|
||||
(Just _, _) -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
|
||||
where
|
||||
@@ -3873,7 +3871,7 @@ processChatCommand cxt nm = \case
|
||||
-- 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)
|
||||
Just (PCEGroup (GIK 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"
|
||||
@@ -3890,7 +3888,7 @@ processChatCommand cxt nm = \case
|
||||
xContactId <- mkXContactId xContactId_
|
||||
-- [incognito] generate profile to send, or use membership profile for relay groups
|
||||
incognitoProfile_ <- case gInfo_ of
|
||||
Just (Just gInfo) | useRelays' gInfo -> pure $ ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
Just (Just (GIK gInfo _)) | useRelays' gInfo -> pure $ ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
_ -> if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
|
||||
let incognitoProfile = fromIncognitoProfile <$> incognitoProfile_
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
@@ -3924,8 +3922,8 @@ processChatCommand cxt nm = \case
|
||||
ct' <- withStore $ \db -> getContact db cxt user contactId
|
||||
pure $ CRSentInvitationToContact user ct' incognitoProfile
|
||||
_ -> throwCmdError "contact already has connection"
|
||||
connectToRelay :: User -> GroupInfo -> ShortLinkContact -> CM (ShortLinkContact, GroupMember, Either ChatError ())
|
||||
connectToRelay user gInfo relayLink = do
|
||||
connectToRelay :: User -> GroupInfoKeys -> ShortLinkContact -> CM (ShortLinkContact, GroupMember, Either ChatError ())
|
||||
connectToRelay user g@(GIK gInfo _) relayLink = do
|
||||
gVar <- asks random
|
||||
-- Save relayLink to re-use relay member record on retry (check by relayLink)
|
||||
relayMember <- withFastStore $ \db -> getCreateRelayForMember db cxt gVar user gInfo relayLink
|
||||
@@ -3938,7 +3936,7 @@ processChatCommand cxt nm = \case
|
||||
pure $ MemberId entityId
|
||||
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
|
||||
let relayLinkToConnect = CCLink cReq (Just relayLink)
|
||||
void $ connectViaContact user (Just $ PCEGroup gInfo (relayMember {memberId = relayMemberId})) (incognitoMembership gInfo) relayLinkToConnect Nothing Nothing
|
||||
void $ connectViaContact user (Just $ PCEGroup g (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 ()
|
||||
@@ -3971,21 +3969,19 @@ 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) -> Maybe MemberId -> PQSupport -> CM Connection
|
||||
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfoKeys) -> Maybe MemberId -> PQSupport -> CM Connection
|
||||
joinContact user conn 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
|
||||
Just gInfo_' -> userProfileInGroup' user gInfo_' incognitoProfile
|
||||
Just gInfo_' -> userProfileInGroup' user ((\(GIK g _) -> g) <$> gInfo_') incognitoProfile
|
||||
Nothing -> userProfileDirect user incognitoProfile Nothing True
|
||||
dm <- case gInfo_ of
|
||||
Just (Just gInfo)
|
||||
| useRelays' gInfo -> case relayMemberId_ of
|
||||
Just (Just gInfo@(GIK g gks))
|
||||
| useRelays' g -> case relayMemberId_ of
|
||||
Just relayMemberId -> encodeXMemberConnInfo gInfo relayMemberId profileToSend
|
||||
Nothing -> throwChatError $ CEInternalError "relay group join without target relay memberId"
|
||||
| otherwise -> do
|
||||
gInfo' <- createUserMemberKey gInfo
|
||||
encodeConnInfoPQ pqSup $ XContact profileToSend (groupMemberKey gInfo') (Just xContactId) welcomeSharedMsgId msg_
|
||||
| otherwise -> encodeConnInfoPQ pqSup $ XContact profileToSend (Just $ groupMemberKey gks) (Just xContactId) welcomeSharedMsgId msg_
|
||||
_ ->
|
||||
encodeConnInfoPQ pqSup $ XContact profileToSend Nothing (Just xContactId) welcomeSharedMsgId msg_
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
@@ -4100,8 +4096,8 @@ processChatCommand cxt nm = \case
|
||||
void (sendDirectContactMessage user ct' $ XInfo p Nothing) `catchAllErrors` eToView
|
||||
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
|
||||
pure $ CRContactPrefsUpdated user ct ct'
|
||||
runUpdateGroupProfile :: User -> GroupInfo -> GroupProfile -> Bool -> CM ChatResponse
|
||||
runUpdateGroupProfile user gInfo@GroupInfo {businessChat, groupProfile = p@GroupProfile {displayName = n}} p'@GroupProfile {displayName = n', image = img', memberAdmission = ma'} domainVerified = do
|
||||
runUpdateGroupProfile :: User -> GroupInfoKeys -> GroupProfile -> Bool -> CM ChatResponse
|
||||
runUpdateGroupProfile user (GIK gInfo@GroupInfo {businessChat, groupProfile = p@GroupProfile {displayName = n}} gks) p'@GroupProfile {displayName = n', image = img', memberAdmission = ma'} domainVerified = do
|
||||
assertUserGroupRole gInfo GROwner
|
||||
when (n /= n') $ checkValidName n'
|
||||
checkProfileImageSize img'
|
||||
@@ -4121,14 +4117,14 @@ processChatCommand cxt nm = \case
|
||||
withStore $ \db -> getGroupMemberByMemberId db cxt user gInfo' businessId
|
||||
let p'' = p' {displayName, fullName, shortDescr, image} :: GroupProfile
|
||||
recipients = filter memberCurrentOrPending oldMs
|
||||
void $ sendGroupMessage user gInfo' Nothing recipients False (XGrpInfo p'')
|
||||
void $ sendGroupMessage user (GIK gInfo' gks) Nothing recipients False (XGrpInfo p'')
|
||||
let ps' = fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
|
||||
recipients = filter memberCurrentOrPending newMs
|
||||
sendGroupMessage user gInfo' Nothing recipients False $ XGrpPrefs ps'
|
||||
sendGroupMessage user (GIK gInfo' gks) Nothing recipients False $ XGrpPrefs ps'
|
||||
Nothing -> do
|
||||
void $ setGroupLinkData' nm user gInfo'
|
||||
void $ setGroupLinkData' nm user (GIK gInfo' gks)
|
||||
recipients <- getRecipients
|
||||
sendGroupMessage user gInfo' Nothing recipients False (XGrpInfo p')
|
||||
sendGroupMessage user (GIK gInfo' gks) Nothing recipients False (XGrpInfo p')
|
||||
where
|
||||
getRecipients
|
||||
| useRelays' gInfo' = withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo'
|
||||
@@ -4152,13 +4148,13 @@ processChatCommand cxt nm = \case
|
||||
when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
|
||||
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
|
||||
delGroupChatItemsForMembers :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [GroupMember] -> [CChatItem 'CTGroup] -> CM [ChatItemDeletion]
|
||||
delGroupChatItemsForMembers user gInfo chatScopeInfo ms items = do
|
||||
delGroupChatItemsForMembers :: User -> GroupInfoKeys -> Maybe GroupChatScopeInfo -> [GroupMember] -> [CChatItem 'CTGroup] -> CM [ChatItemDeletion]
|
||||
delGroupChatItemsForMembers user g@(GIK gInfo _) chatScopeInfo ms items = do
|
||||
assertDeletable gInfo items
|
||||
assertUserGroupRole gInfo GRModerator
|
||||
let msgMemIds = itemsMsgMemIds gInfo items
|
||||
-- moderation deletes always sign (attributable; avoids the catch-up-moderator divergence)
|
||||
signedEvents = L.nonEmpty $ map (\(msgId, memId) -> let evt = XMsgDel msgId memId (toMsgScope gInfo <$> chatScopeInfo) False in (groupMsgSigning True gInfo evt, evt)) msgMemIds
|
||||
signedEvents = L.nonEmpty $ map (\(msgId, memId) -> let evt = XMsgDel msgId memId (toMsgScope gInfo <$> chatScopeInfo) False in (groupMsgSigning True g evt, evt)) msgMemIds
|
||||
mapM_ (sendGroupSignedMessages_ gInfo ms) signedEvents
|
||||
delGroupChatItems user gInfo chatScopeInfo items True
|
||||
where
|
||||
@@ -4196,10 +4192,10 @@ processChatCommand cxt nm = \case
|
||||
updateGroupProfileByName = updateGroupProfileByName_ Nothing
|
||||
updateGroupProfileByName_ :: Maybe GroupFeature -> GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse
|
||||
updateGroupProfileByName_ feature_ gName update = withUser $ \user -> do
|
||||
gInfo@GroupInfo {groupProfile = p} <- withStore $ \db ->
|
||||
getGroupIdByName db user gName >>= getGroupInfo db cxt user
|
||||
gInfo@(GIK g@GroupInfo {groupProfile = p} _) <- withStore $ \db ->
|
||||
getGroupIdByName db user gName >>= getGroupInfoKeys db cxt user
|
||||
forM_ feature_ $ \feature -> do
|
||||
let channel = useRelays' gInfo
|
||||
let channel = useRelays' g
|
||||
applicable = if channel then groupFeatureInChannel feature else groupFeatureInRegularGroup feature
|
||||
unless applicable $
|
||||
throwCmdError $ T.unpack (groupFeatureNameText feature) <> " is not available in " <> (if channel then "channels" else "groups")
|
||||
@@ -4257,29 +4253,30 @@ processChatCommand cxt nm = \case
|
||||
groupId <- getGroupIdByName db user gName
|
||||
groupMemberId <- getGroupMemberIdByName db user groupId groupMemberName
|
||||
pure (groupId, groupMemberId)
|
||||
newGroup :: User -> IncognitoEnabled -> GroupProfile -> Bool -> MemberId -> Maybe GroupKeys -> Maybe Int64 -> CM GroupInfo
|
||||
newGroup user incognito gProfile@GroupProfile {displayName, image, memberAdmission} useRelays memberId groupKeys_ publicMemberCount_ = do
|
||||
newGroup :: User -> IncognitoEnabled -> GroupProfile -> MemberId -> GroupKeys -> Maybe Int64 -> CM GroupInfo
|
||||
newGroup user incognito gProfile@GroupProfile {displayName, image, memberAdmission, publicGroup} memberId groupKeys publicMemberCount_ = do
|
||||
checkValidName displayName
|
||||
checkProfileImageSize image
|
||||
checkGroupProfileSize gProfile
|
||||
when (useRelays && isJust (memberAdmission >>= review)) $ throwCmdError "Admission review is not supported in channels"
|
||||
when (isPublicGroup groupKeys && isJust (memberAdmission >>= review)) $ throwCmdError "Admission review is not supported in channels"
|
||||
when (not (isPublicGroup groupKeys) && isJust publicGroup) $ throwCmdError "publicGroup is not allowed in groups"
|
||||
-- [incognito] generate incognito profile for group membership
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
withFastStore $ \db -> createNewGroup db cxt user gProfile incognitoProfile useRelays memberId groupKeys_ publicMemberCount_
|
||||
withFastStore $ \db -> createNewGroup db cxt user gProfile incognitoProfile memberId groupKeys publicMemberCount_
|
||||
createNewGroupItems :: User -> GroupInfo -> CM ()
|
||||
createNewGroupItems user gInfo = do
|
||||
let cd = CDGroupSnd gInfo Nothing
|
||||
createInternalChatItem user cd CIChatBanner (Just epochStart)
|
||||
createInternalChatItem user cd (CISndGroupE2EEInfo $ e2eInfoGroup gInfo) Nothing
|
||||
createGroupFeatureItems user cd CISndGroupFeature gInfo
|
||||
sendGrpInvitation :: User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> CM ()
|
||||
sendGrpInvitation user ct@Contact {contactId, localDisplayName} gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} m@GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
|
||||
sendGrpInvitation :: User -> Contact -> GroupInfoKeys -> GroupMember -> ConnReqInvitation -> CM ()
|
||||
sendGrpInvitation user ct@Contact {contactId, localDisplayName} (GIK gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} gks) m@GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
|
||||
let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo
|
||||
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
||||
groupInv =
|
||||
GroupInvitation
|
||||
{ fromMember = MemberIdRole userMemberId userRole,
|
||||
fromMemberKey = groupMemberKey gInfo,
|
||||
fromMemberKey = Just $ groupMemberKey gks,
|
||||
invitedMember = MemberIdRole memberId memRole,
|
||||
connRequest = cReq,
|
||||
groupProfile,
|
||||
@@ -4826,19 +4823,17 @@ processChatCommand cxt nm = \case
|
||||
quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
|
||||
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
|
||||
quoteData _ = throwError SEInvalidQuote
|
||||
sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Bool -> Maybe Int -> Bool -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages user gInfo scope showGroupAsSender live itemTTL sign cmrs = do
|
||||
sendGroupContentMessages :: User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> Bool -> Maybe Int -> Bool -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages user gInfo@(GIK g _) scope showGroupAsSender live itemTTL sign cmrs = do
|
||||
assertMultiSendable live cmrs
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
-- the member key is created before the send, so that signatures and file badge proofs assert the same key
|
||||
gInfo' <- createUserMemberKey gInfo
|
||||
recipients <- getGroupRecipients cxt user gInfo' chatScopeInfo modsCompatVersion
|
||||
sendGroupContentMessages_ user gInfo' scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs
|
||||
recipients <- getGroupRecipients cxt user g chatScopeInfo modsCompatVersion
|
||||
sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs
|
||||
where
|
||||
hasReport = any (\(ComposedMessage {msgContent}, _, _, _) -> isReport msgContent) cmrs
|
||||
modsCompatVersion = if hasReport then contentReportsVersion else groupKnockingVersion
|
||||
sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> Bool -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs = do
|
||||
sendGroupContentMessages_ :: User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> Bool -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages_ user g@(GIK gInfo@GroupInfo {groupId, membership} _) scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs = do
|
||||
forM_ allowedRole $ assertUserGroupRole gInfo
|
||||
assertGroupContentAllowed
|
||||
processComposedMessages
|
||||
@@ -4868,7 +4863,7 @@ processChatCommand cxt nm = \case
|
||||
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length recipients)
|
||||
timed_ <- sndGroupCITimed live gInfo itemTTL
|
||||
(chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
|
||||
(msgs_, gsr) <- sendGroupMessages user gInfo Nothing showGroupAsSender recipients signMsgs chatMsgEvents
|
||||
(msgs_, gsr) <- sendGroupMessages user g Nothing showGroupAsSender recipients signMsgs chatMsgEvents
|
||||
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) showGroupAsSender itemsData timed_ live
|
||||
when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
|
||||
@@ -4992,12 +4987,12 @@ processChatCommand cxt nm = \case
|
||||
where
|
||||
getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect))
|
||||
getDirectCI db itemId = runExceptT . withExceptT ChatErrorStore $ getDirectChatItem db user ctId itemId
|
||||
getCommandGroupChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (GroupInfo, [CChatItem 'CTGroup])
|
||||
getCommandGroupChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (GroupInfoKeys, [CChatItem 'CTGroup])
|
||||
getCommandGroupChatItems user gId itemIds = do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user gId
|
||||
g@(GIK gInfo _) <- withFastStore $ \db -> getGroupInfoKeys db cxt user gId
|
||||
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db gInfo) (L.toList itemIds))
|
||||
unless (null errs) $ toView $ CEvtChatErrors errs
|
||||
pure (gInfo, items)
|
||||
pure (g, items)
|
||||
where
|
||||
getGroupCI :: DB.Connection -> GroupInfo -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup))
|
||||
getGroupCI db gInfo itemId = runExceptT . withExceptT ChatErrorStore $ getGroupCIWithReactions db user gInfo itemId
|
||||
@@ -5206,7 +5201,7 @@ presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadg
|
||||
Just User {userId = activeId} | activeId == userId -> Just user'
|
||||
active_ -> active_
|
||||
lift $ withAgent' $ \a -> setUserEntitlement a (aUserId user') (badgeServerCredential localBadge)
|
||||
cxt <- asks $ mkStoreCxt . config
|
||||
cxt <- chatStoreCxt
|
||||
contacts <- withFastStore' $ \db -> getUserContacts db cxt user'
|
||||
withChatLock "presentUserBadge" $ forM_ contacts $ \ct ->
|
||||
case contactSendConn_ ct of
|
||||
@@ -5839,8 +5834,8 @@ runRelayGroupLinkChecks user = do
|
||||
where
|
||||
checkRelayServedGroups = do
|
||||
cxt <- chatStoreCxt
|
||||
relayGroups <- withStore' $ \db -> getRelayServedGroups db cxt user
|
||||
forM_ relayGroups $ \gInfo@GroupInfo {groupProfile = gp} -> flip catchAllErrors eToView $ do
|
||||
relayGroups <- withStore $ \db -> getRelayServedGroups db cxt user
|
||||
forM_ relayGroups $ \g@(GIK gInfo@GroupInfo {groupProfile = gp} _) -> flip catchAllErrors eToView $ do
|
||||
case publicGroup gp of
|
||||
Just PublicGroupProfile {groupLink = sLnk} -> do
|
||||
(_, ContactLinkData _ UserContactData {relays = relayLinks}, _) <-
|
||||
@@ -5856,7 +5851,7 @@ runRelayGroupLinkChecks user = do
|
||||
else void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSActive RSInactive
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
sendRelayCapIfNeeded user gInfo
|
||||
sendRelayCapIfNeeded user g
|
||||
checkRelayInactiveGroups = do
|
||||
cxt <- chatStoreCxt
|
||||
ttl <- asks (relayInactiveTTL . config)
|
||||
|
||||
@@ -470,9 +470,9 @@ sndBadgeProof_ User {profile = LocalProfile {localBadge}} ph = case localBadge o
|
||||
_ -> pure Nothing
|
||||
|
||||
sndGroupChatBinding :: GroupInfo -> ShowGroupAsSender -> Maybe ByteString
|
||||
sndGroupChatBinding GroupInfo {groupKeys, membership = GroupMember {memberId}} asGroup
|
||||
| asGroup = (\PublicGroupKeys {publicGroupId} -> encodeChatBinding CBChannel $ smpEncode publicGroupId) <$> (groupKeys >>= publicGroupKeys)
|
||||
| otherwise = (\GroupKeys {memberPrivKey} -> encodeChatBinding CBGroup $ groupBindingData groupKeys memberId (C.publicKey memberPrivKey)) <$> groupKeys
|
||||
sndGroupChatBinding gInfo@GroupInfo {membership = GroupMember {memberId, memberPubKey}} asGroup
|
||||
| asGroup = (\PublicGroupProfile {publicGroupId} -> encodeChatBinding CBChannel $ smpEncode publicGroupId) <$> publicGroup' gInfo
|
||||
| otherwise = (\k -> encodeChatBinding CBGroup $ groupBindingData gInfo memberId k) <$> memberPubKey
|
||||
|
||||
cryptoFileDigest :: CryptoFile -> CM FD.FileDigest
|
||||
cryptoFileDigest (CryptoFile filePath cfArgs) = do
|
||||
@@ -1020,11 +1020,11 @@ acceptContactRequestAsync
|
||||
agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend Nothing) cReqPQSup subMode
|
||||
pure ct'
|
||||
|
||||
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 -> Int64 -> GroupInfoKeys -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
|
||||
acceptGroupJoinRequestAsync
|
||||
user@User {userId}
|
||||
uclId
|
||||
gInfo@GroupInfo {groupProfile, membership, businessChat}
|
||||
(GIK gInfo@GroupInfo {groupProfile, membership, businessChat} gks)
|
||||
cReqInvId
|
||||
cReqChatVRange
|
||||
cReqProfile
|
||||
@@ -1058,7 +1058,7 @@ acceptGroupJoinRequestAsync
|
||||
GroupLinkInvitation
|
||||
{ fromMember = MemberIdRole userMemberId userRole,
|
||||
fromMemberName = displayName,
|
||||
fromMemberKey = groupMemberKey gInfo,
|
||||
fromMemberKey = Just $ groupMemberKey gks,
|
||||
invitedMember = MemberIdRole memberId gLinkMemRole,
|
||||
groupProfile,
|
||||
accepted = Just gAccepted,
|
||||
@@ -1106,11 +1106,11 @@ acceptGroupJoinSendRejectAsync
|
||||
agentAcceptContactAsync cmdId acId False cReqInvId msg PQSupportOff subMode
|
||||
pure m
|
||||
|
||||
acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
|
||||
acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfoKeys -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
|
||||
acceptBusinessJoinRequestAsync
|
||||
user
|
||||
uclId
|
||||
gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}}
|
||||
(GIK gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}} gks)
|
||||
clientMember@GroupMember {groupMemberId, memberId}
|
||||
UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId} = do
|
||||
cxt <- chatStoreCxt
|
||||
@@ -1122,7 +1122,7 @@ acceptBusinessJoinRequestAsync
|
||||
GroupLinkInvitation
|
||||
{ fromMember = MemberIdRole userMemberId userRole,
|
||||
fromMemberName = displayName,
|
||||
fromMemberKey = groupMemberKey gInfo,
|
||||
fromMemberKey = Just $ groupMemberKey gks,
|
||||
invitedMember = MemberIdRole memberId GRMember,
|
||||
groupProfile = businessGroupProfile userProfile groupPreferences,
|
||||
accepted = Just GAAccepted,
|
||||
@@ -1197,15 +1197,15 @@ businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
|
||||
businessGroupProfile Profile {displayName, fullName, shortDescr, description, image} groupPreferences =
|
||||
GroupProfile {displayName, fullName, description, shortDescr, image, publicGroup = Nothing, groupPreferences = Just groupPreferences, memberAdmission = Nothing}
|
||||
|
||||
introduceToModerators :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToModerators cxt user gInfo@GroupInfo {groupId} m@GroupMember {memberRole, memberId} = do
|
||||
introduceToModerators :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
|
||||
introduceToModerators cxt user gInfo@(GIK g@GroupInfo {groupId} _) m@GroupMember {memberRole, memberId} = do
|
||||
forM_ (memberConn m) $ \mConn -> do
|
||||
let msg =
|
||||
if maxVersion (memberChatVRange m) >= groupKnockingVersion
|
||||
then XGrpLinkAcpt GAPendingReview memberRole memberId
|
||||
else XMsgNew $ mcSimple (MCText pendingReviewMessage)
|
||||
void $ sendDirectMemberMessage mConn msg groupId
|
||||
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
modMs <- withStore' $ \db -> getGroupModerators db cxt user g
|
||||
let rcpModMs = filter shouldIntroduceToMod modMs
|
||||
introduceMember user gInfo m rcpModMs (Just $ MSMember $ memberId' m)
|
||||
where
|
||||
@@ -1215,15 +1215,15 @@ introduceToModerators cxt user gInfo@GroupInfo {groupId} m@GroupMember {memberRo
|
||||
&& groupMemberId' mem /= groupMemberId' m
|
||||
&& maxVersion (memberChatVRange mem) >= groupKnockingVersion
|
||||
|
||||
introduceToAll :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToAll cxt user gInfo m = do
|
||||
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
|
||||
introduceToAll :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
|
||||
introduceToAll cxt user gInfo@(GIK g _) m = do
|
||||
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user g) (getMemberRelationsVector db m)
|
||||
let recipients = filter (shouldIntroduce m vector) members
|
||||
introduceMember user gInfo m recipients Nothing
|
||||
|
||||
introduceToRemaining :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToRemaining cxt user gInfo m = do
|
||||
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
|
||||
introduceToRemaining :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
|
||||
introduceToRemaining cxt user gInfo@(GIK g _) m = do
|
||||
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user g) (getMemberRelationsVector db m)
|
||||
let recipients = filter (shouldIntroduce m vector) members
|
||||
introduceMember user gInfo m recipients Nothing
|
||||
|
||||
@@ -1233,17 +1233,17 @@ shouldIntroduce m vec mem =
|
||||
&& groupMemberId' mem /= groupMemberId' m
|
||||
&& getRelation (indexInGroup mem) vec == MRNew
|
||||
|
||||
introduceMember :: User -> GroupInfo -> GroupMember -> [GroupMember] -> Maybe MsgScope -> CM ()
|
||||
introduceMember :: User -> GroupInfoKeys -> GroupMember -> [GroupMember] -> Maybe MsgScope -> CM ()
|
||||
introduceMember _ _ GroupMember {activeConn = Nothing} _ _ = throwChatError $ CEInternalError "member connection not active"
|
||||
introduceMember user gInfo toMember@GroupMember {activeConn = Just conn} introduceToMembers msgScope = do
|
||||
void . sendGroupMessage' user gInfo introduceToMembers $ XGrpMemNew (memberInfo gInfo toMember) msgScope
|
||||
introduceMember user gInfo@(GIK g _) toMember@GroupMember {activeConn = Just conn} introduceToMembers msgScope = do
|
||||
void . sendGroupMessage' user gInfo introduceToMembers $ XGrpMemNew (memberInfo g toMember) msgScope
|
||||
sendIntroductions introduceToMembers
|
||||
where
|
||||
sendIntroductions reMembers = do
|
||||
updateToMemberVector reMembers
|
||||
updateReMembersVectors reMembers
|
||||
shuffledReMembers <- liftIO $ shuffleMembers reMembers
|
||||
let events = map (memberIntroEvt gInfo) shuffledReMembers
|
||||
let events = map (memberIntroEvt g) shuffledReMembers
|
||||
forM_ (L.nonEmpty events) $ \events' ->
|
||||
sendGroupMemberMessages user gInfo conn events'
|
||||
updateToMemberVector :: [GroupMember] -> CM ()
|
||||
@@ -1272,11 +1272,11 @@ memberIntroEvt gInfo reMember =
|
||||
|
||||
-- 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 =
|
||||
serveRoster :: User -> GroupInfoKeys -> GroupMember -> CM ()
|
||||
serveRoster user gInfo@(GIK g _) member =
|
||||
when (member `supportsVersion` groupRosterVersion) $ do
|
||||
cxt <- chatStoreCxt
|
||||
withStore' (\db -> getStoredGroupRoster db gInfo) >>= \case
|
||||
withStore' (\db -> getStoredGroupRoster db g) >>= \case
|
||||
Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}, blob_, storedVer_) ->
|
||||
case J.eitherDecodeStrict' signedBody :: Either String (ChatMessage 'Json) of
|
||||
Left e -> logError $ "serveRoster: cannot decode saved roster message: " <> tshow e
|
||||
@@ -1297,24 +1297,24 @@ serveRoster user gInfo member =
|
||||
-- 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 :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
|
||||
introduceInChannel _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
|
||||
introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
|
||||
introduceInChannel cxt user g@(GIK gInfo _) subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
|
||||
(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
|
||||
void $ sendGroupMessage' user g modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
|
||||
withStore' $ \db ->
|
||||
setMemberVectorNewRelations db subscriber [(indexInGroup m, (IDSubjectIntroduced, MRIntroduced)) | m <- modMs]
|
||||
-- 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
|
||||
serveRoster user g 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
|
||||
sendGroupMemberMessages user g conn evts
|
||||
|
||||
userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
|
||||
userProfileInGroup user g = userProfileInGroup' user (Just g)
|
||||
@@ -1558,29 +1558,29 @@ splitFileDescr partSize lastSize rfdText = splitParts 1 rfdText
|
||||
then fileDescr :| []
|
||||
else fileDescr <| splitParts (partNo + 1) rest
|
||||
|
||||
setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfo -> CM (Maybe GroupLink)
|
||||
setGroupLinkData' nm user gInfo =
|
||||
withFastStore' (\db -> runExceptT $ getGroupLink db user gInfo) >>= \case
|
||||
setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfoKeys -> CM (Maybe GroupLink)
|
||||
setGroupLinkData' nm user gInfo@(GIK g _) =
|
||||
withFastStore' (\db -> runExceptT $ getGroupLink db user g) >>= \case
|
||||
Right gLink@GroupLink {shortLinkDataSet}
|
||||
| shortLinkDataSet -> Just <$> setGroupLinkData nm user gInfo gLink
|
||||
_ -> pure Nothing
|
||||
|
||||
setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM GroupLink
|
||||
setGroupLinkData nm user gInfo gLink = do
|
||||
setGroupLinkData :: NetworkRequestMode -> User -> GroupInfoKeys -> GroupLink -> CM GroupLink
|
||||
setGroupLinkData nm user g@(GIK gInfo _) gLink = do
|
||||
cxt <- chatStoreCxt
|
||||
(conn, groupRelays) <- withFastStore $ \db ->
|
||||
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
|
||||
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
|
||||
let (userLinkData, crClientData) = groupLinkData g 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) False Nothing)
|
||||
withFastStore' $ \db -> setGroupLinkShortLink db gLink sLnk
|
||||
|
||||
setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
|
||||
setGroupLinkDataAsync user gInfo gLink = do
|
||||
setGroupLinkDataAsync :: User -> GroupInfoKeys -> GroupLink -> CM ()
|
||||
setGroupLinkDataAsync user g@(GIK gInfo _) gLink = do
|
||||
cxt <- chatStoreCxt
|
||||
(conn, groupRelays) <- withStore $ \db ->
|
||||
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
|
||||
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
|
||||
let (userLinkData, crClientData) = groupLinkData g gLink groupRelays
|
||||
setAgentConnShortLinkAsync user conn userLinkData (Just crClientData)
|
||||
|
||||
connectToRelayAsync :: User -> GroupInfo -> ShortLinkContact -> CM ()
|
||||
@@ -1595,15 +1595,15 @@ connectToRelayAsync user gInfo relayLink = do
|
||||
newConnIds <- getAgentConnShortLinkAsync user CFGetRelayDataJoin Nothing relayLink
|
||||
withFastStore' $ \db -> createRelayMemberConnectionAsync db user gInfo relayMember relayLink newConnIds subMode
|
||||
|
||||
updatePublicGroupData :: User -> GroupInfo -> CM GroupInfo
|
||||
updatePublicGroupData user gInfo
|
||||
updatePublicGroupData :: User -> GroupInfo -> GroupKeys -> CM GroupInfo
|
||||
updatePublicGroupData user gInfo gks
|
||||
| useRelays' gInfo && memberRole' (membership gInfo) == GROwner = do
|
||||
cxt <- chatStoreCxt
|
||||
(gInfo', gLink) <- withStore $ \db -> do
|
||||
gInfo' <- updatePublicMemberCount db cxt user gInfo
|
||||
gLink <- getGroupLink db user gInfo'
|
||||
pure (gInfo', gLink)
|
||||
setGroupLinkDataAsync user gInfo' gLink
|
||||
setGroupLinkDataAsync user (GIK gInfo' gks) gLink
|
||||
pure gInfo'
|
||||
| useRelays' gInfo && isRelay (membership gInfo) = do
|
||||
cxt <- chatStoreCxt
|
||||
@@ -1647,14 +1647,14 @@ updateContactFromLinkData user ct@Contact {profile = profile@LocalProfile {conta
|
||||
verifyChanged = contactDomainVerified /= Just True || claimChanged
|
||||
|
||||
-- TODO [relays] owner: set owners on updating link data (multi-owner)
|
||||
groupLinkData :: GroupInfo -> GroupLink -> [GroupRelay] -> (UserConnLinkData 'CMContact, CRClientData)
|
||||
groupLinkData gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {publicMemberCount}, membership = GroupMember {memberId}, groupKeys} GroupLink {groupLinkId} groupRelays =
|
||||
groupLinkData :: GroupInfoKeys -> GroupLink -> [GroupRelay] -> (UserConnLinkData 'CMContact, CRClientData)
|
||||
groupLinkData (GIK gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {publicMemberCount}, membership = GroupMember {memberId}} gks) GroupLink {groupLinkId} groupRelays =
|
||||
let direct = not $ useRelays' gInfo
|
||||
relays = mapMaybe (\GroupRelay {relayLink} -> relayLink) groupRelays
|
||||
publicGroupData_ = PublicGroupData <$> publicMemberCount
|
||||
userData = encodeShortLinkData $ GroupShortLinkData {groupProfile, publicGroupData = publicGroupData_}
|
||||
owners = case groupKeys of
|
||||
Just GroupKeys {publicGroupKeys = Just PublicGroupKeys {groupRootKey = GRKPrivate rootPrivKey}, memberPrivKey} ->
|
||||
owners = case gks of
|
||||
GKPublicGroup {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey} ->
|
||||
let ownerId = unMemberId memberId
|
||||
ownerKey = C.publicKey memberPrivKey
|
||||
authOwnerSig = C.sign' rootPrivKey (ownerId <> C.encodePubKey ownerKey)
|
||||
@@ -2308,18 +2308,19 @@ createSndMessages idsEvents = do
|
||||
encodeMessage sharedMsgId =
|
||||
encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
|
||||
|
||||
groupMsgSigning :: Bool -> GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning
|
||||
groupMsgSigning sign GroupInfo {membership = GroupMember {memberId}, groupKeys} evt = case groupKeys of
|
||||
Just gks@GroupKeys {memberPrivKey} | shouldSign -> Just $ MsgSigning CBGroup bindingData KRMember memberPrivKey
|
||||
where
|
||||
tag = toCMEventTag evt
|
||||
shouldSign = requiresSignature tag || (sign && signableContent tag)
|
||||
bindingData = groupBindingData (Just gks) memberId (C.publicKey memberPrivKey)
|
||||
_ -> Nothing
|
||||
|
||||
groupBindingData :: Maybe GroupKeys -> MemberId -> C.PublicKeyEd25519 -> ByteString
|
||||
groupBindingData gks memberId memberKey = case gks >>= publicGroupKeys of
|
||||
Just PublicGroupKeys {publicGroupId} -> smpEncode (publicGroupId, memberId)
|
||||
groupMsgSigning :: Bool -> GroupInfoKeys -> ChatMsgEvent e -> Maybe MsgSigning
|
||||
groupMsgSigning sign (GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) evt
|
||||
| shouldSign = Just $ MsgSigning CBGroup bindingData KRMember memberPrivKey'
|
||||
| otherwise = Nothing
|
||||
where
|
||||
memberPrivKey' = memberPrivKey gks
|
||||
tag = toCMEventTag evt
|
||||
shouldSign = requiresSignature tag || (sign && signableContent tag)
|
||||
bindingData = groupBindingData gInfo memberId (C.publicKey memberPrivKey')
|
||||
|
||||
groupBindingData :: GroupInfo -> MemberId -> C.PublicKeyEd25519 -> ByteString
|
||||
groupBindingData gInfo memberId memberKey = case publicGroup' gInfo of
|
||||
Just PublicGroupProfile {publicGroupId} -> smpEncode (publicGroupId, memberId)
|
||||
Nothing -> smpEncode (memberId, memberKey)
|
||||
|
||||
type HistoryFile = (FileInvitation, RcvFileDescrText, Maybe UTCTime, Maybe BadgeProof)
|
||||
@@ -2330,11 +2331,11 @@ directChatBinding ct =
|
||||
encodeChatBinding CBDirect <$> withAgent (`getConnectionRatchetAdHash` aConnId conn)
|
||||
|
||||
rcvGroupChatBinding :: GroupInfo -> Maybe GroupMember -> ShowGroupAsSender -> Maybe BadgeProof -> Maybe ByteString
|
||||
rcvGroupChatBinding GroupInfo {groupKeys} m_ asGroup badge_ =
|
||||
case (groupKeys >>= publicGroupKeys, asGroup, m_) of
|
||||
(Just PublicGroupKeys {publicGroupId}, True, _) ->
|
||||
rcvGroupChatBinding gInfo m_ asGroup badge_ =
|
||||
case (publicGroup' gInfo, asGroup, m_) of
|
||||
(Just PublicGroupProfile {publicGroupId}, True, _) ->
|
||||
Just $ encodeChatBinding CBChannel $ smpEncode publicGroupId
|
||||
(Just PublicGroupKeys {publicGroupId}, False, Just GroupMember {memberId}) ->
|
||||
(Just PublicGroupProfile {publicGroupId}, False, Just GroupMember {memberId}) ->
|
||||
Just $ encodeChatBinding CBGroup $ smpEncode (publicGroupId, memberId)
|
||||
(Nothing, False, Just GroupMember {memberId, memberPubKey}) ->
|
||||
(\k -> encodeChatBinding CBGroup $ smpEncode (memberId, k)) <$> (memberPubKey <|> proofMemberKey memberId badge_)
|
||||
@@ -2387,21 +2388,13 @@ rcvFileProhibited binding_ FileInvitation {fileSize, fileBadge} = do
|
||||
then Nothing
|
||||
else Just FileProhibited {maxSize, badgeStatus = Just st}
|
||||
|
||||
createUserMemberKey :: GroupInfo -> CM GroupInfo
|
||||
createUserMemberKey gInfo@GroupInfo {groupId, membership, groupKeys}
|
||||
| useRelays' gInfo || isJust groupKeys = pure gInfo
|
||||
| otherwise = do
|
||||
(_, memberPrivKey) <- atomically . C.generateKeyPair =<< asks random
|
||||
withStore' $ \db -> setUserMemberKey db groupId (groupMemberId' membership) memberPrivKey
|
||||
pure gInfo {groupKeys = Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey}}
|
||||
groupMemberKey :: GroupKeys -> MemberKey
|
||||
groupMemberKey gks = MemberKey $ C.publicKey $ memberPrivKey gks
|
||||
|
||||
groupMemberKey :: GroupInfo -> Maybe MemberKey
|
||||
groupMemberKey GroupInfo {groupKeys} = MemberKey . C.publicKey . memberPrivKey <$> groupKeys
|
||||
|
||||
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfo -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
|
||||
sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do
|
||||
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfoKeys -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
|
||||
sendGroupMemberMessages user g@(GIK gInfo@GroupInfo {groupId} _) conn events = do
|
||||
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
|
||||
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False gInfo evt, evt)) events
|
||||
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False g evt, evt)) events
|
||||
(errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts
|
||||
unless (null errs) $ toView $ CEvtChatErrors errs
|
||||
forM_ (L.nonEmpty msgs) $ \msgs' ->
|
||||
@@ -2468,15 +2461,13 @@ encodeSignedConnInfo signing chatMsgEvent = do
|
||||
|
||||
-- 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 gks@GroupKeys {memberPrivKey} ->
|
||||
let xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey) (Just relayMemberId)
|
||||
bindingData = groupBindingData (Just gks) memberId (C.publicKey memberPrivKey)
|
||||
signing = MsgSigning CBGroup bindingData KRMember memberPrivKey
|
||||
in encodeSignedConnInfo signing xMemberEvt
|
||||
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
|
||||
encodeXMemberConnInfo :: GroupInfoKeys -> MemberId -> Profile -> CM ByteString
|
||||
encodeXMemberConnInfo (GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) relayMemberId profileToSend =
|
||||
let memberPrivKey' = memberPrivKey gks
|
||||
xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey') (Just relayMemberId)
|
||||
bindingData = groupBindingData gInfo memberId (C.publicKey memberPrivKey')
|
||||
signing = MsgSigning CBGroup bindingData KRMember memberPrivKey'
|
||||
in encodeSignedConnInfo signing xMemberEvt
|
||||
|
||||
deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
|
||||
deliverMessage conn cmEventTag msgBody msgId = do
|
||||
@@ -2539,13 +2530,13 @@ deliverMessagesB msgReqs = do
|
||||
where
|
||||
updatePQ = updateConnPQSndEnabled db connId pqSndEnabled'
|
||||
|
||||
sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> Bool -> ChatMsgEvent e -> CM SndMessage
|
||||
sendGroupMessage :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> [GroupMember] -> Bool -> ChatMsgEvent e -> CM SndMessage
|
||||
sendGroupMessage user gInfo gcScope members sign chatMsgEvent = do
|
||||
sendGroupMessages user gInfo gcScope False members sign (chatMsgEvent :| []) >>= \case
|
||||
((Right msg) :| [], _) -> pure msg
|
||||
_ -> throwChatError $ CEInternalError "sendGroupMessage: expected 1 message"
|
||||
|
||||
sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
|
||||
sendGroupMessage' :: MsgEncodingI e => User -> GroupInfoKeys -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
|
||||
sendGroupMessage' user gInfo members chatMsgEvent =
|
||||
sendGroupMessages_ user gInfo members False (chatMsgEvent :| []) >>= \case
|
||||
((Right msg) :| [], _) -> pure msg
|
||||
@@ -2571,8 +2562,8 @@ applyRosterDelta delta current = case delta of
|
||||
-- advances past a version the owner hasn't recorded), then broadcast the matching blob with the change projected
|
||||
-- onto the served roster (so it excludes demoted/removed members). Returns the reserved version for the delta
|
||||
-- that follows. The blob send is best-effort - a failed send heals on the next change or on resume.
|
||||
broadcastRoster :: User -> GroupInfo -> RosterDelta -> CM VersionRoster
|
||||
broadcastRoster user gInfo delta = do
|
||||
broadcastRoster :: User -> GroupInfoKeys -> RosterDelta -> CM VersionRoster
|
||||
broadcastRoster user g@(GIK gInfo _) delta = do
|
||||
let rosterVer = maybe (VersionRoster 0) (\(VersionRoster n) -> VersionRoster (n + 1)) (rosterVersion gInfo)
|
||||
withStore' $ \db -> setGroupRosterVersion db gInfo rosterVer
|
||||
sendRosterBlob rosterVer `catchAllErrors` eToView
|
||||
@@ -2583,18 +2574,18 @@ broadcastRoster user gInfo delta = do
|
||||
(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 $ applyRosterDelta delta rosterMems)
|
||||
sendRoster user g (L.toList relays') rosterVer (buildGroupRoster $ applyRosterDelta delta 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 =
|
||||
sendGroupRosterToRelay :: User -> GroupInfoKeys -> GroupMember -> CM ()
|
||||
sendGroupRosterToRelay user g@(GIK gInfo _) relayMember =
|
||||
forM_ (rosterVersion gInfo) $ \rosterVer -> do
|
||||
cxt <- chatStoreCxt
|
||||
rosterMems <- withStore' $ \db -> getGroupRosterMembers db cxt user gInfo
|
||||
sendRoster user gInfo [relayMember] rosterVer (buildGroupRoster rosterMems)
|
||||
sendRoster user g [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 -> GroupInfoKeys -> [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}
|
||||
@@ -2602,7 +2593,7 @@ sendRoster user gInfo members rosterVer roster = do
|
||||
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 -> GroupInfoKeys -> [GroupMember] -> SharedMsgId -> ByteString -> CM ()
|
||||
sendInlineBlobChunks user gInfo members sharedMsgId blob = do
|
||||
chSize <- fromIntegral <$> asks (fileChunkSize . config)
|
||||
go chSize 1 blob
|
||||
@@ -2615,8 +2606,8 @@ sendInlineBlobChunks user gInfo members sharedMsgId blob = do
|
||||
-- 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).
|
||||
sendRelayCapIfNeeded :: User -> GroupInfo -> CM ()
|
||||
sendRelayCapIfNeeded user gInfo = do
|
||||
sendRelayCapIfNeeded :: User -> GroupInfoKeys -> CM ()
|
||||
sendRelayCapIfNeeded user g@(GIK gInfo _) = do
|
||||
ChatConfig {webPreviewConfig} <- asks config
|
||||
let currentWebDomain = (\WebPreviewConfig {webDomain} -> webDomain) <$> webPreviewConfig
|
||||
sentWebDomain <- withStore' (`getRelaySentWebDomain` gInfo)
|
||||
@@ -2625,24 +2616,22 @@ sendRelayCapIfNeeded user gInfo = do
|
||||
owners <- withStore' $ \db -> getGroupOwners db cxt user gInfo
|
||||
let capableOwners = filter (\m -> memberCurrent m && m `supportsVersion` relayWebCapVersion) owners
|
||||
unless (null capableOwners) $ do
|
||||
void $ sendGroupMessage' user gInfo capableOwners (XGrpRelayCap RelayCapabilities {webDomain = currentWebDomain})
|
||||
void $ sendGroupMessage' user g capableOwners (XGrpRelayCap RelayCapabilities {webDomain = currentWebDomain})
|
||||
withStore' $ \db -> updateRelaySentWebDomain db gInfo currentWebDomain
|
||||
|
||||
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages user gInfo' scope asGroup members sign events = do
|
||||
gInfo <- createUserMemberKey gInfo'
|
||||
sendGroupMessages :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages user gInfo scope asGroup members sign events = do
|
||||
sendGroupProfileUpdate user gInfo scope asGroup members
|
||||
sendGroupMessages_ user gInfo members sign events
|
||||
|
||||
-- per-item signer variant of sendGroupMessages (used for per-item delete signing); preserves the profile-update prelude
|
||||
sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupSignedMessages user gInfo' scope asGroup members signedEvents = do
|
||||
gInfo <- createUserMemberKey gInfo'
|
||||
sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupSignedMessages user gInfo@(GIK g _) scope asGroup members signedEvents = do
|
||||
sendGroupProfileUpdate user gInfo scope asGroup members
|
||||
sendGroupSignedMessages_ gInfo members signedEvents
|
||||
sendGroupSignedMessages_ g members signedEvents
|
||||
|
||||
sendGroupProfileUpdate :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> CM ()
|
||||
sendGroupProfileUpdate user gInfo scope asGroup members =
|
||||
sendGroupProfileUpdate :: User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> CM ()
|
||||
sendGroupProfileUpdate user g@(GIK gInfo gks) scope asGroup members =
|
||||
-- TODO [knocking] send current profile to pending member after approval?
|
||||
when shouldSendProfileUpdate $
|
||||
sendProfileUpdate `catchAllErrors` eToView
|
||||
@@ -2661,7 +2650,7 @@ sendGroupProfileUpdate user gInfo scope asGroup members =
|
||||
sendProfileUpdate = do
|
||||
-- shouldSendProfileUpdate excludes incognito membership, so the badge is presented
|
||||
profileUpdate <- presentUserBadge user Nothing $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p
|
||||
void $ sendGroupMessage' user gInfo members $ XInfo profileUpdate (groupMemberKey gInfo)
|
||||
void $ sendGroupMessage' user g members $ XInfo profileUpdate (Just $ groupMemberKey gks)
|
||||
currentTs <- liftIO getCurrentTime
|
||||
withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
|
||||
|
||||
@@ -2671,9 +2660,9 @@ data GroupSndResult = GroupSndResult
|
||||
forwarded :: [GroupMember]
|
||||
}
|
||||
|
||||
sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages_ _user gInfo recipientMembers sign events =
|
||||
sendGroupSignedMessages_ gInfo recipientMembers $ L.map (\evt -> (groupMsgSigning sign gInfo evt, evt)) events
|
||||
sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfoKeys -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages_ _user gInfo@(GIK g _) recipientMembers sign events =
|
||||
sendGroupSignedMessages_ g recipientMembers $ L.map (\evt -> (groupMsgSigning sign gInfo evt, evt)) events
|
||||
|
||||
sendGroupSignedMessages_ :: MsgEncodingI e => GroupInfo -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents = do
|
||||
@@ -3046,10 +3035,10 @@ joinAgentConnectionAsync :: CommandId -> Bool -> ConnId -> Bool -> ConnectionReq
|
||||
joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode =
|
||||
withAgent $ \a -> joinConnectionAsync a (aCorrId cmdId) updateConn connId enableNtfs cReqUri cInfo PQSupportOff subMode
|
||||
|
||||
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> Maybe GroupInfo -> ChatMsgEvent e -> CM ()
|
||||
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> Maybe GroupInfoKeys -> ChatMsgEvent e -> CM ()
|
||||
allowAgentConnectionAsync user conn@Connection {pqSupport} confId gInfo_ msg = do
|
||||
let signing_ = case gInfo_ of
|
||||
Just gInfo | useRelays' gInfo || maxVersion (peerChatVRange conn) >= relayWebCapVersion -> groupMsgSigning False gInfo msg
|
||||
Just gInfo@(GIK g _) | useRelays' g || maxVersion (peerChatVRange conn) >= relayWebCapVersion -> groupMsgSigning False gInfo msg
|
||||
_ -> Nothing
|
||||
dm <- case signing_ of
|
||||
Just signing -> encodeSignedConnInfo signing msg
|
||||
@@ -3292,7 +3281,7 @@ createChatItems ::
|
||||
createChatItems user itemTs_ dirsCIContents = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
let itemTs = fromMaybe createdAt itemTs_
|
||||
cxt <- chatStoreCxt'
|
||||
cxt <- asks storeCxt
|
||||
void . withStoreBatch' $ \db -> map (updateChat db cxt createdAt) dirsCIContents
|
||||
withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents
|
||||
where
|
||||
@@ -3390,13 +3379,9 @@ waitChatStartedAndActivated = do
|
||||
unless (isJust started && activated) retry
|
||||
|
||||
chatStoreCxt :: CM StoreCxt
|
||||
chatStoreCxt = lift chatStoreCxt'
|
||||
chatStoreCxt = asks storeCxt
|
||||
{-# INLINE chatStoreCxt #-}
|
||||
|
||||
chatStoreCxt' :: CM' StoreCxt
|
||||
chatStoreCxt' = mkStoreCxt <$> asks config
|
||||
{-# INLINE chatStoreCxt' #-}
|
||||
|
||||
chatVersionRange :: CM VersionRangeChat
|
||||
chatVersionRange = lift chatVersionRange'
|
||||
{-# INLINE chatVersionRange #-}
|
||||
|
||||
@@ -115,9 +115,9 @@ smallGroupsRcptsMemLimit = 20
|
||||
|
||||
-- Verifies member signatures over CBGroup <> (publicGroupId, memberId) or (memberId, pubKey) <> signedBody under the given key.
|
||||
-- signatures is NonEmpty so the verification can't be vacuously true.
|
||||
verifyGroupSig :: C.PublicKeyEd25519 -> Maybe GroupKeys -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
|
||||
verifyGroupSig key gks memberId signatures signedBody =
|
||||
let prefix = encodeChatBinding CBGroup $ groupBindingData gks memberId key
|
||||
verifyGroupSig :: C.PublicKeyEd25519 -> GroupInfo -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
|
||||
verifyGroupSig key gInfo memberId signatures signedBody =
|
||||
let prefix = encodeChatBinding CBGroup $ groupBindingData gInfo memberId key
|
||||
in all (\case (MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 key) sig (prefix <> signedBody)) signatures
|
||||
|
||||
processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
|
||||
@@ -138,13 +138,18 @@ processAgentMessage corrId connId msg = do
|
||||
-- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
|
||||
-- as in this case no need to ACK message - we can't process messages for this connection anyway.
|
||||
critical connId (withStore $ getUserEntity cxt) >>= \case
|
||||
Just (user, entity) -> processAgentMessageConn cxt user entity corrId connId msg `catchAllErrors` eToView
|
||||
Just (user, entity, gks_) -> processAgentMessageConn cxt user entity gks_ corrId connId msg `catchAllErrors` eToView
|
||||
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
|
||||
where
|
||||
getUserEntity :: StoreCxt -> DB.Connection -> ExceptT StoreError IO (Maybe (User, ConnectionEntity))
|
||||
getUserEntity :: StoreCxt -> DB.Connection -> ExceptT StoreError IO (Maybe (User, ConnectionEntity, Maybe GroupKeys))
|
||||
getUserEntity cxt db =
|
||||
liftIO (getUserByAConnId db $ AgentConnId connId)
|
||||
>>= mapM (\user -> (user,) <$> (getConnectionEntity db cxt user (AgentConnId connId) >>= liftIO . updateConnStatus db))
|
||||
>>= mapM (\user -> do
|
||||
(entity, groupKeysData_) <- getConnectionEntityKeys db cxt user (AgentConnId connId)
|
||||
gks_ <- case entity of
|
||||
RcvGroupMsgConnection _ gInfo _ -> mapM (mkGroupKeys db cxt gInfo) groupKeysData_
|
||||
_ -> pure Nothing
|
||||
(user,,gks_) <$> liftIO (updateConnStatus db entity))
|
||||
|
||||
updateConnStatus :: DB.Connection -> ConnectionEntity -> IO ConnectionEntity
|
||||
updateConnStatus db acEntity = case agentMsgConnStatus (entityConnection acEntity) msg of
|
||||
@@ -431,8 +436,8 @@ processAgentMsgRcvFile _corrId aFileId msg = do
|
||||
|
||||
type ShouldDeleteGroupConns = Bool
|
||||
|
||||
processAgentMessageConn :: StoreCxt -> User -> ConnectionEntity -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
|
||||
processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMessage =
|
||||
processAgentMessageConn :: StoreCxt -> User -> ConnectionEntity -> Maybe GroupKeys -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
|
||||
processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId agentMessage =
|
||||
case agentMessage of
|
||||
END -> case entity of
|
||||
RcvDirectMsgConnection _ (Just ct) -> toView $ CEvtContactAnotherClient user ct
|
||||
@@ -441,8 +446,9 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
_ -> case entity of
|
||||
RcvDirectMsgConnection conn contact_ ->
|
||||
processDirectMessage agentMessage entity conn contact_
|
||||
RcvGroupMsgConnection conn gInfo m ->
|
||||
processGroupMessage agentMessage entity conn gInfo m
|
||||
RcvGroupMsgConnection conn gInfo m -> case gks_ of
|
||||
Just gks -> processGroupMessage agentMessage entity conn (GIK gInfo gks) m
|
||||
Nothing -> throwChatError $ CEInternalError "group connection entity without group keys"
|
||||
UserContactConnection conn uc ->
|
||||
processContactConnMessage agentMessage entity conn uc
|
||||
where
|
||||
@@ -497,10 +503,10 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
profileToSend <-
|
||||
presentUserBadge user incognitoProfile $ case gInfo_ of
|
||||
Just gInfo -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
|
||||
Just (GIK gInfo _) -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
|
||||
Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn'' confId gInfo_ $ XInfo profileToSend (groupMemberKey =<< gInfo_)
|
||||
allowAgentConnectionAsync user conn'' confId gInfo_ $ XInfo profileToSend ((\(GIK _ gks) -> groupMemberKey gks) <$> gInfo_)
|
||||
INFO pqSupport connInfo -> do
|
||||
processINFOpqSupport conn pqSupport
|
||||
void $ saveConnInfo conn connInfo
|
||||
@@ -620,6 +626,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
void $ withStore' $ \db -> resetMemberContactFields db ct'
|
||||
XGrpLinkInv glInv -> do
|
||||
-- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
|
||||
when (isPublicGroupInv glInv) $ throwChatError $ CEInvalidChatMessage conn'' Nothing (safeDecodeUtf8 connInfo) "x.grp.link.inv: publicGroup not allowed in p2p groups"
|
||||
memberKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
(gInfo, host) <- withStore $ \db -> do
|
||||
liftIO $ deleteContactCardKeepConn db connId ct
|
||||
@@ -628,7 +635,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
-- [incognito] send saved profile
|
||||
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
|
||||
allowAgentConnectionAsync user conn'' confId (Just gInfo) $ XInfo profileToSend (groupMemberKey gInfo)
|
||||
let gks = GKGroup {memberPrivKey = snd memberKeys}
|
||||
allowAgentConnectionAsync user conn'' confId (Just $ GIK gInfo gks) $ XInfo profileToSend (Just $ groupMemberKey gks)
|
||||
toView $ CEvtBusinessLinkConnecting user gInfo host ct
|
||||
_ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info"
|
||||
INFO pqSupport connInfo -> do
|
||||
@@ -754,8 +762,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci]
|
||||
|
||||
processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM ()
|
||||
processGroupMessage agentMsg connEntity conn@Connection {connId, customUserProfileId, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of
|
||||
processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfoKeys -> GroupMember -> CM ()
|
||||
processGroupMessage agentMsg connEntity conn@Connection {connId, customUserProfileId, connectionCode} g@(GIK gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} gks) m = case agentMsg of
|
||||
INV (ACR _ cReq) ->
|
||||
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} ->
|
||||
case cReq of
|
||||
@@ -780,7 +788,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
||||
forM_ mKey $ \(MemberKey k) -> withStore' $ \db -> setMemberPubKey db (groupMemberId' m) k
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn' confId (Just gInfo) XOk
|
||||
allowAgentConnectionAsync user conn' confId (Just g) XOk
|
||||
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
|
||||
XGrpRelayAcpt relayLink relayCap
|
||||
| memberRole' membership == GROwner && isRelay m -> do
|
||||
@@ -800,7 +808,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
liftIO $ updateGroupMemberStatus db userId m GSMemLeft
|
||||
pure (relay', m {memberStatus = GSMemLeft})
|
||||
-- complete the contact handshake so the relay receives INFO and cleans up its transient bookkeeping
|
||||
allowAgentConnectionAsync user conn' confId (Just gInfo) XOk
|
||||
allowAgentConnectionAsync user conn' confId (Just g) XOk
|
||||
toView $ CEvtGroupRelayUpdated user gInfo m' relay'
|
||||
toViewTE $ TERelayRejected user gInfo reason
|
||||
| otherwise -> messageError "x.grp.relay.reject: only owner should receive relay rejection"
|
||||
@@ -812,12 +820,11 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
pgId = fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId),
|
||||
useRelays' gInfo == isJust rcvPG && pgId rcvPG == pgId curPG -> do
|
||||
-- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records
|
||||
(gInfo'', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
|
||||
gInfo' <- createUserMemberKey gInfo''
|
||||
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
|
||||
-- [incognito] send saved profile
|
||||
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo' (fromLocalProfile <$> incognitoProfile)
|
||||
allowAgentConnectionAsync user conn' confId (Just gInfo') $ XInfo profileToSend (groupMemberKey gInfo')
|
||||
allowAgentConnectionAsync user conn' confId (Just $ GIK gInfo' gks) $ XInfo profileToSend (Just $ groupMemberKey gks)
|
||||
toView $ CEvtGroupLinkConnecting user gInfo' m'
|
||||
| otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch"
|
||||
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
|
||||
@@ -833,7 +840,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
-- TODO update member profile
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn' confId (Just gInfo) $ XGrpMemInfo membershipMemId membershipProfile
|
||||
allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo membershipMemId membershipProfile
|
||||
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
||||
_ -> messageError "CONF from member must have x.grp.mem.info"
|
||||
INFO _pqSupport connInfo -> do
|
||||
@@ -914,12 +921,12 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
Nothing -> do
|
||||
withStore' $ \db -> setGroupRosterVersion db gInfo (VersionRoster 0)
|
||||
pure gInfo {rosterVersion = Just (VersionRoster 0)}
|
||||
sendGroupRosterToRelay user gInfo' m
|
||||
sendGroupRosterToRelay user (GIK gInfo' gks) 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
|
||||
setGroupLinkDataAsync user g gLink
|
||||
| otherwise -> do
|
||||
(gInfo', mStatus) <-
|
||||
if not (memberPending m)
|
||||
@@ -940,26 +947,25 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo'' m'
|
||||
if useRelays' gInfo''
|
||||
then do
|
||||
introduceInChannel cxt user gInfo'' m'
|
||||
introduceInChannel cxt user (GIK gInfo'' gks) m'
|
||||
case mStatus of
|
||||
GSMemPendingApproval -> pure ()
|
||||
GSMemPendingReview -> pure ()
|
||||
_ -> when (groupFeatureAllowed SGFHistory gInfo'') $ sendHistory user gInfo'' m'
|
||||
else case mStatus of
|
||||
GSMemPendingApproval -> pure ()
|
||||
GSMemPendingReview -> introduceToModerators cxt user gInfo'' m'
|
||||
GSMemPendingReview -> introduceToModerators cxt user (GIK gInfo'' gks) m'
|
||||
_ -> do
|
||||
introduceToAll cxt user gInfo'' m'
|
||||
introduceToAll cxt user (GIK gInfo'' gks) m'
|
||||
let memberIsCustomer = case businessChat gInfo'' of
|
||||
Just BusinessChatInfo {chatType = BCCustomer, customerId} -> memberId' m' == customerId
|
||||
_ -> False
|
||||
when (groupFeatureAllowed SGFHistory gInfo'' && not memberIsCustomer) $ sendHistory user gInfo'' m'
|
||||
where
|
||||
sendXGrpLinkMem gInfo''' m' = do
|
||||
gInfo'' <- createUserMemberKey gInfo'''
|
||||
sendXGrpLinkMem gInfo'' m' = do
|
||||
let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo''
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo'' (fromIncognitoProfile <$> incognitoProfile)
|
||||
sendGroupMemberMessages user gInfo'' conn [XGrpLinkMem profileToSend (groupMemberKey gInfo'')]
|
||||
sendGroupMemberMessages user (GIK gInfo'' gks) conn [XGrpLinkMem profileToSend (Just $ groupMemberKey gks)]
|
||||
_ -> do
|
||||
unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected
|
||||
notifyMemberConnected gInfo m Nothing
|
||||
@@ -1023,7 +1029,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
case fwd_ of
|
||||
Just fwd | SJson <- enc -> do
|
||||
logInfo $ "group fwd=" <> tshow tag <> " " <> eInfo
|
||||
xGrpMsgForward gInfo' scopeInfo m' fwd parsedMsg brokerTs
|
||||
xGrpMsgForward (GIK gInfo' gks) scopeInfo m' fwd parsedMsg brokerTs
|
||||
`catchAllErrors` \e -> eToView e
|
||||
pure newDeliveryTasks
|
||||
-- direct JSON and binary messages; binary events don't produce delivery tasks
|
||||
@@ -1074,36 +1080,36 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName
|
||||
XInfo p mKey -> fmap ctx <$> xInfoMember gInfo' m'' p mKey msg brokerTs
|
||||
XGrpLinkMem p mKey -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p mKey msg
|
||||
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs
|
||||
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt (GIK gInfo' gks) m'' acceptance role memberId msg brokerTs
|
||||
XGrpRelayNew rl -> fmap ctx <$> xGrpRelayNew gInfo' m'' rl
|
||||
XGrpRelayCap relayCap
|
||||
| memberRole' membership == GROwner && isRelay m'' ->
|
||||
Nothing <$ withStore' (\db -> updateRelayCapabilities db m'' relayCap)
|
||||
| otherwise -> Nothing <$ messageWarning "x.grp.relay.cap: only owner should receive relay capabilities"
|
||||
XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs
|
||||
XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew (GIK gInfo' gks) m'' memInfo msgScope msg brokerTs
|
||||
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 memberKey rosterVer -> fmap ctx <$> xGrpMemRole gInfo' Nothing m'' memId memRole memberKey rosterVer msg brokerTs
|
||||
XGrpMemRole memId memRole memberKey rosterVer -> fmap ctx <$> xGrpMemRole (GIK gInfo' gks) Nothing 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 rosterVer -> case encoding @e of
|
||||
SJson -> fmap ctx <$> xGrpMemDel gInfo' Nothing m'' memId withMessages rosterVer verifiedMsg msg brokerTs False
|
||||
SJson -> fmap ctx <$> xGrpMemDel (GIK gInfo' gks) Nothing m'' memId withMessages rosterVer verifiedMsg msg brokerTs False
|
||||
SBinary -> pure Nothing
|
||||
XGrpLeave -> fmap ctx <$> xGrpLeave gInfo' m'' msg brokerTs
|
||||
XGrpLeave -> fmap ctx <$> xGrpLeave (GIK gInfo' gks) 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
|
||||
XGrpInfo p' -> fmap ctx <$> xGrpInfo (GIK gInfo' gks) 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
|
||||
XGrpRosterRequest reqVer -> Nothing <$ xGrpRosterRequest gInfo' m'' reqVer
|
||||
XGrpRosterAck ackVer ackErr -> Nothing <$ xGrpRosterAck (GIK gInfo' gks) m'' ackVer ackErr
|
||||
XGrpRosterRequest reqVer -> Nothing <$ xGrpRosterRequest (GIK gInfo' gks) m'' reqVer
|
||||
-- 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
|
||||
XGrpMsgForward fwd msg' -> Nothing <$ xGrpMsgForward (GIK gInfo' gks) 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' m'' sharedMsgId chunk msgMeta
|
||||
BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup (GIK gInfo' gks) m'' sharedMsgId chunk msgMeta
|
||||
_ -> Nothing <$ messageError ("unsupported message: " <> tshow event)
|
||||
forM deliveryTaskContext_ $ \taskContext -> do
|
||||
let contentChanged :: CM ()
|
||||
@@ -1170,7 +1176,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
mapM_ toView fileEvent_
|
||||
unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis
|
||||
when continued $ do
|
||||
when (isUserGrpFwdRelay gInfo) $ serveRoster user gInfo m -- roster ahead of the resumed backlog
|
||||
when (isUserGrpFwdRelay gInfo) $ serveRoster user g 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)
|
||||
@@ -1241,7 +1247,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
withStore' $ \db -> updateConnLinkData db user conn cReq cReqHash groupLinkId chatV pqSup
|
||||
let incognitoProfile = fromLocalProfile <$> incognitoMembershipProfile gInfo
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo incognitoProfile
|
||||
dm <- encodeXMemberConnInfo gInfo relayMemberId profileToSend
|
||||
dm <- encodeXMemberConnInfo g relayMemberId profileToSend
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
(cmdId, connId') <- prepareAgentJoin user (Just conn) True cReq
|
||||
joinAgentConnectionAsync cmdId True connId' True cReq dm subMode
|
||||
@@ -1257,7 +1263,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
||||
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
|
||||
pure (confId, m', relay)
|
||||
allowAgentConnectionAsync user conn confId (Just gInfo) XOk
|
||||
allowAgentConnectionAsync user conn confId (Just g) XOk
|
||||
toView $ CEvtGroupRelayUpdated user gInfo m' relay
|
||||
else
|
||||
-- TODO [relays] owner: TBC failed RelayStatus?
|
||||
@@ -1266,7 +1272,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
QCONT -> do
|
||||
continued <- continueSending connEntity conn
|
||||
when continued $ do
|
||||
when (isUserGrpFwdRelay gInfo) $ serveRoster user gInfo m -- roster ahead of the resumed backlog
|
||||
when (isUserGrpFwdRelay gInfo) $ serveRoster user g 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)
|
||||
@@ -1311,9 +1317,9 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
_ -> pure Nothing
|
||||
sendGroupAutoReply mc = \case
|
||||
Just UserContactRequest {welcomeSharedMsgId = Just smId} ->
|
||||
void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
|
||||
void $ sendGroupMessage' user g [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
|
||||
_ -> do
|
||||
msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ mcSimple mc
|
||||
msg <- sendGroupMessage' user g [m] $ XMsgNew $ mcSimple mc
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndMsgContent mc)
|
||||
withStore' $ \db -> createGroupSndStatus db (chatItemId' ci) (groupMemberId' m) GSSNew
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing) ci]
|
||||
@@ -1340,7 +1346,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
r n'' = Just (ci, CIRcvDecryptionError mde n'')
|
||||
mdeUpdatedCI _ _ = Nothing
|
||||
|
||||
receiveFileChunk :: Maybe GroupInfo -> RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
|
||||
receiveFileChunk :: Maybe GroupInfoKeys -> 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
|
||||
@@ -1408,13 +1414,13 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
CFSetShortLink ->
|
||||
case (ucGroupId_, auData) of
|
||||
(Just groupId, UserContactLinkData UserContactData {relays = relayLinks}) -> do
|
||||
(gInfo, gLink, relays, relaysChanged, newlyActiveLinks) <- withStore $ \db -> do
|
||||
gInfo <- getGroupInfo db cxt user groupId
|
||||
(g@(GIK gInfo _), gLink, relays, relaysChanged, newlyActiveLinks) <- withStore $ \db -> do
|
||||
g@(GIK gInfo _) <- getGroupInfoKeys db cxt user groupId
|
||||
gLink <- getGroupLink db user gInfo
|
||||
relays <- liftIO $ getGroupRelays db gInfo
|
||||
(relays', changed, newlyActiveLinks) <- liftIO $ foldrM (updateRelay db) ([], False, []) relays
|
||||
liftIO $ setGroupInProgressDone db gInfo
|
||||
pure (gInfo, gLink, relays', changed, newlyActiveLinks)
|
||||
pure (g, gLink, relays', changed, newlyActiveLinks)
|
||||
toView $ CEvtGroupLinkDataUpdated user gInfo gLink relays relaysChanged
|
||||
let GroupSummary {publicMemberCount} = groupSummary gInfo
|
||||
-- Owner is counted in publicMemberCount; > 1 means at least one subscriber.
|
||||
@@ -1430,7 +1436,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
allRelayMembers
|
||||
events = XGrpRelayNew <$> newlyActive
|
||||
unless (null recipients) $
|
||||
void $ sendGroupMessages user gInfo Nothing False recipients False events
|
||||
void $ sendGroupMessages user g Nothing False recipients False events
|
||||
where
|
||||
updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool, [ShortLinkContact]) -> IO ([GroupRelay], Bool, [ShortLinkContact])
|
||||
updateRelay db relay@GroupRelay {relayLink, relayStatus} (acc, changed, newlyActiveLinks) =
|
||||
@@ -1479,7 +1485,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
REContact ct ->
|
||||
-- TODO [short links] update request msg
|
||||
toView $ CEvtContactRequestAlreadyAccepted user ct
|
||||
REBusinessChat gInfo _clientMember ->
|
||||
REBusinessChat (GIK gInfo _) _clientMember ->
|
||||
-- TODO [short links] update request msg
|
||||
toView $ CEvtBusinessRequestAlreadyAccepted user gInfo
|
||||
RSCurrentRequest prevUcr_ ucr@UserContactRequest {welcomeSharedMsgId} re_ -> case re_ of
|
||||
@@ -1513,8 +1519,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
else pure Nothing
|
||||
ct' <- acceptContactRequestAsync user uclId ct ucr incognitoProfile
|
||||
toView $ CEvtAcceptingContactRequest user ct'
|
||||
Just (REBusinessChat gInfo clientMember) -> do
|
||||
(_gInfo', _clientMember') <- acceptBusinessJoinRequestAsync user uclId gInfo clientMember ucr
|
||||
Just (REBusinessChat g@(GIK gInfo _) clientMember) -> do
|
||||
(_gInfo', _clientMember') <- acceptBusinessJoinRequestAsync user uclId g clientMember ucr
|
||||
let cd = CDGroupRcv gInfo Nothing clientMember
|
||||
void $ case prevUcr_ of
|
||||
Just UserContactRequest {requestSharedMsgId = prevSharedMsgId_} ->
|
||||
@@ -1606,7 +1612,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
-- ##### Group link join requests (don't create contact requests) #####
|
||||
Just gli@GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
|
||||
-- TODO [short links] deduplicate request by xContactId?
|
||||
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
|
||||
g@(GIK gInfo _) <- withStore $ \db -> getGroupInfoKeys db cxt user groupId
|
||||
if
|
||||
| useRelays' gInfo ->
|
||||
messageWarning $ "processContactConnMessage (group " <> groupName' gInfo <> "): ignored direct join request from " <> displayName <> " (group uses relays)"
|
||||
@@ -1617,7 +1623,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
maybe (pure $ Right (GAAccepted, gLinkMemRole)) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case
|
||||
Right (acceptance, useRole) -> do
|
||||
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode memberKey_ Nothing
|
||||
mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode memberKey_ Nothing
|
||||
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
|
||||
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
||||
toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem'
|
||||
@@ -1661,7 +1667,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
(_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
|
||||
g@(GIK gInfo _) <- withStore $ \db -> getGroupInfoKeys db cxt user groupId
|
||||
existing_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberByMemberId db cxt user gInfo joiningMemberId)
|
||||
case existing_ of
|
||||
Just rosterMem
|
||||
@@ -1669,21 +1675,21 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
-- 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)
|
||||
then acceptJoin g (Just rosterMem) (memberRole' rosterMem)
|
||||
else messageError "memberJoinRequestViaRelay: rejected join claiming privileged memberId (key mismatch or invalid signature)"
|
||||
_ -> acceptJoin gInfo Nothing gLinkMemRole
|
||||
_ -> acceptJoin g 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 gks) ->
|
||||
verifyKey gInfo rosterMem = case signedMsg_ of
|
||||
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} ->
|
||||
memberPubKey rosterMem == Just joiningKey
|
||||
&& verifyGroupSig joiningKey (Just gks) joiningMemberId signatures signedBody
|
||||
&& verifyGroupSig joiningKey gInfo 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_
|
||||
acceptJoin g@(GIK gInfo _) existingMem_ acceptRole = do
|
||||
mem <- acceptGroupJoinRequestAsync user uclId g 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'
|
||||
@@ -2592,8 +2598,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
-- 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
|
||||
bFileChunkGroup :: GroupInfoKeys -> GroupMember -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
|
||||
bFileChunkGroup gInfo@(GIK 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
|
||||
@@ -2613,7 +2619,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
|
||||
-- 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 :: GroupInfoKeys -> RcvFileTransfer -> MsgMeta -> FileChunk -> CM ()
|
||||
receiveRosterChunk gInfo ft meta chunk = do
|
||||
case chunk of
|
||||
FileChunk {chunkNo} | chunkNo == 1 -> do
|
||||
@@ -2678,14 +2684,14 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
||||
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
|
||||
memberKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId memberKeys
|
||||
(GIK gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership} gks, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId memberKeys
|
||||
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
|
||||
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
|
||||
-- hostContact is only reported for group links, where the client replaces
|
||||
-- the transient host connection view with the group and removes its chat
|
||||
joinGroupAsync hostContact_ sameLink = do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (groupMemberKey gInfo)
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (Just $ groupMemberKey gks)
|
||||
connIds@(cmdId, acId) <- prepareAgentJoin user Nothing True connRequest
|
||||
withStore' $ \db -> do
|
||||
when sameLink $ setViaGroupLinkUri db groupId connId
|
||||
@@ -2815,11 +2821,11 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
| otherwise -> messageError "member key not signed by that key, ignored"
|
||||
where
|
||||
signed = case signedMsg_ of
|
||||
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} -> verifyGroupSig k (groupKeys gInfo) memberId signatures signedBody
|
||||
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} -> verifyGroupSig k gInfo memberId signatures signedBody
|
||||
_ -> False
|
||||
|
||||
xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
|
||||
xGrpLinkAcpt gInfo@GroupInfo {membership} m acceptance role memberId msg brokerTs
|
||||
xGrpLinkAcpt :: GroupInfoKeys -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
|
||||
xGrpLinkAcpt g@(GIK gInfo@GroupInfo {membership} _) m acceptance role memberId msg brokerTs
|
||||
| memberRole' m < GRModerator || memberRole' m < role =
|
||||
messageError "x.grp.link.acpt with insufficient member permissions"
|
||||
| sameMemberId memberId membership = processUserAccepted
|
||||
@@ -2868,7 +2874,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
GAPendingApproval ->
|
||||
messageWarning "x.grp.link.acpt: unexpected group acceptance - pending approval"
|
||||
introduceToRemainingMembers acceptedMember = do
|
||||
introduceToRemaining cxt user gInfo acceptedMember
|
||||
introduceToRemaining cxt user g acceptedMember
|
||||
when (groupFeatureAllowed SGFHistory gInfo) $ sendHistory user gInfo acceptedMember
|
||||
|
||||
maybeCreateGroupDescrLocal :: GroupInfo -> GroupMember -> CM ()
|
||||
@@ -3144,7 +3150,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
toView $ CEvtContactAndMemberAssociated user c2 g m1 c2'
|
||||
pure c2'
|
||||
|
||||
saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Maybe GroupInfo)
|
||||
saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Maybe GroupInfoKeys)
|
||||
saveConnInfo activeConn connInfo = do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
|
||||
conn' <- updatePeerChatVRange activeConn chatVRange
|
||||
@@ -3154,21 +3160,25 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
toView $ CEvtContactConnecting user ct
|
||||
pure (conn', Nothing)
|
||||
XGrpLinkInv glInv -> do
|
||||
when (isPublicGroupInv glInv) $ throwChatError $ CEInvalidChatMessage conn' Nothing (safeDecodeUtf8 connInfo) "x.grp.link.inv: publicGroup not allowed in p2p groups"
|
||||
memberKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db cxt user conn' memberKeys glInv
|
||||
toView $ CEvtGroupLinkConnecting user gInfo host
|
||||
pure (conn', Just gInfo)
|
||||
pure (conn', Just $ GIK gInfo GKGroup {memberPrivKey = snd memberKeys})
|
||||
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
|
||||
memberKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db cxt user conn' memberKeys glRjct
|
||||
toView $ CEvtGroupLinkConnecting user gInfo host
|
||||
toViewTE $ TEGroupLinkRejected user gInfo rejectionReason
|
||||
pure (conn', Just gInfo)
|
||||
pure (conn', Just $ GIK gInfo GKGroup {memberPrivKey = snd memberKeys})
|
||||
-- TODO show/log error, other events in SMP confirmation
|
||||
_ -> pure (conn', Nothing)
|
||||
|
||||
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _ assertedKey_) msgScope_ msg brokerTs = do
|
||||
isPublicGroupInv :: GroupLinkInvitation -> Bool
|
||||
isPublicGroupInv GroupLinkInvitation {groupProfile = GroupProfile {publicGroup}} = isJust publicGroup
|
||||
|
||||
xGrpMemNew :: GroupInfoKeys -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpMemNew (GIK gInfo gks) m memInfo@(MemberInfo memId memRole _ _ assertedKey_) msgScope_ msg brokerTs = do
|
||||
unless (useRelays' gInfo) $ checkHostRole m memRole
|
||||
if sameMemberId memId (membership gInfo)
|
||||
then pure Nothing
|
||||
@@ -3188,7 +3198,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
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
|
||||
gInfo' <- updatePublicGroupData user gInfo gks
|
||||
toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember
|
||||
memberAnnouncedToView updatedMember gInfo'
|
||||
pure $ deliveryJobScope updatedMember
|
||||
@@ -3203,7 +3213,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
|
||||
else pure gInfo
|
||||
pure (updatedMember, gInfo')
|
||||
gInfo'' <- updatePublicGroupData user gInfo'
|
||||
gInfo'' <- updatePublicGroupData user gInfo' gks
|
||||
toView $ CEvtUnknownMemberAnnounced user gInfo'' m unknownMember updatedMember
|
||||
memberAnnouncedToView updatedMember gInfo''
|
||||
pure $ deliveryJobScope updatedMember
|
||||
@@ -3221,7 +3231,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
|
||||
else pure gInfo
|
||||
pure (newMember, gInfo')
|
||||
gInfo'' <- updatePublicGroupData user gInfo'
|
||||
gInfo'' <- updatePublicGroupData user gInfo' gks
|
||||
memberAnnouncedToView newMember gInfo''
|
||||
pure $ deliveryJobScope newMember
|
||||
where
|
||||
@@ -3341,8 +3351,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
-- 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 -> Maybe GroupMember -> GroupMember -> Maybe VersionRoster -> CM (Maybe DeliveryJobScope) -> CM (Maybe DeliveryJobScope)
|
||||
applyAtRosterVersion gInfo fwdRelay_ sender rosterVer_ action
|
||||
applyAtRosterVersion :: GroupInfoKeys -> Maybe GroupMember -> GroupMember -> Maybe VersionRoster -> CM (Maybe DeliveryJobScope) -> CM (Maybe DeliveryJobScope)
|
||||
applyAtRosterVersion g@(GIK gInfo _) fwdRelay_ sender rosterVer_ action
|
||||
| not (useRelays' gInfo) = action
|
||||
| otherwise = case rosterVer_ of
|
||||
Nothing -> action
|
||||
@@ -3380,19 +3390,19 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
| otherwise = case fwdRelay_ of
|
||||
Just relay
|
||||
| gap, relay `supportsVersion` groupRosterVersion ->
|
||||
void $ sendGroupMessage' user gInfo [relay] (XGrpRosterRequest prevComplete)
|
||||
void $ sendGroupMessage' user g [relay] (XGrpRosterRequest prevComplete)
|
||||
_ -> pure ()
|
||||
where
|
||||
gap = v > nextCompleteVersion prevComplete
|
||||
|
||||
xGrpMemRole :: GroupInfo -> Maybe GroupMember -> GroupMember -> MemberId -> GroupMemberRole -> Maybe MemberKey -> Maybe VersionRoster -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpMemRole gInfo@GroupInfo {membership} fwdRelay_ m@GroupMember {memberRole = senderRole} memId memRole memberKey_ rosterVer_ msg@RcvMessage {msgSigned} brokerTs
|
||||
xGrpMemRole :: GroupInfoKeys -> Maybe GroupMember -> GroupMember -> MemberId -> GroupMemberRole -> Maybe MemberKey -> Maybe VersionRoster -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpMemRole g@(GIK gInfo@GroupInfo {membership} _) fwdRelay_ m@GroupMember {memberRole = senderRole} memId memRole memberKey_ rosterVer_ msg@RcvMessage {msgSigned} brokerTs
|
||||
| memRole == GRRelay = messageError "x.grp.mem.role: relay role can't be assigned" $> Nothing
|
||||
| membershipMemId == memId =
|
||||
applyAtRosterVersion gInfo fwdRelay_ m rosterVer_ $
|
||||
applyAtRosterVersion g fwdRelay_ m rosterVer_ $
|
||||
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
|
||||
in changeMemberRole gInfo' membership False (\db -> updateGroupMemberRole db user membership memRole) (RGEUserRole memRole) True
|
||||
| otherwise = applyAtRosterVersion gInfo fwdRelay_ m rosterVer_ $ do
|
||||
| otherwise = applyAtRosterVersion g fwdRelay_ 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_
|
||||
@@ -3486,8 +3496,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
|
||||
-- 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} =
|
||||
rosterCompletion :: GroupInfoKeys -> RcvFileTransfer -> CM ()
|
||||
rosterCompletion g@(GIK 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
|
||||
@@ -3497,7 +3507,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
let isRelay' = isUserGrpFwdRelay gInfo
|
||||
ackErr err = do
|
||||
cleanupRosterTransferById transferId
|
||||
when isRelay' $ forM_ owner_ $ \owner -> sendRosterAck gInfo owner pendingVer (Just err)
|
||||
when isRelay' $ forM_ owner_ $ \owner -> sendRosterAck g 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
|
||||
@@ -3522,7 +3532,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
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
|
||||
sendRosterAck g author pendingVer Nothing
|
||||
withStore' $ \db -> void $ updateRelayOwnStatusFromTo db gInfo RSAccepted RSAcknowledgedRoster
|
||||
where
|
||||
rosterFilePath = \case
|
||||
@@ -3588,11 +3598,11 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
else pure (gInfo, author)
|
||||
toView CEvtMemberRole {user, groupInfo = gInfo', byMember = author', member, fromRole, toRole, msgSigned = Just MSSVerified}
|
||||
|
||||
sendRosterAck :: GroupInfo -> GroupMember -> VersionRoster -> Maybe Text -> CM ()
|
||||
sendRosterAck :: GroupInfoKeys -> 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
|
||||
xGrpRosterAck :: GroupInfoKeys -> GroupMember -> VersionRoster -> Maybe Text -> CM ()
|
||||
xGrpRosterAck g@(GIK 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
|
||||
@@ -3602,7 +3612,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
relay' <- liftIO $ updateRelayStatus db relay RSAcknowledgedRoster
|
||||
gLink <- getGroupLink db user gInfo
|
||||
pure (relay', gLink)
|
||||
setGroupLinkDataAsync user gInfo gLink
|
||||
setGroupLinkDataAsync user g gLink
|
||||
toView $ CEvtGroupRelayUpdated user gInfo m relay'
|
||||
| otherwise -> messageWarning "x.grp.roster.ack: stale version, awaiting ack for the current roster"
|
||||
Just e -> do
|
||||
@@ -3616,13 +3626,13 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
-- - the latter bounds reflected amplification (a member can't re-trigger a full serve). Gating on the stored
|
||||
-- blob (not roster_version, the gate) means the relay serves only a blob the requester will accept.
|
||||
-- serveRoster records the served version (on all serve paths) and is a no-op without a roster.
|
||||
xGrpRosterRequest :: GroupInfo -> GroupMember -> Maybe VersionRoster -> CM ()
|
||||
xGrpRosterRequest gInfo m reqVer_ =
|
||||
xGrpRosterRequest :: GroupInfoKeys -> GroupMember -> Maybe VersionRoster -> CM ()
|
||||
xGrpRosterRequest g@(GIK gInfo _) m reqVer_ =
|
||||
when (isUserGrpFwdRelay gInfo) $ do
|
||||
(stored_, served_) <- withStore' $ \db ->
|
||||
(,) <$> getStoredRosterVersion db gInfo <*> getMemberRosterServedVersion db m
|
||||
forM_ stored_ $ \stored ->
|
||||
when (maybe True (stored >) reqVer_ && maybe True (stored >) served_) $ serveRoster user gInfo m
|
||||
when (maybe True (stored >) reqVer_ && maybe True (stored >) served_) $ serveRoster user g m
|
||||
|
||||
checkHostRole :: GroupMember -> GroupMemberRole -> CM ()
|
||||
checkHostRole GroupMember {memberRole, localDisplayName} memRole =
|
||||
@@ -3668,11 +3678,11 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
withStore $ \db -> setMemberVectorRelationConnected db sendingMem refMem MRSubjectConnected
|
||||
withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected
|
||||
|
||||
xGrpMemDel :: GroupInfo -> Maybe GroupMember -> GroupMember -> MemberId -> Bool -> Maybe VersionRoster -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
|
||||
xGrpMemDel gInfo@GroupInfo {membership} fwdRelay_ m@GroupMember {memberRole = senderRole} memId withMessages rosterVer_ verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do
|
||||
xGrpMemDel :: GroupInfoKeys -> Maybe GroupMember -> GroupMember -> MemberId -> Bool -> Maybe VersionRoster -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
|
||||
xGrpMemDel g@(GIK gInfo@GroupInfo {membership} gks) fwdRelay_ m@GroupMember {memberRole = senderRole} memId withMessages rosterVer_ verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do
|
||||
let GroupMember {memberId = membershipMemId} = membership
|
||||
if membershipMemId == memId
|
||||
then applyAtRosterVersion gInfo fwdRelay_ m rosterVer_ $ checkRole membership $ do
|
||||
then applyAtRosterVersion g fwdRelay_ 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
|
||||
@@ -3684,7 +3694,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
deleteMemberItem msg gInfo RGEUserDeleted
|
||||
toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned
|
||||
pure $ Just DJSGroup {jobSpec = DJRelayRemoved}
|
||||
else applyAtRosterVersion gInfo fwdRelay_ m rosterVer_ $
|
||||
else applyAtRosterVersion g fwdRelay_ m rosterVer_ $
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
|
||||
Left _ -> do
|
||||
messageError "x.grp.mem.del with unknown member ID"
|
||||
@@ -3710,7 +3720,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
fullyDeleteMemberRecord user gInfo deletedMember
|
||||
-- Undeleted "member connected" chat item will prevent deletion of member record.
|
||||
| otherwise -> deleteOrUpdateMemberRecord user gInfo deletedMember
|
||||
gInfo'' <- updatePublicGroupData user gInfo'
|
||||
gInfo'' <- updatePublicGroupData user gInfo' gks
|
||||
let wasDeleted = memberStatus == GSMemRemoved || memberStatus == GSMemLeft
|
||||
-- Clear forwardedByMember if it references the deleted member,
|
||||
-- as the member record was already deleted above.
|
||||
@@ -3752,12 +3762,12 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
| useRelays' gInfo = asks $ channelSubscriberRole . config
|
||||
| otherwise = pure GRAuthor
|
||||
|
||||
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpLeave gInfo m msg@RcvMessage {msgSigned} brokerTs = do
|
||||
xGrpLeave :: GroupInfoKeys -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpLeave (GIK gInfo gks) m msg@RcvMessage {msgSigned} brokerTs = do
|
||||
deleteMemberConnection m
|
||||
-- member record is not deleted to allow creation of "member left" chat item
|
||||
gInfo' <- updateMemberRecordDeleted user gInfo m GSMemLeft
|
||||
gInfo'' <- updatePublicGroupData user gInfo'
|
||||
gInfo'' <- updatePublicGroupData user gInfo' gks
|
||||
unless (muteEventInChannel gInfo'' m) $ do
|
||||
(gInfo''', m', scopeInfo) <- mkGroupChatScope gInfo'' m
|
||||
(ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo''' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEMemberLeft)
|
||||
@@ -3777,8 +3787,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
groupMsgToView cInfo ci
|
||||
toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m' msgSigned
|
||||
|
||||
xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpInfo g@GroupInfo {groupProfile = p@GroupProfile {publicGroup = pg}, businessChat} m@GroupMember {memberRole} p'@GroupProfile {publicGroup = pg'} msg@RcvMessage {msgSigned} brokerTs
|
||||
xGrpInfo :: GroupInfoKeys -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpInfo gik@(GIK g@GroupInfo {groupProfile = p@GroupProfile {publicGroup = pg}, businessChat} gks) m@GroupMember {memberRole} p'@GroupProfile {publicGroup = pg'} msg@RcvMessage {msgSigned} brokerTs
|
||||
| memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" $> Nothing
|
||||
| let pgId = fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId),
|
||||
useRelays' g && (isNothing pg' || pgId pg' /= pgId pg) = messageError "x.grp.info: publicGroupId mismatch for channel" $> Nothing
|
||||
@@ -3798,10 +3808,10 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
-- other owners receiving the update do not refresh the same link
|
||||
ChatConfig {updateGroupLinksFromApp} <- asks config
|
||||
unless (useRelays' g'' || updateGroupLinksFromApp) $
|
||||
void $ forkIO $ void $ setGroupLinkData' NRMBackground user g''
|
||||
void $ forkIO $ void $ setGroupLinkData' NRMBackground user (GIK g'' gks)
|
||||
Just _ -> updateGroupPrefs_ msgSigned g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
|
||||
-- relay advertises its web capability now that the owner's version is known (bumped by saveGroupRcvMsg)
|
||||
when (isRelay (membership g)) $ sendRelayCapIfNeeded user g
|
||||
when (isRelay (membership g)) $ sendRelayCapIfNeeded user gik
|
||||
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
|
||||
|
||||
xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> RcvMessage -> CM (Maybe DeliveryJobScope)
|
||||
@@ -3916,8 +3926,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
toViewTE $ TEContactVerificationReset user ct
|
||||
createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing
|
||||
|
||||
xGrpMsgForward :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> GrpMsgForward -> ParsedMsg 'Json -> UTCTime -> CM ()
|
||||
xGrpMsgForward gInfo scopeInfo m@GroupMember {localDisplayName} GrpMsgForward {fwdSender, fwdBrokerTs = msgTs} parsedMsg@(ParsedMsg _ _ chatMsg@ChatMessage {chatMsgEvent}) brokerTs = do
|
||||
xGrpMsgForward :: GroupInfoKeys -> Maybe GroupChatScopeInfo -> GroupMember -> GrpMsgForward -> ParsedMsg 'Json -> UTCTime -> CM ()
|
||||
xGrpMsgForward g@(GIK gInfo _) scopeInfo m@GroupMember {localDisplayName} GrpMsgForward {fwdSender, fwdBrokerTs = msgTs} parsedMsg@(ParsedMsg _ _ chatMsg@ChatMessage {chatMsgEvent}) brokerTs = do
|
||||
unless (isMemberGrpFwdRelay gInfo m) $ throwChatError (CEGroupContactRole localDisplayName)
|
||||
case fwdSender of
|
||||
FwdMember memberId memberName -> do
|
||||
@@ -3961,13 +3971,13 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId
|
||||
XInfo p mKey -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p mKey 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 memberKey rosterVer -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo (Just m) author memId memRole memberKey rosterVer rcvMsg msgTs
|
||||
XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew g author memInfo msgScope rcvMsg msgTs
|
||||
XGrpMemRole memId memRole memberKey rosterVer -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole g (Just m) author memId memRole memberKey rosterVer rcvMsg msgTs
|
||||
XGrpMemRestrict memId memRestrictions -> withAuthor XGrpMemRestrict_ $ \author -> void $ xGrpMemRestrict gInfo author memId memRestrictions rcvMsg msgTs
|
||||
XGrpMemDel memId withMessages rosterVer -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel gInfo (Just m) author memId withMessages rosterVer verifiedMsg rcvMsg msgTs True
|
||||
XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave gInfo author rcvMsg msgTs
|
||||
XGrpMemDel memId withMessages rosterVer -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel g (Just m) author memId withMessages rosterVer verifiedMsg rcvMsg msgTs True
|
||||
XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave g 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
|
||||
XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo g 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)
|
||||
@@ -3978,7 +3988,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author"
|
||||
|
||||
withVerifiedMsg :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a)
|
||||
withVerifiedMsg gInfo@GroupInfo {membership, groupKeys} scopeInfo member@GroupMember {memberPubKey, memberId} (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
|
||||
withVerifiedMsg gInfo@GroupInfo {membership} scopeInfo member@GroupMember {memberPubKey, memberId} (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
|
||||
case verified of
|
||||
Just verifiedMsg -> Just <$> action verifiedMsg
|
||||
Nothing -> do
|
||||
@@ -3988,7 +3998,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
|
||||
verified = case signedMsg_ of
|
||||
Just sm@SignedMsg {chatBinding, signatures, signedBody} -> case memberPubKey of
|
||||
Just pubKey -> case chatBinding of
|
||||
CBGroup -> signed MSSVerified <$ guard (verifyGroupSig pubKey groupKeys memberId signatures signedBody)
|
||||
CBGroup -> signed MSSVerified <$ guard (verifyGroupSig pubKey gInfo memberId signatures signedBody)
|
||||
_ -> signed MSSSignedNoKey <$ guard signatureOptional
|
||||
Nothing -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag)
|
||||
where
|
||||
@@ -4476,10 +4486,10 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
eToView e
|
||||
processRelayRequest :: GroupId -> RelayRequestData -> CM ()
|
||||
processRelayRequest groupId rrd = do
|
||||
(gInfo, groupLink_) <- withStore $ \db -> do
|
||||
gInfo <- getGroupInfo db cxt user groupId
|
||||
(g@(GIK gInfo _), groupLink_) <- withStore $ \db -> do
|
||||
g@(GIK gInfo _) <- getGroupInfoKeys db cxt user groupId
|
||||
groupLink_ <- liftIO $ runExceptT $ getGroupLink db user gInfo
|
||||
pure (gInfo, groupLink_)
|
||||
pure (g, groupLink_)
|
||||
-- Check if relay link already exists (recovery case)
|
||||
case groupLink_ of
|
||||
Right GroupLink {connLinkContact = CCLink _ sLnk_} ->
|
||||
@@ -4487,11 +4497,14 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
Just sLnk -> acceptOwnerConnection rrd gInfo sLnk
|
||||
Nothing -> throwChatError $ CEException "processRelayRequest: relay link doesn't have short link"
|
||||
Left _ -> do
|
||||
(gInfo', sLnk) <- getLinkDataCreateRelayLink rrd gInfo
|
||||
(gInfo', sLnk) <- getLinkDataCreateRelayLink rrd g
|
||||
acceptOwnerConnection rrd gInfo' sLnk
|
||||
where
|
||||
getLinkDataCreateRelayLink :: RelayRequestData -> GroupInfo -> CM (GroupInfo, ShortLinkContact)
|
||||
getLinkDataCreateRelayLink RelayRequestData {reqGroupLink} gInfo = do
|
||||
getLinkDataCreateRelayLink :: RelayRequestData -> GroupInfoKeys -> CM (GroupInfo, ShortLinkContact)
|
||||
getLinkDataCreateRelayLink RelayRequestData {reqGroupLink} (GIK gInfo gks) = do
|
||||
memberPrivKey' <- case gks of
|
||||
GKRelayRequest {memberPrivKey} -> pure memberPrivKey
|
||||
_ -> throwChatError $ CEException "getLinkDataCreateRelayLink: group is not a relay request"
|
||||
(FixedLinkData {linkEntityId, rootKey}, cData@(ContactLinkData _ UserContactData {owners}), _) <- getShortLinkConnReq' NRMBackground user reqGroupLink
|
||||
liftIO (decodeLinkUserData cData) >>= \case
|
||||
Nothing -> throwChatError $ CEException "getLinkDataCreateRelayLink: no group link data"
|
||||
@@ -4501,10 +4514,10 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
| B64UrlByteString entityId == publicGroupId -> pure pg
|
||||
_ -> throwChatError $ CEException "getLinkDataCreateRelayLink: linkEntityId does not match profile publicGroupId"
|
||||
validateGroupProfile gp
|
||||
((_, memberPrivKey), sLnk) <- createRelayLink gInfo
|
||||
sLnk <- createRelayLink gInfo (C.publicKey memberPrivKey', memberPrivKey')
|
||||
gInfo' <- withStore $ \db -> do
|
||||
void $ updateGroupProfile db user gInfo gp
|
||||
updateRelayGroupKeys db user gInfo pg rootKey memberPrivKey owners
|
||||
updateRelayGroupKeys db user gInfo pg rootKey owners
|
||||
getGroupInfo db cxt user groupId
|
||||
pure (gInfo', sLnk)
|
||||
where
|
||||
@@ -4512,14 +4525,13 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
validateGroupProfile _groupProfile = do
|
||||
-- TODO [relays] relay: validate group profile, verify owner's signature
|
||||
pure ()
|
||||
createRelayLink :: GroupInfo -> CM (C.KeyPairEd25519, ShortLinkContact)
|
||||
createRelayLink gi = do
|
||||
createRelayLink :: GroupInfo -> C.KeyPairEd25519 -> CM ShortLinkContact
|
||||
createRelayLink gi sigKeys = do
|
||||
let GroupInfo {membership} = gi
|
||||
GroupMember {memberId = MemberId relayMemId, memberProfile = p} = membership
|
||||
gVar <- asks random
|
||||
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
sigKeys <- atomically $ C.generateKeyPair gVar
|
||||
let crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
-- prepare link with relayMemId as linkEntityId (no server request)
|
||||
(ccLink, preparedParams) <- withAgent $ \a' -> prepareConnectionLink a' (aUserId user) sigKeys relayMemId True (Just crClientData) CR.IKPQOff False Nothing
|
||||
@@ -4534,7 +4546,7 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
-- TODO [relays] starting role should be communicated in protocol from owner to relays
|
||||
subRole <- asks $ channelSubscriberRole . config
|
||||
void $ withFastStore $ \db -> createGroupLink db gVar user gi connId ccLink' groupLinkId subRole subMode
|
||||
pure (sigKeys, sLnk)
|
||||
pure sLnk
|
||||
acceptOwnerConnection :: RelayRequestData -> GroupInfo -> ShortLinkContact -> CM ()
|
||||
acceptOwnerConnection RelayRequestData {relayInvId, reqChatVRange} gi relayLink = do
|
||||
ownerMember <- withStore $ \db -> getHostMember db cxt user groupId
|
||||
|
||||
@@ -12,6 +12,7 @@
|
||||
module Simplex.Chat.Store.Connections
|
||||
( getChatLockEntity,
|
||||
getConnectionEntity,
|
||||
getConnectionEntityKeys,
|
||||
getConnectionEntityByConnReq,
|
||||
getConnectionEntityViaShortLink,
|
||||
getContactConnEntityByConnReqHash,
|
||||
@@ -76,18 +77,23 @@ getChatLockEntity db agentConnId = do
|
||||
-- - from receiving: getConnectionEntity, getContactConnEntityByConnReqHash
|
||||
-- - from subscribing: getContactConnsToSub, getUCLConnsToSub, getMemberConnsToSub, getPendingConnsToSub
|
||||
getConnectionEntity :: DB.Connection -> StoreCxt -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
|
||||
getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
|
||||
getConnectionEntity db cxt user agentConnId = fst <$> getConnectionEntityKeys db cxt user agentConnId
|
||||
|
||||
getConnectionEntityKeys :: DB.Connection -> StoreCxt -> User -> AgentConnId -> ExceptT StoreError IO (ConnectionEntity, Maybe GroupKeysRow)
|
||||
getConnectionEntityKeys db cxt user@User {userId, userContactId} agentConnId = do
|
||||
c@Connection {connType, entityId} <- getConnection_
|
||||
case entityId of
|
||||
Nothing ->
|
||||
if connType == ConnContact
|
||||
then pure $ RcvDirectMsgConnection c Nothing
|
||||
then pure (RcvDirectMsgConnection c Nothing, Nothing)
|
||||
else throwError $ SEInternalError $ "connection " <> show connType <> " without entity"
|
||||
Just entId ->
|
||||
case connType of
|
||||
ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ entId c
|
||||
ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c
|
||||
ConnUserContact -> UserContactConnection c <$> getUserContact_ entId
|
||||
ConnMember -> do
|
||||
((gInfo, keysData), m) <- getGroupAndMember_ entId c
|
||||
pure (RcvGroupMsgConnection c gInfo m, Just keysData)
|
||||
ConnContact -> (,Nothing) . RcvDirectMsgConnection c . Just <$> getContactRec_ entId c
|
||||
ConnUserContact -> (,Nothing) . UserContactConnection c <$> getUserContact_ entId
|
||||
where
|
||||
getConnection_ :: ExceptT StoreError IO Connection
|
||||
getConnection_ = ExceptT $ do
|
||||
@@ -134,7 +140,7 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
|
||||
contactRequest = UserContactRequestRef <$> contactRequestId <*> (unBI <$> rejectionSupported_)
|
||||
groupDirectInv = toGroupDirectInvitation groupDirectInvRow
|
||||
in Contact {contactId, localDisplayName, profile, activeConn, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, preparedContact, contactRequestId, contactRequest, contactGroupMemberId, contactGrpInvSent, groupDirectInv, chatTags, chatItemTTL, uiThemes, chatDeleted, customData}
|
||||
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO ((GroupInfo, GroupKeysRow), GroupMember)
|
||||
getGroupAndMember_ groupMemberId c = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
gm <-
|
||||
@@ -178,8 +184,8 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
|
||||
AND mu.member_status NOT IN (?,?,?)
|
||||
|]
|
||||
(groupMemberId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
|
||||
liftIO $ bitraverse (addGroupChatTags db) pure gm
|
||||
toGroupAndMember :: UTCTime -> Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
|
||||
liftIO $ bitraverse (\(g, keysData) -> (,keysData) <$> addGroupChatTags db g) pure gm
|
||||
toGroupAndMember :: UTCTime -> Connection -> GroupInfoRow :. GroupMemberRow -> ((GroupInfo, GroupKeysRow), GroupMember)
|
||||
toGroupAndMember currentTs c (groupInfoRow :. memberRow) =
|
||||
let groupInfo = toGroupInfo currentTs cxt userContactId [] groupInfoRow
|
||||
member = toGroupMember currentTs userContactId memberRow
|
||||
|
||||
@@ -91,11 +91,12 @@ createOrUpdateContactRequest
|
||||
pure $ RSAcceptedRequest cr (REContact ct)
|
||||
Nothing ->
|
||||
liftIO (getAcceptedBusinessChat xContactId) >>= \case
|
||||
Just gInfo@GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
|
||||
Just (gInfo@GroupInfo {businessChat = Just BusinessChatInfo {customerId}}, keysData) -> do
|
||||
clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
|
||||
cr <- liftIO $ getContactRequestByXContactId xContactId
|
||||
pure $ RSAcceptedRequest cr (REBusinessChat gInfo clientMember)
|
||||
Just GroupInfo {businessChat = Nothing} -> throwError SEInvalidBusinessChatContactRequest
|
||||
gks <- mkGroupKeys db cxt gInfo keysData
|
||||
pure $ RSAcceptedRequest cr (REBusinessChat (GIK gInfo gks) clientMember)
|
||||
Just (GroupInfo {businessChat = Nothing}, _) -> throwError SEInvalidBusinessChatContactRequest
|
||||
-- 2) if no legacy accepted contact or business chat was found, next we try to find an existing request
|
||||
Nothing ->
|
||||
liftIO (getContactRequestByXContactId xContactId) >>= \case
|
||||
@@ -131,7 +132,7 @@ createOrUpdateContactRequest
|
||||
|]
|
||||
(userId, xContactId)
|
||||
mapM (addDirectChatTags db) ct_
|
||||
getAcceptedBusinessChat :: XContactId -> IO (Maybe GroupInfo)
|
||||
getAcceptedBusinessChat :: XContactId -> IO (Maybe (GroupInfo, GroupKeysRow))
|
||||
getAcceptedBusinessChat xContactId = do
|
||||
currentTs <- getCurrentTime
|
||||
g_ <-
|
||||
@@ -140,7 +141,7 @@ createOrUpdateContactRequest
|
||||
db
|
||||
(groupInfoQuery <> " WHERE g.business_xcontact_id = ? AND g.user_id = ? AND mu.contact_id = ?")
|
||||
(xContactId, userId, userContactId)
|
||||
mapM (addGroupChatTags db) g_
|
||||
forM g_ $ \(g, keysData) -> (,keysData) <$> addGroupChatTags db g
|
||||
getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest)
|
||||
getContactRequestByXContactId xContactId = do
|
||||
currentTs <- getCurrentTime
|
||||
@@ -214,7 +215,7 @@ createOrUpdateContactRequest
|
||||
pure $ RSCurrentRequest Nothing ucr (Just $ REContact ct)
|
||||
createBusinessChat = do
|
||||
let groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs $ preferences' user
|
||||
(gInfo@GroupInfo {groupId}, clientMember) <-
|
||||
(gInfo@(GIK GroupInfo {groupId} _), clientMember) <-
|
||||
createBusinessRequestGroup db cxt gVar user cReqChatVRange profile profileId ldn groupPreferences
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -302,11 +303,12 @@ createOrUpdateContactRequest
|
||||
ct <- getContact db cxt user contactId
|
||||
pure $ Just (REContact ct)
|
||||
(Nothing, Just businessGroupId) -> do
|
||||
gInfo <- getGroupInfo db cxt user businessGroupId
|
||||
(gInfo, keysData) <- getGroupInfoRow db cxt user businessGroupId
|
||||
case gInfo of
|
||||
GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
|
||||
clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
|
||||
pure $ Just (REBusinessChat gInfo clientMember)
|
||||
gks <- mkGroupKeys db cxt gInfo keysData
|
||||
pure $ Just (REBusinessChat (GIK gInfo gks) clientMember)
|
||||
_ -> throwError SEInvalidBusinessChatContactRequest
|
||||
(Nothing, Nothing) -> pure Nothing
|
||||
_ -> throwError $ SEInvalidContactRequestEntity contactRequestId
|
||||
|
||||
@@ -188,7 +188,7 @@ createConnReqConnection db userId acId preparedEntity_ cReq cReqHash sLnk xConta
|
||||
connId <- insertedRowId db
|
||||
case preparedEntity_ of
|
||||
-- For relay groups, setPreparedGroupLinkInfo_ is called via updatePreparedRelayedGroup before the relay loop
|
||||
Just (PCEGroup gInfo _) | not (useRelays' gInfo) ->
|
||||
Just (PCEGroup (GIK gInfo _) _) | not (useRelays' gInfo) ->
|
||||
setPreparedGroupLinkInfo_ db gInfo cReq cReqHash customUserProfileId Nothing currentTs
|
||||
_ -> pure ()
|
||||
pure
|
||||
|
||||
@@ -40,6 +40,7 @@ module Simplex.Chat.Store.Groups
|
||||
createGroupRejectedViaLink,
|
||||
setGroupInvitationChatItemId,
|
||||
getGroup,
|
||||
getGroupKeys_,
|
||||
getGroupInfoByUserContactLinkConnReq,
|
||||
getGroupInfoViaUserTarget,
|
||||
getGroupViaShortLinkToConnect,
|
||||
@@ -144,7 +145,7 @@ module Simplex.Chat.Store.Groups
|
||||
updatePreparedRelayedGroup,
|
||||
updatePublicMemberCount,
|
||||
setPublicMemberCount,
|
||||
updateGroupMemberKeys,
|
||||
setGroupRootKey,
|
||||
updateRelayGroupKeys,
|
||||
updateGroupMemberStatus,
|
||||
updateGroupMemberStatusById,
|
||||
@@ -376,26 +377,24 @@ setGroupLinkShortLink db gLnk@GroupLink {userContactLinkId, connLinkContact = CC
|
||||
pure gLnk {connLinkContact = CCLink connFullLink (Just shortLink), shortLinkDataSet = True, shortLinkLargeDataSet = BoolDef True}
|
||||
|
||||
-- | creates completely new group with a single member - the current user
|
||||
createNewGroup :: DB.Connection -> StoreCxt -> User -> GroupProfile -> Maybe Profile -> Bool -> MemberId -> Maybe GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
|
||||
createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays memberId groupKeys publicMemberCount_ = ExceptT $ do
|
||||
createNewGroup :: DB.Connection -> StoreCxt -> User -> GroupProfile -> Maybe Profile -> MemberId -> GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
|
||||
createNewGroup db cxt user@User {userId} groupProfile incognitoProfile memberId groupKeys publicMemberCount_ = ExceptT $ do
|
||||
let GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission} = groupProfile
|
||||
(groupType_, groupLink_, publicGroupId_) = case publicGroup of
|
||||
Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
|
||||
Nothing -> (Nothing, Nothing, Nothing)
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
useRelays = isPublicGroup groupKeys
|
||||
rosterVersion0 = if useRelays then Just (VersionRoster 0) else Nothing
|
||||
currentTs <- getCurrentTime
|
||||
customUserProfileId <- mapM (createIncognitoProfile_ db userId currentTs) incognitoProfile
|
||||
withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
|
||||
let (rootPrivKey_, rootPubKey_, memberPrivKey_) = case groupKeys of
|
||||
Nothing -> (Nothing, Nothing, Nothing)
|
||||
Just GroupKeys {publicGroupKeys, memberPrivKey} ->
|
||||
let (rpk, rpub) = case publicGroupKeys of
|
||||
Just PublicGroupKeys {groupRootKey} -> case groupRootKey of
|
||||
GRKPrivate pk -> (Just pk, Nothing)
|
||||
GRKPublic k -> (Nothing, Just k)
|
||||
Nothing -> (Nothing, Nothing)
|
||||
in (rpk, rpub, Just memberPrivKey)
|
||||
let (rootPrivKey_, rootPubKey_) = case groupKeys of
|
||||
GKPublicGroup {groupRootKey} -> case groupRootKey of
|
||||
GRKPrivate pk -> (Just pk, Nothing)
|
||||
GRKPublic k -> (Nothing, Just k)
|
||||
_ -> (Nothing, Nothing)
|
||||
memberPrivKey_ = Just $ memberPrivKey groupKeys
|
||||
groupId <- liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
@@ -423,7 +422,7 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
|
||||
:. (rootPrivKey_, rootPubKey_, memberPrivKey_, publicMemberCount_, rosterVersion0)
|
||||
)
|
||||
insertedRowId db
|
||||
let memberPubKey = C.publicKey . memberPrivKey <$> groupKeys
|
||||
let memberPubKey = Just $ C.publicKey $ memberPrivKey groupKeys
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole memberId GROwner) GCUserMember GSMemCreator IBUser customUserProfileId memberPubKey currentTs (vr cxt)
|
||||
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
|
||||
pure
|
||||
@@ -451,18 +450,17 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
|
||||
customData = Nothing,
|
||||
membersRequireAttention = 0,
|
||||
viaGroupLinkUri = Nothing,
|
||||
groupKeys,
|
||||
groupDomainVerified = Nothing
|
||||
}
|
||||
|
||||
-- | creates a new group record for the group the current user was invited to, or returns an existing one
|
||||
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> C.KeyPairEd25519 -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> C.KeyPairEd25519 -> ExceptT StoreError IO (GroupInfoKeys, GroupMemberId)
|
||||
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ _ = throwError $ SEContactNotReady localDisplayName
|
||||
createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, fromMemberKey, invitedMember, connRequest, groupProfile, business} incognitoProfileId memberKeys = do
|
||||
liftIO getInvitationGroupId_ >>= \case
|
||||
Nothing -> createGroupInvitation_
|
||||
Just gId -> do
|
||||
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db cxt user gId
|
||||
GIK gInfo@GroupInfo {membership, groupProfile = p'} gks <- getGroupInfoKeys db cxt user gId
|
||||
hostId <- getHostMemberId_ db user gId
|
||||
let GroupMember {groupMemberId, memberId, memberRole} = membership
|
||||
MemberIdRole {memberId = invMemberId, memberRole = invMemberRole} = invitedMember
|
||||
@@ -472,13 +470,13 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
|
||||
if p' == groupProfile
|
||||
then pure gInfo
|
||||
else updateGroupProfile db user gInfo groupProfile
|
||||
pure (gInfo', hostId)
|
||||
pure (GIK gInfo' gks, hostId)
|
||||
where
|
||||
getInvitationGroupId_ :: IO (Maybe Int64)
|
||||
getInvitationGroupId_ =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId)
|
||||
createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation_ :: ExceptT StoreError IO (GroupInfoKeys, GroupMemberId)
|
||||
createGroupInvitation_ = do
|
||||
let GroupProfile {displayName, fullName, shortDescr, description, image, groupPreferences, memberAdmission} = groupProfile
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
@@ -530,9 +528,9 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
|
||||
customData = Nothing,
|
||||
membersRequireAttention = 0,
|
||||
viaGroupLinkUri = Nothing,
|
||||
groupKeys = Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey = snd memberKeys},
|
||||
groupDomainVerified = Nothing
|
||||
},
|
||||
}
|
||||
`GIK` GKGroup {memberPrivKey = snd memberKeys},
|
||||
groupMemberId
|
||||
)
|
||||
|
||||
@@ -946,10 +944,13 @@ setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getGroup :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO Group
|
||||
getGroup db cxt user groupId = do
|
||||
gInfo <- getGroupInfo db cxt user groupId
|
||||
getGroup db cxt user groupId = fst <$> getGroupKeys_ db cxt user groupId
|
||||
|
||||
getGroupKeys_ :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO (Group, GroupKeys)
|
||||
getGroupKeys_ db cxt user groupId = do
|
||||
GIK gInfo gks <- getGroupInfoKeys db cxt user groupId
|
||||
members <- liftIO $ getGroupMembers db cxt user gInfo
|
||||
pure $ Group gInfo members
|
||||
pure (Group gInfo members, gks)
|
||||
|
||||
deleteGroupChatItems :: DB.Connection -> User -> GroupInfo -> IO ()
|
||||
deleteGroupChatItems db User {userId} GroupInfo {groupId} =
|
||||
@@ -1054,7 +1055,7 @@ getInProgressGroups db cxt user@User {userId} createdAtCutoff = do
|
||||
getBaseGroupDetails :: DB.Connection -> StoreCxt -> User -> Maybe ContactId -> Maybe Text -> IO [GroupInfo]
|
||||
getBaseGroupDetails db cxt User {userId, userContactId} _contactId_ search_ = do
|
||||
currentTs <- getCurrentTime
|
||||
map (toGroupInfo currentTs cxt userContactId [])
|
||||
map (toGroupInfo_ currentTs cxt userContactId [])
|
||||
<$> DB.query db (groupInfoQuery <> " " <> condition) (userId, userContactId, search, search, search, search)
|
||||
where
|
||||
condition =
|
||||
@@ -1361,11 +1362,11 @@ getGroupInvitation :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT St
|
||||
getGroupInvitation db cxt user groupId =
|
||||
getConnRec_ user >>= \case
|
||||
Just connRequest -> do
|
||||
groupInfo@GroupInfo {membership} <- getGroupInfo db cxt user groupId
|
||||
GIK groupInfo@GroupInfo {membership} groupKeys <- getGroupInfoKeys db cxt user groupId
|
||||
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
|
||||
hostId <- getHostMemberId_ db user groupId
|
||||
fromMember <- getGroupMember db cxt user groupId hostId
|
||||
pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo}
|
||||
pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo, groupKeys}
|
||||
_ -> throwError SEGroupInvitationNotFound
|
||||
where
|
||||
getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation)
|
||||
@@ -1695,12 +1696,6 @@ setGroupMemberKeyRole db GroupMember {groupMemberId} pubKey role = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE group_members SET member_pub_key = ?, member_role = ?, updated_at = ? WHERE group_member_id = ?" (pubKey, role, currentTs, groupMemberId)
|
||||
|
||||
setUserMemberKey :: DB.Connection -> GroupId -> GroupMemberId -> C.PrivateKeyEd25519 -> IO ()
|
||||
setUserMemberKey db groupId membershipId memberPrivKey = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE groups SET member_priv_key = ?, updated_at = ? WHERE group_id = ?" (memberPrivKey, currentTs, groupId)
|
||||
DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (C.publicKey memberPrivKey, currentTs, membershipId)
|
||||
|
||||
setMemberPubKey :: DB.Connection -> GroupMemberId -> C.PublicKeyEd25519 -> IO ()
|
||||
setMemberPubKey db groupMemberId pubKey = do
|
||||
currentTs <- getCurrentTime
|
||||
@@ -1914,13 +1909,13 @@ createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMemb
|
||||
groupPreferences = Nothing,
|
||||
memberAdmission = Nothing
|
||||
}
|
||||
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing Nothing currentTs
|
||||
(_, memberPrivKey) <- atomically $ C.generateKeyPair (drg cxt)
|
||||
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing (Just memberPrivKey) currentTs
|
||||
-- Store relay request data for recovery
|
||||
liftIO $ setRelayRequestData_ groupId currentTs
|
||||
ownerMemberId <- insertOwner_ currentTs groupId
|
||||
let relayMember = MemberIdRole relayMemberId GRRelay
|
||||
-- TODO [member keys] should relays use member keys?
|
||||
_membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing Nothing currentTs (vr cxt)
|
||||
_membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing (Just $ C.publicKey memberPrivKey) currentTs (vr cxt)
|
||||
ownerMember <- getGroupMember db cxt user groupId ownerMemberId
|
||||
g <- getGroupInfo db cxt user groupId
|
||||
pure (g, ownerMember)
|
||||
@@ -2015,16 +2010,17 @@ isRelayGroupRejected db User {userId} groupLink =
|
||||
(userId, groupLink, RSRejected)
|
||||
)
|
||||
|
||||
getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> IO [GroupInfo]
|
||||
getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> ExceptT StoreError IO [GroupInfoKeys]
|
||||
getRelayServedGroups db cxt User {userId, userContactId} = do
|
||||
currentTs <- getCurrentTime
|
||||
map (toGroupInfo currentTs cxt userContactId [])
|
||||
currentTs <- liftIO getCurrentTime
|
||||
rows <- liftIO $ map (toGroupInfo currentTs cxt userContactId [])
|
||||
<$> DB.query
|
||||
db
|
||||
( groupInfoQuery
|
||||
<> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.relay_own_status IN (?, ?, ?)"
|
||||
)
|
||||
(userId, userContactId, RSAccepted, RSAcknowledgedRoster, RSActive)
|
||||
forM rows $ \(g, keysData) -> GIK g <$> mkGroupKeys db cxt g keysData
|
||||
|
||||
getRelayPublishableGroups :: DB.Connection -> User -> IO [(Int64, B64UrlByteString, Maybe PublicGroupAccess)]
|
||||
getRelayPublishableGroups db User {userId, userContactId} =
|
||||
@@ -2062,7 +2058,7 @@ getRelayInactiveGroups :: DB.Connection -> StoreCxt -> User -> NominalDiffTime -
|
||||
getRelayInactiveGroups db cxt User {userId, userContactId} ttl = do
|
||||
currentTs <- getCurrentTime
|
||||
let cutoffTs = addUTCTime (- ttl) currentTs
|
||||
map (toGroupInfo currentTs cxt userContactId [])
|
||||
map (toGroupInfo_ currentTs cxt userContactId [])
|
||||
<$> DB.query
|
||||
db
|
||||
( groupInfoQuery
|
||||
@@ -2149,7 +2145,7 @@ createJoiningMemberConnection
|
||||
Connection {connId} <- createConnection_ db userId ConnMember (Just groupMemberId) agentConnId ConnNew chatV cReqChatVRange Nothing (Just uclId) Nothing 0 createdAt subMode PQSupportOff
|
||||
setCommandConnId db user cmdId connId
|
||||
|
||||
createBusinessRequestGroup :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createBusinessRequestGroup :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfoKeys, GroupMember)
|
||||
createBusinessRequestGroup
|
||||
db
|
||||
cxt
|
||||
@@ -2164,7 +2160,7 @@ createBusinessRequestGroup
|
||||
(groupId, membership@GroupMember {memberId = userMemberId}) <- insertGroup_ currentTs
|
||||
(groupMemberId, memberId) <- insertClientMember_ currentTs groupId membership
|
||||
liftIO $ DB.execute db "UPDATE groups SET business_member_id = ?, customer_member_id = ? WHERE group_id = ?" (userMemberId, memberId, groupId)
|
||||
groupInfo <- getGroupInfo db cxt user groupId
|
||||
groupInfo <- getGroupInfoKeys db cxt user groupId
|
||||
clientMember <- getGroupMemberById db cxt user groupMemberId
|
||||
pure (groupInfo, clientMember)
|
||||
where
|
||||
@@ -2250,14 +2246,14 @@ createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentCon
|
||||
-- which is used in single-connection flows.
|
||||
updatePreparedRelayedGroup ::
|
||||
DB.Connection -> StoreCxt -> User -> GroupInfo -> ConnReqContact -> ConnReqUriHash -> Maybe Profile ->
|
||||
C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> Maybe Int64 ->
|
||||
ExceptT StoreError IO GroupInfo
|
||||
updatePreparedRelayedGroup db cxt user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey memberPrivKey publicMemberCount_ = do
|
||||
C.PublicKeyEd25519 -> Maybe Int64 ->
|
||||
ExceptT StoreError IO GroupInfoKeys
|
||||
updatePreparedRelayedGroup db cxt user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey publicMemberCount_ = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
customUserProfileId <- liftIO $ mapM (createIncognitoProfile_ db userId currentTs) incognitoProfile
|
||||
liftIO $ setPreparedGroupLinkInfo_ db gInfo cReq cReqHash customUserProfileId publicMemberCount_ currentTs
|
||||
liftIO $ updateGroupMemberKeys db (groupId' gInfo) rootPubKey memberPrivKey (groupMemberId' $ membership gInfo)
|
||||
getGroupInfo db cxt user (groupId' gInfo)
|
||||
liftIO $ setGroupRootKey db (groupId' gInfo) rootPubKey
|
||||
getGroupInfoKeys db cxt user (groupId' gInfo)
|
||||
|
||||
updatePublicMemberCount :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ExceptT StoreError IO GroupInfo
|
||||
updatePublicMemberCount db cxt user GroupInfo {groupId} = do
|
||||
@@ -2284,23 +2280,15 @@ setPublicMemberCount db cxt user GroupInfo {groupId} publicCount = do
|
||||
liftIO $ DB.execute db "UPDATE groups SET public_member_count = ?, updated_at = ? WHERE group_id = ?" (publicCount, currentTs, groupId)
|
||||
getGroupInfo db cxt user groupId
|
||||
|
||||
updateGroupMemberKeys :: DB.Connection -> GroupId -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> GroupMemberId -> IO ()
|
||||
updateGroupMemberKeys db groupId rootPubKey memberPrivKey membershipGMId = do
|
||||
setGroupRootKey :: DB.Connection -> GroupId -> C.PublicKeyEd25519 -> IO ()
|
||||
setGroupRootKey db groupId rootPubKey = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?"
|
||||
(rootPubKey, memberPrivKey, currentTs, groupId)
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?"
|
||||
(C.publicKey memberPrivKey, currentTs, membershipGMId)
|
||||
DB.execute db "UPDATE groups SET root_pub_key = ?, updated_at = ? WHERE group_id = ?" (rootPubKey, currentTs, groupId)
|
||||
|
||||
updateRelayGroupKeys :: DB.Connection -> User -> GroupInfo -> PublicGroupProfile -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> [OwnerAuth] -> ExceptT StoreError IO ()
|
||||
updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType, groupLink, publicGroupId} rootPubKey memberPrivKey owners = do
|
||||
updateRelayGroupKeys :: DB.Connection -> User -> GroupInfo -> PublicGroupProfile -> C.PublicKeyEd25519 -> [OwnerAuth] -> ExceptT StoreError IO ()
|
||||
updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType, groupLink, publicGroupId} rootPubKey owners = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let membershipGMId = groupMemberId' $ membership gInfo
|
||||
groupId = groupId' gInfo
|
||||
let groupId = groupId' gInfo
|
||||
liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
@@ -2309,14 +2297,7 @@ updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType,
|
||||
WHERE group_profile_id IN (SELECT group_profile_id FROM groups WHERE user_id = ? AND group_id = ?)
|
||||
|]
|
||||
(groupType, groupLink, publicGroupId, currentTs, userId, groupId)
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?"
|
||||
(rootPubKey, memberPrivKey, currentTs, groupId)
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?"
|
||||
(C.publicKey memberPrivKey, currentTs, membershipGMId)
|
||||
setGroupRootKey db groupId rootPubKey
|
||||
-- TODO [relays] relay: if not found, create owner record (multi-owner)
|
||||
forM_ owners $ \OwnerAuth {ownerId, ownerKey} -> do
|
||||
ownerGMId <- getGroupMemberIdViaMemberId db user gInfo (MemberId ownerId)
|
||||
|
||||
@@ -1870,6 +1870,15 @@ Query:
|
||||
Plan:
|
||||
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query:
|
||||
UPDATE groups
|
||||
SET member_priv_key = COALESCE(member_priv_key, ?), updated_at = ?
|
||||
WHERE group_id = ?
|
||||
RETURNING member_priv_key
|
||||
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query:
|
||||
UPDATE groups
|
||||
SET relay_request_inv_id = ?,
|
||||
@@ -7587,10 +7596,22 @@ Query: SELECT member_id FROM group_members WHERE member_role = ? LIMIT 1
|
||||
Plan:
|
||||
SCAN group_members
|
||||
|
||||
Query: SELECT member_priv_key FROM groups
|
||||
Plan:
|
||||
SCAN groups
|
||||
|
||||
Query: SELECT member_pub_key FROM group_members WHERE local_display_name = ?
|
||||
Plan:
|
||||
SCAN group_members
|
||||
|
||||
Query: SELECT member_pub_key FROM group_members WHERE member_category = 'host'
|
||||
Plan:
|
||||
SCAN group_members
|
||||
|
||||
Query: SELECT member_pub_key FROM group_members WHERE member_category = 'user'
|
||||
Plan:
|
||||
SCAN group_members
|
||||
|
||||
Query: SELECT member_pub_key FROM group_members WHERE member_role = 'moderator'
|
||||
Plan:
|
||||
SCAN group_members
|
||||
@@ -7967,6 +7988,14 @@ Query: UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_m
|
||||
Plan:
|
||||
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE group_members SET member_pub_key = NULL WHERE member_category = 'host'
|
||||
Plan:
|
||||
SCAN group_members
|
||||
|
||||
Query: UPDATE group_members SET member_pub_key = NULL WHERE member_category = 'user'
|
||||
Plan:
|
||||
SCAN group_members
|
||||
|
||||
Query: UPDATE group_members SET member_relations_vector = set_member_vector_new_relation(member_relations_vector, ?, ?, ?), updated_at = ? WHERE group_member_id = ?
|
||||
Plan:
|
||||
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
|
||||
@@ -8059,6 +8088,10 @@ Query: UPDATE groups SET local_display_name = ?, updated_at = ? WHERE user_id =
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE groups SET member_priv_key = NULL
|
||||
Plan:
|
||||
SCAN groups
|
||||
|
||||
Query: UPDATE groups SET members_require_attention=1 WHERE group_id=?
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
@@ -8079,7 +8112,7 @@ Query: UPDATE groups SET request_shared_msg_id = ? WHERE group_id = ?
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?
|
||||
Query: UPDATE groups SET root_pub_key = ?, updated_at = ? WHERE group_id = ?
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
|
||||
@@ -694,18 +694,21 @@ type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, Ver
|
||||
|
||||
type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences) :. BadgeRow :. ContactDomainRow
|
||||
|
||||
toGroupInfo :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
|
||||
toGroupInfo :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> (GroupInfo, GroupKeysRow)
|
||||
toGroupInfo now cxt userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, rosterVersion, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri, groupDomainVerified) :. groupKeysRow :. userMemberRow) =
|
||||
let membership = (toGroupMember now userContactId userMemberRow) {memberChatVRange = vr cxt}
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
publicGroup = toPublicGroupProfile groupType_ groupLink_ publicGroupId_ (toPublicGroupAccess accessRow)
|
||||
groupKeys = toGroupKeys publicGroupId_ groupKeysRow
|
||||
groupProfile = GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission}
|
||||
businessChat = toBusinessChatInfo (toPublicGroupAccess accessRow >>= groupDomainClaim) businessRow
|
||||
preparedGroup = toPreparedGroup preparedGroupRow
|
||||
groupSummary = GroupSummary {currentMembers, publicMemberCount}
|
||||
in GroupInfo {groupId, useRelays = BoolDef useRelays, relayOwnStatus, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, preparedGroup, chatTags, chatItemTTL, uiThemes, groupSummary, rosterVersion, customData, membersRequireAttention, viaGroupLinkUri, groupKeys, groupDomainVerified = unBI <$> groupDomainVerified}
|
||||
gInfo = GroupInfo {groupId, useRelays = BoolDef useRelays, relayOwnStatus, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, preparedGroup, chatTags, chatItemTTL, uiThemes, groupSummary, rosterVersion, customData, membersRequireAttention, viaGroupLinkUri, groupDomainVerified = unBI <$> groupDomainVerified}
|
||||
in (gInfo, groupKeysRow)
|
||||
|
||||
toGroupInfo_ :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
|
||||
toGroupInfo_ now cxt userContactId chatTags row = fst $ toGroupInfo now cxt userContactId chatTags row
|
||||
|
||||
toPreparedGroup :: PreparedGroupRow -> Maybe PreparedGroup
|
||||
toPreparedGroup = \case
|
||||
@@ -733,13 +736,35 @@ toPublicGroupAccess (groupWebPage, groupDomain_, domainWebPage_, allowEmbedding_
|
||||
domainWebPage = maybe False unBI domainWebPage_
|
||||
allowEmbedding = maybe False unBI allowEmbedding_
|
||||
|
||||
toGroupKeys :: Maybe B64UrlByteString -> GroupKeysRow -> Maybe GroupKeys
|
||||
toGroupKeys publicGroupId_ (rootPrivKey, rootPubKey, memberPrivKey) =
|
||||
let publicGroupKeys = case (publicGroupId_, GRKPrivate <$> rootPrivKey <|> GRKPublic <$> rootPubKey) of
|
||||
(Just publicGroupId, Just groupRootKey) -> Just $ Just PublicGroupKeys {publicGroupId, groupRootKey}
|
||||
(Nothing, Nothing) -> Just Nothing
|
||||
_ -> Nothing -- invalid state, in which case messages won't be signed even if memberPrivKey is present
|
||||
in GroupKeys <$> publicGroupKeys <*> memberPrivKey
|
||||
mkGroupKeys :: DB.Connection -> StoreCxt -> GroupInfo -> GroupKeysRow -> ExceptT StoreError IO GroupKeys
|
||||
mkGroupKeys db cxt g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup}, membership} (rootPrivKey, rootPubKey, memberPrivKey_) = do
|
||||
memberPrivKey <- case memberPrivKey_ of
|
||||
Just k -> pure k
|
||||
Nothing -> do
|
||||
(_, k) <- atomically $ C.generateKeyPair (drg cxt)
|
||||
setUserMemberKey db groupId (groupMemberId' membership) k
|
||||
pure $ case (useRelays' g, isJust publicGroup, GRKPrivate <$> rootPrivKey <|> GRKPublic <$> rootPubKey) of
|
||||
(False, _, _) -> GKGroup {memberPrivKey}
|
||||
(True, True, Just groupRootKey) -> GKPublicGroup {groupRootKey, memberPrivKey}
|
||||
(True, True, Nothing) -> GKPreparedPublicGroup {memberPrivKey}
|
||||
(True, False, _) -> GKRelayRequest {memberPrivKey}
|
||||
|
||||
setUserMemberKey :: DB.Connection -> GroupId -> GroupMemberId -> C.PrivateKeyEd25519 -> ExceptT StoreError IO C.PrivateKeyEd25519
|
||||
setUserMemberKey db groupId membershipId newKey = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
memberPrivKey <-
|
||||
ExceptT . firstRow fromOnly (SEGroupNotFound groupId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
UPDATE groups
|
||||
SET member_priv_key = COALESCE(member_priv_key, ?), updated_at = ?
|
||||
WHERE group_id = ?
|
||||
RETURNING member_priv_key
|
||||
|]
|
||||
(newKey, currentTs, groupId)
|
||||
liftIO $ DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (C.publicKey memberPrivKey, currentTs, membershipId)
|
||||
pure memberPrivKey
|
||||
|
||||
toGroupMember :: UTCTime -> Int64 -> GroupMemberRow -> GroupMember
|
||||
toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, BI showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. profileRow :. (createdAt, updatedAt) :. (supportChatTs_, supportChatUnread, supportChatMemberAttention, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) =
|
||||
@@ -901,8 +926,18 @@ addGroupChatTags db g@GroupInfo {groupId} = do
|
||||
chatTags <- getGroupChatTags db groupId
|
||||
pure (g :: GroupInfo) {chatTags}
|
||||
|
||||
getGroupInfoKeys :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfoKeys
|
||||
getGroupInfoKeys db cxt user groupId = do
|
||||
(g@GroupInfo {membership}, keysData) <- getGroupInfoRow db cxt user groupId
|
||||
gks <- mkGroupKeys db cxt g keysData
|
||||
let membership' = membership {memberPubKey = Just $ C.publicKey $ memberPrivKey gks} :: GroupMember
|
||||
pure $ GIK (g :: GroupInfo) {membership = membership'} gks
|
||||
|
||||
getGroupInfo :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfo db cxt User {userId, userContactId} groupId = ExceptT $ do
|
||||
getGroupInfo db cxt user groupId = fst <$> getGroupInfoRow db cxt user groupId
|
||||
|
||||
getGroupInfoRow :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupKeysRow)
|
||||
getGroupInfoRow db cxt User {userId, userContactId} groupId = ExceptT $ do
|
||||
currentTs <- getCurrentTime
|
||||
chatTags <- getGroupChatTags db groupId
|
||||
firstRow (toGroupInfo currentTs cxt userContactId chatTags) (SEGroupNotFound groupId) $
|
||||
|
||||
+33
-21
@@ -30,7 +30,9 @@
|
||||
module Simplex.Chat.Types where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.STM (TVar)
|
||||
import Crypto.Number.Serialize (os2ip)
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
@@ -437,7 +439,7 @@ instance ToJSON ConnReqUriHash where
|
||||
|
||||
data RequestEntity
|
||||
= REContact Contact
|
||||
| REBusinessChat GroupInfo GroupMember
|
||||
| REBusinessChat GroupInfoKeys GroupMember
|
||||
|
||||
type RepeatRequest = Bool
|
||||
|
||||
@@ -479,17 +481,30 @@ groupRootPubKey :: GroupRootKey -> C.PublicKeyEd25519
|
||||
groupRootPubKey (GRKPrivate pk) = C.publicKey pk
|
||||
groupRootPubKey (GRKPublic pk) = pk
|
||||
|
||||
data GroupKeys = GroupKeys
|
||||
{ publicGroupKeys :: Maybe PublicGroupKeys,
|
||||
memberPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
data GroupKeys
|
||||
= GKGroup
|
||||
{ memberPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
| GKPublicGroup
|
||||
{ groupRootKey :: GroupRootKey,
|
||||
memberPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
| GKRelayRequest
|
||||
{ memberPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
| GKPreparedPublicGroup
|
||||
{ memberPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data PublicGroupKeys = PublicGroupKeys
|
||||
{ publicGroupId :: B64UrlByteString,
|
||||
groupRootKey :: GroupRootKey
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
isPublicGroup :: GroupKeys -> Bool
|
||||
isPublicGroup = \case
|
||||
GKGroup {} -> False
|
||||
GKPublicGroup {} -> True
|
||||
GKRelayRequest {} -> True
|
||||
GKPreparedPublicGroup {} -> True
|
||||
|
||||
data GroupInfoKeys = GIK GroupInfo GroupKeys
|
||||
|
||||
data GroupInfo = GroupInfo
|
||||
{ groupId :: GroupId,
|
||||
@@ -515,7 +530,6 @@ data GroupInfo = GroupInfo
|
||||
rosterVersion :: Maybe VersionRoster,
|
||||
membersRequireAttention :: Int,
|
||||
viaGroupLinkUri :: Maybe ConnReqContact,
|
||||
groupKeys :: Maybe GroupKeys,
|
||||
groupDomainVerified :: Maybe Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -523,6 +537,9 @@ data GroupInfo = GroupInfo
|
||||
useRelays' :: GroupInfo -> Bool
|
||||
useRelays' GroupInfo {useRelays} = isTrue useRelays
|
||||
|
||||
publicGroup' :: GroupInfo -> Maybe PublicGroupProfile
|
||||
publicGroup' g@GroupInfo {groupProfile = GroupProfile {publicGroup}} = if useRelays' g then publicGroup else Nothing
|
||||
|
||||
relayServesGroup :: GroupInfo -> Bool
|
||||
relayServesGroup GroupInfo {relayOwnStatus} = case relayOwnStatus of
|
||||
Just RSInactive -> False
|
||||
@@ -595,7 +612,7 @@ data GroupLink = GroupLink
|
||||
|
||||
data ContactOrGroup = CGContact Contact | CGGroup GroupInfo [GroupMember]
|
||||
|
||||
data PreparedChatEntity = PCEContact Contact | PCEGroup {groupInfo :: GroupInfo, hostMember :: GroupMember}
|
||||
data PreparedChatEntity = PCEContact Contact | PCEGroup {groupInfo :: GroupInfoKeys, hostMember :: GroupMember}
|
||||
|
||||
contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId)
|
||||
contactAndGroupIds = \case
|
||||
@@ -1145,7 +1162,8 @@ memberRestrictions m
|
||||
data ReceivedGroupInvitation = ReceivedGroupInvitation
|
||||
{ fromMember :: GroupMember,
|
||||
connRequest :: ConnReqInvitation,
|
||||
groupInfo :: GroupInfo
|
||||
groupInfo :: GroupInfo,
|
||||
groupKeys :: GroupKeys
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -2240,8 +2258,8 @@ type VersionChat = Version ChatVersion
|
||||
type VersionRangeChat = VersionRange ChatVersion
|
||||
|
||||
-- | Store-wide context passed to store functions in place of the bare `vr`
|
||||
-- parameter. Built from config by mkStoreCxt; more fields are added here over time.
|
||||
data StoreCxt = StoreCxt {vr :: VersionRangeChat, badgeKeys :: Map Int BBSPublicKey}
|
||||
-- parameter. Built from config by storeCxt; more fields are added here over time.
|
||||
data StoreCxt = StoreCxt {vr :: VersionRangeChat, badgeKeys :: Map Int BBSPublicKey, drg :: TVar ChaChaDRG}
|
||||
|
||||
pattern VersionChat :: Word16 -> VersionChat
|
||||
pattern VersionChat v = Version v
|
||||
@@ -2347,12 +2365,6 @@ instance FromJSON GroupSummary where
|
||||
parseJSON = $(JQ.mkParseJSON defaultJSON ''GroupSummary)
|
||||
omittedField = Just GroupSummary {currentMembers = 0, publicMemberCount = Nothing}
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GRK") ''GroupRootKey)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''PublicGroupKeys)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''GroupKeys)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''GroupInfo)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''Group)
|
||||
|
||||
@@ -42,7 +42,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Simplex.Chat.Controller (ChatController (..), CorsOrigin (..), PublishableGroup (..), WebPreviewConfig (..), WebPreviewState (..), mkStoreCxt)
|
||||
import Simplex.Chat.Controller (ChatController (..), CorsOrigin (..), PublishableGroup (..), WebPreviewConfig (..), WebPreviewState (..), storeCxt)
|
||||
import Simplex.Chat.Markdown (FormattedText (..), MarkdownList, parseMaybeMarkdownList)
|
||||
import Simplex.Chat.Messages
|
||||
( CChatItem (..),
|
||||
@@ -137,7 +137,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
|
||||
seedRoutinePending wps
|
||||
forever $ workerLoop wps `catchOwn` \e -> logError ("web preview worker error: " <> tshow e)
|
||||
where
|
||||
cxt = mkStoreCxt (config cc)
|
||||
cxt = storeCxt cc
|
||||
|
||||
workerLoop wps@WebPreviewState {priorityRender, filesToRemove, corsNeeded, routinePending, wakeSignal} = do
|
||||
drainRemovals
|
||||
@@ -262,7 +262,7 @@ renderGroupPreview WebPreviewConfig {webJsonDir, webPreviewItemCount} cc user gI
|
||||
pure $ corsEntry publicGroupId <$> publicGroupAccess
|
||||
Nothing -> pure Nothing
|
||||
where
|
||||
cxt = mkStoreCxt (config cc)
|
||||
cxt = storeCxt cc
|
||||
|
||||
channelContentChanged :: ChatController -> Int64 -> STM ()
|
||||
channelContentChanged cc gId =
|
||||
|
||||
Reference in New Issue
Block a user