From cca62e949f9090e59946c8231a2cbef6c9c0c024 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 9 Jun 2026 13:01:46 +0000 Subject: [PATCH] configurable badge key --- src/Simplex/Chat.hs | 2 + src/Simplex/Chat/Controller.hs | 4 +- src/Simplex/Chat/Library/Commands.hs | 12 ++--- src/Simplex/Chat/Library/Internal.hs | 8 +-- src/Simplex/Chat/Library/Subscriber.hs | 18 +++---- src/Simplex/Chat/Store/ContactRequest.hs | 4 +- src/Simplex/Chat/Store/Direct.hs | 10 ++-- src/Simplex/Chat/Store/Groups.hs | 62 ++++++++++++------------ src/Simplex/Chat/Store/Shared.hs | 12 ++--- src/Simplex/Chat/Types.hs | 11 +++-- tests/ChatTests/Profiles.hs | 14 +++--- 11 files changed, 82 insertions(+), 75 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c3658a1c94..e5d2706642 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -29,6 +29,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import Data.Time.Clock (getCurrentTime, nominalDay) import Simplex.Chat.Controller +import Simplex.Messaging.Crypto.BBS (BBSPublicKey (..)) import Simplex.Chat.Library.Commands import Simplex.Chat.Operators import Simplex.Chat.Operators.Presets @@ -65,6 +66,7 @@ defaultChatConfig = tbqSize = 1024 }, chatVRange = supportedChatVRange, + badgePublicKey = BBSPublicKey "", confirmMigrations = MCConsole, -- this property should NOT use operator = Nothing -- non-operator servers can be passed via options diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index c92c1f9e09..4a740cb838 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -81,6 +81,7 @@ import Simplex.Messaging.Agent.Store.DB (SQLError) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyMode (..), SMPWebPortServers (..), SocksMode (..)) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPublicKey) import Simplex.Messaging.Crypto.File (CryptoFile (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Crypto.Ratchet (PQEncryption) @@ -137,6 +138,7 @@ coreVersionInfo simplexmqCommit = data ChatConfig = ChatConfig { agentConfig :: AgentConfig, chatVRange :: VersionRangeChat, + badgePublicKey :: BBSPublicKey, confirmMigrations :: MigrationConfirmation, presetServers :: PresetServers, shortLinkPresetServers :: NonEmpty SMPServer, @@ -172,7 +174,7 @@ data ChatConfig = ChatConfig -- | 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} = StoreCxt chatVRange +mkStoreCxt ChatConfig {chatVRange, badgePublicKey} = StoreCxt chatVRange badgePublicKey {-# INLINE mkStoreCxt #-} data RandomAgentServers = RandomAgentServers diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index c8aa9b2657..0b2bf80186 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -363,16 +363,16 @@ processChatCommand cxt nm = \case user <- withFastStore $ \db -> do user <- createUserRecordAt db (AgentUserId auId) p userChatRelay True ts mapM_ (setUserServers db user ts) uss - createPresetContactCards db user `catchAllErrors` \_ -> pure () + createPresetContactCards db cxt user `catchAllErrors` \_ -> pure () createNoteFolder db user pure user atomically . writeTVar u $ Just user pure $ CRActiveUser user where - createPresetContactCards :: DB.Connection -> User -> ExceptT StoreError IO () - createPresetContactCards db user = do - createContact db user simplexStatusContactProfile - createContact db user simplexTeamContactProfile + createPresetContactCards :: DB.Connection -> StoreCxt -> User -> ExceptT StoreError IO () + createPresetContactCards db cxt user = do + createContact db cxt user simplexStatusContactProfile + createContact db cxt user simplexTeamContactProfile chooseServers :: Maybe User -> CM ([UpdatedUserOperatorServers], (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))) chooseServers user_ = do as <- asks randomAgentServers @@ -3624,7 +3624,7 @@ processChatCommand cxt nm = \case relayLinkData_ <- liftIO $ decodeLinkUserData cData case (relayLinkData_, linkEntityId) of (Just RelayShortLinkData {relayProfile = p}, Just entityId) -> - withFastStore $ \db -> updateRelayMemberData db user relayMember (MemberId entityId) (MemberKey relayKey) p + withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) p _ -> throwChatError $ CEException "relay link: no relay link data or entity id" let cReq = linkConnReq fd relayLinkToConnect = CCLink cReq (Just relayLink) diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index d0f85fbea2..d448eabf5a 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -947,8 +947,9 @@ acceptGroupJoinRequestAsync memberKey_ = do gVar <- asks random let initialStatus = acceptanceToStatus (memberAdmission groupProfile) gAccepted + cxt <- chatStoreCxt (groupMemberId, memberId) <- withStore $ \db -> - createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_ + createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_ let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo let Profile {displayName} = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile) GroupMember {memberRole = userRole, memberId = userMemberId} = membership @@ -964,7 +965,6 @@ acceptGroupJoinRequestAsync groupSize = Just currentMemCount } subMode <- chatReadVar subscriptionMode - cxt <- chatStoreCxt let chatV = vr cxt `peerConnChatVersion` cReqChatVRange connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV withStore $ \db -> do @@ -982,8 +982,9 @@ acceptGroupJoinSendRejectAsync cReqXContactId_ rejectionReason = do gVar <- asks random + cxt <- chatStoreCxt (groupMemberId, memberId) <- withStore $ \db -> - createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ Nothing Nothing GRObserver GSMemRejected Nothing + createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ Nothing Nothing GRObserver GSMemRejected Nothing let GroupMember {memberRole = userRole, memberId = userMemberId} = membership msg = XGrpLinkReject $ @@ -994,7 +995,6 @@ acceptGroupJoinSendRejectAsync rejectionReason } subMode <- chatReadVar subscriptionMode - cxt <- chatStoreCxt let chatV = vr cxt `peerConnChatVersion` cReqChatVRange connIds <- agentAcceptContactAsync user False cReqInvId msg subMode PQSupportOff chatV withStore $ \db -> do diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 87b560d1ab..be41dad654 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -1170,7 +1170,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = relayLinkData_ <- liftIO $ decodeLinkUserData cData case (relayLinkData_, linkEntityId) of (Just RelayShortLinkData {relayProfile = p}, Just entityId) -> - withStore $ \db -> updateRelayMemberData db user m (MemberId entityId) (MemberKey relayKey) p + withStore $ \db -> updateRelayMemberData db cxt user m (MemberId entityId) (MemberKey relayKey) p _ -> throwChatError $ CEException "relay link: no relay link data or entity id" case cReq of CRContactUri crData@ConnReqUriData {crClientData} -> do @@ -2553,10 +2553,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = | p /= p' = do c' <- withStore $ \db -> if userTTL == rcvTTL - then updateContactProfile db user c p' + then updateContactProfile db cxt user c p' else do c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs' - updateContactProfile db user c' p' + updateContactProfile db cxt user c' p' when (directOrUsed c' && createItems) $ do createProfileUpdatedItem c' lift $ createRcvFeatureItems user c c' @@ -2671,7 +2671,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = updateBusinessChatProfile gInfo case memberContactId of Nothing -> do - m' <- withStore $ \db -> updateMemberProfile db user m p' + m' <- withStore $ \db -> updateMemberProfile db cxt user m p' unless (muteEventInChannel gInfo m') $ do forM_ msgTs_ $ createProfileUpdatedItem m' toView $ CEvtGroupMemberUpdated user gInfo m m' @@ -2680,7 +2680,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = mCt <- withStore $ \db -> getContact db cxt user mContactId if canUpdateProfile mCt then do - (m', ct') <- withStore $ \db -> updateContactMemberProfile db user m mCt p' + (m', ct') <- withStore $ \db -> updateContactMemberProfile db cxt user m mCt p' unless (muteEventInChannel gInfo m') $ do forM_ msgTs_ $ createProfileUpdatedItem m' toView $ CEvtGroupMemberUpdated user gInfo m m' @@ -2976,7 +2976,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = | otherwise -> messageError "x.grp.mem.new error: member already exists" $> Nothing Left _ -> do (newMember, gInfo') <- withStore $ \db -> do - newMember <- createNewGroupMember db user gInfo m memInfo GCPostMember initialStatus + newMember <- createNewGroupMember db cxt user gInfo m memInfo GCPostMember initialStatus gInfo' <- if memberPending newMember then liftIO $ increaseGroupMembersRequireAttention db user gInfo @@ -3028,7 +3028,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = MemberInfo mId mRole v p _ | mRole == GROwner -> MemberInfo mId mRole v p Nothing _ -> memInfo - void $ withStore $ \db -> createIntroReMember db user gInfo memInfo' memRestrictions + void $ withStore $ \db -> createIntroReMember db cxt user gInfo memInfo' memRestrictions | otherwise -> do when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c) case memChatVRange of @@ -3040,7 +3040,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = groupConnIds <- createConn subMode let chatV = maybe (minVersion (vr cxt)) (\peerVR -> vr cxt `peerConnChatVersion` fromChatVRange peerVR) memChatVRange void $ withStore $ \db -> do - reMember <- createIntroReMember db user gInfo memInfo memRestrictions + reMember <- createIntroReMember db cxt user gInfo memInfo memRestrictions createIntroReMemberConn db user m reMember chatV memInfo groupConnIds subMode | otherwise -> messageError "x.grp.mem.intro: member chat version range incompatible" _ -> messageError "x.grp.mem.intro can be only sent by host member" @@ -3075,7 +3075,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that. -- For now, this branch compensates for the lack of delayed message delivery. `catchError` \case - SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced + SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db cxt user gInfo m memInfo GCPostMember GSMemAnnounced e -> throwError e -- TODO [knocking] separate pending statuses from GroupMemberStatus? -- TODO add GSMemIntroInvitedPending, GSMemConnectedPending, etc.? diff --git a/src/Simplex/Chat/Store/ContactRequest.hs b/src/Simplex/Chat/Store/ContactRequest.hs index 1963b5f837..adac1b455f 100644 --- a/src/Simplex/Chat/Store/ContactRequest.hs +++ b/src/Simplex/Chat/Store/ContactRequest.hs @@ -163,7 +163,7 @@ createOrUpdateContactRequest createContactRequest :: ExceptT StoreError IO RequestStage createContactRequest = do currentTs <- liftIO $ getCurrentTime - badgeVerified <- liftIO $ verifyBadge_ srvBadgePublicKey badge + badgeVerified <- liftIO $ verifyBadge_ (badgeKey cxt) badge ExceptT $ withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do liftIO $ DB.execute @@ -230,7 +230,7 @@ createOrUpdateContactRequest pure $ RSCurrentRequest (Just ucr) ucr' re_ where updateProfile currentTs = do - badgeVerified <- liftIO $ verifyBadge_ srvBadgePublicKey badge + badgeVerified <- liftIO $ verifyBadge_ (badgeKey cxt) badge DB.execute db [sql| diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 381fd5ab8d..07db856847 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -402,7 +402,7 @@ createPreparedContact db cxt user p connLinkToConnect welcomeSharedMsgId = do currentTs <- liftIO getCurrentTime let prepared = Just (connLinkToConnect, welcomeSharedMsgId) ctUserPreferences = newContactUserPrefs user p - contactId <- createContact_ db user p ctUserPreferences prepared "" currentTs + contactId <- createContact_ db cxt user p ctUserPreferences prepared "" currentTs getContact db cxt user contactId updatePreparedContactUser :: DB.Connection -> StoreCxt -> User -> Contact -> User -> ExceptT StoreError IO Contact @@ -447,7 +447,7 @@ createDirectContact :: DB.Connection -> StoreCxt -> User -> Connection -> Profil createDirectContact db cxt user Connection {connId, localAlias} p = do currentTs <- liftIO getCurrentTime let ctUserPreferences = newContactUserPrefs user p - contactId <- createContact_ db user p ctUserPreferences Nothing localAlias currentTs + contactId <- createContact_ db cxt user p ctUserPreferences Nothing localAlias currentTs liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId) getContact db cxt user contactId @@ -555,10 +555,10 @@ deleteUnusedProfile_ db userId profileId = :. (userId, profileId, userId, profileId, profileId) ) -updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact -updateContactProfile db user@User {userId} c p' = do +updateContactProfile :: DB.Connection -> StoreCxt -> User -> Contact -> Profile -> ExceptT StoreError IO Contact +updateContactProfile db cxt user@User {userId} c p' = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ profileBadgeVerified lp p' + badgeVerified <- liftIO $ profileBadgeVerified (badgeKey cxt) lp p' let profile = toLocalProfile profileId p' localAlias currentTs badgeVerified updateContactProfile' currentTs badgeVerified profile where diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 811bd80846..e4ef35bc8f 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -635,7 +635,7 @@ createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile b randHostId <- liftIO $ encodedRandomBytes gVar 12 let memberId = MemberId $ encodeUtf8 groupLDN <> "_unknown_host_" <> randHostId hostProfile = profileFromName $ nameFromBS randHostId - (localDisplayName, profileId, _) <- createNewMemberProfile_ db user hostProfile currentTs + (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user hostProfile currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ do DB.execute @@ -790,7 +790,7 @@ updatePreparedUserAndHostMembers' |] (memberId, memberRole, membershipStatus, currentTs, groupMemberId' membership) updateHostMember currentTs = do - _ <- updateMemberProfile db user hostMember fromMemberProfile + _ <- updateMemberProfile db cxt user hostMember fromMemberProfile let MemberIdRole memberId memberRole = fromMember gmId = groupMemberId' hostMember liftIO $ @@ -840,7 +840,7 @@ createGroupViaLink' (,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId where insertHost_ currentTs groupId = do - (localDisplayName, profileId, _) <- createNewMemberProfile_ db user fromMemberProfile currentTs + (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile currentTs let MemberIdRole {memberId, memberRole} = fromMember indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ do @@ -1375,7 +1375,7 @@ createRelayForOwner :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> Gr createRelayForOwner db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {relayProfile = RelayProfile {displayName}} = do currentTs <- liftIO getCurrentTime let relayProfile = profileFromName displayName - (localDisplayName, memProfileId, _) <- createNewMemberProfile_ db user relayProfile currentTs + (localDisplayName, memProfileId, _) <- createNewMemberProfile_ db cxt user relayProfile currentTs groupMemberId <- createWithRandomId' db gVar $ \memId -> runExceptT $ do indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ @@ -1414,7 +1414,7 @@ getCreateRelayForMember db cxt gVar user@User {userId, userContactId} GroupInfo randRelayId <- liftIO $ encodedRandomBytes gVar 12 let memberId = MemberId $ encodeUtf8 groupLDN <> "_unknown_relay_" <> randRelayId relayProfile = profileFromName $ nameFromBS randRelayId - (localDisplayName, profileId, _) <- createNewMemberProfile_ db user relayProfile currentTs + (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user relayProfile currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId groupMemberId <- liftIO $ do DB.execute @@ -1487,7 +1487,7 @@ setRelayLinkAccepted db cxt user m (MemberKey relayKey) profile = do WHERE group_member_id = ? |] (relayKey, currentTs, gmId) - void $ updateMemberProfile db user m profile + void $ updateMemberProfile db cxt user m profile (,) <$> getGroupMemberById db cxt user gmId <*> getGroupRelayByGMId db gmId setRelayLinkConfId :: DB.Connection -> GroupMember -> ConfirmationId -> ShortLinkContact -> IO () @@ -1534,8 +1534,8 @@ getRelayConfId db m = |] (Only (groupMemberId' m)) -updateRelayMemberData :: DB.Connection -> User -> GroupMember -> MemberId -> MemberKey -> Profile -> ExceptT StoreError IO () -updateRelayMemberData db user m memberId (MemberKey relayKey) profile = do +updateRelayMemberData :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberId -> MemberKey -> Profile -> ExceptT StoreError IO () +updateRelayMemberData db cxt user m memberId (MemberKey relayKey) profile = do currentTs <- liftIO getCurrentTime liftIO $ DB.execute @@ -1546,7 +1546,7 @@ updateRelayMemberData db user m memberId (MemberKey relayKey) profile = do WHERE group_member_id = ? |] (memberId, relayKey, currentTs, groupMemberId' m) - void $ updateMemberProfile db user m profile + void $ updateMemberProfile db cxt user m profile setGroupInProgressDone :: DB.Connection -> GroupInfo -> IO () setGroupInProgressDone db GroupInfo {groupId} = do @@ -1599,7 +1599,7 @@ createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMemb insertOwner_ currentTs groupId = do let MemberIdRole {memberId, memberRole} = fromMember VersionRange minV maxV = reqChatVRange - (localDisplayName, profileId, _) <- createNewMemberProfile_ db user fromMemberProfile currentTs + (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ do DB.execute @@ -1714,9 +1714,10 @@ createNewContactMemberAsync db gVar user@User {userId, userContactId} GroupInfo :. (minV, maxV) ) -createJoiningMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupMemberRole -> GroupMemberStatus -> Maybe MemberKey -> ExceptT StoreError IO (GroupMemberId, MemberId) +createJoiningMember :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupMemberRole -> GroupMemberStatus -> Maybe MemberKey -> ExceptT StoreError IO (GroupMemberId, MemberId) createJoiningMember db + cxt gVar User {userId, userContactId} GroupInfo {groupId, membership} @@ -1729,7 +1730,7 @@ createJoiningMember memberStatus memberKey_ = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ verifyBadge_ srvBadgePublicKey badge + badgeVerified <- liftIO $ verifyBadge_ (badgeKey cxt) badge ExceptT . withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do liftIO $ DB.execute @@ -2071,10 +2072,10 @@ increaseGroupMembersRequireAttention db User {userId} g@GroupInfo {groupId, memb pure g {membersRequireAttention = membersRequireAttention + 1} -- | add new member with profile -createNewGroupMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember -createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} memCategory memStatus = do +createNewGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember +createNewGroupMember db cxt user gInfo invitingMember memInfo@MemberInfo {profile} memCategory memStatus = do currentTs <- liftIO getCurrentTime - (localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db user profile currentTs + (localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user profile currentTs let newMember = NewGroupMember { memInfo, @@ -2089,10 +2090,10 @@ createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} m } createNewMember_ db user gInfo newMember badgeVerified currentTs -createNewMemberProfile_ :: DB.Connection -> User -> Profile -> UTCTime -> ExceptT StoreError IO (Text, ProfileId, Bool) -createNewMemberProfile_ db User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, badge, preferences} createdAt = +createNewMemberProfile_ :: DB.Connection -> StoreCxt -> User -> Profile -> UTCTime -> ExceptT StoreError IO (Text, ProfileId, Bool) +createNewMemberProfile_ db cxt User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, badge, preferences} createdAt = ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do - badgeVerified <- verifyBadge_ srvBadgePublicKey badge + badgeVerified <- verifyBadge_ (badgeKey cxt) badge DB.execute db "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" @@ -2268,15 +2269,16 @@ getMemberRelationsVector db GroupMember {groupMemberId} = "SELECT member_relations_vector FROM group_members WHERE group_member_id = ?" (Only groupMemberId) -createIntroReMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> Maybe MemberRestrictions -> ExceptT StoreError IO GroupMember +createIntroReMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberInfo -> Maybe MemberRestrictions -> ExceptT StoreError IO GroupMember createIntroReMember db + cxt user gInfo memInfo@(MemberInfo _ _ _ memberProfile _) memRestrictions_ = do currentTs <- liftIO getCurrentTime - (localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db user memberProfile currentTs + (localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile currentTs let memRestriction = restriction <$> memRestrictions_ newMember = NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId} createNewMember_ db user gInfo newMember badgeVerified currentTs @@ -3003,10 +3005,10 @@ setMemberContactStartedConnection db Contact {contactId} = do "UPDATE contacts SET grp_direct_inv_started_connection = ?, updated_at = ? WHERE contact_id = ?" (BI True, currentTs, contactId) -updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember -updateMemberProfile db user@User {userId} m p' = do +updateMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember +updateMemberProfile db cxt user@User {userId} m p' = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ profileBadgeVerified (memberProfile m) p' + badgeVerified <- liftIO $ profileBadgeVerified (badgeKey cxt) (memberProfile m) p' let memberProfile = toLocalProfile profileId p' localAlias currentTs badgeVerified updateMemberProfile' currentTs badgeVerified memberProfile where @@ -3026,10 +3028,10 @@ updateMemberProfile db user@User {userId} m p' = do safeDeleteLDN db user localDisplayName pure $ Right m {localDisplayName = ldn, memberProfile} -updateContactMemberProfile :: DB.Connection -> User -> GroupMember -> Contact -> Profile -> ExceptT StoreError IO (GroupMember, Contact) -updateContactMemberProfile db user@User {userId} m ct@Contact {contactId} p' = do +updateContactMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Contact -> Profile -> ExceptT StoreError IO (GroupMember, Contact) +updateContactMemberProfile db cxt user@User {userId} m ct@Contact {contactId} p' = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ profileBadgeVerified (memberProfile m) p' + badgeVerified <- liftIO $ profileBadgeVerified (badgeKey cxt) (memberProfile m) p' let profile = toLocalProfile profileId p' localAlias currentTs badgeVerified updateContactMemberProfile' currentTs badgeVerified profile where @@ -3062,7 +3064,7 @@ createNewUnknownGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> createNewUnknownGroupMember db cxt user@User {userId, userContactId} GroupInfo {groupId} memberId memberName unknownMemberRole = do currentTs <- liftIO getCurrentTime let memberProfile = profileFromName memberName - (localDisplayName, profileId, _) <- createNewMemberProfile_ db user memberProfile currentTs + (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ DB.execute @@ -3087,7 +3089,7 @@ createLinkOwnerMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupId} contactId_ memberId ownerKey = do currentTs <- liftIO getCurrentTime let memberProfile = profileFromName $ nameFromMemberId memberId - (localDisplayName, profileId, _) <- createNewMemberProfile_ db user memberProfile currentTs + (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ DB.execute @@ -3113,7 +3115,7 @@ createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupI -- Updating from an in-band message would allow a compromised relay to substitute keys. updatePreparedChannelMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile} = do - _ <- updateMemberProfile db user member profile + _ <- updateMemberProfile db cxt user member profile currentTs <- liftIO getCurrentTime liftIO $ DB.execute @@ -3134,7 +3136,7 @@ updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupM updateUnknownMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} status = do - _ <- updateMemberProfile db user unknownMember profile + _ <- updateMemberProfile db cxt user unknownMember profile currentTs <- liftIO getCurrentTime liftIO $ DB.execute diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index bbf48a31e8..bbc8182330 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -407,15 +407,15 @@ setCommandConnId db User {userId} cmdId connId = do |] (connId, updatedAt, userId, cmdId) -createContact :: DB.Connection -> User -> Profile -> ExceptT StoreError IO () -createContact db user profile = do +createContact :: DB.Connection -> StoreCxt -> User -> Profile -> ExceptT StoreError IO () +createContact db cxt user profile = do currentTs <- liftIO getCurrentTime - void $ createContact_ db user profile emptyChatPrefs Nothing "" currentTs + void $ createContact_ db cxt user profile emptyChatPrefs Nothing "" currentTs -createContact_ :: DB.Connection -> User -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> ExceptT StoreError IO ContactId -createContact_ db User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs = +createContact_ :: DB.Connection -> StoreCxt -> User -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> ExceptT StoreError IO ContactId +createContact_ db cxt User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs = ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do - badgeVerified <- verifyBadge_ srvBadgePublicKey badge + badgeVerified <- verifyBadge_ (badgeKey cxt) badge DB.execute db "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, chat_peer_type, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 43a1dab873..a905effb4e 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -47,7 +47,8 @@ import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Typeable (Typeable) import Data.Word (Word16) -import Simplex.Chat.Badges (Badge (..), BadgeCrypto (..), BadgeInfo (..), BadgeStatus (..), LocalBadge (..), localBadgeInfo, localBadgeStatus, mkBadgeStatus, srvBadgePublicKey, verifyBadge) +import Simplex.Chat.Badges (Badge (..), BadgeCrypto (..), BadgeInfo (..), BadgeStatus (..), LocalBadge (..), localBadgeInfo, localBadgeStatus, mkBadgeStatus, verifyBadge) +import Simplex.Messaging.Crypto.BBS (BBSPublicKey) import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme @@ -783,13 +784,13 @@ fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contact BadgeProof {} -> Just b BadgeCredential {} -> Nothing -profileBadgeVerified :: LocalProfile -> Profile -> IO Bool -profileBadgeVerified LocalProfile {localBadge} Profile {badge = newBadge} = +profileBadgeVerified :: BBSPublicKey -> LocalProfile -> Profile -> IO Bool +profileBadgeVerified key LocalProfile {localBadge} Profile {badge = newBadge} = case (localBadge, newBadge) of (_, Nothing) -> pure False (Just lb, Just (BadgeProof _ _ newInfo)) | localBadgeInfo lb == newInfo -> pure (localBadgeStatus lb /= BSFailed) - (_, Just newB) -> verifyBadge srvBadgePublicKey newB + (_, Just newB) -> verifyBadge key newB data GroupType = GTChannel @@ -2053,7 +2054,7 @@ 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. -newtype StoreCxt = StoreCxt {vr :: VersionRangeChat} +data StoreCxt = StoreCxt {vr :: VersionRangeChat, badgeKey :: BBSPublicKey} pattern VersionChat :: Word16 -> VersionChat pattern VersionChat v = Version v diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 9fdba5a8e6..c22cf39b51 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -18,7 +18,7 @@ import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.Text as T -import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatHooks (..), defaultChatHooks, mkStoreCxt) import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Protocol (currentChatVersion) import Simplex.Chat.Store.Shared (createContact) @@ -1187,13 +1187,13 @@ testPlanAddressContactViaAddress = Left _ -> error "error parsing contact link" Right cReq -> do let profile = aliceProfile {contactLink = Just cReq} - void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile + void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile bob @@@ [("@alice", "")] bob ##> "/delete @alice" bob <## "alice: contact is deleted" - void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile + void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile bob @@@ [("@alice", "")] bob ##> ("/_connect plan 1 " <> cLink) @@ -1208,7 +1208,7 @@ testPlanAddressContactViaAddress = alice ##> "/delete @bob" alice <## "bob: contact is deleted" - void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile + void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile bob @@@ [("@alice", "")] -- GUI api @@ -1249,13 +1249,13 @@ testPlanAddressContactViaShortAddress = Left _ -> error "error parsing contact link" Right shortLink -> do let profile = aliceProfile {contactLink = Just shortLink} - void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile + void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile bob @@@ [("@alice", "")] bob ##> "/delete @alice" bob <## "alice: contact is deleted" - void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile + void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile bob @@@ [("@alice", "")] bob ##> ("/_connect plan 1 " <> sLink) @@ -1270,7 +1270,7 @@ testPlanAddressContactViaShortAddress = alice ##> "/delete @bob" alice <## "bob: contact is deleted" - void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile + void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile bob @@@ [("@alice", "")] -- GUI api