mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-10-23 00:02:28 +00:00
badge presentation in groups
This commit is contained in:
Evgeny @ SimpleX Chat committed
1 parent
c8466b2010
commit
84e627439a
12 files changed
+328
-177
No files matched your search
+15
-14
@@ -48,6 +48,8 @@ module Simplex.Chat.Badges
|
||||
badgeProof,
|
||||
verifyBadge,
|
||||
verifyBadge_,
|
||||
unboundProof,
|
||||
boundProof,
|
||||
mkBadgeStatus,
|
||||
BadgeRow,
|
||||
BadgeProofKind (..),
|
||||
@@ -318,14 +320,13 @@ instance StrEncoding ProofPresHeader where
|
||||
pure PHFileDescr {chatBinding, fileSize, descrHash, fileExpires = systemToUTCTime <$> expires_}
|
||||
PHUnknownTag c -> PHUnknown c <$> A.takeByteString
|
||||
|
||||
-- v6.5.x accepts both; v7 will reject PHTest/PHUnknown
|
||||
proofPresHeaderAccepted :: ProofPresHeader -> Bool
|
||||
proofPresHeaderAccepted = \case
|
||||
PHTest _ -> True
|
||||
PHChat _ -> True
|
||||
PHFileInv {} -> True
|
||||
PHFileDescr {} -> True
|
||||
PHUnknown _ _ -> True
|
||||
unboundProof :: BadgeProof -> Bool
|
||||
unboundProof BadgeProof {presHeader = BBSPresHeader ph} = case strDecode ph of
|
||||
Right (PHTest _) -> True
|
||||
_ -> False
|
||||
|
||||
boundProof :: Maybe ByteString -> BadgeProof -> Bool
|
||||
boundProof binding_ BadgeProof {presHeader} = maybe False (\b -> presHeader == BBSPresHeader (strEncode (PHChat b))) binding_
|
||||
|
||||
-- Payment proof
|
||||
|
||||
@@ -419,13 +420,13 @@ verifyBadge keys b@(BadgeProof keyIdx _ _ _) = case M.lookup keyIdx keys of
|
||||
Just pk -> Just <$> verifyBadgeWith pk b
|
||||
|
||||
verifyBadgeWith :: BBSPublicKey -> BadgeProof -> IO Bool
|
||||
verifyBadgeWith pk (BadgeProof _ ph@(BBSPresHeader phBytes) proof badgeInfo)
|
||||
| either (const False) proofPresHeaderAccepted (strDecode phBytes) =
|
||||
bbsProofVerify pk proof bbsBadgeHeader ph bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeInfoMessages badgeInfo)
|
||||
| otherwise = pure False
|
||||
verifyBadgeWith pk (BadgeProof _ ph proof badgeInfo) =
|
||||
bbsProofVerify pk proof bbsBadgeHeader ph bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeInfoMessages badgeInfo)
|
||||
|
||||
verifyBadge_ :: Map Int BBSPublicKey -> Maybe BadgeProof -> IO (Maybe Bool)
|
||||
verifyBadge_ keys = maybe (pure (Just False)) (verifyBadge keys)
|
||||
verifyBadge_ :: (BadgeProof -> Bool) -> Map Int BBSPublicKey -> Maybe BadgeProof -> IO (Maybe Bool)
|
||||
verifyBadge_ accepted keys = \case
|
||||
Just b | accepted b -> verifyBadge keys b
|
||||
_ -> pure (Just False)
|
||||
|
||||
-- DB
|
||||
|
||||
|
||||
@@ -2119,7 +2119,7 @@ processChatCommand cxt nm = \case
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- TODO [badges] bind link and badge to handshake context
|
||||
linkProfile <- presentUserBadge user incognitoProfile $ userProfileDirect user incognitoProfile Nothing True
|
||||
linkProfile <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user incognitoProfile Nothing True
|
||||
let userData = contactShortLinkData linkProfile {contactDomain = Nothing} Nothing
|
||||
userLinkData = UserInvLinkData userData
|
||||
(connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation (Just userLinkData) Nothing IKUsePQ True subMode
|
||||
@@ -2141,7 +2141,7 @@ processChatCommand cxt nm = \case
|
||||
updatePCCIncognito db user conn (Just pId) sLnk
|
||||
pure $ CRConnectionIncognitoUpdated user conn' (Just incognitoProfile)
|
||||
(ConnNew, Just pId, False) -> do
|
||||
sLnk <- updatePCCShortLinkData conn =<< presentUserBadge user Nothing (userProfileDirect user Nothing Nothing True)
|
||||
sLnk <- updatePCCShortLinkData conn =<< presentUserBadge user Nothing Nothing (userProfileDirect user Nothing Nothing True)
|
||||
conn' <- withFastStore' $ \db -> do
|
||||
deletePCCIncognitoProfile db user pId
|
||||
updatePCCIncognito db user conn Nothing sLnk
|
||||
@@ -2162,7 +2162,7 @@ processChatCommand cxt nm = \case
|
||||
let short = isJust $ connShortLink' =<< connLinkInv
|
||||
userLinkData_ <-
|
||||
if short
|
||||
then Just . UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing (userProfileDirect newUser Nothing Nothing True)
|
||||
then Just . UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing Nothing (userProfileDirect newUser Nothing Nothing True)
|
||||
else pure Nothing
|
||||
(agConnId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId newUser) True False SCMInvitation userLinkData_ Nothing IKPQOn True subMode
|
||||
ccLink' <- shortenCreatedLink ccLink
|
||||
@@ -2467,7 +2467,7 @@ processChatCommand cxt nm = \case
|
||||
userData <-
|
||||
if isTrue userChatRelay
|
||||
then pure $ relayShortLinkData (userProfileDirect user Nothing Nothing True)
|
||||
else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing (userProfileDirect user Nothing Nothing True)
|
||||
else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing Nothing (userProfileDirect user Nothing Nothing True)
|
||||
let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData, ratchetKeys = Nothing}
|
||||
connId <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True ccLink preparedParams userLinkData subMode
|
||||
let ccLink'' = if isTrue userChatRelay then setShortLinkType CCTRelay ccLink' else ccLink'
|
||||
@@ -3405,7 +3405,7 @@ processChatCommand cxt nm = \case
|
||||
joinPreparedConn subMode conn
|
||||
joinPreparedConn subMode conn = do
|
||||
-- [incognito] send membership incognito profile
|
||||
p <- presentUserBadge user (incognitoMembershipProfile gInfo) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True
|
||||
p <- presentUserBadge user (incognitoMembershipProfile gInfo) Nothing $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True
|
||||
dm <- encodeConnInfo $ XInfo p Nothing
|
||||
sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode
|
||||
let newStatus = if sqSecured then ConnSndReady else ConnJoined
|
||||
@@ -3823,7 +3823,7 @@ processChatCommand cxt nm = \case
|
||||
conn <- withFastStore' $ \db -> createDirectConnection' db userId connId ccLink contactId_ ConnPrepared incognitoProfile subMode chatV pqSup'
|
||||
joinPreparedConn conn incognitoProfile
|
||||
joinPreparedConn conn incognitoProfile = do
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user incognitoProfile Nothing True
|
||||
profileToSend <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user incognitoProfile Nothing True
|
||||
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing
|
||||
sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode
|
||||
let newStatus = if sqSecured then ConnSndReady else ConnJoined
|
||||
@@ -3932,7 +3932,7 @@ processChatCommand cxt nm = \case
|
||||
relayLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
relayMemberId <- case (relayLinkData_, linkEntityId) of
|
||||
(Just RelayShortLinkData {relayProfile = p}, Just entityId) -> do
|
||||
withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) p
|
||||
withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) Nothing p
|
||||
pure $ MemberId entityId
|
||||
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
|
||||
let relayLinkToConnect = CCLink cReq (Just relayLink)
|
||||
@@ -3972,10 +3972,13 @@ processChatCommand cxt nm = \case
|
||||
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfoKeys) -> Maybe MemberId -> PQSupport -> CM Connection
|
||||
joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup = do
|
||||
-- gInfo_ is Maybe (Maybe GroupInfo), where Just Nothing means "some unknown group", e.g. when joining via link without profile
|
||||
profileToSend <-
|
||||
presentUserBadge user incognitoProfile $ case gInfo_ of
|
||||
Just gInfo_' -> userProfileInGroup' user ((\(GIK g _) -> g) <$> gInfo_') incognitoProfile
|
||||
Nothing -> userProfileDirect user incognitoProfile Nothing True
|
||||
profileToSend <- case gInfo_ of
|
||||
Just gInfo_' -> do
|
||||
let p = userProfileInGroup' user ((\(GIK g _) -> g) <$> gInfo_') incognitoProfile
|
||||
case gInfo_' of
|
||||
Just (GIK g _) | useRelays' g -> presentUserBadge user incognitoProfile (Just g) p
|
||||
_ -> pure p
|
||||
Nothing -> presentUserBadge user incognitoProfile Nothing $ userProfileDirect user incognitoProfile Nothing True
|
||||
dm <- case gInfo_ of
|
||||
Just (Just gInfo@(GIK g gks))
|
||||
| useRelays' g -> case relayMemberId_ of
|
||||
@@ -4059,7 +4062,7 @@ processChatCommand cxt nm = \case
|
||||
-- non-incognito (filtered above), so the user's badge is presented; a profile update keeps the badge instead of clearing it
|
||||
ctSndEvent :: ChangedProfileContact -> CM (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
|
||||
ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = do
|
||||
p'' <- presentUserBadge user' Nothing mergedProfile'
|
||||
p'' <- presentUserBadge user' Nothing Nothing mergedProfile'
|
||||
pure (ConnectionId connId, Nothing, XInfo p'' Nothing)
|
||||
ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq
|
||||
ctMsgReq ChangedProfileContact {conn} =
|
||||
@@ -4068,7 +4071,7 @@ processChatCommand cxt nm = \case
|
||||
setMyAddressData :: Bool -> Maybe InitialKeys -> User -> UserContactLink -> CM UserContactLink
|
||||
setMyAddressData rotateKeys pqInitKeys user@User {userChatRelay} ucl@UserContactLink {userContactLinkId, connLinkContact = CCLink connFullLink _, addressSettings} = do
|
||||
conn <- withFastStore $ \db -> getUserAddressConnection db cxt user
|
||||
shortLinkProfile <- presentUserBadge user Nothing (userProfileDirect user Nothing Nothing True)
|
||||
shortLinkProfile <- presentUserBadge user Nothing Nothing (userProfileDirect user Nothing Nothing True)
|
||||
-- TODO [short links] do not save address to server if data did not change, spinners, error handling
|
||||
let userData
|
||||
| isTrue userChatRelay = relayShortLinkData shortLinkProfile
|
||||
@@ -4092,7 +4095,7 @@ processChatCommand cxt nm = \case
|
||||
mergedProfile' = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') False
|
||||
when (mergedProfile' /= mergedProfile) $
|
||||
withContactLock "updateContactPrefs" (contactId' ct) $ do
|
||||
p <- presentUserBadge user incognitoProfile mergedProfile'
|
||||
p <- presentUserBadge user incognitoProfile Nothing mergedProfile'
|
||||
void (sendDirectContactMessage user ct' $ XInfo p Nothing) `catchAllErrors` eToView
|
||||
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
|
||||
pure $ CRContactPrefsUpdated user ct ct'
|
||||
@@ -4312,7 +4315,7 @@ processChatCommand cxt nm = \case
|
||||
pure (relayMember, conn, groupRelay)
|
||||
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
||||
GroupMember {memberId = relayMemberId} = relayMember
|
||||
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) (Just gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
let relayInv = GroupRelayInvitation {
|
||||
fromMember = MemberIdRole userMemberId userRole,
|
||||
fromMemberProfile = membershipProfile,
|
||||
@@ -5208,7 +5211,7 @@ presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadg
|
||||
Right conn
|
||||
| not (connIncognito conn) -> do
|
||||
let ct' = updateMergedPreferences user' ct
|
||||
p <- presentUserBadge user' Nothing $ userProfileDirect user' Nothing (Just ct') False
|
||||
p <- presentUserBadge user' Nothing Nothing $ userProfileDirect user' Nothing (Just ct') False
|
||||
void (sendDirectContactMessage user' ct' (XInfo p Nothing)) `catchAllErrors` eToView
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
@@ -53,7 +53,7 @@ import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Time (addUTCTime)
|
||||
import Data.Time.Calendar (fromGregorian)
|
||||
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime)
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), ProofPresHeader (..), BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), badgeProof, badgeSndGraceInterval, generateBadgeProof, localBadgeStatus, maxXFTPFileSize, mkBadgeStatus, verifyBadge)
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), ProofPresHeader (..), BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), badgeSndGraceInterval, generateBadgeProof, localBadgeStatus, maxXFTPFileSize, mkBadgeStatus, unboundProof, verifyBadge, verifyBadge_)
|
||||
import Simplex.Chat.Names (SimplexDomainClaim (..), claimDomain)
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Controller
|
||||
@@ -995,7 +995,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
|
||||
Just conn@Connection {customUserProfileId} -> do
|
||||
incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
|
||||
pure (ct, conn, ExistingIncognito <$> incognitoProfile)
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
|
||||
profileToSend <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
|
||||
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing
|
||||
(ct,conn,) <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode)
|
||||
|
||||
@@ -1007,7 +1007,7 @@ acceptContactRequestAsync
|
||||
UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId, pqSupport = cReqPQSup}
|
||||
incognitoProfile = do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
|
||||
profileToSend <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
|
||||
cxt <- chatStoreCxt
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
(cmdId, acId) <- prepareAgentAccept user True cReqInvId cReqPQSup
|
||||
@@ -1041,15 +1041,16 @@ acceptGroupJoinRequestAsync
|
||||
-- a roster-established privileged member attaches a connection to its existing record (keeping
|
||||
-- owner-authoritative role + key); everyone else is created fresh with the group-link role
|
||||
cxt <- chatStoreCxt
|
||||
let binding_ = (\mId -> memberChatBinding gInfo mId Nothing) =<< cReqMemberId_
|
||||
(groupMemberId, memberId) <- case existingMem_ of
|
||||
Just m -> do
|
||||
-- refresh the hash placeholder name from the authenticated join profile; role + key stay roster-authoritative
|
||||
withStore $ \db -> do
|
||||
liftIO $ updateGroupMemberStatus db userId m initialStatus
|
||||
void $ updateMemberProfile db cxt user m cReqProfile
|
||||
void $ updateMemberProfile db cxt user m binding_ cReqProfile
|
||||
pure (groupMemberId' m, memberId' m)
|
||||
Nothing -> withStore $ \db ->
|
||||
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_
|
||||
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile binding_ 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
|
||||
@@ -1087,7 +1088,7 @@ acceptGroupJoinSendRejectAsync
|
||||
gVar <- asks random
|
||||
cxt <- chatStoreCxt
|
||||
(groupMemberId, memberId) <- withStore $ \db ->
|
||||
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ Nothing Nothing GRObserver GSMemRejected Nothing
|
||||
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile Nothing cReqXContactId_ Nothing Nothing GRObserver GSMemRejected Nothing
|
||||
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
||||
msg =
|
||||
XGrpLinkReject $
|
||||
@@ -2234,17 +2235,14 @@ sendDirectContactMessages user ct events = do
|
||||
-- present the user's own badge on an outgoing profile: a fresh, single-use proof from the stored credential.
|
||||
-- the send's incognito profile (when set) suppresses it - an incognito identity must never carry the badge.
|
||||
-- a long-expired badge is not presented at all (receivers would hide it anyway).
|
||||
presentUserBadge :: User -> Maybe i -> Profile -> CM Profile
|
||||
presentUserBadge User {profile = LocalProfile {localBadge}} incognitoProfile p = case (incognitoProfile, localBadge) of
|
||||
(Nothing, Just (OwnBadge cred@(BadgeCredential keyIdx _ _ _) st)) | st == BSActive || st == BSExpired -> do
|
||||
keys <- asks $ badgePublicKeys . config
|
||||
case M.lookup keyIdx keys of
|
||||
Nothing -> p <$ logError "presentUserBadge: badge key index not in config"
|
||||
Just key -> do
|
||||
nonce <- drgRandomBytes 16
|
||||
liftIO (badgeProof key cred (PHTest nonce)) >>= \case
|
||||
Right proof -> pure p {badge = Just proof}
|
||||
Left e -> p <$ logError ("presentUserBadge: proof generation failed: " <> T.pack e)
|
||||
presentUserBadge :: User -> Maybe i -> Maybe GroupInfo -> Profile -> CM Profile
|
||||
presentUserBadge user@User {profile = LocalProfile {localBadge}} incognitoProfile gInfo_ p = case (incognitoProfile, localBadge) of
|
||||
(Nothing, Just (OwnBadge _ st)) | st == BSActive || st == BSExpired -> do
|
||||
ph_ <- case gInfo_ of
|
||||
Nothing -> Just . PHTest <$> drgRandomBytes 16
|
||||
Just gInfo -> pure $ PHChat <$> sndGroupChatBinding gInfo False
|
||||
badge <- join <$> mapM (sndBadgeProof user) ph_
|
||||
pure p {badge}
|
||||
_ -> pure p
|
||||
|
||||
|
||||
@@ -2255,7 +2253,7 @@ linkDataBadge cld@ContactShortLinkData {profile = Profile {badge}} = case badge
|
||||
Nothing -> pure cld
|
||||
Just b@(BadgeProof _ _ _ info) -> do
|
||||
keys <- asks $ badgePublicKeys . config
|
||||
verified <- liftIO $ verifyBadge keys b
|
||||
verified <- liftIO $ verifyBadge_ unboundProof keys badge
|
||||
now <- liftIO getCurrentTime
|
||||
pure (cld :: ContactShortLinkData) {localBadge = Just $ ShownBadge info (mkBadgeStatus now verified info)}
|
||||
|
||||
@@ -2315,7 +2313,10 @@ groupMsgSigning sign (GIK gInfo@GroupInfo {membership = GroupMember {memberId}}
|
||||
where
|
||||
memberPrivKey' = memberPrivKey gks
|
||||
tag = toCMEventTag evt
|
||||
shouldSign = requiresSignature tag || (sign && signableContent tag)
|
||||
shouldSign = requiresSignature tag || (sign && signableContent tag) || badgePresented
|
||||
badgePresented = case evt of
|
||||
XGrpMemInfo _ Profile {badge} -> isJust badge
|
||||
_ -> False
|
||||
bindingData = groupBindingData gInfo memberId (C.publicKey memberPrivKey')
|
||||
|
||||
groupBindingData :: GroupInfo -> MemberId -> C.PublicKeyEd25519 -> ByteString
|
||||
@@ -2335,12 +2336,15 @@ rcvGroupChatBinding gInfo m_ asGroup badge_ =
|
||||
case (publicGroup' gInfo, asGroup, m_) of
|
||||
(Just PublicGroupProfile {publicGroupId}, True, _) ->
|
||||
Just $ encodeChatBinding CBChannel $ smpEncode publicGroupId
|
||||
(Just PublicGroupProfile {publicGroupId}, False, Just GroupMember {memberId}) ->
|
||||
Just $ encodeChatBinding CBGroup $ smpEncode (publicGroupId, memberId)
|
||||
(Nothing, False, Just GroupMember {memberId, memberPubKey}) ->
|
||||
(\k -> encodeChatBinding CBGroup $ smpEncode (memberId, k)) <$> (memberPubKey <|> proofMemberKey memberId badge_)
|
||||
(_, False, Just GroupMember {memberId, memberPubKey}) ->
|
||||
memberChatBinding gInfo memberId (memberPubKey <|> proofMemberKey memberId badge_)
|
||||
_ -> Nothing
|
||||
|
||||
memberChatBinding :: GroupInfo -> MemberId -> Maybe C.PublicKeyEd25519 -> Maybe ByteString
|
||||
memberChatBinding gInfo memberId key_ = case publicGroup' gInfo of
|
||||
Just PublicGroupProfile {publicGroupId} -> Just $ encodeChatBinding CBGroup $ smpEncode (publicGroupId, memberId)
|
||||
Nothing -> (\k -> encodeChatBinding CBGroup $ smpEncode (memberId, k)) <$> key_
|
||||
|
||||
proofMemberKey :: MemberId -> Maybe BadgeProof -> Maybe C.PublicKeyEd25519
|
||||
proofMemberKey memberId badge_ = do
|
||||
BadgeProof _ (BBSPresHeader phBytes) _ _ <- badge_
|
||||
@@ -2649,7 +2653,7 @@ sendGroupProfileUpdate user g@(GIK gInfo gks) scope asGroup members =
|
||||
_ -> False
|
||||
sendProfileUpdate = do
|
||||
-- shouldSendProfileUpdate excludes incognito membership, so the badge is presented
|
||||
profileUpdate <- presentUserBadge user Nothing $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p
|
||||
profileUpdate <- presentUserBadge user Nothing (Just gInfo) $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p
|
||||
void $ sendGroupMessage' user g members $ XInfo profileUpdate (Just $ groupMemberKey gks)
|
||||
currentTs <- liftIO getCurrentTime
|
||||
withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
|
||||
|
||||
@@ -502,7 +502,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
(conn'', gInfo_) <- saveConnInfo conn' connInfo
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
profileToSend <-
|
||||
presentUserBadge user incognitoProfile $ case gInfo_ of
|
||||
presentUserBadge user incognitoProfile ((\(GIK gInfo _) -> gInfo) <$> gInfo_) $ case gInfo_ of
|
||||
Just (GIK gInfo _) -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
|
||||
Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
@@ -621,7 +621,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
ct' <- processContactProfileUpdate ct profile False `catchAllErrors` const (pure ct)
|
||||
-- [incognito] send incognito profile
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
|
||||
p <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True
|
||||
p <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True
|
||||
allowAgentConnectionAsync user conn'' confId Nothing $ XInfo p Nothing
|
||||
void $ withStore' $ \db -> resetMemberContactFields db ct'
|
||||
XGrpLinkInv glInv -> do
|
||||
@@ -634,7 +634,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
|
||||
-- [incognito] send saved profile
|
||||
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
|
||||
profileToSend <- presentUserBadge user incognitoProfile (Just gInfo) $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
|
||||
let gks = GKGroup {memberPrivKey = snd memberKeys}
|
||||
allowAgentConnectionAsync user conn'' confId (Just $ GIK gInfo gks) $ XInfo profileToSend (Just $ groupMemberKey gks)
|
||||
toView $ CEvtBusinessLinkConnecting user gInfo host ct
|
||||
@@ -778,7 +778,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
|
||||
CRContactUri _ _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
|
||||
CONF confId _pqSupport _ connInfo -> do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
||||
(signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo
|
||||
conn' <- updatePeerChatVRange conn chatVRange
|
||||
case memberCategory m of
|
||||
GCInviteeMember ->
|
||||
@@ -823,7 +823,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
|
||||
-- [incognito] send saved profile
|
||||
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo' (fromLocalProfile <$> incognitoProfile)
|
||||
profileToSend <- presentUserBadge user incognitoProfile (Just gInfo') $ userProfileInGroup user gInfo' (fromLocalProfile <$> incognitoProfile)
|
||||
allowAgentConnectionAsync user conn' confId (Just $ GIK gInfo' gks) $ XInfo profileToSend (Just $ groupMemberKey gks)
|
||||
toView $ CEvtGroupLinkConnecting user gInfo' m'
|
||||
| otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch"
|
||||
@@ -834,23 +834,26 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
_ -> messageError "CONF from host member in prepared group must have x.grp.link.inv or x.grp.link.reject"
|
||||
_ ->
|
||||
case chatMsgEvent of
|
||||
XGrpMemInfo memId _memProfile
|
||||
XGrpMemInfo memId memProfile
|
||||
| sameMemberId memId m -> do
|
||||
let GroupMember {memberId = membershipMemId} = membership
|
||||
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
-- TODO update member profile
|
||||
p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
membershipProfile <-
|
||||
if maxVersion (peerChatVRange conn') >= relayWebCapVersion
|
||||
then presentUserBadge user (incognitoMembershipProfile gInfo) (Just gInfo) p
|
||||
else pure p
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo membershipMemId membershipProfile
|
||||
void $ processMemberProfileUpdate gInfo m (signedMemberBinding gInfo m signedMsg_) memProfile Nothing
|
||||
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
||||
_ -> messageError "CONF from member must have x.grp.mem.info"
|
||||
INFO _pqSupport connInfo -> do
|
||||
(signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo
|
||||
_conn' <- updatePeerChatVRange conn chatVRange
|
||||
case chatMsgEvent of
|
||||
XGrpMemInfo memId _memProfile
|
||||
| sameMemberId memId m -> do
|
||||
-- TODO update member profile
|
||||
pure ()
|
||||
XGrpMemInfo memId memProfile
|
||||
| sameMemberId memId m ->
|
||||
void $ processMemberProfileUpdate gInfo m (signedMemberBinding gInfo m signedMsg_) memProfile Nothing
|
||||
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
||||
-- sent when connecting via group link
|
||||
XInfo _ mKey
|
||||
@@ -964,7 +967,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
where
|
||||
sendXGrpLinkMem gInfo'' m' = do
|
||||
let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo''
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo'' (fromIncognitoProfile <$> incognitoProfile)
|
||||
profileToSend <- presentUserBadge user incognitoProfile (Just gInfo'') $ userProfileInGroup user gInfo'' (fromIncognitoProfile <$> incognitoProfile)
|
||||
sendGroupMemberMessages user (GIK gInfo'' gks) conn [XGrpLinkMem profileToSend (Just $ groupMemberKey gks)]
|
||||
_ -> do
|
||||
unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected
|
||||
@@ -1089,7 +1092,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew (GIK gInfo' gks) m'' memInfo msgScope msg brokerTs
|
||||
XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_
|
||||
XGrpMemInv memId introInv -> Nothing <$ xGrpMemInv gInfo' m'' memId introInv
|
||||
XGrpMemFwd memInfo introInv -> Nothing <$ xGrpMemFwd gInfo' m'' memInfo introInv
|
||||
XGrpMemFwd memInfo introInv -> Nothing <$ xGrpMemFwd (GIK gInfo' gks) m'' memInfo introInv
|
||||
XGrpMemRole memId memRole memberKey rosterVer -> fmap ctx <$> xGrpMemRole (GIK gInfo' gks) Nothing m'' memId memRole memberKey rosterVer msg brokerTs
|
||||
XGrpMemRestrict memId memRestrictions -> fmap ctx <$> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs
|
||||
XGrpMemCon memId -> Nothing <$ xGrpMemCon gInfo' m'' memId
|
||||
@@ -1231,7 +1234,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
relayLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
relayMemberId <- case (relayLinkData_, linkEntityId) of
|
||||
(Just RelayShortLinkData {relayProfile = p}, Just entityId) -> do
|
||||
withStore $ \db -> updateRelayMemberData db cxt user m (MemberId entityId) (MemberKey relayKey) p
|
||||
withStore $ \db -> updateRelayMemberData db cxt user m (MemberId entityId) (MemberKey relayKey) Nothing p
|
||||
pure $ MemberId entityId
|
||||
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
|
||||
case cReq of
|
||||
@@ -1246,7 +1249,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
-- Update connection with data derived from cReq, now available after getConnShortLinkAsync
|
||||
withStore' $ \db -> updateConnLinkData db user conn cReq cReqHash groupLinkId chatV pqSup
|
||||
let incognitoProfile = fromLocalProfile <$> incognitoMembershipProfile gInfo
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo incognitoProfile
|
||||
profileToSend <- presentUserBadge user incognitoProfile (Just gInfo) $ userProfileInGroup user gInfo incognitoProfile
|
||||
dm <- encodeXMemberConnInfo g relayMemberId profileToSend
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
(cmdId, connId') <- prepareAgentJoin user (Just conn) True cReq
|
||||
@@ -1261,7 +1264,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
(confId, m', relay) <- withStore $ \db -> do
|
||||
confId <- getRelayConfId db m
|
||||
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
||||
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
|
||||
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) Nothing relayProfile
|
||||
pure (confId, m', relay)
|
||||
allowAgentConnectionAsync user conn confId (Just g) XOk
|
||||
toView $ CEvtGroupRelayUpdated user gInfo m' relay
|
||||
@@ -2796,33 +2799,44 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
Profile {displayName = n', fullName = fn', shortDescr = sd', image = i', contactLink = cl'} = p'
|
||||
|
||||
xInfoMember :: GroupInfo -> GroupMember -> Profile -> Maybe MemberKey -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xInfoMember gInfo m p' mKey msg@RcvMessage {signedMsg_} brokerTs = do
|
||||
mapM_ (storeMemberKey gInfo m signedMsg_) mKey
|
||||
void $ processMemberProfileUpdate gInfo m p' (Just (msg, brokerTs))
|
||||
xInfoMember gInfo m p' mKey msg brokerTs = do
|
||||
binding_ <- verifiedMemberBinding gInfo m mKey msg
|
||||
void $ processMemberProfileUpdate gInfo m binding_ p' (Just (msg, brokerTs))
|
||||
pure $ memberEventDeliveryScope m
|
||||
|
||||
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> Maybe MemberKey -> RcvMessage -> CM ()
|
||||
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' mKey RcvMessage {signedMsg_} = do
|
||||
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' mKey msg = do
|
||||
xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId
|
||||
if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived
|
||||
then do
|
||||
mapM_ (storeMemberKey gInfo m signedMsg_) mKey
|
||||
m' <- processMemberProfileUpdate gInfo m p' Nothing
|
||||
binding_ <- verifiedMemberBinding gInfo m mKey msg
|
||||
m' <- processMemberProfileUpdate gInfo m binding_ p' Nothing
|
||||
withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True
|
||||
let connectedIncognito = memberIncognito membership
|
||||
probeMatchingMemberContact m' connectedIncognito
|
||||
else messageError "x.grp.link.mem error: invalid group link host profile update"
|
||||
|
||||
storeMemberKey :: GroupInfo -> GroupMember -> Maybe SignedMsg -> MemberKey -> CM ()
|
||||
verifiedMemberBinding :: GroupInfo -> GroupMember -> Maybe MemberKey -> RcvMessage -> CM (Maybe ByteString)
|
||||
verifiedMemberBinding gInfo m@GroupMember {memberId, memberPubKey} mKey RcvMessage {msgSigned, signedMsg_} = do
|
||||
storedKey_ <- maybe (pure Nothing) (storeMemberKey gInfo m signedMsg_) mKey
|
||||
let key_ = if msgSigned == Just MSSVerified then memberPubKey else storedKey_
|
||||
pure $ memberChatBinding gInfo memberId key_
|
||||
|
||||
signedMemberBinding :: GroupInfo -> GroupMember -> Maybe SignedMsg -> Maybe ByteString
|
||||
signedMemberBinding gInfo GroupMember {memberId, memberPubKey} signedMsg_ =
|
||||
memberChatBinding gInfo memberId $ mfilter (\k -> memberSigned gInfo memberId k signedMsg_) memberPubKey
|
||||
|
||||
memberSigned :: GroupInfo -> MemberId -> C.PublicKeyEd25519 -> Maybe SignedMsg -> Bool
|
||||
memberSigned gInfo memberId k = \case
|
||||
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} -> verifyGroupSig k gInfo memberId signatures signedBody
|
||||
_ -> False
|
||||
|
||||
storeMemberKey :: GroupInfo -> GroupMember -> Maybe SignedMsg -> MemberKey -> CM (Maybe C.PublicKeyEd25519)
|
||||
storeMemberKey gInfo GroupMember {groupMemberId, memberPubKey, memberId} signedMsg_ (MemberKey k) = case memberPubKey of
|
||||
Just k0 -> when (k /= k0) $ messageError "member key change rejected, keeping current key"
|
||||
Just k0 -> Nothing <$ when (k /= k0) (messageError "member key change rejected, keeping current key")
|
||||
Nothing
|
||||
| signed -> withStore' $ \db -> setMemberPubKey db groupMemberId k
|
||||
| otherwise -> messageError "member key not signed by that key, ignored"
|
||||
where
|
||||
signed = case signedMsg_ of
|
||||
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} -> verifyGroupSig k gInfo memberId signatures signedBody
|
||||
_ -> False
|
||||
| memberSigned gInfo memberId k signedMsg_ -> Just k <$ withStore' (\db -> setMemberPubKey db groupMemberId k)
|
||||
| otherwise -> Nothing <$ messageError "member key not signed by that key, ignored"
|
||||
|
||||
xGrpLinkAcpt :: GroupInfoKeys -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
|
||||
xGrpLinkAcpt g@(GIK gInfo@GroupInfo {membership} _) m acceptance role memberId msg brokerTs
|
||||
@@ -2882,14 +2896,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
unless (groupFeatureAllowed SGFHistory gInfo) $ forM_ description $ \descr ->
|
||||
createInternalChatItem user (CDGroupRcv gInfo Nothing m) (CIRcvMsgContent $ MCText descr) Nothing
|
||||
|
||||
processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember
|
||||
processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} p' msgTs_
|
||||
processMemberProfileUpdate :: GroupInfo -> GroupMember -> Maybe ByteString -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember
|
||||
processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} binding_ p' msgTs_
|
||||
-- a failed/unknown-key badge is re-verified even when content is unchanged, so it heals after an app update adds the key
|
||||
| contentChanged || badgeNeedsReverify p = do
|
||||
when contentChanged $ updateBusinessChatProfile gInfo
|
||||
case memberContactId of
|
||||
Nothing -> do
|
||||
m' <- withStore $ \db -> updateMemberProfile db cxt user m p''
|
||||
m' <- withStore $ \db -> updateMemberProfile db cxt user m binding_ p''
|
||||
unless (muteEventInChannel gInfo m') $ do
|
||||
when contentChanged $ forM_ msgTs_ $ createProfileUpdatedItem m'
|
||||
toView $ CEvtGroupMemberUpdated user gInfo m m'
|
||||
@@ -2898,7 +2912,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
mCt <- withStore $ \db -> getContact db cxt user mContactId
|
||||
if canUpdateProfile mCt
|
||||
then do
|
||||
(m', ct') <- withStore $ \db -> updateContactMemberProfile db cxt user m mCt p'
|
||||
(m', ct') <- withStore $ \db -> updateContactMemberProfile db cxt user m mCt binding_ p'
|
||||
unless (muteEventInChannel gInfo m') $ do
|
||||
when contentChanged $ forM_ msgTs_ $ createProfileUpdatedItem m'
|
||||
toView $ CEvtGroupMemberUpdated user gInfo m m'
|
||||
@@ -3180,6 +3194,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
xGrpMemNew :: GroupInfoKeys -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xGrpMemNew (GIK gInfo gks) m memInfo@(MemberInfo memId memRole _ _ assertedKey_) msgScope_ msg brokerTs = do
|
||||
unless (useRelays' gInfo) $ checkHostRole m memRole
|
||||
let binding_ = memberChatBinding gInfo memId Nothing
|
||||
if sameMemberId memId (membership gInfo)
|
||||
then pure Nothing
|
||||
else
|
||||
@@ -3196,7 +3211,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
-- TODO [relays] member: surface relay-key-mismatch as a dedicated event / chat item / relay state
|
||||
when (assertedKey /= memberPubKey unknownMember) $
|
||||
messageWarning $ "x.grp.mem.new: relay asserted key differs from roster-established key, keeping roster key, memberId=" <> safeDecodeUtf8 (strEncode memId)
|
||||
updatedMember <- withStore $ \db -> updateRosterMemberAnnounced db cxt user m unknownMember memInfo initialStatus
|
||||
updatedMember <- withStore $ \db -> updateRosterMemberAnnounced db cxt user m unknownMember memInfo binding_ initialStatus
|
||||
-- roster members can't be pending, so no members-require-attention update
|
||||
gInfo' <- updatePublicGroupData user gInfo gks
|
||||
toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember
|
||||
@@ -3207,7 +3222,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
messageError "x.grp.mem.new: privileged role not established by roster" $> Nothing
|
||||
| otherwise -> do
|
||||
(updatedMember, gInfo') <- withStore $ \db -> do
|
||||
updatedMember <- updateUnknownMemberAnnounced db cxt user m unknownMember memInfo initialStatus
|
||||
updatedMember <- updateUnknownMemberAnnounced db cxt user m unknownMember memInfo binding_ initialStatus
|
||||
gInfo' <-
|
||||
if memberPending updatedMember
|
||||
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
|
||||
@@ -3225,7 +3240,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
| useRelays' gInfo && isPrivilegedRole memRole -> messageError "x.grp.mem.new: privileged member not established by roster" $> Nothing
|
||||
| otherwise -> do
|
||||
(newMember, gInfo') <- withStore $ \db -> do
|
||||
newMember <- createNewGroupMember db cxt user gInfo m memInfo GCPostMember initialStatus
|
||||
newMember <- createNewGroupMember db cxt user gInfo m memInfo binding_ GCPostMember initialStatus
|
||||
gInfo' <-
|
||||
if memberPending newMember
|
||||
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
|
||||
@@ -3261,12 +3276,13 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
|
||||
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM ()
|
||||
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ _) memRestrictions = do
|
||||
let binding_ = memberChatBinding gInfo memId Nothing
|
||||
case memberCategory m of
|
||||
GCHostMember ->
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
|
||||
Right existingMember
|
||||
| useRelays' gInfo -> do
|
||||
updatedMember <- withStore $ \db -> updatePreparedChannelMember db cxt user existingMember memInfo
|
||||
updatedMember <- withStore $ \db -> updatePreparedChannelMember db cxt user existingMember memInfo binding_
|
||||
toView $ CEvtGroupMemberUpdated user gInfo existingMember updatedMember
|
||||
| otherwise ->
|
||||
messageError "x.grp.mem.intro ignored: member already exists"
|
||||
@@ -3279,7 +3295,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
MemberInfo mId mRole v p _
|
||||
| mRole >= GRMember -> MemberInfo mId defaultRole v p Nothing
|
||||
_ -> memInfo
|
||||
void $ withStore $ \db -> createIntroReMember db cxt user gInfo memInfo' memRestrictions
|
||||
void $ withStore $ \db -> createIntroReMember db cxt user gInfo memInfo' binding_ memRestrictions
|
||||
| otherwise -> do
|
||||
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c)
|
||||
case memChatVRange of
|
||||
@@ -3289,7 +3305,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
groupConnIds@(cmdId, connId) <- prepareAgentCreation user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation
|
||||
let chatV = maybe (minVersion (vr cxt)) (\peerVR -> vr cxt `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
|
||||
void $ withStore $ \db -> do
|
||||
reMember <- createIntroReMember db cxt user gInfo memInfo memRestrictions
|
||||
reMember <- createIntroReMember db cxt user gInfo memInfo binding_ memRestrictions
|
||||
createIntroReMemberConn db user m reMember chatV memInfo groupConnIds subMode
|
||||
withAgent $ \a -> createConnectionAsync a (aCorrId cmdId) connId (chatHasNtfs chatSettings) SCMInvitation CR.IKPQOff True subMode
|
||||
_ -> messageError "x.grp.mem.intro can be only sent by host member"
|
||||
@@ -3310,8 +3326,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
Right reMember -> sendGroupMemberMessage gInfo reMember $ XGrpMemFwd (memberInfo gInfo m) introInv
|
||||
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
|
||||
|
||||
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
|
||||
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _ _) IntroInvitation {groupConnReq, directConnReq} = do
|
||||
xGrpMemFwd :: GroupInfoKeys -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
|
||||
xGrpMemFwd g@(GIK gInfo@GroupInfo {membership, chatSettings} _) m memInfo@(MemberInfo memId memRole memChatVRange _ _) IntroInvitation {groupConnReq, directConnReq} = do
|
||||
let GroupMember {memberId = membershipMemId} = membership
|
||||
checkHostRole m memRole
|
||||
toMember <- withStore $ \db -> do
|
||||
@@ -3322,7 +3338,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
-- 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 cxt user gInfo m memInfo GCPostMember GSMemAnnounced
|
||||
SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db cxt user gInfo m memInfo (memberChatBinding gInfo memId Nothing) GCPostMember GSMemAnnounced
|
||||
e -> throwError e
|
||||
-- TODO [knocking] separate pending statuses from GroupMemberStatus?
|
||||
-- TODO add GSMemIntroInvitedPending, GSMemConnectedPending, etc.?
|
||||
@@ -3331,16 +3347,21 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
liftIO $ updateGroupMemberStatus db userId toMember newMemberStatus
|
||||
pure toMember
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
|
||||
chatV = vr cxt `peerConnChatVersion` mcvr
|
||||
p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
-- [incognito] send membership incognito profile, create direct connection as incognito
|
||||
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
dm <- encodeConnInfo $ XGrpMemInfo membershipMemId membershipProfile
|
||||
membershipProfile <-
|
||||
if chatV >= relayWebCapVersion
|
||||
then presentUserBadge user (incognitoMembershipProfile gInfo) (Just gInfo) p
|
||||
else pure p
|
||||
let msg = XGrpMemInfo membershipMemId membershipProfile
|
||||
dm <- maybe (encodeConnInfo msg) (`encodeSignedConnInfo` msg) (groupMsgSigning False g msg)
|
||||
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
|
||||
let enableNtfsGrp = chatHasNtfs chatSettings
|
||||
groupConnIds@(gCmdId, gAcId) <- prepareAgentJoin user Nothing enableNtfsGrp groupConnReq
|
||||
directConnIds <- mapM (prepareAgentJoin user Nothing True) directConnReq
|
||||
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
|
||||
mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
|
||||
chatV = vr cxt `peerConnChatVersion` mcvr
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode
|
||||
joinAgentConnectionAsync gCmdId False gAcId enableNtfsGrp groupConnReq dm subMode
|
||||
forM_ ((,) <$> directConnIds <*> directConnReq) $ \((dCmdId, dAcId), dcr) ->
|
||||
@@ -3909,7 +3930,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
|
||||
createItems mCt m'
|
||||
joinMemberContactAsync cmdId acId subMode = do
|
||||
-- [incognito] send membership incognito profile
|
||||
p <- presentUserBadge user (incognitoMembershipProfile g) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True
|
||||
p <- presentUserBadge user (incognitoMembershipProfile g) Nothing $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True
|
||||
-- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ)
|
||||
dm <- encodeConnInfo $ XInfo p Nothing
|
||||
joinAgentConnectionAsync cmdId False acId True connReq dm subMode
|
||||
|
||||
@@ -24,7 +24,7 @@ import Control.Monad.IO.Class
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Int (Int64)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Simplex.Chat.Badges (badgeToRow, verifyBadge_)
|
||||
import Simplex.Chat.Badges (badgeToRow, unboundProof, verifyBadge_)
|
||||
import Simplex.Chat.Protocol (MsgContent, businessChatsVersion)
|
||||
import Simplex.Chat.Store.Direct
|
||||
import Simplex.Chat.Store.Groups
|
||||
@@ -167,7 +167,7 @@ createOrUpdateContactRequest
|
||||
createContactRequest :: ExceptT StoreError IO RequestStage
|
||||
createContactRequest = do
|
||||
currentTs <- liftIO $ getCurrentTime
|
||||
badgeVerified <- liftIO $ verifyBadge_ (badgeKeys cxt) badge
|
||||
badgeVerified <- liftIO $ verifyBadge_ unboundProof (badgeKeys cxt) badge
|
||||
ExceptT $ withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -234,7 +234,7 @@ createOrUpdateContactRequest
|
||||
pure $ RSCurrentRequest (Just ucr) ucr' re_
|
||||
where
|
||||
updateProfile currentTs = do
|
||||
badgeVerified <- liftIO $ verifyBadge_ (badgeKeys cxt) badge
|
||||
badgeVerified <- liftIO $ verifyBadge_ unboundProof (badgeKeys cxt) badge
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
|
||||
@@ -108,7 +108,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Data.Type.Equality
|
||||
import Simplex.Chat.Badges (badgeToRow)
|
||||
import Simplex.Chat.Badges (badgeToRow, unboundProof)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Names (SimplexDomainClaim (..))
|
||||
@@ -565,7 +565,7 @@ deleteUnusedProfile_ db userId profileId =
|
||||
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 (badgeKeys cxt) lp p'
|
||||
badgeVerified <- liftIO $ profileBadgeVerified unboundProof (badgeKeys cxt) lp p'
|
||||
let nameVerified = if claimChanged then Nothing else prevVerification
|
||||
profile = toLocalProfile profileId p'' localAlias currentTs badgeVerified nameVerified
|
||||
updateContactProfile' currentTs badgeVerified profile
|
||||
|
||||
@@ -230,7 +230,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, getCurrentTime)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Simplex.Chat.Badges (BadgeRow, badgeToRow, verifyBadge_)
|
||||
import Simplex.Chat.Badges (BadgeRow, badgeToRow, boundProof, verifyBadge_)
|
||||
import Simplex.Chat.Names (SimplexDomainClaim (..))
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Operators
|
||||
@@ -677,7 +677,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 cxt user hostProfile currentTs
|
||||
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user hostProfile Nothing currentTs
|
||||
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
|
||||
liftIO $ do
|
||||
DB.execute
|
||||
@@ -834,7 +834,7 @@ updatePreparedUserAndHostMembers'
|
||||
|]
|
||||
(memberId, memberRole, membershipStatus, currentTs, groupMemberId' membership)
|
||||
updateHostMember currentTs = do
|
||||
_ <- updateMemberProfile db cxt user hostMember fromMemberProfile
|
||||
_ <- updateMemberProfile db cxt user hostMember Nothing fromMemberProfile
|
||||
let MemberIdRole memberId memberRole = fromMember
|
||||
gmId = groupMemberId' hostMember
|
||||
liftIO $
|
||||
@@ -885,7 +885,7 @@ createGroupViaLink'
|
||||
(,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId
|
||||
where
|
||||
insertHost_ currentTs groupId = do
|
||||
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile currentTs
|
||||
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile Nothing currentTs
|
||||
let MemberIdRole {memberId, memberRole} = fromMember
|
||||
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
|
||||
liftIO $ do
|
||||
@@ -1713,7 +1713,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 cxt user relayProfile currentTs
|
||||
(localDisplayName, memProfileId, _) <- createNewMemberProfile_ db cxt user relayProfile Nothing currentTs
|
||||
groupMemberId <- createWithRandomId' db gVar $ \memId -> runExceptT $ do
|
||||
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
|
||||
liftIO $
|
||||
@@ -1752,7 +1752,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 cxt user relayProfile currentTs
|
||||
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user relayProfile Nothing currentTs
|
||||
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
|
||||
groupMemberId <- liftIO $ do
|
||||
DB.execute
|
||||
@@ -1805,8 +1805,8 @@ 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 -> StoreCxt -> User -> GroupMember -> MemberKey -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
|
||||
setRelayLinkAccepted db cxt user m (MemberKey relayKey) profile = do
|
||||
setRelayLinkAccepted :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberKey -> Maybe ByteString -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
|
||||
setRelayLinkAccepted db cxt user m (MemberKey relayKey) binding_ profile = do
|
||||
let gmId = groupMemberId' m
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $ DB.execute
|
||||
@@ -1825,7 +1825,7 @@ setRelayLinkAccepted db cxt user m (MemberKey relayKey) profile = do
|
||||
WHERE group_member_id = ?
|
||||
|]
|
||||
(relayKey, currentTs, gmId)
|
||||
void $ updateMemberProfile db cxt user m profile
|
||||
void $ updateMemberProfile db cxt user m binding_ profile
|
||||
(,) <$> getGroupMemberById db cxt user gmId <*> getGroupRelayByGMId db gmId
|
||||
|
||||
setRelayLinkConfId :: DB.Connection -> GroupMember -> ConfirmationId -> ShortLinkContact -> IO ()
|
||||
@@ -1872,8 +1872,8 @@ getRelayConfId db m =
|
||||
|]
|
||||
(Only (groupMemberId' m))
|
||||
|
||||
updateRelayMemberData :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberId -> MemberKey -> Profile -> ExceptT StoreError IO ()
|
||||
updateRelayMemberData db cxt user m memberId (MemberKey relayKey) profile = do
|
||||
updateRelayMemberData :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberId -> MemberKey -> Maybe ByteString -> Profile -> ExceptT StoreError IO ()
|
||||
updateRelayMemberData db cxt user m memberId (MemberKey relayKey) binding_ profile = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -1884,7 +1884,7 @@ updateRelayMemberData db cxt user m memberId (MemberKey relayKey) profile = do
|
||||
WHERE group_member_id = ?
|
||||
|]
|
||||
(memberId, relayKey, currentTs, groupMemberId' m)
|
||||
void $ updateMemberProfile db cxt user m profile
|
||||
void $ updateMemberProfile db cxt user m binding_ profile
|
||||
|
||||
setGroupInProgressDone :: DB.Connection -> GroupInfo -> IO ()
|
||||
setGroupInProgressDone db GroupInfo {groupId} = do
|
||||
@@ -1937,7 +1937,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 cxt user fromMemberProfile currentTs
|
||||
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile Nothing currentTs
|
||||
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
|
||||
liftIO $ do
|
||||
DB.execute
|
||||
@@ -2066,7 +2066,7 @@ getRelayInactiveGroups db cxt User {userId, userContactId} ttl = do
|
||||
)
|
||||
(userId, userContactId, RSInactive, cutoffTs)
|
||||
|
||||
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.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> VersionRangeChat -> Profile -> Maybe ByteString -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupMemberRole -> GroupMemberStatus -> Maybe MemberKey -> ExceptT StoreError IO (GroupMemberId, MemberId)
|
||||
createJoiningMember
|
||||
db
|
||||
cxt
|
||||
@@ -2075,6 +2075,7 @@ createJoiningMember
|
||||
GroupInfo {groupId, membership}
|
||||
cReqChatVRange
|
||||
Profile {displayName, fullName, shortDescr, description, image, contactLink, badge, preferences}
|
||||
binding_
|
||||
cReqXContactId_
|
||||
cReqMemberId_
|
||||
welcomeMsgId_
|
||||
@@ -2082,7 +2083,7 @@ createJoiningMember
|
||||
memberStatus
|
||||
memberKey_ = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
badgeVerified <- liftIO $ verifyBadge_ (badgeKeys cxt) badge
|
||||
badgeVerified <- liftIO $ verifyBadge_ (boundProof binding_) (badgeKeys cxt) badge
|
||||
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -2416,10 +2417,10 @@ increaseGroupMembersRequireAttention db User {userId} g@GroupInfo {groupId, memb
|
||||
pure g {membersRequireAttention = membersRequireAttention + 1}
|
||||
|
||||
-- | add new member with profile
|
||||
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
|
||||
createNewGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> MemberInfo -> Maybe ByteString -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
|
||||
createNewGroupMember db cxt user gInfo invitingMember memInfo@MemberInfo {profile} binding_ memCategory memStatus = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
(localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user profile currentTs
|
||||
(localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user profile binding_ currentTs
|
||||
let newMember =
|
||||
NewGroupMember
|
||||
{ memInfo,
|
||||
@@ -2434,10 +2435,10 @@ createNewGroupMember db cxt user gInfo invitingMember memInfo@MemberInfo {profil
|
||||
}
|
||||
createNewMember_ db user gInfo newMember badgeVerified currentTs
|
||||
|
||||
createNewMemberProfile_ :: DB.Connection -> StoreCxt -> User -> Profile -> UTCTime -> ExceptT StoreError IO (Text, ProfileId, Maybe Bool)
|
||||
createNewMemberProfile_ db cxt User {userId} Profile {displayName, fullName, shortDescr, description, image, contactLink, badge, preferences} createdAt =
|
||||
createNewMemberProfile_ :: DB.Connection -> StoreCxt -> User -> Profile -> Maybe ByteString -> UTCTime -> ExceptT StoreError IO (Text, ProfileId, Maybe Bool)
|
||||
createNewMemberProfile_ db cxt User {userId} Profile {displayName, fullName, shortDescr, description, image, contactLink, badge, preferences} binding_ createdAt =
|
||||
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
|
||||
badgeVerified <- verifyBadge_ (badgeKeys cxt) badge
|
||||
badgeVerified <- verifyBadge_ (boundProof binding_) (badgeKeys cxt) badge
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO contact_profiles (display_name, full_name, short_descr, description, 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, badge_key_idx) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
@@ -2614,16 +2615,17 @@ getMemberRelationsVector db GroupMember {groupMemberId} =
|
||||
"SELECT member_relations_vector FROM group_members WHERE group_member_id = ?"
|
||||
(Only groupMemberId)
|
||||
|
||||
createIntroReMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberInfo -> Maybe MemberRestrictions -> ExceptT StoreError IO GroupMember
|
||||
createIntroReMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberInfo -> Maybe ByteString -> Maybe MemberRestrictions -> ExceptT StoreError IO GroupMember
|
||||
createIntroReMember
|
||||
db
|
||||
cxt
|
||||
user
|
||||
gInfo
|
||||
memInfo@(MemberInfo _ _ _ memberProfile _)
|
||||
binding_
|
||||
memRestrictions_ = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
(localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile currentTs
|
||||
(localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile binding_ 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
|
||||
@@ -3408,10 +3410,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 -> StoreCxt -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember
|
||||
updateMemberProfile db cxt user@User {userId} m p' = do
|
||||
updateMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Maybe ByteString -> Profile -> ExceptT StoreError IO GroupMember
|
||||
updateMemberProfile db cxt user@User {userId} m binding_ p' = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
badgeVerified <- liftIO $ profileBadgeVerified (badgeKeys cxt) (memberProfile m) p'
|
||||
badgeVerified <- liftIO $ profileBadgeVerified (boundProof binding_) (badgeKeys cxt) (memberProfile m) p'
|
||||
let memberProfile = toLocalProfile profileId p' localAlias currentTs badgeVerified Nothing
|
||||
updateMemberProfile' currentTs badgeVerified memberProfile
|
||||
where
|
||||
@@ -3431,10 +3433,10 @@ updateMemberProfile db cxt user@User {userId} m p' = do
|
||||
safeDeleteLDN db user localDisplayName
|
||||
pure $ Right m {localDisplayName = ldn, memberProfile}
|
||||
|
||||
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
|
||||
updateContactMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Contact -> Maybe ByteString -> Profile -> ExceptT StoreError IO (GroupMember, Contact)
|
||||
updateContactMemberProfile db cxt user@User {userId} m ct@Contact {contactId} binding_ p' = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
badgeVerified <- liftIO $ profileBadgeVerified (badgeKeys cxt) (memberProfile m) p'
|
||||
badgeVerified <- liftIO $ profileBadgeVerified (boundProof binding_) (badgeKeys cxt) (memberProfile m) p'
|
||||
let profile = toLocalProfile profileId p' localAlias currentTs badgeVerified Nothing
|
||||
updateContactMemberProfile' currentTs badgeVerified profile
|
||||
where
|
||||
@@ -3467,7 +3469,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 cxt user memberProfile currentTs
|
||||
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile Nothing currentTs
|
||||
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -3492,7 +3494,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 cxt user memberProfile currentTs
|
||||
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile Nothing currentTs
|
||||
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -3516,9 +3518,9 @@ createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupI
|
||||
-- Intro refreshes only profile / status / peer version. Role and key stay owner-authoritative
|
||||
-- (the owner-signed roster for members/moderators/admins, link data for owners), so taking either from
|
||||
-- an in-band relayed intro would let a compromised relay substitute them.
|
||||
updatePreparedChannelMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember
|
||||
updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} = do
|
||||
_ <- updateMemberProfile db cxt user member profile
|
||||
updatePreparedChannelMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberInfo -> Maybe ByteString -> ExceptT StoreError IO GroupMember
|
||||
updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} binding_ = do
|
||||
_ <- updateMemberProfile db cxt user member binding_ profile
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -3536,9 +3538,9 @@ updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupM
|
||||
where
|
||||
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
|
||||
|
||||
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 cxt user unknownMember profile
|
||||
updateUnknownMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> Maybe ByteString -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
|
||||
updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} binding_ status = do
|
||||
_ <- updateMemberProfile db cxt user unknownMember binding_ profile
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -3565,9 +3567,9 @@ updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMem
|
||||
|
||||
-- Like updateUnknownMemberAnnounced but preserves member_role and member_pub_key
|
||||
-- (roster-established for moderators/admins; the dissemination carries only the profile).
|
||||
updateRosterMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
|
||||
updateRosterMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} status = do
|
||||
_ <- updateMemberProfile db cxt user unknownMember profile
|
||||
updateRosterMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> Maybe ByteString -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
|
||||
updateRosterMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} binding_ status = do
|
||||
_ <- updateMemberProfile db cxt user unknownMember binding_ profile
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
DB.execute
|
||||
|
||||
@@ -32,7 +32,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Data.Type.Equality
|
||||
import Simplex.Chat.Badges (BadgeRow, badgeToRow, rowToBadge, verifyBadge_)
|
||||
import Simplex.Chat.Badges (BadgeRow, badgeToRow, rowToBadge, unboundProof, verifyBadge_)
|
||||
import Simplex.Chat.Names (SimplexDomainProof, SimplexDomainClaim (..), claimDomain)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Remote.Types
|
||||
@@ -418,7 +418,7 @@ createContact db cxt user profile = do
|
||||
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, description, image, contactLink, contactDomain, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs =
|
||||
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
|
||||
badgeVerified <- verifyBadge_ (badgeKeys cxt) badge
|
||||
badgeVerified <- verifyBadge_ unboundProof (badgeKeys cxt) badge
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO contact_profiles (display_name, full_name, short_descr, description, 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, badge_key_idx, contact_domain, contact_domain_proof) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
|
||||
@@ -848,10 +848,11 @@ fromLocalProfile LocalProfile {displayName, fullName, shortDescr, description, i
|
||||
OwnBadge _ _ -> Nothing -- the own credential is not sent, proof is generated on send
|
||||
ShownBadge _ _ -> Nothing -- a display-only badge is not sent
|
||||
|
||||
profileBadgeVerified :: Map Int BBSPublicKey -> LocalProfile -> Profile -> IO (Maybe Bool)
|
||||
profileBadgeVerified keys LocalProfile {localBadge} Profile {badge = newBadge} =
|
||||
profileBadgeVerified :: (BadgeProof -> Bool) -> Map Int BBSPublicKey -> LocalProfile -> Profile -> IO (Maybe Bool)
|
||||
profileBadgeVerified accepted keys LocalProfile {localBadge} Profile {badge = newBadge} =
|
||||
case (localBadge, newBadge) of
|
||||
(_, Nothing) -> pure (Just False)
|
||||
(_, Just newB) | not (accepted newB) -> pure (Just False)
|
||||
-- an unchanged badge that verified before stays verified; failed or unknown-key badges
|
||||
-- are re-verified, so an unknown key heals once an app update adds it
|
||||
(Just lb, Just (BadgeProof _ _ _ newInfo))
|
||||
|
||||
Reference in new issue
Block a user