core: show contact and group member servers (#824)

* core: show contact and group member servers (WIP) * contact and member information * update simplexmq
2026-03-30 16:25:57 +00:00 · 2022-07-20 14:57:16 +01:00
parent 5e71deaa3d
commit 3c03c96a53
7 changed files with 85 additions and 18 deletions
--- a/cabal.project
+++ b/cabal.project
@@ -5,7 +5,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
    type: git
    location: https://github.com/simplex-chat/simplexmq.git
-    tag: 1d40bb97c2b2f9b143ca7c1982331cf531786000
+    tag: d810db4eed04f33260e037507d0cb1f017fe6cae

 source-repository-package
    type: git
--- a/scripts/nix/sha256map.nix
+++ b/scripts/nix/sha256map.nix
@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."1d40bb97c2b2f9b143ca7c1982331cf531786000" = "1i55c00crg380sh0zig5k6viganccrrrh3bxkkhjisbr7lixvfbd";
+  "https://github.com/simplex-chat/simplexmq.git"."d810db4eed04f33260e037507d0cb1f017fe6cae" = "0py3kaysqm24pa4rzhxr3l8ayz18rggh0vjnc7glzwf3hyv5wa05";
  "https://github.com/simplex-chat/aeson.git"."3eb66f9a68f103b5f1489382aad89f5712a64db7" = "0kilkx59fl6c3qy3kjczqvm8c3f4n3p0bdk9biyflf51ljnzp4yp";
  "https://github.com/simplex-chat/haskell-terminal.git"."f708b00009b54890172068f168bf98508ffcd495" = "0zmq7lmfsk8m340g47g5963yba7i88n4afa6z93sg9px5jv1mijj";
  "https://github.com/zw3rk/android-support.git"."3c3a5ab0b8b137a072c98d3d0937cbdc96918ddb" = "1r6jyxbim3dsvrmakqfyxbd6ms6miaghpbwyl0sr6dzwpgaprz97";
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -591,6 +591,18 @@ processChatCommand = \case
    ChatConfig {defaultServers = InitialAgentServers {smp = defaultSMPServers}} <- asks config
    withAgent $ \a -> setSMPServers a (fromMaybe defaultSMPServers (nonEmpty smpServers))
    pure CRCmdOk
+  APIContactInfo contactId -> withUser $ \User {userId} -> do
+    ct <- withStore $ \db -> getContact db userId contactId
+    CRContactInfo ct <$> withAgent (`getConnectionServers` contactConnId ct)
+  APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do
+    (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
+    CRGroupMemberInfo g m <$> mapM (withAgent . flip getConnectionServers) (memberConnId m)
+  ContactInfo cName -> withUser $ \User {userId} -> do
+    contactId <- withStore $ \db -> getContactIdByName db userId cName
+    processChatCommand $ APIContactInfo contactId
+  GroupMemberInfo gName mName -> withUser $ \user -> do
+    (gId, mId) <- withStore $ \db -> getGroupIdByName db user gName >>= \gId -> (gId,) <$> getGroupMemberIdByName db user gId mName
+    processChatCommand $ APIGroupMemberInfo gId mId
  ChatHelp section -> pure $ CRChatHelp section
  Welcome -> withUser $ pure . CRWelcome
  AddContact -> withUser $ \User {userId} -> withChatLock . procCmd $ do
@@ -1245,7 +1257,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
    processDirectMessage :: ACommand 'Agent -> Connection -> Maybe Contact -> m ()
    processDirectMessage agentMsg conn@Connection {connId, viaUserContactLink} = \case
      Nothing -> case agentMsg of
-        CONF confId connInfo -> do
+        CONF confId _ connInfo -> do
          saveConnInfo conn connInfo
          allowAgentConnection conn confId $ XInfo profile
        INFO connInfo ->
@@ -1284,7 +1296,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
              XCallEnd callId -> xCallEnd ct callId msg msgMeta
              _ -> pure ()
          ackMsgDeliveryEvent conn msgMeta
-        CONF confId connInfo -> do
+        CONF confId _ connInfo -> do
          -- confirming direct connection with a member
          ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
          case chatMsgEvent of
@@ -1347,7 +1359,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage

    processGroupMessage :: ACommand 'Agent -> Connection -> GroupInfo -> GroupMember -> m ()
    processGroupMessage agentMsg conn gInfo@GroupInfo {groupId, localDisplayName = gName, membership} m = case agentMsg of
-      CONF confId connInfo -> do
+      CONF confId _ connInfo -> do
        ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
        case memberCategory m of
          GCInviteeMember ->
@@ -1443,7 +1455,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
      case agentMsg of
        -- SMP CONF for SndFileConnection happens for direct file protocol
        -- when recipient of the file "joins" connection created by the sender
-        CONF confId connInfo -> do
+        CONF confId _ connInfo -> do
          ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
          case chatMsgEvent of
            -- TODO save XFileAcpt message
@@ -1481,7 +1493,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
        -- SMP CONF for RcvFileConnection happens for group file protocol
        -- when sender of the file "joins" connection created by the recipient
        -- (sender doesn't create connections for all group members)
-        CONF confId connInfo -> do
+        CONF confId _ connInfo -> do
          ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
          case chatMsgEvent of
            XOk -> allowAgentConnection conn confId XOk
@@ -1532,7 +1544,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage

    processUserContactRequest :: ACommand 'Agent -> Connection -> UserContact -> m ()
    processUserContactRequest agentMsg _conn UserContact {userContactLinkId} = case agentMsg of
-      REQ invId connInfo -> do
+      REQ invId _ connInfo -> do
        ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
        case chatMsgEvent of
          XContact p xContactId_ -> profileContactRequest invId p xContactId_
@@ -2435,6 +2447,10 @@ chatCommandP =
      "/smp_servers default" $> SetUserSMPServers [],
      "/smp_servers " *> (SetUserSMPServers <$> smpServersP),
      "/smp_servers" $> GetUserSMPServers,
+      "/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal),
+      "/_info @" *> (APIContactInfo <$> A.decimal),
+      ("/info #" <|> "/i #") *> (GroupMemberInfo <$> displayName <* A.space <* optional (A.char '@') <*> displayName),
+      ("/info @" <|> "/info " <|> "/i @" <|> "/i ") *> (ContactInfo <$> displayName),
      ("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles,
      ("/help groups" <|> "/help group" <|> "/hg") $> ChatHelp HSGroups,
      ("/help address" <|> "/ha") $> ChatHelp HSMyAddress,
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -143,6 +143,10 @@ data ChatCommand
  | APIListMembers GroupId
  | GetUserSMPServers
  | SetUserSMPServers [SMPServer]
+  | APIContactInfo ContactId
+  | APIGroupMemberInfo GroupId GroupMemberId
+  | ContactInfo ContactName
+  | GroupMemberInfo GroupName ContactName
  | ChatHelp HelpSection
  | Welcome
  | AddContact
@@ -199,6 +203,8 @@ data ChatResponse
  | CRLastMessages {chatItems :: [AChatItem]}
  | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
  | CRUserSMPServers {smpServers :: [SMPServer]}
+  | CRContactInfo {contact :: Contact, connectionStats :: ConnectionStats}
+  | CRGroupMemberInfo {groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats}
  | CRNewChatItem {chatItem :: AChatItem}
  | CRChatItemStatusUpdated {chatItem :: AChatItem}
  | CRChatItemUpdated {chatItem :: AChatItem}
--- a/src/Simplex/Chat/Store.hs
+++ b/src/Simplex/Chat/Store.hs
@@ -67,6 +67,7 @@ module Simplex.Chat.Store
    getGroupIdByName,
    getGroupMemberIdByName,
    getGroupInfoByName,
+    getGroupMember,
    getGroupMembers,
    deleteGroup,
    getUserGroups,
@@ -1395,9 +1396,31 @@ toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, im
  let membership = toGroupMember userContactId userMemberRow
   in GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName, image}, membership, createdAt, updatedAt}

+getGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember
+getGroupMember db user@User {userId} groupId groupMemberId =
+  ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound {groupId, groupMemberId}) $
+    DB.query
+      db
+      [sql|
+        SELECT
+          m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
+          m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image,
+          c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link,
+          c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
+        FROM group_members m
+        JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
+        LEFT JOIN connections c ON c.connection_id = (
+          SELECT max(cc.connection_id)
+          FROM connections cc
+          where cc.group_member_id = m.group_member_id
+        )
+        WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?
+      |]
+      (groupId, groupMemberId, userId)
+
 getGroupMembers :: DB.Connection -> User -> GroupInfo -> IO [GroupMember]
-getGroupMembers db User {userId, userContactId} GroupInfo {groupId} = do
-  map toContactMember
+getGroupMembers db user@User {userId, userContactId} GroupInfo {groupId} = do
+  map (toContactMember user)
    <$> DB.query
      db
      [sql|
@@ -1416,10 +1439,10 @@ getGroupMembers db User {userId, userContactId} GroupInfo {groupId} = do
        WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)
      |]
      (groupId, userId, userContactId)
-  where
-    toContactMember :: (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
-    toContactMember (memberRow :. connRow) =
-      (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow}
+
+toContactMember :: User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
+toContactMember User {userContactId} (memberRow :. connRow) =
+  (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow}

 -- TODO no need to load all members to find the member who invited the user,
 -- instead of findFromContact there could be a query
@@ -3106,7 +3129,7 @@ getGroupIdByName db User {userId} gName =

 getGroupMemberIdByName :: DB.Connection -> User -> GroupId -> ContactName -> ExceptT StoreError IO GroupMemberId
 getGroupMemberIdByName db User {userId} groupId groupMemberName =
-  ExceptT . firstRow fromOnly (SEGroupMemberNotFound groupId groupMemberName) $
+  ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $
    DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName)

 getChatItemIdByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId)
@@ -3798,7 +3821,8 @@ data StoreError
  | SEContactRequestNotFoundByName {contactName :: ContactName}
  | SEGroupNotFound {groupId :: GroupId}
  | SEGroupNotFoundByName {groupName :: GroupName}
-  | SEGroupMemberNotFound {groupId :: GroupId, groupMemberName :: ContactName}
+  | SEGroupMemberNameNotFound {groupId :: GroupId, groupMemberName :: ContactName}
+  | SEGroupMemberNotFound {groupId :: GroupId, groupMemberId :: GroupMemberId}
  | SEGroupWithoutUser
  | SEDuplicateGroupMember
  | SEGroupAlreadyJoined
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@@ -59,6 +59,8 @@ responseToView testView = \case
  CRApiChat chat -> if testView then testViewChat chat else [plain . bshow $ J.encode chat]
  CRApiParsedMarkdown ft -> [plain . bshow $ J.encode ft]
  CRUserSMPServers smpServers -> viewSMPServers smpServers testView
+  CRContactInfo ct cStats -> viewContactInfo ct cStats
+  CRGroupMemberInfo g m cStats -> viewGroupMemberInfo g m cStats
  CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item False
  CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True) chatItems
  CRChatItemStatusUpdated _ -> []
@@ -483,7 +485,26 @@ viewSMPServers smpServers testView =
    customSMPServers =
      if null smpServers
        then "no custom SMP servers saved"
-        else plain $ intercalate ", " (map (B.unpack . strEncode) smpServers)
+        else viewServers smpServers
+
+viewContactInfo :: Contact -> ConnectionStats -> [StyledString]
+viewContactInfo Contact {contactId} stats =
+  ["contact ID: " <> sShow contactId] <> viewConnectionStats stats
+
+viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString]
+viewGroupMemberInfo GroupInfo {groupId} GroupMember {groupMemberId} stats =
+  [ "group ID: " <> sShow groupId,
+    "member ID: " <> sShow groupMemberId
+  ]
+    <> maybe ["member not connected"] viewConnectionStats stats
+
+viewConnectionStats :: ConnectionStats -> [StyledString]
+viewConnectionStats ConnectionStats {rcvServers, sndServers} =
+  ["receiving messages via: " <> viewServers rcvServers | not $ null rcvServers]
+    <> ["sending messages via: " <> viewServers sndServers | not $ null sndServers]
+
+viewServers :: [SMPServer] -> StyledString
+viewServers = plain . intercalate ", " . map (B.unpack . strEncode)

 viewUserProfileUpdated :: Profile -> Profile -> [StyledString]
 viewUserProfileUpdated Profile {displayName = n, fullName, image} Profile {displayName = n', fullName = fullName', image = image'}
--- a/stack.yaml
+++ b/stack.yaml
@@ -49,7 +49,7 @@ extra-deps:
  # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
  # - ../simplexmq
  - github: simplex-chat/simplexmq
-    commit: 1d40bb97c2b2f9b143ca7c1982331cf531786000
+    commit: d810db4eed04f33260e037507d0cb1f017fe6cae
  # - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977
  - github: simplex-chat/aeson
    commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7