terminal: set voice message preferences (#1447)

* terminal: set voice message preferences * enable all tests
2026-03-30 18:35:49 +00:00 · 2022-11-27 13:54:34 +00:00
parent 7f0355ec67
commit 8af0229f52
5 changed files with 133 additions and 24 deletions
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -992,20 +992,8 @@ processChatCommand = \case
    processChatCommand $ APIListMembers groupId
  ListGroups -> CRGroupsList <$> withUser (\user -> withStore' (`getUserGroupDetails` user))
  APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
-    Group g@GroupInfo {groupProfile = p} ms <- withStore $ \db -> getGroup db user groupId
-    let s = memberStatus $ membership g
-        canUpdate =
-          memberRole (membership g :: GroupMember) == GROwner
-            || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited)
-    unless canUpdate $ throwChatError CEGroupUserRole
-    g' <- withStore $ \db -> updateGroupProfile db user g p'
-    msg <- sendGroupMessage g' ms (XGrpInfo p')
-    let cd = CDGroupSnd g'
-    unless (sameGroupProfileInfo p p') $ do
-      ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') Nothing Nothing
-      toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat g') ci
-    createGroupFeatureChangedItems user cd CISndGroupFeature p p'
-    pure $ CRGroupUpdated g g' Nothing
+    g <- withStore $ \db -> getGroup db user groupId
+    runUpdateGroupProfile user g p'
  UpdateGroupProfile gName profile -> withUser $ \user -> do
    groupId <- withStore $ \db -> getGroupIdByName db user gName
    processChatCommand $ APIUpdateGroupProfile groupId profile
@@ -1096,6 +1084,17 @@ processChatCommand = \case
  UpdateProfileImage image -> withUser $ \user@User {profile} -> do
    let p = (fromLocalProfile profile :: Profile) {image}
    updateProfile user p
+  SetUserFeature f allowed -> withUser $ \user@User {profile} -> do
+    let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user}
+    updateProfile user p
+  SetContactFeature f cName allowed_ -> withUser $ \user -> do
+    ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db user cName
+    let prefs' = setPreference f allowed_ $ Just userPreferences
+    updateContactPrefs user ct prefs'
+  SetGroupFeature f gName enabled -> withUser $ \user -> do
+    g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> getGroup db user =<< getGroupIdByName db user gName
+    let p' = p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p}
+    runUpdateGroupProfile user g p'
  QuitChat -> liftIO exitSuccess
  ShowVersion -> pure $ CRVersionInfo versionNumber
  DebugLocks -> do
@@ -1202,6 +1201,21 @@ processChatCommand = \case
          void (sendDirectContactMessage ct' $ XInfo p') `catchError` (toView . CRChatError)
          when (directContact ct) $ createFeatureChangedItems user ct ct' CDDirectSnd CISndChatFeature
          pure $ CRContactPrefsUpdated ct ct'
+    runUpdateGroupProfile :: User -> Group -> GroupProfile -> m ChatResponse
+    runUpdateGroupProfile user (Group g@GroupInfo {groupProfile = p} ms) p' = do
+      let s = memberStatus $ membership g
+          canUpdate =
+            memberRole (membership g :: GroupMember) == GROwner
+              || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited)
+      unless canUpdate $ throwChatError CEGroupUserRole
+      g' <- withStore $ \db -> updateGroupProfile db user g p'
+      msg <- sendGroupMessage g' ms (XGrpInfo p')
+      let cd = CDGroupSnd g'
+      unless (sameGroupProfileInfo p p') $ do
+        ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') Nothing Nothing
+        toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat g') ci
+      createGroupFeatureChangedItems user cd CISndGroupFeature p p'
+      pure $ CRGroupUpdated g g' Nothing
    isReady :: Contact -> Bool
    isReady ct =
      let s = connStatus $ activeConn (ct :: Contact)
@@ -2412,7 +2426,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =

    receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> m ()
    receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _
-      | chunkNo == 1 = throwChatError $ CEFileLargeSentInline fileId
+      | chunkNo == 1 = throwChatError $ CEInlineFileProhibited fileId
      | otherwise = pure ()
    receiveInlineChunk ft chunk meta = do
      case chunk of
@@ -3384,6 +3398,9 @@ chatCommandP =
      "/profile_image" $> UpdateProfileImage Nothing,
      ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> userNames),
      ("/profile" <|> "/p") $> ShowProfile,
+      "/voice #" *> (SetGroupFeature CFVoice <$> displayName <*> (A.space *> strP)),
+      "/voice @" *> (SetContactFeature CFVoice <$> displayName <*> optional (A.space *> strP)),
+      "/voice " *> (SetUserFeature CFVoice <$> strP),
      "/incognito " *> (SetIncognito <$> onOffP),
      ("/quit" <|> "/q" <|> "/exit") $> QuitChat,
      ("/version" <|> "/v") $> ShowVersion,
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -250,6 +250,9 @@ data ChatCommand
  | ShowProfile
  | UpdateProfile ContactName Text
  | UpdateProfileImage (Maybe ImageData)
+  | SetUserFeature ChatFeature FeatureAllowed
+  | SetContactFeature ChatFeature ContactName (Maybe FeatureAllowed)
+  | SetGroupFeature ChatFeature GroupName GroupFeatureEnabled
  | QuitChat
  | ShowVersion
  | DebugLocks
@@ -536,7 +539,7 @@ data ChatErrorType
  | CEFileImageType {filePath :: FilePath}
  | CEFileImageSize {filePath :: FilePath}
  | CEFileNotReceived {fileId :: FileTransferId}
-  | CEFileLargeSentInline {fileId :: FileTransferId}
+  | CEInlineFileProhibited {fileId :: FileTransferId}
  | CEInvalidQuote
  | CEInvalidChatItemUpdate
  | CEInvalidChatItemDelete
--- a/src/Simplex/Chat/Types.hs
+++ b/src/Simplex/Chat/Types.hs
@@ -303,6 +303,14 @@ instance PreferenceI FullPreferences where
    CFVoice -> voice
  {-# INLINE getPreference #-}

+setPreference :: ChatFeature -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences
+setPreference f allow_ prefs_ =
+  let prefs = toChatPrefs $ mergePreferences Nothing prefs_
+      pref = (\allow -> (getPreference f prefs :: Preference) {allow}) <$> allow_
+   in case f of
+        CFVoice -> prefs {voice = pref}
+        CFFullDelete -> prefs {fullDelete = pref}
+
 -- collection of optional chat preferences for the user and the contact
 data Preferences = Preferences
  { fullDelete :: Maybe Preference,
@@ -361,6 +369,14 @@ instance ToField GroupPreferences where
 instance FromField GroupPreferences where
  fromField = fromTextField_ decodeJSON

+setGroupPreference :: ChatFeature -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences
+setGroupPreference f enable prefs_ =
+  let prefs = mergeGroupPreferences prefs_
+      pref = (getGroupPreference f prefs :: GroupPreference) {enable}
+   in toGroupPreferences $ case f of
+        CFVoice -> prefs {voice = pref}
+        CFFullDelete -> prefs {fullDelete = pref}
+
 -- full collection of chat preferences defined in the app - it is used to ensure we include all preferences and to simplify processing
 -- if some of the preferences are not defined in Preferences, defaults from defaultChatPrefs are used here.
 data FullPreferences = FullPreferences
@@ -534,6 +550,16 @@ mergeGroupPreferences groupPreferences =
  where
    pref pt = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPreferences >>= groupPrefSel pt)

+toGroupPreferences :: FullGroupPreferences -> GroupPreferences
+toGroupPreferences groupPreferences =
+  GroupPreferences
+    { fullDelete = pref CFFullDelete,
+      -- receipts = pref CFReceipts,
+      voice = pref CFVoice
+    }
+  where
+    pref f = Just $ getGroupPreference f groupPreferences
+
 data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool}
  deriving (Eq, Show, Generic, FromJSON)

--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@@ -1083,7 +1083,7 @@ viewChatError = \case
    CEFileImageType _ -> ["image type must be jpg, send as a file using " <> highlight' "/f"]
    CEFileImageSize _ -> ["max image size: " <> sShow maxImageSize <> " bytes, resize it or send as a file using " <> highlight' "/f"]
    CEFileNotReceived fileId -> ["file " <> sShow fileId <> " not received"]
-    CEFileLargeSentInline _ -> ["A small file sent without acceptance - you can enable receiving such files automatically with -f option."]
+    CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."]
    CEInvalidQuote -> ["cannot reply to this message"]
    CEInvalidChatItemUpdate -> ["cannot update this item"]
    CEInvalidChatItemDelete -> ["cannot delete this item"]
--- a/tests/ChatTests.hs
+++ b/tests/ChatTests.hs
@@ -80,6 +80,7 @@ chatTests = do
    describe "send and receive file" $ fileTestMatrix2 runTestFileTransfer
    it "send and receive file inline (without accepting)" testInlineFileTransfer
    it "send and receive small file inline (default config)" testSmallInlineFileTransfer
+    it "small file sent without acceptance is ignored in terminal by default" testSmallInlineFileIgnored
    it "receive file inline with inline=on option" testReceiveInline
    describe "send and receive a small file" $ fileTestMatrix2 runTestSmallFileTransfer
    describe "sender cancelled file transfer before transfer" $ fileTestMatrix2 runTestFileSndCancelBeforeTransfer
@@ -88,6 +89,7 @@ chatTests = do
    describe "send and receive file to group" $ fileTestMatrix3 runTestGroupFileTransfer
    it "send and receive file inline to group (without accepting)" testInlineGroupFileTransfer
    it "send and receive small file inline to group (default config)" testSmallInlineGroupFileTransfer
+    it "small file sent without acceptance is ignored in terminal by default" testSmallInlineGroupFileIgnored
    describe "sender cancelled group file transfer before transfer" $ fileTestMatrix3 runTestGroupFileSndCancelBeforeTransfer
  describe "messages with files" $ do
    describe "send and receive message with file" $ fileTestMatrix2 runTestMessageWithFile
@@ -1616,7 +1618,7 @@ testInlineFileTransfer =

 testSmallInlineFileTransfer :: IO ()
 testSmallInlineFileTransfer =
-  testChatCfg2 testCfg aliceProfile bobProfile $ \alice bob -> do
+  testChat2 aliceProfile bobProfile $ \alice bob -> do
    connectUsers alice bob
    bob ##> "/_files_folder ./tests/tmp/"
    bob <## "ok"
@@ -1637,6 +1639,28 @@ testSmallInlineFileTransfer =
    dest <- B.readFile "./tests/tmp/logo.jpg"
    dest `shouldBe` src

+testSmallInlineFileIgnored :: IO ()
+testSmallInlineFileIgnored = withTmpFiles $ do
+  withNewTestChat "alice" aliceProfile $ \alice ->
+    withNewTestChatOpts testOpts {allowInstantFiles = False} "bob" bobProfile $ \bob -> do
+      connectUsers alice bob
+      bob ##> "/_files_folder ./tests/tmp/"
+      bob <## "ok"
+      alice ##> "/_send @2 json {\"msgContent\":{\"type\":\"voice\", \"duration\":10, \"text\":\"\"}, \"filePath\":\"./tests/fixtures/logo.jpg\"}"
+      alice <# "@bob voice message (00:10)"
+      alice <# "/f @bob ./tests/fixtures/logo.jpg"
+      -- below is not shown in "sent" mode
+      -- alice <## "use /fc 1 to cancel sending"
+      bob <# "alice> voice message (00:10)"
+      bob <# "alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
+      bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
+      bob <## "A small file sent without acceptance - you can enable receiving such files with -f option."
+      -- below is not shown in "sent" mode
+      -- bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
+      alice <## "completed sending file 1 (logo.jpg) to bob"
+      bob ##> "/fr 1"
+      bob <## "file is already being received: logo.jpg"
+
 testReceiveInline :: IO ()
 testReceiveInline =
  testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
@@ -1868,6 +1892,45 @@ testSmallInlineGroupFileTransfer =
      dest1 `shouldBe` src
      dest2 `shouldBe` src

+testSmallInlineGroupFileIgnored :: IO ()
+testSmallInlineGroupFileIgnored = withTmpFiles $ do
+  withNewTestChat "alice" aliceProfile $ \alice ->
+    withNewTestChatOpts testOpts {allowInstantFiles = False} "bob" bobProfile $ \bob -> do
+      withNewTestChatOpts testOpts {allowInstantFiles = False} "cath" cathProfile $ \cath -> do
+        createGroup3 "team" alice bob cath
+        bob ##> "/_files_folder ./tests/tmp/bob/"
+        bob <## "ok"
+        cath ##> "/_files_folder ./tests/tmp/cath/"
+        cath <## "ok"
+        alice ##> "/_send #1 json {\"msgContent\":{\"type\":\"voice\", \"duration\":10, \"text\":\"\"}, \"filePath\":\"./tests/fixtures/logo.jpg\"}"
+        alice <# "#team voice message (00:10)"
+        alice <# "/f #team ./tests/fixtures/logo.jpg"
+        -- below is not shown in "sent" mode
+        -- alice <## "use /fc 1 to cancel sending"
+        concurrentlyN_
+          [ do
+              alice
+                <### [ "completed sending file 1 (logo.jpg) to bob",
+                       "completed sending file 1 (logo.jpg) to cath"
+                     ]
+              alice ##> "/fs 1"
+              alice <##. "sending file 1 (logo.jpg) complete",
+            do
+              bob <# "#team alice> voice message (00:10)"
+              bob <# "#team alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
+              bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
+              bob <## "A small file sent without acceptance - you can enable receiving such files with -f option."
+              bob ##> "/fr 1"
+              bob <## "file is already being received: logo.jpg",
+            do
+              cath <# "#team alice> voice message (00:10)"
+              cath <# "#team alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
+              cath <## "use /fr 1 [<dir>/ | <path>] to receive it"
+              cath <## "A small file sent without acceptance - you can enable receiving such files with -f option."
+              cath ##> "/fr 1"
+              cath <## "file is already being received: logo.jpg"
+          ]
+
 runTestGroupFileSndCancelBeforeTransfer :: TestCC -> TestCC -> TestCC -> IO ()
 runTestGroupFileSndCancelBeforeTransfer alice bob cath = do
  createGroup3 "team" alice bob cath
@@ -2938,7 +3001,8 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $
    alice <## voiceNotAllowed
    bob ##> sendVoice
    bob <## voiceNotAllowed
-    alice ##> "/_set prefs @2 {\"voice\": {\"allow\": \"always\"}}"
+    -- alice ##> "/_set prefs @2 {\"voice\": {\"allow\": \"always\"}}"
+    alice ##> "/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")])
@@ -2956,13 +3020,11 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $
    alice <## "started receiving file 1 (test.txt) from bob"
    alice <## "completed receiving file 1 (test.txt) from bob"
    (bob </)
-    alice ##> "/_profile {\"displayName\": \"alice\", \"fullName\": \"\", \"preferences\": {\"voice\": {\"allow\": \"no\"}}}"
-    alice <## "user full name removed (your contacts are notified)"
+    -- alice ##> "/_profile {\"displayName\": \"alice\", \"fullName\": \"Alice\", \"preferences\": {\"voice\": {\"allow\": \"no\"}}}"
+    alice ##> "/voice no"
    alice <## "updated preferences:"
    alice <## "voice messages allowed: no"
    (alice </)
-    bob <## "contact alice removed full name"
-    (bob </)
    alice ##> "/_set prefs @2 {\"voice\": {\"allow\": \"yes\"}}"
    alice <## "you updated preferences for bob:"
    alice <## "voice messages: off (you allow: yes, contact allows: no)"
@@ -3024,7 +3086,8 @@ testUpdateGroupPrefs =
      bob <## "voice messages enabled: off"
      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 ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}}}"
+      alice ##> "/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")])