core: update ttl in contact user preference on profile update, fix api, tests; fix global user preferences not being updated in controller state (#1617)

src/Simplex/Chat.hs

@@ -1284,22 +1284,24 @@ processChatCommand = \case
       | chunks <= sendChunks && chunks * n <= totalSendChunks && isVoice mc = Just IFMSent
       | otherwise = Just IFMOffer
     updateProfile :: User -> Profile -> m ChatResponse
-    updateProfile user@User {profile = p@LocalProfile {profileId, localAlias}} p'@Profile {displayName}
+    updateProfile user@User {profile = p} p'
       | p' == fromLocalProfile p = pure CRUserProfileNoChange
       | otherwise = do
-        withStore $ \db -> updateUserProfile db user p'
-        let user' = (user :: User) {localDisplayName = displayName, profile = toLocalProfile profileId p' localAlias}
-        asks currentUser >>= atomically . (`writeTVar` Just user')
+        -- read contacts before user update to correctly merge preferences
         -- [incognito] filter out contacts with whom user has incognito connections
         contacts <-
           filter (\ct -> isReady ct && not (contactConnIncognito ct))
             <$> withStore' (`getUserContacts` user)
+        user' <- withStore $ \db -> updateUserProfile db user p'
+        asks currentUser >>= atomically . (`writeTVar` Just user')
         withChatLock "updateProfile" . procCmd $ do
           forM_ contacts $ \ct -> do
-            let mergedProfile = userProfileToSend user' Nothing $ Just ct
+            let mergedProfile = userProfileToSend user Nothing $ Just ct
                 ct' = updateMergedPreferences user' ct
-            void (sendDirectContactMessage ct $ XInfo mergedProfile) `catchError` (toView . CRChatError)
-            when (directOrUsed ct) $ createFeatureChangedItems user' ct ct' CDDirectSnd CISndChatFeature
+                mergedProfile' = userProfileToSend user' Nothing $ Just ct'
+            when (mergedProfile' /= mergedProfile) $ do
+              void (sendDirectContactMessage ct' $ XInfo mergedProfile') `catchError` (toView . CRChatError)
+              when (directOrUsed ct') $ createFeatureChangedItems user' ct ct' CDDirectSnd CISndChatFeature
           pure $ CRUserProfileUpdated (fromLocalProfile p) p'
     updateContactPrefs :: User -> Contact -> Preferences -> m ChatResponse
     updateContactPrefs user@User {userId} ct@Contact {activeConn = Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs'
@@ -1308,11 +1310,13 @@ processChatCommand = \case
         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')
-        withChatLock "updateProfile" . procCmd $ do
-          void (sendDirectContactMessage ct' $ XInfo p') `catchError` (toView . CRChatError)
-          when (directOrUsed ct) $ createFeatureChangedItems user ct ct' CDDirectSnd CISndChatFeature
-          pure $ CRContactPrefsUpdated ct ct'
+        let mergedProfile = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct)
+            mergedProfile' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct')
+        when (mergedProfile' /= mergedProfile) $
+          withChatLock "updateProfile" $ do
+            void (sendDirectContactMessage ct' $ XInfo mergedProfile') `catchError` (toView . CRChatError)
+            when (directOrUsed 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
@@ -2771,9 +2775,28 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
 
     xInfo :: Contact -> Profile -> m ()
     xInfo c@Contact {profile = p} p' = unless (fromLocalProfile p == p') $ do
-      c' <- withStore $ \db -> updateContactProfile db user c p'
+      c' <- withStore $ \db ->
+        if userTTL == rcvTTL
+          then updateContactProfile db user c p'
+          else do
+            c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs'
+            updateContactProfile db user c' p'
+      when (directOrUsed c') $ createFeatureChangedItems user c c' CDDirectRcv CIRcvChatFeature
       toView $ CRContactUpdated c c'
-      when (directOrUsed c) $ createFeatureChangedItems user c c' CDDirectRcv CIRcvChatFeature
+      where
+        Contact {userPreferences = ctUserPrefs@Preferences {timedMessages = ctUserTMPref}} = c
+        userTTL = prefParam $ getPreference SCFTimedMessages ctUserPrefs
+        Profile {preferences = rcvPrefs_} = p'
+        rcvTTL = prefParam $ getPreference SCFTimedMessages rcvPrefs_
+        ctUserPrefs' =
+          let userDefault = getPreference SCFTimedMessages (fullPreferences user)
+              userDefaultTTL = prefParam userDefault
+              ctUserTMPref' = case ctUserTMPref of
+                Just userTM -> Just (userTM :: TimedMessagesPreference) {ttl = rcvTTL}
+                _
+                  | rcvTTL /= userDefaultTTL -> Just (userDefault :: TimedMessagesPreference) {ttl = rcvTTL}
+                  | otherwise -> Nothing
+           in setPreference_ SCFTimedMessages ctUserTMPref' ctUserPrefs
 
     createFeatureEnabledItems :: Contact -> m ()
     createFeatureEnabledItems ct@Contact {mergedPreferences} =
@@ -3702,9 +3725,9 @@ chatCommandP =
       "/set delete @" *> (SetContactFeature (ACF SCFFullDelete) <$> displayName <*> optional (A.space *> strP)),
       "/set delete " *> (SetUserFeature (ACF SCFFullDelete) <$> strP),
       "/set direct #" *> (SetGroupFeature (AGF SGFDirectMessages) <$> displayName <*> (A.space *> strP)),
-      "/set disappear #" *> (SetGroupTimedMessages <$> displayName <*> (A.space *> timedTTLOffP)),
+      "/set disappear #" *> (SetGroupTimedMessages <$> displayName <*> (A.space *> timedTTLOnOffP)),
       "/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)),
-      "/set disappear " *> (SetUserTimedMessages <$> onOffP),
+      "/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
       "/incognito " *> (SetIncognito <$> onOffP),
       ("/quit" <|> "/q" <|> "/exit") $> QuitChat,
       ("/version" <|> "/v") $> ShowVersion,
@@ -3774,9 +3797,11 @@ chatCommandP =
         <|> ("day" $> 86400)
         <|> ("week" $> (7 * 86400))
         <|> ("month" $> (30 * 86400))
-    timedTTLOffP = (Just <$> timedTTLP) <|> ("off" $> Nothing)
+    timedTTLOnOffP =
+      optional ("on" *> A.space) *> (Just <$> timedTTLP)
+        <|> ("off" $> Nothing)
     timedMessagesEnabledP =
-      optional "yes" *> A.space *> (TMEEnableSetTTL <$> timedTTLP)
+      optional ("yes" *> A.space) *> (TMEEnableSetTTL <$> timedTTLP)
         <|> ("yes" $> TMEEnableKeepTTL)
         <|> ("no" $> TMEDisableKeepTTL)
     netCfgP = do

src/Simplex/Chat/Store.hs

@@ -588,7 +588,7 @@ createContact_ db userId connId Profile {displayName, fullName, image, preferenc
       (profileId, ldn, userId, viaGroup, currentTs, currentTs)
     contactId <- insertedRowId db
     DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId)
-    pure . Right $ (ldn, contactId, profileId)
+    pure $ Right (ldn, contactId, profileId)
 
 deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO ()
 deleteContactConnectionsAndFiles db userId Contact {contactId} = do
@@ -660,10 +660,11 @@ deleteContactProfile_ db userId contactId =
     |]
     (userId, contactId)
 
-updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO ()
-updateUserProfile db User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName}} p'@Profile {displayName = newName}
-  | displayName == newName =
+updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
+updateUserProfile db user p'
+  | displayName == newName = do
     liftIO $ updateContactProfile_ db userId profileId p'
+    pure user {profile, fullPreferences}
   | otherwise =
     checkConstraint SEDuplicateName . liftIO $ do
       currentTs <- getCurrentTime
@@ -674,18 +675,24 @@ updateUserProfile db User {userId, userContactId, localDisplayName, profile = Lo
         (newName, newName, userId, currentTs, currentTs)
       updateContactProfile_' db userId profileId p' currentTs
       updateContact_ db userId userContactId localDisplayName newName currentTs
+      pure user {localDisplayName = newName, profile, fullPreferences}
+  where
+    User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user
+    Profile {displayName = newName, preferences} = p'
+    profile = toLocalProfile profileId p' localAlias
+    fullPreferences = mergePreferences Nothing preferences
 
 updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
 updateContactProfile db user@User {userId} c p'
   | displayName == newName = do
     liftIO $ updateContactProfile_ db userId profileId p'
-    pure $ c {profile, mergedPreferences}
+    pure c {profile, mergedPreferences}
   | otherwise =
     ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
       currentTs <- getCurrentTime
       updateContactProfile_' db userId profileId p' currentTs
       updateContact_ db userId contactId localDisplayName ldn currentTs
-      pure . Right $ c {localDisplayName = ldn, profile, mergedPreferences}
+      pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
   where
     Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, activeConn, userPreferences} = c
     Profile {displayName = newName, preferences} = p'
@@ -3748,13 +3755,14 @@ updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> Exce
 updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences}
   | displayName == newName = liftIO $ do
     currentTs <- getCurrentTime
-    updateGroupProfile_ currentTs $> (g :: GroupInfo) {groupProfile = p', fullGroupPreferences}
+    updateGroupProfile_ currentTs
+    pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences}
   | otherwise =
     ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
       currentTs <- getCurrentTime
       updateGroupProfile_ currentTs
       updateGroup_ ldn currentTs
-      pure . Right $ (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences}
+      pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences}
   where
     fullGroupPreferences = mergeGroupPreferences groupPreferences
     updateGroupProfile_ currentTs =

src/Simplex/Chat/Types.hs

@@ -338,17 +338,15 @@ instance PreferenceI FullPreferences where
   {-# INLINE getPreference #-}
 
 setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences
-setPreference f allow_ prefs_ = setPreference_ f pref prefs
+setPreference f allow_ prefs_ = setPreference_ f pref $ fromMaybe emptyChatPrefs prefs_
   where
     pref = setAllow <$> allow_
     setAllow :: FeatureAllowed -> FeaturePreference f
     setAllow = setField @"allow" (getPreference f prefs)
-    prefs = toChatPrefs $ mergePreferences Nothing prefs_
+    prefs = mergePreferences Nothing prefs_
 
 setPreference' :: SChatFeature f -> Maybe (FeaturePreference f) -> Maybe Preferences -> Preferences
-setPreference' f pref_ prefs_ = setPreference_ f pref_ prefs
-  where
-    prefs = toChatPrefs $ mergePreferences Nothing prefs_
+setPreference' f pref_ prefs_ = setPreference_ f pref_ $ fromMaybe emptyChatPrefs prefs_
 
 setPreference_ :: SChatFeature f -> Maybe (FeaturePreference f) -> Preferences -> Preferences
 setPreference_ f pref_ prefs =

tests/ChatTests.hs

@@ -142,6 +142,7 @@ chatTests = do
     it "prohibit direct messages to group members" testProhibitDirectMessages
     it "enable timed messages with contact" testEnableTimedMessagesContact
     it "enable timed messages in group" testEnableTimedMessagesGroup
+    it "timed messages enabled globally, contact turns on" testTimedMessagesEnabledGlobally
   describe "SMP servers" $ do
     it "get and set SMP servers" testGetSetSMPServers
     it "test SMP server connection" testTestSMPServerConnection
@@ -3587,9 +3588,8 @@ testEnableTimedMessagesContact =
       alice <## "you updated preferences for bob:"
       alice <## "Disappearing messages: off (you allow: yes, after 1 sec, contact allows: no)"
       bob <## "alice updated preferences for you:"
-      bob <## "Disappearing messages: off (you allow: default (no), contact allows: yes, after 1 sec)"
-      -- TODO bob ##> "/set disappear @alice yes"
-      bob ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 1}}"
+      bob <## "Disappearing messages: off (you allow: no, contact allows: yes, after 1 sec)"
+      bob ##> "/set disappear @alice yes"
       bob <## "you updated preferences for alice:"
       bob <## "Disappearing messages: enabled (you allow: yes, after 1 sec, contact allows: yes, after 1 sec)"
       alice <## "bob updated preferences for you:"
@@ -3601,6 +3601,27 @@ testEnableTimedMessagesContact =
       threadDelay 1000000
       alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled, after 1 sec")])
       bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled, after 1 sec")])
+      -- turn off, messages are not disappearing
+      bob ##> "/set disappear @alice no"
+      bob <## "you updated preferences for alice:"
+      bob <## "Disappearing messages: off (you allow: no, contact allows: yes, after 1 sec)"
+      alice <## "bob updated preferences for you:"
+      alice <## "Disappearing messages: off (you allow: yes, after 1 sec, contact allows: no)"
+      alice <##> bob
+      threadDelay 1500000
+      alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled, after 1 sec"), (0, "Disappearing messages: off"), (1, "hi"), (0, "hey")])
+      bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled, after 1 sec"), (1, "Disappearing messages: off"), (0, "hi"), (1, "hey")])
+      -- test api
+      bob ##> "/set disappear @alice yes 30s"
+      bob <## "you updated preferences for alice:"
+      bob <## "Disappearing messages: enabled (you allow: yes, after 30 sec, contact allows: yes, after 1 sec)"
+      alice <## "bob updated preferences for you:"
+      alice <## "Disappearing messages: enabled (you allow: yes, after 30 sec, contact allows: yes, after 30 sec)"
+      bob ##> "/set disappear @alice week" -- "yes" is optional
+      bob <## "you updated preferences for alice:"
+      bob <## "Disappearing messages: enabled (you allow: yes, after 1 week, contact allows: yes, after 1 sec)"
+      alice <## "bob updated preferences for you:"
+      alice <## "Disappearing messages: enabled (you allow: yes, after 1 week, contact allows: yes, after 1 week)"
 
 testEnableTimedMessagesGroup :: IO ()
 testEnableTimedMessagesGroup =
@@ -3623,6 +3644,53 @@ testEnableTimedMessagesGroup =
       threadDelay 1000000
       alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Disappearing messages: on, after 1 sec")])
       bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on, after 1 sec")])
+      -- turn off, messages are not disappearing
+      alice ##> "/set disappear #team off"
+      alice <## "updated group preferences:"
+      alice <## "Disappearing messages enabled: off"
+      bob <## "alice updated group #team:"
+      bob <## "updated group preferences:"
+      bob <## "Disappearing messages enabled: off"
+      threadDelay 1000000
+      alice #> "#team hey"
+      bob <# "#team alice> hey"
+      threadDelay 1500000
+      alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Disappearing messages: on, after 1 sec"), (1, "Disappearing messages: off"), (1, "hey")])
+      bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on, after 1 sec"), (0, "Disappearing messages: off"), (0, "hey")])
+      -- test api
+      alice ##> "/set disappear #team on 30s"
+      alice <## "updated group preferences:"
+      alice <## "Disappearing messages enabled: on, after 30 sec"
+      bob <## "alice updated group #team:"
+      bob <## "updated group preferences:"
+      bob <## "Disappearing messages enabled: on, after 30 sec"
+      alice ##> "/set disappear #team week" -- "on" is optional
+      alice <## "updated group preferences:"
+      alice <## "Disappearing messages enabled: on, after 1 week"
+      bob <## "alice updated group #team:"
+      bob <## "updated group preferences:"
+      bob <## "Disappearing messages enabled: on, after 1 week"
+
+testTimedMessagesEnabledGlobally :: IO ()
+testTimedMessagesEnabledGlobally =
+  testChat2 aliceProfile bobProfile $
+    \alice bob -> do
+      alice ##> "/set disappear yes"
+      alice <## "updated preferences:"
+      alice <## "Disappearing messages allowed: yes"
+      connectUsers alice bob
+      bob ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 1}}"
+      bob <## "you updated preferences for alice:"
+      bob <## "Disappearing messages: enabled (you allow: yes, after 1 sec, contact allows: yes)"
+      alice <## "bob updated preferences for you:"
+      alice <## "Disappearing messages: enabled (you allow: yes, after 1 sec, contact allows: yes, after 1 sec)"
+      alice <##> bob
+      threadDelay 500000
+      alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled, after 1 sec"), (1, "hi"), (0, "hey")])
+      bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled, after 1 sec"), (0, "hi"), (1, "hey")])
+      threadDelay 1000000
+      alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled, after 1 sec")])
+      bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled, after 1 sec")])
 
 testGetSetSMPServers :: IO ()
 testGetSetSMPServers =