blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

add remote host bindings (#3471)

Browse Source 
* 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
2023-11-28 18:32:33 +02:00
committed by GitHub
parent 950bbe19da
commit 6a21d5c7f1
14 changed files with 139 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Remote.hs
+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