relay acceptance

2026-08-07 01:50:05 +00:00 · 2025-11-03 19:57:13 +04:00
parent 6d53532ada
commit c3b66d2269
4 changed files with 126 additions and 36 deletions
@@ -2018,7 +2018,7 @@ processChatCommand vr nm = \case
    ccLink <- case contactLink of
      Just (CLFull cReq) -> pure $ CCLink cReq Nothing
      Just (CLShort sLnk) -> do
-        (cReq, _cData) <- getShortLinkConnReq user sLnk
+        (cReq, _cData) <- getShortLinkConnReq nm user sLnk
        pure $ CCLink cReq $ Just sLnk
      Nothing -> throwCmdError "no address in contact profile"
    connectContactViaAddress user incognito ct ccLink `catchAllErrors` \e -> do
@@ -3581,7 +3581,7 @@ processChatCommand vr nm = \case
        addRelay :: UserChatRelay -> CM GroupRelay
        addRelay relay@UserChatRelay {address} = do
          -- TODO [relays] owner: can update relay profile from data retrieved via getConnShortLink
-          (cReq, _cData) <- getShortLinkConnReq user address
+          (cReq, _cData) <- getShortLinkConnReq nm user address
          lift (withAgent' $ \a -> connRequestPQSupport a PQSupportOff cReq) >>= \case
            Nothing -> throwChatError CEInvalidConnReq
            Just (agentV, _) -> do
@@ -3613,8 +3613,6 @@ processChatCommand vr nm = \case
                void $ updateConnectionStatusFromTo db conn ConnPrepared newConnStatus
                updateRelayStatusFromTo db groupRelay RSNew RSInvited
              pure groupRelay'
-    drgRandomBytes :: Int -> CM ByteString
-    drgRandomBytes n = asks random >>= atomically . C.randomBytes n
    privateGetUser :: UserId -> CM User
    privateGetUser userId =
      tryAllErrors (withStore (`getUser` userId)) >>= \case
@@ -3686,7 +3684,7 @@ processChatCommand vr nm = \case
        knownLinkPlans l' >>= \case
          Just r -> pure r
          Nothing -> do
-            (cReq, cData) <- getShortLinkConnReq user l'
+            (cReq, cData) <- getShortLinkConnReq nm user l'
            contactSLinkData_ <- liftIO $ decodeShortLinkData cData
            invitationReqAndPlan cReq (Just l') contactSLinkData_
      where
@@ -3712,7 +3710,7 @@ processChatCommand vr nm = \case
            knownLinkPlans >>= \case
              Just r -> pure r
              Nothing -> do
-                (cReq, cData) <- getShortLinkConnReq user l'
+                (cReq, cData) <- getShortLinkConnReq nm user l'
                withFastStore' (\db -> getContactWithoutConnViaShortAddress db vr user l') >>= \case
                  Just ct' | not (contactDeleted ct') -> pure (con cReq, CPContactAddress (CAPContactViaAddress ct'))
                  _ -> do
@@ -3744,7 +3742,7 @@ processChatCommand vr nm = \case
                -- TODO   retreiving relays at point of conenctions seems better, as arbitrary time
                -- TODO   can pass between creating prepared group from plan and connecting to it,
                -- TODO   during which relays can change.
-                (cReq, cData) <- getShortLinkConnReq user l'
+                (cReq, cData) <- getShortLinkConnReq nm user l'
                groupSLinkData_ <- liftIO $ decodeShortLinkData cData
                plan <- groupJoinRequestPlan user cReq groupSLinkData_
                pure (con cReq, plan)
@@ -3846,21 +3844,12 @@ processChatCommand vr nm = \case
      )
    contactCReqHash :: ConnReqContact -> ConnReqUriHash
    contactCReqHash = ConnReqUriHash . C.sha256Hash . strEncode
-    getShortLinkConnReq :: User -> ConnShortLink m -> CM (ConnectionRequestUri m, ConnLinkData m)
-    getShortLinkConnReq user l = do
-      l' <- restoreShortLink' l
-      (cReq, cData) <- withAgent $ \a -> getConnShortLink a nm (aUserId user) l'
-      case cData of
-        ContactLinkData {direct} | not direct -> throwChatError CEUnsupportedConnReq
-        _ -> pure ()
-      pure (cReq, cData)
    -- This function is needed, as UI uses simplex:/ schema in message view, so that the links can be handled without browser,
    -- and short links are stored with server hostname schema, so they wouldn't match without it.
    serverShortLink :: ConnShortLink m -> ConnShortLink m
    serverShortLink = \case
      CSLInvitation _ srv lnkId linkKey -> CSLInvitation SLSServer srv lnkId linkKey
      CSLContact _ ct srv linkKey -> CSLContact SLSServer ct srv linkKey
-    restoreShortLink' l = (`restoreShortLink` l) <$> asks (shortLinkPresetServers . config)
    contactShortLinkData :: Profile -> Maybe AddressSettings -> UserLinkData
    contactShortLinkData p settings =
      let msg = autoReply =<< settings
@@ -89,6 +89,7 @@ import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..))
 import Simplex.Messaging.Compression (compressionLevel)
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
 import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
@@ -1016,6 +1017,26 @@ acceptBusinessJoinRequestAsync
    -- TODO [short links] get updated business chat group and member? (currently not used)
    pure (gInfo, clientMember)

+acceptRelayJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> InvitationId -> VersionRangeChat -> ShortLinkContact -> CM (GroupInfo, GroupMember)
+acceptRelayJoinRequestAsync
+  user
+  uclId
+  gInfo
+  _ownerMember@GroupMember {groupMemberId}
+  cReqInvId
+  cReqChatVRange
+  relayLink = do
+    let msg = XGrpRelayAcpt relayLink
+    subMode <- chatReadVar subscriptionMode
+    vr <- chatVersionRange
+    let chatV = vr `peerConnChatVersion` cReqChatVRange
+    connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
+    withStore $ \db -> do
+      liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
+      gInfo' <- liftIO $ updateRelayOwnStatusFromTo db gInfo RSInvited RSAccepted
+      ownerMember' <- getGroupMemberById db vr user groupMemberId
+      pure (gInfo', ownerMember')
+
 businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
 businessGroupProfile Profile {displayName, fullName, shortDescr, image} groupPreferences =
  GroupProfile {displayName, fullName, description = Nothing, shortDescr, image, groupLink = Nothing, groupPreferences = Just groupPreferences, memberAdmission = Nothing}
@@ -1236,6 +1257,18 @@ setGroupLinkData nm user gInfo@GroupInfo {groupProfile} gLink@GroupLink {groupLi
  sLnk <- shortenShortLink' . toShortGroupLink =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userData (Just crClientData))
  withFastStore' $ \db -> setGroupLinkShortLink db gLink sLnk

+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
+  l' <- restoreShortLink' l
+  (cReq, cData) <- withAgent $ \a -> getConnShortLink a nm (aUserId user) l'
+  case cData of
+    ContactLinkData {direct} | not direct -> throwChatError CEUnsupportedConnReq
+    _ -> pure ()
+  pure (cReq, cData)
+
 encodeShortLinkData :: J.ToJSON a => a -> UserLinkData
 encodeShortLinkData d =
  let s = LB.toStrict $ J.encode d
@@ -2603,3 +2636,6 @@ timeItToView s action = do

 epochStart :: UTCTime
 epochStart = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)
+
+drgRandomBytes :: Int -> CM ByteString
+drgRandomBytes n = asks random >>= atomically . C.randomBytes n
@@ -28,7 +28,7 @@ import Data.Either (lefts, partitionEithers, rights)
 import Data.Foldable (foldr')
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (find, foldl')
+import Data.List (find)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
@@ -1150,7 +1150,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
        case chatMsgEvent of
          XContact p xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ pqSupport
          XInfo p -> profileContactRequest invId chatVRange p Nothing Nothing Nothing pqSupport
-          XGrpRelayInv groupRelayInv -> relayContactRequest groupRelayInv
+          XGrpRelayInv groupRelayInv -> relayContactRequest invId chatVRange groupRelayInv
          -- TODO show/log error, other events in contact request
          _ -> pure ()
      MERR _ err -> do
@@ -1319,18 +1319,43 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
                  | otherwise -> do
                      mem <- acceptGroupJoinSendRejectAsync user uclId gInfo invId chatVRange p xContactId_ rjctReason
                      toViewTE $ TERejectingGroupJoinRequestMember user gInfo mem rjctReason
-        relayContactRequest :: GroupRelayInvitation -> CM ()
-        relayContactRequest _groupRelayInv = do
-          -- TODO [relays] relay: process contact request to server group
-          -- TODO   - retrieve group link data, validate group profile, verify owner's signature
-          -- TODO   - create group record, relay status: RSInvited
-          -- TODO   - create relay link (async)
-          -- TODO     - new user contact link referencing this group
-          -- TODO     - link data: relay key for group, relay identity (profile, certificate, relay identity key)
-          -- TODO   - accept request - send XGrpRelayAcpt to owner (continuation on link created)
-          -- TODO     - create owner member connection, relay status: RSAccepted
+        relayContactRequest :: InvitationId -> VersionRangeChat -> GroupRelayInvitation -> CM ()
+        relayContactRequest invId chatVRange groupRelayInv@GroupRelayInvitation {groupLink} = do
+          -- TODO [relays] relay: retrieve group link data asynchronously/add recovery
          -- TODO   - * duplicate requests can be deduplicated by group link
-          pure ()
+          (_cReq, cData) <- getShortLinkConnReq NRMBackground user groupLink
+          (liftIO $ decodeShortLinkData cData) >>= \case
+            Nothing -> messageError "relayContactRequest: no group link data"
+            Just (GroupShortLinkData gp) -> do
+              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
+              -- TODO [relays] relay: event, chat item (?)
+              pure ()
+              where
+                validateGroupProfile :: GroupProfile -> CM ()
+                validateGroupProfile _groupProfile = do
+                  -- TODO [relays] relay: validate group profile, verify owner's signature
+                  -- TODO   - throw error if invalid
+                  pure ()
+                createRelayLink :: GroupInfo -> CM ShortLinkContact
+                createRelayLink gInfo@GroupInfo {groupProfile} = do
+                  -- TODO [relays] relay: create relay link asynchronously/add recovery; set relay link data
+                  -- TODO   - link data: relay key for group, relay identity (profile, certificate, relay identity key)
+                  -- TODO   - TBC link's member role - owner to communicate in invitation?
+                  groupLinkId <- GroupLinkId <$> drgRandomBytes 16
+                  subMode <- chatReadVar subscriptionMode
+                  let userData = encodeShortLinkData $ GroupShortLinkData groupProfile
+                      crClientData = encodeJSON $ CRDataGroup groupLinkId
+                  (connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a NRMBackground (aUserId user) True True SCMContact (Just userData) (Just crClientData) CR.IKPQOff subMode
+                  ccLink' <- createdRelayLink <$> shortenCreatedLink ccLink
+                  sLnk <- case toShortLinkContact ccLink' of
+                    Just sl -> pure sl
+                    Nothing -> throwChatError $ CEException "failed to create relay link: no short link"
+                  gVar <- asks random
+                  void $ withFastStore $ \db -> createGroupLink db gVar user gInfo connId ccLink' groupLinkId GRMember subMode
+                  pure sLnk

    memberCanSend ::
      GroupMember ->
@@ -79,6 +79,8 @@ module Simplex.Chat.Store.Groups
    createRelayMemberRecord,
    createRelayConnection,
    updateRelayStatusFromTo,
+    createGroupRelayInvitation,
+    updateRelayOwnStatusFromTo,
    createNewContactMemberAsync,
    createJoiningMember,
    getMemberJoinRequest,
@@ -540,7 +542,7 @@ createPreparedGroup :: DB.Connection -> VersionRangeChat -> User -> GroupProfile
 createPreparedGroup db vr user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId = do
  currentTs <- liftIO getCurrentTime
  let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
-  (groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing currentTs
+  (groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing Nothing currentTs
  hostMemberId <- insertHost_ currentTs groupId groupLDN
  let userMember = MemberIdRole (MemberId $ encodeUtf8 groupLDN <> "_user_unknown_id") GRMember
  membership <- createContactMemberInv_ db user groupId (Just hostMemberId) user userMember GCUserMember GSMemUnknown IBUnknown Nothing currentTs vr
@@ -737,7 +739,7 @@ createGroupViaLink'
  business
  membershipStatus = do
    currentTs <- liftIO getCurrentTime
-    (groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing business currentTs
+    (groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing business Nothing currentTs
    hostMemberId <- insertHost_ currentTs groupId
    liftIO $ DB.execute db "UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ?" (ConnMember, hostMemberId, currentTs, connId)
    -- using IBUnknown since host is created without contact
@@ -762,8 +764,8 @@ createGroupViaLink'
            )
          insertedRowId db

-createGroup_ :: DB.Connection -> UserId -> GroupProfile -> Maybe (CreatedLinkContact, Maybe SharedMsgId) -> Maybe BusinessChatInfo -> UTCTime -> ExceptT StoreError IO (GroupId, Text)
-createGroup_ db userId groupProfile prepared business currentTs = ExceptT $ do
+createGroup_ :: DB.Connection -> UserId -> GroupProfile -> Maybe (CreatedLinkContact, Maybe SharedMsgId) -> Maybe BusinessChatInfo -> Maybe RelayStatus -> UTCTime -> ExceptT StoreError IO (GroupId, Text)
+createGroup_ db userId groupProfile prepared business relayOwnStatus currentTs = ExceptT $ do
  let GroupProfile {displayName, fullName, shortDescr, description, image, groupPreferences, memberAdmission} = groupProfile
  withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do
    liftIO $ do
@@ -778,10 +780,10 @@ createGroup_ db userId groupProfile prepared business currentTs = ExceptT $ do
          INSERT INTO groups
            (group_profile_id, local_display_name, user_id, enable_ntfs,
              created_at, updated_at, chat_ts, user_member_profile_sent_at, conn_full_link_to_connect, conn_short_link_to_connect, welcome_shared_msg_id,
-              business_chat, business_member_id, customer_member_id)
-          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+              business_chat, business_member_id, customer_member_id, use_relays, relay_own_status)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
        |]
-        ((profileId, localDisplayName, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. toPreparedGroupRow prepared :. businessChatInfoRow business)
+        ((profileId, localDisplayName, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. toPreparedGroupRow prepared :. businessChatInfoRow business :. (BI $ isJust relayOwnStatus, relayOwnStatus))
      groupId <- insertedRowId db
      pure (groupId, localDisplayName)

@@ -1218,6 +1220,44 @@ 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)

+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
+  (groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing Nothing (Just RSInvited) currentTs
+  ownerMemberId <- insertOwner_ currentTs groupId
+  _membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown Nothing currentTs vr
+  ownerMember <- getGroupMember db vr user groupId ownerMemberId
+  g <- getGroupInfo db vr user groupId
+  pure (g, ownerMember)
+  where
+    insertOwner_ currentTs groupId = do
+      let MemberIdRole {memberId, memberRole} = fromMember
+      (localDisplayName, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
+      liftIO $ do
+        DB.execute
+          db
+          [sql|
+            INSERT INTO group_members
+              ( group_id, member_id, member_role, member_category, member_status,
+                user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
+            VALUES (?,?,?,?,?,?,?,?,?,?,?)
+          |]
+          ( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted)
+              :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
+          )
+        insertedRowId db
+
+updateRelayOwnStatusFromTo :: DB.Connection -> GroupInfo -> RelayStatus -> RelayStatus -> IO GroupInfo
+updateRelayOwnStatusFromTo db gInfo@GroupInfo {groupId} fromStatus toStatus = do
+  maybeFirstRow fromOnly (DB.query db "SELECT relay_own_status FROM groups WHERE group_id = ?" (Only groupId)) >>= \case
+    Just status | status == fromStatus -> updateRelayOwnStatus_ db gInfo toStatus $> gInfo {relayOwnStatus = Just toStatus}
+    _ -> pure gInfo
+
+updateRelayOwnStatus_ :: DB.Connection -> GroupInfo -> RelayStatus -> IO ()
+updateRelayOwnStatus_ db GroupInfo {groupId} relayStatus = do
+  currentTs <- getCurrentTime
+  DB.execute db "UPDATE groups SET relay_own_status = ?, updated_at = ? WHERE group_id = ?" (relayStatus, currentTs, groupId)
+
 createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionChat -> VersionRangeChat -> SubscriptionMode -> ExceptT StoreError IO ()
 createNewContactMemberAsync db gVar user@User {userId, userContactId} GroupInfo {groupId, membership} Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) chatV peerChatVRange subMode =
  createWithRandomId gVar $ \memId -> do