From 9cfca4ed3546943fd0d60a9a6cb02b61eee331d6 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 22 Aug 2021 15:56:36 +0100 Subject: [PATCH] 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 | 42 +++++++++++---- src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Store.hs | 55 +++++++++++++++++++ src/Simplex/Chat/View.hs | 42 +++++++++++++++ tests/ChatTests.hs | 97 ++++++++++++++++++++++++++-------- 5 files changed, 206 insertions(+), 32 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 89bc860b59..68bb15f167 100644 --- a/src/Simplex/Chat.hs +++ b/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) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 395f62d963..b67bfbab7b 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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, diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 607e07ba1e..95f6dae0ef 100644 --- a/src/Simplex/Chat/Store.hs +++ b/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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 4af608f959..608cac4811 100644 --- a/src/Simplex/Chat/View.hs +++ b/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' "" <> " to send messages" ] +userProfile :: Profile -> [StyledString] +userProfile Profile {displayName, fullName} = + [ "user profile: " <> ttyFullName displayName fullName, + "use " <> highlight' "/p [ ]" <> " 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' "" <> " 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 diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 3053d52763..ad5c4ff08e 100644 --- a/tests/ChatTests.hs +++ b/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 [ ] 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 to send messages", + do + bob <## "contact cath changed to cate" + bob <## "use @cate 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 to send messages", + do + bob <## "contact cate changed to cat (Cate)" + bob <## "use @cat 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")) - (cc1 <## (showName cc2 <> ": contact is connected")) + (cc2 <## (name1 <> ": contact is connected")) + (cc1 <## (name2 <> ": contact is connected")) -showName :: TestCC -> String -showName (TestCC ChatController {currentUser = User {localDisplayName, profile = Profile {fullName}}} _ _ _ _) = - T.unpack $ localDisplayName <> " (" <> fullName <> ")" +showName :: TestCC -> IO String +showName (TestCC ChatController {currentUser} _ _ _ _) = do + 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 <> " 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 <> ": new member " <> name cc3 <> " is connected") + cc2 <## ("#" <> gName <> ": alice added " <> sName3 <> " to the group (connecting...)") + 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") - cc2 <# (name cc1 <> "> hi") - cc2 #> ("@" <> name cc1 <> " hey") - cc1 <# (name cc2 <> "> hey") - where - name (TestCC ChatController {currentUser = User {localDisplayName}} _ _ _ _) = T.unpack localDisplayName + name1 <- userName cc1 + name2 <- userName cc2 + cc1 #> ("@" <> name2 <> " hi") + cc2 <# (name1 <> "> hi") + cc2 #> ("@" <> name1 <> " hey") + cc1 <# (name2 <> "> hey") + +userName :: TestCC -> IO [Char] +userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName <$> readTVarIO currentUser (##>) :: TestCC -> String -> IO () cc ##> cmd = do