diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 664661603..dad00fcef 100644 --- a/src/Simplex/Chat.hs +++ b/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), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 6832bb562..a9950372b 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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} diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 53b63d72b..ef5589e5a 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/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 = diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index ca47cb15e..177f3400d 100644 --- a/src/Simplex/Chat/View.hs +++ b/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_, diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index a2aff4bf5..83b0d507b 100644 --- a/tests/ChatTests/Utils.hs +++ b/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 diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index b35e54032..9c135a81a 100644 --- a/tests/RemoteTests.hs +++ b/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 ()