diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index f1f34b679a..bbbd3768aa 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -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 diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index c7c31fbb53..acae2702a4 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -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 diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index a6f0caf813..3d6e35b5ac 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -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 -> diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index b08ab5c8b6..4cb5fa3a05 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -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