terminal: commands to mute/unmute contacts and groups (#1018)

* terminal: commands to mute/unmute contacts and groups * tests
2026-05-14 19:05:27 +00:00 · 2022-09-05 15:23:38 +01:00
parent f512298d10
commit b232b6132f
7 changed files with 112 additions and 38 deletions
@@ -509,8 +509,8 @@ processChatCommand = \case
      forM_ call_ $ \call -> updateCallItemStatus userId ct call WCSDisconnected Nothing
      toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
      pure CRCmdOk
-  SendCallInvitation cName callType -> withUser $ \User {userId} -> do
-    contactId <- withStore $ \db -> getContactIdByName db userId cName
+  SendCallInvitation cName callType -> withUser $ \user -> do
+    contactId <- withStore $ \db -> getContactIdByName db user cName
    processChatCommand $ APISendCallInvitation contactId callType
  APIRejectCall contactId ->
    -- party accepting call
@@ -629,8 +629,14 @@ processChatCommand = \case
    (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
    connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
    pure $ CRGroupMemberInfo g m connectionStats
-  ContactInfo cName -> withUser $ \User {userId} -> do
-    contactId <- withStore $ \db -> getContactIdByName db userId cName
+  ShowMessages (ChatName cType name) ntfOn -> withUser $ \user -> do
+    chatId <- case cType of
+      CTDirect -> withStore $ \db -> getContactIdByName db user name
+      CTGroup -> withStore $ \db -> getGroupIdByName db user name
+      _ -> throwChatError $ CECommandError "not supported"
+    processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ ChatSettings ntfOn
+  ContactInfo cName -> withUser $ \user -> do
+    contactId <- withStore $ \db -> getContactIdByName db user cName
    processChatCommand $ APIContactInfo contactId
  GroupMemberInfo gName mName -> withUser $ \user -> do
    (gId, mId) <- withStore $ \db -> getGroupIdByName db user gName >>= \gId -> (gId,) <$> getGroupMemberIdByName db user gId mName
@@ -661,11 +667,11 @@ processChatCommand = \case
  ConnectSimplex -> withUser $ \User {userId, profile} ->
    -- [incognito] generate profile to send
    connectViaContact userId adminContactReq $ fromLocalProfile profile
-  DeleteContact cName -> withUser $ \User {userId} -> do
-    contactId <- withStore $ \db -> getContactIdByName db userId cName
+  DeleteContact cName -> withUser $ \user -> do
+    contactId <- withStore $ \db -> getContactIdByName db user cName
    processChatCommand $ APIDeleteChat (ChatRef CTDirect contactId)
-  ClearContact cName -> withUser $ \User {userId} -> do
-    contactId <- withStore $ \db -> getContactIdByName db userId cName
+  ClearContact cName -> withUser $ \user -> do
+    contactId <- withStore $ \db -> getContactIdByName db user cName
    processChatCommand $ APIClearChat (ChatRef CTDirect contactId)
  ListContacts -> withUser $ \user -> CRContactsList <$> withStore' (`getUserContacts` user)
  CreateMyAddress -> withUser $ \User {userId} -> withChatLock . procCmd $ do
@@ -706,8 +712,8 @@ processChatCommand = \case
          )
          `catchError` (toView . CRChatError)
      CRBroadcastSent mc (length cts) <$> liftIO getZonedTime
-  SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \User {userId} -> do
-    contactId <- withStore $ \db -> getContactIdByName db userId cName
+  SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do
+    contactId <- withStore $ \db -> getContactIdByName db user cName
    quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir (safeDecodeUtf8 quotedMsg)
    let mc = MCText $ safeDecodeUtf8 msg
    processChatCommand . APISendMessage (ChatRef CTDirect contactId) $ ComposedMessage Nothing (Just quotedItemId) mc
@@ -807,8 +813,8 @@ processChatCommand = \case
      withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
      pure $ CRLeftMemberUser gInfo {membership = membership {memberStatus = GSMemLeft}}
  APIListMembers groupId -> CRGroupMembers <$> withUser (\user -> withStore (\db -> getGroup db user groupId))
-  AddMember gName cName memRole -> withUser $ \user@User {userId} -> do
-    (groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db userId cName
+  AddMember gName cName memRole -> withUser $ \user -> do
+    (groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName
    processChatCommand $ APIAddMember groupId contactId memRole
  JoinGroup gName -> withUser $ \user -> do
    groupId <- withStore $ \db -> getGroupIdByName db user gName
@@ -929,9 +935,9 @@ processChatCommand = \case
    procCmd :: m ChatResponse -> m ChatResponse
    procCmd = id
    getChatRef :: User -> ChatName -> m ChatRef
-    getChatRef user@User {userId} (ChatName cType name) =
+    getChatRef user (ChatName cType name) =
      ChatRef cType <$> case cType of
-        CTDirect -> withStore $ \db -> getContactIdByName db userId name
+        CTDirect -> withStore $ \db -> getContactIdByName db user name
        CTGroup -> withStore $ \db -> getGroupIdByName db user name
        _ -> throwChatError $ CECommandError "not supported"
    checkChatStopped :: m ChatResponse -> m ChatResponse
@@ -1715,8 +1721,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
      (probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId ct
      void . sendDirectContactMessage ct $ XInfoProbe probe
      if connectedIncognito
-        then
-          withStore' $ \db -> deleteSentProbe db userId probeId
+        then withStore' $ \db -> deleteSentProbe db userId probeId
        else do
          cs <- withStore' $ \db -> getMatchingContacts db userId ct
          let probeHash = ProbeHash $ C.sha256Hash (unProbe probe)
@@ -1734,14 +1739,14 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
    messageError = toView . CRMessageError "error"

    newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
-    newContentMessage ct@Contact {localDisplayName = c} mc msg msgMeta = do
+    newContentMessage ct@Contact {localDisplayName = c, chatSettings} mc msg msgMeta = do
      checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
      let (ExtMsgContent content fileInvitation_) = mcExtMsgContent mc
      ciFile_ <- processFileInvitation fileInvitation_ $
        \fi chSize -> withStore' $ \db -> createRcvFileTransfer db userId ct fi chSize
      ci@ChatItem {formattedText} <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent content) ciFile_
      toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
-      showMsgToast (c <> "> ") content formattedText
+      when (enableNtfs chatSettings) $ showMsgToast (c <> "> ") content formattedText
      setActive $ ActiveC c

    processFileInvitation :: Maybe FileInvitation -> (FileInvitation -> Integer -> m RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
@@ -1761,9 +1766,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
            -- This patches initial sharedMsgId into chat item when locally deleted chat item
            -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
            -- Chat item and update message which created it will have different sharedMsgId in this case...
-            ci@ChatItem {formattedText} <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing
+            ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing
            toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
-            showMsgToast (c <> "> ") mc formattedText
            setActive $ ActiveC c
          _ -> throwError e
      where
@@ -1790,14 +1794,14 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
            SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete"

    newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
-    newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msg msgMeta = do
+    newGroupContentMessage gInfo@GroupInfo {chatSettings} m@GroupMember {localDisplayName = c} mc msg msgMeta = do
      let (ExtMsgContent content fileInvitation_) = mcExtMsgContent mc
      ciFile_ <- processFileInvitation fileInvitation_ $
        \fi chSize -> withStore' $ \db -> createRcvGroupFileTransfer db userId m fi chSize
      ci@ChatItem {formattedText} <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvMsgContent content) ciFile_
      groupMsgToView gInfo m ci msgMeta
      let g = groupName' gInfo
-      showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText
+      when (enableNtfs chatSettings) $ showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText
      setActive $ ActiveG g

    groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> m ()
@@ -2524,7 +2528,9 @@ withStore action = do
 chatCommandP :: Parser ChatCommand
 chatCommandP =
  A.choice
-    [ ("/user " <|> "/u ") *> (CreateActiveUser <$> userProfile),
+    [ "/mute " *> ((`ShowMessages` False) <$> chatNameP'),
+      "/unmute " *> ((`ShowMessages` True) <$> chatNameP'),
+      ("/user " <|> "/u ") *> (CreateActiveUser <$> userProfile),
      ("/user" <|> "/u") $> ShowActiveUser,
      "/_start subscribe=" *> (StartChat <$> ("on" $> True <|> "off" $> False)),
      "/_start" $> StartChat True,
@@ -2588,9 +2594,9 @@ chatCommandP =
      ("/help" <|> "/h") $> ChatHelp HSMain,
      ("/group #" <|> "/group " <|> "/g #" <|> "/g ") *> (NewGroup <$> groupProfile),
      "/_group " *> (NewGroup <$> jsonP),
-      ("/add #" <|> "/add " <|> "/a #" <|> "/a ") *> (AddMember <$> displayName <* A.space <*> displayName <*> memberRole),
+      ("/add #" <|> "/add " <|> "/a #" <|> "/a ") *> (AddMember <$> displayName <* A.space <* optional (A.char '@') <*> displayName <*> memberRole),
      ("/join #" <|> "/join " <|> "/j #" <|> "/j ") *> (JoinGroup <$> displayName),
-      ("/remove #" <|> "/remove " <|> "/rm #" <|> "/rm ") *> (RemoveMember <$> displayName <* A.space <*> displayName),
+      ("/remove #" <|> "/remove " <|> "/rm #" <|> "/rm ") *> (RemoveMember <$> displayName <* A.space <* optional (A.char '@') <*> displayName),
      ("/leave #" <|> "/leave " <|> "/l #" <|> "/l ") *> (LeaveGroup <$> displayName),
      ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName),
      ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName),
@@ -154,6 +154,7 @@ data ChatCommand
  | APISetChatSettings ChatRef ChatSettings
  | APIContactInfo ContactId
  | APIGroupMemberInfo GroupId GroupMemberId
+  | ShowMessages ChatName Bool
  | ContactInfo ContactName
  | GroupMemberInfo GroupName ContactName
  | ChatHelp HelpSection
@@ -18,7 +18,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Simplex.Chat.Markdown
 import Simplex.Chat.Styled
-import Simplex.Chat.Types (User (..), LocalProfile (..))
+import Simplex.Chat.Types (LocalProfile (..), User (..))
 import System.Console.ANSI.Types

 highlight :: Text -> Markdown
@@ -195,5 +195,7 @@ settingsInfo =
      indent <> highlight "/network                 " <> " - show / set network access options",
      indent <> highlight "/smp_servers             " <> " - show / set custom SMP servers",
      indent <> highlight "/info <contact>          " <> " - information about contact connection",
-      indent <> highlight "/info #<group> <member>  " <> " - information about member connection"
+      indent <> highlight "/info #<group> <member>  " <> " - information about member connection",
+      indent <> highlight "/(un)mute <contact>      " <> " - (un)mute contact, the last messages can be printed with /tail command",
+      indent <> highlight "/(un)mute #<group>       " <> " - (un)mute group"
    ]
@@ -609,9 +609,9 @@ toContactOrError ((contactId, profileId, localDisplayName, viaGroup, displayName

 -- TODO return the last connection that is ready, not any last connection
 -- requires updating connection status
-getContactByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Contact
-getContactByName db userId localDisplayName = do
-  cId <- getContactIdByName db userId localDisplayName
+getContactByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Contact
+getContactByName db user@User {userId} localDisplayName = do
+  cId <- getContactIdByName db user localDisplayName
  getContact db userId cId

 getUserContacts :: DB.Connection -> User -> IO [Contact]
@@ -3012,8 +3012,8 @@ getDirectChatStats_ db userId contactId =
    toChatStats' [statsRow] = toChatStats statsRow
    toChatStats' _ = ChatStats {unreadCount = 0, minUnreadItemId = 0}

-getContactIdByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Int64
-getContactIdByName db userId cName =
+getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64
+getContactIdByName db User {userId} cName =
  ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $
    DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ?" (userId, cName)

@@ -9,6 +9,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}

@@ -214,6 +215,9 @@ instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOpt
 defaultChatSettings :: ChatSettings
 defaultChatSettings = ChatSettings {enableNtfs = True}

+pattern DisableNtfs :: ChatSettings
+pattern DisableNtfs = ChatSettings {enableNtfs = False}
+
 data Profile = Profile
  { displayName :: ContactName,
    fullName :: Text,
@@ -66,11 +66,11 @@ responseToView testView = \case
  CRNetworkConfig cfg -> viewNetworkConfig cfg
  CRContactInfo ct cStats customUserProfile -> viewContactInfo ct cStats customUserProfile
  CRGroupMemberInfo g m cStats -> viewGroupMemberInfo g m cStats
-  CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item False
+  CRNewChatItem (AChatItem _ _ chat item) -> unmuted chat item $ viewChatItem chat item False
  CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True) chatItems
  CRChatItemStatusUpdated _ -> []
-  CRChatItemUpdated (AChatItem _ _ chat item) -> viewItemUpdate chat item
-  CRChatItemDeleted (AChatItem _ _ chat deletedItem) (AChatItem _ _ _ toItem) -> viewItemDelete chat deletedItem toItem
+  CRChatItemUpdated (AChatItem _ _ chat item) -> unmuted chat item $ viewItemUpdate chat item
+  CRChatItemDeleted (AChatItem _ _ chat deletedItem) (AChatItem _ _ _ toItem) -> unmuted chat deletedItem $ viewItemDelete chat deletedItem toItem
  CRChatItemDeletedNotFound Contact {localDisplayName = c} _ -> [ttyFrom $ c <> "> [deleted - original message not found]"]
  CRBroadcastSent mc n ts -> viewSentBroadcast mc n ts
  CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr
@@ -207,6 +207,11 @@ responseToView testView = \case
    viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)]
    contactList :: [ContactRef] -> String
    contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
+    unmuted :: ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
+    unmuted chat ChatItem {chatDir} s = case (chat, chatDir) of
+      (DirectChat Contact {chatSettings = DisableNtfs}, CIDirectRcv) -> []
+      (GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _) -> []
+      _ -> s

 viewGroupSubscribed :: GroupInfo -> [StyledString]
 viewGroupSubscribed g@GroupInfo {membership} =
@@ -383,7 +388,11 @@ viewContactsList :: [Contact] -> [StyledString]
 viewContactsList =
  let ldn = T.toLower . (localDisplayName :: Contact -> ContactName)
      incognito ct = if contactConnIncognito ct then incognitoPrefix else ""
-   in map (\ct -> incognito ct <> ttyFullContact ct) . sortOn ldn
+   in map (\ct -> incognito ct <> ttyFullContact ct <> muted ct) . sortOn ldn
+  where
+    muted Contact {chatSettings, localDisplayName = ldn}
+      | enableNtfs chatSettings = ""
+      | otherwise = " (muted, you can " <> highlight ("/unmute @" <> ldn) <> ")"

 viewUserContactLinkDeleted :: [StyledString]
 viewUserContactLinkDeleted =
@@ -504,7 +513,7 @@ viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <nam
 viewGroupsList gs = map groupSS $ sortOn ldn_ gs
  where
    ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName)
-    groupSS g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership} =
+    groupSS g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings} =
      case memberStatus membership of
        GSMemInvited -> groupInvitation' g
        s -> incognito <> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s
@@ -514,7 +523,9 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs
          GSMemRemoved -> delete "you are removed"
          GSMemLeft -> delete "you left"
          GSMemGroupDeleted -> delete "group deleted"
-          _ -> ""
+          _
+            | enableNtfs chatSettings -> ""
+            | otherwise -> " (muted, you can " <> highlight ("/unmute #" <> ldn) <> ")"
        delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> ldn) <> ")"

 groupInvitation' :: GroupInfo -> StyledString
@@ -115,6 +115,9 @@ chatTests = do
  describe "maintenance mode" $ do
    it "start/stop/export/import chat" testMaintenanceMode
    it "export/import chat with files" testMaintenanceModeWithFiles
+  describe "mute/unmute messages" $ do
+    it "mute/unmute contact" testMuteContact
+    it "mute/unmute group" testMuteGroup

 versionTestMatrix2 :: (TestCC -> TestCC -> IO ()) -> Spec
 versionTestMatrix2 runTest = do
@@ -2757,6 +2760,53 @@ testMaintenanceModeWithFiles = withTmpFiles $ do
    -- works after full restart
    withTestChat "alice" $ \alice -> testChatWorking alice bob

+testMuteContact :: IO ()
+testMuteContact =
+  testChat2 aliceProfile bobProfile $
+    \alice bob -> do
+      connectUsers alice bob
+      alice #> "@bob hello"
+      bob <# "alice> hello"
+      bob ##> "/mute alice"
+      bob <## "ok"
+      alice #> "@bob hi"
+      (bob </)
+      bob ##> "/cs"
+      bob <## "alice (Alice) (muted, you can /unmute @alice)"
+      bob ##> "/unmute alice"
+      bob <## "ok"
+      bob ##> "/cs"
+      bob <## "alice (Alice)"
+      alice #> "@bob hi again"
+      bob <# "alice> hi again"
+
+testMuteGroup :: IO ()
+testMuteGroup =
+  testChat3 aliceProfile bobProfile cathProfile $
+    \alice bob cath -> do
+      createGroup3 "team" alice bob cath
+      threadDelay 1000000
+      alice #> "#team hello!"
+      concurrently_
+        (bob <# "#team alice> hello!")
+        (cath <# "#team alice> hello!")
+      bob ##> "/mute #team"
+      bob <## "ok"
+      alice #> "#team hi"
+      concurrently_
+        (bob </)
+        (cath <# "#team alice> hi")
+      bob ##> "/gs"
+      bob <## "#team (muted, you can /unmute #team)"
+      bob ##> "/unmute #team"
+      bob <## "ok"
+      alice #> "#team hi again"
+      concurrently_
+        (bob <# "#team alice> hi again")
+        (cath <# "#team alice> hi again")
+      bob ##> "/gs"
+      bob <## "#team"
+
 withTestChatContactConnected :: String -> (TestCC -> IO a) -> IO a
 withTestChatContactConnected dbPrefix action =
  withTestChat dbPrefix $ \cc -> do