Merge branch 'master' into master-ghc8107

This commit is contained in:
spaced4ndy
2023-11-30 20:56:51 +04:00
32 changed files with 449 additions and 271 deletions
+6 -6
View File
@@ -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
@@ -556,8 +557,8 @@ data ChatResponse
| CRInvitation {user :: User, connReqInvitation :: ConnReqInvitation, connection :: PendingContactConnection}
| CRConnectionIncognitoUpdated {user :: User, toConnection :: PendingContactConnection}
| CRConnectionPlan {user :: User, connectionPlan :: ConnectionPlan}
| CRSentConfirmation {user :: User}
| CRSentInvitation {user :: User, customUserProfile :: Maybe Profile}
| CRSentConfirmation {user :: User, connection :: PendingContactConnection}
| CRSentInvitation {user :: User, connection :: PendingContactConnection, customUserProfile :: Maybe Profile}
| CRSentInvitationToContact {user :: User, contact :: Contact, customUserProfile :: Maybe Profile}
| CRContactUpdated {user :: User, fromContact :: Contact, toContact :: Contact}
| CRGroupMemberUpdated {user :: User, groupInfo :: GroupInfo, fromMember :: GroupMember, toMember :: GroupMember}
@@ -654,11 +655,10 @@ data ChatResponse
| CRNtfTokenStatus {status :: NtfTknStatus}
| CRNtfToken {token :: DeviceToken, status :: NtfTknStatus, ntfMode :: NotificationsMode}
| CRNtfMessages {user_ :: Maybe User, connEntity :: Maybe ConnectionEntity, msgTs :: Maybe UTCTime, ntfMessages :: [NtfMsgInfo]}
| CRNewContactConnection {user :: User, connection :: PendingContactConnection}
| 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}
@@ -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
+18 -16
View File
@@ -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
+6
View File
@@ -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
+3 -1
View File
@@ -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
+25 -13
View File
@@ -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)
+12 -7
View File
@@ -64,6 +64,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
@@ -162,8 +163,8 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRInvitation u cReq _ -> ttyUser u $ viewConnReqInvitation cReq
CRConnectionIncognitoUpdated u c -> ttyUser u $ viewConnectionIncognitoUpdated c
CRConnectionPlan u connectionPlan -> ttyUser u $ viewConnectionPlan connectionPlan
CRSentConfirmation u -> ttyUser u ["confirmation sent!"]
CRSentInvitation u customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
CRSentConfirmation u _ -> ttyUser u ["confirmation sent!"]
CRSentInvitation u _ customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
CRSentInvitationToContact u _c customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
CRContactDeleted u c -> ttyUser u [ttyContact' c <> ": contact is deleted"]
CRContactDeletedByContact u c -> ttyUser u [ttyFullContact c <> " deleted contact with you"]
@@ -273,7 +274,6 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRCallInvitations _ -> []
CRUserContactLinkSubscribed -> ["Your address is active! To show: " <> highlight' "/sa"]
CRUserContactLinkSubError e -> ["user address error: " <> sShow e, "to delete your address: " <> highlight' "/da"]
CRNewContactConnection u _ -> ttyUser u []
CRContactConnectionDeleted u PendingContactConnection {pccConnId} -> ttyUser u ["connection :" <> sShow pccConnId <> " deleted"]
CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)]
CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)]
@@ -285,13 +285,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:",
@@ -1712,8 +1712,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)"