dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-07-12 05:18:57 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge origin/master into sh/namespace

Browse Source 
The names (simplex_name / RSLV) feature and master's badge feature both
extended the contact/group profile row layer. Resolution keeps both, with
simplex_name ordered last (chronological - it is the newer column):
- Profile/LocalProfile gain badge + simplex_name; simplex_name last in the
  data types, record builds, schema, and SQL row types/SELECTs/INSERTs
- SQL row types, SELECTs and INSERT/UPDATE lists carry both badge_* and
  simplex_name columns (simplex_name after badge)
- migration lists ordered by date (master 0601/0602 before names 0603+)
- SQLite chat_schema.sql regenerated; Postgres chat_schema.sql hand-merged

Verified: lib + test suite build; SchemaDump, Operators, Protocol and
direct/group profile round-trip tests pass.
This commit is contained in:
shum
2026-06-23 11:05:27 +00:00
parent e08367dc9b 514bfc8519
commit e9656d0b18
191 changed files with 11177 additions and 1653 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Library/Commands.hs
+205 -109
View File
@@ -55,6 +55,7 @@ import Data.Type.Equality
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as V4
import Simplex.Chat.Library.Subscriber
import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..))
@@ -89,6 +90,7 @@ import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (liftIOEither, zipWith3')
import qualified Simplex.Chat.Util as U
import Simplex.Chat.Web (webPreviewWorker)
import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, maxFileSizeHard)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
@@ -200,6 +202,7 @@ startChatController mainApp enableSndFiles = do
startCleanupManager
void $ forkIO $ mapM_ startExpireCIs users
startRelayChecks users
startWebPreview users
else when enableSndFiles $ startXFTP xftpStartSndWorkers
pure a1
startXFTP startWorkers = do
@@ -231,6 +234,20 @@ startChatController mainApp enableSndFiles = do
a <- Just <$> async (void $ runExceptT $ runRelayGroupLinkChecks relayUser)
atomically $ writeTVar relayAsync a
_ -> pure ()
startWebPreview users = do
let relayUsers = filter (\User {userChatRelay} -> isTrue userChatRelay) users
ChatConfig {webPreviewConfig = cfg_} <- asks config
case (relayUsers, cfg_) of
(_ : _, Just cfg) -> do
wps_ <- asks webPreviewState
forM_ wps_ $ \WebPreviewState {webPreviewWorkerAsync} ->
readTVarIO webPreviewWorkerAsync >>= \case
Nothing -> do
cc <- ask
a <- Just <$> async (liftIO $ webPreviewWorker cfg cc relayUsers)
atomically $ writeTVar webPreviewWorkerAsync a
_ -> pure ()
_ -> pure ()
startExpireCIs user = whenM shouldExpireChats $ do
startExpireCIThread user
setExpireCIFlag user True
@@ -364,16 +381,16 @@ processChatCommand cxt nm = \case
user <- withFastStore $ \db -> do
user <- createUserRecordAt db (AgentUserId auId) (isTrue userChatRelay) service p True ts
mapM_ (setUserServers db user ts) uss
createPresetContactCards db user `catchAllErrors` \_ -> pure ()
createPresetContactCards db cxt user `catchAllErrors` \_ -> pure ()
createNoteFolder db user
pure user
atomically . writeTVar u $ Just user
pure $ CRActiveUser user
where
createPresetContactCards :: DB.Connection -> User -> ExceptT StoreError IO ()
createPresetContactCards db user = do
createContact db user simplexStatusContactProfile
createContact db user simplexTeamContactProfile
createPresetContactCards :: DB.Connection -> StoreCxt -> User -> ExceptT StoreError IO ()
createPresetContactCards db cxt user = do
createContact db cxt user simplexStatusContactProfile
createContact db cxt user simplexTeamContactProfile
chooseServers :: Maybe User -> CM ([UpdatedUserOperatorServers], (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP)))
chooseServers user_ = do
as <- asks randomAgentServers
@@ -652,12 +669,14 @@ processChatCommand cxt nm = \case
_ <- createChatTag db user emoji text
CRChatTags user <$> getUserChatTags db user
APISetChatTags (ChatRef cType chatId scope) tagIds -> withUser $ \user -> case cType of
CTDirect -> withFastStore' $ \db -> do
updateDirectChatTags db chatId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> getUserChatTags db user <*> getDirectChatTags db chatId
CTGroup | isNothing scope -> withFastStore' $ \db -> do
updateGroupChatTags db chatId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> getUserChatTags db user <*> getGroupChatTags db chatId
CTDirect -> withFastStore $ \db -> do
Contact {contactId} <- getContact db cxt user chatId
liftIO $ updateDirectChatTags db contactId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> liftIO (getUserChatTags db user) <*> liftIO (getDirectChatTags db contactId)
CTGroup | isNothing scope -> withFastStore $ \db -> do
GroupInfo {groupId} <- getGroupInfo db cxt user chatId
liftIO $ updateGroupChatTags db groupId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> liftIO (getUserChatTags db user) <*> liftIO (getGroupChatTags db groupId)
_ -> throwCmdError "not supported"
APIDeleteChatTag tagId -> withUser $ \user -> do
withFastStore' $ \db -> deleteChatTag db user tagId
@@ -1270,6 +1289,8 @@ processChatCommand cxt nm = \case
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
withGroupLock "deleteChat group" chatId $ do
deleteCIFiles user filesInfo
-- the roster blob file has no chat item, so it is missed by getGroupFileInfo above
cleanupGroupRosterFile user gInfo
(members, recipients) <- getRecipients gInfo
let doSendDel = memberActive membership && isOwner
msgSigned <-
@@ -1692,8 +1713,11 @@ processChatCommand cxt nm = \case
CRServerOperatorConditions <$> getServerOperators db
APISetChatTTL userId (ChatRef cType chatId scope) newTTL_ ->
withUserId userId $ \user -> checkStoreNotChanged $ withChatLock "setChatTTL" $ do
(oldTTL_, globalTTL, ttlCount) <- withStore' $ \db ->
(,,) <$> getSetChatTTL db <*> getChatItemTTL db user <*> getChatTTLCount db user
(oldTTL_, globalTTL, ttlCount) <- withStore $ \db -> do
oldTTL <- getSetChatTTL db user
globalTTL <- liftIO $ getChatItemTTL db user
ttlCount <- liftIO $ getChatTTLCount db user
pure (oldTTL, globalTTL, ttlCount)
let newTTL = fromMaybe globalTTL newTTL_
oldTTL = fromMaybe globalTTL oldTTL_
when (newTTL > 0 && (newTTL < oldTTL || oldTTL == 0)) $ do
@@ -1702,9 +1726,13 @@ processChatCommand cxt nm = \case
lift $ setChatItemsExpiration user globalTTL ttlCount
ok user
where
getSetChatTTL db = case cType of
CTDirect -> getDirectChatTTL db chatId <* setDirectChatTTL db chatId newTTL_
CTGroup | isNothing scope -> getGroupChatTTL db chatId <* setGroupChatTTL db chatId newTTL_
getSetChatTTL db currentUser = case cType of
CTDirect -> do
Contact {contactId} <- getContact db cxt currentUser chatId
liftIO $ getDirectChatTTL db contactId <* setDirectChatTTL db contactId newTTL_
CTGroup | isNothing scope -> do
GroupInfo {groupId} <- getGroupInfo db cxt currentUser chatId
liftIO $ getGroupChatTTL db groupId <* setGroupChatTTL db groupId newTTL_
_ -> pure Nothing
expireChat user globalTTL = do
currentTs <- liftIO getCurrentTime
@@ -1955,7 +1983,8 @@ processChatCommand cxt nm = \case
-- [incognito] generate profile for connection
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
subMode <- chatReadVar subscriptionMode
let userData = contactShortLinkData (userProfileDirect user incognitoProfile Nothing True) Nothing
linkProfile <- presentUserBadge user incognitoProfile $ userProfileDirect user incognitoProfile Nothing True
let userData = contactShortLinkData linkProfile Nothing
userLinkData = UserInvLinkData userData
(connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation (Just userLinkData) Nothing IKPQOn subMode
ccLink' <- shortenCreatedLink ccLink
@@ -1976,7 +2005,7 @@ processChatCommand cxt nm = \case
updatePCCIncognito db user conn (Just pId) sLnk
pure $ CRConnectionIncognitoUpdated user conn' (Just incognitoProfile)
(ConnNew, Just pId, False) -> do
sLnk <- updatePCCShortLinkData conn $ userProfileDirect user Nothing Nothing True
sLnk <- updatePCCShortLinkData conn =<< presentUserBadge user Nothing (userProfileDirect user Nothing Nothing True)
conn' <- withFastStore' $ \db -> do
deletePCCIncognitoProfile db user pId
updatePCCIncognito db user conn Nothing sLnk
@@ -1995,9 +2024,10 @@ processChatCommand cxt nm = \case
recreateConn user conn@PendingContactConnection {customUserProfileId, connLinkInv} newUser = do
subMode <- chatReadVar subscriptionMode
let short = isJust $ connShortLink' =<< connLinkInv
userLinkData_
| short = Just $ UserInvLinkData $ contactShortLinkData (userProfileDirect newUser Nothing Nothing True) Nothing
| otherwise = Nothing
userLinkData_ <-
if short
then Just . UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing (userProfileDirect newUser Nothing Nothing True)
else pure Nothing
(agConnId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId newUser) True False SCMInvitation userLinkData_ Nothing IKPQOn subMode
ccLink' <- shortenCreatedLink ccLink
conn' <- withFastStore' $ \db -> do
@@ -2022,9 +2052,9 @@ processChatCommand cxt nm = \case
gVar <- asks random
(gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar cxt user groupProfile True ccLink welcomeSharedMsgId False GRMember Nothing Nothing
hostMember <- maybe (throwCmdError "no host member") pure hostMember_
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = CDGroupRcv gInfo Nothing hostMember
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing Nothing
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent) message
@@ -2034,9 +2064,9 @@ processChatCommand cxt nm = \case
pure $ CRNewPreparedChat user $ AChat SCTGroup chat
ACCL _ (CCLink cReq _) -> do
ct <- withStore $ \db -> createPreparedContact db cxt user profile accLink welcomeSharedMsgId Nothing
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = CDDirectRcv ct
createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing
createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing Nothing
cInfo = DirectChat ct
void $ createItem Nothing $ CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ connRequestPQEncryption cReq
void $ createFeatureEnabledItems_ user ct
@@ -2053,11 +2083,11 @@ processChatCommand cxt nm = \case
subRole <- if useRelays then asks $ channelSubscriberRole . config else pure GRMember
gVar <- asks random
(gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar cxt user gp False ccLink welcomeSharedMsgId useRelays subRole publicMemberCount_ Nothing
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = maybe (CDChannelRcv gInfo Nothing) (CDGroupRcv gInfo Nothing) hostMember_
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- forM description $ \descr -> createChatItem user cd True (CIRcvMsgContent $ MCText descr) welcomeSharedMsgId Nothing
aci <- forM description $ \descr -> createChatItem user cd True (CIRcvMsgContent $ MCText descr) welcomeSharedMsgId Nothing Nothing
let chat = case aci of
Just (AChatItem SCTGroup dir _ ci) -> Chat cInfo [CChatItem dir ci] emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci}
_ -> Chat cInfo [] emptyChatStats
@@ -2125,7 +2155,7 @@ processChatCommand cxt nm = \case
-- create changed feature items (connecting incognito sends default preferences, instead of user preferences)
lift . when incognito $ createContactChangedFeatureItems user ct ct'
forM_ msg_ $ \(sharedMsgId, mc) -> do
ci <- createChatItem user (CDDirectSnd ct') False (CISndMsgContent mc) (Just sharedMsgId) Nothing
ci <- createChatItem user (CDDirectSnd ct') False (CISndMsgContent mc) (Just sharedMsgId) Nothing Nothing
toView $ CEvtNewChatItems user [ci]
pure $ CRStartedConnectionToContact user ct' customUserProfile
CVRConnectedContact ct' -> pure $ CRContactAlreadyExists user ct'
@@ -2218,7 +2248,7 @@ processChatCommand cxt nm = \case
liftIO $ setPreparedGroupStartedConnection db groupId
getGroupInfo db cxt user groupId
forM_ msg_ $ \(sharedMsgId, mc) -> do
ci <- createChatItem user (CDGroupSnd gInfo' Nothing) False (CISndMsgContent mc) (Just sharedMsgId) Nothing
ci <- createChatItem user (CDGroupSnd gInfo' Nothing) False (CISndMsgContent mc) (Just sharedMsgId) Nothing Nothing
toView $ CEvtNewChatItems user [ci]
pure $ CRStartedConnectionToGroup user gInfo' customUserProfile []
CVRConnectedContact _ct -> throwChatError $ CEException "contact already exists when connecting to group"
@@ -2274,10 +2304,11 @@ processChatCommand cxt nm = \case
Right _ -> throwError $ ChatErrorStore SEDuplicateContactLink
subMode <- chatReadVar subscriptionMode
-- TODO [relays] relay: add identity, key to link data?
let userData
| isTrue userChatRelay = relayShortLinkData (userProfileDirect user Nothing Nothing True)
| otherwise = contactShortLinkData (userProfileDirect user Nothing Nothing True) Nothing
userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
userData <-
if isTrue userChatRelay
then pure $ relayShortLinkData (userProfileDirect user Nothing Nothing True)
else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing (userProfileDirect user Nothing Nothing True)
let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
(connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) Nothing IKPQOn subMode
ccLink' <- shortenCreatedLink ccLink
let ccLink'' = if isTrue userChatRelay then setShortLinkType CCTRelay ccLink' else ccLink'
@@ -2730,34 +2761,45 @@ processChatCommand cxt nm = \case
-- TODO [relays] possible optimization is to read only required members + relays
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db cxt user groupId
when (selfSelected gInfo) $ throwCmdError "can't change role for self"
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending, anyPrivilegedTarget, finalPrivilegedCount) = selectMembers members
when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && (anyAdmin || newRole >= GRAdmin)) $
throwCmdError "can't change role of multiple members when admins selected, or new role is admin"
when anyPending $ throwCmdError "can't change role of members pending approval"
assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole])
-- in relay groups the roster has a single signer, so only the owner may change moderator/admin roles
when (useRelays' gInfo && (isRosterRole newRole || anyPrivilegedTarget) && memberRole' (membership gInfo) /= GROwner) $
throwCmdError "only the group owner can change moderator and admin roles"
when (useRelays' gInfo && isRosterRole newRole && finalPrivilegedCount > maxGroupRosterSize) $
throwCmdError $ "the number of members, moderators and admins would exceed the limit of " <> show maxGroupRosterSize
(errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g currentMems
let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && (isRosterRole newRole || anyPrivilegedTarget)
rosterVer <- if doBumpRoster then Just <$> reserveRosterVersion gInfo else pure Nothing
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g rosterVer currentMems
forM_ rosterVer $ \v -> broadcastRoster user gInfo v `catchAllErrors` eToView
unless (null acis) $ toView $ CEvtNewChatItems user acis
let errs = errs1 <> errs2
unless (null errs) $ toView $ CEvtChatErrors errs
pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole, msgSigned} -- same order is not guaranteed
where
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
selectMembers = foldr' addMember ([], [], [], GRObserver, False, False)
-- anyPrivilegedTarget: a target currently moderator/admin; finalPrivilegedCount:
-- moderators + admins after the change (targets take newRole, others keep their role).
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool, Bool, Int)
selectMembers = foldr' addMember ([], [], [], GRObserver, False, False, False, 0)
where
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending)
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending, anyPrivTarget, privCount)
| groupMemberId `elem` memberIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
anyPending' = anyPending || memberPending m
in
if
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending')
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending')
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending')
| otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending)
anyPrivTarget' = anyPrivTarget || isRosterRole memberRole
privCount' = if isRosterRole newRole then privCount + 1 else privCount
in if
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending, anyPrivTarget, if isRosterRole memberRole then privCount + 1 else privCount)
changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember])
changeRoleInvitedMems user gInfo memsToChange = do
-- not batched, as we need to send different invitations to different connections anyway
@@ -2772,19 +2814,20 @@ processChatCommand cxt nm = \case
withFastStore' $ \db -> updateGroupMemberRole db user m newRole
pure (m :: GroupMember) {memberRole = newRole}
_ -> throwChatError $ CEGroupCantResendInvitation gInfo cName
changeRoleCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
changeRoleCurrentMems user (Group gInfo members) memsToChange = case L.nonEmpty memsToChange of
changeRoleCurrentMems :: User -> Group -> Maybe VersionRoster -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
changeRoleCurrentMems user (Group gInfo members) rosterVer memsToChange = case L.nonEmpty memsToChange of
Nothing -> pure ([], [], [], False)
Just memsToChange' -> do
let events = L.map (\GroupMember {memberId} -> XGrpMemRole memberId newRole) memsToChange'
let mKey m = if isJust rosterVer then MemberKey <$> memberPubKey m else Nothing
events = L.map (\m@GroupMember {memberId} -> XGrpMemRole memberId newRole (mKey m) rosterVer) memsToChange'
recipients = filter memberCurrent members
(msgs_, _gsr) <- sendGroupMessages user gInfo Nothing False recipients events
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch"
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
pure (errs, changed, acis, signed)
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
@@ -2848,20 +2891,25 @@ processChatCommand cxt nm = \case
withGroupLock "removeMembers" groupId $ do
-- TODO [relays] possible optimization is to read only required members + relays
Group gInfo members <- withFastStore $ \db -> getGroup db cxt user groupId
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin) = selectMembers gmIds members
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin, anyPrivilegedRemoved) = selectMembers gmIds members
gmIds = S.fromList $ L.toList groupMemberIds
memCount = length groupMemberIds
when (count /= memCount) $ throwChatError CEGroupMemberNotFound
when (memCount > 1 && anyAdmin) $ throwCmdError "can't remove multiple members when admins selected"
assertUserGroupRole gInfo $ max GRAdmin maxRole
when (useRelays' gInfo && anyPrivilegedRemoved && memberRole' (membership gInfo) /= GROwner) $
throwCmdError "only the group owner can remove members, moderators and admins"
(errs1, deleted1) <- deleteInvitedMems user invitedMems
let recipients = filter memberCurrent members
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing recipients currentMems
let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && anyPrivilegedRemoved
rosterVer <- if doBumpRoster then Just <$> reserveRosterVersion gInfo else pure Nothing
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing rosterVer recipients currentMems
(errs3, deleted3, acis3, signed3) <-
foldM (\acc m -> deletePendingMember acc user gInfo [m] m) ([], [], [], False) pendingApprvMems
let moderators = filter (\GroupMember {memberRole} -> memberRole >= GRModerator) members
(errs4, deleted4, acis4, signed4) <-
foldM (\acc m -> deletePendingMember acc user gInfo (m : moderators) m) ([], [], [], False) pendingRvwMems
forM_ rosterVer $ \v -> broadcastRoster user gInfo v `catchAllErrors` eToView
let acis = acis2 <> acis3 <> acis4
errs = errs1 <> errs2 <> errs3 <> errs4
deleted = deleted1 <> deleted2 <> deleted3 <> deleted4
@@ -2876,19 +2924,20 @@ processChatCommand cxt nm = \case
unless (null errs) $ toView $ CEvtChatErrors errs
pure $ CRUserDeletedMembers user gInfo' deleted withMessages msgSigned -- same order is not guaranteed
where
selectMembers :: S.Set GroupMemberId -> [GroupMember] -> (Int, [GroupMember], [GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool)
selectMembers gmIds = foldl' addMember (0, [], [], [], [], GRObserver, False)
selectMembers :: S.Set GroupMemberId -> [GroupMember] -> (Int, [GroupMember], [GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
selectMembers gmIds = foldl' addMember (0, [], [], [], [], GRObserver, False, False)
where
addMember acc@(n, invited, pendingApprv, pendingRvw, current, maxRole, anyAdmin) m@GroupMember {groupMemberId, memberStatus, memberRole}
addMember acc@(n, invited, pendingApprv, pendingRvw, current, maxRole, anyAdmin, anyPrivRemoved) m@GroupMember {groupMemberId, memberStatus, memberRole}
| groupMemberId `S.member` gmIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
anyPrivRemoved' = anyPrivRemoved || isRosterRole memberRole
n' = n + 1
in case memberStatus of
GSMemInvited -> (n', m : invited, pendingApprv, pendingRvw, current, maxRole', anyAdmin')
GSMemPendingApproval -> (n', invited, m : pendingApprv, pendingRvw, current, maxRole', anyAdmin')
GSMemPendingReview -> (n', invited, pendingApprv, m : pendingRvw, current, maxRole', anyAdmin')
_ -> (n', invited, pendingApprv, pendingRvw, m : current, maxRole', anyAdmin')
GSMemInvited -> (n', m : invited, pendingApprv, pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
GSMemPendingApproval -> (n', invited, m : pendingApprv, pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
GSMemPendingReview -> (n', invited, pendingApprv, m : pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
_ -> (n', invited, pendingApprv, pendingRvw, m : current, maxRole', anyAdmin', anyPrivRemoved')
| otherwise = acc
deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember])
deleteInvitedMems user memsToDelete = do
@@ -2901,14 +2950,14 @@ processChatCommand cxt nm = \case
deletePendingMember :: ([ChatError], [GroupMember], [AChatItem], Bool) -> User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deletePendingMember (accErrs, accDeleted, accACIs, accSigned) user gInfo recipients m = do
(m', scopeInfo) <- mkMemberSupportChatInfo m
(errs, deleted, acis, signed) <- deleteMemsSend user gInfo (Just scopeInfo) recipients [m']
(errs, deleted, acis, signed) <- deleteMemsSend user gInfo (Just scopeInfo) Nothing recipients [m']
pure (errs <> accErrs, deleted <> accDeleted, acis <> accACIs, accSigned || signed)
deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deleteMemsSend user gInfo chatScopeInfo recipients memsToDelete = case L.nonEmpty memsToDelete of
deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe VersionRoster -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deleteMemsSend user gInfo chatScopeInfo rosterVer recipients memsToDelete = case L.nonEmpty memsToDelete of
Nothing -> pure ([], [], [], False)
Just memsToDelete' -> do
let chatScope = toChatScope <$> chatScopeInfo
events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages) memsToDelete'
events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages rosterVer) memsToDelete'
(msgs_, _gsr) <- sendGroupMessages user gInfo chatScope False recipients events
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
@@ -3050,6 +3099,12 @@ processChatCommand cxt nm = \case
updateGroupProfileByName gName $ \p -> p {description}
ShowGroupDescription gName -> withUser $ \user ->
CRGroupDescription user <$> withFastStore (\db -> getGroupInfoByName db cxt user gName)
SetPublicGroupAccess gName access -> withUser $ \user -> do
gInfo@GroupInfo {groupProfile = p@GroupProfile {publicGroup}} <- withStore $ \db ->
getGroupIdByName db user gName >>= getGroupInfo db cxt user
case publicGroup of
Just pg -> runUpdateGroupProfile user gInfo p {publicGroup = Just pg {publicGroupAccess = Just access}}
Nothing -> throwChatError $ CECommandError "not a public group"
APICreateGroupLink groupId mRole -> withUser $ \user -> withGroupLock "createGroupLink" groupId $ do
gInfo@GroupInfo {groupProfile} <- withFastStore $ \db -> getGroupInfo db cxt user groupId
assertUserGroupRole gInfo GRAdmin
@@ -3102,7 +3157,7 @@ processChatCommand cxt nm = \case
(connId, CCLink cReq _) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation Nothing Nothing IKPQOff subMode
-- [incognito] reuse membership incognito profile
ct <- withFastStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart)
-- TODO not sure it is correct to set connections status here?
pure $ CRNewMemberContact user ct g m
_ -> throwChatError CEGroupMemberNotActive
@@ -3158,7 +3213,7 @@ processChatCommand cxt nm = \case
joinPreparedConn subMode conn
joinPreparedConn subMode conn = do
-- [incognito] send membership incognito profile
let p = userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True
p <- presentUserBadge user (incognitoMembershipProfile gInfo) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True
dm <- encodeConnInfo $ XInfo p
sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode
let newStatus = if sqSecured then ConnSndReady else ConnJoined
@@ -3308,6 +3363,7 @@ processChatCommand cxt nm = \case
fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId
pure $ CRFileTransferStatus user fileStatus
ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile)
AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user
SetBotCommands commands -> withUser $ \user@User {profile} -> do
let LocalProfile {preferences} = profile
prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands}
@@ -3535,7 +3591,7 @@ processChatCommand cxt nm = \case
conn <- withFastStore' $ \db -> createDirectConnection' db userId connId ccLink contactId_ ConnPrepared incognitoProfile subMode chatV pqSup'
joinPreparedConn conn incognitoProfile chatV
joinPreparedConn conn incognitoProfile chatV = do
let profileToSend = userProfileDirect user incognitoProfile Nothing True
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user incognitoProfile Nothing True
dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend
sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode
let newStatus = if sqSecured then ConnSndReady else ConnJoined
@@ -3580,13 +3636,18 @@ processChatCommand cxt nm = \case
where
cReqHash1 = contactCReqHash $ CRContactUri crData {crScheme = SSSimplex}
cReqHash2 = contactCReqHash $ CRContactUri crData {crScheme = simplexChat}
-- relay-group joins (only via connectToRelay) carry the target relay member in preparedEntity_;
-- its memberId binds the join signature so a sibling relay can't replay it
relayMemberId_ = case preparedEntity_ of
Just (PCEGroup gInfo m) | useRelays' gInfo -> Just (memberId' m)
_ -> Nothing
joinPreparedConn' xContactId_ conn@Connection {customUserProfileId} gInfo_ = do
when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection"
-- TODO [relays] member: refactor joinContact and up avoiding parallel ifs, xContactId is not used
xContactId <- mkXContactId xContactId_
localIncognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ PQSupportOn
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn
pure $ CVRSentInvitation conn' incognitoProfile
connect' groupLinkId xContactId_ gInfo_ = do
let inGroup = isJust groupLinkId
@@ -3601,7 +3662,7 @@ processChatCommand cxt nm = \case
subMode <- chatReadVar subscriptionMode
let sLnk' = serverShortLink <$> sLnk
conn <- withFastStore' $ \db -> createConnReqConnection db userId connId preparedEntity_ cReq cReqHash1 sLnk' xContactId incognitoProfile_ groupLinkId subMode chatV pqSup
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ pqSup
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup
pure $ CVRSentInvitation conn' incognitoProfile
connectContactViaAddress :: User -> IncognitoEnabled -> Contact -> CreatedLinkContact -> CM ChatResponse
connectContactViaAddress user@User {userId} incognito ct@Contact {contactId, activeConn} (CCLink cReq shortLink) =
@@ -3616,7 +3677,7 @@ processChatCommand cxt nm = \case
subMode <- chatReadVar subscriptionMode
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
conn <- withFastStore' $ \db -> createConnReqConnection db userId connId (Just $ PCEContact ct) cReq cReqHash shortLink newXContactId (NewIncognito <$> incognitoProfile) Nothing subMode chatV pqSup
void $ joinContact user conn cReq incognitoProfile newXContactId Nothing Nothing Nothing pqSup
void $ joinContact user conn cReq incognitoProfile newXContactId Nothing Nothing Nothing Nothing pqSup
ct' <- withStore $ \db -> getContact db cxt user contactId
pure $ CRSentInvitationToContact user ct' incognitoProfile
Just conn@Connection {connStatus, xContactId = xContactId_, customUserProfileId} -> case connStatus of
@@ -3625,7 +3686,7 @@ processChatCommand cxt nm = \case
xContactId <- mkXContactId xContactId_
localIncognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
void $ joinContact user conn cReq incognitoProfile xContactId Nothing Nothing Nothing PQSupportOn
void $ joinContact user conn cReq incognitoProfile xContactId Nothing Nothing Nothing Nothing PQSupportOn
ct' <- withStore $ \db -> getContact db cxt user contactId
pure $ CRSentInvitationToContact user ct' incognitoProfile
_ -> throwCmdError "contact already has connection"
@@ -3637,13 +3698,14 @@ processChatCommand cxt nm = \case
r <- tryAllErrors $ do
(fd@FixedLinkData {rootKey = relayKey, linkEntityId}, cData) <- getShortLinkConnReq nm user relayLink
relayLinkData_ <- liftIO $ decodeLinkUserData cData
case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) ->
withFastStore $ \db -> updateRelayMemberData db user relayMember (MemberId entityId) (MemberKey relayKey) p
relayMemberId <- case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) -> do
withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) p
pure $ MemberId entityId
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
let cReq = linkConnReq fd
relayLinkToConnect = CCLink cReq (Just relayLink)
void $ connectViaContact user (Just $ PCEGroup gInfo relayMember) (incognitoMembership gInfo) relayLinkToConnect Nothing Nothing
void $ connectViaContact user (Just $ PCEGroup gInfo (relayMember {memberId = relayMemberId})) (incognitoMembership gInfo) relayLinkToConnect Nothing Nothing
relayMember' <- withFastStore $ \db -> getGroupMember db cxt user (groupId' gInfo) (groupMemberId' relayMember)
pure (relayLink, relayMember', r)
syncSubscriberRelays :: User -> GroupInfo -> [ShortLinkContact] -> CM ()
@@ -3679,23 +3741,20 @@ processChatCommand cxt nm = \case
pure (connId, chatV)
mkXContactId :: Maybe XContactId -> CM XContactId
mkXContactId = maybe (XContactId <$> drgRandomBytes 16) pure
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfo) -> PQSupport -> CM Connection
joinContact user conn@Connection {connChatVersion = chatV} cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ pqSup = do
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfo) -> Maybe MemberId -> PQSupport -> CM Connection
joinContact user conn@Connection {connChatVersion = chatV} cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup = do
-- gInfo_ is Maybe (Maybe GroupInfo), where Just Nothing means "some unknown group", e.g. when joining via link without profile
let profileToSend = case gInfo_ of
Just gInfo_' ->
let allowSimplexLinks = maybe True (groupFeatureUserAllowed SGFSimplexLinks) gInfo_'
in userProfileInGroup' user allowSimplexLinks incognitoProfile
Nothing -> userProfileDirect user incognitoProfile Nothing True
chatEvent <- case gInfo_ of
Just (Just gInfo) | useRelays' gInfo -> do
let GroupInfo {membership = GroupMember {memberId}} = gInfo
memberPubKey <- case groupKeys gInfo of
Just GroupKeys {memberPrivKey} -> pure $ C.publicKey memberPrivKey
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
pure $ XMember profileToSend memberId (MemberKey memberPubKey)
_ -> pure $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
dm <- encodeConnInfoPQ pqSup chatV chatEvent
profileToSend <-
presentUserBadge user incognitoProfile $ case gInfo_ of
Just gInfo_' ->
let allowSimplexLinks = maybe True groupUserAllowSimplexLinks gInfo_'
in userProfileInGroup' user allowSimplexLinks 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 chatV $ XContact profileToSend (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
@@ -3703,12 +3762,12 @@ processChatCommand cxt nm = \case
contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
cId == Just contactId && s /= GSMemRejected && s /= GSMemRemoved && s /= GSMemLeft
checkSndFile :: CryptoFile -> CM Integer
checkSndFile (CryptoFile f cfArgs) = do
checkSndFile :: Maybe LocalBadge -> CryptoFile -> CM Integer
checkSndFile sndBadge (CryptoFile f cfArgs) = do
fsFilePath <- lift $ toFSFilePath f
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs
when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f
when (fromInteger fileSize > maxXFTPFileSize sndBadge) $ throwChatError $ CEFileSize f
pure fileSize
updateProfile :: User -> Profile -> CM ChatResponse
updateProfile user p' = updateProfile_ user p' True $ withFastStore $ \db -> updateUserProfile db user p'
@@ -3738,7 +3797,7 @@ processChatCommand cxt nm = \case
case changedCts_ of
Nothing -> pure $ UserProfileUpdateSummary 0 0 []
Just changedCts -> do
let idsEvts = L.map ctSndEvent changedCts
idsEvts <- mapM ctSndEvent changedCts
msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts
(errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_
unless (null errs) $ toView $ CEvtChatErrors errs
@@ -3762,8 +3821,11 @@ processChatCommand cxt nm = \case
mergedProfile = userProfileDirect user Nothing (Just ct) False
ct' = updateMergedPreferences user' ct
mergedProfile' = userProfileDirect user' Nothing (Just ct') False
ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, Nothing, XInfo mergedProfile')
-- non-incognito (filtered above), so the user's badge is presented; a profile update keeps the badge instead of clearing it
ctSndEvent :: ChangedProfileContact -> CM (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = do
p <- presentUserBadge user' Nothing mergedProfile'
pure (ConnectionId connId, Nothing, XInfo p)
ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq
ctMsgReq ChangedProfileContact {conn} =
fmap $ \SndMessage {msgId, msgBody} ->
@@ -3771,9 +3833,9 @@ processChatCommand cxt nm = \case
setMyAddressData :: User -> UserContactLink -> CM UserContactLink
setMyAddressData user@User {userChatRelay} ucl@UserContactLink {userContactLinkId, connLinkContact = CCLink connFullLink _sLnk_, addressSettings} = do
conn <- withFastStore $ \db -> getUserAddressConnection db cxt user
let shortLinkProfile = userProfileDirect user Nothing Nothing True
-- TODO [short links] do not save address to server if data did not change, spinners, error handling
userData
shortLinkProfile <- presentUserBadge user Nothing $ userProfileDirect user Nothing Nothing True
-- TODO [short links] do not save address to server if data did not change, spinners, error handling
let userData
| isTrue userChatRelay = relayShortLinkData shortLinkProfile
| otherwise = contactShortLinkData shortLinkProfile $ Just addressSettings
userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
@@ -3794,7 +3856,8 @@ processChatCommand cxt nm = \case
mergedProfile' = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') False
when (mergedProfile' /= mergedProfile) $
withContactLock "updateContactPrefs" (contactId' ct) $ do
void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchAllErrors` eToView
p <- presentUserBadge user incognitoProfile mergedProfile'
void (sendDirectContactMessage user ct' $ XInfo p) `catchAllErrors` eToView
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
pure $ CRContactPrefsUpdated user ct ct'
runUpdateGroupProfile :: User -> GroupInfo -> GroupProfile -> CM ChatResponse
@@ -3993,10 +4056,10 @@ processChatCommand cxt nm = \case
conn <- createRelayConnection db cxt user (groupMemberId' relayMember) connId ConnPrepared chatV subMode
pure (relayMember, conn, groupRelay)
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo
membershipProfile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership
allowSimplexLinks = groupUserAllowSimplexLinks gInfo
GroupMember {memberId = relayMemberId} = relayMember
relayInv = GroupRelayInvitation {
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership
let relayInv = GroupRelayInvitation {
fromMember = MemberIdRole userMemberId userRole,
fromMemberProfile = membershipProfile,
relayMemberId,
@@ -4084,7 +4147,7 @@ processChatCommand cxt nm = \case
Just r -> pure r
Nothing -> do
(FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l'
contactSLinkData_ <- liftIO $ decodeLinkUserData cData
contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData)
let ov = verifyLinkOwner rootKey [] l sig_
invitationReqAndPlan cReq (Just l') contactSLinkData_ ov
where
@@ -4111,7 +4174,7 @@ processChatCommand cxt nm = \case
withFastStore' (\db -> getContactWithoutConnViaShortAddress db cxt user l') >>= \case
Just ct' | not (contactDeleted ct') -> pure (con cReq, CPContactAddress (CAPContactViaAddress ct'))
_ -> do
contactSLinkData_ <- liftIO $ decodeLinkUserData cData
contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData)
let ContactLinkData _ UserContactData {owners} = cData
ov = verifyLinkOwner rootKey owners l' sig_
plan <- contactRequestPlan user cReq contactSLinkData_ ov
@@ -4313,7 +4376,7 @@ processChatCommand cxt nm = \case
contactShortLinkData p settings =
let msg = autoReply =<< settings
business = maybe False businessAddress settings
contactData = ContactShortLinkData p msg business
contactData = ContactShortLinkData p msg business Nothing
in encodeShortLinkData contactData
relayShortLinkData :: Profile -> UserLinkData
relayShortLinkData Profile {displayName, fullName, shortDescr, image} =
@@ -4377,7 +4440,8 @@ processChatCommand cxt nm = \case
setupSndFileTransfers =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _, _) -> case file_ of
Just file -> do
fileSize <- checkSndFile file
let User {profile = LocalProfile {localBadge}} = user
fileSize <- checkSndFile (if contactConnIncognito ct then Nothing else localBadge) file
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct
pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing)
@@ -4458,7 +4522,8 @@ processChatCommand cxt nm = \case
setupSndFileTransfers n =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _, _) -> case file_ of
Just file -> do
fileSize <- checkSndFile file
let User {profile = LocalProfile {localBadge}} = user
fileSize <- checkSndFile (if incognitoMembership gInfo then Nothing else localBadge) file
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup gInfo recipients
pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing)
@@ -4830,6 +4895,28 @@ createContactsSndFeatureItems user cts =
CUPContact {preference} -> preference
CUPUser {preference} -> preference
-- attach an issued badge credential to the user's own profile and present it to all current contacts.
-- the credential is stored once; every profile send generates a fresh single-use proof (see presentUserBadge).
addUserBadge :: User -> BadgeCredential -> CM ()
addUserBadge user cred@(BadgeCredential keyIdx _ _ info) = do
keys <- asks $ badgePublicKeys . config
key <- maybe (throwCmdError "unknown badge key index") pure $ M.lookup keyIdx keys
verified <- liftIO $ verifyCredential key cred
unless verified $ throwCmdError "badge credential does not verify against configured key"
now <- liftIO getCurrentTime
user' <- withFastStore' $ \db -> setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info)))
asks currentUser >>= atomically . (`writeTVar` Just user')
cxt <- asks $ mkStoreCxt . config
contacts <- withFastStore' $ \db -> getUserContacts db cxt user'
withChatLock "addUserBadge" $ forM_ contacts $ \ct ->
case contactSendConn_ ct of
Right conn
| 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
_ -> pure ()
assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM ()
assertDirectAllowed user dir ct event =
unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $
@@ -5026,10 +5113,11 @@ runRelayGroupLinkChecks user = do
then do
-- TODO [relays] emit event to UI when relay own status promoted to RSActive
-- CEvtGroupRelayUpdated requires GroupRelay (owner-side), not available on relay side
void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSAccepted RSActive
void $ withStore' $ \db -> updateRelayOwnStatus_ db gInfo RSActive
else void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSActive RSInactive
_ -> pure ()
_ -> pure ()
sendRelayCapIfNeeded user gInfo
checkRelayInactiveGroups = do
cxt <- chatStoreCxt
ttl <- asks (relayInactiveTTL . config)
@@ -5353,6 +5441,7 @@ chatCommandP =
"/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP),
("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayNameP <* A.space <*> groupProfile),
("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayNameP),
"/public group access " *> char_ '#' *> (SetPublicGroupAccess <$> displayNameP <*> publicGroupAccessP),
"/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayNameP <*> optional (A.space *> msgTextP)),
"/set welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayNameP <* A.space <*> (Just <$> msgTextP)),
"/delete welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayNameP <*> pure Nothing),
@@ -5441,6 +5530,7 @@ chatCommandP =
"/show profile image" $> ShowProfileImage,
("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNameDescr),
("/profile" <|> "/p") $> ShowProfile,
"/badge add " *> (AddBadge <$> jsonP),
"/set bot commands " *> (SetBotCommands <$> botCommandsP),
"/delete bot commands" $> SetBotCommands [],
"/set voice #" *> (SetGroupFeatureRole (AGFR SGFVoice) <$> displayNameP <*> _strP <*> optional memberRole),
@@ -5559,6 +5649,12 @@ chatCommandP =
clearOverrides <- (" clear_overrides=" *> onOffP) <|> pure False
pure UserMsgReceiptSettings {enable, clearOverrides}
onOffP = ("on" $> True) <|> ("off" $> False)
publicGroupAccessP = do
groupWebPage <- optional (" web=" *> (safeDecodeUtf8 <$> A.takeTill A.isSpace))
groupDomain <- optional (" domain=" *> (safeDecodeUtf8 <$> A.takeTill A.isSpace))
domainWebPage <- (" domain_page=" *> onOffP) <|> pure False
allowEmbedding <- (" embed=" *> onOffP) <|> pure False
pure PublicGroupAccess {groupWebPage, groupDomain, domainWebPage, allowEmbedding}
profileNameDescr = (,) <$> displayNameP <*> shortDescrP
-- 'Help with bot':'link <ID>','Menu of commands':[...]
botCommandsP :: Parser [ChatBotCommand]
@@ -5579,7 +5675,7 @@ chatCommandP =
newUserP relay = do
(cName, shortDescr) <- profileNameDescr
service <- (" service=" *> onOffP) <|> pure False
let profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Nothing, preferences = Nothing}
let profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, simplexName = Nothing}
pure NewUser {profile, pastTimestamp = False, userChatRelay = BoolDef relay, clientService = BoolDef service}
newBotUserP = do
files_ <- optional $ "files=" *> onOffP <* A.space
@@ -5588,7 +5684,7 @@ chatCommandP =
let preferences = case files_ of
Just True -> Nothing
_ -> Just (emptyChatPrefs :: Preferences) {files = Just FilesPreference {allow = FANo}}
profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Just CPTBot, preferences}
profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences, badge = Nothing, simplexName = Nothing}
pure NewUser {profile, pastTimestamp = False, userChatRelay = BoolDef False, clientService = BoolDef service}
jsonP :: J.FromJSON a => Parser a
jsonP = J.eitherDecodeStrict' <$?> A.takeByteString
src/Simplex/Chat/Library/Internal.hs
+299 -63
View File
@@ -53,12 +53,13 @@ import Data.Text.Encoding (encodeUtf8)
import Data.Time (addUTCTime)
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime)
import Simplex.Chat.Badges (BadgeCredential (..), BadgePresHeader (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), badgeProof, mkBadgeStatus, verifyBadge)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Files
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (BatchMode (..), MsgBatch (..), batchMessages, encodeBinaryBatch, encodeFwdElement)
import Simplex.Chat.Messages.Batch (BatchMode (..), MsgBatch (..), batchMessages, encodeBatchElement, encodeBinaryBatch, encodeFwdElement)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Operators
@@ -79,6 +80,7 @@ import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (encryptFile, shuffle)
import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription)
import qualified Simplex.FileTransfer.Description as FD
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
import Simplex.Messaging.Agent
@@ -89,7 +91,7 @@ import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..))
import Simplex.Messaging.Compression (compressionLevel)
import Simplex.Messaging.Compression (compressionLevel, limitDecompress')
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
@@ -366,7 +368,7 @@ prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Maybe MarkdownList -> Bool
prohibitedSimplexLinks gInfo m mc ft =
not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo)
&& (isChatLink mc || maybe False (any ftIsSimplexLink) ft)
&& (isChatLink mc || maybe False (any ftIsSimplexLink) ft || hasObfuscatedSimplexLink (msgContentText mc))
where
isChatLink = \case
MCChat {} -> True
@@ -699,7 +701,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
ci <- xftpAcceptRcvFT db cxt user fileId filePath userApproved
rfd <- getRcvFileDescrByRcvFileId db fileId
pure (ci, rfd)
receiveViaCompleteFD user fileId rfd userApproved cryptoArgs
receiveViaCompleteFD user fileId rfd fileSize userApproved cryptoArgs
pure ci
(Nothing, Just _fileConnReq) -> throwChatError $ CEException "accepting file via a separate connection is deprecated"
-- group & direct file protocol
@@ -741,10 +743,17 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|| (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks)
)
receiveViaCompleteFD :: User -> FileTransferId -> RcvFileDescr -> Bool -> Maybe CryptoFileArgs -> CM ()
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} userApprovedRelays cfArgs =
receiveViaCompleteFD :: User -> FileTransferId -> RcvFileDescr -> Integer -> Bool -> Maybe CryptoFileArgs -> CM ()
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} expectedFileSize userApprovedRelays cfArgs =
when fileDescrComplete $ do
rd <- parseFileDescription fileDescrText
let FD.ValidFileDescription FD.FileDescription {size = FD.FileSize encSize, redirect} = rd
redirectSize = maybe 0 (\FD.RedirectFileInfo {size = FD.FileSize s} -> toInteger s) redirect
-- for a redirect, encSize is the description blob and redirectSize the final file; take the larger
rcvSize = max (toInteger encSize) redirectSize
-- 10 MB margin: encryption and chunk-size rounding make the transfer larger than the advertised size
maxRcvSize = min expectedFileSize (toInteger FD.maxFileSizeHard) + toInteger (FD.mb 10 :: Int64)
when (rcvSize > maxRcvSize) $ throwChatError $ CEFileRcvChunk "declared file size exceeds the file invitation size"
if userApprovedRelays
then receive' rd True
else do
@@ -904,7 +913,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
Just conn@Connection {customUserProfileId} -> do
incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
pure (ct, conn, ExistingIncognito <$> incognitoProfile)
let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend
(ct,conn,) <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode)
@@ -916,7 +925,7 @@ acceptContactRequestAsync
UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId, pqSupport = cReqPQSup}
incognitoProfile = do
subMode <- chatReadVar subscriptionMode
let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
(cmdId, acId) <- agentAcceptContactAsync user True cReqInvId (XInfo profileToSend) subMode cReqPQSup chatV
@@ -927,9 +936,9 @@ acceptContactRequestAsync
liftIO $ setCommandConnId db user cmdId connId
getContact db cxt user contactId
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> CM GroupMember
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
acceptGroupJoinRequestAsync
user
user@User {userId}
uclId
gInfo@GroupInfo {groupProfile, membership, businessChat}
cReqInvId
@@ -941,11 +950,22 @@ acceptGroupJoinRequestAsync
gAccepted
gLinkMemRole
incognitoProfile
memberKey_ = do
memberKey_
existingMem_ = do
gVar <- asks random
let initialStatus = acceptanceToStatus (memberAdmission groupProfile) gAccepted
(groupMemberId, memberId) <- withStore $ \db ->
createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_
-- a roster-established privileged member attaches a connection to its existing record (keeping
-- owner-authoritative role + key); everyone else is created fresh with the group-link role
cxt <- chatStoreCxt
(groupMemberId, memberId) <- case existingMem_ of
Just m -> do
-- refresh the hash placeholder name from the authenticated join profile; role + key stay roster-authoritative
withStore $ \db -> do
liftIO $ updateGroupMemberStatus db userId m initialStatus
void $ updateMemberProfile db cxt user m cReqProfile
pure (groupMemberId' m, memberId' m)
Nothing -> withStore $ \db ->
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_
let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo
let Profile {displayName} = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile)
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
@@ -961,7 +981,6 @@ acceptGroupJoinRequestAsync
groupSize = Just currentMemCount
}
subMode <- chatReadVar subscriptionMode
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
withStore $ \db -> do
@@ -979,8 +998,9 @@ acceptGroupJoinSendRejectAsync
cReqXContactId_
rejectionReason = do
gVar <- asks random
cxt <- chatStoreCxt
(groupMemberId, memberId) <- withStore $ \db ->
createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ Nothing Nothing GRObserver GSMemRejected Nothing
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ Nothing Nothing GRObserver GSMemRejected Nothing
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
msg =
XGrpLinkReject $
@@ -991,7 +1011,6 @@ acceptGroupJoinSendRejectAsync
rejectionReason
}
subMode <- chatReadVar subscriptionMode
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
connIds <- agentAcceptContactAsync user False cReqInvId msg subMode PQSupportOff chatV
withStore $ \db -> do
@@ -1045,8 +1064,9 @@ acceptRelayJoinRequestAsync
cReqInvId
cReqChatVRange
relayLink = do
-- TODO [channel web] derive RelayCapabilities from relay config (RelayWebOptions)
let msg = XGrpRelayAcpt relayLink defaultRelayCapabilities
ChatConfig {webPreviewConfig} <- asks config
let webDomain_ = (\WebPreviewConfig {webDomain} -> webDomain) <$> webPreviewConfig
msg = XGrpRelayAcpt relayLink RelayCapabilities {webDomain = webDomain_}
subMode <- chatReadVar subscriptionMode
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
@@ -1160,24 +1180,50 @@ memberIntroEvt gInfo reMember =
mRestrictions = memberRestrictions reMember
in XGrpMemIntro mInfo mRestrictions
-- Forward the saved owner-signed roster verbatim (reusing its signed shared_msg_id), then the
-- blob chunks, so the recipient verifies the owner signature.
serveRoster :: User -> GroupInfo -> GroupMember -> CM ()
serveRoster user gInfo member =
when (member `supportsVersion` groupRosterVersion) $ do
cxt <- chatStoreCxt
withStore' (\db -> getGroupRoster db gInfo) >>= \case
Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}, blob_) ->
case J.eitherDecodeStrict' signedBody :: Either String (ChatMessage 'Json) of
Left e -> logError $ "serveRoster: cannot decode saved roster message: " <> tshow e
Right chatMsg@ChatMessage {msgId} ->
withStore' (\db -> runExceptT $ getGroupMemberById db cxt user ownerGMId) >>= \case
Right owner -> do
let fwd = GrpMsgForward {fwdSender = FwdMember (memberId' owner) (memberShortenedName owner), fwdBrokerTs = brokerTs}
sendFwdMemberMessage member fwd (VMSigned MSSVerified sm chatMsg)
forM_ ((,) <$> msgId <*> blob_) $ \(sid, blob) ->
sendInlineBlobChunks user gInfo [member] sid blob
Left e -> logError $ "serveRoster: roster owner not found: " <> tshow e
Nothing -> pure ()
-- Used in groups with relays to introduce moderators and above to a new member,
-- and to announce the new member to moderators and above.
-- This doesn't create introduction records in db, compared to above methods.
introduceInChannel :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceInChannel _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
(owners, adminsMods) <- withStore' $ \db ->
(,) <$> getGroupOwners db cxt user gInfo <*> getGroupAdminsMods db cxt user gInfo
let modMs = owners <> adminsMods
void $ sendGroupMessage' user gInfo modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
withStore' $ \db ->
setMemberVectorNewRelations db subscriber [(indexInGroup m, (IDSubjectIntroduced, MRIntroduced)) | m <- modMs]
let introEvts = map (memberIntroEvt gInfo) modMs
forM_ (L.nonEmpty introEvts) $ \introEvts' ->
sendGroupMemberMessages user gInfo conn introEvts'
-- owner intros first so the joiner has the owner profile loaded before applying the saved roster (signed by the owner)
sendIntros owners
serveRoster user gInfo subscriber
sendIntros adminsMods
withStore' $ \db ->
setMembersVectorsNewRelation db modMs subscriberIdx IDSubjectIntroduced MRIntroduced
where
sendIntros ms = forM_ (L.nonEmpty $ map (memberIntroEvt gInfo) ms) $ \evts ->
sendGroupMemberMessages user gInfo conn evts
userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup user = userProfileInGroup' user . groupFeatureUserAllowed SGFSimplexLinks
userProfileInGroup user = userProfileInGroup' user . groupUserAllowSimplexLinks
{-# INLINE userProfileInGroup #-}
userProfileInGroup' :: User -> Bool -> Maybe Profile -> Profile
@@ -1195,16 +1241,40 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, memberPubKey, a
memberKey = MemberKey <$> memberPubKey
}
where
allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m g
allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m g && groupFeatureMemberAllowed SGFDirectMessages m g
redactedMemberProfile :: Bool -> Profile -> Profile
redactedMemberProfile allowSimplexLinks Profile {displayName, fullName, shortDescr, image, simplexName, peerType} =
Profile {displayName, fullName, shortDescr = removeSimplexLink =<< shortDescr, image, contactLink = Nothing, simplexName, preferences = Nothing, peerType}
redactedMemberProfile allowSimplexLinks Profile {displayName, fullName, shortDescr, image, peerType, badge, simplexName} =
Profile {displayName, fullName, shortDescr = removeSimplexLink =<< shortDescr, image, contactLink = Nothing, preferences = Nothing, peerType, badge, simplexName}
where
removeSimplexLink s
| allowSimplexLinks = Just s
| hasObfuscatedSimplexLink s = Nothing
| otherwise = maybe (Just s) (\fts -> if any ftIsSimplexLink fts then Nothing else Just s) $ parseMaybeMarkdownList s
-- Roles carried by the roster; owners are on the link, not the roster.
isRosterRole :: GroupMemberRole -> Bool
isRosterRole r = r == GRMember || r == GRModerator || r == GRAdmin
-- Drop non-privileged-role entries and de-duplicate by memberId, keeping the first.
-- Runs on the parsed roster blob.
validateGroupRoster :: [RosterMember] -> [RosterMember]
validateGroupRoster entries =
dedup S.empty $ filter (\RosterMember {role} -> isRosterRole role) entries
where
dedup _ [] = []
dedup seen (rm@RosterMember {memberId} : rms)
| memberId `S.member` seen = dedup seen rms
| otherwise = rm : dedup (S.insert memberId seen) rms
-- Privileged members without a known key are skipped (recipients can't verify them).
buildGroupRoster :: [GroupMember] -> [RosterMember]
buildGroupRoster mods = take maxGroupRosterSize $ mapMaybe rosterMember mods
where
rosterMember GroupMember {memberId, memberPubKey, memberRole}
| isRosterRole memberRole = (\k -> RosterMember {memberId, key = MemberKey k, role = memberRole, privileges = 0}) <$> memberPubKey
| otherwise = Nothing
sendHistory :: User -> GroupInfo -> GroupMember -> CM ()
sendHistory _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just conn} =
@@ -1331,7 +1401,7 @@ setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM G
setGroupLinkData nm user gInfo gLink = do
cxt <- chatStoreCxt
(conn, groupRelays) <- withFastStore $ \db ->
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
linkType = if useRelays' gInfo then CCTChannel else CCTGroup
sLnk <- shortenShortLink' . setShortLinkType_ linkType =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData))
@@ -1341,7 +1411,7 @@ setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
setGroupLinkDataAsync user gInfo gLink = do
cxt <- chatStoreCxt
(conn, groupRelays) <- withStore $ \db ->
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
setAgentConnShortLinkAsync user conn userLinkData (Just crClientData)
@@ -1367,6 +1437,9 @@ updatePublicGroupData user gInfo
pure (gInfo', gLink)
setGroupLinkDataAsync user gInfo' gLink
pure gInfo'
| useRelays' gInfo && isRelay (membership gInfo) = do
cxt <- chatStoreCxt
withStore $ \db -> updatePublicMemberCount db cxt user gInfo
| otherwise = pure gInfo
updateGroupFromLinkData :: User -> GroupInfo -> GroupShortLinkData -> CM (GroupInfo, Bool)
@@ -1437,10 +1510,9 @@ encodeShortLinkData d =
decodeLinkUserData :: J.FromJSON a => ConnLinkData c -> IO (Maybe a)
decodeLinkUserData cData
| B.null s = pure Nothing
| B.head s == 'X' = case Z1.decompress $ B.drop 1 s of
Z1.Error e -> Nothing <$ logError ("Error decompressing link data: " <> tshow e)
Z1.Skip -> pure Nothing
Z1.Decompress s' -> decode s'
| B.head s == 'X' = case limitDecompress' maxDecompressedMsgLength $ B.drop 1 s of
Left e -> Nothing <$ logError ("Error decompressing link data: " <> tshow e)
Right s' -> decode s'
| otherwise = decode s
where
decode s' = case J.eitherDecodeStrict s' of
@@ -1616,13 +1688,16 @@ sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg =
chSize = fromIntegral chunkSize
parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage conn s = do
parseChatMessage conn s = snd <$> parseChatMessage' conn s
{-# INLINE parseChatMessage #-}
parseChatMessage' :: Connection -> ByteString -> CM (Maybe SignedMsg, ChatMessage 'Json)
parseChatMessage' conn s =
case parseChatMessages s of
[msg] -> liftEither . first (ChatError . errType) $ (\(APMsg _ (ParsedMsg _ _ m)) -> checkEncoding m) =<< msg
[msg] -> liftEither . first (ChatError . errType) $ (\(APMsg _ (ParsedMsg _ sm m)) -> (sm,) <$> checkEncoding m) =<< msg
_ -> throwChatError $ CEException "parseChatMessage: single message is expected"
where
errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s)
{-# INLINE parseChatMessage #-}
getChatScopeInfo :: StoreCxt -> User -> GroupChatScope -> CM GroupChatScopeInfo
getChatScopeInfo cxt user = \case
@@ -1819,6 +1894,51 @@ closeFileHandle fileId files = do
h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
liftIO $ mapM_ hClose h_ `catchAll_` pure ()
-- The roster file has no chat item, so chat-item file enumeration misses it; clean it up by group.
cleanupGroupRosterFile :: User -> GroupInfo -> CM ()
cleanupGroupRosterFile User {userId} GroupInfo {groupId} = do
infos <- withStore' $ \db -> getGroupRosterFileInfo db userId groupId
forM_ infos $ \(fileId, filePath_) -> do
lift $ closeFileHandle fileId rcvFiles
forM_ filePath_ removeFsFile
withStore' $ \db -> do
deleteGroupRosterFile db userId groupId
deleteGroupRosterTransfers db groupId
-- Supersede/cancel one source relay's in-flight roster transfer: remove its on-disk file + cached
-- handle first (the cascade only does rows), then the files + transfer rows.
cleanupRosterTransfer :: GroupInfo -> GroupMemberId -> CM ()
cleanupRosterTransfer gInfo fromMemberId =
withStore' (\db -> getRosterTransferId db gInfo fromMemberId) >>= mapM_ cleanupRosterTransferById
cleanupRosterTransferById :: Int64 -> CM ()
cleanupRosterTransferById transferId = do
file_ <- withStore' $ \db -> getRosterTransferFile db transferId
forM_ file_ $ \(fileId, filePath_) -> do
lift $ closeFileHandle fileId rcvFiles
forM_ filePath_ removeFsFile
withStore' $ \db -> do
deleteRosterTransferFile db transferId
deleteRosterTransfer db transferId
-- MUST evict the cached AppendMode handle before deleting chunks, else re-driven bytes append
-- after the stale prefix and corrupt the blob.
resetRosterPartialChunks :: RcvFileTransfer -> CM ()
resetRosterPartialChunks ft@RcvFileTransfer {fileId, fileStatus} = do
lift $ closeFileHandle fileId rcvFiles
forM_ (rcvFilePath fileStatus) removeFsFile
withStore' $ \db -> deleteRcvFileChunks db ft
where
rcvFilePath = \case
RFSAccepted p -> Just p
RFSConnected p -> Just p
_ -> Nothing
removeFsFile :: FilePath -> CM ()
removeFsFile fp = do
p <- lift $ toFSFilePath fp
removeFile p `catchAllErrors` \_ -> pure ()
deleteMembersConnections :: User -> [GroupMember] -> CM ()
deleteMembersConnections user members = deleteMembersConnections' user members False
@@ -1911,6 +2031,33 @@ sendDirectContactMessages' user ct events = do
forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc'
pure sndMsgs'
-- present the user's own badge on an outgoing profile: a fresh, single-use proof from the stored credential.
-- the send's incognito profile (when set) suppresses it - an incognito identity must never carry the badge.
-- a long-expired badge is not presented at all (receivers would hide it anyway).
presentUserBadge :: User -> Maybe i -> Profile -> CM Profile
presentUserBadge User {profile = LocalProfile {localBadge}} incognitoProfile p = case (incognitoProfile, localBadge) of
(Nothing, Just (OwnBadge cred@(BadgeCredential keyIdx _ _ _) st)) | st == BSActive || st == BSExpired -> do
keys <- asks $ badgePublicKeys . config
case M.lookup keyIdx keys of
Nothing -> p <$ logError "presentUserBadge: badge key index not in config"
Just key -> do
nonce <- drgRandomBytes 16
liftIO (badgeProof key cred (PHTest nonce)) >>= \case
Right proof -> pure p {badge = Just proof}
Left e -> p <$ logError ("presentUserBadge: proof generation failed: " <> T.pack e)
_ -> pure p
-- receiving side of contact/invitation link data: verify the badge proof from the link profile
-- and set the crypto-free display badge for the UI (the raw proof stays in profile for APIPrepareContact)
linkDataBadge :: ContactShortLinkData -> CM ContactShortLinkData
linkDataBadge cld@ContactShortLinkData {profile = Profile {badge}} = case badge of
Nothing -> pure cld
Just b@(BadgeProof _ _ _ info) -> do
keys <- asks $ badgePublicKeys . config
verified <- liftIO $ verifyBadge keys b
now <- liftIO getCurrentTime
pure (cld :: ContactShortLinkData) {localBadge = Just $ ShownBadge info (mkBadgeStatus now verified info)}
sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64)
sendDirectContactMessage user ct chatMsgEvent = do
conn@Connection {connId} <- liftEither $ contactSendConn_ ct
@@ -2024,6 +2171,26 @@ encodeConnInfoPQ pqSup v chatMsgEvent = do
_ -> pure connInfo
ECMLarge -> throwChatError $ CEException "large info"
-- conn-info wrapped as a signed element, so the receiver can verify the signature over the body
encodeSignedConnInfo :: MsgEncodingI e => MsgSigning -> ChatMsgEvent e -> CM ByteString
encodeSignedConnInfo signing chatMsgEvent = do
vr <- chatVersionRange
let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent}
case encodeChatMessage maxEncodedInfoLength info of
ECMEncoded body -> pure $ encodeBatchElement (Just $ signChatMsgBody signing body) body
ECMLarge -> throwChatError $ CEException "large signed info"
-- signed XMember for a relay-group join: proves the joiner holds the member key it asserts, and carries
-- viaRelay = the target relay's memberId inside the signed body so a sibling relay can't accept a replay
encodeXMemberConnInfo :: GroupInfo -> MemberId -> Profile -> CM ByteString
encodeXMemberConnInfo GroupInfo {membership = GroupMember {memberId}, groupKeys} relayMemberId profileToSend =
case groupKeys of
Just GroupKeys {publicGroupId, memberPrivKey} ->
let xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey) (Just relayMemberId)
signing = MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
in encodeSignedConnInfo signing xMemberEvt
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
deliverMessage conn cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
@@ -2097,6 +2264,68 @@ sendGroupMessage' user gInfo members chatMsgEvent =
((Right msg) :| [], _) -> pure msg
_ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message"
-- TODO [relays] improvement: publish roster_version in link data so the owner can recover the latest version
-- TODO after restoring from a stale backup (relays accept only strictly-greater versions)
-- Persist the next roster version before sending the events that carry it (so a recipient never advances
-- past a version the owner hasn't recorded). The matching blob is broadcast separately, by broadcastRoster,
-- after the change is applied to the owner's members - so the served roster excludes demoted/removed members.
reserveRosterVersion :: GroupInfo -> CM VersionRoster
reserveRosterVersion gInfo = do
let rosterVer = maybe (VersionRoster 0) (\(VersionRoster n) -> VersionRoster (n + 1)) (rosterVersion gInfo)
withStore' $ \db -> setGroupRosterVersion db gInfo rosterVer
pure rosterVer
broadcastRoster :: User -> GroupInfo -> VersionRoster -> CM ()
broadcastRoster user gInfo rosterVer = do
cxt <- chatStoreCxt
(relays, rosterMems) <- withStore' $ \db ->
(,) <$> getGroupRelayMembers db cxt user gInfo <*> getGroupRosterMembers db cxt user gInfo
forM_ (L.nonEmpty relays) $ \relays' ->
sendRoster user gInfo (L.toList relays') rosterVer (buildGroupRoster rosterMems)
-- Send the current roster (no version bump) to a newly added relay so it can serve joiners.
sendGroupRosterToRelay :: User -> GroupInfo -> GroupMember -> CM ()
sendGroupRosterToRelay user gInfo relayMember =
forM_ (rosterVersion gInfo) $ \rosterVer -> do
cxt <- chatStoreCxt
rosterMems <- withStore' $ \db -> getGroupRosterMembers db cxt user gInfo
sendRoster user gInfo [relayMember] rosterVer (buildGroupRoster rosterMems)
-- Row-less send (no files/snd_files rows, so no send-side cleanup); redelivery is the agent's.
sendRoster :: User -> GroupInfo -> [GroupMember] -> VersionRoster -> [RosterMember] -> CM ()
sendRoster user gInfo members rosterVer roster = do
let blob = encodeRosterBlob roster
fileInv = InlineFileInvitation {fileSize = fromIntegral (B.length blob), fileDigest = FD.FileDigest $ LC.sha512Hash $ LB.fromStrict blob}
SndMessage {sharedMsgId} <- sendGroupMessage' user gInfo members (XGrpRoster GroupRoster {version = rosterVer, fileInv})
sendInlineBlobChunks user gInfo members sharedMsgId blob
-- Send a binary blob as BFileChunks under a shared_msg_id to the given members (chunked by fileChunkSize).
sendInlineBlobChunks :: User -> GroupInfo -> [GroupMember] -> SharedMsgId -> ByteString -> CM ()
sendInlineBlobChunks user gInfo members sharedMsgId blob = do
chSize <- fromIntegral <$> asks (fileChunkSize . config)
go chSize 1 blob
where
go chSize chunkNo bytes = do
let (chunk, rest) = B.splitAt chSize bytes
void $ sendGroupMessage' user gInfo members (BFileChunk sharedMsgId (FileChunk chunkNo chunk))
unless (B.null rest) $ go chSize (chunkNo + 1) rest
-- Relay advertises its current web preview capability to channel owners.
-- Idempotent: sends only when the configured web domain differs from what was last sent, and only to
-- owners whose recorded chat version supports relayWebCapVersion (older apps can't parse XGrpRelayCap).
sendRelayCapIfNeeded :: User -> GroupInfo -> CM ()
sendRelayCapIfNeeded user gInfo = do
ChatConfig {webPreviewConfig} <- asks config
let currentWebDomain = (\WebPreviewConfig {webDomain} -> webDomain) <$> webPreviewConfig
sentWebDomain <- withStore' (`getRelaySentWebDomain` gInfo)
when (currentWebDomain /= sentWebDomain) $ do
cxt <- chatStoreCxt
owners <- withStore' $ \db -> getGroupOwners db cxt user gInfo
let capableOwners = filter (\m -> memberCurrent m && m `supportsVersion` relayWebCapVersion) owners
unless (null capableOwners) $ do
void $ sendGroupMessage' user gInfo capableOwners (XGrpRelayCap RelayCapabilities {webDomain = currentWebDomain})
withStore' $ \db -> updateRelaySentWebDomain db gInfo currentWebDomain
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages user gInfo scope asGroup members events = do
-- TODO [knocking] send current profile to pending member after approval?
@@ -2117,9 +2346,10 @@ sendGroupMessages user gInfo scope asGroup members events = do
_ -> False
sendProfileUpdate = do
let members' = filter (`supportsVersion` memberProfileUpdateVersion) members
allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo
profileUpdateEvent = XInfo $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile p
void $ sendGroupMessage' user gInfo members' profileUpdateEvent
allowSimplexLinks = groupUserAllowSimplexLinks gInfo
-- shouldSendProfileUpdate excludes incognito membership, so the badge is presented
profileUpdate <- presentUserBadge user Nothing $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile p
void $ sendGroupMessage' user gInfo members' $ XInfo profileUpdate
currentTs <- liftIO getCurrentTime
withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
@@ -2316,10 +2546,14 @@ saveDirectRcvMSG conn@Connection {connId} agentMsgMeta chatMsg@ChatMessage {chat
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
pure (conn', msg)
saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> VerifiedMsg e -> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg :: forall e. MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> VerifiedMsg e -> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta verifiedMsg = do
let ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = verifiedChatMsg verifiedMsg
(am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange
-- binary messages (file chunks) carry only the initial-version sentinel, not the sender's range;
-- applying it would downgrade the member's negotiated version and suppress version-gated delivery
(am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- case encoding @e of
SBinary -> pure (authorMember, conn)
SJson -> updateMemberChatVRange authorMember conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
brokerTs = metaBrokerTs agentMsgMeta
newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs}
@@ -2457,11 +2691,11 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem
_ -> Nothing
-- TODO [mentions] optimize by avoiding unnecessary parsing
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember msgSigned currentTs =
let ts@(_, ft_) = ciContentTexts content
hasLink_ = ciContentHasLink content ft_
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember Nothing currentTs
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs =
@@ -2623,7 +2857,7 @@ createFeatureEnabledItems_ :: User -> Contact -> CM [AChatItem]
createFeatureEnabledItems_ user ct@Contact {mergedPreferences} =
forM allChatFeatures $ \(ACF f) -> do
let state = featureState $ getContactUserPreference f mergedPreferences
createChatItem user (CDDirectRcv ct) False (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing Nothing
createChatItem user (CDDirectRcv ct) False (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing Nothing Nothing
createFeatureItems ::
MsgDirectionI d =>
@@ -2653,15 +2887,15 @@ createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do
unless (null errs) $ toView' $ CEvtChatErrors errs
toView' $ CEvtNewChatItems user acis
where
contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])
contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)])
contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do
let contents = mapMaybe (\(ACF f) -> featureCIContent_ f) allChatFeatures
(chatDir ct', False, contents)
where
featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId)
featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)
featureCIContent_ f
| state /= state' = Just (fContent ciFeature state', Nothing)
| prefState /= prefState' = Just (fContent ciOffer prefState', Nothing)
| state /= state' = Just (fContent ciFeature state', Nothing, Nothing)
| prefState /= prefState' = Just (fContent ciOffer prefState', Nothing, Nothing)
| otherwise = Nothing
where
fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d
@@ -2694,16 +2928,16 @@ createGroupFeatureItems_ user cd showGroupAsSender ciContent GroupInfo {fullGrou
forM allGroupFeatures $ \(AGF f) -> do
let p = getGroupPreference f fullGroupPreferences
(_, param, role) = groupFeatureState p
createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing
createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing Nothing
createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem user cd content itemTs_ = do
ci <- createChatItem user cd False content Nothing itemTs_
ci <- createChatItem user cd False content Nothing Nothing itemTs_
toView $ CEvtNewChatItems user [ci]
createChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Maybe UTCTime -> CM AChatItem
createChatItem user cd showGroupAsSender content sharedMsgId itemTs_ =
lift (createChatItems user itemTs_ [(cd, showGroupAsSender, [(content, sharedMsgId)])]) >>= \case
createChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Maybe MsgSigStatus -> Maybe UTCTime -> CM AChatItem
createChatItem user cd showGroupAsSender content sharedMsgId msgSigned itemTs_ =
lift (createChatItems user itemTs_ [(cd, showGroupAsSender, [(content, sharedMsgId, msgSigned)])]) >>= \case
[Right ci] -> pure ci
[Left e] -> throwError e
rs -> throwChatError $ CEInternalError $ "createInternalChatItem: expected 1 result, got " <> show (length rs)
@@ -2715,7 +2949,7 @@ createChatItems ::
(ChatTypeI c, MsgDirectionI d) =>
User ->
Maybe UTCTime ->
[(ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])] ->
[(ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)])] ->
CM' [Either ChatError AChatItem]
createChatItems user itemTs_ dirsCIContents = do
createdAt <- liftIO getCurrentTime
@@ -2724,24 +2958,24 @@ createChatItems user itemTs_ dirsCIContents = do
void . withStoreBatch' $ \db -> map (updateChat db cxt createdAt) dirsCIContents
withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents
where
updateChat :: DB.Connection -> StoreCxt -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO ()
updateChat :: DB.Connection -> StoreCxt -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)]) -> IO ()
updateChat db cxt createdAt (cd, _, contents)
| any (ciRequiresAttention . fst) contents || contactChatDeleted cd = void $ updateChatTsStats db cxt user cd createdAt memberChatStats
| any (\(content, _, _) -> ciRequiresAttention content) contents || contactChatDeleted cd = void $ updateChatTsStats db cxt user cd createdAt memberChatStats
| otherwise = pure ()
where
memberChatStats :: Maybe (Int, MemberAttention, Int)
memberChatStats = case cd of
CDGroupRcv _g (Just scope) m -> do
let unread = length $ filter (ciRequiresAttention . fst) contents
let unread = length $ filter (\(content, _, _) -> ciRequiresAttention content) contents
in Just (unread, memberAttentionChange unread itemTs_ (Just m) scope, 0)
_ -> Nothing
createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> [IO AChatItem]
createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)]) -> [IO AChatItem]
createACIs db itemTs createdAt (cd, showGroupAsSender, contents) = map createACI contents
where
createACI (content, sharedMsgId) = do
createACI (content, sharedMsgId, msgSigned) = do
let hasLink_ = ciContentHasLink content Nothing
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ itemTs createdAt
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ msgSigned itemTs createdAt
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing msgSigned createdAt
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
-- rcvMem_ Nothing means message from channel - treated same as message from moderator,
@@ -2854,7 +3088,8 @@ simplexTeamContactProfile =
contactLink = Just $ CLFull adminContactReq,
simplexName = Nothing,
peerType = Nothing,
preferences = Nothing
preferences = Nothing,
badge = Nothing
}
simplexStatusContactProfile :: Profile
@@ -2867,7 +3102,8 @@ simplexStatusContactProfile =
contactLink = Just (either error CLFull $ strDecode "simplex:/contact/#/?v=1-2&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FShQuD-rPokbDvkyotKx5NwM8P3oUXHxA%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEA6fSx1k9zrOmF0BJpCaTarZvnZpMTAVQhd3RkDQ35KT0%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"),
simplexName = Nothing,
peerType = Just CPTBot,
preferences = Nothing
preferences = Nothing,
badge = Nothing
}
timeItToView :: String -> CM' a -> CM' a
src/Simplex/Chat/Library/Subscriber.hs
+548 -198
View File
File diff suppressed because it is too large Load Diff