core: fix current user becoming incorrect after hiding or (un)muting inactive user profile (#2098)

* core: fix current user becoming incorrect after hiding or (un)muting inactive user profile

* refactor test
This commit is contained in:
Evgeny Poberezkin 2023-03-29 17:39:04 +01:00 committed by GitHub
parent 7b33e1fba8
commit a8c8137ade
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 34 additions and 28 deletions

View File

@ -335,7 +335,7 @@ processChatCommand = \case
tryError (withStore (`getUserIdByName` uName)) >>= \case tryError (withStore (`getUserIdByName` uName)) >>= \case
Left _ -> throwChatError CEUserUnknown Left _ -> throwChatError CEUserUnknown
Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_ Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_
APIHideUser userId' (UserPwd viewPwd) -> withUser $ \_ -> do APIHideUser userId' (UserPwd viewPwd) -> withUser $ \user -> do
user' <- privateGetUser userId' user' <- privateGetUser userId'
case viewPwdHash user' of case viewPwdHash user' of
Just _ -> throwChatError $ CEUserAlreadyHidden userId' Just _ -> throwChatError $ CEUserAlreadyHidden userId'
@ -344,7 +344,7 @@ processChatCommand = \case
users <- withStore' getUsers users <- withStore' getUsers
unless (length (filter (isNothing . viewPwdHash) users) > 1) $ throwChatError $ CECantHideLastUser userId' unless (length (filter (isNothing . viewPwdHash) users) > 1) $ throwChatError $ CECantHideLastUser userId'
viewPwdHash' <- hashPassword viewPwdHash' <- hashPassword
setUserPrivacy user' {viewPwdHash = viewPwdHash', showNtfs = False} setUserPrivacy user user' {viewPwdHash = viewPwdHash', showNtfs = False}
where where
hashPassword = do hashPassword = do
salt <- drgRandomBytes 16 salt <- drgRandomBytes 16
@ -356,18 +356,18 @@ processChatCommand = \case
Nothing -> throwChatError $ CEUserNotHidden userId' Nothing -> throwChatError $ CEUserNotHidden userId'
_ -> do _ -> do
validateUserPassword user user' viewPwd_ validateUserPassword user user' viewPwd_
setUserPrivacy user' {viewPwdHash = Nothing, showNtfs = True} setUserPrivacy user user' {viewPwdHash = Nothing, showNtfs = True}
APIMuteUser userId' viewPwd_ -> withUser $ \user -> do APIMuteUser userId' viewPwd_ -> withUser $ \user -> do
user' <- privateGetUser userId' user' <- privateGetUser userId'
validateUserPassword user user' viewPwd_ validateUserPassword user user' viewPwd_
setUserPrivacy user' {showNtfs = False} setUserPrivacy user user' {showNtfs = False}
APIUnmuteUser userId' viewPwd_ -> withUser $ \user -> do APIUnmuteUser userId' viewPwd_ -> withUser $ \user -> do
user' <- privateGetUser userId' user' <- privateGetUser userId'
case viewPwdHash user' of case viewPwdHash user' of
Just _ -> throwChatError $ CECantUnmuteHiddenUser userId' Just _ -> throwChatError $ CECantUnmuteHiddenUser userId'
_ -> do _ -> do
validateUserPassword user user' viewPwd_ validateUserPassword user user' viewPwd_
setUserPrivacy user' {showNtfs = True} setUserPrivacy user user' {showNtfs = True}
HideUser viewPwd -> withUser $ \User {userId} -> processChatCommand $ APIHideUser userId viewPwd HideUser viewPwd -> withUser $ \User {userId} -> processChatCommand $ APIHideUser userId viewPwd
UnhideUser -> withUser $ \User {userId} -> processChatCommand $ APIUnhideUser userId Nothing UnhideUser -> withUser $ \User {userId} -> processChatCommand $ APIUnhideUser userId Nothing
MuteUser -> withUser $ \User {userId} -> processChatCommand $ APIMuteUser userId Nothing MuteUser -> withUser $ \User {userId} -> processChatCommand $ APIMuteUser userId Nothing
@ -1706,11 +1706,15 @@ processChatCommand = \case
validPassword :: Text -> UserPwdHash -> Bool validPassword :: Text -> UserPwdHash -> Bool
validPassword pwd UserPwdHash {hash = B64UrlByteString hash, salt = B64UrlByteString salt} = validPassword pwd UserPwdHash {hash = B64UrlByteString hash, salt = B64UrlByteString salt} =
hash == C.sha512Hash (encodeUtf8 pwd <> salt) hash == C.sha512Hash (encodeUtf8 pwd <> salt)
setUserPrivacy :: User -> m ChatResponse setUserPrivacy :: User -> User -> m ChatResponse
setUserPrivacy user = do setUserPrivacy user@User {userId} user'@User {userId = userId'}
asks currentUser >>= atomically . (`writeTVar` Just user) | userId == userId' = do
withStore' (`updateUserPrivacy` user) asks currentUser >>= atomically . (`writeTVar` Just user')
pure $ CRUserPrivacy user withStore' (`updateUserPrivacy` user')
pure $ CRUserPrivacy {user = user', updatedUser = user'}
| otherwise = do
withStore' (`updateUserPrivacy` user')
pure $ CRUserPrivacy {user, updatedUser = user'}
checkDeleteChatUser :: User -> m () checkDeleteChatUser :: User -> m ()
checkDeleteChatUser user@User {userId} = do checkDeleteChatUser user@User {userId} = do
when (activeUser user) $ throwChatError (CECantDeleteActiveUser userId) when (activeUser user) $ throwChatError (CECantDeleteActiveUser userId)

View File

@ -421,7 +421,7 @@ data ChatResponse
| CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus | CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus
| CRUserProfile {user :: User, profile :: Profile} | CRUserProfile {user :: User, profile :: Profile}
| CRUserProfileNoChange {user :: User} | CRUserProfileNoChange {user :: User}
| CRUserPrivacy {user :: User} | CRUserPrivacy {user :: User, updatedUser :: User}
| CRVersionInfo {versionInfo :: CoreVersionInfo, chatMigrations :: [UpMigration], agentMigrations :: [UpMigration]} | CRVersionInfo {versionInfo :: CoreVersionInfo, chatMigrations :: [UpMigration], agentMigrations :: [UpMigration]}
| CRInvitation {user :: User, connReqInvitation :: ConnReqInvitation} | CRInvitation {user :: User, connReqInvitation :: ConnReqInvitation}
| CRSentConfirmation {user :: User} | CRSentConfirmation {user :: User}

View File

@ -116,7 +116,7 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
CRFileTransferStatus u ftStatus -> ttyUser u $ viewFileTransferStatus ftStatus CRFileTransferStatus u ftStatus -> ttyUser u $ viewFileTransferStatus ftStatus
CRUserProfile u p -> ttyUser u $ viewUserProfile p CRUserProfile u p -> ttyUser u $ viewUserProfile p
CRUserProfileNoChange u -> ttyUser u ["user profile did not change"] CRUserProfileNoChange u -> ttyUser u ["user profile did not change"]
CRUserPrivacy u -> ttyUserPrefix u $ viewUserPrivacy u CRUserPrivacy u u' -> ttyUserPrefix u $ viewUserPrivacy u u'
CRVersionInfo info _ _ -> viewVersionInfo logLevel info CRVersionInfo info _ _ -> viewVersionInfo logLevel info
CRInvitation u cReq -> ttyUser u $ viewConnReqInvitation cReq CRInvitation u cReq -> ttyUser u $ viewConnReqInvitation cReq
CRSentConfirmation u -> ttyUser u ["confirmation sent!"] CRSentConfirmation u -> ttyUser u ["confirmation sent!"]
@ -740,10 +740,11 @@ viewUserProfile Profile {displayName, fullName} =
"(the updated profile will be sent to all your contacts)" "(the updated profile will be sent to all your contacts)"
] ]
viewUserPrivacy :: User -> [StyledString] viewUserPrivacy :: User -> User -> [StyledString]
viewUserPrivacy User {showNtfs, viewPwdHash} = viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', showNtfs, viewPwdHash} =
[ "user messages are " <> if showNtfs then "shown" else "hidden (use /tail to view)", [ (if userId == userId' then "current " else "") <> "user " <> plain n' <> ":",
"user profile is " <> if isJust viewPwdHash then "hidden" else "visible" "messages are " <> if showNtfs then "shown" else "hidden (use /tail to view)",
"profile is " <> if isJust viewPwdHash then "hidden" else "visible"
] ]
-- TODO make more generic messages or split -- TODO make more generic messages or split

View File

@ -1518,7 +1518,7 @@ testUserPrivacy =
alice <# "bob> hey" alice <# "bob> hey"
-- hide user profile -- hide user profile
alice ##> "/hide user my_password" alice ##> "/hide user my_password"
userHidden alice userHidden alice "current "
-- shows messages when active -- shows messages when active
bob #> "@alisa hello again" bob #> "@alisa hello again"
alice <# "bob> hello again" alice <# "bob> hello again"
@ -1559,9 +1559,9 @@ testUserPrivacy =
alice ##> "/hide user password" alice ##> "/hide user password"
alice <## "user is already hidden" alice <## "user is already hidden"
alice ##> "/unhide user" alice ##> "/unhide user"
userVisible alice userVisible alice "current "
alice ##> "/hide user new_password" alice ##> "/hide user new_password"
userHidden alice userHidden alice "current "
alice ##> "/_delete user 1 del_smp=on" alice ##> "/_delete user 1 del_smp=on"
alice <## "cannot delete last user" alice <## "cannot delete last user"
alice ##> "/_hide user 1 \"password\"" alice ##> "/_hide user 1 \"password\""
@ -1578,10 +1578,9 @@ testUserPrivacy =
alice ##> "/_unhide user 2 \"wrong_password\"" alice ##> "/_unhide user 2 \"wrong_password\""
alice <## "user does not exist or incorrect password" alice <## "user does not exist or incorrect password"
alice ##> "/_unhide user 2 \"new_password\"" alice ##> "/_unhide user 2 \"new_password\""
userVisible alice userVisible alice ""
alice ##> "/_hide user 2 \"another_password\"" alice ##> "/_hide user 2 \"another_password\""
userHidden alice userHidden alice ""
-- check new password
alice ##> "/user alisa another_password" alice ##> "/user alisa another_password"
showActiveUser alice "alisa" showActiveUser alice "alisa"
alice ##> "/user alice" alice ##> "/user alice"
@ -1594,12 +1593,14 @@ testUserPrivacy =
alice <## "ok" alice <## "ok"
alice <## "completed deleting user" alice <## "completed deleting user"
where where
userHidden alice = do userHidden alice current = do
alice <## "user messages are hidden (use /tail to view)" alice <## (current <> "user alisa:")
alice <## "user profile is hidden" alice <## "messages are hidden (use /tail to view)"
userVisible alice = do alice <## "profile is hidden"
alice <## "user messages are shown" userVisible alice current = do
alice <## "user profile is visible" alice <## (current <> "user alisa:")
alice <## "messages are shown"
alice <## "profile is visible"
testSetChatItemTTL :: HasCallStack => FilePath -> IO () testSetChatItemTTL :: HasCallStack => FilePath -> IO ()
testSetChatItemTTL = testSetChatItemTTL =