update user profile (and notify contacts)

src/Simplex/Chat.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -69,6 +70,8 @@ data ChatCommand
   | DeleteGroup GroupName
   | ListMembers GroupName
   | SendGroupMessage GroupName ByteString
+  | UpdateProfile Profile
+  | ShowProfile
   | QuitChat
   deriving (Show)
 
@@ -106,14 +109,14 @@ simplexChat cfg opts t =
 newChatController :: WithTerminal t => ChatConfig -> ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
 newChatController ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {dbFile, smpServers} t sendNotification = do
   chatStore <- createStore (dbFile <> ".chat.db") dbPoolSize
-  currentUser <- getCreateActiveUser chatStore
+  currentUser <- newTVarIO =<< getCreateActiveUser chatStore
   chatTerminal <- newChatTerminal t
   smpAgent <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers}
   idsDrg <- newTVarIO =<< drgNew
   inputQ <- newTBQueueIO tbqSize
   notifyQ <- newTBQueueIO tbqSize
   chatLock <- newTMVarIO ()
-  pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, idsDrg, inputQ, notifyQ, sendNotification, chatLock}
+  pure ChatController {..}
 
 runSimplexChat :: ChatController -> IO ()
 runSimplexChat = runReaderT (race_ runTerminalInput runChatController)
@@ -147,7 +150,7 @@ inputSubscriber = do
               SendMessage c msg -> showSentMessage c msg
               SendGroupMessage g msg -> showSentGroupMessage g msg
               _ -> printToView [plain s]
-            user <- asks currentUser
+            user <- readTVarIO =<< asks currentUser
             withLock l . void . runExceptT $
               processChatCommand user cmd `catchError` showChatError
 
@@ -244,6 +247,13 @@ processChatCommand user@User {userId, profile} = \case
     let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}]
     sendGroupMessage members msgEvent
     setActive $ ActiveG gName
+  UpdateProfile p -> unless (p == profile) $ do
+    user' <- withStore $ \st -> updateUserProfile st user p
+    asks currentUser >>= atomically . (`writeTVar` user')
+    contacts <- withStore (`getUserContacts` user)
+    forM_ contacts $ \ct -> sendDirectMessage (contactConnId ct) $ XInfo p
+    showUserProfileUpdated user user'
+  ShowProfile -> showUserProfile profile
   QuitChat -> liftIO exitSuccess
   where
     contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
@@ -258,14 +268,14 @@ agentSubscriber = do
   subscribeUserConnections
   forever $ do
     (_, connId, msg) <- atomically $ readTBQueue q
-    user <- asks currentUser
+    user <- readTVarIO =<< asks currentUser
     -- TODO handle errors properly
     withLock l . void . runExceptT $
       processAgentMessage user connId msg `catchError` (liftIO . print)
 
 subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
 subscribeUserConnections = void . runExceptT $ do
-  user <- asks currentUser
+  user <- readTVarIO =<< asks currentUser
   subscribeContacts user
   subscribeGroups user
   where
@@ -334,7 +344,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
           ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
           case chatMsgEvent of
             XMsgNew (MsgContent MTText [] body) -> newTextMessage c meta $ find (isSimplexContentType XCText) body
-            XInfo _ -> pure () -- TODO profile update
+            XInfo p -> xInfo ct p
             XGrpInv gInv -> processGroupInvitation ct gInv
             XInfoProbe probe -> xInfoProbe ct probe
             XInfoProbeCheck probeHash -> xInfoProbeCheck ct probeHash
@@ -511,6 +521,11 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
       group <- withStore $ \st -> createGroupInvitation st user ct inv
       showReceivedGroupInvitation group localDisplayName memRole
 
+    xInfo :: Contact -> Profile -> m ()
+    xInfo c@Contact {profile = p} p' = unless (p == p') $ do
+      c' <- withStore $ \st -> updateContactProfile st userId c p'
+      showContactUpdated c c'
+
     xInfoProbe :: Contact -> ByteString -> m ()
     xInfoProbe c2 probe = do
       r <- withStore $ \st -> matchReceivedProbe st userId c2 probe
@@ -722,7 +737,7 @@ getCreateActiveUser st = do
                 pure user
     userStr :: User -> String
     userStr User {localDisplayName, profile = Profile {fullName}} =
-      T.unpack $ localDisplayName <> if T.null fullName then "" else " (" <> fullName <> ")"
+      T.unpack $ localDisplayName <> if T.null fullName || localDisplayName == fullName then "" else " (" <> fullName <> ")"
     getContactName :: IO ContactName
     getContactName = do
       displayName <- getWithPrompt "display name (no spaces)"
@@ -771,14 +786,23 @@ chatCommandP =
     <|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName)
     <|> A.char '@' *> (SendMessage <$> displayName <*> (A.space *> A.takeByteString))
     <|> ("/markdown" <|> "/m") $> MarkdownHelp
+    <|> ("/profile " <|> "/p ") *> (UpdateProfile <$> userProfile)
+    <|> ("/profile" <|> "/p") $> ShowProfile
     <|> ("/quit" <|> "/q") $> QuitChat
   where
     displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' '))
     refChar c = c > ' ' && c /= '#' && c /= '@'
+    userProfile = do
+      cName <- displayName
+      fullName <- fullNameP cName
+      pure Profile {displayName = cName, fullName}
     groupProfile = do
       gName <- displayName
-      fullName' <- safeDecodeUtf8 <$> (A.space *> A.takeByteString) <|> pure ""
-      pure GroupProfile {displayName = gName, fullName = if T.null fullName' then gName else fullName'}
+      fullName <- fullNameP gName
+      pure GroupProfile {displayName = gName, fullName}
+    fullNameP name = do
+      n <- (A.space *> A.takeByteString) <|> pure ""
+      pure $ if B.null n then name else safeDecodeUtf8 n
     memberRole =
       (" owner" $> GROwner)
         <|> (" admin" $> GRAdmin)

src/Simplex/Chat/Controller.hs

@@ -21,7 +21,7 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
 import UnliftIO.STM
 
 data ChatController = ChatController
-  { currentUser :: User,
+  { currentUser :: TVar User,
     smpAgent :: AgentClient,
     chatTerminal :: ChatTerminal,
     chatStore :: SQLiteStore,

src/Simplex/Chat/Store.hs

@@ -24,6 +24,8 @@ module Simplex.Chat.Store
     getContactGroupNames,
     deleteContact,
     getContact,
+    updateUserProfile,
+    updateContactProfile,
     getUserContacts,
     getContactConnections,
     getConnectionChatDirection,
@@ -69,6 +71,7 @@ import Data.ByteString.Char8 (ByteString)
 import Data.Either (rights)
 import Data.FileEmbed (embedDir, makeRelativeToProject)
 import Data.Function (on)
+import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (find, sortBy)
 import Data.Maybe (listToMaybe)
@@ -232,6 +235,58 @@ getContact :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact
 getContact st userId localDisplayName =
   liftIOEither . withTransaction st $ \db -> runExceptT $ getContact_ db userId localDisplayName
 
+updateUserProfile :: StoreMonad m => SQLiteStore -> User -> Profile -> m User
+updateUserProfile st u@User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
+  | displayName == newName =
+    liftIO . withTransaction st $ \db ->
+      updateContactProfile_ db userId userContactId p' $> (u :: User) {profile = p'}
+  | otherwise =
+    liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
+      DB.execute db "UPDATE users SET local_display_name = ? WHERE user_id = ?" (newName, userId)
+      DB.execute db "INSERT INTO display_names (local_display_name, ldn_base, user_id) VALUES (?, ?, ?)" (newName, newName, userId)
+      updateContactProfile_ db userId userContactId p'
+      updateContact_ db userId userContactId localDisplayName newName
+      pure . Right $ (u :: User) {localDisplayName = newName, profile = p'}
+
+updateContactProfile :: StoreMonad m => SQLiteStore -> UserId -> Contact -> Profile -> m Contact
+updateContactProfile st userId c@Contact {contactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
+  | displayName == newName =
+    liftIO . withTransaction st $ \db ->
+      updateContactProfile_ db userId contactId p' $> (c :: Contact) {profile = p'}
+  | otherwise =
+    liftIOEither . withTransaction st $ \db ->
+      withLocalDisplayName db userId newName $ \ldn -> do
+        updateContactProfile_ db userId contactId p'
+        updateContact_ db userId contactId localDisplayName ldn
+        pure $ (c :: Contact) {localDisplayName = ldn, profile = p'}
+
+updateContactProfile_ :: DB.Connection -> UserId -> Int64 -> Profile -> IO ()
+updateContactProfile_ db userId contactId Profile {displayName, fullName} =
+  DB.executeNamed
+    db
+    [sql|
+      UPDATE contact_profiles
+      SET display_name = :display_name,
+          full_name = :full_name
+      WHERE contact_profile_id IN (
+        SELECT contact_profile_id
+        FROM contacts
+        WHERE user_id = :user_id
+          AND contact_id = :contact_id
+      )
+    |]
+    [ ":display_name" := displayName,
+      ":full_name" := fullName,
+      ":user_id" := userId,
+      ":contact_id" := contactId
+    ]
+
+updateContact_ :: DB.Connection -> UserId -> Int64 -> ContactName -> ContactName -> IO ()
+updateContact_ db userId contactId displayName newName = do
+  DB.execute db "UPDATE contacts SET local_display_name = ? WHERE user_id = ? AND contact_id = ?" (newName, userId, contactId)
+  DB.execute db "UPDATE group_members SET local_display_name = ? WHERE user_id = ? AND contact_id = ?" (newName, userId, contactId)
+  DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId)
+
 -- TODO return the last connection that is ready, not any last connection
 -- requires updating connection status
 getContact_ :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Contact

src/Simplex/Chat/View.hs

@@ -39,6 +39,9 @@ module Simplex.Chat.View
     showLeftMember,
     showGroupMembers,
     showContactsMerged,
+    showUserProfile,
+    showUserProfileUpdated,
+    showContactUpdated,
     safeDecodeUtf8,
   )
 where
@@ -166,6 +169,15 @@ showGroupMembers = printToView . groupMembers
 showContactsMerged :: ChatReader m => Contact -> Contact -> m ()
 showContactsMerged = printToView .: contactsMerged
 
+showUserProfile :: ChatReader m => Profile -> m ()
+showUserProfile = printToView . userProfile
+
+showUserProfileUpdated :: ChatReader m => User -> User -> m ()
+showUserProfileUpdated = printToView .: userProfileUpdated
+
+showContactUpdated :: ChatReader m => Contact -> Contact -> m ()
+showContactUpdated = printToView .: contactUpdated
+
 invitation :: SMPQueueInfo -> [StyledString]
 invitation qInfo =
   [ "pass this invitation to your contact (via another channel): ",
@@ -302,6 +314,36 @@ contactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayNa
     "use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages"
   ]
 
+userProfile :: Profile -> [StyledString]
+userProfile Profile {displayName, fullName} =
+  [ "user profile: " <> ttyFullName displayName fullName,
+    "use " <> highlight' "/p <display name>[ <full name>]" <> " to change it",
+    "(the updated profile will be sent to all your contacts)"
+  ]
+
+userProfileUpdated :: User -> User -> [StyledString]
+userProfileUpdated
+  User {localDisplayName = n, profile = Profile {fullName}}
+  User {localDisplayName = n', profile = Profile {fullName = fullName'}}
+    | n == n' && fullName == fullName' = []
+    | n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified]
+    | otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
+    where
+      notified = " (your contacts are notified)"
+
+contactUpdated :: Contact -> Contact -> [StyledString]
+contactUpdated
+  Contact {localDisplayName = n, profile = Profile {fullName}}
+  Contact {localDisplayName = n', profile = Profile {fullName = fullName'}}
+    | n == n' && fullName == fullName' = []
+    | n == n' = ["contact " <> ttyContact n <> fullNameUpdate]
+    | otherwise =
+      [ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
+        "use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
+      ]
+    where
+      fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
+
 receivedMessage :: StyledString -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
 receivedMessage from utcTime msg mOk = do
   t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime