mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-10-06 09:58:26 +00:00
core: support message signing in p2p groups (#7312)
* core: support message signing in p2p groups * improve * add member key * distribute keys and sign * refactor * better query * map * sign in relay groups too * clean up * list * fix test * update bot types * some refactor * remove unnecessary condition * simplify * refactor * simplify * move * clean up * diff * diff * limit attempts for key sending * optimize * fix test * split * fuse * null * only mark as "key sent" when forwarder supports binary encoding * fix bot apis * fix some tests * add key distribution steps, and fix some tests * fix test * increase timeout * fix tests * fix more tests * simplify * disable test output * mark keys sent with invitations * fix test * fix test, query plans * unify signing of connection info packets * revert change to createNewGroup * create key at group/member creation * rename, remove liftIO * clean up * fix type * remove ad hoc key sending * update bot api * diff * reduce diff * failing test * fix sending messages in groups with members before version 18 * remove test delays * update query plans * update test * add tests * fix tests --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny
co-authored by
Evgeny @ SimpleX Chat
Evgeny @ SimpleX Chat
parent
ecdc518d4c
commit
44773d0412
@@ -872,7 +872,7 @@ data ChatResponse
|
||||
| CRAcceptingContactRequest {user :: User, contact :: Contact}
|
||||
| CRContactAlreadyExists {user :: User, contact :: Contact}
|
||||
| CRLeftMemberUser {user :: User, groupInfo :: GroupInfo}
|
||||
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool}
|
||||
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool, localDeletion :: Bool}
|
||||
| CRForwardPlan {user :: User, itemsCount :: Int, chatItemIds :: [ChatItemId], forwardConfirmation :: Maybe ForwardConfirmation}
|
||||
| CRChatMsgContent {user :: User, msgContent :: MsgContent}
|
||||
| CRRcvFileAccepted {user :: User, chatItem :: AChatItem}
|
||||
|
||||
@@ -64,7 +64,7 @@ import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), Deliv
|
||||
import Simplex.Chat.Files
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.Batch (encodeBatchElement)
|
||||
import Simplex.Chat.Messages.Batch (BatchMode, encodeBatchElement)
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Messages.CIContent.Events
|
||||
import Simplex.Chat.Operators
|
||||
@@ -164,7 +164,7 @@ checkProfileImageSize = mapM_ $ \(ImageData t) ->
|
||||
in when (size > maxProfileImageSize) $ throwCmdError $ "Profile image is too large " <> show size
|
||||
|
||||
checkProfileSize :: Profile -> CM ()
|
||||
checkProfileSize p = checkInfoSize "Profile" (XInfo p)
|
||||
checkProfileSize p = checkInfoSize "Profile" (XInfo p Nothing)
|
||||
|
||||
checkGroupProfileSize :: GroupProfile -> CM ()
|
||||
checkGroupProfileSize p = checkInfoSize "Group profile" (XGrpInfo p)
|
||||
@@ -1205,7 +1205,7 @@ processChatCommand cxt nm = \case
|
||||
Nothing -> throwCmdError "not a public group"
|
||||
Just PublicGroupProfile {groupLink} -> do
|
||||
let signingKeys = case (memberRole, groupKeys) of
|
||||
(GROwner, Just gk@GroupKeys {groupRootKey = GRKPrivate _}) -> Just gk
|
||||
(GROwner, Just gk@GroupKeys {publicGroupKeys = Just PublicGroupKeys {groupRootKey = GRKPrivate _}}) -> Just gk
|
||||
_ -> Nothing
|
||||
ownerSig <-
|
||||
pure signingKeys $>>= \GroupKeys {memberPrivKey} ->
|
||||
@@ -1373,7 +1373,7 @@ processChatCommand cxt nm = \case
|
||||
withFastStore' $ \db -> cleanupHostGroupLinkConn db user gInfo
|
||||
withFastStore' $ \db -> deleteGroupMembers db user gInfo
|
||||
withFastStore' $ \db -> deleteGroup db user gInfo
|
||||
pure $ CRGroupDeletedUser user gInfo msgSigned
|
||||
pure $ CRGroupDeletedUser user gInfo msgSigned (not doSendDel)
|
||||
where
|
||||
getRecipients gInfo
|
||||
| useRelays' gInfo = do
|
||||
@@ -2304,8 +2304,7 @@ processChatCommand cxt nm = \case
|
||||
-- set group link info and incognito profile, generate and store membership keys
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
let cReqHash = contactCReqHash $ CRContactUri crData {crScheme = SSSimplex} e2e
|
||||
gVar <- asks random
|
||||
(_, memberPrivKey) <- liftIO $ atomically $ C.generateKeyPair gVar
|
||||
(_, memberPrivKey) <- atomically . C.generateKeyPair =<< asks random
|
||||
gInfo' <- withFastStore $ \db -> do
|
||||
gInfo' <- updatePreparedRelayedGroup db cxt user gInfo mainCReq cReqHash incognitoProfile rootKey memberPrivKey publicMemberCount_
|
||||
-- Pre-emptively create owner members with trusted keys from link data
|
||||
@@ -2447,8 +2446,7 @@ processChatCommand cxt nm = \case
|
||||
Left e -> throwError $ ChatErrorStore e
|
||||
Right _ -> throwError $ ChatErrorStore SEDuplicateContactLink
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
gVar <- asks random
|
||||
rootKey@(rootPubKey, rootPrivKey) <- liftIO $ atomically $ C.generateKeyPair gVar
|
||||
rootKey@(rootPubKey, rootPrivKey) <- atomically . C.generateKeyPair =<< asks random
|
||||
let entityId = C.sha256Hash $ C.pubKeyBytes rootPubKey
|
||||
-- TODO [address DR] remove this option and switch to IKUsePQ True
|
||||
let (pqInitKeys, useDR) = case pqRatchet_ of
|
||||
@@ -2691,7 +2689,8 @@ processChatCommand cxt nm = \case
|
||||
APINewGroup userId incognito gProfile -> withUserId userId $ \user -> do
|
||||
g <- asks random
|
||||
memberId <- liftIO $ MemberId <$> encodedRandomBytes g 12
|
||||
gInfo <- newGroup user incognito gProfile False memberId Nothing Nothing
|
||||
(_, memberPrivKey) <- atomically $ C.generateKeyPair g
|
||||
gInfo <- newGroup user incognito gProfile False memberId (Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey}) Nothing
|
||||
createNewGroupItems user gInfo
|
||||
pure $ CRGroupCreated user gInfo
|
||||
NewGroup incognito gProfile -> withUser $ \User {userId} ->
|
||||
@@ -2727,7 +2726,7 @@ processChatCommand cxt nm = \case
|
||||
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- generate root key pair; entity ID = sha256(rootPubKey) — see docs/rfcs/2026-03-28-group-identity-binding.md
|
||||
rootKey@(rootPubKey, rootPrivKey) <- liftIO $ atomically $ C.generateKeyPair gVar
|
||||
rootKey@(rootPubKey, rootPrivKey) <- atomically $ C.generateKeyPair gVar
|
||||
let entityId = C.sha256Hash $ C.pubKeyBytes rootPubKey
|
||||
crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
-- prepare link with entityId as linkEntityId (no server request)
|
||||
@@ -2745,7 +2744,8 @@ processChatCommand cxt nm = \case
|
||||
userLinkData = UserContactLinkData UserContactData {direct = False, owners = [ownerAuth], relays = [], userData, ratchetKeys = Nothing}
|
||||
-- create connection with prepared link (single network call)
|
||||
connId <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True ccLink preparedParams userLinkData subMode
|
||||
let groupKeys = GroupKeys {publicGroupId = B64UrlByteString entityId, groupRootKey = GRKPrivate rootPrivKey, memberPrivKey}
|
||||
let groupKeys = GroupKeys {publicGroupKeys, memberPrivKey}
|
||||
publicGroupKeys = Just PublicGroupKeys {publicGroupId = B64UrlByteString entityId, groupRootKey = GRKPrivate rootPrivKey}
|
||||
setupLink gInfo = do
|
||||
-- TODO [relays] starting role should be communicated in protocol from owner to relays
|
||||
subRole <- asks $ channelSubscriberRole . config
|
||||
@@ -2834,7 +2834,7 @@ processChatCommand cxt nm = \case
|
||||
case activeConn of
|
||||
Just Connection {peerChatVRange} -> do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (groupMemberKey g)
|
||||
agentConnId <- case memberConn fromMember of
|
||||
Nothing -> do
|
||||
agentConnId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff
|
||||
@@ -3399,7 +3399,7 @@ processChatCommand cxt nm = \case
|
||||
joinPreparedConn subMode conn = do
|
||||
-- [incognito] send membership incognito profile
|
||||
p <- presentUserBadge user (incognitoMembershipProfile gInfo) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True
|
||||
dm <- encodeConnInfo $ XInfo p
|
||||
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
|
||||
void $ withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared newStatus
|
||||
@@ -3801,7 +3801,7 @@ processChatCommand cxt nm = \case
|
||||
joinPreparedConn conn incognitoProfile
|
||||
joinPreparedConn conn incognitoProfile = do
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user incognitoProfile Nothing True
|
||||
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend
|
||||
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
|
||||
conn' <- withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared newStatus
|
||||
@@ -3954,10 +3954,15 @@ processChatCommand cxt nm = \case
|
||||
Just gInfo_' -> userProfileInGroup' user gInfo_' incognitoProfile
|
||||
Nothing -> userProfileDirect user incognitoProfile Nothing True
|
||||
dm <- case gInfo_ of
|
||||
Just (Just gInfo) | useRelays' gInfo -> case relayMemberId_ of
|
||||
Just relayMemberId -> encodeXMemberConnInfo gInfo relayMemberId profileToSend
|
||||
Nothing -> throwChatError $ CEInternalError "relay group join without target relay memberId"
|
||||
_ -> encodeConnInfoPQ pqSup $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
|
||||
Just (Just gInfo)
|
||||
| useRelays' gInfo -> case relayMemberId_ of
|
||||
Just relayMemberId -> encodeXMemberConnInfo gInfo relayMemberId profileToSend
|
||||
Nothing -> throwChatError $ CEInternalError "relay group join without target relay memberId"
|
||||
| otherwise -> do
|
||||
gInfo' <- createUserMemberKey gInfo
|
||||
encodeConnInfoPQ pqSup $ XContact profileToSend (groupMemberKey gInfo') (Just xContactId) welcomeSharedMsgId msg_
|
||||
_ ->
|
||||
encodeConnInfoPQ pqSup $ XContact profileToSend Nothing (Just xContactId) welcomeSharedMsgId msg_
|
||||
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
|
||||
@@ -4032,7 +4037,7 @@ processChatCommand cxt nm = \case
|
||||
ctSndEvent :: ChangedProfileContact -> CM (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
|
||||
ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = do
|
||||
p'' <- presentUserBadge user' Nothing mergedProfile'
|
||||
pure (ConnectionId connId, Nothing, XInfo p'')
|
||||
pure (ConnectionId connId, Nothing, XInfo p'' Nothing)
|
||||
ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq
|
||||
ctMsgReq ChangedProfileContact {conn} =
|
||||
fmap $ \SndMessage {msgId, msgBody} ->
|
||||
@@ -4065,7 +4070,7 @@ processChatCommand cxt nm = \case
|
||||
when (mergedProfile' /= mergedProfile) $
|
||||
withContactLock "updateContactPrefs" (contactId' ct) $ do
|
||||
p <- presentUserBadge user incognitoProfile mergedProfile'
|
||||
void (sendDirectContactMessage user ct' $ XInfo p) `catchAllErrors` eToView
|
||||
void (sendDirectContactMessage user ct' $ XInfo p Nothing) `catchAllErrors` eToView
|
||||
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
|
||||
pure $ CRContactPrefsUpdated user ct ct'
|
||||
runUpdateGroupProfile :: User -> GroupInfo -> GroupProfile -> Bool -> CM ChatResponse
|
||||
@@ -4241,12 +4246,13 @@ processChatCommand cxt nm = \case
|
||||
createInternalChatItem user cd (CISndGroupE2EEInfo $ e2eInfoGroup gInfo) Nothing
|
||||
createGroupFeatureItems user cd CISndGroupFeature gInfo
|
||||
sendGrpInvitation :: User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> CM ()
|
||||
sendGrpInvitation user ct@Contact {contactId, localDisplayName} gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
|
||||
sendGrpInvitation user ct@Contact {contactId, localDisplayName} gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} m@GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
|
||||
let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo
|
||||
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
||||
groupInv =
|
||||
GroupInvitation
|
||||
{ fromMember = MemberIdRole userMemberId userRole,
|
||||
fromMemberKey = groupMemberKey gInfo,
|
||||
invitedMember = MemberIdRole memberId memRole,
|
||||
connRequest = cReq,
|
||||
groupProfile,
|
||||
@@ -5154,7 +5160,7 @@ addUserBadge user cred@(BadgeCredential keyIdx _ _ info) = do
|
||||
| not (connIncognito conn) -> do
|
||||
let ct' = updateMergedPreferences user' ct
|
||||
p <- presentUserBadge user' Nothing $ userProfileDirect user' Nothing (Just ct') False
|
||||
void (sendDirectContactMessage user' ct' (XInfo p)) `catchAllErrors` eToView
|
||||
void (sendDirectContactMessage user' ct' (XInfo p Nothing)) `catchAllErrors` eToView
|
||||
_ -> pure ()
|
||||
|
||||
assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM ()
|
||||
|
||||
@@ -40,7 +40,7 @@ import Data.Foldable (foldr')
|
||||
import Data.Functor (($>))
|
||||
import Data.Functor.Identity
|
||||
import Data.Int (Int64)
|
||||
import Data.List (foldl', mapAccumL, partition)
|
||||
import Data.List (find, foldl', mapAccumL, partition)
|
||||
import Data.List.NonEmpty (NonEmpty (..), (<|))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
@@ -970,7 +970,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
|
||||
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
|
||||
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend
|
||||
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing
|
||||
(ct,conn,) <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode)
|
||||
|
||||
acceptContactRequestAsync :: User -> Int64 -> Contact -> UserContactRequest -> Maybe IncognitoProfile -> CM Contact
|
||||
@@ -991,7 +991,7 @@ acceptContactRequestAsync
|
||||
Connection {connId} <- liftIO $ createAcceptedContactConn db user (Just uclId) contactId acId chatV cReqChatVRange cReqPQSup incognitoProfile subMode currentTs
|
||||
liftIO $ setCommandConnId db user cmdId connId
|
||||
getContact db cxt user contactId
|
||||
agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend) cReqPQSup subMode
|
||||
agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend Nothing) cReqPQSup subMode
|
||||
pure ct'
|
||||
|
||||
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
|
||||
@@ -1032,6 +1032,7 @@ acceptGroupJoinRequestAsync
|
||||
GroupLinkInvitation
|
||||
{ fromMember = MemberIdRole userMemberId userRole,
|
||||
fromMemberName = displayName,
|
||||
fromMemberKey = groupMemberKey gInfo,
|
||||
invitedMember = MemberIdRole memberId gLinkMemRole,
|
||||
groupProfile,
|
||||
accepted = Just gAccepted,
|
||||
@@ -1095,6 +1096,7 @@ acceptBusinessJoinRequestAsync
|
||||
GroupLinkInvitation
|
||||
{ fromMember = MemberIdRole userMemberId userRole,
|
||||
fromMemberName = displayName,
|
||||
fromMemberKey = groupMemberKey gInfo,
|
||||
invitedMember = MemberIdRole memberId GRMember,
|
||||
groupProfile = businessGroupProfile userProfile groupPreferences,
|
||||
accepted = Just GAAccepted,
|
||||
@@ -1593,7 +1595,7 @@ groupLinkData gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {public
|
||||
publicGroupData_ = PublicGroupData <$> publicMemberCount
|
||||
userData = encodeShortLinkData $ GroupShortLinkData {groupProfile, publicGroupData = publicGroupData_}
|
||||
owners = case groupKeys of
|
||||
Just GroupKeys {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey} ->
|
||||
Just GroupKeys {publicGroupKeys = Just PublicGroupKeys {groupRootKey = GRKPrivate rootPrivKey}, memberPrivKey} ->
|
||||
let ownerId = unMemberId memberId
|
||||
ownerKey = C.publicKey memberPrivKey
|
||||
authOwnerSig = C.sign' rootPrivKey (ownerId <> C.encodePubKey ownerKey)
|
||||
@@ -2248,27 +2250,46 @@ createSndMessages idsEvents = do
|
||||
encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
|
||||
|
||||
groupMsgSigning :: Bool -> GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning
|
||||
groupMsgSigning sign gInfo@GroupInfo {membership = GroupMember {memberId}, groupKeys = Just GroupKeys {publicGroupId, memberPrivKey}} evt
|
||||
| useRelays' gInfo && shouldSign =
|
||||
Just $ MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
|
||||
where
|
||||
tag = toCMEventTag evt
|
||||
shouldSign = requiresSignature tag || (sign && signableContent tag)
|
||||
groupMsgSigning _ _ _ = Nothing
|
||||
groupMsgSigning sign GroupInfo {membership = GroupMember {memberId}, groupKeys} evt = case groupKeys of
|
||||
Just gks@GroupKeys {memberPrivKey} | shouldSign -> Just $ MsgSigning CBGroup bindingData KRMember memberPrivKey
|
||||
where
|
||||
tag = toCMEventTag evt
|
||||
shouldSign = requiresSignature tag || (sign && signableContent tag)
|
||||
bindingData = groupBindingData (Just gks) memberId (C.publicKey memberPrivKey)
|
||||
_ -> Nothing
|
||||
|
||||
groupBindingData :: Maybe GroupKeys -> MemberId -> C.PublicKeyEd25519 -> ByteString
|
||||
groupBindingData gks memberId memberKey = case gks >>= publicGroupKeys of
|
||||
Just PublicGroupKeys {publicGroupId} -> smpEncode (publicGroupId, memberId)
|
||||
Nothing -> smpEncode (memberId, memberKey)
|
||||
|
||||
createUserMemberKey :: GroupInfo -> CM GroupInfo
|
||||
createUserMemberKey gInfo@GroupInfo {groupId, membership, groupKeys}
|
||||
| useRelays' gInfo || isJust groupKeys = pure gInfo
|
||||
| otherwise = do
|
||||
(_, memberPrivKey) <- atomically . C.generateKeyPair =<< asks random
|
||||
withStore' $ \db -> setUserMemberKey db groupId (groupMemberId' membership) memberPrivKey
|
||||
pure gInfo {groupKeys = Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey}}
|
||||
|
||||
groupMemberKey :: GroupInfo -> Maybe MemberKey
|
||||
groupMemberKey GroupInfo {groupKeys} = MemberKey . C.publicKey . memberPrivKey <$> groupKeys
|
||||
|
||||
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfo -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
|
||||
sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do
|
||||
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
|
||||
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False gInfo evt, evt)) events
|
||||
mode = if useRelays' gInfo then BMBinary else BMJson
|
||||
(errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts
|
||||
unless (null errs) $ toView $ CEvtChatErrors errs
|
||||
forM_ (L.nonEmpty msgs) $ \msgs' ->
|
||||
batchSendConnMessages mode user conn MsgFlags {notification = True} msgs'
|
||||
batchSendConnMessages gInfo user conn MsgFlags {notification = True} msgs'
|
||||
|
||||
batchSendConnMessages :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
|
||||
batchSendConnMessages mode user conn msgFlags msgs =
|
||||
batchSendConnMessages :: GroupInfo -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
|
||||
batchSendConnMessages gInfo user conn msgFlags msgs =
|
||||
batchSendConnMessagesB mode user conn msgFlags $ L.map Right msgs
|
||||
where
|
||||
mode
|
||||
| useRelays' gInfo || maxVersion (peerChatVRange conn) >= relayWebCapVersion = BMBinary
|
||||
| otherwise = BMJson
|
||||
|
||||
batchSendConnMessagesB :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
|
||||
batchSendConnMessagesB mode _user conn msgFlags msgs_ = do
|
||||
@@ -2326,9 +2347,10 @@ encodeSignedConnInfo signing chatMsgEvent = do
|
||||
encodeXMemberConnInfo :: GroupInfo -> MemberId -> Profile -> CM ByteString
|
||||
encodeXMemberConnInfo GroupInfo {membership = GroupMember {memberId}, groupKeys} relayMemberId profileToSend =
|
||||
case groupKeys of
|
||||
Just GroupKeys {publicGroupId, memberPrivKey} ->
|
||||
Just gks@GroupKeys {memberPrivKey} ->
|
||||
let xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey) (Just relayMemberId)
|
||||
signing = MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
|
||||
bindingData = groupBindingData (Just gks) memberId (C.publicKey memberPrivKey)
|
||||
signing = MsgSigning CBGroup bindingData KRMember memberPrivKey
|
||||
in encodeSignedConnInfo signing xMemberEvt
|
||||
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
|
||||
|
||||
@@ -2483,13 +2505,15 @@ sendRelayCapIfNeeded user gInfo = do
|
||||
withStore' $ \db -> updateRelaySentWebDomain db gInfo currentWebDomain
|
||||
|
||||
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages user gInfo scope asGroup members sign events = do
|
||||
sendGroupMessages user gInfo' scope asGroup members sign events = do
|
||||
gInfo <- createUserMemberKey gInfo'
|
||||
sendGroupProfileUpdate user gInfo scope asGroup members
|
||||
sendGroupMessages_ user gInfo members sign events
|
||||
|
||||
-- per-item signer variant of sendGroupMessages (used for per-item delete signing); preserves the profile-update prelude
|
||||
sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupSignedMessages user gInfo scope asGroup members signedEvents = do
|
||||
sendGroupSignedMessages user gInfo' scope asGroup members signedEvents = do
|
||||
gInfo <- createUserMemberKey gInfo'
|
||||
sendGroupProfileUpdate user gInfo scope asGroup members
|
||||
sendGroupSignedMessages_ gInfo members signedEvents
|
||||
|
||||
@@ -2513,7 +2537,7 @@ sendGroupProfileUpdate user gInfo scope asGroup members =
|
||||
sendProfileUpdate = do
|
||||
-- shouldSendProfileUpdate excludes incognito membership, so the badge is presented
|
||||
profileUpdate <- presentUserBadge user Nothing $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p
|
||||
void $ sendGroupMessage' user gInfo members $ XInfo profileUpdate
|
||||
void $ sendGroupMessage' user gInfo members $ XInfo profileUpdate (groupMemberKey gInfo)
|
||||
currentTs <- liftIO getCurrentTime
|
||||
withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
|
||||
|
||||
@@ -2533,7 +2557,7 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
|
||||
recipientMembers' <- liftIO $ shuffleMembers recipientMembers
|
||||
let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events}
|
||||
(toSend, toPending, forwarded, _, dups) =
|
||||
foldr' (addMember recipientMembers') ([], [], [], S.empty, 0 :: Int) recipientMembers'
|
||||
foldr' (addMember recipientMembers') (([], []), [], [], S.empty, 0 :: Int) recipientMembers'
|
||||
when (dups /= 0) $ logError $ "sendGroupMessages_: " <> tshow dups <> " duplicate members"
|
||||
-- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here
|
||||
-- Deliver to toSend members
|
||||
@@ -2557,26 +2581,30 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
|
||||
liftM2 (<>) (shuffle adminMs) (shuffle otherMs)
|
||||
where
|
||||
isAdmin GroupMember {memberRole} = memberRole >= GRAdmin
|
||||
addMember members m acc@(toSend, pending, forwarded, !mIds, !dups) =
|
||||
addMember members m acc@(toSend@(toSendBin, toSendJson), pending, forwarded, !mIds, !dups) =
|
||||
case memberSendAction gInfo events members m of
|
||||
Just a
|
||||
| mId `S.member` mIds -> (toSend, pending, forwarded, mIds, dups + 1)
|
||||
| otherwise -> case a of
|
||||
MSASend conn -> ((m, conn) : toSend, pending, forwarded, mIds', dups)
|
||||
MSASend conn ->
|
||||
let toSend' = case batchMode gInfo m of
|
||||
BMBinary -> ((m, conn) : toSendBin, toSendJson)
|
||||
BMJson -> (toSendBin, (m, conn) : toSendJson)
|
||||
in (toSend', pending, forwarded, mIds', dups)
|
||||
MSAPending -> (toSend, m : pending, forwarded, mIds', dups)
|
||||
MSAForwarded -> (toSend, pending, m : forwarded, mIds', dups)
|
||||
Nothing -> acc
|
||||
where
|
||||
mId = groupMemberId' m
|
||||
mIds' = S.insert mId mIds
|
||||
prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
|
||||
prepareMsgReqs msgFlags msgs toSend = do
|
||||
let mode = if useRelays' gInfo then BMBinary else BMJson
|
||||
batched_ = batchSndMessagesJSON mode msgs
|
||||
case L.nonEmpty batched_ of
|
||||
Just batched' -> foldMembers (length batched' + length msgs) msgBatchMBR batched' toSend
|
||||
Nothing -> ([], [])
|
||||
prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> ([(GroupMember, Connection)], [(GroupMember, Connection)]) -> ([GroupMemberId], [Either ChatError ChatMsgReq])
|
||||
prepareMsgReqs msgFlags msgs (toSendBin, toSendJson) =
|
||||
batchReqs 1 BMBinary toSendBin <> batchReqs 2 BMJson toSendJson
|
||||
where
|
||||
batchReqs _ _ [] = ([], [])
|
||||
batchReqs n mode toSend' = case L.nonEmpty (batchSndMessagesJSON mode msgs) of
|
||||
Just batched -> foldMembers (n * (length batched + length msgs)) msgBatchMBR batched toSend'
|
||||
Nothing -> ([], [])
|
||||
foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
|
||||
foldMembers lastRef mkMb mbs mems = snd $ foldr' foldMsgBodies (lastMemIdx_, ([], [])) mems
|
||||
where
|
||||
@@ -2609,6 +2637,11 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
|
||||
createPendingMsg db (groupMemberId, msgId) =
|
||||
createPendingGroupMessage db groupMemberId msgId $> Right ()
|
||||
|
||||
batchMode :: GroupInfo -> GroupMember -> BatchMode
|
||||
batchMode gInfo m
|
||||
| useRelays' gInfo || m `supportsVersion` relayWebCapVersion = BMBinary
|
||||
| otherwise = BMJson
|
||||
|
||||
data MemberSendAction = MSASend Connection | MSAPending | MSAForwarded
|
||||
|
||||
memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction
|
||||
@@ -2682,10 +2715,9 @@ sendFwdMemberMessage member fwd verifiedMsg =
|
||||
-- TODO ensure order - pending messages interleave with user input messages
|
||||
sendPendingGroupMessages :: User -> GroupInfo -> GroupMember -> Connection -> CM ()
|
||||
sendPendingGroupMessages user gInfo GroupMember {groupMemberId} conn = do
|
||||
let mode = if useRelays' gInfo then BMBinary else BMJson
|
||||
msgs <- withStore' $ \db -> getPendingGroupMessages db groupMemberId
|
||||
forM_ (L.nonEmpty msgs) $ \msgs' -> do
|
||||
void $ batchSendConnMessages mode user conn MsgFlags {notification = True} msgs'
|
||||
void $ batchSendConnMessages gInfo user conn MsgFlags {notification = True} msgs'
|
||||
lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs'
|
||||
|
||||
saveDirectRcvMSG :: forall e. MsgEncodingI e => Connection -> MsgMeta -> ChatMessage e -> CM (Connection, RcvMessage)
|
||||
@@ -2890,10 +2922,19 @@ joinAgentConnectionAsync :: CommandId -> Bool -> ConnId -> Bool -> ConnectionReq
|
||||
joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode =
|
||||
withAgent $ \a -> joinConnectionAsync a (aCorrId cmdId) updateConn connId enableNtfs cReqUri cInfo PQSupportOff subMode
|
||||
|
||||
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> CM ()
|
||||
allowAgentConnectionAsync user conn@Connection {connId, pqSupport} confId msg = do
|
||||
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> Maybe GroupInfo -> ChatMsgEvent e -> CM ()
|
||||
allowAgentConnectionAsync user conn@Connection {pqSupport} confId gInfo_ msg = do
|
||||
let signing_ = case gInfo_ of
|
||||
Just gInfo | useRelays' gInfo || maxVersion (peerChatVRange conn) >= relayWebCapVersion -> groupMsgSigning False gInfo msg
|
||||
_ -> Nothing
|
||||
dm <- case signing_ of
|
||||
Just signing -> encodeSignedConnInfo signing msg
|
||||
Nothing -> encodeConnInfoPQ pqSupport msg
|
||||
allowAgentConnectionInfo user conn confId dm
|
||||
|
||||
allowAgentConnectionInfo :: User -> Connection -> ConfirmationId -> ByteString -> CM ()
|
||||
allowAgentConnectionInfo user conn@Connection {connId} confId dm = do
|
||||
cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFAllowConn
|
||||
dm <- encodeConnInfoPQ pqSupport msg
|
||||
withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm
|
||||
withStore' $ \db -> updateConnectionStatus db conn ConnAccepted
|
||||
|
||||
|
||||
@@ -112,11 +112,11 @@ import qualified Data.Aeson as J
|
||||
smallGroupsRcptsMemLimit :: Int
|
||||
smallGroupsRcptsMemLimit = 20
|
||||
|
||||
-- Verifies member signatures over CBGroup <> (publicGroupId, memberId) <> signedBody under the given key.
|
||||
-- Verifies member signatures over CBGroup <> (publicGroupId, memberId) or (memberId, pubKey) <> signedBody under the given key.
|
||||
-- signatures is NonEmpty so the verification can't be vacuously true.
|
||||
verifyGroupSig :: C.PublicKeyEd25519 -> B64UrlByteString -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
|
||||
verifyGroupSig key publicGroupId memberId signatures signedBody =
|
||||
let prefix = smpEncode CBGroup <> smpEncode (publicGroupId, memberId)
|
||||
verifyGroupSig :: C.PublicKeyEd25519 -> Maybe GroupKeys -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
|
||||
verifyGroupSig key gks memberId signatures signedBody =
|
||||
let prefix = encodeChatBinding CBGroup $ groupBindingData gks memberId key
|
||||
in all (\case (MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 key) sig (prefix <> signedBody)) signatures
|
||||
|
||||
processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
|
||||
@@ -481,7 +481,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
Just 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
|
||||
allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
|
||||
allowAgentConnectionAsync user conn'' confId gInfo_ $ XInfo profileToSend (groupMemberKey =<< gInfo_)
|
||||
INFO pqSupport connInfo -> do
|
||||
processINFOpqSupport conn pqSupport
|
||||
void $ saveConnInfo conn connInfo
|
||||
@@ -558,7 +558,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta
|
||||
XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId
|
||||
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct'' sharedMsgId fileConnReq_ fName
|
||||
XInfo p -> xInfo ct'' p
|
||||
XInfo p _ -> xInfo ct'' p
|
||||
XDirectDel -> xDirectDel ct'' msg msgMeta
|
||||
XGrpInv gInv -> processGroupInvitation ct'' gInv msg msgMeta
|
||||
XInfoProbe probe -> xInfoProbe (COMContact ct'') probe
|
||||
@@ -591,24 +591,25 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
-- TODO check member ID
|
||||
-- TODO update member profile
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn'' confId XOk
|
||||
XInfo profile -> do
|
||||
allowAgentConnectionAsync user conn'' confId Nothing XOk
|
||||
XInfo profile _ -> do
|
||||
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
|
||||
allowAgentConnectionAsync user conn'' confId $ XInfo p
|
||||
allowAgentConnectionAsync user conn'' confId Nothing $ XInfo p Nothing
|
||||
void $ withStore' $ \db -> resetMemberContactFields db ct'
|
||||
XGrpLinkInv glInv -> do
|
||||
-- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
|
||||
memberKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
(gInfo, host) <- withStore $ \db -> do
|
||||
liftIO $ deleteContactCardKeepConn db connId ct
|
||||
createGroupInvitedViaLink db cxt user conn'' glInv
|
||||
createGroupInvitedViaLink db cxt user conn'' memberKeys glInv
|
||||
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)
|
||||
allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
|
||||
allowAgentConnectionAsync user conn'' confId (Just gInfo) $ XInfo profileToSend (groupMemberKey gInfo)
|
||||
toView $ CEvtBusinessLinkConnecting user gInfo host ct
|
||||
_ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info"
|
||||
INFO pqSupport connInfo -> do
|
||||
@@ -620,7 +621,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
-- TODO check member ID
|
||||
-- TODO update member profile
|
||||
pure ()
|
||||
XInfo profile -> do
|
||||
XInfo profile _ -> do
|
||||
let prepared = isJust (preparedContact ct) || isJust (contactRequestId' ct)
|
||||
void $ processContactProfileUpdate ct profile prepared
|
||||
XOk -> pure ()
|
||||
@@ -754,11 +755,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
case memberCategory m of
|
||||
GCInviteeMember ->
|
||||
case chatMsgEvent of
|
||||
XGrpAcpt memId
|
||||
XGrpAcpt memId mKey
|
||||
| sameMemberId memId m -> do
|
||||
withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
||||
forM_ mKey $ \(MemberKey k) -> withStore' $ \db -> setMemberPubKey db (groupMemberId' m) k
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn' confId XOk
|
||||
allowAgentConnectionAsync user conn' confId (Just gInfo) XOk
|
||||
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
|
||||
XGrpRelayAcpt relayLink relayCap
|
||||
| memberRole' membership == GROwner && isRelay m -> do
|
||||
@@ -778,7 +780,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
liftIO $ updateGroupMemberStatus db userId m GSMemLeft
|
||||
pure (relay', m {memberStatus = GSMemLeft})
|
||||
-- complete the contact handshake so the relay receives INFO and cleans up its transient bookkeeping
|
||||
allowAgentConnectionAsync user conn' confId XOk
|
||||
allowAgentConnectionAsync user conn' confId (Just gInfo) XOk
|
||||
toView $ CEvtGroupRelayUpdated user gInfo m' relay'
|
||||
toViewTE $ TERelayRejected user gInfo reason
|
||||
| otherwise -> messageError "x.grp.relay.reject: only owner should receive relay rejection"
|
||||
@@ -790,11 +792,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
pgId = fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId),
|
||||
useRelays' gInfo == isJust rcvPG && pgId rcvPG == pgId curPG -> do
|
||||
-- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records
|
||||
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
|
||||
(gInfo'', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
|
||||
gInfo' <- createUserMemberKey gInfo''
|
||||
-- [incognito] send saved profile
|
||||
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
|
||||
allowAgentConnectionAsync user conn' confId $ XInfo profileToSend
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo' (fromLocalProfile <$> incognitoProfile)
|
||||
allowAgentConnectionAsync user conn' confId (Just gInfo') $ XInfo profileToSend (groupMemberKey gInfo')
|
||||
toView $ CEvtGroupLinkConnecting user gInfo' m'
|
||||
| otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch"
|
||||
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
|
||||
@@ -810,11 +813,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
-- TODO update member profile
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membershipMemId membershipProfile
|
||||
allowAgentConnectionAsync user conn' confId (Just gInfo) $ XGrpMemInfo membershipMemId membershipProfile
|
||||
| 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
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
||||
(signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo
|
||||
_conn' <- updatePeerChatVRange conn chatVRange
|
||||
case chatMsgEvent of
|
||||
XGrpMemInfo memId _memProfile
|
||||
@@ -823,11 +826,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
pure ()
|
||||
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
||||
-- sent when connecting via group link
|
||||
XInfo _ ->
|
||||
XInfo _ mKey
|
||||
-- TODO Keep rejected member to allow them to appeal against rejection.
|
||||
when (memberStatus m == GSMemRejected) $ do
|
||||
deleteMemberConnection' m True
|
||||
withStore' $ \db -> deleteGroupMember db user m
|
||||
| memberStatus m == GSMemRejected -> do
|
||||
deleteMemberConnection' m True
|
||||
withStore' $ \db -> deleteGroupMember db user m
|
||||
| otherwise -> mapM_ (storeMemberKey gInfo m signedMsg_) mKey
|
||||
XOk ->
|
||||
-- transient relay-reject row cleanup after the rejection handshake completes
|
||||
when (memberCategory m == GCHostMember && not (relayServesGroup gInfo)) $ do
|
||||
@@ -913,7 +917,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
_ -> pure ()
|
||||
toView $ CEvtJoinedGroupMember user gInfo'' m' {memberStatus = mStatus}
|
||||
let Connection {viaUserContactLink} = conn
|
||||
when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo''
|
||||
when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo'' m'
|
||||
if useRelays' gInfo''
|
||||
then do
|
||||
introduceInChannel cxt user gInfo'' m'
|
||||
@@ -931,10 +935,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
_ -> False
|
||||
when (groupFeatureAllowed SGFHistory gInfo'' && not memberIsCustomer) $ sendHistory user gInfo'' m'
|
||||
where
|
||||
sendXGrpLinkMem gInfo'' = do
|
||||
sendXGrpLinkMem gInfo''' m' = do
|
||||
gInfo'' <- createUserMemberKey gInfo'''
|
||||
let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo''
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile)
|
||||
void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo'' (fromIncognitoProfile <$> incognitoProfile)
|
||||
sendGroupMemberMessages user gInfo'' conn [XGrpLinkMem profileToSend (groupMemberKey gInfo'')]
|
||||
_ -> do
|
||||
unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected
|
||||
notifyMemberConnected gInfo m Nothing
|
||||
@@ -1047,8 +1052,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
XFile fInv -> Nothing <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs
|
||||
XFileCancel sharedMsgId -> xFileCancelGroup gInfo' (Just m'') sharedMsgId
|
||||
XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName
|
||||
XInfo p -> fmap ctx <$> xInfoMember gInfo' m'' p msg brokerTs
|
||||
XGrpLinkMem p -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p
|
||||
XInfo p mKey -> fmap ctx <$> xInfoMember gInfo' m'' p mKey msg brokerTs
|
||||
XGrpLinkMem p mKey -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p mKey msg
|
||||
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs
|
||||
XGrpRelayNew rl -> fmap ctx <$> xGrpRelayNew gInfo' m'' rl
|
||||
XGrpRelayCap relayCap
|
||||
@@ -1229,7 +1234,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
||||
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
|
||||
pure (confId, m', relay)
|
||||
allowAgentConnectionAsync user conn confId XOk
|
||||
allowAgentConnectionAsync user conn confId (Just gInfo) XOk
|
||||
toView $ CEvtGroupRelayUpdated user gInfo m' relay
|
||||
else
|
||||
-- TODO [relays] owner: TBC failed RelayStatus?
|
||||
@@ -1359,9 +1364,9 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
REQ invId pqSupport _ connInfo rejectionSupported -> do
|
||||
(signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo
|
||||
case chatMsgEvent of
|
||||
XContact p xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ pqSupport rejectionSupported
|
||||
XContact p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange 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 p Nothing Nothing Nothing pqSupport rejectionSupported
|
||||
XInfo p _ -> profileContactRequest invId chatVRange p Nothing Nothing Nothing Nothing pqSupport rejectionSupported
|
||||
XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv
|
||||
XGrpRelayTest challenge _ -> xGrpRelayTest invId chatVRange challenge
|
||||
-- TODO show/log error, other events in contact request
|
||||
@@ -1435,8 +1440,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
-- TODO add debugging output
|
||||
_ -> pure ()
|
||||
where
|
||||
profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> PQSupport -> Bool -> CM ()
|
||||
profileContactRequest invId chatVRange p@Profile {displayName} xContactId_ welcomeMsgId_ requestMsg_ reqPQSup rejectionSupported = do
|
||||
profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe MemberKey -> Maybe XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> PQSupport -> Bool -> CM ()
|
||||
profileContactRequest invId chatVRange p@Profile {displayName} memberKey_ xContactId_ welcomeMsgId_ requestMsg_ reqPQSup rejectionSupported = do
|
||||
(ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId
|
||||
let v = maxVersion chatVRange
|
||||
case gLinkInfo_ of
|
||||
@@ -1589,7 +1594,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
maybe (pure $ Right (GAAccepted, gLinkMemRole)) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case
|
||||
Right (acceptance, useRole) -> do
|
||||
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode Nothing Nothing
|
||||
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode memberKey_ Nothing
|
||||
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
|
||||
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
||||
toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem'
|
||||
@@ -1649,9 +1654,9 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
where
|
||||
-- replay defense: the viaRelay == own memberId check (viaRelay is in the signed body); without it a sibling relay could replay a privileged member's signed join
|
||||
verifyKey gInfo rosterMem = case (signedMsg_, groupKeys gInfo) of
|
||||
(Just SignedMsg {chatBinding = CBGroup, signatures, signedBody}, Just GroupKeys {publicGroupId}) ->
|
||||
(Just SignedMsg {chatBinding = CBGroup, signatures, signedBody}, Just gks) ->
|
||||
memberPubKey rosterMem == Just joiningKey
|
||||
&& verifyGroupSig joiningKey publicGroupId joiningMemberId signatures signedBody
|
||||
&& verifyGroupSig joiningKey (Just gks) joiningMemberId signatures signedBody
|
||||
&& viaRelay == Just (memberId' (membership gInfo))
|
||||
_ -> False
|
||||
acceptJoin gInfo existingMem_ acceptRole = do
|
||||
@@ -2618,14 +2623,15 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
||||
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
||||
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId
|
||||
memberKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, 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
|
||||
-- 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
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (groupMemberKey gInfo)
|
||||
connIds@(cmdId, acId) <- prepareAgentJoin user Nothing True connRequest
|
||||
withStore' $ \db -> do
|
||||
when sameLink $ setViaGroupLinkUri db groupId connId
|
||||
@@ -2729,22 +2735,35 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
Profile {displayName = n, fullName = fn, shortDescr = sd, image = i, contactLink = cl} = p
|
||||
Profile {displayName = n', fullName = fn', shortDescr = sd', image = i', contactLink = cl'} = p'
|
||||
|
||||
xInfoMember :: GroupInfo -> GroupMember -> Profile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
xInfoMember gInfo m p' msg brokerTs = do
|
||||
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))
|
||||
pure $ memberEventDeliveryScope m
|
||||
|
||||
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
|
||||
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do
|
||||
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
|
||||
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
|
||||
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 ()
|
||||
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"
|
||||
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 (groupKeys gInfo) memberId signatures signedBody
|
||||
_ -> False
|
||||
|
||||
xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
|
||||
xGrpLinkAcpt gInfo@GroupInfo {membership} m acceptance role memberId msg brokerTs
|
||||
| memberRole' m < GRModerator || memberRole' m < role =
|
||||
@@ -2840,7 +2859,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of
|
||||
Just bc | isMainBusinessMember bc m -> do
|
||||
g' <- withStore $ \db -> updateGroupProfileFromMember db user g p'
|
||||
toView $ CEvtGroupUpdated user g g' (Just m) Nothing
|
||||
toView $ CEvtGroupUpdated user g g' (Just m) ((\(RcvMessage {msgSigned}, _) -> msgSigned) =<< msgTs_)
|
||||
_ -> pure ()
|
||||
isMainBusinessMember BusinessChatInfo {chatType, businessId, customerId} GroupMember {memberId} = case chatType of
|
||||
BCBusiness -> businessId == memberId
|
||||
@@ -3076,16 +3095,18 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
|
||||
conn' <- updatePeerChatVRange activeConn chatVRange
|
||||
case chatMsgEvent of
|
||||
XInfo p -> do
|
||||
XInfo p _ -> do
|
||||
ct <- withStore $ \db -> createDirectContact db cxt user conn' p
|
||||
toView $ CEvtContactConnecting user ct
|
||||
pure (conn', Nothing)
|
||||
XGrpLinkInv glInv -> do
|
||||
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db cxt user conn' glInv
|
||||
memberKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db cxt user conn' memberKeys glInv
|
||||
toView $ CEvtGroupLinkConnecting user gInfo host
|
||||
pure (conn', Just gInfo)
|
||||
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
|
||||
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db cxt user conn' glRjct
|
||||
memberKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db cxt user conn' memberKeys glRjct
|
||||
toView $ CEvtGroupLinkConnecting user gInfo host
|
||||
toViewTE $ TEGroupLinkRejected user gInfo rejectionReason
|
||||
pure (conn', Just gInfo)
|
||||
@@ -3826,7 +3847,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
-- [incognito] send membership incognito profile
|
||||
p <- presentUserBadge user (incognitoMembershipProfile g) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True
|
||||
-- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ)
|
||||
dm <- encodeConnInfo $ XInfo p
|
||||
dm <- encodeConnInfo $ XInfo p Nothing
|
||||
joinAgentConnectionAsync cmdId False acId True connReq dm subMode
|
||||
createItems mCt' m' = do
|
||||
(g', m'', scopeInfo) <- mkGroupChatScope g m'
|
||||
@@ -3884,7 +3905,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
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
|
||||
XInfo p -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p rcvMsg msgTs
|
||||
XInfo p mKey -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p mKey rcvMsg msgTs
|
||||
XGrpRelayNew rl -> withAuthor XGrpRelayNew_ $ \author -> void $ xGrpRelayNew gInfo author rl
|
||||
XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs
|
||||
XGrpMemRole memId memRole memberKey rosterVer -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo (Just m) author memId memRole memberKey rosterVer rcvMsg msgTs
|
||||
@@ -3903,7 +3924,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author"
|
||||
|
||||
withVerifiedMsg :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a)
|
||||
withVerifiedMsg gInfo@GroupInfo {membership} scopeInfo member (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
|
||||
withVerifiedMsg gInfo@GroupInfo {membership, groupKeys} scopeInfo member@GroupMember {memberPubKey, memberId} (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
|
||||
case verified of
|
||||
Just verifiedMsg -> Just <$> action verifiedMsg
|
||||
Nothing -> do
|
||||
@@ -3911,17 +3932,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
pure Nothing
|
||||
where
|
||||
verified = case signedMsg_ of
|
||||
Just sm@SignedMsg {chatBinding, signatures, signedBody}
|
||||
| GroupMember {memberPubKey = Just pubKey, memberId} <- member ->
|
||||
case chatBinding of
|
||||
CBGroup
|
||||
| Just GroupKeys {publicGroupId} <- groupKeys gInfo ->
|
||||
signed MSSVerified <$ guard (verifyGroupSig pubKey publicGroupId memberId signatures signedBody)
|
||||
| otherwise ->
|
||||
let prefix = smpEncode chatBinding <> smpEncode (memberId, pubKey) -- forward compatibility for verifying signed messages in p2p groups
|
||||
in signed MSSVerified <$ guard (all (\case (MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (prefix <> signedBody)) signatures)
|
||||
_ -> signed MSSSignedNoKey <$ guard signatureOptional
|
||||
| otherwise -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag)
|
||||
Just sm@SignedMsg {chatBinding, signatures, signedBody} -> case memberPubKey of
|
||||
Just pubKey -> case chatBinding of
|
||||
CBGroup -> signed MSSVerified <$ guard (verifyGroupSig pubKey groupKeys memberId signatures signedBody)
|
||||
_ -> signed MSSSignedNoKey <$ guard signatureOptional
|
||||
Nothing -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag)
|
||||
where
|
||||
signed status = VMSigned status sm chatMsg
|
||||
Nothing -> VMUnsigned chatMsg <$ guard signatureOptional
|
||||
@@ -4379,7 +4394,7 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
r -> pure r
|
||||
scheduleRequest :: GroupId -> NominalDiffTime -> CM ()
|
||||
scheduleRequest groupId delay = do
|
||||
v_ <- liftIO $ atomically $
|
||||
v_ <- atomically $
|
||||
ifM
|
||||
(isNothing <$> TM.lookup groupId delayThreads)
|
||||
(newEmptyTMVar >>= \v -> TM.insert groupId v delayThreads $> Just v)
|
||||
@@ -4390,7 +4405,7 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
atomically $ TM.delete groupId delayThreads
|
||||
void $ atomically $ tryPutTMVar doWork ()
|
||||
weakTId <- liftIO $ mkWeakThreadId tId
|
||||
liftIO $ atomically $ putTMVar v weakTId
|
||||
atomically $ putTMVar v weakTId
|
||||
retryTmpError :: (Int, NominalDiffTime) -> GroupId -> RelayRequestData -> ChatError -> CM ()
|
||||
retryTmpError (retriesThreshold, ttl) groupId RelayRequestData {reqDelay, reqRetries, reqCreatedAt} = \case
|
||||
ChatErrorAgent {agentError} | temporaryOrHostError agentError -> do
|
||||
@@ -4450,7 +4465,7 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
gVar <- asks random
|
||||
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
sigKeys <- liftIO $ atomically $ C.generateKeyPair gVar
|
||||
sigKeys <- atomically $ C.generateKeyPair gVar
|
||||
let crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
-- prepare link with relayMemId as linkEntityId (no server request)
|
||||
(ccLink, preparedParams) <- withAgent $ \a' -> prepareConnectionLink a' (aUserId user) sigKeys relayMemId True (Just crClientData) CR.IKPQOff False Nothing
|
||||
|
||||
@@ -67,7 +67,7 @@ batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
|
||||
| msgLen <= maxLen = (addBatch acc, [body], [msg], msgLen, 1)
|
||||
| otherwise = (errLarge msg : addBatch acc, [], [], 0, 0)
|
||||
where
|
||||
body = encodeBatchElement signedMsg_ msgBody
|
||||
body = encodeBatchElement (if mode == BMBinary then signedMsg_ else Nothing) msgBody
|
||||
msgLen = B.length body
|
||||
len' = len + msgLen
|
||||
n' = n + 1
|
||||
|
||||
@@ -86,12 +86,13 @@ import Simplex.Messaging.Version hiding (version)
|
||||
-- 17 - allow host voice messages during member approval regardless of group voice setting (2026-02-10)
|
||||
-- 18 - relay web capabilities (2026-05-31)
|
||||
-- 19 - group roster (2026-06-18)
|
||||
-- 20 - p2p group member keys for signing (2026-07-26)
|
||||
|
||||
-- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
|
||||
-- This indirection is needed for backward/forward compatibility testing.
|
||||
-- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code.
|
||||
currentChatVersion :: VersionChat
|
||||
currentChatVersion = VersionChat 19
|
||||
currentChatVersion = VersionChat 20
|
||||
|
||||
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
|
||||
supportedChatVRange :: VersionRangeChat
|
||||
@@ -135,6 +136,10 @@ relayWebCapVersion = VersionChat 18
|
||||
groupRosterVersion :: VersionChat
|
||||
groupRosterVersion = VersionChat 19
|
||||
|
||||
-- members sign messages in p2p groups; member keys are distributed for verification
|
||||
groupMemberKeyVersion :: VersionChat
|
||||
groupMemberKeyVersion = VersionChat 20
|
||||
|
||||
data ConnectionEntity
|
||||
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
|
||||
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
|
||||
@@ -455,15 +460,15 @@ data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol
|
||||
XFileAcptInv :: SharedMsgId -> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json
|
||||
XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
|
||||
XInfo :: Profile -> ChatMsgEvent 'Json
|
||||
XContact :: {profile :: Profile, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
|
||||
XInfo :: {profile :: Profile, memberKey :: Maybe MemberKey} -> ChatMsgEvent 'Json
|
||||
XContact :: {profile :: Profile, memberKey :: Maybe MemberKey, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
|
||||
XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey, viaRelay :: Maybe MemberId} -> ChatMsgEvent 'Json
|
||||
XDirectDel :: ChatMsgEvent 'Json
|
||||
XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json
|
||||
XGrpAcpt :: MemberId -> ChatMsgEvent 'Json
|
||||
XGrpAcpt :: MemberId -> Maybe MemberKey -> ChatMsgEvent 'Json
|
||||
XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json
|
||||
XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json
|
||||
XGrpLinkMem :: Profile -> ChatMsgEvent 'Json
|
||||
XGrpLinkMem :: Profile -> Maybe MemberKey -> ChatMsgEvent 'Json
|
||||
XGrpLinkAcpt :: GroupAcceptance -> GroupMemberRole -> MemberId -> ChatMsgEvent 'Json
|
||||
XGrpRelayInv :: GroupRelayInvitation -> ChatMsgEvent 'Json
|
||||
XGrpRelayAcpt :: ShortLinkContact -> RelayCapabilities -> ChatMsgEvent 'Json
|
||||
@@ -522,7 +527,7 @@ isForwardedGroupMsg ev = case ev of
|
||||
XMsgDel {} -> True
|
||||
XMsgReact {} -> True
|
||||
XFileCancel _ -> True
|
||||
XInfo _ -> True
|
||||
XInfo {} -> True
|
||||
XGrpRelayNew _ -> True
|
||||
XGrpMemNew {} -> True
|
||||
XGrpMemRole {} -> True
|
||||
@@ -1248,15 +1253,15 @@ toCMEventTag msg = case msg of
|
||||
XFileAcpt _ -> XFileAcpt_
|
||||
XFileAcptInv {} -> XFileAcptInv_
|
||||
XFileCancel _ -> XFileCancel_
|
||||
XInfo _ -> XInfo_
|
||||
XInfo {} -> XInfo_
|
||||
XContact {} -> XContact_
|
||||
XMember {} -> XMember_
|
||||
XDirectDel -> XDirectDel_
|
||||
XGrpInv _ -> XGrpInv_
|
||||
XGrpAcpt _ -> XGrpAcpt_
|
||||
XGrpAcpt {} -> XGrpAcpt_
|
||||
XGrpLinkInv _ -> XGrpLinkInv_
|
||||
XGrpLinkReject _ -> XGrpLinkReject_
|
||||
XGrpLinkMem _ -> XGrpLinkMem_
|
||||
XGrpLinkMem {} -> XGrpLinkMem_
|
||||
XGrpLinkAcpt {} -> XGrpLinkAcpt_
|
||||
XGrpRelayInv _ -> XGrpRelayInv_
|
||||
XGrpRelayAcpt {} -> XGrpRelayAcpt_
|
||||
@@ -1342,6 +1347,7 @@ requiresSignature = \case
|
||||
XGrpRelayNew_ -> True
|
||||
XGrpRoster_ -> True
|
||||
XInfo_ -> True
|
||||
XGrpLinkMem_ -> True
|
||||
_ -> False
|
||||
|
||||
-- | Content events a member may sign (XMsgNew opt-in; XMsgUpdate/XMsgDel when the target was signed).
|
||||
@@ -1408,22 +1414,23 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
XFileAcpt_ -> XFileAcpt <$> p "fileName"
|
||||
XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> opt "fileConnReq" <*> p "fileName"
|
||||
XFileCancel_ -> XFileCancel <$> p "msgId"
|
||||
XInfo_ -> XInfo <$> p "profile"
|
||||
XInfo_ -> XInfo <$> p "profile" <*> opt "memberKey"
|
||||
XContact_ -> do
|
||||
profile <- p "profile"
|
||||
memberKey <- opt "memberKey"
|
||||
contactReqId <- opt "contactReqId"
|
||||
welcomeMsgId <- opt "welcomeMsgId"
|
||||
reqMsgId <- opt "msgId"
|
||||
reqContent <- opt "content"
|
||||
let requestMsg = (,) <$> reqMsgId <*> reqContent
|
||||
pure XContact {profile, contactReqId, welcomeMsgId, requestMsg}
|
||||
pure XContact {profile, memberKey, contactReqId, welcomeMsgId, requestMsg}
|
||||
XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey" <*> opt "viaRelay"
|
||||
XDirectDel_ -> pure XDirectDel
|
||||
XGrpInv_ -> XGrpInv <$> p "groupInvitation"
|
||||
XGrpAcpt_ -> XGrpAcpt <$> p "memberId"
|
||||
XGrpAcpt_ -> XGrpAcpt <$> p "memberId" <*> opt "memberKey"
|
||||
XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation"
|
||||
XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection"
|
||||
XGrpLinkMem_ -> XGrpLinkMem <$> p "profile"
|
||||
XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" <*> opt "memberKey"
|
||||
XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "acceptance" <*> p "role" <*> p "memberId"
|
||||
XGrpRelayInv_ -> XGrpRelayInv <$> p "groupRelayInvitation"
|
||||
XGrpRelayAcpt_ -> XGrpRelayAcpt <$> p "relayLink" <*> (fromMaybe defaultRelayCapabilities <$> opt "relayCap")
|
||||
@@ -1491,15 +1498,15 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
|
||||
XFileAcpt fileName -> o ["fileName" .= fileName]
|
||||
XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName]
|
||||
XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId]
|
||||
XInfo profile -> o ["profile" .= profile]
|
||||
XContact {profile, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ["profile" .= profile]
|
||||
XInfo {profile, memberKey} -> o $ ("memberKey" .=? memberKey) ["profile" .= profile]
|
||||
XContact {profile, memberKey, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ("memberKey" .=? memberKey) $ ["profile" .= profile]
|
||||
XMember {profile, newMemberId, newMemberKey, viaRelay} -> o $ ("viaRelay" .=? viaRelay) ["profile" .= profile, "newMemberId" .= newMemberId, "newMemberKey" .= newMemberKey]
|
||||
XDirectDel -> JM.empty
|
||||
XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
|
||||
XGrpAcpt memId -> o ["memberId" .= memId]
|
||||
XGrpAcpt memId memberKey -> o $ ("memberKey" .=? memberKey) ["memberId" .= memId]
|
||||
XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv]
|
||||
XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct]
|
||||
XGrpLinkMem profile -> o ["profile" .= profile]
|
||||
XGrpLinkMem profile memberKey -> o $ ("memberKey" .=? memberKey) ["profile" .= profile]
|
||||
XGrpLinkAcpt acceptance role memberId -> o ["acceptance" .= acceptance, "role" .= role, "memberId" .= memberId]
|
||||
XGrpRelayInv groupRelayInv -> o ["groupRelayInvitation" .= groupRelayInv]
|
||||
XGrpRelayAcpt relayLink relayCap -> o ["relayLink" .= relayLink, "relayCap" .= relayCap]
|
||||
|
||||
@@ -107,6 +107,8 @@ module Simplex.Chat.Store.Groups
|
||||
deleteRosterTransfer,
|
||||
deleteGroupRosterTransfers,
|
||||
setGroupMemberKeyRole,
|
||||
setUserMemberKey,
|
||||
setMemberPubKey,
|
||||
setGroupMemberVerified,
|
||||
createRelayForOwner,
|
||||
getCreateRelayForMember,
|
||||
@@ -387,10 +389,12 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
|
||||
withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
|
||||
let (rootPrivKey_, rootPubKey_, memberPrivKey_) = case groupKeys of
|
||||
Nothing -> (Nothing, Nothing, Nothing)
|
||||
Just GroupKeys {groupRootKey, memberPrivKey} ->
|
||||
let (rpk, rpub) = case groupRootKey of
|
||||
GRKPrivate pk -> (Just pk, Nothing)
|
||||
GRKPublic k -> (Nothing, Just k)
|
||||
Just GroupKeys {publicGroupKeys, memberPrivKey} ->
|
||||
let (rpk, rpub) = case publicGroupKeys of
|
||||
Just PublicGroupKeys {groupRootKey} -> case groupRootKey of
|
||||
GRKPrivate pk -> (Just pk, Nothing)
|
||||
GRKPublic k -> (Nothing, Just k)
|
||||
Nothing -> (Nothing, Nothing)
|
||||
in (rpk, rpub, Just memberPrivKey)
|
||||
groupId <- liftIO $ do
|
||||
DB.execute
|
||||
@@ -452,9 +456,9 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
|
||||
}
|
||||
|
||||
-- | creates a new group record for the group the current user was invited to, or returns an existing one
|
||||
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
|
||||
createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile, business} incognitoProfileId = do
|
||||
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> C.KeyPairEd25519 -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ _ = throwError $ SEContactNotReady localDisplayName
|
||||
createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, fromMemberKey, invitedMember, connRequest, groupProfile, business} incognitoProfileId memberKeys = do
|
||||
liftIO getInvitationGroupId_ >>= \case
|
||||
Nothing -> createGroupInvitation_
|
||||
Just gId -> do
|
||||
@@ -492,14 +496,14 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
|
||||
[sql|
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_display_name, inv_queue_info, user_id, enable_ntfs,
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, business_member_id, customer_member_id)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, member_priv_key, business_chat, business_member_id, customer_member_id)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((profileId, localDisplayName, connRequest, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. businessChatInfoRow business)
|
||||
((profileId, localDisplayName, connRequest, userId, BI True, currentTs, currentTs, currentTs, currentTs, snd memberKeys) :. businessChatInfoRow business)
|
||||
insertedRowId db
|
||||
let hostVRange = adjustedMemberVRange (vr cxt) peerChatVRange
|
||||
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing Nothing currentTs hostVRange
|
||||
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId Nothing currentTs (vr cxt)
|
||||
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing ((\(MemberKey k) -> k) <$> fromMemberKey) currentTs hostVRange
|
||||
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId (Just $ fst memberKeys) currentTs (vr cxt)
|
||||
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
|
||||
pure
|
||||
( GroupInfo
|
||||
@@ -526,7 +530,7 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
|
||||
customData = Nothing,
|
||||
membersRequireAttention = 0,
|
||||
viaGroupLinkUri = Nothing,
|
||||
groupKeys = Nothing,
|
||||
groupKeys = Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey = snd memberKeys},
|
||||
groupDomainVerified = Nothing
|
||||
},
|
||||
groupMemberId
|
||||
@@ -647,8 +651,9 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile {
|
||||
createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> StoreCxt -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> GroupMemberRole -> Maybe Int64 -> Maybe SimplexDomain -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember)
|
||||
createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays userMemberRole publicMemberCount_ verifiedDomain = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
(memberPubKey, memberPrivKey) <- atomically $ C.generateKeyPair gVar
|
||||
let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
|
||||
(groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing publicMemberCount_ currentTs
|
||||
(groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing publicMemberCount_ (Just memberPrivKey) currentTs
|
||||
hostMemberId_ <-
|
||||
if useRelays
|
||||
then pure Nothing
|
||||
@@ -658,8 +663,7 @@ createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile b
|
||||
then liftIO $ MemberId <$> encodedRandomBytes gVar 12
|
||||
else pure $ MemberId $ encodeUtf8 groupLDN <> "_user_unknown_id"
|
||||
let userMember = MemberIdRole userMemberId userMemberRole
|
||||
-- TODO [member keys] user key must be included here. Should key be added when group is prepared?
|
||||
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs (vr cxt)
|
||||
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing (Just memberPubKey) currentTs (vr cxt)
|
||||
hostMember_ <- forM hostMemberId_ $ getGroupMember db cxt user groupId
|
||||
forM_ hostMember_ $ \hostMember ->
|
||||
when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember
|
||||
@@ -781,10 +785,12 @@ updatePreparedGroupUser db cxt user gInfo@GroupInfo {groupId, membership} hostMe
|
||||
safeDeleteLDN db user oldHostLDN
|
||||
|
||||
updatePreparedUserAndHostMembersInvited :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
updatePreparedUserAndHostMembersInvited db cxt user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
updatePreparedUserAndHostMembersInvited db cxt user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberKey, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
let fromMemberProfile = profileFromName fromMemberName
|
||||
initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
|
||||
updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
|
||||
r@(_, hostMember') <- updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
|
||||
forM_ fromMemberKey $ \(MemberKey k) -> liftIO $ setMemberPubKey db (groupMemberId' hostMember') k
|
||||
pure r
|
||||
|
||||
updatePreparedUserAndHostMembersRejected :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
updatePreparedUserAndHostMembersRejected db cxt user gInfo hostMember GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
|
||||
@@ -846,36 +852,37 @@ updatePreparedUserAndHostMembers'
|
||||
(memberId, memberRole, currentTs, gmId)
|
||||
getGroupMemberById db cxt user gmId
|
||||
|
||||
createGroupInvitedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupInvitedViaLink db cxt user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
createGroupInvitedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupInvitedViaLink db cxt user conn memberKeys GroupLinkInvitation {fromMember, fromMemberKey, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
let fromMemberProfile = profileFromName fromMemberName
|
||||
initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
|
||||
createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus
|
||||
createGroupViaLink' db cxt user conn memberKeys fromMember fromMemberProfile ((\(MemberKey k) -> k) <$> fromMemberKey) invitedMember groupProfile business initialStatus
|
||||
|
||||
createGroupRejectedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupRejectedViaLink db cxt user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
|
||||
createGroupRejectedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupRejectedViaLink db cxt user conn memberKeys GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
|
||||
let fromMemberProfile = profileFromName $ nameFromMemberId memberId
|
||||
createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
|
||||
createGroupViaLink' db cxt user conn memberKeys fromMember fromMemberProfile Nothing invitedMember groupProfile Nothing GSMemRejected
|
||||
|
||||
createGroupViaLink' :: DB.Connection -> StoreCxt -> User -> Connection -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupViaLink' :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> MemberIdRole -> Profile -> Maybe C.PublicKeyEd25519 -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupViaLink'
|
||||
db
|
||||
cxt
|
||||
user@User {userId, userContactId}
|
||||
Connection {connId, customUserProfileId}
|
||||
memberKeys
|
||||
fromMember
|
||||
fromMemberProfile
|
||||
fromMemberPubKey_
|
||||
invitedMember
|
||||
groupProfile
|
||||
business
|
||||
membershipStatus = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
(groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing business False Nothing Nothing currentTs
|
||||
(groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing business False Nothing Nothing (Just (snd memberKeys)) currentTs
|
||||
hostMemberId <- insertHost_ currentTs groupId
|
||||
liftIO $ DB.execute db "UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ?" (ConnMember, hostMemberId, currentTs, connId)
|
||||
-- using IBUnknown since host is created without contact
|
||||
-- TODO [member keys] this is currently not used with public groups. If it needs to be used, member keys need to be added
|
||||
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId Nothing currentTs (vr cxt)
|
||||
_membership <- createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId (Just (fst memberKeys)) currentTs (vr cxt)
|
||||
liftIO $ setViaGroupLinkUri db groupId connId
|
||||
(,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId
|
||||
where
|
||||
@@ -889,16 +896,16 @@ createGroupViaLink'
|
||||
[sql|
|
||||
INSERT INTO group_members
|
||||
( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (groupId, indexInGroup, memberId, memberRole, GCHostMember, GSMemAccepted, Binary B.empty, fromInvitedBy userContactId IBUnknown)
|
||||
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
|
||||
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, fromMemberPubKey_, currentTs, currentTs)
|
||||
)
|
||||
insertedRowId db
|
||||
|
||||
createGroup_ :: DB.Connection -> UserId -> GroupProfile -> Maybe (CreatedLinkContact, Maybe SharedMsgId) -> Maybe BusinessChatInfo -> Bool -> Maybe RelayStatus -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO (GroupId, Text)
|
||||
createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus publicMemberCount_ currentTs = ExceptT $ do
|
||||
createGroup_ :: DB.Connection -> UserId -> GroupProfile -> Maybe (CreatedLinkContact, Maybe SharedMsgId) -> Maybe BusinessChatInfo -> Bool -> Maybe RelayStatus -> Maybe Int64 -> Maybe C.PrivateKeyEd25519 -> UTCTime -> ExceptT StoreError IO (GroupId, Text)
|
||||
createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus publicMemberCount_ memberPrivKey_ currentTs = ExceptT $ do
|
||||
let GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission} = groupProfile
|
||||
(groupType_, groupLink_, publicGroupId_) = case publicGroup of
|
||||
Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
|
||||
@@ -924,10 +931,10 @@ createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus p
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_display_name, user_id, enable_ntfs,
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, conn_full_link_to_connect, conn_short_link_to_connect, welcome_shared_msg_id,
|
||||
business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count, member_priv_key)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((profileId, localDisplayName, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. toPreparedGroupRow prepared :. businessChatInfoRow business :. (BI useRelays, relayOwnStatus, publicMemberCount_))
|
||||
((profileId, localDisplayName, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. toPreparedGroupRow prepared :. businessChatInfoRow business :. (BI useRelays, relayOwnStatus, publicMemberCount_, memberPrivKey_))
|
||||
groupId <- insertedRowId db
|
||||
pure (groupId, localDisplayName)
|
||||
|
||||
@@ -1688,6 +1695,17 @@ setGroupMemberKeyRole db GroupMember {groupMemberId} pubKey role = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE group_members SET member_pub_key = ?, member_role = ?, updated_at = ? WHERE group_member_id = ?" (pubKey, role, currentTs, groupMemberId)
|
||||
|
||||
setUserMemberKey :: DB.Connection -> GroupId -> GroupMemberId -> C.PrivateKeyEd25519 -> IO ()
|
||||
setUserMemberKey db groupId membershipId memberPrivKey = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE groups SET member_priv_key = ?, updated_at = ? WHERE group_id = ?" (memberPrivKey, currentTs, groupId)
|
||||
DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (C.publicKey memberPrivKey, currentTs, membershipId)
|
||||
|
||||
setMemberPubKey :: DB.Connection -> GroupMemberId -> C.PublicKeyEd25519 -> IO ()
|
||||
setMemberPubKey db groupMemberId pubKey = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (pubKey, currentTs, groupMemberId)
|
||||
|
||||
setGroupMemberVerified :: DB.Connection -> User -> GroupMemberId -> Maybe Text -> IO ()
|
||||
setGroupMemberVerified db User {userId} groupMemberId code = do
|
||||
updatedAt <- getCurrentTime
|
||||
@@ -1896,7 +1914,7 @@ createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMemb
|
||||
groupPreferences = Nothing,
|
||||
memberAdmission = Nothing
|
||||
}
|
||||
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing currentTs
|
||||
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing Nothing currentTs
|
||||
-- Store relay request data for recovery
|
||||
liftIO $ setRelayRequestData_ groupId currentTs
|
||||
ownerMemberId <- insertOwner_ currentTs groupId
|
||||
@@ -2151,6 +2169,7 @@ createBusinessRequestGroup
|
||||
pure (groupInfo, clientMember)
|
||||
where
|
||||
insertGroup_ currentTs = do
|
||||
(memberPubKey, memberPrivKey) <- atomically $ C.generateKeyPair gVar
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
@@ -2163,14 +2182,13 @@ createBusinessRequestGroup
|
||||
[sql|
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_display_name, user_id, enable_ntfs,
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat)
|
||||
VALUES (?,?,?,?,?,?,?,?,?)
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, member_priv_key)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(groupProfileId, ldn, userId, BI True, currentTs, currentTs, currentTs, currentTs, BCCustomer)
|
||||
(groupProfileId, ldn, userId, BI True, currentTs, currentTs, currentTs, currentTs, BCCustomer, memberPrivKey)
|
||||
groupId <- liftIO $ insertedRowId db
|
||||
memberId <- liftIO $ encodedRandomBytes gVar 12
|
||||
-- TODO [member keys] we could support member keys in business groups to allow binding agreements (though identity keys would be better for it.
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing Nothing currentTs (vr cxt)
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing (Just memberPubKey) currentTs (vr cxt)
|
||||
pure (groupId, membership)
|
||||
VersionRange minV maxV = cReqChatVRange
|
||||
insertClientMember_ currentTs groupId membership =
|
||||
|
||||
@@ -115,8 +115,8 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
|
||||
Query:
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_display_name, inv_queue_info, user_id, enable_ntfs,
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, business_member_id, customer_member_id)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, member_priv_key, business_chat, business_member_id, customer_member_id)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|
||||
Plan:
|
||||
|
||||
@@ -288,8 +288,8 @@ SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
|
||||
Query:
|
||||
INSERT INTO group_members
|
||||
( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|
||||
Plan:
|
||||
SEARCH rcv_roster_transfers USING COVERING INDEX idx_rcv_roster_transfers_from_member_id (from_member_id=?)
|
||||
@@ -395,8 +395,8 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
|
||||
Query:
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_display_name, user_id, enable_ntfs,
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat)
|
||||
VALUES (?,?,?,?,?,?,?,?,?)
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, member_priv_key)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?)
|
||||
|
||||
Plan:
|
||||
|
||||
@@ -1312,8 +1312,8 @@ Query:
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_display_name, user_id, enable_ntfs,
|
||||
created_at, updated_at, chat_ts, user_member_profile_sent_at, conn_full_link_to_connect, conn_short_link_to_connect, welcome_shared_msg_id,
|
||||
business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count, member_priv_key)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|
||||
Plan:
|
||||
|
||||
|
||||
@@ -733,10 +733,12 @@ toPublicGroupAccess (groupWebPage, groupDomain_, domainWebPage_, allowEmbedding_
|
||||
allowEmbedding = maybe False unBI allowEmbedding_
|
||||
|
||||
toGroupKeys :: Maybe B64UrlByteString -> GroupKeysRow -> Maybe GroupKeys
|
||||
toGroupKeys (Just publicGroupId) (rootPrivKey_, rootPubKey_, Just memberPrivKey) =
|
||||
(\grk -> GroupKeys {publicGroupId, groupRootKey = grk, memberPrivKey})
|
||||
<$> (GRKPrivate <$> rootPrivKey_ <|> GRKPublic <$> rootPubKey_)
|
||||
toGroupKeys _ _ = Nothing
|
||||
toGroupKeys publicGroupId_ (rootPrivKey, rootPubKey, memberPrivKey) =
|
||||
let publicGroupKeys = case (publicGroupId_, GRKPrivate <$> rootPrivKey <|> GRKPublic <$> rootPubKey) of
|
||||
(Just publicGroupId, Just groupRootKey) -> Just $ Just PublicGroupKeys {publicGroupId, groupRootKey}
|
||||
(Nothing, Nothing) -> Just Nothing
|
||||
_ -> Nothing -- invalid state, in which case messages won't be signed even if memberPrivKey is present
|
||||
in GroupKeys <$> publicGroupKeys <*> memberPrivKey
|
||||
|
||||
toGroupMember :: UTCTime -> Int64 -> GroupMemberRow -> GroupMember
|
||||
toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, BI showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. profileRow :. (createdAt, updatedAt) :. (supportChatTs_, supportChatUnread, supportChatMemberAttention, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) =
|
||||
|
||||
@@ -80,7 +80,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
|
||||
CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
|
||||
CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
|
||||
CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
|
||||
CRGroupDeletedUser u g _ -> whenCurrUser cc u $ unsetActiveGroup ct g
|
||||
CRGroupDeletedUser u g _ _ -> whenCurrUser cc u $ unsetActiveGroup ct g
|
||||
CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
|
||||
CRCmdOk _ -> case cmd of
|
||||
Right APIDeleteUser {} -> setActive ct ""
|
||||
|
||||
@@ -480,12 +480,17 @@ groupRootPubKey (GRKPrivate pk) = C.publicKey pk
|
||||
groupRootPubKey (GRKPublic pk) = pk
|
||||
|
||||
data GroupKeys = GroupKeys
|
||||
{ publicGroupId :: B64UrlByteString,
|
||||
groupRootKey :: GroupRootKey,
|
||||
{ publicGroupKeys :: Maybe PublicGroupKeys,
|
||||
memberPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data PublicGroupKeys = PublicGroupKeys
|
||||
{ publicGroupId :: B64UrlByteString,
|
||||
groupRootKey :: GroupRootKey
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data GroupInfo = GroupInfo
|
||||
{ groupId :: GroupId,
|
||||
useRelays :: BoolDef,
|
||||
@@ -943,6 +948,7 @@ instance ToJSON GroupLinkId where
|
||||
|
||||
data GroupInvitation = GroupInvitation
|
||||
{ fromMember :: MemberIdRole,
|
||||
fromMemberKey :: Maybe MemberKey,
|
||||
invitedMember :: MemberIdRole,
|
||||
connRequest :: ConnReqInvitation,
|
||||
groupProfile :: GroupProfile,
|
||||
@@ -955,6 +961,7 @@ data GroupInvitation = GroupInvitation
|
||||
data GroupLinkInvitation = GroupLinkInvitation
|
||||
{ fromMember :: MemberIdRole,
|
||||
fromMemberName :: ContactName,
|
||||
fromMemberKey :: Maybe MemberKey,
|
||||
invitedMember :: MemberIdRole,
|
||||
groupProfile :: GroupProfile,
|
||||
accepted :: Maybe GroupAcceptance,
|
||||
@@ -2336,6 +2343,8 @@ instance FromJSON GroupSummary where
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GRK") ''GroupRootKey)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''PublicGroupKeys)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''GroupKeys)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''GroupInfo)
|
||||
|
||||
@@ -241,7 +241,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
|
||||
"use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group (also clears the rejection)"
|
||||
]
|
||||
| otherwise -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
|
||||
CRGroupDeletedUser u g signed -> ttyUser u [ttyGroup' g <> ": you deleted the group" <> signedStr signed]
|
||||
CRGroupDeletedUser u g signed local -> ttyUser u [ttyGroup' g <> (if local then ": you deleted your local copy of the group" else ": you deleted the group" <> signedStr signed)]
|
||||
CRForwardPlan u count itemIds fc -> ttyUser u $ viewForwardPlan count itemIds fc
|
||||
CRChatMsgContent u mc -> ttyUser u $ ttyMsgContent mc <> viewMsgTestInfo testView mc
|
||||
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
|
||||
|
||||
Reference in New Issue
Block a user