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
5 changed files with 206 additions and 32 deletions
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