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

* core: group permision to allow files and media

* test

src/Simplex/Chat.hs

@@ -551,11 +551,14 @@ 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)
+      send g
-        then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFVoice))
+      where
-        else do
+        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
@@ -566,7 +569,7 @@ processChatCommand = \case
               startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci)
             setActive $ ActiveG gName
             pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
-      where
+        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,11 +3536,11 @@ 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
+    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
-      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_
@@ -3547,6 +3550,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
             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)),

src/Simplex/Chat/Help.hs

@@ -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>:",

src/Simplex/Chat/Types.hs

@@ -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)

tests/ChatTests/Files.hs

@@ -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)
 

tests/ChatTests/Groups.hs

@@ -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...)"

tests/ChatTests/Utils.hs

@@ -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

tests/ProtocolTests.hs

@@ -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}