mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-29 12:49:53 +00:00
add remote host bindings (#3471)
* add remote host bindings * group iface/address together * rename migration * add implementation * update view and api * bump upstream * add schema --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
GitHub
parent
950bbe19da
commit
6a21d5c7f1
14 changed files with 139 additions and 48 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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";
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
22
src/Simplex/Chat/Migrations/M20231126_remote_ctrl_address.hs
Normal file
22
src/Simplex/Chat/Migrations/M20231126_remote_ctrl_address.hs
Normal file
|
|
@ -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;
|
||||
|]
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue