mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
core: update ttl in contact user preference on profile update, fix api, tests; fix global user preferences not being updated in controller state (#1617)
This commit is contained in:
JRoberts
GitHub
+43
-18
@@ -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
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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 =
|
||||
|
||||
Reference in New Issue
Block a user