add /switch remote host (#3342)

* Add SwitchRemoteHost

* Add message test

* Match remote prefix and the rest of the line

* Move prefix match to utils

src/Simplex/Chat.hs

@@ -1953,6 +1953,7 @@ processChatCommand = \case
       p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p}
   SetLocalDeviceName name -> withUser_ $ chatWriteVar localDeviceName name >> ok_
   ListRemoteHosts -> withUser_ $ CRRemoteHostList <$> listRemoteHosts
+  SwitchRemoteHost rh_ -> withUser_ $ CRCurrentRemoteHost <$> switchRemoteHost rh_
   StartRemoteHost rh_ -> withUser_ $ do
     (remoteHost_, inv) <- startRemoteHost' rh_
     pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv}
@@ -5977,6 +5978,7 @@ chatCommandP =
       "/set device name " *> (SetLocalDeviceName <$> textP),
       -- "/create remote host" $> CreateRemoteHost,
       "/list remote hosts" $> ListRemoteHosts,
+      "/switch remote host " *> (SwitchRemoteHost <$> ("local" $> Nothing <|> (Just <$> A.decimal))),
       "/start remote host " *> (StartRemoteHost <$> ("new" $> Nothing <|> (Just <$> ((,) <$> A.decimal <*> (" multicast=" *> onOffP <|> pure False))))),
       "/stop remote host " *> (StopRemoteHost <$> ("new" $> RHNew <|> RHId <$> A.decimal)),
       "/delete remote host " *> (DeleteRemoteHost <$> A.decimal),

src/Simplex/Chat/Controller.hs

@@ -425,7 +425,7 @@ data ChatCommand
   -- | CreateRemoteHost -- ^ Configure a new remote host
   | ListRemoteHosts
   | StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host
-  -- | SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host
+  | SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host
   | StopRemoteHost RHKey -- ^ Shut down a running session
   | DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
   | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
@@ -456,7 +456,7 @@ allowRemoteCommand = \case
   QuitChat -> False
   ListRemoteHosts -> False
   StartRemoteHost _ -> False
-  -- SwitchRemoteHost {} -> False
+  SwitchRemoteHost {} -> False
   StoreRemoteFile {} -> False
   GetRemoteFile {} -> False
   StopRemoteHost _ -> False
@@ -644,6 +644,7 @@ data ChatResponse
   | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection}
   | CRRemoteHostCreated {remoteHost :: RemoteHostInfo}
   | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
+  | CRCurrentRemoteHost {remoteHost_ :: Maybe RemoteHostInfo}
   | CRRemoteHostStarted {remoteHost_ :: Maybe RemoteHostInfo, invitation :: Text}
   | CRRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo, sessionCode :: Text}
   | CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
@@ -1051,6 +1052,7 @@ throwDBError = throwError . ChatErrorDatabase
 -- TODO review errors, some of it can be covered by HTTP2 errors
 data RemoteHostError
   = RHEMissing -- ^ No remote session matches this identifier
+  | RHEInactive -- ^ A session exists, but not active
   | RHEBusy -- ^ A session is already running
   | RHEBadState -- ^ Illegal state transition
   | RHEBadVersion {appVersion :: AppVersion}

src/Simplex/Chat/Remote.hs

@@ -248,6 +248,17 @@ listRemoteHosts = do
     rhInfo active rh@RemoteHost {remoteHostId} =
       remoteHostInfo rh (M.member (RHId remoteHostId) active)
 
+switchRemoteHost :: ChatMonad m => Maybe RemoteHostId -> m (Maybe RemoteHostInfo)
+switchRemoteHost rhId_ = do
+  rhi_ <- forM rhId_ $ \rhId -> do
+    let rhKey = RHId rhId
+    rhi <- withError (const $ ChatErrorRemoteHost rhKey RHEMissing) $ (`remoteHostInfo` True) <$> withStore (`getRemoteHost` rhId)
+    active <- chatReadVar remoteHostSessions
+    case M.lookup rhKey active of
+      Just RHSessionConnected {} -> pure rhi
+      _ -> throwError $ ChatErrorRemoteHost rhKey RHEInactive
+  rhi_ <$ chatWriteVar currentRemoteHost rhId_
+
 -- XXX: replacing hostPairing replaced with sessionActive, could be a ($>)
 remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo
 remoteHostInfo RemoteHost {remoteHostId, storePath, hostName} sessionActive =

src/Simplex/Chat/View.hs

@@ -276,6 +276,12 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
   CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)]
   CRNtfMessages {} -> []
   CRRemoteHostCreated RemoteHostInfo {remoteHostId} -> ["remote host " <> sShow remoteHostId <> " created"]
+  CRCurrentRemoteHost rhi_ ->
+    [ maybe
+        "Using local profile"
+        (\RemoteHostInfo {remoteHostId = rhId, hostName} -> "Using remote host " <> sShow rhId <> " (" <> plain hostName <> ")")
+        rhi_
+    ]
   CRRemoteHostList hs -> viewRemoteHosts hs
   CRRemoteHostStarted {remoteHost_, invitation} ->
     [ maybe "new remote host started" (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> sShow rhId <> " started") remoteHost_,

tests/ChatTests/Utils.hs

@@ -327,6 +327,9 @@ cc ?<# line = (dropTime <$> getTermLine cc) `shouldReturn` "i " <> line
 ($<#) :: HasCallStack => (TestCC, String) -> String -> Expectation
 (cc, uName) $<# line = (dropTime . dropUser uName <$> getTermLine cc) `shouldReturn` line
 
+(^<#) :: HasCallStack => (TestCC, String) -> String -> Expectation
+(cc, p) ^<# line = (dropTime . dropStrPrefix p <$> getTermLine cc) `shouldReturn` line
+
 (⩗) :: HasCallStack => TestCC -> String -> Expectation
 cc ⩗ line = (dropTime . dropReceipt <$> getTermLine cc) `shouldReturn` line
 

tests/RemoteTests.hs

@@ -41,6 +41,8 @@ remoteTests = describe "Remote" $ do
   describe "remote files" $ do
     it "store/get/send/receive files" remoteStoreFileTest
     it "should send files from CLI wihtout /store" remoteCLIFileTest
+  it "switches remote hosts" switchRemoteHostTest
+  it "indicates remote hosts" indicateRemoteHostTest
 
 -- * Chat commands
 
@@ -323,6 +325,56 @@ remoteCLIFileTest = testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile
   where
     cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp/tmp"}
 
+switchRemoteHostTest :: FilePath -> IO ()
+switchRemoteHostTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
+  startRemote mobile desktop
+  contactBob desktop bob
+
+  desktop ##> "/contacts"
+  desktop <## "bob (Bob)"
+
+  desktop ##> "/switch remote host local"
+  desktop <## "Using local profile"
+  desktop ##> "/contacts"
+
+  desktop ##> "/switch remote host 1"
+  desktop <## "Using remote host 1 (Mobile)"
+  desktop ##> "/contacts"
+  desktop <## "bob (Bob)"
+
+  desktop ##> "/switch remote host 123"
+  desktop <## "remote host 123 error: RHEMissing"
+
+  stopDesktop mobile desktop
+  desktop ##> "/contacts"
+  desktop ##> "/switch remote host 1"
+  desktop <## "remote host 1 error: RHEInactive"
+  desktop ##> "/contacts"
+
+indicateRemoteHostTest :: FilePath -> IO ()
+indicateRemoteHostTest = testChat4 aliceProfile aliceDesktopProfile bobProfile cathProfile $ \mobile desktop bob cath -> do
+  connectUsers desktop cath
+  startRemote mobile desktop
+  contactBob desktop bob
+  -- remote contact -> remote host
+  bob #> "@alice hi"
+  desktop <#. "bob> hi"
+  -- local -> remote
+  cath #> "@alice_desktop hello"
+  (desktop, "[local] ") ^<# "cath> hello"
+  -- local -> local
+  desktop ##> "/switch remote host local"
+  desktop <## "Using local profile"
+  desktop <##> cath
+  -- local -> remote
+  bob #> "@alice what's up?"
+  (desktop, "[remote: 1] ") ^<# "bob> what's up?"
+
+  -- local -> local after disconnect
+  stopDesktop mobile desktop
+  desktop <##> cath
+  cath <##> desktop
+
 -- * Utils
 
 startRemote :: TestCC -> TestCC -> IO ()