add relays to link

2026-07-21 04:41:36 +00:00 · 2025-11-05 19:57:54 +04:00
parent 60cc8239f4
commit 5b2359bdb1
7 changed files with 122 additions and 50 deletions
@@ -800,6 +800,7 @@ data ChatEvent
  | CEvtChatItemDeletedNotFound {user :: User, contact :: Contact, sharedMsgId :: SharedMsgId}
  | CEvtUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact} -- there is the same command response
  | CEvtGroupLinkConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember}
+  | CEvtRelayAddedToLink {user :: User, groupInfo :: GroupInfo, relayMember :: GroupMember, groupLink :: GroupLink, groupRelays :: [GroupRelay]}
  | CEvtBusinessLinkConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, fromContact :: Contact}
  | CEvtSentGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember} -- there is the same command response
  | CEvtContactUpdated {user :: User, fromContact :: Contact, toContact :: Contact}
@@ -1186,8 +1186,7 @@ processChatCommand vr nm = \case
      pure $ CRContactConnectionDeleted user conn
    CTGroup | isNothing scope -> do
      gInfo@GroupInfo {membership} <- withFastStore $ \db -> getGroupInfo db vr user chatId
-      let GroupMember {memberRole = membershipMemRole} = membership
-      let isOwner = membershipMemRole == GROwner
+      let isOwner = memberRole' membership == GROwner
          canDelete = isOwner || not (memberCurrent membership)
      unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
      filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
@@ -1207,7 +1206,7 @@ processChatCommand vr nm = \case
        where
          getRecipients gInfo
            | useRelays' gInfo = do
-                relays <- withFastStore' $ \db -> getGroupRelays db vr user gInfo
+                relays <- withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
                pure (relays, relays)
            | otherwise = do
                ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
@@ -1641,7 +1640,7 @@ processChatCommand vr nm = \case
      ok user
      where
        getMembers db gInfo
-          | useRelays' gInfo = getGroupRelays db vr user gInfo
+          | useRelays' gInfo = getGroupRelayMembers db vr user gInfo
          | otherwise = getGroupMembers db vr user gInfo
    _ -> throwCmdError "not supported"
  APISetMemberSettings gId gMemberId settings -> withUser $ \user -> do
@@ -2644,7 +2643,7 @@ processChatCommand vr nm = \case
    where
      getRecipients user gInfo
        | useRelays' gInfo = do
-            relays <- withFastStore' $ \db -> getGroupRelays db vr user gInfo
+            relays <- withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
            pure (relays, relays)
        | otherwise = do
            ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
@@ -3421,12 +3420,12 @@ processChatCommand vr nm = \case
              recipients = filter memberCurrentOrPending newMs
          sendGroupMessage user gInfo' Nothing recipients $ XGrpPrefs ps'
        Nothing -> do
-          setGroupLinkData' nm user gInfo'
+          void $ setGroupLinkData' nm user gInfo'
          recipients <- getRecipients
          sendGroupMessage user gInfo' Nothing recipients (XGrpInfo p')
          where
            getRecipients
-              | useRelays' gInfo' = withFastStore' $ \db -> getGroupRelays db vr user gInfo'
+              | useRelays' gInfo' = withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo'
              | otherwise = do
                  ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo'
                  pure $ filter memberCurrentOrPending ms
@@ -3443,8 +3442,7 @@ processChatCommand vr nm = \case
      when (displayName /= validName) $ throwChatError CEInvalidDisplayName {displayName, validName}
    assertUserGroupRole :: GroupInfo -> GroupMemberRole -> CM ()
    assertUserGroupRole g@GroupInfo {membership} requiredRole = do
-      let GroupMember {memberRole = membershipMemRole} = membership
-      when (membershipMemRole < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole
+      when (memberRole' membership < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole
      when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
      when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
      unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
@@ -3458,13 +3456,13 @@ processChatCommand vr nm = \case
      delGroupChatItems user gInfo chatScopeInfo items True
      where
        assertDeletable :: GroupInfo -> [CChatItem 'CTGroup] -> CM ()
-        assertDeletable GroupInfo {membership = GroupMember {memberRole = membershipMemRole}} items' =
+        assertDeletable GroupInfo {membership} items' =
          unless (all itemDeletable items') $ throwChatError CEInvalidChatItemDelete
          where
            itemDeletable :: CChatItem 'CTGroup -> Bool
            itemDeletable (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) =
              case chatDir of
-                CIGroupRcv GroupMember {memberRole} -> membershipMemRole >= memberRole && isJust itemSharedMsgId
+                CIGroupRcv GroupMember {memberRole} -> memberRole' membership >= memberRole && isJust itemSharedMsgId
                CIGroupSnd -> isJust itemSharedMsgId
        itemsMsgMemIds :: GroupInfo -> [CChatItem 'CTGroup] -> [(SharedMsgId, MemberId)]
        itemsMsgMemIds GroupInfo {membership = GroupMember {memberId = membershipMemId}} = mapMaybe itemMsgMemIds
@@ -1241,19 +1241,23 @@ splitFileDescr partSize rfdText = splitParts 1 rfdText
            then fileDescr :| []
            else fileDescr <| splitParts (partNo + 1) rest

-setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfo -> CM ()
+setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfo -> CM (Maybe GroupLink)
 setGroupLinkData' nm user gInfo =
  withFastStore' (\db -> runExceptT $ getGroupLink db user gInfo) >>= \case
    Right gLink@GroupLink {shortLinkDataSet}
-      | shortLinkDataSet -> void $ setGroupLinkData nm user gInfo gLink
-    _ -> pure ()
+      | shortLinkDataSet -> Just <$> setGroupLinkData nm user gInfo gLink
+    _ -> pure Nothing

+-- TODO [relays] owner: set owners on updating link data
 setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM GroupLink
 setGroupLinkData nm user gInfo@GroupInfo {groupProfile} gLink@GroupLink {groupLinkId} = do
  vr <- chatVersionRange
-  conn <- withFastStore $ \db -> getGroupLinkConnection db vr user gInfo
-  let userData = encodeShortLinkData $ GroupShortLinkData groupProfile
-      userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
+  (conn, groupRelays) <- withFastStore $ \db ->
+    (,) <$> getGroupLinkConnection db vr user gInfo <*> liftIO (getGroupRelays db gInfo)
+  let direct = not $ useRelays' gInfo
+      relays = mapMaybe relayLink groupRelays
+      userData = encodeShortLinkData $ GroupShortLinkData groupProfile
+      userLinkData = UserContactLinkData UserContactData {direct, owners = [], relays, userData}
      crClientData = encodeJSON $ CRDataGroup groupLinkId
  sLnk <- shortenShortLink' . toShortGroupLink =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData))
  withFastStore' $ \db -> setGroupLinkShortLink db gLink sLnk
@@ -1262,11 +1266,14 @@ restoreShortLink' :: ConnShortLink m -> CM (ConnShortLink m)
 restoreShortLink' l = (`restoreShortLink` l) <$> asks (shortLinkPresetServers . config)

 getShortLinkConnReq :: NetworkRequestMode -> User -> ConnShortLink m -> CM (ConnectionRequestUri m, ConnLinkData m)
-getShortLinkConnReq nm user l = do
+getShortLinkConnReq nm user@User {userChatRelay} l = do
  l' <- restoreShortLink' l
  (cReq, cData) <- withAgent $ \a -> getConnShortLink a nm (aUserId user) l'
  case cData of
-    ContactLinkData _ UserContactData {direct} | not direct -> throwChatError CEUnsupportedConnReq
+    ContactLinkData _ UserContactData {direct, relays}
+      | not supported -> throwChatError CEUnsupportedConnReq
+      where
+        supported = direct || not (null relays) || isTrue userChatRelay
    _ -> pure ()
  pure (cReq, cData)

@@ -1496,7 +1503,7 @@ getGroupRecipients :: VersionRangeChat -> User -> GroupInfo -> Maybe GroupChatSc
 getGroupRecipients vr user gInfo@GroupInfo {membership} scopeInfo modsCompatVersion
  | useRelays' gInfo && not (isMemberRelay membership) = do
      unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member"
-      withFastStore' $ \db -> getGroupRelays db vr user gInfo
+      withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
  | otherwise = case scopeInfo of
      Nothing -> do
        unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member"
@@ -220,7 +220,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
                      toView $ CEvtSndFileCompleteXFTP user ci' ft
                      where
                        getRecipients
-                          | useRelays' g = withStore' $ \db -> getGroupRelays db vr user g
+                          | useRelays' g = withStore' $ \db -> getGroupRelayMembers db vr user g
                          | otherwise = withStore' $ \db -> getGroupMembers db vr user g
                        memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)]
                        memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts')
@@ -728,16 +728,29 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
                    -- [async agent commands] no continuation needed, but command should be asynchronous for stability
                    allowAgentConnectionAsync user conn' confId XOk
                | otherwise -> messageError "x.grp.acpt: memberId is different from expected"
-              XGrpRelayAcpt _relayLink -> do
-                liftIO $ print $ "XGrpRelayAcpt relayLink = " <> show _relayLink
-                -- TODO [relays] owner: process relay acceptance
-                -- TODO   - * relay is invitee? other processing branch?
-                -- TODO   - * check processing client is owner, otherwise error
-                -- TODO   - update relay record with relay link, relay status: RSAccepted
-                -- TODO   - update group link (add relay link)
-                -- TODO     - agent async setConnShortLink api; agent api to allow setting ContactLinkData.relays
-                -- TODO   - on group link updated: relay status: RSActive (can share group link with members)
-                pure ()
+              -- TODO [relays] owner: XGrpRelayAcpt processing branch
+              -- TODO   - TBC relay category
+              -- TODO   - set relay status RSActive on CON?
+              XGrpRelayAcpt relayLink
+                | memberRole' membership == GROwner ->
+                    case relayData m of
+                      Just relay -> do
+                        -- TODO [relays] owner: check current relay status?
+                        relay' <- withStore' $ \db -> do
+                          updateGroupMemberStatus db userId m GSMemAccepted
+                          setRelayLinkAccepted db relay relayLink
+                        let m' = m {relayData = Just relay', memberStatus = GSMemAccepted}
+                        allowAgentConnectionAsync user conn' confId XOk
+                        -- TODO [relays] owner: agent async setConnShortLink api
+                        setGroupLinkData' NRMBackground user gInfo >>= \case
+                          Just gLink -> do
+                            (relay'', relays) <- withStore' $ \db ->
+                              (,) <$> updateRelayStatusFromTo db relay' RSAccepted RSActive <*> getGroupRelays db gInfo
+                            let m'' = m' {relayData = Just relay''}
+                            toView $ CEvtRelayAddedToLink user gInfo m'' gLink relays
+                          Nothing -> messageError "x.grp.relay.acpt: group link not updated"
+                      Nothing -> messageError "x.grp.relay.acpt: member is not saved as relay"
+                | otherwise -> messageError "x.grp.relay.acpt: only owner can add relay"
              _ -> messageError "CONF from invited member must have x.grp.acpt"
          GCHostMember ->
            case chatMsgEvent of
@@ -1331,7 +1344,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
              validateGroupProfile gp
              (gInfo, ownerMember) <- withStore $ \db -> createGroupRelayInvitation db vr user gp groupRelayInv
              relayLink <- createRelayLink gInfo
-              (gInfo', ownerMember') <- acceptRelayJoinRequestAsync user uclId gInfo ownerMember invId chatVRange relayLink
+              (_gInfo', _ownerMember') <- acceptRelayJoinRequestAsync user uclId gInfo ownerMember invId chatVRange relayLink
              -- TODO [relays] relay: event, chat item (?)
              pure ()
              where
@@ -1351,7 +1364,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
                      userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
                      crClientData = encodeJSON $ CRDataGroup groupLinkId
                  (connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a NRMBackground (aUserId user) True True SCMContact (Just userLinkData) (Just crClientData) CR.IKPQOff subMode
-                  ccLink' <- createdRelayLink <$> shortenCreatedLink ccLink
+                  ccLink' <- createdGroupLink <$> shortenCreatedLink ccLink
                  sLnk <- case toShortLinkContact ccLink' of
                    Just sl -> pure sl
                    Nothing -> throwChatError $ CEException "failed to create relay link: no short link"
@@ -2907,7 +2920,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
                (ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p')
                groupMsgToView cInfo ci
              createGroupFeatureChangedItems user cd CIRcvGroupFeature g g''
-              void $ forkIO $ setGroupLinkData' NRMBackground user g''
+              void $ forkIO $ void $ setGroupLinkData' NRMBackground user g''
            Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
          pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}

@@ -3145,7 +3158,7 @@ deleteGroupConnections user gInfo waitDelivery = do
  deleteMembersConnections' user members waitDelivery
  where
    getMembers vr
-      | useRelays' gInfo = withStore' $ \db -> getGroupRelays db vr user gInfo
+      | useRelays' gInfo = withStore' $ \db -> getGroupRelayMembers db vr user gInfo
      | otherwise = withStore' $ \db -> getGroupMembers db vr user gInfo

 startDeliveryTaskWorkers :: CM ()
@@ -63,7 +63,7 @@ module Simplex.Chat.Store.Groups
    getScopeMemberIdViaMemberId,
    getGroupMembers,
    getGroupModerators,
-    getGroupRelays,
+    getGroupRelayMembers,
    getGroupMembersForExpiration,
    getGroupCurrentMembersCount,
    deleteGroupChatItems,
@@ -76,9 +76,11 @@ module Simplex.Chat.Store.Groups
    createNewContactMember,
    createGroupRelayRecord,
    getGroupRelayById,
+    getGroupRelays,
    createRelayMemberRecord,
    createRelayConnection,
    updateRelayStatusFromTo,
+    setRelayLinkAccepted,
    createGroupRelayInvitation,
    updateRelayOwnStatusFromTo,
    createNewContactMemberAsync,
@@ -380,9 +382,9 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ
      gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db vr user gId
      hostId <- getHostMemberId_ db user gId
      let GroupMember {groupMemberId, memberId, memberRole} = membership
-          MemberIdRole {memberId = invMemberId, memberRole = memberRole'} = invitedMember
-      liftIO . when (memberId /= invMemberId || memberRole /= memberRole') $
-        DB.execute db "UPDATE group_members SET member_id = ?, member_role = ? WHERE group_member_id = ?" (invMemberId, memberRole', groupMemberId)
+          MemberIdRole {memberId = invMemberId, memberRole = invMemberRole} = invitedMember
+      liftIO . when (memberId /= invMemberId || memberRole /= invMemberRole) $
+        DB.execute db "UPDATE group_members SET member_id = ?, member_role = ? WHERE group_member_id = ?" (invMemberId, invMemberRole, groupMemberId)
      gInfo' <-
        if p' == groupProfile
          then pure gInfo
@@ -1022,8 +1024,8 @@ getGroupModerators db vr user@User {userId, userContactId} GroupInfo {groupId} =
      (userId, groupId, userContactId, GRModerator, GRAdmin, GROwner)

 -- TODO [channels fwd] retrieve relays based on knowledge about member from protocol, not role (isMemberRelay)
-getGroupRelays :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
-getGroupRelays db vr user@User {userId, userContactId} GroupInfo {groupId} = do
+getGroupRelayMembers :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
+getGroupRelayMembers db vr user@User {userId, userContactId} GroupInfo {groupId} = do
  map (toContactMember vr user)
    <$> DB.query
      db
@@ -1151,16 +1153,27 @@ getGroupRelayById db relayId =
  ExceptT . firstRow toGroupRelay (SEGroupRelayNotFound relayId) $
    DB.query
      db
-      [sql|
-        SELECT group_relay_id, chat_relay_id, relay_status, relay_link
-        FROM group_relays
-        WHERE group_relay_id = ?
-      |]
+      (groupRelayQuery <> " WHERE group_relay_id = ?")
      (Only relayId)
-  where
-    toGroupRelay :: (Int64, Int64, RelayStatus, Maybe ShortLinkContact) -> GroupRelay
-    toGroupRelay (groupRelayId, userChatRelayId, relayStatus, relayLink) =
-      GroupRelay {groupRelayId, userChatRelayId, relayStatus, relayLink}
+
+getGroupRelays :: DB.Connection -> GroupInfo -> IO [GroupRelay]
+getGroupRelays db GroupInfo {groupId} =
+  map toGroupRelay
+    <$> DB.query
+      db
+      (groupRelayQuery <> " WHERE group_id = ?")
+      (Only groupId)
+
+groupRelayQuery :: Query
+groupRelayQuery =
+  [sql|
+    SELECT group_relay_id, chat_relay_id, relay_status, relay_link
+    FROM group_relays
+  |]
+
+toGroupRelay :: (Int64, Int64, RelayStatus, Maybe ShortLinkContact) -> GroupRelay
+toGroupRelay (groupRelayId, userChatRelayId, relayStatus, relayLink) =
+  GroupRelay {groupRelayId, userChatRelayId, relayStatus, relayLink}

 -- TODO [relays] TBC role, category, relay profile
 -- TODO   - GCInviteeMember -> GCRelayMember?
@@ -1220,6 +1233,19 @@ updateRelayStatus_ db relayId relayStatus = do
  currentTs <- getCurrentTime
  DB.execute db "UPDATE group_relays SET relay_status = ?, updated_at = ? WHERE group_relay_id = ?" (relayStatus, currentTs, relayId)

+setRelayLinkAccepted :: DB.Connection -> GroupRelay -> ShortLinkContact -> IO GroupRelay
+setRelayLinkAccepted db relay@GroupRelay {groupRelayId} relayLink = do
+  currentTs <- getCurrentTime
+  DB.execute
+    db
+    [sql|
+      UPDATE group_relays
+      SET relay_link = ?, relay_status = ?, updated_at = ?
+      WHERE group_relay_id = ?
+    |]
+    (relayLink, RSAccepted, currentTs, groupRelayId)
+  pure relay {relayStatus = RSAccepted, relayLink = Just relayLink}
+
 createGroupRelayInvitation :: DB.Connection -> VersionRangeChat -> User -> GroupProfile -> GroupRelayInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
 createGroupRelayInvitation db vr user@User {userId} groupProfile GroupRelayInvitation {fromMember, fromMemberProfile, invitedMember} = do
  currentTs <- liftIO getCurrentTime
@@ -967,6 +967,9 @@ data GroupMember = GroupMember
  }
  deriving (Eq, Show)

+memberRole' :: GroupMember -> GroupMemberRole
+memberRole' GroupMember {memberRole} = memberRole
+
 data GroupRelay = GroupRelay
  { groupRelayId :: Int64,
    userChatRelayId :: Int64, -- ID of configured UserChatRelay
@@ -982,6 +985,13 @@ data RelayStatus
  | RSActive
  deriving (Eq, Show)

+relayStatusText :: RelayStatus -> Text
+relayStatusText = \case
+  RSNew -> "new"
+  RSInvited -> "invited"
+  RSAccepted -> "accepted"
+  RSActive -> "active"
+
 instance TextEncoding RelayStatus where
  textEncode = \case
    RSNew -> "new"
@@ -418,6 +418,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
  CEvtContactRequestAlreadyAccepted u c -> ttyUser u [ttyFullContact c <> ": sent you a duplicate contact request, but you are already connected, no action needed"]
  CEvtBusinessRequestAlreadyAccepted u g -> ttyUser u [ttyFullGroup g <> ": sent you a duplicate connection request, but you are already connected, no action needed"]
  CEvtGroupLinkConnecting u g _ -> ttyUser u [ttyGroup' g <> ": joining the group..."]
+  CEvtRelayAddedToLink u g relayMem groupLink relays -> ttyUser u $ viewRelayAddedToLink g relayMem groupLink relays
  CEvtBusinessLinkConnecting u g _ _ -> ttyUser u [ttyGroup' g <> ": joining the group..."]
  CEvtUnknownMemberCreated u g fwdM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember fwdM <> " forwarded a message from an unknown member, creating unknown member record " <> ttyMember um]
  CEvtUnknownMemberBlocked u g byM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember byM <> " blocked an unknown member, creating unknown member record " <> ttyMember um]
@@ -1147,6 +1148,22 @@ viewReceivedContactRequest c Profile {fullName, shortDescr} =
    "to reject: " <> highlight ("/rc " <> viewName c) <> " (the sender will NOT be notified)"
  ]

+viewRelayAddedToLink :: GroupInfo -> GroupMember -> GroupLink -> [GroupRelay] -> [StyledString]
+viewRelayAddedToLink g relayMem groupLink relays =
+  [ ttyFullGroup g <> ": relay " <> ttyMember relayMem <> " added to group link",
+    "current relays:"
+  ]
+    <> map showRelay relays
+    <>
+      [ "group link:",
+        plain $ maybe cReqStr strEncode shortLink
+      ]
+  where
+    showRelay GroupRelay {groupRelayId, relayStatus} =
+      "  - relay id " <> sShow groupRelayId <> ": " <> sShow (relayStatusText relayStatus)
+    GroupLink {connLinkContact = CCLink cReq shortLink} = groupLink
+    cReqStr = strEncode $ simplexChatContact cReq
+
 -- TODO [relays] operator: CLI specific apis based on name
 viewGroupCreated :: GroupInfo -> Bool -> [StyledString]
 viewGroupCreated g@GroupInfo {groupId} testView =