diff --git a/cabal.project b/cabal.project index 05857ba8f..eed550df5 100644 --- a/cabal.project +++ b/cabal.project @@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 757b7eec81341d8560a326deab303bb6fb6a26a3 + tag: febf9019e25e3de35f1b005da59e8434e12ae54b source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index cf61c6376..ad2343aff 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."757b7eec81341d8560a326deab303bb6fb6a26a3" = "0kqnxpyz8v43802fncqxdg6i2ni70yv7jg7a1nbkny1w937fwf40"; + "https://github.com/simplex-chat/simplexmq.git"."febf9019e25e3de35f1b005da59e8434e12ae54b" = "0rd6cf600978l7xp1sajn9lswml72ms0f55h5q7rxbwpbgx9c3if"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/kazu-yamamoto/http2.git"."f5525b755ff2418e6e6ecc69e877363b0d0bcaeb" = "0fyx0047gvhm99ilp212mmz37j84cwrfnpmssib5dw363fyb88b6"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 0e052ce60..18b5da39a 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -124,6 +124,7 @@ library Simplex.Chat.Migrations.M20231107_indexes Simplex.Chat.Migrations.M20231113_group_forward Simplex.Chat.Migrations.M20231114_remote_control + Simplex.Chat.Migrations.M20231126_remote_ctrl_address Simplex.Chat.Mobile Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index e7575ce3e..0a8b64682 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -105,6 +105,7 @@ import Simplex.Messaging.Transport.Client (defaultSocksProxy) import Simplex.Messaging.Util import Simplex.Messaging.Version import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..)) +import Simplex.RemoteControl.Types (RCCtrlAddress (..)) import System.Exit (ExitCode, exitFailure, exitSuccess) import System.FilePath (takeFileName, ()) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout) @@ -1968,9 +1969,9 @@ processChatCommand = \case SetLocalDeviceName name -> chatWriteVar localDeviceName name >> ok_ ListRemoteHosts -> CRRemoteHostList <$> listRemoteHosts SwitchRemoteHost rh_ -> CRCurrentRemoteHost <$> switchRemoteHost rh_ - StartRemoteHost rh_ -> do - (remoteHost_, inv@RCSignedInvitation {invitation = RCInvitation {port}}) <- startRemoteHost rh_ - pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv, ctrlPort = show port} + StartRemoteHost rh_ ca_ bp_ -> do + (localAddrs, remoteHost_, inv@RCSignedInvitation {invitation = RCInvitation {port}}) <- startRemoteHost rh_ ca_ bp_ + pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv, ctrlPort = show port, localAddrs} StopRemoteHost rh_ -> closeRemoteHost rh_ >> ok_ DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_ StoreRemoteFile rh encrypted_ localPath -> CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath @@ -6189,7 +6190,7 @@ chatCommandP = "/set device name " *> (SetLocalDeviceName <$> textP), "/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))))), + "/start remote host " *> (StartRemoteHost <$> ("new" $> Nothing <|> (Just <$> ((,) <$> A.decimal <*> (" multicast=" *> onOffP <|> pure False)))) <*> optional (A.space *> rcCtrlAddressP) <*> optional (" port=" *> A.decimal)), "/stop remote host " *> (StopRemoteHost <$> ("new" $> RHNew <|> RHId <$> A.decimal)), "/delete remote host " *> (DeleteRemoteHost <$> A.decimal), "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath), @@ -6327,6 +6328,8 @@ chatCommandP = (pure Nothing) srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP) toServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True} + rcCtrlAddressP = RCCtrlAddress <$> ("addr=" *> strP) <*> (" iface=" *> text1P) + text1P = safeDecodeUtf8 <$> A.takeTill (== ' ') char_ = optional . A.char adminContactReq :: ConnReqContact diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index cae17e24a..4ae6636e4 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -41,6 +41,7 @@ import Data.String import Data.Text (Text) import Data.Time (NominalDiffTime, UTCTime) import Data.Version (showVersion) +import Data.Word (Word16) import Language.Haskell.TH (Exp, Q, runIO) import Numeric.Natural import qualified Paths_simplex_chat as SC @@ -426,7 +427,7 @@ data ChatCommand | SetGroupTimedMessages GroupName (Maybe Int) | SetLocalDeviceName Text | ListRemoteHosts - | StartRemoteHost (Maybe (RemoteHostId, Bool)) -- Start new or known remote host with optional multicast for known host + | StartRemoteHost (Maybe (RemoteHostId, Bool)) (Maybe RCCtrlAddress) (Maybe Word16) -- Start new or known remote host with optional multicast for known host | SwitchRemoteHost (Maybe RemoteHostId) -- Switch current remote host | StopRemoteHost RHKey -- Shut down a running session | DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data @@ -469,7 +470,7 @@ allowRemoteCommand = \case APIGetNetworkConfig -> False SetLocalDeviceName _ -> False ListRemoteHosts -> False - StartRemoteHost _ -> False + StartRemoteHost {} -> False SwitchRemoteHost {} -> False StoreRemoteFile {} -> False GetRemoteFile {} -> False @@ -658,7 +659,7 @@ data ChatResponse | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection} | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} | CRCurrentRemoteHost {remoteHost_ :: Maybe RemoteHostInfo} - | CRRemoteHostStarted {remoteHost_ :: Maybe RemoteHostInfo, invitation :: Text, ctrlPort :: String} + | CRRemoteHostStarted {remoteHost_ :: Maybe RemoteHostInfo, invitation :: Text, ctrlPort :: String, localAddrs :: NonEmpty RCCtrlAddress} | CRRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo, sessionCode :: Text} | CRNewRemoteHost {remoteHost :: RemoteHostInfo} | CRRemoteHostConnected {remoteHost :: RemoteHostInfo} diff --git a/src/Simplex/Chat/Migrations/M20231126_remote_ctrl_address.hs b/src/Simplex/Chat/Migrations/M20231126_remote_ctrl_address.hs new file mode 100644 index 000000000..343e4ca6f --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20231126_remote_ctrl_address.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20231126_remote_ctrl_address where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20231126_remote_ctrl_address :: Query +m20231126_remote_ctrl_address = + [sql| +ALTER TABLE remote_hosts ADD COLUMN bind_addr TEXT; +ALTER TABLE remote_hosts ADD COLUMN bind_iface TEXT; +ALTER TABLE remote_hosts ADD COLUMN bind_port INTEGER; +|] + +down_m20231126_remote_ctrl_address :: Query +down_m20231126_remote_ctrl_address = + [sql| +ALTER TABLE remote_hosts DROP COLUMN bind_addr; +ALTER TABLE remote_hosts DROP COLUMN bind_iface; +ALTER TABLE remote_hosts DROP COLUMN bind_port; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index bc441ec6f..19b4d7237 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -537,6 +537,10 @@ CREATE TABLE remote_hosts( id_key BLOB NOT NULL, -- long-term/identity signing key host_fingerprint BLOB NOT NULL, -- remote host CA cert fingerprint, set when connected host_dh_pub BLOB NOT NULL -- last session DH key + , + bind_addr TEXT, + bind_iface TEXT, + bind_port INTEGER ); CREATE TABLE remote_controllers( -- e.g., desktops known to a mobile app diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 98d7289f9..b9989d8af 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -26,13 +26,14 @@ import qualified Data.ByteString.Base64.URL as B64U import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) -import Data.List.NonEmpty (nonEmpty) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Word (Word32) +import Data.Word (Word16, Word32) import qualified Network.HTTP.Types as N import Network.HTTP2.Server (responseStreaming) import qualified Paths_simplex_chat as SC @@ -135,8 +136,8 @@ setNewRemoteHostId sseq rhId = do where err = pure . Left . ChatErrorRemoteHost RHNew -startRemoteHost :: ChatMonad m => Maybe (RemoteHostId, Bool) -> m (Maybe RemoteHostInfo, RCSignedInvitation) -startRemoteHost rh_ = do +startRemoteHost :: ChatMonad m => Maybe (RemoteHostId, Bool) -> Maybe RCCtrlAddress -> Maybe Word16 -> m (NonEmpty RCCtrlAddress, Maybe RemoteHostInfo, RCSignedInvitation) +startRemoteHost rh_ rcAddrPrefs_ port_ = do (rhKey, multicast, remoteHost_, pairing) <- case rh_ of Just (rhId, multicast) -> do rh@RemoteHost {hostPairing} <- withStore $ \db -> getRemoteHost db rhId @@ -144,19 +145,20 @@ startRemoteHost rh_ = do Nothing -> (RHNew,False,Nothing,) <$> rcNewHostPairing sseq <- startRemoteHostSession rhKey ctrlAppInfo <- mkCtrlAppInfo - (invitation, rchClient, vars) <- handleConnectError rhKey sseq . withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast + (localAddrs, invitation, rchClient, vars) <- handleConnectError rhKey sseq . withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast rcAddrPrefs_ port_ + let rcAddr_ = L.head localAddrs <$ rcAddrPrefs_ cmdOk <- newEmptyTMVarIO rhsWaitSession <- async $ do rhKeyVar <- newTVarIO rhKey atomically $ takeTMVar cmdOk - handleHostError sseq rhKeyVar $ waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars + handleHostError sseq rhKeyVar $ waitForHostSession remoteHost_ rhKey sseq rcAddr_ rhKeyVar vars let rhs = RHPendingSession {rhKey, rchClient, rhsWaitSession, remoteHost_} withRemoteHostSession rhKey sseq $ \case RHSessionStarting -> let inv = decodeLatin1 $ strEncode invitation in Right ((), RHSessionConnecting inv rhs) _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState - (remoteHost_, invitation) <$ atomically (putTMVar cmdOk ()) + (localAddrs, remoteHost_, invitation) <$ atomically (putTMVar cmdOk ()) where mkCtrlAppInfo = do deviceName <- chatReadVar localDeviceName @@ -179,8 +181,8 @@ startRemoteHost rh_ = do action `catchChatError` \err -> do logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err)) - waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () - waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars = do + waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> Maybe RCCtrlAddress -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () + waitForHostSession remoteHost_ rhKey sseq rcAddr_ rhKeyVar vars = do (sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars let sessionCode = verificationCode sessId withRemoteHostSession rhKey sseq $ \case @@ -194,7 +196,7 @@ startRemoteHost rh_ = do withRemoteHostSession rhKey sseq $ \case RHSessionPendingConfirmation _ tls' rhs' -> Right ((), RHSessionConfirmed tls' rhs') _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState - rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' rh_' hostDeviceName sseq RHSConfirmed {sessionCode} + rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' rh_' rcAddr_ hostDeviceName sseq RHSConfirmed {sessionCode} let rhKey' = RHId remoteHostId -- rhKey may be invalid after upserting on RHNew when (rhKey' /= rhKey) $ do atomically $ writeTVar rhKeyVar rhKey' @@ -209,17 +211,17 @@ startRemoteHost rh_ = do _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState chatWriteVar currentRemoteHost $ Just remoteHostId -- this is required for commands to be passed to remote host toView $ CRRemoteHostConnected rhi {sessionState = Just RHSConnected {sessionCode}} - upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Text -> SessionSeq -> RemoteHostSessionState -> m RemoteHostInfo - upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ hostDeviceName sseq state = do + upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Maybe RCCtrlAddress -> Text -> SessionSeq -> RemoteHostSessionState -> m RemoteHostInfo + upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ rcAddr_ hostDeviceName sseq state = do KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_ case rhi_ of Nothing -> do storePath <- liftIO randomStorePath - rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath pairing' >>= getRemoteHost db + rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath rcAddr_ port_ pairing' >>= getRemoteHost db setNewRemoteHostId sseq remoteHostId pure $ remoteHostInfo rh $ Just state Just rhi@RemoteHostInfo {remoteHostId} -> do - withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey' + withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey' rcAddr_ port_ pure (rhi :: RemoteHostInfo) {sessionState = Just state} onDisconnected :: ChatMonad m => RHKey -> SessionSeq -> m () onDisconnected rhKey sseq = do @@ -317,8 +319,8 @@ switchRemoteHost rhId_ = do rhi_ <$ chatWriteVar currentRemoteHost rhId_ remoteHostInfo :: RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo -remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName} sessionState = - RemoteHostInfo {remoteHostId, storePath, hostDeviceName, sessionState} +remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName, bindAddress_, bindPort_} sessionState = + RemoteHostInfo {remoteHostId, storePath, hostDeviceName, bindAddress_, bindPort_, sessionState} deleteRemoteHost :: ChatMonad m => RemoteHostId -> m () deleteRemoteHost rhId = do diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index 8411ceea0..d85dde9e8 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -18,6 +18,7 @@ import qualified Data.Aeson.TH as J import Data.ByteString (ByteString) import Data.Int (Int64) import Data.Text (Text) +import Data.Word (Word16) import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Types (verificationCode) import qualified Simplex.Messaging.Crypto as C @@ -128,6 +129,8 @@ data RemoteHost = RemoteHost { remoteHostId :: RemoteHostId, hostDeviceName :: Text, storePath :: FilePath, + bindAddress_ :: Maybe RCCtrlAddress, + bindPort_ :: Maybe Word16, hostPairing :: RCHostPairing } @@ -136,6 +139,8 @@ data RemoteHostInfo = RemoteHostInfo { remoteHostId :: RemoteHostId, hostDeviceName :: Text, storePath :: FilePath, + bindAddress_ :: Maybe RCCtrlAddress, + bindPort_ :: Maybe Word16, sessionState :: Maybe RemoteHostSessionState } deriving (Show) @@ -158,6 +163,7 @@ data PlatformEncoding deriving (Show, Eq) localEncoding :: PlatformEncoding + #if defined(darwin_HOST_OS) && defined(swiftJSON) localEncoding = PESwift #else diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index 7b9ead1b1..31d0525db 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -90,6 +90,7 @@ import Simplex.Chat.Migrations.M20231030_xgrplinkmem_received import Simplex.Chat.Migrations.M20231107_indexes import Simplex.Chat.Migrations.M20231113_group_forward import Simplex.Chat.Migrations.M20231114_remote_control +import Simplex.Chat.Migrations.M20231126_remote_ctrl_address import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -179,7 +180,8 @@ schemaMigrations = ("20231030_xgrplinkmem_received", m20231030_xgrplinkmem_received, Just down_m20231030_xgrplinkmem_received), ("20231107_indexes", m20231107_indexes, Just down_m20231107_indexes), ("20231113_group_forward", m20231113_group_forward, Just down_m20231113_group_forward), - ("20231114_remote_control", m20231114_remote_control, Just down_m20231114_remote_control) + ("20231114_remote_control", m20231114_remote_control, Just down_m20231114_remote_control), + ("20231126_remote_ctrl_address", m20231126_remote_ctrl_address, Just down_m20231126_remote_ctrl_address) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Remote.hs b/src/Simplex/Chat/Store/Remote.hs index ec8486037..a88d87a04 100644 --- a/src/Simplex/Chat/Store/Remote.hs +++ b/src/Simplex/Chat/Store/Remote.hs @@ -8,6 +8,8 @@ module Simplex.Chat.Store.Remote where import Control.Monad.Except import Data.Int (Int64) import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeASCII) +import Data.Word (Word16) import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL import Database.SQLite.Simple.QQ (sql) @@ -16,11 +18,12 @@ import Simplex.Chat.Store.Shared import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.RemoteControl.Types import UnliftIO -insertRemoteHost :: DB.Connection -> Text -> FilePath -> RCHostPairing -> ExceptT StoreError IO RemoteHostId -insertRemoteHost db hostDeviceName storePath RCHostPairing {caKey, caCert, idPrivKey, knownHost = kh_} = do +insertRemoteHost :: DB.Connection -> Text -> FilePath -> Maybe RCCtrlAddress -> Maybe Word16 -> RCHostPairing -> ExceptT StoreError IO RemoteHostId +insertRemoteHost db hostDeviceName storePath rcAddr_ bindPort_ RCHostPairing {caKey, caCert, idPrivKey, knownHost = kh_} = do KnownHostPairing {hostFingerprint, hostDhPubKey} <- maybe (throwError SERemoteHostUnknown) pure kh_ checkConstraint SERemoteHostDuplicateCA . liftIO $ @@ -28,12 +31,14 @@ insertRemoteHost db hostDeviceName storePath RCHostPairing {caKey, caCert, idPri db [sql| INSERT INTO remote_hosts - (host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub) + (host_device_name, store_path, bind_addr, bind_iface, bind_port, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub) VALUES - (?, ?, ?, ?, ?, ?, ?) + (?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |] - (hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey) + (hostDeviceName, storePath, bindAddr_, bindIface_, bindPort_, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey) liftIO $ insertedRowId db + where + (bindAddr_, bindIface_) = rcCtrlAddressFields_ rcAddr_ getRemoteHosts :: DB.Connection -> IO [RemoteHost] getRemoteHosts db = @@ -52,27 +57,34 @@ getRemoteHostByFingerprint db fingerprint = remoteHostQuery :: SQL.Query remoteHostQuery = [sql| - SELECT remote_host_id, host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub + SELECT remote_host_id, host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub, bind_iface, bind_addr, bind_port FROM remote_hosts |] -toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject C.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519) -> RemoteHost -toRemoteHost (remoteHostId, hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey) = - RemoteHost {remoteHostId, hostDeviceName, storePath, hostPairing} +toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject C.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16) -> RemoteHost +toRemoteHost (remoteHostId, hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey, ifaceName_, ifaceAddr_, bindPort_) = + RemoteHost {remoteHostId, hostDeviceName, storePath, hostPairing, bindAddress_, bindPort_} where hostPairing = RCHostPairing {caKey, caCert, idPrivKey, knownHost = Just knownHost} knownHost = KnownHostPairing {hostFingerprint, hostDhPubKey} + bindAddress_ = RCCtrlAddress <$> (decodeAddr <$> ifaceAddr_) <*> ifaceName_ + decodeAddr = either (error "Error parsing TransportHost") id . strDecode . encodeUtf8 -updateHostPairing :: DB.Connection -> RemoteHostId -> Text -> C.PublicKeyX25519 -> IO () -updateHostPairing db rhId hostDeviceName hostDhPubKey = +updateHostPairing :: DB.Connection -> RemoteHostId -> Text -> C.PublicKeyX25519 -> Maybe RCCtrlAddress -> Maybe Word16 -> IO () +updateHostPairing db rhId hostDeviceName hostDhPubKey rcAddr_ bindPort_ = DB.execute db [sql| UPDATE remote_hosts - SET host_device_name = ?, host_dh_pub = ? + SET host_device_name = ?, host_dh_pub = ?, bind_addr = ?, bind_iface = ?, bind_port = ? WHERE remote_host_id = ? |] - (hostDeviceName, hostDhPubKey, rhId) + (hostDeviceName, hostDhPubKey, bindAddr_, bindIface_, bindPort_, rhId) + where + (bindAddr_, bindIface_) = rcCtrlAddressFields_ rcAddr_ + +rcCtrlAddressFields_ :: Maybe RCCtrlAddress -> (Maybe Text, Maybe Text) +rcCtrlAddressFields_ = maybe (Nothing, Nothing) $ \RCCtrlAddress {address, interface} -> (Just . decodeASCII $ strEncode address, Just interface) deleteRemoteHostRecord :: DB.Connection -> RemoteHostId -> IO () deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index c49076d0c..1363fcced 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -65,6 +65,7 @@ import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util (bshow, tshow) import Simplex.Messaging.Version hiding (version) +import Simplex.RemoteControl.Types (RCCtrlAddress (..)) import System.Console.ANSI.Types type CurrentTime = UTCTime @@ -286,13 +287,13 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe rhi_ ] CRRemoteHostList hs -> viewRemoteHosts hs - CRRemoteHostStarted {remoteHost_, invitation, ctrlPort} -> + CRRemoteHostStarted {remoteHost_, invitation, localAddrs = RCCtrlAddress {address} :| _, ctrlPort} -> [ plain $ maybe ("new remote host" <> started) (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> show rhId <> started) remoteHost_, "Remote session invitation:", plain invitation ] where - started = " started on port " <> ctrlPort + started = " started on " <> B.unpack (strEncode address) <> ":" <> ctrlPort CRRemoteHostSessionCode {remoteHost_, sessionCode} -> [ maybe "new remote host connecting" (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> sShow rhId <> " connecting") remoteHost_, "Compare session code with host:", @@ -1713,8 +1714,13 @@ viewRemoteHosts = \case [] -> ["No remote hosts"] hs -> "Remote hosts: " : map viewRemoteHostInfo hs where - viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionState} = - plain $ tshow remoteHostId <> ". " <> hostDeviceName <> maybe "" viewSessionState sessionState + viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionState, bindAddress_, bindPort_} = + plain $ tshow remoteHostId <> ". " <> hostDeviceName <> maybe "" viewSessionState sessionState <> ctrlBinds bindAddress_ bindPort_ + ctrlBinds Nothing Nothing = "" + ctrlBinds rca_ port_ = mconcat [" [", maybe "" rca rca_, maybe "" port port_, "]"] + where + rca RCCtrlAddress {interface, address} = interface <> " " <> decodeLatin1 (strEncode address) + port p = ":" <> tshow p viewSessionState = \case RHSStarting -> " (starting)" RHSConnecting _ -> " (connecting)" diff --git a/stack.yaml b/stack.yaml index 39c96ef75..bc00f838a 100644 --- 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: 757b7eec81341d8560a326deab303bb6fb6a26a3 + commit: febf9019e25e3de35f1b005da59e8434e12ae54b - github: kazu-yamamoto/http2 commit: f5525b755ff2418e6e6ecc69e877363b0d0bcaeb # - ../direct-sqlcipher diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index ea6413834..f03e19149 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -38,6 +38,7 @@ remoteTests = describe "Remote" $ do it "connects with stored pairing" remoteHandshakeStoredTest it "connects with multicast discovery" remoteHandshakeDiscoverTest it "refuses invalid client cert" remoteHandshakeRejectTest + it "connects with stored server bindings" storedBindingsTest it "sends messages" remoteMessageTest describe "remote files" $ do it "store/get/send/receive files" remoteStoreFileTest @@ -117,7 +118,7 @@ remoteHandshakeRejectTest = testChat3 aliceProfile aliceDesktopProfile bobProfil mobileBob ##> "/set device name MobileBob" mobileBob <## "ok" desktop ##> "/start remote host 1" - desktop <##. "remote host 1 started on port " + desktop <##. "remote host 1 started on " desktop <## "Remote session invitation:" inv <- getTermLine desktop mobileBob ##> ("/connect remote ctrl " <> inv) @@ -138,6 +139,37 @@ remoteHandshakeRejectTest = testChat3 aliceProfile aliceDesktopProfile bobProfil desktop <## "remote host 1 connected" stopMobile mobile desktop +storedBindingsTest :: HasCallStack => FilePath -> IO () +storedBindingsTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do + desktop ##> "/set device name My desktop" + desktop <## "ok" + mobile ##> "/set device name Mobile" + mobile <## "ok" + + desktop ##> "/start remote host new addr=127.0.0.1 iface=lo port=52230" + desktop <##. "new remote host started on 127.0.0.1:52230" -- TODO: show ip? + desktop <## "Remote session invitation:" + inv <- getTermLine desktop + + mobile ##> ("/connect remote ctrl " <> inv) + mobile <## ("connecting new remote controller: My desktop, v" <> versionNumber) + desktop <## "new remote host connecting" + mobile <## "new remote controller connected" + verifyRemoteCtrl mobile desktop + mobile <## "remote controller 1 session started with My desktop" + desktop <## "new remote host 1 added: Mobile" + desktop <## "remote host 1 connected" + + desktop ##> "/list remote hosts" + desktop <## "Remote hosts:" + desktop <## "1. Mobile (connected) [lo 127.0.0.1:52230]" + stopDesktop mobile desktop + desktop ##> "/list remote hosts" + desktop <## "Remote hosts:" + desktop <## "1. Mobile [lo 127.0.0.1:52230]" + + -- TODO: more parser tests + remoteMessageTest :: HasCallStack => FilePath -> IO () remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do startRemote mobile desktop @@ -475,7 +507,7 @@ startRemote mobile desktop = do mobile ##> "/set device name Mobile" mobile <## "ok" desktop ##> "/start remote host new" - desktop <##. "new remote host started on port " + desktop <##. "new remote host started on " desktop <## "Remote session invitation:" inv <- getTermLine desktop mobile ##> ("/connect remote ctrl " <> inv) @@ -490,7 +522,7 @@ startRemote mobile desktop = do startRemoteStored :: TestCC -> TestCC -> IO () startRemoteStored mobile desktop = do desktop ##> "/start remote host 1" - desktop <##. "remote host 1 started on port " + desktop <##. "remote host 1 started on " desktop <## "Remote session invitation:" inv <- getTermLine desktop mobile ##> ("/connect remote ctrl " <> inv) @@ -504,7 +536,7 @@ startRemoteStored mobile desktop = do startRemoteDiscover :: TestCC -> TestCC -> IO () startRemoteDiscover mobile desktop = do desktop ##> "/start remote host 1 multicast=on" - desktop <##. "remote host 1 started on port " + desktop <##. "remote host 1 started on " desktop <## "Remote session invitation:" _inv <- getTermLine desktop -- will use multicast instead mobile ##> "/find remote ctrl"