IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source 
* update user profile (and notify contacts)

* add concurrently to profile update test for better layout
This commit is contained in:
Evgeny Poberezkin 2021-08-22 15:56:36 +01:00 committed by GitHub
parent e5b9cdef9d
commit 9cfca4ed35
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 206 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
src/Simplex/Chat.hs
View File

@ -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)

2
src/Simplex/Chat/Controller.hs
View File

@ -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,

55
src/Simplex/Chat/Store.hs
View File

@ -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

42
src/Simplex/Chat/View.hs
View File

@ -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

97
tests/ChatTests.hs
View File

@ -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"))
(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 <> " <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 <> ": 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