core: add remote controller discovery with multicast (#3369)
* draft multicast chat api * prepare tests * Plug discovery into chat api * Add discovery timeout * post-merge fixes * rename discovery state to match others * update for unified invitation * fix review notices * rename, remove stack, update simplexmq --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
GitHub
parent
84e09f195c
commit
42e0400014
@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: c501f4f9ccdd48807a5153697ea1827129841158
|
||||
tag: 40ba94ce72fb4273641c56fd4c60cd133a24925a
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."c501f4f9ccdd48807a5153697ea1827129841158" = "1s99mjc7rjk9wg14m5xddw64a3mlr8l7ba9mclma598hg73l0vaw";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."40ba94ce72fb4273641c56fd4c60cd133a24925a" = "0vqjk4c5vd32y92myv6xr4jhipqza6n08qpii4a0xw6ssm5dgc88";
|
||||
"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";
|
||||
|
||||
@ -1967,10 +1967,12 @@ processChatCommand = \case
|
||||
StoreRemoteFile rh encrypted_ localPath -> withUser_ $ CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath
|
||||
GetRemoteFile rh rf -> withUser_ $ getRemoteFile rh rf >> ok_
|
||||
ConnectRemoteCtrl inv -> withUser_ $ do
|
||||
(remoteCtrl_, ctrlAppInfo) <- connectRemoteCtrl inv
|
||||
(remoteCtrl_, ctrlAppInfo) <- connectRemoteCtrlURI inv
|
||||
pure CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion = currentAppVersion}
|
||||
FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl >> ok_
|
||||
ConfirmRemoteCtrl rc -> withUser_ $ confirmRemoteCtrl rc >> ok_
|
||||
ConfirmRemoteCtrl rcId -> withUser_ $ do
|
||||
(rc, ctrlAppInfo) <- confirmRemoteCtrl rcId
|
||||
pure CRRemoteCtrlConnecting {remoteCtrl_ = Just rc, ctrlAppInfo, appVersion = currentAppVersion}
|
||||
VerifyRemoteCtrlSession sessId -> withUser_ $ CRRemoteCtrlConnected <$> verifyRemoteCtrlSession (execChatCommand Nothing) sessId
|
||||
StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_
|
||||
ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls
|
||||
|
||||
@ -75,7 +75,7 @@ import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (allFinally, catchAllErrors, liftEitherError, tryAllErrors, (<$$>))
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.RemoteControl.Client
|
||||
import Simplex.RemoteControl.Invitation (RCSignedInvitation)
|
||||
import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitation)
|
||||
import Simplex.RemoteControl.Types
|
||||
import System.IO (Handle)
|
||||
import System.Mem.Weak (Weak)
|
||||
@ -1061,6 +1061,8 @@ data RemoteCtrlError
|
||||
| RCEBadState -- ^ A session is in a wrong state for the current operation
|
||||
| RCEBusy -- ^ A session is already running
|
||||
| RCETimeout
|
||||
| RCENoKnownControllers -- ^ No previously-contacted controllers to discover
|
||||
| RCEBadController -- ^ Attempting to confirm a found controller with another ID
|
||||
| RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller
|
||||
| RCEBadInvitation
|
||||
| RCEBadVersion {appVersion :: AppVersion}
|
||||
@ -1076,6 +1078,10 @@ data ArchiveError
|
||||
-- | Host (mobile) side of transport to process remote commands and forward notifications
|
||||
data RemoteCtrlSession
|
||||
= RCSessionStarting
|
||||
| RCSessionSearching
|
||||
{ action :: Async (),
|
||||
foundCtrl :: TMVar (RemoteCtrl, RCVerifiedInvitation)
|
||||
}
|
||||
| RCSessionConnecting
|
||||
{ remoteCtrlId_ :: Maybe RemoteCtrlId,
|
||||
rcsClient :: RCCtrlClient,
|
||||
@ -1101,6 +1107,7 @@ data RemoteCtrlSession
|
||||
|
||||
data RemoteCtrlSessionState
|
||||
= RCSStarting
|
||||
| RCSSearching
|
||||
| RCSConnecting
|
||||
| RCSPendingConfirmation {sessionCode :: Text}
|
||||
| RCSConnected {sessionCode :: Text}
|
||||
@ -1109,6 +1116,7 @@ data RemoteCtrlSessionState
|
||||
rcsSessionState :: RemoteCtrlSession -> RemoteCtrlSessionState
|
||||
rcsSessionState = \case
|
||||
RCSessionStarting -> RCSStarting
|
||||
RCSessionSearching {} -> RCSSearching
|
||||
RCSessionConnecting {} -> RCSConnecting
|
||||
RCSessionPendingConfirmation {tls} -> RCSPendingConfirmation {sessionCode = tlsSessionCode tls}
|
||||
RCSessionConnected {tls} -> RCSConnected {sessionCode = tlsSessionCode tls}
|
||||
|
||||
@ -8,7 +8,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Remote where
|
||||
@ -28,12 +27,13 @@ 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 qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Word (Word16, Word32)
|
||||
import Data.Word (Word32)
|
||||
import qualified Network.HTTP.Types as N
|
||||
import Network.HTTP2.Server (responseStreaming)
|
||||
import qualified Paths_simplex_chat as SC
|
||||
@ -54,18 +54,16 @@ import Simplex.Chat.Util (encryptFile)
|
||||
import Simplex.FileTransfer.Description (FileDigest (..))
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType (RCP))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (TLS, closeConnection, tlsUniq)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2ClientError, closeHTTP2Client)
|
||||
import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.RemoteControl.Client
|
||||
import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..))
|
||||
import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..), RCVerifiedInvitation (..), verifySignedInvitation)
|
||||
import Simplex.RemoteControl.Types
|
||||
import System.FilePath (takeFileName, (</>))
|
||||
import UnliftIO
|
||||
@ -92,6 +90,9 @@ hostAppVersionRange = mkAppVersionRange minRemoteCtrlVersion currentAppVersion
|
||||
networkIOTimeout :: Int
|
||||
networkIOTimeout = 15000000
|
||||
|
||||
discoveryTimeout :: Int
|
||||
discoveryTimeout = 60000000
|
||||
|
||||
-- * Desktop side
|
||||
|
||||
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
|
||||
@ -342,19 +343,61 @@ liftRH rhId = liftError (ChatErrorRemoteHost (RHId rhId) . RHEProtocolError)
|
||||
|
||||
-- * Mobile side
|
||||
|
||||
findKnownRemoteCtrl :: ChatMonad m => m ()
|
||||
findKnownRemoteCtrl = undefined -- do
|
||||
-- ** QR/link
|
||||
|
||||
-- | Use provided OOB link as an annouce
|
||||
connectRemoteCtrl :: ChatMonad m => RCSignedInvitation -> m (Maybe RemoteCtrlInfo, CtrlAppInfo)
|
||||
connectRemoteCtrl signedInv@RCSignedInvitation {invitation = inv@RCInvitation {ca, app}} = handleCtrlError "connectRemoteCtrl" $ do
|
||||
(ctrlInfo@CtrlAppInfo {deviceName = ctrlDeviceName}, v) <- parseCtrlAppInfo app
|
||||
connectRemoteCtrlURI :: ChatMonad m => RCSignedInvitation -> m (Maybe RemoteCtrlInfo, CtrlAppInfo)
|
||||
connectRemoteCtrlURI signedInv = handleCtrlError "connectRemoteCtrl" $ do
|
||||
verifiedInv <- maybe (throwError $ ChatErrorRemoteCtrl RCEBadInvitation) pure $ verifySignedInvitation signedInv
|
||||
withRemoteCtrlSession_ $ maybe (Right ((), Just RCSessionStarting)) (\_ -> Left $ ChatErrorRemoteCtrl RCEBusy)
|
||||
connectRemoteCtrl verifiedInv
|
||||
|
||||
-- ** Multicast
|
||||
|
||||
findKnownRemoteCtrl :: ChatMonad m => m ()
|
||||
findKnownRemoteCtrl = handleCtrlError "findKnownRemoteCtrl" $ do
|
||||
knownCtrls <- withStore' getRemoteCtrls
|
||||
pairings <- case nonEmpty knownCtrls of
|
||||
Nothing -> throwError $ ChatErrorRemoteCtrl RCENoKnownControllers
|
||||
Just ne -> pure $ fmap (\RemoteCtrl {ctrlPairing} -> ctrlPairing) ne
|
||||
withRemoteCtrlSession_ $ maybe (Right ((), Just RCSessionStarting)) (\_ -> Left $ ChatErrorRemoteCtrl RCEBusy)
|
||||
foundCtrl <- newEmptyTMVarIO
|
||||
cmdOk <- newEmptyTMVarIO
|
||||
action <- async $ handleCtrlError "findKnownRemoteCtrl.discover" $ do
|
||||
atomically $ takeTMVar cmdOk
|
||||
(RCCtrlPairing {ctrlFingerprint}, inv) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
|
||||
rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
|
||||
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
||||
Just rc -> pure rc
|
||||
atomically $ putTMVar foundCtrl (rc, inv)
|
||||
toView CRRemoteCtrlFound {remoteCtrl = remoteCtrlInfo rc (Just RCSSearching)}
|
||||
withRemoteCtrlSession $ \case
|
||||
RCSessionStarting -> Right ((), RCSessionSearching {action, foundCtrl})
|
||||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
|
||||
atomically $ putTMVar cmdOk ()
|
||||
|
||||
confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m (RemoteCtrlInfo, CtrlAppInfo)
|
||||
confirmRemoteCtrl rcId = do
|
||||
(listener, found) <- withRemoteCtrlSession $ \case
|
||||
RCSessionSearching {action, foundCtrl} -> Right ((action, foundCtrl), RCSessionStarting) -- drop intermediate "Searching" state so connectRemoteCtrl can proceed
|
||||
_ -> throwError $ ChatErrorRemoteCtrl RCEBadState
|
||||
uninterruptibleCancel listener
|
||||
(RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
|
||||
unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController
|
||||
connectRemoteCtrl verifiedInv >>= \case
|
||||
(Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
||||
(Just rci, appInfo) -> pure (rci, appInfo)
|
||||
|
||||
-- ** Common
|
||||
|
||||
connectRemoteCtrl :: ChatMonad m => RCVerifiedInvitation -> m (Maybe RemoteCtrlInfo, CtrlAppInfo)
|
||||
connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app}) = handleCtrlError "connectRemoteCtrl" $ do
|
||||
(ctrlInfo@CtrlAppInfo {deviceName = ctrlDeviceName}, v) <- parseCtrlAppInfo app
|
||||
rc_ <- withStore' $ \db -> getRemoteCtrlByFingerprint db ca
|
||||
mapM_ (validateRemoteCtrl inv) rc_
|
||||
hostAppInfo <- getHostAppInfo v
|
||||
(rcsClient, vars) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout . withAgent $ \a ->
|
||||
rcConnectCtrlURI a signedInv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo)
|
||||
rcConnectCtrl a verifiedInv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo)
|
||||
cmdOk <- newEmptyTMVarIO
|
||||
rcsWaitSession <- async $ do
|
||||
atomically $ takeTMVar cmdOk
|
||||
@ -420,9 +463,6 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque
|
||||
attach send
|
||||
flush
|
||||
|
||||
timeoutThrow :: (MonadUnliftIO m, MonadError e m) => e -> Int -> m a -> m a
|
||||
timeoutThrow e ms action = timeout ms action >>= maybe (throwError e) pure
|
||||
|
||||
takeRCStep :: ChatMonad m => RCStepTMVar a -> m a
|
||||
takeRCStep = liftEitherError (\e -> ChatErrorAgent {agentError = RCP e, connectionEntity_ = Nothing}) . atomically . takeTMVar
|
||||
|
||||
@ -482,10 +522,6 @@ handleGetFile encryption User {userId} RemoteFile {userId = commandUserId, fileI
|
||||
encFile <- liftRC $ prepareEncryptedFile encryption (h, fileSize)
|
||||
reply RRFile {fileSize, fileDigest} $ sendEncryptedFile encFile
|
||||
|
||||
discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> m ()
|
||||
discoverRemoteCtrls discovered = do
|
||||
error "TODO: discoverRemoteCtrls"
|
||||
|
||||
listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo]
|
||||
listRemoteCtrls = do
|
||||
session <- chatReadVar remoteCtrlSession
|
||||
@ -506,15 +542,6 @@ remoteCtrlInfo :: RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
|
||||
remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlDeviceName} sessionState =
|
||||
RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState}
|
||||
|
||||
-- XXX: only used for multicast
|
||||
confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
|
||||
confirmRemoteCtrl _rcId = do
|
||||
-- TODO check it exists, check the ID is the same as in session
|
||||
-- RemoteCtrlSession {confirmed} <- getRemoteCtrlSession
|
||||
-- withStore' $ \db -> markRemoteCtrlResolution db rcId True
|
||||
-- atomically . void $ tryPutTMVar confirmed rcId -- the remote host can now proceed with connection
|
||||
undefined
|
||||
|
||||
-- | Take a look at emoji of tlsunique, commit pairing, and start session server
|
||||
verifyRemoteCtrlSession :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteCtrlInfo
|
||||
verifyRemoteCtrlSession execChatCommand sessCode' = handleCtrlError "verifyRemoteCtrlSession" $ do
|
||||
@ -555,10 +582,11 @@ stopRemoteCtrl :: ChatMonad m => m ()
|
||||
stopRemoteCtrl = cancelActiveRemoteCtrl False
|
||||
|
||||
handleCtrlError :: ChatMonad m => Text -> m a -> m a
|
||||
handleCtrlError name action = action `catchChatError` \e -> do
|
||||
logError $ name <> " remote ctrl error: " <> tshow e
|
||||
cancelActiveRemoteCtrl True
|
||||
throwError e
|
||||
handleCtrlError name action =
|
||||
action `catchChatError` \e -> do
|
||||
logError $ name <> " remote ctrl error: " <> tshow e
|
||||
cancelActiveRemoteCtrl True
|
||||
throwError e
|
||||
|
||||
cancelActiveRemoteCtrl :: ChatMonad m => Bool -> m ()
|
||||
cancelActiveRemoteCtrl handlingError = handleAny (logError . tshow) $ do
|
||||
@ -570,6 +598,7 @@ cancelActiveRemoteCtrl handlingError = handleAny (logError . tshow) $ do
|
||||
cancelRemoteCtrl :: Bool -> RemoteCtrlSession -> IO ()
|
||||
cancelRemoteCtrl handlingError = \case
|
||||
RCSessionStarting -> pure ()
|
||||
RCSessionSearching {action} -> uninterruptibleCancel action
|
||||
RCSessionConnecting {rcsClient, rcsWaitSession} -> do
|
||||
unless handlingError $ uninterruptibleCancel rcsWaitSession
|
||||
cancelCtrlClient rcsClient
|
||||
|
||||
@ -1724,6 +1724,7 @@ viewRemoteCtrls = \case
|
||||
plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> maybe "" viewSessionState sessionState
|
||||
viewSessionState = \case
|
||||
RCSStarting -> " (starting)"
|
||||
RCSSearching -> " (searching)"
|
||||
RCSConnecting -> " (connecting)"
|
||||
RCSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")"
|
||||
RCSConnected _ -> " (connected)"
|
||||
|
||||
@ -49,7 +49,7 @@ extra-deps:
|
||||
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
|
||||
# - ../simplexmq
|
||||
- github: simplex-chat/simplexmq
|
||||
commit: c501f4f9ccdd48807a5153697ea1827129841158
|
||||
commit: 40ba94ce72fb4273641c56fd4c60cd133a24925a
|
||||
- github: kazu-yamamoto/http2
|
||||
commit: f5525b755ff2418e6e6ecc69e877363b0d0bcaeb
|
||||
# - ../direct-sqlcipher
|
||||
|
||||
@ -36,6 +36,7 @@ remoteTests = describe "Remote" $ do
|
||||
it "connects with new pairing (stops mobile)" $ remoteHandshakeTest False
|
||||
it "connects with new pairing (stops desktop)" $ remoteHandshakeTest True
|
||||
it "connects with stored pairing" remoteHandshakeStoredTest
|
||||
it "connects with multicast discovery" remoteHandshakeDiscoverTest
|
||||
it "refuses invalid client cert" remoteHandshakeRejectTest
|
||||
it "sends messages" remoteMessageTest
|
||||
describe "remote files" $ do
|
||||
@ -96,6 +97,16 @@ remoteHandshakeStoredTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile
|
||||
startRemoteStored mobile desktop
|
||||
stopMobile mobile desktop `catchAny` (logError . tshow)
|
||||
|
||||
remoteHandshakeDiscoverTest :: HasCallStack => FilePath -> IO ()
|
||||
remoteHandshakeDiscoverTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do
|
||||
logNote "Preparing new session"
|
||||
startRemote mobile desktop
|
||||
stopMobile mobile desktop `catchAny` (logError . tshow)
|
||||
|
||||
logNote "Starting stored session with multicast"
|
||||
startRemoteDiscover mobile desktop
|
||||
stopMobile mobile desktop `catchAny` (logError . tshow)
|
||||
|
||||
remoteHandshakeRejectTest :: HasCallStack => FilePath -> IO ()
|
||||
remoteHandshakeRejectTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop mobileBob -> do
|
||||
logNote "Starting new session"
|
||||
@ -420,12 +431,8 @@ startRemote mobile desktop = do
|
||||
mobile ##> ("/connect remote ctrl " <> inv)
|
||||
mobile <## "connecting new remote controller: My desktop, v5.4.0.3"
|
||||
desktop <## "new remote host connecting"
|
||||
desktop <## "Compare session code with host:"
|
||||
sessId <- getTermLine desktop
|
||||
mobile <## "new remote controller connected"
|
||||
mobile <## "Compare session code with controller and use:"
|
||||
mobile <## ("/verify remote ctrl " <> sessId)
|
||||
mobile ##> ("/verify remote ctrl " <> sessId)
|
||||
verifyRemoteCtrl mobile desktop
|
||||
mobile <## "remote controller 1 session started with My desktop"
|
||||
desktop <## "new remote host 1 added: Mobile"
|
||||
desktop <## "remote host 1 connected"
|
||||
@ -439,14 +446,37 @@ startRemoteStored mobile desktop = do
|
||||
mobile ##> ("/connect remote ctrl " <> inv)
|
||||
mobile <## "connecting remote controller 1: My desktop, v5.4.0.3"
|
||||
desktop <## "remote host 1 connecting"
|
||||
mobile <## "remote controller 1 connected"
|
||||
verifyRemoteCtrl mobile desktop
|
||||
mobile <## "remote controller 1 session started with My desktop"
|
||||
desktop <## "remote host 1 connected"
|
||||
|
||||
startRemoteDiscover :: TestCC -> TestCC -> IO ()
|
||||
startRemoteDiscover mobile desktop = do
|
||||
desktop ##> "/start remote host 1 multicast=on"
|
||||
desktop <## "remote host 1 started"
|
||||
desktop <## "Remote session invitation:"
|
||||
_inv <- getTermLine desktop -- will use multicast instead
|
||||
mobile ##> "/find remote ctrl"
|
||||
mobile <## "ok"
|
||||
mobile <## "remote controller found:"
|
||||
mobile <## "1. My desktop"
|
||||
mobile ##> "/confirm remote ctrl 1"
|
||||
|
||||
mobile <## "connecting remote controller 1: My desktop, v5.4.0.3"
|
||||
desktop <## "remote host 1 connecting"
|
||||
mobile <## "remote controller 1 connected"
|
||||
verifyRemoteCtrl mobile desktop
|
||||
mobile <## "remote controller 1 session started with My desktop"
|
||||
desktop <## "remote host 1 connected"
|
||||
|
||||
verifyRemoteCtrl :: TestCC -> TestCC -> IO ()
|
||||
verifyRemoteCtrl mobile desktop = do
|
||||
desktop <## "Compare session code with host:"
|
||||
sessId <- getTermLine desktop
|
||||
mobile <## "remote controller 1 connected"
|
||||
mobile <## "Compare session code with controller and use:"
|
||||
mobile <## ("/verify remote ctrl " <> sessId)
|
||||
mobile ##> ("/verify remote ctrl " <> sessId)
|
||||
mobile <## "remote controller 1 session started with My desktop"
|
||||
desktop <## "remote host 1 connected"
|
||||
|
||||
contactBob :: TestCC -> TestCC -> IO ()
|
||||
contactBob desktop bob = do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user