mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-27 05:14:51 +00:00
core: additional group preferences: prohibit SimpleX links, restrict some features to specific roles (#3964)
* core: additional group preferences: prohibit SimpleX links, restrict some features to specific roles * add role to group preference items, tests
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
069395c2a0
commit
18efc28d16
+43
-29
@@ -80,6 +80,7 @@ import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Chat.Util (encryptFile, shuffle)
|
||||
import Simplex.FileTransfer.Client.Main (maxFileSize, maxFileSizeHard)
|
||||
@@ -748,10 +749,10 @@ processChatCommand' vr = \case
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
send g
|
||||
where
|
||||
send g@(Group gInfo@GroupInfo {groupId} ms)
|
||||
| isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice
|
||||
| not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles
|
||||
| otherwise = do
|
||||
send g@(Group gInfo@GroupInfo {groupId, membership} ms) =
|
||||
case prohibitedGroupContent gInfo membership mc file_ of
|
||||
Just f -> notAllowedError f
|
||||
Nothing -> do
|
||||
(fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer g (length $ filter memberCurrent ms)
|
||||
timed_ <- sndGroupCITimed live gInfo itemTTL
|
||||
(msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ timed_ live
|
||||
@@ -1587,8 +1588,9 @@ processChatCommand' vr = \case
|
||||
let mc = MCText msg
|
||||
case memberContactId m of
|
||||
Nothing -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user gId
|
||||
toView $ CRNoMemberContactCreating user gInfo m
|
||||
g <- withStore $ \db -> getGroupInfo db vr user gId
|
||||
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed"
|
||||
toView $ CRNoMemberContactCreating user g m
|
||||
processChatCommand (APICreateMemberContact gId mId) >>= \case
|
||||
cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do
|
||||
toView cr
|
||||
@@ -1872,7 +1874,7 @@ processChatCommand' vr = \case
|
||||
APICreateMemberContact gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId
|
||||
assertUserGroupRole g GRAuthor
|
||||
unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed"
|
||||
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed"
|
||||
case memberConn m of
|
||||
Just mConn@Connection {peerChatVRange} -> do
|
||||
unless (maxVersion peerChatVRange >= groupDirectInvVersion) $ throwChatError CEPeerChatVRangeIncompatible
|
||||
@@ -2053,9 +2055,12 @@ processChatCommand' vr = \case
|
||||
ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db vr user cName
|
||||
let prefs' = setPreference f allowed_ $ Just userPreferences
|
||||
updateContactPrefs user ct prefs'
|
||||
SetGroupFeature (AGF f) gName enabled ->
|
||||
SetGroupFeature (AGFNR f) gName enabled ->
|
||||
updateGroupProfileByName gName $ \p ->
|
||||
p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p}
|
||||
SetGroupFeatureRole (AGFR f) gName enabled role ->
|
||||
updateGroupProfileByName gName $ \p ->
|
||||
p {groupPreferences = Just . setGroupPreferenceRole f enabled role $ groupPreferences p}
|
||||
SetUserTimedMessages onOff -> withUser $ \user@User {profile} -> do
|
||||
let allowed = if onOff then FAYes else FANo
|
||||
pref = TimedMessagesPreference allowed Nothing
|
||||
@@ -2645,7 +2650,7 @@ assertDirectAllowed user dir ct event =
|
||||
unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $
|
||||
throwChatError (CEDirectMessagesProhibited dir ct)
|
||||
where
|
||||
directMessagesAllowed = any (groupFeatureAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct)
|
||||
directMessagesAllowed = any (uncurry $ groupFeatureMemberAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct)
|
||||
allowedChatEvent = case event of
|
||||
XMsgNew_ -> False
|
||||
XMsgUpdate_ -> False
|
||||
@@ -2655,6 +2660,13 @@ assertDirectAllowed user dir ct event =
|
||||
XCallInv_ -> False
|
||||
_ -> True
|
||||
|
||||
prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe f -> Maybe GroupFeature
|
||||
prohibitedGroupContent gInfo m mc file_
|
||||
| isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice
|
||||
| not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles
|
||||
| not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) && containsFormat isSimplexLink (parseMarkdown $ msgContentText mc) = Just GFSimplexLinks
|
||||
| otherwise = Nothing
|
||||
|
||||
roundedFDCount :: Int -> Int
|
||||
roundedFDCount n
|
||||
| n <= 0 = 4
|
||||
@@ -4739,14 +4751,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM ()
|
||||
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded
|
||||
| blockedByAdmin m = createBlockedByAdmin
|
||||
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
|
||||
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
|
||||
| otherwise =
|
||||
withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
|
||||
Nothing -> createContentItem
|
||||
| otherwise = case prohibitedGroupContent gInfo m content fInv_ of
|
||||
Just f -> rejected f
|
||||
Nothing ->
|
||||
withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
|
||||
Nothing -> createContentItem
|
||||
where
|
||||
rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False
|
||||
timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL
|
||||
@@ -5189,8 +5201,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
createGroupFeatureItems g@GroupInfo {fullGroupPreferences} m =
|
||||
forM_ allGroupFeatures $ \(AGF f) -> do
|
||||
let p = getGroupPreference f fullGroupPreferences
|
||||
(_, param) = groupFeatureState p
|
||||
createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing
|
||||
(_, param, role) = groupFeatureState p
|
||||
createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param role) Nothing
|
||||
|
||||
xInfoProbe :: ContactOrMember -> Probe -> CM ()
|
||||
xInfoProbe cgm2 probe = do
|
||||
@@ -5701,7 +5713,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM ()
|
||||
xGrpDirectInv g m mConn connReq mContent_ msg brokerTs = do
|
||||
unless (groupFeatureAllowed SGFDirectMessages g) $ messageError "x.grp.direct.inv: direct messages not allowed"
|
||||
unless (groupFeatureMemberAllowed SGFDirectMessages m g) $ messageError "x.grp.direct.inv: direct messages not allowed"
|
||||
let GroupMember {memberContactId} = m
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
case memberContactId of
|
||||
@@ -6681,14 +6693,14 @@ createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do
|
||||
cup = getContactUserPreference f cups
|
||||
cup' = getContactUserPreference f cups'
|
||||
|
||||
createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> CIContent d) -> GroupInfo -> GroupInfo -> CM ()
|
||||
createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> GroupInfo -> CM ()
|
||||
createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} =
|
||||
forM_ allGroupFeatures $ \(AGF f) -> do
|
||||
let state = groupFeatureState $ getGroupPreference f gps
|
||||
pref' = getGroupPreference f gps'
|
||||
state'@(_, int') = groupFeatureState pref'
|
||||
state'@(_, param', role') = groupFeatureState pref'
|
||||
when (state /= state') $
|
||||
createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') int') Nothing
|
||||
createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') param' role') Nothing
|
||||
|
||||
sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool
|
||||
sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing}
|
||||
@@ -7046,20 +7058,22 @@ chatCommandP =
|
||||
"/show profile image" $> ShowProfileImage,
|
||||
("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNames),
|
||||
("/profile" <|> "/p") $> ShowProfile,
|
||||
"/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)),
|
||||
"/set voice #" *> (SetGroupFeatureRole (AGFR SGFVoice) <$> displayName <*> _strP <*> optional memberRole),
|
||||
"/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP),
|
||||
"/set files #" *> (SetGroupFeature (AGF SGFFiles) <$> displayName <*> (A.space *> strP)),
|
||||
"/set history #" *> (SetGroupFeature (AGF SGFHistory) <$> displayName <*> (A.space *> strP)),
|
||||
"/set files #" *> (SetGroupFeatureRole (AGFR SGFFiles) <$> displayName <*> _strP <*> optional memberRole),
|
||||
"/set history #" *> (SetGroupFeature (AGFNR SGFHistory) <$> displayName <*> (A.space *> strP)),
|
||||
"/set reactions #" *> (SetGroupFeature (AGFNR SGFReactions) <$> displayName <*> (A.space *> strP)),
|
||||
"/set calls @" *> (SetContactFeature (ACF SCFCalls) <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set calls " *> (SetUserFeature (ACF SCFCalls) <$> strP),
|
||||
"/set delete #" *> (SetGroupFeature (AGF SGFFullDelete) <$> displayName <*> (A.space *> strP)),
|
||||
"/set delete #" *> (SetGroupFeature (AGFNR SGFFullDelete) <$> displayName <*> (A.space *> strP)),
|
||||
"/set delete @" *> (SetContactFeature (ACF SCFFullDelete) <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set delete " *> (SetUserFeature (ACF SCFFullDelete) <$> strP),
|
||||
"/set direct #" *> (SetGroupFeature (AGF SGFDirectMessages) <$> displayName <*> (A.space *> strP)),
|
||||
"/set direct #" *> (SetGroupFeatureRole (AGFR SGFDirectMessages) <$> displayName <*> _strP <*> optional memberRole),
|
||||
"/set disappear #" *> (SetGroupTimedMessages <$> displayName <*> (A.space *> timedTTLOnOffP)),
|
||||
"/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)),
|
||||
"/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
|
||||
"/set links #" *> (SetGroupFeatureRole (AGFR SGFSimplexLinks) <$> displayName <*> _strP <*> optional memberRole),
|
||||
("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito,
|
||||
"/set device name " *> (SetLocalDeviceName <$> textP),
|
||||
"/list remote hosts" $> ListRemoteHosts,
|
||||
@@ -7147,7 +7161,7 @@ chatCommandP =
|
||||
let groupPreferences =
|
||||
Just
|
||||
(emptyGroupPrefs :: GroupPreferences)
|
||||
{ directMessages = Just DirectMessagesGroupPreference {enable = FEOn},
|
||||
{ directMessages = Just DirectMessagesGroupPreference {enable = FEOn, role = Nothing},
|
||||
history = Just HistoryGroupPreference {enable = FEOn}
|
||||
}
|
||||
pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences}
|
||||
|
||||
Reference in New Issue
Block a user