core, iOS: hidden and muted user profiles (#2025)

* core, ios: profile privacy design

* migration

* core: user profile privacy

* update nix dependencies

* update simplexmq

* import stateTVar

* update core library

* update UI

* update hide/show user profile

* update API, UI, fix test

* update api, UI, test

* update api call

* fix api

* update UI for hidden profiles

* filter notifications on hidden/muted profiles when inactive, alerts

* updates

* update schema, test, icon

src/Simplex/Chat/Controller.hs

@@ -19,7 +19,7 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random (ChaChaDRG)
-import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
@@ -182,10 +182,18 @@ data ChatCommand
   = ShowActiveUser
   | CreateActiveUser Profile Bool
   | ListUsers
-  | APISetActiveUser UserId
-  | SetActiveUser UserName
-  | APIDeleteUser UserId Bool
-  | DeleteUser UserName Bool
+  | APISetActiveUser UserId (Maybe UserPwd)
+  | SetActiveUser UserName (Maybe UserPwd)
+  | APIHideUser UserId UserPwd
+  | APIUnhideUser UserId (Maybe UserPwd)
+  | APIMuteUser UserId (Maybe UserPwd)
+  | APIUnmuteUser UserId (Maybe UserPwd)
+  | HideUser UserPwd
+  | UnhideUser
+  | MuteUser
+  | UnmuteUser
+  | APIDeleteUser UserId Bool (Maybe UserPwd)
+  | DeleteUser UserName Bool (Maybe UserPwd)
   | StartChat {subscribeConnections :: Bool, enableExpireChatItems :: Bool}
   | APIStopChat
   | APIActivateChat
@@ -406,6 +414,7 @@ data ChatResponse
   | CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus
   | CRUserProfile {user :: User, profile :: Profile}
   | CRUserProfileNoChange {user :: User}
+  | CRUserPrivacy {user :: User}
   | CRVersionInfo {versionInfo :: CoreVersionInfo}
   | CRInvitation {user :: User, connReqInvitation :: ConnReqInvitation}
   | CRSentConfirmation {user :: User}
@@ -522,6 +531,16 @@ instance ToJSON ChatResponse where
   toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
   toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"
 
+newtype UserPwd = UserPwd {unUserPwd :: Text}
+  deriving (Eq, Show)
+
+instance FromJSON UserPwd where
+  parseJSON v = UserPwd <$> parseJSON v
+
+instance ToJSON UserPwd where
+  toJSON (UserPwd p) = toJSON p
+  toEncoding (UserPwd p) = toEncoding p
+
 newtype AgentQueueId = AgentQueueId QueueId
   deriving (Eq, Show)
 
@@ -683,11 +702,17 @@ instance ToJSON ChatError where
 data ChatErrorType
   = CENoActiveUser
   | CENoConnectionUser {agentConnId :: AgentConnId}
+  | CEUserUnknown
   | CEActiveUserExists -- TODO delete
   | CEUserExists {contactName :: ContactName}
   | CEDifferentActiveUser {commandUserId :: UserId, activeUserId :: UserId}
   | CECantDeleteActiveUser {userId :: UserId}
   | CECantDeleteLastUser {userId :: UserId}
+  | CECantHideLastUser {userId :: UserId}
+  | CECantUnmuteHiddenUser {userId :: UserId}
+  | CEEmptyUserPassword {userId :: UserId}
+  | CEUserAlreadyHidden {userId :: UserId}
+  | CEUserNotHidden {userId :: UserId}
   | CEChatNotStarted
   | CEChatNotStopped
   | CEChatStoreChanged
@@ -764,7 +789,9 @@ instance ToJSON SQLiteError where
 throwDBError :: ChatMonad m => DatabaseError -> m ()
 throwDBError = throwError . ChatErrorDatabase
 
-type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
+type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
+
+type ChatMonad m = (ChatMonad' m, MonadError ChatError m)
 
 chatCmdError :: Maybe User -> String -> ChatResponse
 chatCmdError user = CRChatCmdError user . ChatError . CECommandError

src/Simplex/Chat/Migrations/M20230317_hidden_profiles.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Migrations.M20230317_hidden_profiles where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230317_hidden_profiles :: Query
+m20230317_hidden_profiles =
+  [sql|
+ALTER TABLE users ADD COLUMN view_pwd_hash BLOB;
+ALTER TABLE users ADD COLUMN view_pwd_salt BLOB;
+ALTER TABLE users ADD COLUMN show_ntfs INTEGER NOT NULL DEFAULT 1;
+|]

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -30,7 +30,10 @@ CREATE TABLE users(
   active_user INTEGER NOT NULL DEFAULT 0,
   created_at TEXT CHECK(created_at NOT NULL),
   updated_at TEXT CHECK(updated_at NOT NULL),
-  agent_user_id INTEGER CHECK(agent_user_id NOT NULL), -- 1 for active user
+  agent_user_id INTEGER CHECK(agent_user_id NOT NULL),
+  view_pwd_hash BLOB,
+  view_pwd_salt BLOB,
+  show_ntfs INTEGER NOT NULL DEFAULT 1, -- 1 for active user
   FOREIGN KEY(user_id, local_display_name)
   REFERENCES display_names(user_id, local_display_name)
   ON DELETE CASCADE

src/Simplex/Chat/Mobile.hs

@@ -12,12 +12,15 @@ import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Aeson (ToJSON (..))
 import qualified Data.Aeson as J
+import qualified Data.ByteString.Base64.URL as U
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
 import Data.List (find)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word8)
 import Database.SQLite.Simple (SQLError (..))
 import qualified Database.SQLite.Simple as DB
@@ -65,6 +68,8 @@ foreign export ccall "chat_parse_markdown" cChatParseMarkdown :: CString -> IO C
 
 foreign export ccall "chat_parse_server" cChatParseServer :: CString -> IO CJSONString
 
+foreign export ccall "chat_password_hash" cChatPasswordHash :: CString -> CString -> IO CString
+
 foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
 
 foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
@@ -122,6 +127,12 @@ cChatParseMarkdown s = newCAString . chatParseMarkdown =<< peekCAString s
 cChatParseServer :: CString -> IO CJSONString
 cChatParseServer s = newCAString . chatParseServer =<< peekCAString s
 
+cChatPasswordHash :: CString -> CString -> IO CString
+cChatPasswordHash cPwd cSalt = do
+  pwd <- peekCAString cPwd
+  salt <- peekCAString cSalt
+  newCAString $ chatPasswordHash pwd salt
+
 mobileChatOpts :: String -> String -> ChatOpts
 mobileChatOpts dbFilePrefix dbKey =
   ChatOpts
@@ -241,6 +252,12 @@ chatParseServer = LB.unpack . J.encode . toServerAddress . strDecode . B.pack
     enc :: StrEncoding a => a -> String
     enc = B.unpack . strEncode
 
+chatPasswordHash :: String -> String -> String
+chatPasswordHash pwd salt = either (const "") passwordHash salt'
+  where
+    salt' = U.decode $ B.pack salt
+    passwordHash = B.unpack . U.encode . C.sha512Hash . (encodeUtf8 (T.pack pwd) <>)
+
 data APIResponse = APIResponse {corr :: Maybe CorrId, resp :: ChatResponse}
   deriving (Generic)
 

src/Simplex/Chat/Store.hs

@@ -39,6 +39,7 @@ module Simplex.Chat.Store
     getUserByContactRequestId,
     getUserFileInfo,
     deleteUserRecord,
+    updateUserPrivacy,
     createDirectConnection,
     createConnReqConnection,
     getProfileById,
@@ -277,6 +278,7 @@ import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (sortBy, sortOn)
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
 import Data.Ord (Down (..))
 import Data.Text (Text)
@@ -345,6 +347,7 @@ import Simplex.Chat.Migrations.M20230118_recreate_smp_servers
 import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx
 import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id
 import Simplex.Chat.Migrations.M20230303_group_link_role
+import Simplex.Chat.Migrations.M20230317_hidden_profiles
 -- import Simplex.Chat.Migrations.M20230304_file_description
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
@@ -412,7 +415,8 @@ schemaMigrations =
     ("20230118_recreate_smp_servers", m20230118_recreate_smp_servers),
     ("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx),
     ("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id),
-    ("20230303_group_link_role", m20230303_group_link_role)
+    ("20230303_group_link_role", m20230303_group_link_role),
+    ("20230317_hidden_profiles", m20230317_hidden_profiles)
     -- ("20230304_file_description", m20230304_file_description)
   ]
 
@@ -449,8 +453,8 @@ createUserRecord db (AgentUserId auId) Profile {displayName, fullName, image, pr
     when activeUser $ DB.execute_ db "UPDATE users SET active_user = 0"
     DB.execute
       db
-      "INSERT INTO users (agent_user_id, local_display_name, active_user, contact_id, created_at, updated_at) VALUES (?,?,?,0,?,?)"
-      (auId, displayName, activeUser, currentTs, currentTs)
+      "INSERT INTO users (agent_user_id, local_display_name, active_user, contact_id, show_ntfs, created_at, updated_at) VALUES (?,?,?,0,?,?,?)"
+      (auId, displayName, activeUser, True, currentTs, currentTs)
     userId <- insertedRowId db
     DB.execute
       db
@@ -467,7 +471,7 @@ createUserRecord db (AgentUserId auId) Profile {displayName, fullName, image, pr
       (profileId, displayName, userId, True, currentTs, currentTs)
     contactId <- insertedRowId db
     DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId)
-    pure $ toUser (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, userPreferences)
+    pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, userPreferences, True) :. (Nothing, Nothing)
 
 getUsersInfo :: DB.Connection -> IO [UserInfo]
 getUsersInfo db = getUsers db >>= mapM getUserInfo
@@ -505,16 +509,19 @@ getUsers db =
 userQuery :: Query
 userQuery =
   [sql|
-    SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.local_display_name, ucp.full_name, ucp.image, ucp.preferences
+    SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.local_display_name, ucp.full_name, ucp.image, ucp.preferences, u.show_ntfs, u.view_pwd_hash, u.view_pwd_salt
     FROM users u
     JOIN contacts uct ON uct.contact_id = u.contact_id
     JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id
   |]
 
-toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe Preferences) -> User
-toUser (userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, userPreferences) =
-  let profile = LocalProfile {profileId, displayName, fullName, image, preferences = userPreferences, localAlias = ""}
-   in User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences = mergePreferences Nothing userPreferences}
+toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe Preferences, Bool) :. (Maybe B64UrlByteString, Maybe B64UrlByteString) -> User
+toUser ((userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, userPreferences, showNtfs) :. (viewPwdHash_, viewPwdSalt_)) =
+  User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences, showNtfs, viewPwdHash}
+  where
+    profile = LocalProfile {profileId, displayName, fullName, image, preferences = userPreferences, localAlias = ""}
+    fullPreferences = mergePreferences Nothing userPreferences
+    viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_
 
 setActiveUser :: DB.Connection -> UserId -> IO ()
 setActiveUser db userId = do
@@ -581,6 +588,19 @@ deleteUserRecord :: DB.Connection -> User -> IO ()
 deleteUserRecord db User {userId} =
   DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId)
 
+updateUserPrivacy :: DB.Connection -> User -> IO ()
+updateUserPrivacy db User {userId, showNtfs, viewPwdHash} =
+  DB.execute
+    db
+    [sql|
+      UPDATE users
+      SET view_pwd_hash = ?, view_pwd_salt = ?, show_ntfs = ?
+      WHERE user_id = ?
+    |]
+    (hashSalt viewPwdHash :. (showNtfs, userId))
+  where
+    hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt))
+
 createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection
 createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do
   createdAt <- getCurrentTime

src/Simplex/Chat/Types.hs

@@ -110,11 +110,38 @@ data User = User
     localDisplayName :: ContactName,
     profile :: LocalProfile,
     fullPreferences :: FullPreferences,
-    activeUser :: Bool
+    activeUser :: Bool,
+    viewPwdHash :: Maybe UserPwdHash,
+    showNtfs :: Bool
   }
   deriving (Show, Generic, FromJSON)
 
-instance ToJSON User where toEncoding = J.genericToEncoding J.defaultOptions
+instance ToJSON User where
+  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
+
+newtype B64UrlByteString = B64UrlByteString ByteString
+  deriving (Eq, Show)
+
+instance FromField B64UrlByteString where fromField f = B64UrlByteString <$> fromField f
+
+instance ToField B64UrlByteString where toField (B64UrlByteString m) = toField m
+
+instance StrEncoding B64UrlByteString where
+  strEncode (B64UrlByteString m) = strEncode m
+  strP = B64UrlByteString <$> strP
+
+instance FromJSON B64UrlByteString where
+  parseJSON = strParseJSON "B64UrlByteString"
+
+instance ToJSON B64UrlByteString where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+data UserPwdHash = UserPwdHash {hash :: B64UrlByteString, salt :: B64UrlByteString}
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON UserPwdHash where toEncoding = J.genericToEncoding J.defaultOptions
 
 data UserInfo = UserInfo
   { user :: User,

src/Simplex/Chat/View.hs

@@ -116,6 +116,7 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
   CRFileTransferStatus u ftStatus -> ttyUser u $ viewFileTransferStatus ftStatus
   CRUserProfile u p -> ttyUser u $ viewUserProfile p
   CRUserProfileNoChange u -> ttyUser u ["user profile did not change"]
+  CRUserPrivacy u -> ttyUserPrefix u $ viewUserPrivacy u
   CRVersionInfo info -> viewVersionInfo logLevel info
   CRInvitation u cReq -> ttyUser u $ viewConnReqInvitation cReq
   CRSentConfirmation u -> ttyUser u ["confirmation sent!"]
@@ -229,12 +230,16 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
   CRAgentConnDeleted acId -> ["completed deleting connection, agent connection id: " <> sShow acId | logLevel <= CLLInfo]
   CRAgentUserDeleted auId -> ["completed deleting user" <> if logLevel <= CLLInfo then ", agent user id: " <> sShow auId else ""]
   CRMessageError u prefix err -> ttyUser u [plain prefix <> ": " <> plain err | prefix == "error" || logLevel <= CLLWarning]
-  CRChatCmdError u e -> ttyUser' u $ viewChatError logLevel e
+  CRChatCmdError u e -> ttyUserPrefix' u $ viewChatError logLevel e
   CRChatError u e -> ttyUser' u $ viewChatError logLevel e
   where
     ttyUser :: User -> [StyledString] -> [StyledString]
-    ttyUser _ [] = []
-    ttyUser User {userId, localDisplayName = u} ss = prependFirst userPrefix ss
+    ttyUser user@User {showNtfs, activeUser} ss
+      | showNtfs || activeUser = ttyUserPrefix user ss
+      | otherwise = []
+    ttyUserPrefix :: User -> [StyledString] -> [StyledString]
+    ttyUserPrefix _ [] = []
+    ttyUserPrefix User {userId, localDisplayName = u} ss = prependFirst userPrefix ss
       where
         userPrefix = case user_ of
           Just User {userId = activeUserId} -> if userId /= activeUserId then prefix else ""
@@ -242,6 +247,8 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
         prefix = "[user: " <> highlight u <> "] "
     ttyUser' :: Maybe User -> [StyledString] -> [StyledString]
     ttyUser' = maybe id ttyUser
+    ttyUserPrefix' :: Maybe User -> [StyledString] -> [StyledString]
+    ttyUserPrefix' = maybe id ttyUserPrefix
     testViewChats :: [AChat] -> [StyledString]
     testViewChats chats = [sShow $ map toChatView chats]
       where
@@ -293,14 +300,19 @@ chatItemDeletedText ci membership_ = deletedStateToText <$> chatItemDeletedState
       _ -> ""
 
 viewUsersList :: [UserInfo] -> [StyledString]
-viewUsersList = map userInfo . sortOn ldn
+viewUsersList = mapMaybe userInfo . sortOn ldn
   where
     ldn (UserInfo User {localDisplayName = n} _) = T.toLower n
-    userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName}, activeUser} count) =
-      ttyFullName n fullName <> active <> unread
+    userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName}, activeUser, showNtfs, viewPwdHash} count)
+      | activeUser || isNothing viewPwdHash = Just $ ttyFullName n fullName <> infoStr
+      | otherwise = Nothing
       where
-        active = if activeUser then highlight' " (active)" else ""
-        unread = if count /= 0 then plain $ " (unread: " <> show count <> ")" else ""
+        infoStr = if null info then "" else " (" <> mconcat (intersperse ", " info) <> ")"
+        info =
+          [highlight' "active" | activeUser]
+            <> [highlight' "hidden" | isJust viewPwdHash]
+            <> ["muted" | not showNtfs]
+            <> [plain ("unread: " <> show count) | count /= 0]
 
 muted :: ChatInfo c -> ChatItem c d -> Bool
 muted chat ChatItem {chatDir} = case (chat, chatDir) of
@@ -722,6 +734,12 @@ viewUserProfile Profile {displayName, fullName} =
     "(the updated profile will be sent to all your contacts)"
   ]
 
+viewUserPrivacy :: User -> [StyledString]
+viewUserPrivacy User {showNtfs, viewPwdHash} =
+  [ "user messages are " <> if showNtfs then "shown" else "hidden (use /tail to view)",
+    "user profile is " <> if isJust viewPwdHash then "hidden" else "visible"
+  ]
+
 -- TODO make more generic messages or split
 viewSMPServers :: ProtocolTypeI p => [ServerCfg p] -> Bool -> [StyledString]
 viewSMPServers servers testView =
@@ -1210,9 +1228,15 @@ viewChatError logLevel = \case
     CENoConnectionUser agentConnId -> ["error: message user not found, conn id: " <> sShow agentConnId | logLevel <= CLLError]
     CEActiveUserExists -> ["error: active user already exists"]
     CEUserExists name -> ["user with the name " <> ttyContact name <> " already exists"]
+    CEUserUnknown -> ["user does not exist or incorrect password"]
     CEDifferentActiveUser commandUserId activeUserId -> ["error: different active user, command user id: " <> sShow commandUserId <> ", active user id: " <> sShow activeUserId]
     CECantDeleteActiveUser _ -> ["cannot delete active user"]
     CECantDeleteLastUser _ -> ["cannot delete last user"]
+    CECantHideLastUser _ -> ["cannot hide the only not hidden user"]
+    CECantUnmuteHiddenUser _ -> ["cannot unmute hidden user"]
+    CEEmptyUserPassword _ -> ["cannot set empty password"]
+    CEUserAlreadyHidden _ -> ["user is already hidden"]
+    CEUserNotHidden _ -> ["user is not hidden"]
     CEChatNotStarted -> ["error: chat not started"]
     CEChatNotStopped -> ["error: chat not stopped"]
     CEChatStoreChanged -> ["error: chat store changed, please restart chat"]