merge profiles using contact probe (#86)

* chat commands to list members and to quit chat

* merge profiles using probe

* merge contacts connected to the same user based on successful profile probe

* delete display name after merging contacts

* probe: rename "existing" contacts to "matching"

src/Simplex/Chat/Protocol.hs

@@ -56,8 +56,8 @@ data ChatMsgEvent
   | XGrpMemCon MemberId
   | XGrpMemConAll MemberId
   | XInfoProbe ByteString
-  | XInfoProbeCheck MemberId ByteString
-  | XInfoProbeOk MemberId ByteString
+  | XInfoProbeCheck ByteString
+  | XInfoProbeOk ByteString
   | XOk
   deriving (Eq, Show)
 
@@ -124,10 +124,10 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod
       chatMsg . XGrpMemConAll =<< B64.decode memId
     ("x.info.probe", [probe]) -> do
       chatMsg . XInfoProbe =<< B64.decode probe
-    ("x.info.probe.check", [memId, probeHash]) -> do
-      chatMsg =<< (XInfoProbeCheck <$> B64.decode memId <*> B64.decode probeHash)
-    ("x.info.probe.ok", [memId, probe]) -> do
-      chatMsg =<< (XInfoProbeOk <$> B64.decode memId <*> B64.decode probe)
+    ("x.info.probe.check", [probeHash]) -> do
+      chatMsg =<< (XInfoProbeCheck <$> B64.decode probeHash)
+    ("x.info.probe.ok", [probe]) -> do
+      chatMsg =<< (XInfoProbeOk <$> B64.decode probe)
     ("x.ok", []) ->
       chatMsg XOk
     _ -> Left $ "bad syntax or unsupported event " <> B.unpack chatMsgEvent
@@ -202,10 +202,10 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
       rawMsg "x.grp.mem.con.all" [B64.encode memId] []
     XInfoProbe probe ->
       rawMsg "x.info.probe" [B64.encode probe] []
-    XInfoProbeCheck memId probeHash ->
-      rawMsg "x.info.probe.check" [B64.encode memId, B64.encode probeHash] []
-    XInfoProbeOk memId probe ->
-      rawMsg "x.info.probe.ok" [B64.encode memId, B64.encode probe] []
+    XInfoProbeCheck probeHash ->
+      rawMsg "x.info.probe.check" [B64.encode probeHash] []
+    XInfoProbeOk probe ->
+      rawMsg "x.info.probe.ok" [B64.encode probe] []
     XOk ->
       rawMsg "x.ok" [] []
   where

src/Simplex/Chat/Store.hs

@@ -44,6 +44,14 @@ module Simplex.Chat.Store
     saveMemberInvitation,
     getViaGroupMember,
     getViaGroupContact,
+    getMatchingContacts,
+    randomBytes,
+    createSentProbe,
+    createSentProbeHash,
+    matchReceivedProbe,
+    matchReceivedProbeHash,
+    matchSentProbe,
+    mergeContactRecords,
   )
 where
 
@@ -73,6 +81,7 @@ import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Protocol (AParty (..), ConnId, SMPQueueInfo)
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction)
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Util (bshow, liftIOEither)
 import System.FilePath (takeBaseName, takeExtension)
 import UnliftIO.STM
@@ -293,6 +302,126 @@ toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Ju
   Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, createdAt)
 toMaybeConnection _ = Nothing
 
+getMatchingContacts :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [Contact]
+getMatchingContacts st userId Contact {contactId, profile = Profile {displayName, fullName}} =
+  liftIO . withTransaction st $ \db -> do
+    contactNames <-
+      map fromOnly
+        <$> DB.queryNamed
+          db
+          [sql|
+            SELECT ct.local_display_name
+            FROM contacts ct
+            JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id
+            WHERE ct.user_id = :user_id AND ct.contact_id != :contact_id
+              AND p.display_name = :display_name AND p.full_name = :full_name
+          |]
+          [ ":user_id" := userId,
+            ":contact_id" := contactId,
+            ":display_name" := displayName,
+            ":full_name" := fullName
+          ]
+    rights <$> mapM (runExceptT . getContact_ db userId) contactNames
+
+createSentProbe :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> UserId -> Contact -> m (ByteString, Int64)
+createSentProbe st gVar userId _to@Contact {contactId} =
+  liftIOEither . withTransaction st $ \db ->
+    createWithRandomBytes 32 gVar $ \probe -> do
+      DB.execute db "INSERT INTO sent_probes (contact_id, probe, user_id) VALUES (?,?,?)" (contactId, probe, userId)
+      (probe,) <$> insertedRowId db
+
+createSentProbeHash :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> Contact -> m ()
+createSentProbeHash st userId probeId _to@Contact {contactId} =
+  liftIO . withTransaction st $ \db ->
+    DB.execute db "INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, user_id) VALUES (?,?,?)" (probeId, contactId, userId)
+
+matchReceivedProbe :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> ByteString -> m (Maybe Contact)
+matchReceivedProbe st userId _from@Contact {contactId} probe =
+  liftIO . withTransaction st $ \db -> do
+    let probeHash = C.sha256Hash probe
+    contactNames <-
+      map fromOnly
+        <$> DB.query
+          db
+          [sql|
+            SELECT c.local_display_name
+            FROM contacts c
+            JOIN received_probes r ON r.contact_id = c.contact_id
+            WHERE c.user_id = ? AND r.probe_hash = ? AND r.probe IS NULL
+          |]
+          (userId, probeHash)
+    DB.execute db "INSERT INTO received_probes (contact_id, probe, probe_hash, user_id) VALUES (?,?,?,?)" (contactId, probe, probeHash, userId)
+    case contactNames of
+      [] -> pure Nothing
+      cName : _ ->
+        either (const Nothing) Just
+          <$> runExceptT (getContact_ db userId cName)
+
+matchReceivedProbeHash :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> ByteString -> m (Maybe (Contact, ByteString))
+matchReceivedProbeHash st userId _from@Contact {contactId} probeHash =
+  liftIO . withTransaction st $ \db -> do
+    namesAndProbes <-
+      DB.query
+        db
+        [sql|
+          SELECT c.local_display_name, r.probe
+          FROM contacts c
+          JOIN received_probes r ON r.contact_id = c.contact_id
+          WHERE c.user_id = ? AND r.probe_hash = ? AND r.probe IS NOT NULL
+        |]
+        (userId, probeHash)
+    DB.execute db "INSERT INTO received_probes (contact_id, probe_hash, user_id) VALUES (?,?,?)" (contactId, probeHash, userId)
+    case namesAndProbes of
+      [] -> pure Nothing
+      (cName, probe) : _ ->
+        either (const Nothing) (Just . (,probe))
+          <$> runExceptT (getContact_ db userId cName)
+
+matchSentProbe :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> ByteString -> m (Maybe Contact)
+matchSentProbe st userId _from@Contact {contactId} probe =
+  liftIO . withTransaction st $ \db -> do
+    contactNames <-
+      map fromOnly
+        <$> DB.query
+          db
+          [sql|
+            SELECT c.local_display_name
+            FROM contacts c
+            JOIN sent_probes s ON s.contact_id = c.contact_id
+            JOIN sent_probe_hashes h ON h.sent_probe_id = s.sent_probe_id
+            WHERE c.user_id = ? AND s.probe = ? AND h.contact_id = ?
+          |]
+          (userId, probe, contactId)
+    case contactNames of
+      [] -> pure Nothing
+      cName : _ ->
+        either (const Nothing) Just
+          <$> runExceptT (getContact_ db userId cName)
+
+mergeContactRecords :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> Contact -> m ()
+mergeContactRecords st userId Contact {contactId = toContactId} Contact {contactId = fromContactId, localDisplayName} =
+  liftIO . withTransaction st $ \db -> do
+    DB.execute db "UPDATE connections SET contact_id = ? WHERE contact_id = ? AND user_id = ?" (toContactId, fromContactId, userId)
+    DB.execute db "UPDATE connections SET via_contact = ? WHERE via_contact = ? AND user_id = ?" (toContactId, fromContactId, userId)
+    DB.execute db "UPDATE group_members SET invited_by = ? WHERE invited_by = ? AND user_id = ?" (toContactId, fromContactId, userId)
+    DB.execute db "UPDATE messages SET contact_id = ? WHERE contact_id = ?" (toContactId, fromContactId)
+    DB.executeNamed
+      db
+      [sql|
+        UPDATE group_members
+        SET contact_id = :to_contact_id,
+            local_display_name = (SELECT local_display_name FROM contacts WHERE contact_id = :to_contact_id),
+            contact_profile_id = (SELECT contact_profile_id FROM contacts WHERE contact_id = :to_contact_id)
+        WHERE contact_id = :from_contact_id
+          AND user_id = :user_id
+      |]
+      [ ":to_contact_id" := toContactId,
+        ":from_contact_id" := fromContactId,
+        ":user_id" := userId
+      ]
+    DB.execute db "DELETE FROM contacts WHERE contact_id = ? AND user_id = ?" (fromContactId, userId)
+    DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
+
 getConnectionChatDirection :: StoreMonad m => SQLiteStore -> User -> ConnId -> m (ChatDirection 'Agent)
 getConnectionChatDirection st User {userId, userContactId} agentConnId =
   liftIOEither . withTransaction st $ \db -> runExceptT $ do
@@ -377,7 +506,7 @@ createNewGroup st gVar user groupProfile =
     profileId <- insertedRowId db
     DB.execute db "INSERT INTO groups (local_display_name, user_id, group_profile_id) VALUES (?, ?, ?)" (displayName, uId, profileId)
     groupId <- insertedRowId db
-    memberId <- randomId gVar 12
+    memberId <- randomBytes gVar 12
     membership <- createContactMember_ db user groupId user (memberId, GROwner) GCUserMember GSMemCreator IBUser
     pure $ Right Group {groupId, localDisplayName = displayName, groupProfile, members = [], membership}
 
@@ -865,20 +994,23 @@ withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreate
             (ldn, displayName, ldnSuffix, userId)
 
 createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError a)
-createWithRandomId gVar create = tryCreate 3
+createWithRandomId = createWithRandomBytes 12
+
+createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError a)
+createWithRandomBytes size gVar create = tryCreate 3
   where
     tryCreate :: Int -> IO (Either StoreError a)
     tryCreate 0 = pure $ Left SEUniqueID
     tryCreate n = do
-      id' <- randomId gVar 12
+      id' <- randomBytes gVar size
       E.try (create id') >>= \case
         Right x -> pure $ Right x
         Left e
           | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1)
           | otherwise -> pure . Left . SEInternal $ bshow e
 
-randomId :: TVar ChaChaDRG -> Int -> IO ByteString
-randomId gVar n = B64.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
+randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
+randomBytes gVar n = B64.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
 
 data StoreError
   = SEDuplicateName

src/Simplex/Chat/View.hs

@@ -27,6 +27,8 @@ module Simplex.Chat.View
     showUserJoinedGroup,
     showJoinedGroupMemberConnecting,
     showConnectedToGroupMember,
+    showGroupMembers,
+    showContactsMerged,
     safeDecodeUtf8,
   )
 where
@@ -118,6 +120,12 @@ showJoinedGroupMemberConnecting = printToView .:. joinedGroupMemberConnecting
 showConnectedToGroupMember :: ChatReader m => GroupName -> GroupMember -> m ()
 showConnectedToGroupMember = printToView .: connectedToGroupMember
 
+showGroupMembers :: ChatReader m => Group -> m ()
+showGroupMembers = printToView . groupMembers
+
+showContactsMerged :: ChatReader m => Contact -> Contact -> m ()
+showContactsMerged = printToView .: contactsMerged
+
 invitation :: SMPQueueInfo -> [StyledString]
 invitation qInfo =
   [ "pass this invitation to your contact (via another channel): ",
@@ -181,6 +189,32 @@ connectedMember m = case memberCategory m of
   GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting
   _ -> "member " <> ttyMember m -- these case is not used
 
+groupMembers :: Group -> [StyledString]
+groupMembers Group {membership, members} = map groupMember . filter (not . removedOrLeft) $ membership : members
+  where
+    removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
+    groupMember m = ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m
+    role = plain . serializeMemberRole . memberRole
+    category m = case memberCategory m of
+      GCUserMember -> "you, "
+      GCInviteeMember -> "invited, "
+      GCHostMember -> "host, "
+      _ -> ""
+    status m = case memberStatus m of
+      GSMemRemoved -> "removed"
+      GSMemLeft -> "left"
+      GSMemInvited -> "not yet joined"
+      GSMemConnected -> "connected"
+      GSMemComplete -> "connected"
+      GSMemCreator -> "created group"
+      _ -> ""
+
+contactsMerged :: Contact -> Contact -> [StyledString]
+contactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} =
+  [ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1,
+    "use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages"
+  ]
+
 receivedMessage :: StyledString -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
 receivedMessage from utcTime msg mOk = do
   t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime