prohibit direct messages to group contacts unless group preferences allow them (#1476)

* prohibit direct messages to group contacts unless group preferences allow them * tests * refactor * more test
2026-03-30 16:25:57 +00:00 · 2022-12-03 18:06:21 +00:00
parent e44e9a0940
commit 6f59df4e33
7 changed files with 140 additions and 31 deletions
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -290,6 +290,7 @@ processChatCommand = \case
  APISendMessage (ChatRef cType chatId) (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of
    CTDirect -> do
      ct@Contact {localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
+      assertDirectAllowed user MDSnd ct XMsgNew_
      unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
      if isVoice mc && not (featureAllowed CFVoice forUser ct)
        then pure $ chatCmdError $ "feature not allowed " <> T.unpack (chatFeatureToText CFVoice)
@@ -418,6 +419,7 @@ processChatCommand = \case
  APIUpdateChatItem (ChatRef cType chatId) itemId mc -> withUser $ \user@User {userId} -> withChatLock "updateChatItem" $ case cType of
    CTDirect -> do
      (ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId
+      assertDirectAllowed user MDSnd ct XMsgUpdate_
      case ci of
        CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId}, content = ciContent} -> do
          case (ciContent, itemSharedMsgId) of
@@ -447,6 +449,7 @@ processChatCommand = \case
  APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user@User {userId} -> withChatLock "deleteChatItem" $ case cType of
    CTDirect -> do
      (ct@Contact {localDisplayName = c}, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId
+      assertDirectAllowed user MDSnd ct XMsgDel_
      case (mode, msgDir, itemSharedMsgId) of
        (CIDMInternal, _, _) -> deleteDirectCI user ct ci True
        (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
@@ -570,6 +573,7 @@ processChatCommand = \case
  APISendCallInvitation contactId callType -> withUser $ \user@User {userId} -> do
    -- party initiating call
    ct <- withStore $ \db -> getContact db user contactId
+    assertDirectAllowed user MDSnd ct XCallInv_
    calls <- asks currentCalls
    withChatLock "sendCallInvitation" $ do
      callId <- CallId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16))
@@ -852,6 +856,7 @@ processChatCommand = \case
  APIAddMember groupId contactId memRole -> withUser $ \user -> withChatLock "addMember" $ do
    -- TODO for large groups: no need to load all members to determine if contact is a member
    (group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db user contactId
+    assertDirectAllowed user MDSnd contact XGrpInv_
    let Group gInfo@GroupInfo {membership} members = group
        GroupMember {memberRole = userRole} = membership
        Contact {localDisplayName = cName} = contact
@@ -1184,6 +1189,7 @@ processChatCommand = \case
    updateContactPrefs user@User {userId} ct@Contact {activeConn = Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs'
      | contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated ct ct
      | otherwise = do
+        assertDirectAllowed user MDSnd ct XInfo_
        ct' <- withStore' $ \db -> updateContactUserPreferences db user ct contactUserPrefs'
        incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
        let p' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct')
@@ -1253,6 +1259,21 @@ processChatCommand = \case
      toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
      setActive $ ActiveG localDisplayName

+assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m ()
+assertDirectAllowed user dir ct event =
+  unless (allowedChatEvent || anyDirectContact ct) . unlessM directMessagesAllowed $
+    throwChatError $ CEDirectMessagesProhibited dir ct
+  where
+    directMessagesAllowed = any (groupFeatureAllowed' GFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct)
+    allowedChatEvent = case event of
+      XMsgNew_ -> False
+      XMsgUpdate_ -> False
+      XMsgDel_ -> False
+      XFile_ -> False
+      XGrpInv_ -> False
+      XCallInv_ -> False
+      _ -> True
+
 setExpireCIs :: (MonadUnliftIO m, MonadReader ChatController m) => Bool -> m ()
 setExpireCIs b = do
  expire <- asks expireCIs
@@ -1713,9 +1734,10 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
              CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
        MSG msgMeta _msgFlags msgBody -> do
          cmdId <- createAckCmd conn
-          msg@RcvMessage {chatMsgEvent = ACME _ event} <- saveRcvMSG conn (ConnectionId connId) msgMeta msgBody cmdId
-          updateChatLock "directMessage" event
-          withAckMessage agentConnId cmdId msgMeta $
+          withAckMessage agentConnId cmdId msgMeta $ do
+            msg@RcvMessage {chatMsgEvent = ACME _ event} <- saveRcvMSG conn (ConnectionId connId) msgMeta msgBody cmdId
+            assertDirectAllowed user MDRcv ct $ toCMEventTag event
+            updateChatLock "directMessage" event
            case event of
              XMsgNew mc -> newContentMessage ct mc msg msgMeta
              XMsgUpdate sharedMsgId mContent -> messageUpdate ct sharedMsgId mContent msg msgMeta
@@ -3404,13 +3426,13 @@ chatCommandP =
      "/profile_image" $> UpdateProfileImage Nothing,
      ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> userNames),
      ("/profile" <|> "/p") $> ShowProfile,
-      "/voice #" *> (SetGroupFeature GFVoice <$> displayName <*> (A.space *> strP)),
-      "/voice @" *> (SetContactFeature CFVoice <$> displayName <*> optional (A.space *> strP)),
-      "/voice " *> (SetUserFeature CFVoice <$> strP),
-      "/full_delete #" *> (SetGroupFeature GFFullDelete <$> displayName <*> (A.space *> strP)),
-      "/full_delete @" *> (SetContactFeature CFFullDelete <$> displayName <*> optional (A.space *> strP)),
-      "/full_delete " *> (SetUserFeature CFFullDelete <$> strP),
-      "/dms #" *> (SetGroupFeature GFDirectMessages <$> displayName <*> (A.space *> strP)),
+      "/set voice #" *> (SetGroupFeature GFVoice <$> displayName <*> (A.space *> strP)),
+      "/set voice @" *> (SetContactFeature CFVoice <$> displayName <*> optional (A.space *> strP)),
+      "/set voice " *> (SetUserFeature CFVoice <$> strP),
+      "/set delete #" *> (SetGroupFeature GFFullDelete <$> displayName <*> (A.space *> strP)),
+      "/set delete @" *> (SetContactFeature CFFullDelete <$> displayName <*> optional (A.space *> strP)),
+      "/set delete " *> (SetUserFeature CFFullDelete <$> strP),
+      "/set direct #" *> (SetGroupFeature GFDirectMessages <$> displayName <*> (A.space *> strP)),
      "/incognito " *> (SetIncognito <$> onOffP),
      ("/quit" <|> "/q" <|> "/exit") $> QuitChat,
      ("/version" <|> "/v") $> ShowVersion,
@@ -3445,7 +3467,8 @@ chatCommandP =
    groupProfile = do
      gName <- displayName
      fullName <- fullNameP gName
-      pure GroupProfile {displayName = gName, fullName, image = Nothing, groupPreferences = Nothing}
+      let groupPreferences = Just (emptyGroupPrefs :: GroupPreferences) {directMessages = Just GroupPreference {enable = FEOn}}
+      pure GroupProfile {displayName = gName, fullName, image = Nothing, groupPreferences}
    fullNameP name = do
      n <- (A.space *> A.takeByteString) <|> pure ""
      pure $ if B.null n then name else safeDecodeUtf8 n
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -547,6 +547,7 @@ data ChatErrorType
  | CENoCurrentCall
  | CECallContact {contactId :: Int64}
  | CECallState {currentCallState :: CallStateTag}
+  | CEDirectMessagesProhibited {direction :: MsgDirection, contact :: Contact}
  | CEAgentVersion
  | CEAgentNoSubResult {agentConnId :: AgentConnId}
  | CECommandError {message :: String}
--- a/src/Simplex/Chat/Store.hs
+++ b/src/Simplex/Chat/Store.hs
@@ -91,6 +91,7 @@ module Simplex.Chat.Store
    deleteGroup,
    getUserGroups,
    getUserGroupDetails,
+    getContactGroupPreferences,
    getGroupInvitation,
    createNewContactMember,
    createNewContactMemberAsync,
@@ -1817,6 +1818,20 @@ getUserGroupDetails db User {userId, userContactId} =
      |]
      (userId, userContactId)

+getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
+getContactGroupPreferences db User {userId} Contact {contactId} = do
+  map (mergeGroupPreferences . fromOnly)
+    <$> DB.query
+      db
+      [sql|
+        SELECT gp.preferences
+        FROM groups g
+        JOIN group_profiles gp USING (group_profile_id)
+        JOIN group_members m USING (group_id)
+        WHERE g.user_id = ? AND m.contact_id = ?
+      |]
+      (userId, contactId)
+
 getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo
 getGroupInfoByName db user gName = do
  gId <- getGroupIdByName db user gName
--- a/src/Simplex/Chat/Types.hs
+++ b/src/Simplex/Chat/Types.hs
@@ -123,6 +123,9 @@ directContact :: Contact -> Bool
 directContact Contact {contactUsed, activeConn = Connection {connLevel, viaGroupLink}} =
  (connLevel == 0 && not viaGroupLink) || contactUsed

+anyDirectContact :: Contact -> Bool
+anyDirectContact Contact {contactUsed, activeConn = Connection {connLevel}} = connLevel == 0 || contactUsed
+
 data ContactRef = ContactRef
  { contactId :: ContactId,
    localDisplayName :: ContactName
@@ -342,8 +345,11 @@ groupFeatureToText = \case
  GFVoice -> "Voice messages"

 groupFeatureAllowed :: GroupFeature -> GroupInfo -> Bool
-groupFeatureAllowed feature GroupInfo {fullGroupPreferences} =
-  let GroupPreference {enable} = getGroupPreference feature fullGroupPreferences
+groupFeatureAllowed feature gInfo = groupFeatureAllowed' feature $ fullGroupPreferences gInfo
+
+groupFeatureAllowed' :: GroupFeature -> FullGroupPreferences -> Bool
+groupFeatureAllowed' feature prefs =
+  let GroupPreference {enable} = getGroupPreference feature prefs
   in enable == FEOn

 instance ToJSON GroupFeature where
@@ -490,6 +496,9 @@ defaultGroupPrefs =
      voice = GroupPreference {enable = FEOn}
    }

+emptyGroupPrefs :: GroupPreferences
+emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing
+
 data Preference = Preference
  {allow :: FeatureAllowed}
  deriving (Eq, Show, Generic, FromJSON)
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@@ -496,6 +496,10 @@ viewCannotResendInvitation GroupInfo {localDisplayName = gn} c =
    "to re-send invitation: " <> highlight ("/rm " <> gn <> " " <> c) <> ", " <> highlight ("/a " <> gn <> " " <> c)
  ]

+viewDirectMessagesProhibited :: MsgDirection -> Contact -> [StyledString]
+viewDirectMessagesProhibited MDSnd c = [ "direct messages to indirect contact " <> ttyContact' c <> " are prohibited"]
+viewDirectMessagesProhibited MDRcv c = [ "received prohibited direct message from indirect contact " <> ttyContact' c <> " (discarded)"]
+
 viewUserJoinedGroup :: GroupInfo -> [StyledString]
 viewUserJoinedGroup g@GroupInfo {membership = membership@GroupMember {memberProfile}} =
  if memberIncognito membership
@@ -1098,6 +1102,7 @@ viewChatError = \case
    CENoCurrentCall -> ["no call in progress"]
    CECallContact _ -> []
    CECallState _ -> []
+    CEDirectMessagesProhibited dir ct -> viewDirectMessagesProhibited dir ct
    CEAgentVersion -> ["unsupported agent version"]
    CEAgentNoSubResult connId -> ["no subscription result for connection: " <> sShow connId]
    CECommandError e -> ["bad chat command: " <> plain e]
--- a/tests/ChatClient.hs
+++ b/tests/ChatClient.hs
@@ -212,15 +212,14 @@ testChatN cfg opts ps test = withTmpFiles $ do
 (<//) cc t = timeout t (getTermLine cc) `shouldReturn` Nothing

 getTermLine :: TestCC -> IO String
-getTermLine = atomically . readTQueue . termQ
-
-- Use code below to echo virtual terminal
-- getTermLine :: TestCC -> IO String
-- getTermLine cc = do
--   s <- atomically . readTQueue $ termQ cc
--   name <- userName cc
--   putStrLn $ name <> ": " <> s
--   pure s
+getTermLine cc =
+  5000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case
+    Just s -> do
+      -- uncomment code below to echo virtual terminal
+      -- name <- userName cc
+      -- putStrLn $ name <> ": " <> s
+      pure s
+    _ -> error "no output for 5 seconds"

 userName :: TestCC -> IO [Char]
 userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName . fromJust <$> readTVarIO currentUser
--- a/tests/ChatTests.hs
+++ b/tests/ChatTests.hs
@@ -124,6 +124,7 @@ chatTests = do
    it "update group preferences" testUpdateGroupPrefs
    it "allow full deletion to contact" testAllowFullDeletionContact
    it "allow full deletion to group" testAllowFullDeletionGroup
+    it "prohibit direct messages to group members" testProhibitDirectMessages
  describe "SMP servers" $ do
    it "get and set SMP servers" testGetSetSMPServers
    it "test SMP server connection" testTestSMPServerConnection
@@ -3010,7 +3011,7 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $
    bob ##> sendVoice
    bob <## voiceNotAllowed
    -- alice ##> "/_set prefs @2 {\"voice\": {\"allow\": \"always\"}}"
-    alice ##> "/voice @bob always"
+    alice ##> "/set voice @bob always"
    alice <## "you updated preferences for bob:"
    alice <## "Voice messages: enabled for contact (you allow: always, contact allows: no)"
    alice #$> ("/_get chat @2 count=100", chat, startFeatures <> [(1, "Voice messages: enabled for contact")])
@@ -3029,7 +3030,7 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $
    alice <## "completed receiving file 1 (test.txt) from bob"
    (bob </)
    -- alice ##> "/_profile {\"displayName\": \"alice\", \"fullName\": \"Alice\", \"preferences\": {\"voice\": {\"allow\": \"no\"}}}"
-    alice ##> "/voice no"
+    alice ##> "/set voice no"
    alice <## "updated preferences:"
    alice <## "Voice messages allowed: no"
    (alice </)
@@ -3074,7 +3075,7 @@ testUpdateGroupPrefs =
      alice #$> ("/_get chat #1 count=100", chat, [(0, "connected")])
      bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected")])
      threadDelay 1000000
-      alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"on\"}}}"
+      alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}}}"
      alice <## "updated group preferences:"
      alice <## "Full deletion enabled: on"
      alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on")])
@@ -3083,7 +3084,7 @@ testUpdateGroupPrefs =
      bob <## "Full deletion enabled: on"
      bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on")])
      threadDelay 1000000
-      alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"off\"}}}"
+      alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"off\"}, \"directMessages\": {\"enable\": \"on\"}}}"
      alice <## "updated group preferences:"
      alice <## "Full deletion enabled: off"
      alice <## "Voice messages enabled: off"
@@ -3095,7 +3096,7 @@ testUpdateGroupPrefs =
      bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off")])
      threadDelay 1000000
      -- alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}}}"
-      alice ##> "/voice #team on"
+      alice ##> "/set voice #team on"
      alice <## "updated group preferences:"
      alice <## "Voice messages enabled: on"
      alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on"), (1, "Full deletion: off"), (1, "Voice messages: off"), (1, "Voice messages: on")])
@@ -3104,7 +3105,7 @@ testUpdateGroupPrefs =
      bob <## "Voice messages enabled: on"
      bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Voice messages: on")])
      threadDelay 1000000
-      alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}}}"
+      alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}}}"
      -- no update
      alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on"), (1, "Full deletion: off"), (1, "Voice messages: off"), (1, "Voice messages: on")])
      threadDelay 1000000
@@ -3122,7 +3123,7 @@ testAllowFullDeletionContact =
    \alice bob -> do
      connectUsers alice bob
      alice <##> bob
-      alice ##> "/full_delete @bob always"
+      alice ##> "/set delete @bob always"
      alice <## "you updated preferences for bob:"
      alice <## "Full deletion: enabled for contact (you allow: always, contact allows: no)"
      bob <## "alice updated preferences for you:"
@@ -3145,7 +3146,7 @@ testAllowFullDeletionGroup =
      threadDelay 1000000
      bob #> "#team hey"
      alice <# "#team bob> hey"
-      alice ##> "/full_delete #team on"
+      alice ##> "/set delete #team on"
      alice <## "updated group preferences:"
      alice <## "Full deletion enabled: on"
      bob <## "alice updated group #team:"
@@ -3158,6 +3159,62 @@ testAllowFullDeletionGroup =
      alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (1, "Full deletion: on")])
      bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (0, "Full deletion: on")])

+testProhibitDirectMessages :: IO ()
+testProhibitDirectMessages =
+  testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do
+    createGroup3 "team" alice bob cath
+    threadDelay 1000000
+    alice ##> "/set direct #team off"
+    alice <## "updated group preferences:"
+    alice <## "Direct messages enabled: off"
+    directProhibited bob
+    directProhibited cath
+    threadDelay 1000000
+    -- still can send direct messages to direct contacts
+    alice #> "@bob hello again"
+    bob <# "alice> hello again"
+    alice #> "@cath hello again"
+    cath <# "alice> hello again"
+    bob ##> "@cath hello again"
+    bob <## "direct messages to indirect contact cath are prohibited"
+    (cath </)
+    connectUsers cath dan
+    addMember "team" cath dan GRMember
+    dan ##> "/j #team"
+    concurrentlyN_
+      [ cath <## ("#team: dan joined the group"),
+        do
+          dan <## ("#team: you joined the group")
+          dan <### 
+                [ "#team: member alice (Alice) is connected",
+                  "#team: member bob (Bob) is connected"
+                ],
+        do
+          alice <## ("#team: cath added dan (Daniel) to the group (connecting...)")
+          alice <## ("#team: new member dan is connected"),
+        do
+          bob <## ("#team: cath added dan (Daniel) to the group (connecting...)")
+          bob <## ("#team: new member dan is connected")
+      ]
+    alice ##> "@dan hi"
+    alice <## "direct messages to indirect contact dan are prohibited"
+    bob ##> "@dan hi"
+    bob <## "direct messages to indirect contact dan are prohibited"
+    (dan </)
+    dan ##> "@alice hi"
+    dan <## "direct messages to indirect contact alice are prohibited"
+    dan ##> "@bob hi"
+    dan <## "direct messages to indirect contact bob are prohibited"
+    dan #> "@cath hi"
+    cath <# "dan> hi"
+    cath #> "@dan hi"
+    dan <# "cath> hi"
+  where
+    directProhibited cc = do
+      cc <## "alice updated group #team:"
+      cc <## "updated group preferences:"
+      cc <## "Direct messages enabled: off"
+
 testGetSetSMPServers :: IO ()
 testGetSetSMPServers =
  testChat2 aliceProfile bobProfile $
@@ -4296,7 +4353,7 @@ groupFeatures :: [(Int, String)]
 groupFeatures = map (\(a, _, _) -> a) groupFeatures''

 groupFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)]
-groupFeatures'' = [((0, "Direct messages: off"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: on"), Nothing, Nothing)]
+groupFeatures'' = [((0, "Direct messages: on"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: on"), Nothing, Nothing)]

 itemId :: Int -> String
 itemId i = show $ length chatFeatures + i