dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-10-15 22:01:01 +00:00
Code Issues Packages Projects Releases Wiki Activity

improvements

Browse Source
This commit is contained in:
Evgeny @ SimpleX Chat
2026-09-27 12:42:45 +00:00
parent a15b817c59
commit 867949d2aa
13 changed files with 308 additions and 296 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Badges.hs
+1 -1
View File
@@ -271,7 +271,7 @@ maxSndXFTPFileSize lims now = \case
_ -> noBadge lims
-- Presentation header: a tag char + payload. PHTest is unbound - a fresh random nonce per
-- presentation, not bound to any context; the 'T' tag marks it so master rejects it.
-- presentation, not bound to any context.
-- PHUnknown is the forward-compat catch-all for tags this version does not interpret.
data ProofPresHeaderTag = PHTestTag | PHChatTag | PHFileInvTag | PHFileDescrTag | PHRequestTag | PHLinkTag | PHUnknownTag Char
src/Simplex/Chat/Library/Commands.hs
+52 -65
View File
@@ -59,7 +59,7 @@ import qualified Data.UUID.V4 as V4
import Simplex.Chat.Library.Subscriber
import Crypto.Random (ChaChaDRG)
import Simplex.Messaging.Session (SessionVar (..), withGetSessVar')
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), ProofPresHeader, badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential)
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), ProofPresHeader (..), badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential)
import qualified Simplex.Chat.Badges.Ledger as L
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..))
import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
@@ -1244,12 +1244,12 @@ processChatCommand cxt nm = \case
UserContactLink {connLinkContact = CCLink _ sl_, addressSettings} <- withFastStore (`getUserAddress` user)
case sl_ of
Nothing -> throwCmdError "your address has no short link to share"
Just connLink@(CSLContact _ _ _ linkKey) -> do
Just connLink -> do
conn <- withFastStore $ \db -> getUserAddressConnection db cxt user
ownerSig <-
withAgent (`getConnLinkPrivKey` aConnId conn) $>>= \privKey ->
mkLinkOwnerSig privKey connLink Nothing <$$> shareChatBinding user toSendRef
profile <- presentUserBadge user Nothing (Just $ linkPresHeader linkKey) $ userProfileDirect user Nothing Nothing True
profile <- presentUserBadge user Nothing (Just $ linkPresHeader connLink) $ userProfileDirect user Nothing Nothing True
let business = businessAddress addressSettings
text = safeDecodeUtf8 $ strEncode connLink
pure $ CRChatMsgContent user MCChat {text, chatLink = MCLContact {connLink, profile, business}, ownerSig}
@@ -2119,8 +2119,8 @@ processChatCommand cxt nm = \case
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
subMode <- chatReadVar subscriptionMode
rootKey <- atomically . C.generateKeyPair =<< asks random
(preparedLink@(CCLink preparedReq _), preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMInvitation rootKey Nothing False Nothing IKUsePQ False Nothing
linkProfile <- presentUserBadge user incognitoProfile (Just $ invitationPresHeader preparedReq) $ userProfileDirect user incognitoProfile Nothing True
(preparedLink, preparedParams@PreparedLinkParams {plpLinkKey = LinkKey linkKey}) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMInvitation rootKey Nothing False Nothing IKUsePQ False Nothing
linkProfile <- presentUserBadge user incognitoProfile (Just $ PHLink linkKey) $ userProfileDirect user incognitoProfile Nothing True
let userData = contactShortLinkData linkProfile {contactDomain = Nothing} Nothing
userLinkData = UserInvLinkData userData
(connId, ccLink) <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True preparedLink preparedParams userLinkData subMode
@@ -2142,7 +2142,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 (invitationPresHeader . connFullLink <$> connLinkInv) (userProfileDirect user Nothing Nothing True)
sLnk <- updatePCCShortLinkData conn =<< presentUserBadge user Nothing (linkPresHeader <$> (connShortLink' =<< connLinkInv)) (userProfileDirect user Nothing Nothing True)
conn' <- withFastStore' $ \db -> do
deletePCCIncognitoProfile db user pId
updatePCCIncognito db user conn Nothing sLnk
@@ -2164,8 +2164,8 @@ processChatCommand cxt nm = \case
if isJust $ connShortLink' =<< connLinkInv
then do
rootKey <- atomically . C.generateKeyPair =<< asks random
(preparedLink@(CCLink preparedReq _), preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId newUser) SCMInvitation rootKey Nothing False Nothing IKPQOn False Nothing
userLinkData <- UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing (Just $ invitationPresHeader preparedReq) (userProfileDirect newUser Nothing Nothing True)
(preparedLink, preparedParams@PreparedLinkParams {plpLinkKey = LinkKey linkKey}) <- withAgent $ \a -> prepareConnectionLink a (aUserId newUser) SCMInvitation rootKey Nothing False Nothing IKPQOn False Nothing
userLinkData <- UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing (Just $ PHLink linkKey) (userProfileDirect newUser Nothing Nothing True)
withAgent $ \a -> createConnectionForLink a nm (aUserId newUser) True preparedLink preparedParams userLinkData subMode
else withAgent $ \a -> createConnection a nm (aUserId newUser) True False SCMInvitation Nothing Nothing IKPQOn True subMode
ccLink' <- shortenCreatedLink ccLink
@@ -2197,23 +2197,20 @@ processChatCommand cxt nm = \case
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing Nothing
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent) message
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent <=< chatLinkBadge) message
let chat = case aci of
Just (AChatItem SCTGroup dir _ ci) -> Chat cInfo [CChatItem dir ci] emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci}
_ -> Chat cInfo [] emptyChatStats
pure $ CRNewPreparedChat user $ AChat SCTGroup chat
ACCL cMode (CCLink cReq sLnk) -> do
let presHeader_ = case cMode of
SCMInvitation -> Just $ invitationPresHeader cReq
SCMContact -> (\(CSLContact _ _ _ linkKey) -> linkPresHeader linkKey) <$> sLnk
ct <- withStore $ \db -> createPreparedContact db cxt user presHeader_ profile accLink welcomeSharedMsgId (True <$ verifiedDomain)
ACCL _ (CCLink cReq sLnk) -> do
ct <- withStore $ \db -> createPreparedContact db cxt user (linkPresHeader <$> sLnk) profile accLink welcomeSharedMsgId (True <$ verifiedDomain)
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = CDDirectRcv ct
createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing Nothing
cInfo = DirectChat ct
void $ createItem Nothing $ CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ connRequestPQEncryption cReq
void $ createFeatureEnabledItems_ user ct
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent) message
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent <=< chatLinkBadge) message
let chat = case aci of
Just (AChatItem SCTDirect dir _ ci) -> Chat cInfo [CChatItem dir ci] emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci}
_ -> Chat cInfo [] emptyChatStats
@@ -2468,13 +2465,13 @@ processChatCommand cxt nm = \case
Just True -> (IKUsePQ, True)
Just False -> (IKPQOn, True)
Nothing -> (IKPQOn, False)
(ccLink, preparedParams@PreparedLinkParams {plpLinkKey}) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMContact rootKey (Just entityId) True Nothing pqInitKeys useDR server_
(ccLink, preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMContact rootKey (Just entityId) True Nothing pqInitKeys useDR server_
ccLink' <- shortenCreatedLink ccLink
-- TODO [relays] relay: add identity, key to link data?
userData <-
if isTrue userChatRelay
then pure $ relayShortLinkData (userProfileDirect user Nothing Nothing True)
else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing (Just $ linkPresHeader plpLinkKey) (userProfileDirect user Nothing Nothing True)
else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing (linkPresHeader <$> connShortLink' ccLink) (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'
@@ -2843,18 +2840,11 @@ processChatCommand cxt nm = \case
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db cxt user groupId
(inv,) <$> getContactViaMember db cxt user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership, chatSettings}, groupKeys = gks} = invitation
GroupMember {memberId = membershipMemId} = membership
Contact {activeConn} = ct
case activeConn of
Just Connection {peerChatVRange} -> do
subMode <- chatReadVar subscriptionMode
let incognitoProfile = incognitoMembershipProfile g
profile_ <-
if maxVersion peerChatVRange >= relayWebCapVersion
then Just <$> presentUserBadge user incognitoProfile (groupPresHeader g) (userProfileInGroup user g $ fromLocalProfile <$> incognitoProfile)
else pure Nothing
let msg = XGrpAcpt membershipMemId (Just $ groupMemberKey gks) profile_
dm <- maybe (encodeConnInfo msg) (`encodeSignedConnInfo` msg) (groupMsgSigning False (GIK g gks) msg)
dm <- encodeXGrpAcpt user (GIK g gks) peerChatVRange
agentConnId <- case memberConn fromMember of
Nothing -> do
(agentConnId, _) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff
@@ -3404,7 +3394,7 @@ processChatCommand cxt nm = \case
-- so incognito profile can be attached to it and be visible in UI before accepting
Nothing -> joinNewConn subMode
Just conn@Connection {connStatus} -> case connStatus of
ConnPrepared -> joinPreparedConn subMode conn =<< maybe unboundPresHeader pure =<< connPresHeader conn
ConnPrepared -> joinPreparedConn subMode conn =<< sndPresHeader =<< connPresHeader conn
_ -> throwChatError $ CEException "connection already started (past prepared status)"
where
joinNewConn subMode = do
@@ -3823,7 +3813,7 @@ processChatCommand cxt nm = \case
| connStatus == ConnNew && contactConnInitiated -> joinNewConn chatV -- own connection link
| connStatus == ConnPrepared -> do -- retrying join after error
localIncognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn
presHeader <- sndPresHeader =<< connPresHeader conn
joinPreparedConn conn (fromLocalProfile <$> localIncognitoProfile) presHeader
Just ent -> throwCmdError $ "connection is not RcvDirectMsgConnection: " <> show (connEntityInfo ent)
where
@@ -3887,33 +3877,29 @@ processChatCommand cxt nm = \case
relayMemberId_ = case preparedEntity_ of
Just (PCEGroup (GIK gInfo _) m) | useRelays' gInfo -> Just (memberId' m)
_ -> Nothing
joinPresHeader gInfo_ reqHeader = case gInfo_ of
Just (Just (GIK gInfo _)) | useRelays' gInfo -> groupPresHeader gInfo
_ -> Just reqHeader
joinPreparedConn' xContactId_ conn@Connection {connId, customUserProfileId} gInfo_ = do
when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection"
-- TODO [relays] member: refactor joinContact and up avoiding parallel ifs, xContactId is not used
xContactId <- mkXContactId xContactId_
((cReq', reqHeader_), localIncognitoProfile) <- withFastStore $ \db -> (,) <$> getConnReqContact db connId <*> forM customUserProfileId (getProfileById db userId)
reqHeader <- maybe unboundPresHeader pure reqHeader_
reqHeader <- sndPresHeader reqHeader_
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
conn' <- joinContact user conn cReq' incognitoProfile (joinPresHeader gInfo_ reqHeader) xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn
conn' <- joinContact user conn cReq' incognitoProfile reqHeader xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn
pure $ CVRSentInvitation conn' incognitoProfile
connect' groupLinkId xContactId_ gInfo_ = do
let inGroup = isJust groupLinkId
pqSup = if inGroup then PQSupportOff else PQSupportOn
(connId, chatV, binding) <- prepareContact user cReq pqSup
(connId, chatV, reqHeader) <- prepareContact user cReq pqSup
xContactId <- mkXContactId xContactId_
-- [incognito] generate profile to send, or use membership profile for relay groups
incognitoProfile_ <- case gInfo_ of
Just (Just (GIK gInfo _)) | useRelays' gInfo -> pure $ ExistingIncognito <$> incognitoMembershipProfile gInfo
_ -> if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
let incognitoProfile = fromIncognitoProfile <$> incognitoProfile_
reqHeader = directPresHeader binding
subMode <- chatReadVar subscriptionMode
let sLnk' = serverShortLink <$> sLnk
conn <- withFastStore' $ \db -> createConnReqConnection db userId connId preparedEntity_ cReq reqHeader cReqHash1 sLnk' xContactId incognitoProfile_ groupLinkId subMode chatV pqSup
conn' <- joinContact user conn cReq incognitoProfile (joinPresHeader gInfo_ reqHeader) xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup
conn' <- joinContact user conn cReq incognitoProfile reqHeader xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup
pure $ CVRSentInvitation conn' incognitoProfile
connectContactViaAddress :: User -> IncognitoEnabled -> Contact -> CreatedLinkContact -> CM ChatResponse
connectContactViaAddress user@User {userId} incognito ct@Contact {contactId, activeConn} (CCLink cReq shortLink) =
@@ -3921,15 +3907,14 @@ processChatCommand cxt nm = \case
case activeConn of
Nothing -> do
let pqSup = PQSupportOn
(connId, chatV, binding) <- prepareContact user cReq pqSup
(connId, chatV, reqHeader) <- prepareContact user cReq pqSup
newXContactId <- XContactId <$> drgRandomBytes 16
-- [incognito] generate profile to send
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
subMode <- chatReadVar subscriptionMode
let cReqHash = contactCReqHash cReq
reqHeader = directPresHeader binding
conn <- withFastStore' $ \db -> createConnReqConnection db userId connId (Just $ PCEContact ct) cReq reqHeader cReqHash shortLink newXContactId (NewIncognito <$> incognitoProfile) Nothing subMode chatV pqSup
void $ joinContact user conn cReq incognitoProfile (Just reqHeader) newXContactId Nothing Nothing Nothing Nothing pqSup
void $ joinContact user conn cReq incognitoProfile reqHeader newXContactId Nothing Nothing Nothing Nothing pqSup
ct' <- withStore $ \db -> getContact db cxt user contactId
pure $ CRSentInvitationToContact user ct' incognitoProfile
Just conn@Connection {connId, connStatus, xContactId = xContactId_, customUserProfileId} -> case connStatus of
@@ -3937,9 +3922,9 @@ processChatCommand cxt nm = \case
when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection"
xContactId <- mkXContactId xContactId_
((cReq', reqHeader_), localIncognitoProfile) <- withFastStore $ \db -> (,) <$> getConnReqContact db connId <*> forM customUserProfileId (getProfileById db userId)
reqHeader <- maybe unboundPresHeader pure reqHeader_
reqHeader <- sndPresHeader reqHeader_
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
void $ joinContact user conn cReq' incognitoProfile (Just reqHeader) xContactId Nothing Nothing Nothing Nothing PQSupportOn
void $ joinContact user conn cReq' incognitoProfile reqHeader xContactId Nothing Nothing Nothing Nothing PQSupportOn
ct' <- withStore $ \db -> getContact db cxt user contactId
pure $ CRSentInvitationToContact user ct' incognitoProfile
_ -> throwCmdError "contact already has connection"
@@ -3953,7 +3938,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) Nothing p
withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) p
pure $ MemberId entityId
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
let relayLinkToConnect = CCLink cReq (Just relayLink)
@@ -3980,22 +3965,23 @@ processChatCommand cxt nm = \case
deleteMemberConnection m
deleteOrUpdateMemberRecord user gInfo m
_ -> pure ()
prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat, ContactRequestBinding)
prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat, ProofPresHeader)
prepareContact user cReq pqSup = do
lift (withAgent' (`connRequestAgentVersion` cReq)) >>= \case
Nothing -> throwChatError CEInvalidConnReq
Just _ -> do
let chatV = initialChatVersion
(connId, binding) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup
pure (connId, chatV, binding)
pure (connId, chatV, directPresHeader binding)
mkXContactId :: Maybe XContactId -> CM XContactId
mkXContactId = maybe (XContactId <$> drgRandomBytes 16) pure
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> Maybe ProofPresHeader -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfoKeys) -> Maybe MemberId -> PQSupport -> CM Connection
joinContact user conn cReq incognitoProfile presHeader_ xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup = do
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> ProofPresHeader -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfoKeys) -> Maybe MemberId -> PQSupport -> CM Connection
joinContact user conn cReq incognitoProfile reqHeader 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 presHeader_ $ case gInfo_ of
Just gInfo_' -> userProfileInGroup' user ((\(GIK g _) -> g) <$> gInfo_') incognitoProfile
Nothing -> userProfileDirect user incognitoProfile Nothing True
profileToSend <-
presentUserBadge user incognitoProfile presHeader_ $ case gInfo_ of
Just gInfo_' -> userProfileInGroup' user ((\(GIK g _) -> g) <$> gInfo_') incognitoProfile
Nothing -> userProfileDirect user incognitoProfile Nothing True
dm <- case gInfo_ of
Just (Just gInfo@(GIK g gks))
| useRelays' g -> case relayMemberId_ of
@@ -4007,6 +3993,10 @@ processChatCommand cxt nm = \case
subMode <- chatReadVar subscriptionMode
void $ withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup subMode
withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared ConnJoined
where
presHeader_ = case gInfo_ of
Just (Just (GIK g _)) | useRelays' g -> groupPresHeader g
_ -> Just reqHeader
contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
@@ -4052,7 +4042,7 @@ processChatCommand cxt nm = \case
case changedCts_ of
Nothing -> pure $ UserProfileUpdateSummary 0 0 []
Just changedCts -> do
presHeaders <- connsPresHeaders $ map (\ChangedProfileContact {conn} -> conn) $ L.toList changedCts
presHeaders <- if presentsUserBadge user' then connsPresHeaders $ map (\ChangedProfileContact {conn} -> conn) $ L.toList changedCts else pure M.empty
idsEvts <- mapM (ctSndEvent presHeaders) changedCts
msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts
(errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_
@@ -4080,7 +4070,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 :: Map ConnId ProofPresHeader -> ChangedProfileContact -> CM (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
ctSndEvent presHeaders ChangedProfileContact {mergedProfile', conn = conn@Connection {connId}} = do
presHeader <- maybe unboundPresHeader pure $ M.lookup (aConnId conn) presHeaders
presHeader <- sndPresHeader $ M.lookup (aConnId conn) presHeaders
p'' <- presentUserBadge user' Nothing (Just presHeader) mergedProfile'
pure (ConnectionId connId, Nothing, XInfo p'' Nothing)
ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq
@@ -4090,8 +4080,8 @@ processChatCommand cxt nm = \case
setMyAddressData :: Bool -> Maybe InitialKeys -> User -> UserContactLink -> CM UserContactLink
setMyAddressData rotateKeys pqInitKeys user@User {userChatRelay} ucl@UserContactLink {userContactLinkId, connLinkContact = CCLink connFullLink sLnk_, addressSettings} = do
conn <- withFastStore $ \db -> getUserAddressConnection db cxt user
linkKey <- (\(CSLContact _ _ _ k) -> k) <$> maybe (withAgent $ \a -> prepareConnShortLink a (aConnId conn) Nothing) pure sLnk_
shortLinkProfile <- presentUserBadge user Nothing (Just $ linkPresHeader linkKey) (userProfileDirect user Nothing Nothing True)
presHeader <- linkPresHeader <$> maybe (withAgent $ \a -> prepareConnShortLink a (aConnId conn) Nothing) pure sLnk_
shortLinkProfile <- presentUserBadge user Nothing (Just presHeader) (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
@@ -4115,7 +4105,7 @@ processChatCommand cxt nm = \case
mergedProfile' = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') False
when (mergedProfile' /= mergedProfile) $
withContactLock "updateContactPrefs" (contactId' ct) $ do
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn
presHeader <- sndPresHeader =<< connPresHeader conn
p <- presentUserBadge user incognitoProfile (Just presHeader) mergedProfile'
void (sendDirectContactMessage user ct' $ XInfo p Nothing) `catchAllErrors` eToView
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
@@ -4422,7 +4412,7 @@ processChatCommand cxt nm = \case
Just (createdLink, p) -> pure (createdLink, Nothing, Nothing, p)
Nothing -> do
(FixedLinkData {rootKey}, cData, cReq) <- getShortLinkConnReq nm user l'
contactSLinkData_ <- mapM (linkDataBadge $ invitationPresHeader cReq) =<< liftIO (decodeLinkUserData cData)
contactSLinkData_ <- mapM (linkDataBadge $ linkPresHeader l') =<< liftIO (decodeLinkUserData cData)
let ov = verifyLinkOwner rootKey [] l sig_
invitationReqAndPlan cReq (Just l') contactSLinkData_ ov
where
@@ -4476,7 +4466,7 @@ processChatCommand cxt nm = \case
when (resolveMode == PRMNever) $ throwChatError CENotResolvedLocally
l' <- resolveSLink
(FixedLinkData {rootKey}, cData, cReq) <- getShortLinkConnReq nm user l'
let presHeader = linkPresHeader $ (\(CSLContact _ _ _ linkKey) -> linkKey) l'
let presHeader = linkPresHeader l'
contactSLinkData_ <- mapM (linkDataBadge presHeader) =<< liftIO (decodeLinkUserData cData)
let linkProfile_ = (\ContactShortLinkData {profile} -> profile) <$> contactSLinkData_
linkDomain_ = linkProfile_ >>= \Profile {contactDomain} -> claimDomain <$> contactDomain
@@ -5229,16 +5219,13 @@ presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadg
lift $ withAgent' $ \a -> setUserEntitlement a (aUserId user') (badgeServerCredential localBadge)
cxt <- chatStoreCxt
contacts <- withFastStore' $ \db -> getUserContacts db cxt user'
presHeaders <- connsPresHeaders [conn | Right conn <- map contactSendConn_ contacts, not (connIncognito conn)]
withChatLock "presentUserBadge" $ forM_ contacts $ \ct ->
case contactSendConn_ ct of
Right conn
| not (connIncognito conn) -> do
let ct' = updateMergedPreferences user' ct
presHeader <- maybe unboundPresHeader pure $ M.lookup (aConnId conn) presHeaders
p <- presentUserBadge user' Nothing (Just presHeader) $ userProfileDirect user' Nothing (Just ct') False
void (sendDirectContactMessage user' ct' (XInfo p Nothing)) `catchAllErrors` eToView
_ -> pure ()
let sendConns = [(ct, conn) | ct <- contacts, Right conn <- [contactSendConn_ ct], not (connIncognito conn)]
presHeaders <- if presentsUserBadge user' then connsPresHeaders $ map snd sendConns else pure M.empty
withChatLock "presentUserBadge" $ forM_ sendConns $ \(ct, conn) -> do
let ct' = updateMergedPreferences user' ct
presHeader <- sndPresHeader $ M.lookup (aConnId conn) presHeaders
p <- presentUserBadge user' Nothing (Just presHeader) $ userProfileDirect user' Nothing (Just ct') False
void (sendDirectContactMessage user' ct' (XInfo p Nothing)) `catchAllErrors` eToView
-- | The check character is verified before anything leaves the device, and the signing keys are
-- stashed before the request is sent, so a retry reaches the service as the same signer.
src/Simplex/Chat/Library/Internal.hs
+54 -28
View File
@@ -28,7 +28,7 @@ import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import Data.Bifunctor (first, second)
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
@@ -265,7 +265,7 @@ rcvForwardedFrom db user chatDirection RcvMessage {chatMsgEvent} = case chatMsgE
forwardLinkCIFF :: DB.Connection -> User -> ForwardLink -> IO CIForwardedFrom
forwardLinkCIFF db user ForwardLink {displayName, groupLink, publicGroupId, memberId, msgId} =
getGroupViaPublicGroupId db user publicGroupId >>= \case
Just (gId, Just storedLink)
Just (gId, storedLink)
| sameShortLinkContact groupLink storedLink -> do
ciId_ <- itemId_ gId
pure $ CIFFGroup displayName MDRcv (Just gId) ciId_ memberId (Just msgId) linkGroupType
@@ -998,7 +998,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
pure (ct {activeConn = Just conn} :: Contact, conn, incognitoProfile, directPresHeader binding)
Just conn@Connection {customUserProfileId} -> do
incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn
presHeader <- sndPresHeader =<< connPresHeader conn
pure (ct, conn, ExistingIncognito <$> incognitoProfile, presHeader)
profileToSend <- presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing
@@ -1014,8 +1014,8 @@ acceptContactRequestAsync
subMode <- chatReadVar subscriptionMode
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
((cmdId, acId), binding) <- prepareAgentAccept user True cReqInvId cReqPQSup
profileToSend <- presentUserBadge user incognitoProfile (Just $ directPresHeader binding) $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
((cmdId, acId), presHeader) <- prepareAgentAccept user True cReqInvId cReqPQSup
profileToSend <- presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
currentTs <- liftIO getCurrentTime
ct' <- withStore $ \db -> do
forM_ xContactId $ \xcId -> liftIO $ setContactAcceptedXContactId db ct xcId
@@ -1338,7 +1338,7 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, memberPubKey, a
{ memberId,
memberRole,
v = ChatVersionRange . peerChatVRange <$> activeConn,
profile = (p :: Profile) {badge = mfilter (acceptedProof $ PHChat <$> memberChatBinding g memberId memberPubKey) (unNoJSON memberBadgeProof <|> badge)},
profile = (p :: Profile) {badge = mfilter (acceptedProof $ memberPresHeader g memberId memberPubKey) (unNoJSON memberBadgeProof <|> badge)},
memberKey = MemberKey <$> memberPubKey
}
where
@@ -2243,11 +2243,16 @@ sendDirectContactMessages user ct events = do
-- 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 -> Maybe ProofPresHeader -> Profile -> CM Profile
presentUserBadge user@User {profile = LocalProfile {localBadge}} incognitoProfile presHeader_ p = case (incognitoProfile, localBadge) of
(Nothing, Just (OwnBadge _ st)) | st == BSActive || st == BSExpired -> do
badge <- join <$> mapM (sndBadgeProof user) presHeader_
pure p {badge}
_ -> pure p
presentUserBadge user incognitoProfile presHeader_ p
| isNothing incognitoProfile && presentsUserBadge user = do
badge <- pure presHeader_ $>>= sndBadgeProof user
pure p {badge}
| otherwise = pure p
presentsUserBadge :: User -> Bool
presentsUserBadge User {profile = LocalProfile {localBadge}} = case localBadge of
Just (OwnBadge _ st) -> st == BSActive || st == BSExpired
_ -> False
groupPresHeader :: GroupInfo -> Maybe ProofPresHeader
groupPresHeader gInfo = PHChat <$> sndGroupChatBinding gInfo False
@@ -2257,18 +2262,17 @@ directPresHeader = \case
CRBRatchet ConnVerifyCodes {codeAD} -> PHChat $ encodeChatBinding CBDirect codeAD
CRBRequest code -> PHRequest code
linkPresHeader :: LinkKey -> ProofPresHeader
linkPresHeader (LinkKey key) = PHLink key
invitationPresHeader :: ConnReqInvitation -> ProofPresHeader
invitationPresHeader = PHRequest . invitationRequestCode
linkPresHeader :: ConnShortLink c -> ProofPresHeader
linkPresHeader = \case
CSLInvitation _ _ _ (LinkKey key) -> PHLink key
CSLContact _ _ _ (LinkKey key) -> PHLink key
relayInvPresHeader :: GroupRelayInvitation -> Maybe ProofPresHeader
relayInvPresHeader GroupRelayInvitation {fromMember = MemberIdRole {memberId}, publicGroupId} =
(\gId -> PHChat $ encodeChatBinding CBGroup $ smpEncode (gId, memberId)) <$> publicGroupId
unboundPresHeader :: CM ProofPresHeader
unboundPresHeader = PHTest <$> drgRandomBytes 16
sndPresHeader :: Maybe ProofPresHeader -> CM ProofPresHeader
sndPresHeader = maybe (PHTest <$> drgRandomBytes 16) pure
connPresHeader :: Connection -> CM (Maybe ProofPresHeader)
connPresHeader conn = eitherToMaybe <$> tryAllErrors (directPresHeader . CRBRatchet <$> withAgent (`getConnectionVerifyCodes` aConnId conn))
@@ -2280,13 +2284,21 @@ connsPresHeaders conns = either (const M.empty) (M.map (directPresHeader . CRBRa
-- and set the crypto-free display badge for the UI (the raw proof stays in profile for APIPrepareContact)
linkDataBadge :: ProofPresHeader -> ContactShortLinkData -> CM ContactShortLinkData
linkDataBadge presHeader cld@ContactShortLinkData {profile = Profile {badge}} = case mfilter (acceptedProof (Just presHeader)) badge of
Nothing -> pure cld
Nothing -> pure (cld :: ContactShortLinkData) {localBadge = Nothing}
Just b@(BadgeProof _ _ _ info) -> do
keys <- asks $ badgePublicKeys . config
verified <- liftIO $ verifyBadge keys b
now <- liftIO getCurrentTime
pure (cld :: ContactShortLinkData) {localBadge = Just $ ShownBadge info (mkBadgeStatus now verified info)}
chatLinkBadge :: MsgContent -> CM MsgContent
chatLinkBadge = \case
MCChat {text, chatLink = chatLink@MCLContact {connLink, profile = p@Profile {badge = Just b@BadgeProof {presHeader = BBSPresHeader ph}}}, ownerSig} -> do
keys <- asks $ badgePublicKeys . config
verified <- if ph == strEncode (linkPresHeader connLink) then liftIO (verifyBadge keys b) else pure Nothing
pure MCChat {text, chatLink = if verified == Just True then chatLink else (chatLink :: MsgChatLink) {profile = (p :: Profile) {badge = Nothing}}, ownerSig}
c -> pure c
sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64)
sendDirectContactMessage user ct chatMsgEvent = do
conn@Connection {connId} <- liftEither $ contactSendConn_ ct
@@ -2376,6 +2388,12 @@ 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_
memberPresHeader :: GroupInfo -> MemberId -> Maybe C.PublicKeyEd25519 -> Maybe ProofPresHeader
memberPresHeader gInfo memberId = fmap PHChat . memberChatBinding gInfo memberId
memberInfoPresHeader :: GroupInfo -> MemberInfo -> Maybe ProofPresHeader
memberInfoPresHeader gInfo MemberInfo {memberId, memberKey} = memberPresHeader gInfo memberId ((\(MemberKey k) -> k) <$> memberKey)
proofMemberKey :: MemberId -> Maybe BadgeProof -> Maybe C.PublicKeyEd25519
proofMemberKey memberId badge_ = do
BadgeProof _ (BBSPresHeader phBytes) _ _ <- badge_
@@ -2504,6 +2522,16 @@ encodeXMemberConnInfo (GIK gInfo@GroupInfo {membership = GroupMember {memberId}}
signing = MsgSigning CBGroup bindingData KRMember memberPrivKey'
in encodeSignedConnInfo signing xMemberEvt
encodeXGrpAcpt :: User -> GroupInfoKeys -> VersionRangeChat -> CM ByteString
encodeXGrpAcpt user g@(GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) peerVRange = do
let incognitoProfile = incognitoMembershipProfile gInfo
profile_ <-
if maxVersion peerVRange >= relayWebCapVersion
then Just <$> presentUserBadge user incognitoProfile (groupPresHeader gInfo) (userProfileInGroup user gInfo $ fromLocalProfile <$> incognitoProfile)
else pure Nothing
let msg = XGrpAcpt memberId (Just $ groupMemberKey gks) profile_
maybe (encodeConnInfo msg) (`encodeSignedConnInfo` msg) (groupMsgSigning False g msg)
deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
deliverMessage conn cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
@@ -3058,13 +3086,11 @@ prepareAgentCreation user cmdFunction enableNtfs cMode = do
connId <- withAgent $ \a -> prepareConnectionToCreate a (aUserId user) enableNtfs cMode PQSupportOff
pure (cmdId, connId)
prepareAgentJoin :: User -> Maybe Connection -> Bool -> ConnectionRequestUri c -> CM ((CommandId, ConnId), Maybe ContactRequestBinding)
prepareAgentJoin user conn_ enableNtfs cReqUri = do
cmdId <- withStore' $ \db -> createCommand db user (dbConnId <$> conn_) CFJoinConn
(connId, binding_) <- case conn_ of
Just conn -> pure (aConnId conn, Nothing)
Nothing -> second Just <$> withAgent (\a -> prepareConnectionToJoin a (aUserId user) enableNtfs cReqUri PQSupportOff)
pure ((cmdId, connId), binding_)
prepareAgentJoin :: User -> Bool -> ConnectionRequestUri c -> CM ((CommandId, ConnId), ProofPresHeader)
prepareAgentJoin user enableNtfs cReqUri = do
cmdId <- withStore' $ \db -> createCommand db user Nothing CFJoinConn
(connId, binding) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) enableNtfs cReqUri PQSupportOff
pure ((cmdId, connId), directPresHeader binding)
joinAgentConnectionAsync :: CommandId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM ()
joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode =
@@ -3086,11 +3112,11 @@ allowAgentConnectionInfo user conn@Connection {connId} confId dm = do
withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm
withStore' $ \db -> updateConnectionStatus db conn ConnAccepted
prepareAgentAccept :: User -> Bool -> InvitationId -> PQSupport -> CM ((CommandId, ConnId), ContactRequestBinding)
prepareAgentAccept :: User -> Bool -> InvitationId -> PQSupport -> CM ((CommandId, ConnId), ProofPresHeader)
prepareAgentAccept user enableNtfs invId pqSup = do
cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact
(connId, binding) <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) enableNtfs invId pqSup
pure ((cmdId, connId), binding)
pure ((cmdId, connId), directPresHeader binding)
agentAcceptContactAsync :: MsgEncodingI e => CommandId -> ConnId -> Bool -> InvitationId -> ChatMsgEvent e -> PQSupport -> SubscriptionMode -> CM ()
agentAcceptContactAsync cmdId connId enableNtfs invId msg pqSup subMode = do
src/Simplex/Chat/Library/Subscriber.hs
+86 -110
View File
@@ -46,7 +46,7 @@ import Data.Time.Format (defaultTimeLocale, formatTime)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as V4
import Data.Word (Word32)
import Simplex.Chat.Badges (BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), ProofPresHeader (..), acceptedProof, verifyBadge)
import Simplex.Chat.Badges (BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), ProofPresHeader (..), acceptedProof)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Delivery
@@ -498,19 +498,21 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
Right () -> pure ()
Nothing -> do
conn' <- processCONFpqSupport conn pqSupport
presHeader_ <- connPresHeader conn'
-- [incognito] send saved profile
(conn'', gInfo_) <- saveConnInfo conn' connInfo
(conn'', gInfo_) <- saveConnInfo conn' presHeader_ connInfo
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
profileToSend <- case gInfo_ of
Just (GIK gInfo _) -> presentUserBadge user incognitoProfile (groupPresHeader gInfo) $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
Nothing -> do
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn''
presHeader <- sndPresHeader presHeader_
presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn'' confId gInfo_ $ XInfo profileToSend ((\(GIK _ gks) -> groupMemberKey gks) <$> gInfo_)
INFO pqSupport connInfo -> do
processINFOpqSupport conn pqSupport
void $ saveConnInfo conn connInfo
presHeader_ <- connPresHeader conn
void $ saveConnInfo conn presHeader_ connInfo
MSG meta _msgFlags _msgBody ->
-- We are not saving message (saveDirectRcvMSG) as contact hasn't been created yet,
-- chat item is also not created here
@@ -577,7 +579,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> messageFileDescription ct'' sharedMsgId fileDescr fileExpires fileBadge
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> chatLinkBadge mContent >>= \mc -> messageUpdate ct'' sharedMsgId mc msg msgMeta ttl live
XMsgDel sharedMsgId _ _ _ -> messageDelete ct'' sharedMsgId msg msgMeta
XMsgReact sharedMsgId _ _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
-- TODO discontinue XFile
@@ -619,10 +621,11 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn'' confId Nothing XOk
XInfo profile _ -> do
ct' <- processContactProfileUpdate ct profile False `catchAllErrors` const (pure ct)
presHeader_ <- connPresHeader conn''
ct' <- processContactProfileUpdate ct presHeader_ profile False `catchAllErrors` const (pure ct)
-- [incognito] send incognito profile
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn''
presHeader <- sndPresHeader presHeader_
p <- presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True
allowAgentConnectionAsync user conn'' confId Nothing $ XInfo p Nothing
void $ withStore' $ \db -> resetMemberContactFields db ct'
@@ -652,7 +655,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
pure ()
XInfo profile _ -> do
let prepared = isJust (preparedContact ct) || isJust (contactRequestId' ct)
void $ processContactProfileUpdate ct profile prepared
presHeader_ <- connPresHeader conn
void $ processContactProfileUpdate ct presHeader_ profile prepared
XOk -> pure ()
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
CON pqEnc -> do
@@ -788,17 +792,13 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
XGrpAcpt memId mKey memProfile_
| sameMemberId memId m -> do
withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
forM_ mKey $ \(MemberKey k) -> withStore' $ \db -> setMemberPubKey db (groupMemberId' m) k
let m' = maybe m (\(MemberKey k) -> m {memberPubKey = Just k}) mKey
forM_ memProfile_ $ \memProfile -> processMemberProfileUpdate gInfo m' (PHChat <$> signedMemberBinding gInfo m' signedMsg_) memProfile Nothing
let GroupMember {memberId = membershipMemId} = membership
p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
membershipProfile <-
if maxVersion (peerChatVRange conn') >= relayWebCapVersion
then presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p
else pure p
m' <- case mKey of
Just (MemberKey k) -> m {memberPubKey = Just k} <$ withStore' (\db -> setMemberPubKey db (groupMemberId' m) k)
Nothing -> pure m
forM_ memProfile_ $ \memProfile -> processMemberProfileUpdate gInfo m' signedMsg_ memProfile Nothing
membershipProfile <- membershipHandshakeProfile gInfo $ maxVersion (peerChatVRange conn')
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo membershipMemId membershipProfile
allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo (memberId' membership) membershipProfile
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
XGrpRelayAcpt relayLink relayCap
| memberRole' membership == GROwner && isRelay m -> do
@@ -847,14 +847,10 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
XGrpMemInfo memId memProfile
| sameMemberId memId m -> do
let GroupMember {memberId = membershipMemId} = membership
p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
membershipProfile <-
if maxVersion (peerChatVRange conn') >= relayWebCapVersion
then presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p
else pure p
membershipProfile <- membershipHandshakeProfile gInfo $ maxVersion (peerChatVRange conn')
-- [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 (PHChat <$> signedMemberBinding gInfo m signedMsg_) memProfile Nothing
void $ processMemberProfileUpdate 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
@@ -863,7 +859,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
case chatMsgEvent of
XGrpMemInfo memId memProfile
| sameMemberId memId m ->
void $ processMemberProfileUpdate gInfo m (PHChat <$> signedMemberBinding gInfo m signedMsg_) memProfile Nothing
void $ processMemberProfileUpdate gInfo m signedMsg_ memProfile Nothing
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
-- sent when connecting via group link
XInfo memProfile mKey
@@ -872,9 +868,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
deleteMemberConnection' m True
withStore' $ \db -> deleteGroupMember db user m
| otherwise -> do
storedKey_ <- join <$> mapM (storeMemberKey gInfo m signedMsg_) mKey
let m' = maybe m (\k -> m {memberPubKey = Just k}) storedKey_
void $ processMemberProfileUpdate gInfo m' (PHChat <$> signedMemberBinding gInfo m' signedMsg_) memProfile Nothing
m' <- maybe (pure m) (storeMemberKey gInfo m signedMsg_) mKey
void $ processMemberProfileUpdate gInfo m' signedMsg_ memProfile Nothing
XOk ->
-- transient relay-reject row cleanup after the rejection handshake completes
when (memberCategory m == GCHostMember && not (relayServesGroup gInfo)) $ do
@@ -1086,7 +1081,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
checkSendAsGroup asGroup_ $
memberCanSend (Just m'') msgScope $
groupMessageUpdate gInfo' (Just m'') sharedMsgId mContent mentions msgScope msg brokerTs ttl live asGroup_
chatLinkBadge mContent >>= \mc -> groupMessageUpdate gInfo' (Just m'') sharedMsgId mc mentions msgScope msg brokerTs ttl live asGroup_
XMsgDel sharedMsgId memberId_ scope_ onlyHistory ->
groupMessageDelete gInfo' (Just m'') sharedMsgId memberId_ scope_ onlyHistory msg brokerTs
XMsgReact sharedMsgId memberId scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs
@@ -1247,7 +1242,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) Nothing p
withStore $ \db -> updateRelayMemberData db cxt user m (MemberId entityId) (MemberKey relayKey) p
pure $ MemberId entityId
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
case cReq of
@@ -1265,8 +1260,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
profileToSend <- presentUserBadge user incognitoProfile (groupPresHeader gInfo) $ userProfileInGroup user gInfo incognitoProfile
dm <- encodeXMemberConnInfo g relayMemberId profileToSend
subMode <- chatReadVar subscriptionMode
((cmdId, connId'), _) <- prepareAgentJoin user (Just conn) True cReq
joinAgentConnectionAsync cmdId True connId' True cReq dm subMode
cmdId <- withStore' $ \db -> createCommand db user (Just $ dbConnId conn) CFJoinConn
joinAgentConnectionAsync cmdId True (aConnId conn) True cReq dm subMode
CFGetRelayDataAccept -> do
let GroupMember {memberId = MemberId expectedMemberId} = m
if linkEntityId == Just expectedMemberId
@@ -1277,7 +1272,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) Nothing relayProfile
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
pure (confId, m', relay)
allowAgentConnectionAsync user conn confId (Just g) XOk
toView $ CEvtGroupRelayUpdated user gInfo m' relay
@@ -1410,7 +1405,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
(signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo
let reqHeader = directPresHeader binding
case chatMsgEvent of
XContact p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange reqHeader p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ pqSupport rejectionSupported
XContact p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ -> mapM (traverse chatLinkBadge) requestMsg_ >>= \requestMsg' -> profileContactRequest invId chatVRange reqHeader p memberKey_ xContactId_ welcomeMsgId_ requestMsg' pqSupport rejectionSupported
XMember p joiningMemberId joiningMemberKey viaRelay -> memberJoinRequestViaRelay invId chatVRange signedMsg_ p joiningMemberId joiningMemberKey viaRelay
XInfo p _ -> profileContactRequest invId chatVRange reqHeader p Nothing Nothing Nothing Nothing pqSupport rejectionSupported
XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv
@@ -1706,7 +1701,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
&& viaRelay == Just (memberId' (membership gInfo))
_ -> False
acceptJoin g@(GIK gInfo _) existingMem_ acceptRole = do
mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p (PHChat <$> memberChatBinding gInfo joiningMemberId Nothing) Nothing (Just joiningMemberId) Nothing GAAccepted acceptRole Nothing (Just joiningMemberKey) existingMem_
mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p (memberPresHeader gInfo joiningMemberId Nothing) Nothing (Just joiningMemberId) Nothing GAAccepted acceptRole Nothing (Just joiningMemberKey) existingMem_
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem'
@@ -1952,14 +1947,6 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci {reactions}]
chatLinkBadge :: MsgContent -> CM MsgContent
chatLinkBadge = \case
MCChat {text, chatLink = chatLink@MCLContact {connLink = CSLContact _ _ _ linkKey, profile = p@Profile {badge = Just b}}, ownerSig} -> do
keys <- asks $ badgePublicKeys . config
verified <- if acceptedProof (Just $ linkPresHeader linkKey) b then liftIO (verifyBadge keys b) else pure Nothing
pure MCChat {text, chatLink = if verified == Just True then chatLink else (chatLink :: MsgChatLink) {profile = (p :: Profile) {badge = Nothing}}, ownerSig}
c -> pure c
autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM ()
autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do
-- ! autoAcceptFileSize is only used in tests
@@ -2713,19 +2700,13 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
memberKeys <- atomically . C.generateKeyPair =<< asks random
(GIK gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership} gks, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId memberKeys
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
let GroupMember {groupMemberId} = membership
-- hostContact is only reported for group links, where the client replaces
-- the transient host connection view with the group and removes its chat
joinGroupAsync hostContact_ sameLink = do
subMode <- chatReadVar subscriptionMode
let incognitoProfile = incognitoMembershipProfile gInfo
profile_ <-
if maxVersion peerChatVRange >= relayWebCapVersion
then Just <$> presentUserBadge user incognitoProfile (groupPresHeader gInfo) (userProfileInGroup user gInfo $ fromLocalProfile <$> incognitoProfile)
else pure Nothing
let acptMsg = XGrpAcpt membershipMemId (Just $ groupMemberKey gks) profile_
dm <- maybe (encodeConnInfo acptMsg) (`encodeSignedConnInfo` acptMsg) (groupMsgSigning False (GIK gInfo gks) acptMsg)
(connIds@(cmdId, acId), _) <- prepareAgentJoin user Nothing True connRequest
dm <- encodeXGrpAcpt user (GIK gInfo gks) peerChatVRange
(connIds@(cmdId, acId), _) <- prepareAgentJoin user True connRequest
withStore' $ \db -> do
when sameLink $ setViaGroupLinkUri db groupId connId
createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode
@@ -2762,7 +2743,9 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
MsgError e -> createInternalChatItem user cd (CIRcvIntegrityError e) (Just brokerTs)
xInfo :: Contact -> Profile -> CM ()
xInfo c p' = void $ processContactProfileUpdate c p' True
xInfo c p' = do
presHeader_ <- pure (contactConn c) $>>= connPresHeader
void $ processContactProfileUpdate c presHeader_ p' True
xDirectDel :: Contact -> RcvMessage -> MsgMeta -> CM ()
xDirectDel c msg msgMeta =
@@ -2785,11 +2768,10 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
where
brokerTs = metaBrokerTs msgMeta
processContactProfileUpdate :: Contact -> Profile -> Bool -> CM Contact
processContactProfileUpdate c@Contact {profile = lp} p' createItems
processContactProfileUpdate :: Contact -> Maybe ProofPresHeader -> Profile -> Bool -> CM Contact
processContactProfileUpdate c@Contact {profile = lp} presHeader_ p' createItems
-- 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 lp = do
presHeader_ <- maybe (pure Nothing) connPresHeader $ contactConn c
c' <- withStore $ \db ->
if userTTL == rcvTTL
then updateContactProfile db cxt user c presHeader_ p'
@@ -2830,44 +2812,38 @@ 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 brokerTs = do
binding_ <- verifiedMemberBinding gInfo m mKey msg
void $ processMemberProfileUpdate gInfo m (PHChat <$> binding_) p' (Just (msg, brokerTs))
xInfoMember gInfo m p' mKey msg@RcvMessage {signedMsg_} brokerTs = do
m' <- maybe (pure m) (storeMemberKey gInfo m signedMsg_) mKey
void $ processMemberProfileUpdate gInfo m' signedMsg_ 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 msg = do
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' mKey RcvMessage {signedMsg_} = do
xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId
if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived
then do
binding_ <- verifiedMemberBinding gInfo m mKey msg
m' <- processMemberProfileUpdate gInfo m (PHChat <$> binding_) p' Nothing
m' <- maybe (pure m) (storeMemberKey gInfo m signedMsg_) mKey
m'' <- processMemberProfileUpdate gInfo m' signedMsg_ p' Nothing
withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True
let connectedIncognito = memberIncognito membership
probeMatchingMemberContact m' connectedIncognito
probeMatchingMemberContact m'' connectedIncognito
else messageError "x.grp.link.mem error: invalid group link host profile update"
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
signedMemberPresHeader :: GroupInfo -> GroupMember -> Maybe SignedMsg -> Maybe ProofPresHeader
signedMemberPresHeader gInfo GroupMember {memberId, memberPubKey} signedMsg_ =
memberPresHeader 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 -> Nothing <$ when (k /= k0) (messageError "member key change rejected, keeping current key")
storeMemberKey :: GroupInfo -> GroupMember -> Maybe SignedMsg -> MemberKey -> CM GroupMember
storeMemberKey gInfo m@GroupMember {groupMemberId, memberPubKey, memberId} signedMsg_ (MemberKey k) = case memberPubKey of
Just k0 -> m <$ when (k /= k0) (messageError "member key change rejected, keeping current key")
Nothing
| memberSigned gInfo memberId k signedMsg_ -> Just k <$ withStore' (\db -> setMemberPubKey db groupMemberId k)
| otherwise -> Nothing <$ messageError "member key not signed by that key, ignored"
| memberSigned gInfo memberId k signedMsg_ -> m {memberPubKey = Just k} <$ withStore' (\db -> setMemberPubKey db groupMemberId k)
| otherwise -> m <$ 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
@@ -2927,10 +2903,10 @@ 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 -> Maybe ProofPresHeader -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember
processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} presHeader_ rcvProfile msgTs_
processMemberProfileUpdate :: GroupInfo -> GroupMember -> Maybe SignedMsg -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember
processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId, memberBadgeProof} signedMsg_ rcvProfile 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 || proofHeaderChanged = do
| contentChanged || badgeNeedsReverify p || memberProofChanged = do
when contentChanged $ updateBusinessChatProfile gInfo
case memberContactId of
Nothing -> do
@@ -2959,16 +2935,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
| otherwise =
pure m
where
p' = case rcvProfile of
Profile {badge = Just b} | not (acceptedProof presHeader_ b) -> rcvProfile {badge = storedProof}
_ -> rcvProfile
presHeader_ = signedMemberPresHeader gInfo m signedMsg_
(p', memberProofChanged) = case rcvProfile of
Profile {badge = Just b} | not (acceptedProof presHeader_ b) -> (rcvProfile {badge = storedProof}, False)
Profile {badge} -> (rcvProfile, (proofContent <$> badge) /= (proofContent <$> unNoJSON memberBadgeProof))
proofContent BadgeProof {presHeader, badgeInfo} = (presHeader, badgeInfo)
Profile {badge = storedProof} = fromLocalProfile p
p'' = redactedMemberProfile gInfo m p'
contentChanged = not (sameProfileContent (redactedMemberProfile gInfo m (fromLocalProfile p)) p'')
proofHeaderChanged = case (p', p) of
(Profile {badge = Just BadgeProof {presHeader}}, LocalProfile {localBadge = Just (PeerBadge BadgeProof {presHeader = storedHeader} _)}) ->
presHeader /= storedHeader
_ -> False
updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of
Just bc | isMainBusinessMember bc m -> do
g' <- withStore $ \db -> updateGroupProfileFromMember db user g p'
@@ -3203,13 +3177,12 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
toView $ CEvtContactAndMemberAssociated user c2 g m1 c2'
pure c2'
saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Maybe GroupInfoKeys)
saveConnInfo activeConn connInfo = do
saveConnInfo :: Connection -> Maybe ProofPresHeader -> ConnInfo -> CM (Connection, Maybe GroupInfoKeys)
saveConnInfo activeConn presHeader_ connInfo = do
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
conn' <- updatePeerChatVRange activeConn chatVRange
case chatMsgEvent of
XInfo p _ -> do
presHeader_ <- connPresHeader conn'
ct <- withStore $ \db -> createDirectContact db cxt user conn' presHeader_ p
toView $ CEvtContactConnecting user ct
pure (conn', Nothing)
@@ -3234,7 +3207,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 presHeader_ = PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> assertedKey_)
let presHeader_ = memberInfoPresHeader gInfo memInfo
if sameMemberId memId (membership gInfo)
then pure Nothing
else
@@ -3315,8 +3288,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
pure (announcedMember', Just scopeInfo)
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM ()
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ introKey_) memRestrictions = do
let presHeader_ = PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> introKey_)
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ _) memRestrictions = do
let presHeader_ = memberInfoPresHeader gInfo memInfo
case memberCategory m of
GCHostMember ->
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
@@ -3367,7 +3340,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
xGrpMemFwd :: GroupInfoKeys -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
xGrpMemFwd g@(GIK gInfo@GroupInfo {membership, chatSettings} _) m memInfo@(MemberInfo memId memRole memChatVRange _ introKey_) IntroInvitation {groupConnReq, directConnReq} = do
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
@@ -3378,7 +3351,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 (PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> introKey_)) GCPostMember GSMemAnnounced
SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db cxt user gInfo m memInfo (memberInfoPresHeader gInfo memInfo) GCPostMember GSMemAnnounced
e -> throwError e
-- TODO [knocking] separate pending statuses from GroupMemberStatus?
-- TODO add GSMemIntroInvitedPending, GSMemConnectedPending, etc.?
@@ -3389,24 +3362,27 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
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 <-
if chatV >= relayWebCapVersion
then presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p
else pure p
membershipProfile <- membershipHandshakeProfile gInfo chatV
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 (fmap fst . prepareAgentJoin user Nothing True) directConnReq
(groupConnIds@(gCmdId, gAcId), _) <- prepareAgentJoin user enableNtfsGrp groupConnReq
directConnIds <- mapM (fmap fst . prepareAgentJoin user True) directConnReq
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
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) ->
joinAgentConnectionAsync dCmdId False dAcId True dcr dm subMode
membershipHandshakeProfile :: GroupInfo -> VersionChat -> CM Profile
membershipHandshakeProfile gInfo@GroupInfo {membership} v
| v >= relayWebCapVersion = presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p
| otherwise = pure p
where
p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
-- rollback defense (channels): apply an owner-signed role/removal only at a version >= the persisted
-- roster_version (not the batch-constant gInfo, which a relay can stale by reordering events in one
-- batch), then advance it in the same transaction; a strictly lower version is a replay and is ignored.
@@ -3929,12 +3905,12 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
}
joinExistingContact subMode mCt@Contact {contactId = mContactId}
| autoAcceptMemberContacts user = do
((cmdId, acId), binding_) <- prepareAgentJoin user Nothing True connReq
((cmdId, acId), presHeader) <- prepareAgentJoin user True connReq
mCt' <- withStore $ \db -> do
updateMemberContactInvited db user mCt groupDirectInv
void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode
getContact db cxt user mContactId
joinMemberContactAsync cmdId acId (directPresHeader <$> binding_) subMode
joinMemberContactAsync cmdId acId presHeader subMode
securityCodeChanged mCt'
createItems mCt' m
| otherwise = do
@@ -3948,14 +3924,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
createItems mCt' m
createNewContact subMode
| autoAcceptMemberContacts user = do
((cmdId, acId), binding_) <- prepareAgentJoin user Nothing True connReq
((cmdId, acId), presHeader) <- prepareAgentJoin user True connReq
-- [incognito] reuse membership incognito profile
(mCt, m') <- withStore $ \db -> do
(mContactId, m') <- liftIO $ createMemberContactInvited db user g m groupDirectInv
void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode
mCt <- getContact db cxt user mContactId
pure (mCt, m')
joinMemberContactAsync cmdId acId (directPresHeader <$> binding_) subMode
joinMemberContactAsync cmdId acId presHeader subMode
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
createItems mCt m'
| otherwise = do
@@ -3968,9 +3944,9 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
createInternalChatItem user (CDDirectRcv mCt) (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing
createItems mCt m'
joinMemberContactAsync cmdId acId presHeader_ subMode = do
joinMemberContactAsync cmdId acId presHeader subMode = do
-- [incognito] send membership incognito profile
p <- presentUserBadge user (incognitoMembershipProfile g) presHeader_ $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True
p <- presentUserBadge user (incognitoMembershipProfile g) (Just presHeader) $ 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
@@ -3978,7 +3954,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
(g', m'', scopeInfo) <- mkGroupChatScope g m'
createInternalChatItem user (CDGroupRcv g' scopeInfo m'') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing
toView $ CEvtNewMemberContactReceivedInv user mCt' g' m''
forM_ mContent_ $ \mc -> do
forM_ mContent_ $ chatLinkBadge >=> \mc -> do
(ci, cInfo) <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc, msgContentTexts mc)
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci]
@@ -4026,7 +4002,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires fileBadge
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_
void $ memberCanSend author_ msgScope $ chatLinkBadge mContent >>= \mc -> groupMessageUpdate gInfo author_ sharedMsgId mc mentions msgScope rcvMsg msgTs ttl live asGroup_
XMsgDel sharedMsgId memId scope_ _ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ False rcvMsg msgTs
XMsgReact sharedMsgId memId scope_ reaction add -> withAuthor XMsgReact_ $ \author -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId
src/Simplex/Chat/Store/Groups.hs
+9 -9
View File
@@ -1808,8 +1808,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 -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
setRelayLinkAccepted db cxt user m (MemberKey relayKey) presHeader_ profile = do
setRelayLinkAccepted :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberKey -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
setRelayLinkAccepted db cxt user m (MemberKey relayKey) profile = do
let gmId = groupMemberId' m
currentTs <- liftIO getCurrentTime
liftIO $ DB.execute
@@ -1828,7 +1828,7 @@ setRelayLinkAccepted db cxt user m (MemberKey relayKey) presHeader_ profile = do
WHERE group_member_id = ?
|]
(relayKey, currentTs, gmId)
void $ updateMemberProfile db cxt user m presHeader_ profile
void $ updateMemberProfile db cxt user m Nothing profile
(,) <$> getGroupMemberById db cxt user gmId <*> getGroupRelayByGMId db gmId
setRelayLinkConfId :: DB.Connection -> GroupMember -> ConfirmationId -> ShortLinkContact -> IO ()
@@ -1875,8 +1875,8 @@ getRelayConfId db m =
|]
(Only (groupMemberId' m))
updateRelayMemberData :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberId -> MemberKey -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO ()
updateRelayMemberData db cxt user m memberId (MemberKey relayKey) presHeader_ 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
@@ -1887,7 +1887,7 @@ updateRelayMemberData db cxt user m memberId (MemberKey relayKey) presHeader_ pr
WHERE group_member_id = ?
|]
(memberId, relayKey, currentTs, groupMemberId' m)
void $ updateMemberProfile db cxt user m presHeader_ profile
void $ updateMemberProfile db cxt user m Nothing profile
setGroupInProgressDone :: DB.Connection -> GroupInfo -> IO ()
setGroupInProgressDone db GroupInfo {groupId} = do
@@ -2050,7 +2050,7 @@ getRelayPublishableGroups db User {userId, userContactId} =
where
toRow ((gId, pgId) :. accessRow) = (gId, pgId, toPublicGroupAccess accessRow)
getGroupViaPublicGroupId :: DB.Connection -> User -> B64UrlByteString -> IO (Maybe (GroupId, Maybe ShortLinkContact))
getGroupViaPublicGroupId :: DB.Connection -> User -> B64UrlByteString -> IO (Maybe (GroupId, ShortLinkContact))
getGroupViaPublicGroupId db User {userId} publicGroupId =
maybeFirstRow id $
DB.query
@@ -2635,13 +2635,13 @@ createIntroReMember
cxt
user
gInfo
(MemberInfo memId memRole memChatVRange memberProfile memKey)
memInfo@(MemberInfo _ _ _ memberProfile _)
presHeader_
memRestrictions_ = do
currentTs <- liftIO getCurrentTime
(localDisplayName, memProfileId, memberProfile', badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile presHeader_ currentTs
let memRestriction = restriction <$> memRestrictions_
newMember = NewGroupMember {memInfo = MemberInfo memId memRole memChatVRange memberProfile' memKey, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId}
newMember = NewGroupMember {memInfo = (memInfo :: MemberInfo) {profile = memberProfile'}, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId}
createNewMember_ db user gInfo newMember badgeVerified currentTs
createIntroReMemberConn :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionChat -> MemberInfo -> (CommandId, ConnId) -> SubscriptionMode -> ExceptT StoreError IO GroupMember
src/Simplex/Chat/Types.hs
+9 -12
View File
@@ -850,22 +850,19 @@ fromLocalProfile LocalProfile {displayName, fullName, shortDescr, description, i
ShownBadge _ _ -> Nothing -- a display-only badge is not sent
profileBadgeVerified :: Maybe ProofPresHeader -> Map Int BBSPublicKey -> Maybe LocalProfile -> Profile -> IO (Profile, Maybe Bool)
profileBadgeVerified expected keys lp_ p@Profile {badge = newBadge} = case newBadge of
Nothing -> pure (p, Just False)
Just newB@(BadgeProof _ _ _ newInfo)
| not (acceptedProof expected newB) -> pure (p {badge = storedProof}, storedVerified)
profileBadgeVerified expected keys lp_ p@Profile {badge = rcvBadge} =
(,) p {badge = newBadge} <$> case (storedBadge, newBadge) of
(_, Nothing) -> 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 <- storedBadge, localBadgeInfo lb == newInfo && localBadgeStatus lb `notElem` [BSFailed, BSUnknownKey] -> pure (p, Just True)
| otherwise -> (,) p <$> verifyBadge keys newB
(Just lb, Just (BadgeProof _ _ _ newInfo))
| localBadgeInfo lb == newInfo && localBadgeStatus lb `notElem` [BSFailed, BSUnknownKey] -> pure (Just True)
(_, Just newB) -> verifyBadge keys newB
where
storedBadge = (\LocalProfile {localBadge} -> localBadge) =<< lp_
Profile {badge = storedProof} = maybe p {badge = Nothing} fromLocalProfile lp_
storedVerified = case localBadgeStatus <$> storedBadge of
Nothing -> Just False
Just BSFailed -> Just False
Just BSUnknownKey -> Nothing
Just _ -> Just True
newBadge
| all (acceptedProof expected) rcvBadge = rcvBadge
| otherwise = (\Profile {badge} -> badge) . fromLocalProfile =<< lp_
-- a failed or unknown-key badge is re-verified on the next profile update even when its disclosed content
-- is unchanged, so it heals once an app update adds the issuer key