IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: group permision to allow files and media (#2610)

Browse Source 
* core: group permision to allow files and media

* test
This commit is contained in:
Evgeny Poberezkin 2023-06-24 12:36:07 +01:00 committed by GitHub
parent da2622f00e
commit 6da18d9b2a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 97 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
src/Simplex/Chat.hs
View File

@ -551,22 +551,25 @@ processChatCommand = \case
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwChatError CEInvalidQuote
CTGroup -> do
g@(Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms) <- withStore $ \db -> getGroup db user chatId
g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId
assertUserGroupRole gInfo GRAuthor
if isVoice mc && not (groupFeatureAllowed SGFVoice gInfo)
then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFVoice))
else do
(fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms)
timed_ <- sndGroupCITimed live gInfo itemTTL
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership
msg@SndMessage {sharedMsgId} <- sendGroupMessage user gInfo ms (XMsgNew msgContainer)
mapM_ (sendGroupFileInline ms sharedMsgId) ft_
ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
forM_ (timed_ >>= timedDeleteAt') $
startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci)
setActive $ ActiveG gName
pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
send g
where
send g@(Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms)
| isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice
| not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles
| otherwise = do
(fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms)
timed_ <- sndGroupCITimed live gInfo itemTTL
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership
msg@SndMessage {sharedMsgId} <- sendGroupMessage user gInfo ms (XMsgNew msgContainer)
mapM_ (sendGroupFileInline ms sharedMsgId) ft_
ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
forM_ (timed_ >>= timedDeleteAt') $
startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci)
setActive $ ActiveG gName
pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f))
setupSndFileTransfer :: Group -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
setupSndFileTransfer g@(Group gInfo _) n = forM file_ $ \file -> do
(fileSize, fileMode) <- checkSndFile mc file $ fromIntegral n
@ -3533,20 +3536,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
e -> throwError e
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
-- TODO integrity message check
if isVoice content && not (groupFeatureAllowed SGFVoice gInfo)
then void $ newChatItem (CIRcvGroupFeatureRejected GFVoice) Nothing Nothing False
else do
-- check if message moderation event was received ahead of message
let timed_ = rcvGroupCITimed gInfo itemTTL
live = fromMaybe False live_
withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case
Just ciModeration -> do
applyModeration timed_ live ciModeration
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
Nothing -> createItem timed_ live
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
| otherwise = do
-- TODO integrity message check
-- check if message moderation event was received ahead of message
let timed_ = rcvGroupCITimed gInfo itemTTL
live = fromMaybe False live_
withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case
Just ciModeration -> do
applyModeration timed_ live ciModeration
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
Nothing -> createItem timed_ live
where
rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False
ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc
applyModeration timed_ live CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, createdByMsgId, moderatedAt}
| moderatorRole < GRAdmin || moderatorRole < memberRole =
@ -5018,6 +5022,7 @@ chatCommandP =
"/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)),
"/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 calls @" *> (SetContactFeature (ACF SCFCalls) <$> displayName <*> optional (A.space *> strP)),
"/set calls " *> (SetUserFeature (ACF SCFCalls) <$> strP),
"/set delete #" *> (SetGroupFeature (AGF SGFFullDelete) <$> displayName <*> (A.space *> strP)),

1
src/Simplex/Chat/Help.hs
View File

@ -153,6 +153,7 @@ groupsHelpInfo =
"",
green "Group chat preferences:",
indent <> highlight "/set voice #<group> on/off " <> " - enable/disable voice messages",
-- indent <> highlight "/set files #<group> on/off " <> " - enable/disable files and media (other than voice)",
indent <> highlight "/set delete #<group> on/off " <> " - enable/disable full message deletion",
indent <> highlight "/set direct #<group> on/off " <> " - enable/disable direct messages to other members",
indent <> highlight "/set disappear #<group> on <time> " <> " - enable disappearing messages with <time>:",

43
src/Simplex/Chat/Types.hs
View File

@ -488,6 +488,7 @@ data GroupFeature
| -- | GFReceipts
GFReactions
| GFVoice
| GFFiles
deriving (Show, Generic)
data SGroupFeature (f :: GroupFeature) where
@ -497,6 +498,7 @@ data SGroupFeature (f :: GroupFeature) where
-- SGFReceipts :: SGroupFeature 'GFReceipts
SGFReactions :: SGroupFeature 'GFReactions
SGFVoice :: SGroupFeature 'GFVoice
SGFFiles :: SGroupFeature 'GFFiles
deriving instance Show (SGroupFeature f)
@ -511,6 +513,7 @@ groupFeatureNameText = \case
GFFullDelete -> "Full deletion"
GFReactions -> "Message reactions"
GFVoice -> "Voice messages"
GFFiles -> "Files and media"
groupFeatureNameText' :: SGroupFeature f -> Text
groupFeatureNameText' = groupFeatureNameText . toGroupFeature
@ -536,7 +539,8 @@ allGroupFeatures =
AGF SGFFullDelete,
-- GFReceipts,
AGF SGFReactions,
AGF SGFVoice
AGF SGFVoice,
AGF SGFFiles
]
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
@ -547,6 +551,7 @@ groupPrefSel = \case
-- GFReceipts -> receipts
SGFReactions -> reactions
SGFVoice -> voice
SGFFiles -> files
toGroupFeature :: SGroupFeature f -> GroupFeature
toGroupFeature = \case
@ -555,6 +560,7 @@ toGroupFeature = \case
SGFFullDelete -> GFFullDelete
SGFReactions -> GFReactions
SGFVoice -> GFVoice
SGFFiles -> GFFiles
class GroupPreferenceI p where
getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f
@ -573,6 +579,7 @@ instance GroupPreferenceI FullGroupPreferences where
-- GFReceipts -> receipts
SGFReactions -> reactions
SGFVoice -> voice
SGFFiles -> files
{-# INLINE getGroupPreference #-}
-- collection of optional group preferences
@ -582,7 +589,8 @@ data GroupPreferences = GroupPreferences
fullDelete :: Maybe FullDeleteGroupPreference,
-- receipts :: Maybe GroupPreference,
reactions :: Maybe ReactionsGroupPreference,
voice :: Maybe VoiceGroupPreference
voice :: Maybe VoiceGroupPreference,
files :: Maybe FilesGroupPreference
}
deriving (Eq, Show, Generic, FromJSON)
@ -613,9 +621,10 @@ setGroupPreference_ f pref prefs =
toGroupPreferences $ case f of
SGFTimedMessages -> prefs {timedMessages = pref}
SGFDirectMessages -> prefs {directMessages = pref}
SGFFullDelete -> prefs {fullDelete = pref}
SGFReactions -> prefs {reactions = pref}
SGFVoice -> prefs {voice = pref}
SGFFullDelete -> prefs {fullDelete = pref}
SGFFiles -> prefs {files = pref}
setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences
setGroupTimedMessagesPreference pref prefs_ =
@ -645,7 +654,8 @@ data FullGroupPreferences = FullGroupPreferences
fullDelete :: FullDeleteGroupPreference,
-- receipts :: GroupPreference,
reactions :: ReactionsGroupPreference,
voice :: VoiceGroupPreference
voice :: VoiceGroupPreference,
files :: FilesGroupPreference
}
deriving (Eq, Show, Generic, FromJSON)
@ -713,11 +723,12 @@ defaultGroupPrefs =
fullDelete = FullDeleteGroupPreference {enable = FEOff},
-- receipts = GroupPreference {enable = FEOff},
reactions = ReactionsGroupPreference {enable = FEOn},
voice = VoiceGroupPreference {enable = FEOn}
voice = VoiceGroupPreference {enable = FEOn},
files = FilesGroupPreference {enable = FEOn}
}
emptyGroupPrefs :: GroupPreferences
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing
data TimedMessagesPreference = TimedMessagesPreference
{ allow :: FeatureAllowed,
@ -820,6 +831,10 @@ data VoiceGroupPreference = VoiceGroupPreference
{enable :: GroupFeatureEnabled}
deriving (Eq, Show, Generic, FromJSON)
data FilesGroupPreference = FilesGroupPreference
{enable :: GroupFeatureEnabled}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON GroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON TimedMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
@ -832,6 +847,8 @@ instance ToJSON FullDeleteGroupPreference where toEncoding = J.genericToEncoding
instance ToJSON VoiceGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON FilesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where
type GroupFeaturePreference (f :: GroupFeature) = p | p -> f
sGroupFeature :: SGroupFeature f
@ -855,6 +872,9 @@ instance HasField "enable" FullDeleteGroupPreference GroupFeatureEnabled where
instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, enable (p :: VoiceGroupPreference))
instance HasField "enable" FilesGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, enable (p :: FilesGroupPreference))
instance GroupFeatureI 'GFTimedMessages where
type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference
sGroupFeature = SGFTimedMessages
@ -880,6 +900,11 @@ instance GroupFeatureI 'GFVoice where
sGroupFeature = SGFVoice
groupPrefParam _ = Nothing
instance GroupFeatureI 'GFFiles where
type GroupFeaturePreference 'GFFiles = FilesGroupPreference
sGroupFeature = SGFFiles
groupPrefParam _ = Nothing
groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Text
groupPrefStateText feature pref param =
let enabled = getField @"enable" pref
@ -1011,7 +1036,8 @@ mergeGroupPreferences groupPreferences =
fullDelete = pref SGFFullDelete,
-- receipts = pref GFReceipts,
reactions = pref SGFReactions,
voice = pref SGFVoice
voice = pref SGFVoice,
files = pref SGFFiles
}
where
pref :: SGroupFeature f -> GroupFeaturePreference f
@ -1025,7 +1051,8 @@ toGroupPreferences groupPreferences =
fullDelete = pref SGFFullDelete,
-- receipts = pref GFReceipts,
reactions = pref SGFReactions,
voice = pref SGFVoice
voice = pref SGFVoice,
files = pref SGFFiles
}
where
pref :: SGroupFeature f -> Maybe (GroupFeaturePreference f)

25
tests/ChatTests/Files.hs
View File

@ -70,6 +70,7 @@ chatFileTests = do
it "error receiving file" testXFTPRcvError
it "cancel receiving file, repeat receive" testXFTPCancelRcvRepeat
it "should accept file automatically with CLI option" testAutoAcceptFile
it "should prohibit file transfers in groups based on preference" testProhibitFiles
runTestFileTransfer :: HasCallStack => TestCC -> TestCC -> IO ()
runTestFileTransfer alice bob = do
@ -1414,6 +1415,30 @@ testAutoAcceptFile =
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
opts = (testOpts :: ChatOpts) {autoAcceptFileSize = 200000}
testProhibitFiles :: HasCallStack => FilePath -> IO ()
testProhibitFiles =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> withXFTPServer $ do
createGroup3 "team" alice bob cath
alice ##> "/set files #team off"
alice <## "updated group preferences:"
alice <## "Files and media: off"
concurrentlyN_
[ do
bob <## "alice updated group #team:"
bob <## "updated group preferences:"
bob <## "Files and media: off",
do
cath <## "alice updated group #team:"
cath <## "updated group preferences:"
cath <## "Files and media: off"
]
alice ##> "/f #team ./tests/fixtures/test.jpg"
alice <## "bad chat command: feature not allowed Files and media"
(bob </)
(cath </)
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
xftpCLI :: [String] -> IO [String]
xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)

1
tests/ChatTests/Groups.hs
View File

@ -1305,6 +1305,7 @@ testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile
alice <## "Full deletion: off"
alice <## "Message reactions: on"
alice <## "Voice messages: on"
alice <## "Files and media: on"
bobAddedDan :: HasCallStack => TestCC -> IO ()
bobAddedDan cc = do
cc <## "#team: bob added dan (Daniel) to the group (connecting...)"

3
tests/ChatTests/Utils.hs
View File

@ -204,7 +204,8 @@ groupFeatures'' =
((0, "Direct messages: on"), Nothing, Nothing),
((0, "Full deletion: off"), Nothing, Nothing),
((0, "Message reactions: on"), Nothing, Nothing),
((0, "Voice messages: on"), Nothing, Nothing)
((0, "Voice messages: on"), Nothing, Nothing),
((0, "Files and media: on"), Nothing, Nothing)
]
itemId :: Int -> String

2
tests/ProtocolTests.hs
View File

@ -89,7 +89,7 @@ testChatPreferences :: Maybe Preferences
testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, fullDelete = Nothing, timedMessages = Nothing, calls = Nothing, reactions = Just ReactionsPreference {allow = FAYes}}
testGroupPreferences :: Maybe GroupPreferences
testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn}, fullDelete = Nothing}
testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn}, files = Nothing, fullDelete = Nothing}
testProfile :: Profile
testProfile = Profile {displayName = "alice", fullName = "Alice", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), contactLink = Nothing, preferences = testChatPreferences}