From 6f59df4e33a16262bd1525aeb6d957de753f4c42 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 3 Dec 2022 18:06:21 +0000 Subject: [PATCH] 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 --- src/Simplex/Chat.hs | 45 +++++++++++++++----- src/Simplex/Chat/Controller.hs | 1 + src/Simplex/Chat/Store.hs | 15 +++++++ src/Simplex/Chat/Types.hs | 13 +++++- src/Simplex/Chat/View.hs | 5 +++ tests/ChatClient.hs | 17 ++++---- tests/ChatTests.hs | 75 ++++++++++++++++++++++++++++++---- 7 files changed, 140 insertions(+), 31 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 074da66ee6..aa107f54be 100644 --- 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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index db00098626..bef8de88c2 100644 --- 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} diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index c579b28296..3755d3da59 100644 --- 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 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index de6fe39c75..2c54be0c1c 100644 --- 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) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index b1e35c2414..3c4382eb81 100644 --- 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] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index f64a303f07..4b1f6daa59 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -212,15 +212,14 @@ testChatN cfg opts ps test = withTmpFiles $ do ( 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 diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 543a3c8b8d..6c183e9bb1 100644 --- 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 "/_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 ("/_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 "/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 "@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