From ece928d57e7b35f46c0c219c27246f5856929085 Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Wed, 21 Dec 2022 19:54:44 +0400 Subject: [PATCH] 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 | 61 ++++++++++++++++++++++---------- src/Simplex/Chat/Store.hs | 24 ++++++++----- src/Simplex/Chat/Types.hs | 8 ++--- tests/ChatTests.hs | 74 +++++++++++++++++++++++++++++++++++++-- 4 files changed, 133 insertions(+), 34 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 5adecc9d29..072fe2312b 100644 --- a/src/Simplex/Chat.hs +++ b/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 diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 6441ca0e84..7824cf3e87 100644 --- a/src/Simplex/Chat/Store.hs +++ b/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 = diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index d77e3a0a2d..b586c7e337 100644 --- a/src/Simplex/Chat/Types.hs +++ b/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 = diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 72f5bdb56a..07e3e55dac 100644 --- a/tests/ChatTests.hs +++ b/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 =