core: switch connection (#1277)

* core: switch connection

* chat items for SWITCH

* additional events for connection switch

* update simplexmq

* test

* comment test output

* update messages for connection switch

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>

src/Simplex/Chat/Archive.hs

@@ -21,7 +21,7 @@ import qualified Database.SQLite3 as SQL
 import Simplex.Chat.Controller
 import Simplex.Messaging.Agent.Client (agentClientStore)
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), sqlString)
-import Simplex.Messaging.Util (unlessM, whenM)
+import Simplex.Messaging.Util
 import System.FilePath
 import UnliftIO.Directory
 import UnliftIO.Exception (SomeException, bracket, catch)

src/Simplex/Chat/Call.hs

@@ -24,7 +24,7 @@ import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.Generics (Generic)
 import Simplex.Chat.Types (Contact, ContactId)
-import Simplex.Chat.Util (safeDecodeUtf8)
+import Simplex.Messaging.Util (safeDecodeUtf8)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON)

src/Simplex/Chat/Controller.hs

@@ -193,9 +193,13 @@ data ChatCommand
   | APISetChatSettings ChatRef ChatSettings
   | APIContactInfo ContactId
   | APIGroupMemberInfo GroupId GroupMemberId
+  | APISwitchContact ContactId
+  | APISwitchGroupMember GroupId GroupMemberId
   | ShowMessages ChatName Bool
   | ContactInfo ContactName
   | GroupMemberInfo GroupName ContactName
+  | SwitchContact ContactName
+  | SwitchGroupMember GroupName ContactName
   | ChatHelp HelpSection
   | Welcome
   | AddContact
@@ -261,6 +265,8 @@ data ChatResponse
   | CRNetworkConfig {networkConfig :: NetworkConfig}
   | CRContactInfo {contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile}
   | CRGroupMemberInfo {groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats}
+  | CRContactSwitch {contact :: Contact, switchProgress :: SwitchProgress}
+  | CRGroupMemberSwitch {groupInfo :: GroupInfo, member :: GroupMember, switchProgress :: SwitchProgress}
   | CRNewChatItem {chatItem :: AChatItem}
   | CRChatItemStatusUpdated {chatItem :: AChatItem}
   | CRChatItemUpdated {chatItem :: AChatItem}
@@ -448,6 +454,15 @@ instance ToJSON NtfMsgInfo where toEncoding = J.genericToEncoding J.defaultOptio
 crNtfToken :: (DeviceToken, NtfTknStatus, NotificationsMode) -> ChatResponse
 crNtfToken (token, status, ntfMode) = CRNtfToken {token, status, ntfMode}
 
+data SwitchProgress = SwitchProgress
+  { queueDirection :: QueueDirection,
+    switchPhase :: SwitchPhase,
+    connectionStats :: ConnectionStats
+  }
+  deriving (Show, Generic)
+
+instance ToJSON SwitchProgress where toEncoding = J.genericToEncoding J.defaultOptions
+
 data ChatError
   = ChatError {errorType :: ChatErrorType}
   | ChatErrorAgent {agentError :: AgentErrorType}

src/Simplex/Chat/Messages.hs

@@ -32,12 +32,11 @@ import GHC.Generics (Generic)
 import Simplex.Chat.Markdown
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
-import Simplex.Chat.Util (safeDecodeUtf8)
-import Simplex.Messaging.Agent.Protocol (AgentErrorType, AgentMsgId, MsgErrorType (..), MsgMeta (..))
+import Simplex.Messaging.Agent.Protocol (SwitchPhase (..), AgentErrorType, AgentMsgId, MsgErrorType (..), MsgMeta (..), SwitchPhase)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON, sumTypeJSON)
 import Simplex.Messaging.Protocol (MsgBody)
-import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
+import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
 
 data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
   deriving (Show, Generic)
@@ -524,6 +523,21 @@ sndGroupEventToText = \case
   SGEUserLeft -> "left"
   SGEGroupUpdated _ -> "group profile updated"
 
+rcvConnEventToText :: RcvConnEvent -> Text
+rcvConnEventToText = \case
+  RCESwitch phase -> case phase of
+    SPCompleted -> "changed address for you"
+    _ -> decodeLatin1 (strEncode phase) <> " changing address for you..."
+
+sndConnEventToText :: SndConnEvent -> Text
+sndConnEventToText = \case
+  SCESwitch phase m -> case phase of
+    SPCompleted -> "you changed address" <> forMember m
+    _ -> decodeLatin1 (strEncode phase) <> " changing address" <> forMember m <> "..."
+  where
+    forMember member_ =
+      maybe "" (\GroupMemberRef {profile = Profile {displayName}} -> " for " <> displayName) member_
+
 profileToText :: Profile -> Text
 profileToText Profile {displayName, fullName} = displayName <> optionalFullName displayName fullName
 
@@ -542,6 +556,8 @@ data CIContent (d :: MsgDirection) where
   CISndGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDSnd
   CIRcvGroupEvent :: RcvGroupEvent -> CIContent 'MDRcv
   CISndGroupEvent :: SndGroupEvent -> CIContent 'MDSnd
+  CIRcvConnEvent :: RcvConnEvent -> CIContent 'MDRcv
+  CISndConnEvent :: SndConnEvent -> CIContent 'MDSnd
 -- ^ This type is used both in API and in DB, so we use different JSON encodings for the database and for the API
 -- ! ^ Nested sum types also have to use different encodings for database and API
 -- ! ^ to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent
@@ -604,6 +620,44 @@ instance ToJSON DBSndGroupEvent where
   toJSON (SGE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "SGE") v
   toEncoding (SGE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "SGE") v
 
+data RcvConnEvent = RCESwitch {phase :: SwitchPhase}
+  deriving (Show, Generic)
+
+data SndConnEvent = SCESwitch {phase :: SwitchPhase, member :: Maybe GroupMemberRef}
+  deriving (Show, Generic)
+
+instance FromJSON RcvConnEvent where
+  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RCE"
+
+instance ToJSON RcvConnEvent where
+  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RCE"
+  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RCE"
+
+newtype DBRcvConnEvent = RCE RcvConnEvent
+
+instance FromJSON DBRcvConnEvent where
+  parseJSON v = RCE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "RCE") v
+
+instance ToJSON DBRcvConnEvent where
+  toJSON (RCE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "RCE") v
+  toEncoding (RCE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "RCE") v
+
+instance FromJSON SndConnEvent where
+  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SCE"
+
+instance ToJSON SndConnEvent where
+  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SCE"
+  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SCE"
+
+newtype DBSndConnEvent = SCE SndConnEvent
+
+instance FromJSON DBSndConnEvent where
+  parseJSON v = SCE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "SCE") v
+
+instance ToJSON DBSndConnEvent where
+  toJSON (SCE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "SCE") v
+  toEncoding (SCE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "SCE") v
+
 newtype DBMsgErrorType = DBME MsgErrorType
 
 instance FromJSON DBMsgErrorType where
@@ -653,6 +707,8 @@ ciContentToText = \case
   CISndGroupInvitation groupInvitation memberRole -> "sent " <> ciGroupInvitationToText groupInvitation memberRole
   CIRcvGroupEvent event -> rcvGroupEventToText event
   CISndGroupEvent event -> sndGroupEventToText event
+  CIRcvConnEvent event -> rcvConnEventToText event
+  CISndConnEvent event -> sndConnEventToText event
 
 msgIntegrityError :: MsgErrorType -> Text
 msgIntegrityError = \case
@@ -701,6 +757,8 @@ data JSONCIContent
   | JCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
   | JCIRcvGroupEvent {rcvGroupEvent :: RcvGroupEvent}
   | JCISndGroupEvent {sndGroupEvent :: SndGroupEvent}
+  | JCIRcvConnEvent {rcvConnEvent :: RcvConnEvent}
+  | JCISndConnEvent {sndConnEvent :: SndConnEvent}
   deriving (Generic)
 
 instance FromJSON JSONCIContent where
@@ -723,6 +781,8 @@ jsonCIContent = \case
   CISndGroupInvitation groupInvitation memberRole -> JCISndGroupInvitation {groupInvitation, memberRole}
   CIRcvGroupEvent rcvGroupEvent -> JCIRcvGroupEvent {rcvGroupEvent}
   CISndGroupEvent sndGroupEvent -> JCISndGroupEvent {sndGroupEvent}
+  CIRcvConnEvent rcvConnEvent -> JCIRcvConnEvent {rcvConnEvent}
+  CISndConnEvent sndConnEvent -> JCISndConnEvent {sndConnEvent}
 
 aciContentJSON :: JSONCIContent -> ACIContent
 aciContentJSON = \case
@@ -737,6 +797,8 @@ aciContentJSON = \case
   JCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
   JCIRcvGroupEvent {rcvGroupEvent} -> ACIContent SMDRcv $ CIRcvGroupEvent rcvGroupEvent
   JCISndGroupEvent {sndGroupEvent} -> ACIContent SMDSnd $ CISndGroupEvent sndGroupEvent
+  JCIRcvConnEvent {rcvConnEvent} -> ACIContent SMDRcv $ CIRcvConnEvent rcvConnEvent
+  JCISndConnEvent {sndConnEvent} -> ACIContent SMDSnd $ CISndConnEvent sndConnEvent
 
 -- platform independent
 data DBJSONCIContent
@@ -751,6 +813,8 @@ data DBJSONCIContent
   | DBJCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
   | DBJCIRcvGroupEvent {rcvGroupEvent :: DBRcvGroupEvent}
   | DBJCISndGroupEvent {sndGroupEvent :: DBSndGroupEvent}
+  | DBJCIRcvConnEvent {rcvConnEvent :: DBRcvConnEvent}
+  | DBJCISndConnEvent {sndConnEvent :: DBSndConnEvent}
   deriving (Generic)
 
 instance FromJSON DBJSONCIContent where
@@ -773,6 +837,8 @@ dbJsonCIContent = \case
   CISndGroupInvitation groupInvitation memberRole -> DBJCISndGroupInvitation {groupInvitation, memberRole}
   CIRcvGroupEvent rge -> DBJCIRcvGroupEvent $ RGE rge
   CISndGroupEvent sge -> DBJCISndGroupEvent $ SGE sge
+  CIRcvConnEvent rce -> DBJCIRcvConnEvent $ RCE rce
+  CISndConnEvent sce -> DBJCISndConnEvent $ SCE sce
 
 aciContentDBJSON :: DBJSONCIContent -> ACIContent
 aciContentDBJSON = \case
@@ -787,6 +853,8 @@ aciContentDBJSON = \case
   DBJCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
   DBJCIRcvGroupEvent (RGE rge) -> ACIContent SMDRcv $ CIRcvGroupEvent rge
   DBJCISndGroupEvent (SGE sge) -> ACIContent SMDSnd $ CISndGroupEvent sge
+  DBJCIRcvConnEvent (RCE rce) -> ACIContent SMDRcv $ CIRcvConnEvent rce
+  DBJCISndConnEvent (SCE sce) -> ACIContent SMDSnd $ CISndConnEvent sce
 
 data CICallStatus
   = CISCallPending

src/Simplex/Chat/Mobile.hs

@@ -31,13 +31,12 @@ import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
 import Simplex.Chat.Options
 import Simplex.Chat.Store
 import Simplex.Chat.Types
-import Simplex.Chat.Util (safeDecodeUtf8)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (yesToMigrations), createAgentStore)
 import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore)
 import Simplex.Messaging.Client (defaultNetworkConfig)
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Protocol (CorrId (..))
-import Simplex.Messaging.Util (catchAll)
+import Simplex.Messaging.Util (catchAll, safeDecodeUtf8)
 import System.Timeout (timeout)
 
 foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString

src/Simplex/Chat/Protocol.hs

@@ -39,11 +39,10 @@ import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.Generics (Generic)
 import Simplex.Chat.Call
 import Simplex.Chat.Types
-import Simplex.Chat.Util (safeDecodeUtf8)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (fromTextField_, fstToLower, parseAll, sumTypeJSON)
-import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
+import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
 
 data ConnectionEntity
   = RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}

src/Simplex/Chat/Terminal/Input.hs

@@ -16,8 +16,8 @@ import Simplex.Chat
 import Simplex.Chat.Controller
 import Simplex.Chat.Styled
 import Simplex.Chat.Terminal.Output
-import Simplex.Chat.Util (safeDecodeUtf8)
 import Simplex.Chat.View
+import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.Exit (exitSuccess)
 import System.Terminal hiding (insertChars)
 import UnliftIO.STM

src/Simplex/Chat/Types.hs

@@ -367,6 +367,15 @@ instance ToJSON GroupMember where
   toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
   toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
 
+data GroupMemberRef = GroupMemberRef {groupMemberId :: Int64, profile :: Profile}
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON GroupMemberRef where toEncoding = J.genericToEncoding J.defaultOptions
+
+groupMemberRef :: GroupMember -> GroupMemberRef
+groupMemberRef GroupMember {groupMemberId, memberProfile = p} =
+  GroupMemberRef {groupMemberId, profile = fromLocalProfile p}
+
 memberConn :: GroupMember -> Maybe Connection
 memberConn = activeConn
 

src/Simplex/Chat/Util.hs

@@ -1,10 +0,0 @@
-module Simplex.Chat.Util where
-
-import Data.ByteString.Char8 (ByteString)
-import Data.Text (Text)
-import Data.Text.Encoding (decodeUtf8With)
-
-safeDecodeUtf8 :: ByteString -> Text
-safeDecodeUtf8 = decodeUtf8With onError
-  where
-    onError _ _ = Just '?'

src/Simplex/Chat/View.hs

@@ -67,6 +67,8 @@ responseToView testView = \case
   CRNetworkConfig cfg -> viewNetworkConfig cfg
   CRContactInfo ct cStats customUserProfile -> viewContactInfo ct cStats customUserProfile
   CRGroupMemberInfo g m cStats -> viewGroupMemberInfo g m cStats
+  CRContactSwitch ct progress -> viewContactSwitch ct progress
+  CRGroupMemberSwitch g m progress -> viewGroupMemberSwitch g m progress
   CRNewChatItem (AChatItem _ _ chat item) -> unmuted chat item $ viewChatItem chat item False
   CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True) chatItems
   CRChatItemStatusUpdated _ -> []
@@ -254,19 +256,15 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} doShow = c
   DirectChat c -> case chatDir of
     CIDirectSnd -> case content of
       CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
-      CISndDeleted _ -> showSndItem to
-      CISndCall {} -> showSndItem to
-      CISndGroupInvitation {} -> showSndItem to
       CISndGroupEvent {} -> showSndItemProhibited to
+      _ -> showSndItem to
       where
         to = ttyToContact' c
     CIDirectRcv -> case content of
       CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
-      CIRcvDeleted _ -> showRcvItem from
-      CIRcvCall {} -> showRcvItem from
       CIRcvIntegrityError err -> viewRcvIntegrityError from err meta
-      CIRcvGroupInvitation {} -> showRcvItem from
       CIRcvGroupEvent {} -> showRcvItemProhibited from
+      _ -> showRcvItem from
       where
         from = ttyFromContact' c
     where
@@ -274,19 +272,15 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} doShow = c
   GroupChat g -> case chatDir of
     CIGroupSnd -> case content of
       CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
-      CISndDeleted _ -> showSndItem to
-      CISndCall {} -> showSndItem to
       CISndGroupInvitation {} -> showSndItemProhibited to
-      CISndGroupEvent {} -> showSndItem to
+      _ -> showSndItem to
       where
         to = ttyToGroup g
     CIGroupRcv m -> case content of
       CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
-      CIRcvDeleted _ -> showRcvItem from
-      CIRcvCall {} -> showRcvItem from
       CIRcvIntegrityError err -> viewRcvIntegrityError from err meta
       CIRcvGroupInvitation {} -> showRcvItemProhibited from
-      CIRcvGroupEvent {} -> showRcvItem from
+      _ -> showRcvItem from
       where
         from = ttyFromGroup' g m
     where
@@ -682,6 +676,22 @@ viewServers = plain . intercalate ", " . map (B.unpack . strEncode)
 viewServerHosts :: [SMPServer] -> StyledString
 viewServerHosts = plain . intercalate ", " . map showSMPServer
 
+viewContactSwitch :: Contact -> SwitchProgress -> [StyledString]
+viewContactSwitch _ (SwitchProgress _ SPConfirmed _) = []
+viewContactSwitch ct (SwitchProgress qd phase _) = case qd of
+  QDRcv -> [ttyContact' ct <> ": you " <> viewSwitchPhase phase]
+  QDSnd -> [ttyContact' ct <> " " <> viewSwitchPhase phase <> " for you"]
+
+viewGroupMemberSwitch :: GroupInfo -> GroupMember -> SwitchProgress -> [StyledString]
+viewGroupMemberSwitch _ _ (SwitchProgress _ SPConfirmed _) = []
+viewGroupMemberSwitch g m (SwitchProgress qd phase _) = case qd of
+  QDRcv -> [ttyGroup' g <> ": you " <> viewSwitchPhase phase <> " for " <> ttyMember m]
+  QDSnd -> [ttyGroup' g <> ": " <> ttyMember m <> " " <> viewSwitchPhase phase <> " for you"]
+
+viewSwitchPhase :: SwitchPhase -> StyledString
+viewSwitchPhase SPCompleted = "changed address"
+viewSwitchPhase phase = plain (strEncode phase) <> " changing address"
+
 viewUserProfileUpdated :: Profile -> Profile -> [StyledString]
 viewUserProfileUpdated Profile {displayName = n, fullName, image} Profile {displayName = n', fullName = fullName', image = image'}
   | n == n' && fullName == fullName' && image == image' = []