update user profile (and notify contacts) (#93)

* update user profile (and notify contacts)

* add concurrently to profile update test for better layout

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 ""
+      fullName <- fullNameP gName
-      pure GroupProfile {displayName = gName, fullName = if T.null fullName' then gName else fullName'}
+      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

tests/ChatTests.hs

@@ -35,6 +35,8 @@ chatTests = do
     it "create and join group with 4 members" testGroup2
     it "create and delete group" testGroupDelete
     it "remove contact from group and add again" testGroupRemoveAdd
+  describe "user profiles" $
+    it "update user profiles and notify contacts" testUpdateProfile
 
 testAddContact :: IO ()
 testAddContact =
@@ -350,65 +352,116 @@ testGroupRemoveAdd =
         (alice <# "#team cath> hello")
         (bob <# "#team_1 cath> hello")
 
+testUpdateProfile :: IO ()
+testUpdateProfile =
+  testChat3 aliceProfile bobProfile cathProfile $
+    \alice bob cath -> do
+      createGroup3 "team" alice bob cath
+      alice ##> "/p"
+      alice <## "user profile: alice (Alice)"
+      alice <## "use /p <display name>[ <full name>] to change it"
+      alice <## "(the updated profile will be sent to all your contacts)"
+      alice ##> "/p alice"
+      concurrentlyN_
+        [ alice <## "user full name removed (your contacts are notified)",
+          bob <## "contact alice removed full name",
+          cath <## "contact alice removed full name"
+        ]
+      alice ##> "/p alice Alice Jones"
+      concurrentlyN_
+        [ alice <## "user full name changed to Alice Jones (your contacts are notified)",
+          bob <## "contact alice updated full name: Alice Jones",
+          cath <## "contact alice updated full name: Alice Jones"
+        ]
+      cath ##> "/p cate"
+      concurrentlyN_
+        [ cath <## "user profile is changed to cate (your contacts are notified)",
+          do
+            alice <## "contact cath changed to cate"
+            alice <## "use @cate <message> to send messages",
+          do
+            bob <## "contact cath changed to cate"
+            bob <## "use @cate <message> to send messages"
+        ]
+      cath ##> "/p cat Cate"
+      concurrentlyN_
+        [ cath <## "user profile is changed to cat (Cate) (your contacts are notified)",
+          do
+            alice <## "contact cate changed to cat (Cate)"
+            alice <## "use @cat <message> to send messages",
+          do
+            bob <## "contact cate changed to cat (Cate)"
+            bob <## "use @cat <message> to send messages"
+        ]
+
 connectUsers :: TestCC -> TestCC -> IO ()
 connectUsers cc1 cc2 = do
+  name1 <- showName cc1
+  name2 <- showName cc2
   cc1 ##> "/c"
   inv <- getInvitation cc1
   cc2 ##> ("/c " <> inv)
   concurrently_
-    (cc2 <## (showName cc1 <> ": contact is connected"))
+    (cc2 <## (name1 <> ": contact is connected"))
-    (cc1 <## (showName cc2 <> ": contact is connected"))
+    (cc1 <## (name2 <> ": contact is connected"))
 
-showName :: TestCC -> String
+showName :: TestCC -> IO String
-showName (TestCC ChatController {currentUser = User {localDisplayName, profile = Profile {fullName}}} _ _ _ _) =
+showName (TestCC ChatController {currentUser} _ _ _ _) = do
-  T.unpack $ localDisplayName <> " (" <> fullName <> ")"
+  User {localDisplayName, profile = Profile {fullName}} <- readTVarIO currentUser
+  pure . T.unpack $ localDisplayName <> " (" <> fullName <> ")"
 
 createGroup3 :: String -> TestCC -> TestCC -> TestCC -> IO ()
 createGroup3 gName cc1 cc2 cc3 = do
   connectUsers cc1 cc2
   connectUsers cc1 cc3
+  name2 <- userName cc2
+  name3 <- userName cc3
+  sName2 <- showName cc2
+  sName3 <- showName cc3
   cc1 ##> ("/g " <> gName)
   cc1 <## ("group #" <> gName <> " is created")
   cc1 <## ("use /a " <> gName <> " <name> to add members")
   addMember cc2
   cc2 ##> ("/j " <> gName)
   concurrently_
-    (cc1 <## ("#" <> gName <> ": " <> name cc2 <> " joined the group"))
+    (cc1 <## ("#" <> gName <> ": " <> name2 <> " joined the group"))
     (cc2 <## ("#" <> gName <> ": you joined the group"))
   addMember cc3
   cc3 ##> ("/j " <> gName)
   concurrentlyN_
-    [ cc1 <## ("#" <> gName <> ": " <> name cc3 <> " joined the group"),
+    [ cc1 <## ("#" <> gName <> ": " <> name3 <> " joined the group"),
       do
         cc3 <## ("#" <> gName <> ": you joined the group")
-        cc3 <## ("#" <> gName <> ": member " <> showName cc2 <> " is connected"),
+        cc3 <## ("#" <> gName <> ": member " <> sName2 <> " is connected"),
       do
-        cc2 <## ("#" <> gName <> ": alice added " <> showName cc3 <> " to the group (connecting...)")
+        cc2 <## ("#" <> gName <> ": alice added " <> sName3 <> " to the group (connecting...)")
-        cc2 <## ("#" <> gName <> ": new member " <> name cc3 <> " is connected")
+        cc2 <## ("#" <> gName <> ": new member " <> name3 <> " is connected")
     ]
   where
     addMember :: TestCC -> IO ()
     addMember mem = do
-      cc1 ##> ("/a " <> gName <> " " <> name mem)
+      name1 <- userName cc1
+      memName <- userName mem
+      cc1 ##> ("/a " <> gName <> " " <> memName)
       concurrentlyN_
-        [ cc1 <## ("invitation to join the group #" <> gName <> " sent to " <> name mem),
+        [ cc1 <## ("invitation to join the group #" <> gName <> " sent to " <> memName),
           do
-            mem <## ("#" <> gName <> ": " <> name cc1 <> " invites you to join the group as admin")
+            mem <## ("#" <> gName <> ": " <> name1 <> " invites you to join the group as admin")
             mem <## ("use /j " <> gName <> " to accept")
         ]
-    name :: TestCC -> String
-    name (TestCC ChatController {currentUser = User {localDisplayName}} _ _ _ _) =
-      T.unpack localDisplayName
 
 -- | test sending direct messages
 (<##>) :: TestCC -> TestCC -> IO ()
 cc1 <##> cc2 = do
-  cc1 #> ("@" <> name cc2 <> " hi")
+  name1 <- userName cc1
-  cc2 <# (name cc1 <> "> hi")
+  name2 <- userName cc2
-  cc2 #> ("@" <> name cc1 <> " hey")
+  cc1 #> ("@" <> name2 <> " hi")
-  cc1 <# (name cc2 <> "> hey")
+  cc2 <# (name1 <> "> hi")
-  where
+  cc2 #> ("@" <> name1 <> " hey")
-    name (TestCC ChatController {currentUser = User {localDisplayName}} _ _ _ _) = T.unpack localDisplayName
+  cc1 <# (name2 <> "> hey")
+
+userName :: TestCC -> IO [Char]
+userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName <$> readTVarIO currentUser
 
 (##>) :: TestCC -> String -> IO ()
 cc ##> cmd = do