implement some of the robust discovery rfc (#3283)

* implement robust discovery * remove qualified --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2026-03-30 16:25:57 +00:00 · 2023-10-30 16:00:54 +02:00
parent b48690dee6
commit be44632b0b
10 changed files with 430 additions and 150 deletions
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -213,6 +213,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
  rcvFiles <- newTVarIO M.empty
  currentCalls <- atomically TM.empty
  localDeviceName <- newTVarIO "" -- TODO set in config
+  multicastSubscribers <- newTMVarIO 0
  remoteHostSessions <- atomically TM.empty
  remoteHostsFolder <- newTVarIO Nothing
  remoteCtrlSession <- newTVarIO Nothing
@@ -247,6 +248,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
        rcvFiles,
        currentCalls,
        localDeviceName,
+        multicastSubscribers,
        remoteHostSessions,
        remoteHostsFolder,
        remoteCtrlSession,
@@ -5861,8 +5863,8 @@ chatCommandP =
      "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath),
      "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP),
      "/start remote ctrl" $> StartRemoteCtrl,
-      "/register remote ctrl " *> (RegisterRemoteCtrl <$> (RemoteCtrlOOB <$> strP <* A.space <*> textP)),
-      "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP),
+      "/register remote ctrl " *> (RegisterRemoteCtrl <$> strP),
+      -- "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP),
      "/list remote ctrls" $> ListRemoteCtrls,
      "/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal),
      "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal),
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -25,7 +25,7 @@ import Control.Monad.Reader
 import Crypto.Random (ChaChaDRG)
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?))
 import qualified Data.Aeson as J
-import qualified Data.Aeson.TH  as JQ
+import qualified Data.Aeson.TH as JQ
 import qualified Data.Aeson.Types as JT
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
@@ -40,6 +40,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
@@ -177,6 +178,7 @@ data ChatController = ChatController
    rcvFiles :: TVar (Map Int64 Handle),
    currentCalls :: TMap ContactId Call,
    localDeviceName :: TVar Text,
+    multicastSubscribers :: TMVar Int,
    remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts
    remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data
    remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers
@@ -424,12 +426,12 @@ data ChatCommand
  | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
  | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
  | StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers
-  | RegisterRemoteCtrl RemoteCtrlOOB -- ^ Register OOB data for satellite discovery and handshake
+  | RegisterRemoteCtrl SignedOOB -- ^ Register OOB data for remote controller discovery and handshake
  | ListRemoteCtrls
  | AcceptRemoteCtrl RemoteCtrlId -- ^ Accept discovered data and store confirmation
  | RejectRemoteCtrl RemoteCtrlId -- ^ Reject and blacklist discovered data
  | StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session
-  | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a satellite session
+  | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session
  | QuitChat
  | ShowVersion
  | DebugLocks
@@ -634,6 +636,7 @@ data ChatResponse
  | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection}
  | CRRemoteHostCreated {remoteHost :: RemoteHostInfo}
  | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
+  | CRRemoteHostStarted {remoteHost :: RemoteHostInfo, sessionOOB :: Text}
  | CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
  | CRRemoteHostStopped {remoteHostId :: RemoteHostId}
  | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile}
@@ -1069,7 +1072,7 @@ data RemoteCtrlSession = RemoteCtrlSession
    discoverer :: Async (),
    supervisor :: Async (),
    hostServer :: Maybe (Async ()),
-    discovered :: TMap C.KeyHash TransportHost,
+    discovered :: TMap C.KeyHash (TransportHost, Word16),
    accepted :: TMVar RemoteCtrlId,
    remoteOutputQ :: TBQueue ChatResponse
  }
--- a/src/Simplex/Chat/Remote.hs
+++ b/src/Simplex/Chat/Remote.hs
@@ -12,6 +12,7 @@

 module Simplex.Chat.Remote where

+import Control.Applicative ((<|>))
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
@@ -24,15 +25,16 @@ import Data.ByteString (ByteString)
 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 (encodeUtf8)
-import Data.Word (Word32)
-import Network.HTTP2.Server (responseStreaming)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Word (Word16, Word32)
 import qualified Network.HTTP.Types as N
+import Network.HTTP2.Server (responseStreaming)
 import Network.Socket (SockAddr (..), hostAddressToTuple)
 import Simplex.Chat.Archive (archiveFilesFolder)
 import Simplex.Chat.Controller
@@ -51,18 +53,17 @@ import Simplex.FileTransfer.Description (FileDigest (..))
 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 (smpDecode)
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
 import Simplex.Messaging.Transport.HTTP2.File (hSendFile)
 import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
-import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=), (<$$>))
-import System.FilePath ((</>), takeFileName)
+import System.FilePath (takeFileName, (</>))
 import UnliftIO
 import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile)
-import Data.Functor (($>))
-import Control.Applicative ((<|>))

 -- * Desktop side

@@ -108,11 +109,14 @@ startRemoteHost rhId = do
        toView (CRRemoteHostStopped rhId) -- only signal "stopped" when the session is unregistered cleanly
      -- block until some client is connected or an error happens
      logInfo $ "Remote host session connecting for " <> tshow rhId
-      httpClient <- liftEitherError (ChatErrorRemoteCtrl . RCEHTTP2Error . show) $ Discovery.announceRevHTTP2 tasks fingerprint credentials cleanupIO
-      logInfo $ "Remote host session connected for " <> tshow rhId
      rcName <- chatReadVar localDeviceName
+      localAddr <- asks multicastSubscribers >>= Discovery.getLocalAddress >>= maybe (throwError . ChatError $ CEInternalError "unable to get local address") pure
+      (dhKey, sigKey, ann, oob) <- Discovery.startSession (if rcName == "" then Nothing else Just rcName) (localAddr, read Discovery.DISCOVERY_PORT) fingerprint
+      toView CRRemoteHostStarted {remoteHost = remoteHostInfo rh True, sessionOOB = decodeUtf8 $ strEncode oob}
+      httpClient <- liftEitherError (ChatErrorRemoteCtrl . RCEHTTP2Error . show) $ Discovery.announceRevHTTP2 tasks (sigKey, ann) credentials cleanupIO
+      logInfo $ "Remote host session connected for " <> tshow rhId
      -- test connection and establish a protocol layer
-      remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient rcName
+      remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient dhKey rcName
      -- set up message polling
      oq <- asks outputQ
      asyncRegistered tasks . forever $ do
@@ -125,7 +129,6 @@ startRemoteHost rhId = do
        { remoteHostId = rhId,
          storePath = storePath,
          displayName = hostDeviceName remoteHostClient,
-          remoteCtrlOOB = RemoteCtrlOOB {fingerprint, displayName=rcName},
          sessionActive = True
        }

@@ -159,10 +162,9 @@ createRemoteHost = do
  ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) "Host"
  storePath <- liftIO randomStorePath
  let remoteName = "" -- will be passed from remote host in hello
-  remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert
-  localName <- chatReadVar localDeviceName
-  let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = localName}
-  pure RemoteHostInfo {remoteHostId, storePath, displayName = remoteName, remoteCtrlOOB, sessionActive = False}
+  rhId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert
+  rh <- withStore $ \db -> getRemoteHost db rhId
+  pure $ remoteHostInfo rh False

 -- | Generate a random 16-char filepath without / in it by using base64url encoding.
 randomStorePath :: IO FilePath
@@ -171,16 +173,14 @@ randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
 listRemoteHosts :: ChatMonad m => m [RemoteHostInfo]
 listRemoteHosts = do
  active <- chatReadVar remoteHostSessions
-  rcName <- chatReadVar localDeviceName
-  map (rhInfo active rcName) <$> withStore' getRemoteHosts
+  map (rhInfo active) <$> withStore' getRemoteHosts
  where
-    rhInfo active rcName rh@RemoteHost {remoteHostId} =
-      remoteHostInfo rh (M.member remoteHostId active) rcName
+    rhInfo active rh@RemoteHost {remoteHostId} =
+      remoteHostInfo rh (M.member remoteHostId active)

-remoteHostInfo :: RemoteHost -> Bool -> Text -> RemoteHostInfo
-remoteHostInfo RemoteHost {remoteHostId, storePath, displayName, caCert} sessionActive rcName =
-  let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName}
-   in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive}
+remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo
+remoteHostInfo RemoteHost {remoteHostId, storePath, displayName} sessionActive =
+  RemoteHostInfo {remoteHostId, storePath, displayName, sessionActive}

 deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
 deleteRemoteHost rhId = do
@@ -231,7 +231,7 @@ getRemoteFile rhId rf = do
 processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostSession -> ChatCommand -> ByteString -> m ChatResponse
 processRemoteCommand remoteHostId RemoteHostSession {remoteHostClient = Just rhc} cmd s = case cmd of
  SendFile chatName f -> sendFile "/f" chatName f
-  SendImage chatName f -> sendFile "/img" chatName f    
+  SendImage chatName f -> sendFile "/img" chatName f
  _ -> liftRH remoteHostId $ remoteSend rhc s
  where
    sendFile cmdName chatName (CryptoFile path cfArgs) = do
@@ -262,14 +262,14 @@ startRemoteCtrl execChatCommand = do
  chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}

 -- | Track remote host lifecycle in controller session state and signal UI on its progress
-runHost :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> TMVar RemoteCtrlId -> (HTTP2Request -> m ()) -> m ()
+runHost :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> TMVar RemoteCtrlId -> (HTTP2Request -> m ()) -> m ()
 runHost discovered accepted handleHttp = do
  remoteCtrlId <- atomically (readTMVar accepted) -- wait for ???
  rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId)
-  source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure -- wait for location of the matching fingerprint
+  serviceAddress <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure -- wait for location of the matching fingerprint
  toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
  atomically $ writeTVar discovered mempty -- flush unused sources
-  server <- async $ Discovery.connectRevHTTP2 source fingerprint handleHttp -- spawn server for remote protocol commands
+  server <- async $ Discovery.connectRevHTTP2 serviceAddress fingerprint handleHttp -- spawn server for remote protocol commands
  chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
  toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
  _ <- waitCatch server -- wait for the server to finish
@@ -369,34 +369,38 @@ handleGetFile User {userId} RemoteFile{userId = commandUserId, fileId, sent, fil
      withFile path ReadMode $ \h ->
        reply RRFile {fileSize, fileDigest} $ \send -> hSendFile h send fileSize

-discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> m ()
-discoverRemoteCtrls discovered = Discovery.withListener $ receive >=> process
+discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> m ()
+discoverRemoteCtrls discovered = do
+  subscribers <- asks multicastSubscribers
+  Discovery.withListener subscribers run
  where
-    -- TODO how would it receive more than one fingerprint?
+    run sock = receive sock >>= process sock
+
    receive sock =
      Discovery.recvAnnounce sock >>= \case
-        (SockAddrInet _sockPort sockAddr, invite) -> case strDecode invite of
-          -- TODO it is probably better to report errors to view here
-          Left _ -> receive sock
-          Right fingerprint -> pure (sockAddr, fingerprint)
+        (SockAddrInet _sockPort sockAddr, sigAnnBytes) -> case smpDecode sigAnnBytes of
+          Right (SignedAnnounce ann _sig) -> pure (sockAddr, ann)
+          Left _ -> receive sock -- TODO it is probably better to report errors to view here
        _nonV4 -> receive sock
-    process (sockAddr, fingerprint) = do
+
+    process sock (sockAddr, Announce {caFingerprint, serviceAddress=(annAddr, port)}) = do
+      unless (annAddr == sockAddr) $ logError "Announced address doesn't match socket address"
      let addr = THIPv4 (hostAddressToTuple sockAddr)
      ifM
-        (atomically $ TM.member fingerprint discovered)
-        (logDebug $ "Fingerprint already known: " <> tshow (addr, fingerprint))
+        (atomically $ TM.member caFingerprint discovered)
+        (logDebug $ "Fingerprint already known: " <> tshow (addr, caFingerprint))
        ( do
-            logInfo $ "New fingerprint announced: " <> tshow (addr, fingerprint)
-            atomically $ TM.insert fingerprint addr discovered
+            logInfo $ "New fingerprint announced: " <> tshow (addr, caFingerprint)
+            atomically $ TM.insert caFingerprint (addr, port) discovered
        )
      -- TODO we check fingerprint for duplicate where id doesn't matter - to prevent re-insert - and don't check to prevent duplicate events,
      -- so UI now will have to check for duplicates again
-      withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case
-        Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required
+      withStore' (`getRemoteCtrlByFingerprint` caFingerprint) >>= \case
+        Nothing -> toView $ CRRemoteCtrlAnnounce caFingerprint -- unknown controller, ui "register" action required
        -- TODO Maybe Bool is very confusing - the intent is very unclear here
        Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of
          Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required
-          Just False -> pure () -- skipping a rejected item
+          Just False -> run sock -- restart, skipping a rejected item
          Just True ->
            chatReadVar remoteCtrlSession >>= \case
              Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session"
--- a/src/Simplex/Chat/Remote/Discovery.hs
+++ b/src/Simplex/Chat/Remote/Discovery.hs
@@ -1,37 +1,33 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}

-module Simplex.Chat.Remote.Discovery
-  ( -- * Announce
-    announceRevHTTP2,
-    runAnnouncer,
-    startTLSServer,
-    runHTTP2Client,
-
-    -- * Discovery
-    connectRevHTTP2,
-    withListener,
-    openListener,
-    recvAnnounce,
-    connectTLSClient,
-    attachHTTP2Server,
-  )
-where
+module Simplex.Chat.Remote.Discovery where

 import Control.Logger.Simple
 import Control.Monad
+import Crypto.Random (getRandomBytes)
 import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as B64U
 import Data.Default (def)
 import Data.String (IsString)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Time.Clock.System (getSystemTime)
+import Data.Word (Word16)
 import qualified Network.Socket as N
 import qualified Network.TLS as TLS
 import qualified Network.UDP as UDP
 import Simplex.Chat.Remote.Multicast (setMembership)
-import Simplex.Chat.Remote.Types (Tasks, registerAsync)
+import Simplex.Chat.Remote.Types
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding (Encoding (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Transport (supportedParameters)
 import qualified Simplex.Messaging.Transport as Transport
@@ -39,8 +35,9 @@ import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportC
 import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body)
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig)
 import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
-import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer)
-import Simplex.Messaging.Util (ifM, tshow, whenM)
+import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
+import Simplex.Messaging.Util (ifM, tshow)
+import Simplex.Messaging.Version (mkVersionRange)
 import UnliftIO
 import UnliftIO.Concurrent

@@ -52,54 +49,107 @@ pattern ANY_ADDR_V4 :: (IsString a, Eq a) => a
 pattern ANY_ADDR_V4 = "0.0.0.0"

 pattern DISCOVERY_PORT :: (IsString a, Eq a) => a
-pattern DISCOVERY_PORT = "5226"
+pattern DISCOVERY_PORT = "5227"
+
+startSession :: MonadIO m => Maybe Text -> (N.HostAddress, Word16) -> C.KeyHash -> m ((C.APublicDhKey, C.APrivateDhKey), C.PrivateKeyEd25519, Announce, SignedOOB)
+startSession deviceName serviceAddress caFingerprint = liftIO $ do
+  sessionStart <- getSystemTime
+  dh@(C.APublicDhKey C.SX25519 sessionDH, _) <- C.generateDhKeyPair C.SX25519
+  (C.APublicVerifyKey C.SEd25519 sigPubKey, C.APrivateSignKey C.SEd25519 sigSecretKey) <- C.generateSignatureKeyPair C.SEd25519
+  let
+    announce =
+      Announce
+        { versionRange = announceVersionRange,
+          sessionStart,
+          announceCounter = 0,
+          serviceAddress,
+          caFingerprint,
+          sessionDH,
+          announceKey = sigPubKey
+        }
+  authToken <- decodeUtf8 . B64U.encode <$> getRandomBytes 12
+  let
+    oob =
+      OOB
+        { caFingerprint,
+          authToken,
+          host = decodeUtf8 . strEncode $ THIPv4 . N.hostAddressToTuple $ fst serviceAddress,
+          port = snd serviceAddress,
+          version = mkVersionRange 1 1,
+          appName = "simplex-chat",
+          sigPubKey,
+          deviceName
+        }
+  pure (dh, sigSecretKey, announce, signOOB sigSecretKey oob)
+
+getLocalAddress :: MonadIO m => TMVar Int -> m (Maybe N.HostAddress)
+getLocalAddress subscribers = liftIO $ do
+  probe <- mkIpProbe
+  let bytes = smpEncode probe
+  withListener subscribers $ \receiver ->
+    withSender $ \sender -> do
+      UDP.send sender bytes
+      let expect = do
+            UDP.recvFrom receiver >>= \case
+              (p, _) | p /= bytes -> expect
+              (_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure host
+              (_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket"
+      timeout 1000000 expect
+
+mkIpProbe :: MonadIO m => m IpProbe
+mkIpProbe = do
+  randomNonce <- liftIO $ getRandomBytes 32
+  pure IpProbe {versionRange = ipProbeVersionRange, randomNonce}

 -- | Announce tls server, wait for connection and attach http2 client to it.
 --
 -- Announcer is started when TLS server is started and stopped when a connection is made.
-announceRevHTTP2 :: StrEncoding a => Tasks -> a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-announceRevHTTP2 tasks invite credentials finishAction = do
+announceRevHTTP2 :: Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
+announceRevHTTP2 tasks (sigKey, announce@Announce {caFingerprint, serviceAddress=(host, _port)}) credentials finishAction = do
  httpClient <- newEmptyMVar
  started <- newEmptyTMVarIO
  finished <- newEmptyMVar
  _ <- forkIO $ readMVar finished >> finishAction -- attach external cleanup action to session lock
-  announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ do
-    logInfo $ "Starting announcer for " <> tshow (strEncode invite)
-    runAnnouncer (strEncode invite)
+  announcer <- async . liftIO $ atomically (takeTMVar started) >>= \case
+    Nothing -> pure () -- TLS server failed to start, skipping announcer
+    Just givenPort -> do
+      logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort)
+      runAnnouncer (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)})
  tasks `registerAsync` announcer
  tlsServer <- startTLSServer started credentials $ \tls -> do
-    logInfo $ "Incoming connection for " <> tshow (strEncode invite)
+    logInfo $ "Incoming connection for " <> ident
    cancel announcer
    runHTTP2Client finished httpClient tls `catchAny` (logError . tshow)
-    logInfo $ "Client finished for " <> tshow (strEncode invite)
-  -- BUG: this should be handled in HTTP2Client wrapper
-  _ <- forkIO $ do
-    waitCatch tlsServer >>= \case
-      Left err | fromException err == Just AsyncCancelled -> logDebug "tlsServer cancelled"
-      Left err -> do
-        logError $ "tlsServer failed to start: " <> tshow err
-        void $ tryPutMVar httpClient $ Left HCNetworkError
-        void . atomically $ tryPutTMVar started False
-      Right () -> pure ()
-    void $ tryPutMVar finished ()
+    logInfo $ "Client finished for " <> ident
+  -- BUG: this should be handled in HTTP2Client wrapper, partially handled in startTLSServer
+  _ <- forkIO $ waitCatch tlsServer >> void (tryPutMVar finished ())
  tasks `registerAsync` tlsServer
-  logInfo $ "Waiting for client for " <> tshow (strEncode invite)
+  logInfo $ "Waiting for client for " <> ident
  readMVar httpClient
+  where
+    ident = decodeUtf8 $ strEncode caFingerprint

-- | Broadcast invite with link-local datagrams
-runAnnouncer :: ByteString -> IO ()
-runAnnouncer inviteBS = do
-  bracket (UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) UDP.close $ \sock -> do
-    let raw = UDP.udpSocket sock
-    N.setSocketOption raw N.Broadcast 1
-    N.setSocketOption raw N.ReuseAddr 1
-    forever $ do
-      UDP.send sock inviteBS
+-- | Send replay-proof announce datagrams
+runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO ()
+runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce
+  where
+    loop announce sock = do
+      UDP.send sock $ smpEncode (signAnnounce announceKey announce)
      threadDelay 1000000
+      loop announce {announceCounter = announceCounter announce + 1} sock

-- XXX: Do we need to start multiple TLS servers for different mobile hosts?
-startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
-startTLSServer started credentials = async . liftIO . runTransportServer started DISCOVERY_PORT serverParams defaultTransportServerConfig
+startTLSServer :: (MonadUnliftIO m) => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
+startTLSServer started credentials server = async . liftIO $ do
+  startedOk <- newEmptyTMVarIO
+  bracketOnError (startTCPServer startedOk "0") (\_e -> void . atomically $ tryPutTMVar started Nothing) $ \socket ->
+    ifM
+      (atomically $ readTMVar startedOk)
+      do
+        port <- N.socketPort socket
+        logInfo $ "System-assigned port: " <> tshow port
+        atomically $ putTMVar started (Just port)
+        runTransportServerSocket startedOk (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server
+      (void . atomically $ tryPutTMVar started Nothing)
  where
    serverParams =
      def
@@ -123,22 +173,40 @@ runHTTP2Client finishedVar clientVar tls =
    -- TODO connection timeout
    config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}

-withListener :: (MonadUnliftIO m) => (UDP.ListenSocket -> m a) -> m a
-withListener = bracket openListener closeListener
+withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a
+withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close)

-openListener :: (MonadIO m) => m UDP.ListenSocket
-openListener = liftIO $ do
+withListener :: MonadUnliftIO m => TMVar Int -> (UDP.ListenSocket -> m a) -> m a
+withListener subscribers = bracket (openListener subscribers) (closeListener subscribers)
+
+openListener :: MonadIO m => TMVar Int -> m UDP.ListenSocket
+openListener subscribers = liftIO $ do
  sock <- UDP.serverSocket (MULTICAST_ADDR_V4, read DISCOVERY_PORT)
  logDebug $ "Discovery listener socket: " <> tshow sock
  let raw = UDP.listenSocket sock
-  N.setSocketOption raw N.Broadcast 1
-  void $ setMembership raw (listenerHostAddr4 sock) True
+  -- N.setSocketOption raw N.Broadcast 1
+  joinMulticast subscribers raw (listenerHostAddr4 sock)
  pure sock

-closeListener :: MonadIO m => UDP.ListenSocket -> m ()
-closeListener sock = liftIO $ do
-  UDP.stop sock
-  void $ setMembership (UDP.listenSocket sock) (listenerHostAddr4 sock) False
+closeListener :: MonadIO m => TMVar Int -> UDP.ListenSocket -> m ()
+closeListener subscribers sock = liftIO $
+  partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock
+
+joinMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO ()
+joinMulticast subscribers sock group = do
+  now <- atomically $ takeTMVar subscribers
+  when (now == 0) $ do
+    setMembership sock group True >>= \case
+      Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e)
+      Right () -> atomically $ putTMVar subscribers (now + 1)
+
+partMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO ()
+partMulticast subscribers sock group = do
+  now <- atomically $ takeTMVar subscribers
+  when (now == 1) $
+    setMembership sock group False >>= \case
+      Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e)
+      Right () -> atomically $ putTMVar subscribers (now - 1)

 listenerHostAddr4 :: UDP.ListenSocket -> N.HostAddress
 listenerHostAddr4 sock = case UDP.mySockAddr sock of
@@ -150,11 +218,11 @@ recvAnnounce sock = liftIO $ do
  (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
  pure (source, invite)

-connectRevHTTP2 :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (HTTP2Request -> m ()) -> m ()
-connectRevHTTP2 host fingerprint = connectTLSClient host fingerprint . attachHTTP2Server
+connectRevHTTP2 :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (HTTP2Request -> m ()) -> m ()
+connectRevHTTP2 serviceAddress fingerprint = connectTLSClient serviceAddress fingerprint . attachHTTP2Server

-connectTLSClient :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a
-connectTLSClient host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host DISCOVERY_PORT (Just caFingerprint)
+connectTLSClient :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (Transport.TLS -> m a) -> m a
+connectTLSClient (host, port) caFingerprint = runTransportClient defaultTransportClientConfig Nothing host (show port) (Just caFingerprint)

 attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
 attachHTTP2Server processRequest tls = do
--- a/src/Simplex/Chat/Remote/Multicast.hsc
+++ b/src/Simplex/Chat/Remote/Multicast.hsc
@@ -10,12 +10,15 @@ import Network.Socket

 NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
 -}
-setMembership :: Socket -> HostAddress -> Bool -> IO Bool
+setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ())
 setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
  #{poke struct ip_mreq, imr_multiaddr} mReqPtr group
  #{poke struct ip_mreq, imr_interface} mReqPtr (0 :: HostAddress) -- attempt to contact the group on ANY interface
-  withFdSocket sock $ \fd ->
-    (/= 0) <$> c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq})
+  withFdSocket sock $ \fd -> do
+    rc <- c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq})
+    if rc == 0
+      then pure $ Right ()
+      else pure $ Left rc
  where
    flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP

--- a/src/Simplex/Chat/Remote/Protocol.hs
+++ b/src/Simplex/Chat/Remote/Protocol.hs
@@ -66,8 +66,8 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)

 -- * Client side / desktop

-createRemoteHostClient :: HTTP2Client -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient
-createRemoteHostClient httpClient desktopName = do
+createRemoteHostClient :: HTTP2Client -> dh -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient
+createRemoteHostClient httpClient todo'dhKey desktopName = do
  logDebug "Sending initial hello"
  sendRemoteCommand' httpClient localEncoding Nothing RCHello {deviceName = desktopName} >>= \case
    RRHello {encoding, deviceName = mobileName, encryptFiles} -> do
--- a/src/Simplex/Chat/Remote/Types.hs
+++ b/src/Simplex/Chat/Remote/Types.hs
@@ -1,18 +1,39 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GADTs #-}

 module Simplex.Chat.Remote.Types where

 import Control.Exception
+import Control.Monad
+import Crypto.Error (eitherCryptoError)
+import qualified Crypto.PubKey.Ed25519 as Ed25519
 import qualified Data.Aeson.TH as J
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteArray (convert)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Foldable (toList)
 import Data.Int (Int64)
 import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)
+import Data.Time.Clock.System (SystemTime)
+import Data.Word (Word16)
+import Network.HTTP.Types (parseSimpleQuery)
+import Network.HTTP.Types.URI (renderSimpleQuery, urlDecode, urlEncode)
+import qualified Network.Socket as N
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile)
-import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
+import Simplex.Messaging.Encoding (Encoding (..))
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
+import Simplex.Messaging.Version (VersionRange, mkVersionRange)
 import UnliftIO

 data RemoteHostClient = RemoteHostClient
@@ -66,7 +87,6 @@ data RemoteHostInfo = RemoteHostInfo
  { remoteHostId :: RemoteHostId,
    storePath :: FilePath,
    displayName :: Text,
-    remoteCtrlOOB :: RemoteCtrlOOB,
    sessionActive :: Bool
  }
  deriving (Show)
@@ -98,6 +118,161 @@ data RemoteFile = RemoteFile
  }
  deriving (Show)

+ipProbeVersionRange :: VersionRange
+ipProbeVersionRange = mkVersionRange 1 1
+
+data IpProbe = IpProbe
+  { versionRange :: VersionRange,
+    randomNonce :: ByteString
+  } deriving (Show)
+
+instance Encoding IpProbe where
+  smpEncode IpProbe {versionRange, randomNonce} = smpEncode (versionRange, 'I', randomNonce)
+
+  smpP = IpProbe <$> (smpP <* "I") *> smpP
+
+announceVersionRange :: VersionRange
+announceVersionRange = mkVersionRange  1 1
+
+data Announce = Announce
+  { versionRange :: VersionRange,
+    sessionStart :: SystemTime,
+    announceCounter :: Word16,
+    serviceAddress :: (N.HostAddress, Word16),
+    caFingerprint :: C.KeyHash,
+    sessionDH :: C.PublicKeyX25519,
+    announceKey :: C.PublicKeyEd25519
+  } deriving (Show)
+
+instance Encoding Announce where
+  smpEncode Announce {versionRange, sessionStart, announceCounter, serviceAddress, caFingerprint, sessionDH, announceKey} =
+    smpEncode (versionRange, 'A', sessionStart, announceCounter, serviceAddress)
+      <> smpEncode (caFingerprint, sessionDH, announceKey)
+
+  smpP = Announce <$> (smpP <* "A") <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
+
+data SignedAnnounce = SignedAnnounce Announce (C.Signature 'C.Ed25519)
+
+instance Encoding SignedAnnounce where
+  smpEncode (SignedAnnounce ann (C.SignatureEd25519 sig)) = smpEncode (ann, convert sig :: ByteString)
+
+  smpP = do
+    sa <- SignedAnnounce <$> smpP <*> signatureP
+    unless (verifySignedAnnounce sa) $ fail "bad announce signature"
+    pure sa
+    where
+      signatureP = do
+        bs <- smpP :: A.Parser ByteString
+        case eitherCryptoError (Ed25519.signature bs) of
+          Left ce -> fail $ show ce
+          Right ok -> pure $ C.SignatureEd25519 ok
+
+signAnnounce :: C.PrivateKey C.Ed25519 -> Announce -> SignedAnnounce
+signAnnounce announceSecret ann = SignedAnnounce ann sig
+  where
+    sig =
+      case C.sign (C.APrivateSignKey C.SEd25519 announceSecret) (smpEncode ann) of
+        C.ASignature C.SEd25519 s -> s
+        _ -> error "signing with ed25519"
+
+verifySignedAnnounce :: SignedAnnounce -> Bool
+verifySignedAnnounce (SignedAnnounce ann@Announce {announceKey} sig) = C.verify aKey aSig (smpEncode ann)
+  where
+    aKey = C.APublicVerifyKey C.SEd25519 announceKey
+    aSig = C.ASignature C.SEd25519 sig
+
+data OOB = OOB
+  { -- authority part
+    caFingerprint :: C.KeyHash,
+    authToken :: Text,
+    host :: Text,
+    port :: Word16,
+    -- query part
+    version :: VersionRange, -- v=
+    appName :: Text, -- app=
+    sigPubKey :: C.PublicKeyEd25519, -- key=
+    deviceName :: Maybe Text -- device=
+  }
+  deriving (Eq, Show)
+
+instance StrEncoding OOB where
+  strEncode OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName} =
+    schema <> "://" <> authority <> "#/?" <> renderSimpleQuery False query
+    where
+      schema = "xrcp"
+      authority =
+        mconcat
+          [ strEncode caFingerprint,
+            ":",
+            encodeUtf8 authToken,
+            "@",
+            encodeUtf8 host,
+            ":",
+            strEncode port
+          ]
+      query =
+        [ ("v", strEncode version),
+          ("app", encodeUtf8 appName),
+          ("key", strEncode $ C.encodePubKey sigPubKey)
+        ]
+          ++ [("device", urlEncode True $ encodeUtf8 name) | name <- toList deviceName]
+
+  strP = do
+    _ <- A.string "xrcp://"
+    caFingerprint <- strP
+    _ <- A.char ':'
+    authToken <- decodeUtf8Lenient <$> A.takeWhile (/= '@')
+    _ <- A.char '@'
+    host <- decodeUtf8Lenient <$> A.takeWhile (/= ':')
+    _ <- A.char ':'
+    port <- strP
+
+    _ <- A.string "#/?"
+    q <- parseSimpleQuery <$> A.takeByteString
+    version <- maybe (fail "missing version") (either fail pure . strDecode) (lookup "v" q)
+    appName <- maybe (fail "missing appName") (pure . decodeUtf8Lenient) (lookup "app" q)
+    sigPubKeyB64 <- maybe (fail "missing key") pure (lookup "key" q)
+    sigPubKey <- either fail pure $ strDecode sigPubKeyB64 >>= C.decodePubKey
+    let deviceName = fmap (decodeUtf8Lenient . urlDecode True) (lookup "device" q)
+    pure OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName}
+
+data SignedOOB = SignedOOB OOB (C.Signature 'C.Ed25519)
+  deriving (Eq, Show)
+
+instance StrEncoding SignedOOB where
+  strEncode (SignedOOB oob sig) = strEncode oob <> "&sig=" <> strEncode (C.signatureBytes sig)
+
+  strDecode s = do
+    unless (B.length sig == sigLen) $ Left "bad size"
+    unless ("&sig=" `B.isPrefixOf` sig) $ Left "bad signature prefix"
+    signedOOB <- SignedOOB <$> strDecode oob <*> (strDecode (B.drop 5 sig) >>= C.decodeSignature)
+    unless (verifySignedOOB signedOOB) $ Left "bad signature"
+    pure signedOOB
+    where
+      l = B.length s
+      (oob, sig) = B.splitAt (l - sigLen) s
+      sigLen = 93 -- &sig= + ed25519 sig size in base64 (88)
+
+  -- XXX: strP is used in chat command parser, but default strP assumes bas64url-encoded bytestring, where OOB is an URL-like
+  strP = A.takeWhile (/= ' ') >>= either fail pure . strDecode
+
+signOOB :: C.PrivateKey C.Ed25519 -> OOB -> SignedOOB
+signOOB key oob = SignedOOB oob sig
+  where
+    sig =
+      case C.sign (C.APrivateSignKey C.SEd25519 key) (strEncode oob) of
+        C.ASignature C.SEd25519 s -> s
+        _ -> error "signing with ed25519"
+
+verifySignedOOB :: SignedOOB -> Bool
+verifySignedOOB (SignedOOB oob@OOB {sigPubKey} sig) = C.verify aKey aSig (strEncode oob)
+  where
+    aKey = C.APublicVerifyKey C.SEd25519 sigPubKey
+    aSig = C.ASignature C.SEd25519 sig
+
+decodeOOBLink :: Text -> Either String OOB
+decodeOOBLink = fmap (\(SignedOOB oob _verified) -> oob) . strDecode . encodeUtf8
+
 data PlatformEncoding
  = PESwift
  | PEKotlin
@@ -125,8 +300,6 @@ $(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError)

 $(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding)

-$(J.deriveJSON defaultJSON ''RemoteCtrlOOB)
-
 $(J.deriveJSON defaultJSON ''RemoteHostInfo)

 $(J.deriveJSON defaultJSON ''RemoteCtrl)
--- a/src/Simplex/Chat/Store/Remote.hs
+++ b/src/Simplex/Chat/Store/Remote.hs
@@ -6,13 +6,14 @@ module Simplex.Chat.Store.Remote where

 import Control.Monad.Except
 import Data.Int (Int64)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Database.SQLite.Simple (Only (..))
 import qualified Database.SQLite.Simple as SQL
-import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Chat.Store.Shared
 import Simplex.Chat.Remote.Types
+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

 insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId
@@ -39,8 +40,9 @@ toRemoteHost (remoteHostId, storePath, displayName, caKey, C.SignedObject caCert
 deleteRemoteHostRecord :: DB.Connection -> RemoteHostId -> IO ()
 deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId)

-insertRemoteCtrl :: DB.Connection -> RemoteCtrlOOB -> IO RemoteCtrlInfo
-insertRemoteCtrl db RemoteCtrlOOB {fingerprint, displayName} = do
+insertRemoteCtrl :: DB.Connection -> SignedOOB -> IO RemoteCtrlInfo
+insertRemoteCtrl db (SignedOOB OOB {deviceName, caFingerprint = fingerprint} _) = do
+  let displayName = fromMaybe "" deviceName
  DB.execute db "INSERT INTO remote_controllers (display_name, fingerprint) VALUES (?,?)" (displayName, fingerprint)
  remoteCtrlId <- insertedRowId db
  pure RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted = Nothing, sessionActive = False}
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@@ -269,8 +269,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
  CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)]
  CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)]
  CRNtfMessages {} -> []
-  CRRemoteHostCreated RemoteHostInfo {remoteHostId, remoteCtrlOOB} -> ("remote host " <> sShow remoteHostId <> " created") : viewRemoteCtrlOOBData remoteCtrlOOB
+  CRRemoteHostCreated RemoteHostInfo {remoteHostId} -> ["remote host " <> sShow remoteHostId <> " created"]
  CRRemoteHostList hs -> viewRemoteHosts hs
+  CRRemoteHostStarted {remoteHost = RemoteHostInfo {remoteHostId = rhId}, sessionOOB} -> ["remote host " <> sShow rhId <> " started", "connection code:", plain sessionOOB]
  CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"]
  CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"]
  CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) ->
@@ -447,7 +448,7 @@ viewGroupSubscribed :: GroupInfo -> [StyledString]
 viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"]

 showSMPServer :: SMPServer -> String
-showSMPServer = B.unpack . strEncode . host
+showSMPServer srv = B.unpack $ strEncode srv.host

 viewHostEvent :: AProtocolType -> TransportHost -> String
 viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h)
@@ -1659,10 +1660,6 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo
  where
    parens s = " (" <> s <> ")"

-viewRemoteCtrlOOBData :: RemoteCtrlOOB -> [StyledString]
-viewRemoteCtrlOOBData RemoteCtrlOOB {fingerprint} =
-  ["connection code:", plain $ strEncode fingerprint]
-
 viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
 viewRemoteHosts = \case
  [] -> ["No remote hosts"]
--- a/tests/RemoteTests.hs
+++ b/tests/RemoteTests.hs
@@ -8,12 +8,12 @@ module RemoteTests where
 import ChatClient
 import ChatTests.Utils
 import Control.Logger.Simple
-import Control.Monad
 import qualified Data.Aeson as J
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as M
+import Data.String (fromString)
 import Network.HTTP.Types (ok200)
 import qualified Network.HTTP2.Client as C
 import qualified Network.HTTP2.Server as S
@@ -23,11 +23,12 @@ import Simplex.Chat.Archive (archiveFilesFolder)
 import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..))
 import qualified Simplex.Chat.Controller as Controller
 import Simplex.Chat.Mobile.File
-import Simplex.Chat.Remote.Types
 import qualified Simplex.Chat.Remote.Discovery as Discovery
+import Simplex.Chat.Remote.Types
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
-import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Encoding (smpDecode)
+import Simplex.Messaging.Encoding.String (strDecode, strEncode)
 import qualified Simplex.Messaging.Transport as Transport
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
@@ -44,6 +45,7 @@ remoteTests :: SpecWith FilePath
 remoteTests = describe "Remote" $ do
  it "generates usable credentials" genCredentialsTest
  it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test
+  it "OOB encoding, decoding, and signatures are correct" oobCodecTest
  it "performs protocol handshake" remoteHandshakeTest
  it "performs protocol handshake (again)" remoteHandshakeTest -- leaking servers regression check
  it "sends messages" remoteMessageTest
@@ -59,8 +61,9 @@ genCredentialsTest _tmp = do
  started <- newEmptyTMVarIO
  bracket (Discovery.startTLSServer started credentials serverHandler) cancel $ \_server -> do
    ok <- atomically (readTMVar started)
-    unless ok $ error "TLS server failed to start"
-    Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler
+    port <- maybe (error "TLS server failed to start") pure ok
+    logNote $ "Assigned port: " <> tshow port
+    Discovery.connectTLSClient ("127.0.0.1", fromIntegral port) fingerprint clientHandler
  where
    serverHandler serverTls = do
      logNote "Sending from server"
@@ -75,15 +78,28 @@ genCredentialsTest _tmp = do

 -- * UDP discovery and rever HTTP2

+oobCodecTest :: (HasCallStack) => FilePath -> IO ()
+oobCodecTest _tmp = do
+  subscribers <- newTMVarIO 0
+  localAddr <- Discovery.getLocalAddress subscribers >>= maybe (fail "unable to get local address") pure
+  (fingerprint, _credentials) <- genTestCredentials
+  (_dhKey, _sigKey, _ann, signedOOB@(SignedOOB oob _sig)) <- Discovery.startSession (Just "Desktop") (localAddr, read Discovery.DISCOVERY_PORT) fingerprint
+  verifySignedOOB signedOOB `shouldBe` True
+  strDecode (strEncode oob) `shouldBe` Right oob
+  strDecode (strEncode signedOOB) `shouldBe` Right signedOOB
+
 announceDiscoverHttp2Test :: (HasCallStack) => FilePath -> IO ()
 announceDiscoverHttp2Test _tmp = do
+  subscribers <- newTMVarIO 0
+  localAddr <- Discovery.getLocalAddress subscribers >>= maybe (fail "unable to get local address") pure
  (fingerprint, credentials) <- genTestCredentials
+  (_dhKey, sigKey, ann, _oob) <- Discovery.startSession (Just "Desktop") (localAddr, read Discovery.DISCOVERY_PORT) fingerprint
  tasks <- newTVarIO []
  finished <- newEmptyMVar
  controller <- async $ do
    logNote "Controller: starting"
    bracket
-      (Discovery.announceRevHTTP2 tasks fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure)
+      (Discovery.announceRevHTTP2 tasks (sigKey, ann) credentials (putMVar finished ()) >>= either (fail . show) pure)
      closeHTTP2Client
      ( \http -> do
          logNote "Controller: got client"
@@ -94,11 +110,14 @@ announceDiscoverHttp2Test _tmp = do
            Right HTTP2Response {} ->
              logNote "Controller: got response"
      )
-  host <- async $ Discovery.withListener $ \sock -> do
-    (N.SockAddrInet _port addr, invite) <- Discovery.recvAnnounce sock
-    strDecode invite `shouldBe` Right fingerprint
-    logNote "Host: connecting"
-    server <- async $ Discovery.connectTLSClient (THIPv4 $ N.hostAddressToTuple addr) fingerprint $ \tls -> do
+  host <- async $ Discovery.withListener subscribers $ \sock -> do
+    (N.SockAddrInet _port addr, sigAnn) <- Discovery.recvAnnounce sock
+    SignedAnnounce Announce {caFingerprint, serviceAddress=(hostAddr, port)} _sig <- either fail pure $ smpDecode sigAnn
+    caFingerprint `shouldBe` fingerprint
+    addr `shouldBe` hostAddr
+    let service = (THIPv4 $ N.hostAddressToTuple hostAddr, port)
+    logNote $ "Host: connecting to " <> tshow service
+    server <- async $ Discovery.connectTLSClient service fingerprint $ \tls -> do
      logNote "Host: got tls"
      flip Discovery.attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do
        logNote "Host: got request"
@@ -213,7 +232,7 @@ remoteStoreFileTest =
      -- send file not encrypted locally on mobile host
      desktop ##> "/_send @2 json {\"filePath\": \"test_1.pdf\", \"msgContent\": {\"type\": \"file\", \"text\": \"sending a file\"}}"
      desktop <# "@bob sending a file"
-      desktop <# "/f @bob test_1.pdf" 
+      desktop <# "/f @bob test_1.pdf"
      desktop <## "use /fc 1 to cancel sending"
      bob <# "alice> sending a file"
      bob <# "alice> sends file test_1.pdf (266.0 KiB / 272376 bytes)"
@@ -242,7 +261,7 @@ remoteStoreFileTest =

      -- send file encrypted locally on mobile host
      desktop ##> ("/_send @2 json {\"fileSource\": {\"filePath\":\"test_2.pdf\", \"cryptoArgs\": " <> LB.unpack (J.encode cfArgs) <> "}, \"msgContent\": {\"type\": \"file\", \"text\": \"\"}}")
-      desktop <# "/f @bob test_2.pdf" 
+      desktop <# "/f @bob test_2.pdf"
      desktop <## "use /fc 2 to cancel sending"
      bob <# "alice> sends file test_2.pdf (266.0 KiB / 272376 bytes)"
      bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
@@ -372,21 +391,30 @@ remoteCLIFileTest = testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile

 startRemote :: TestCC -> TestCC -> IO ()
 startRemote mobile desktop = do
+  desktop ##> "/set device name My desktop"
+  desktop <## "ok"
  desktop ##> "/create remote host"
  desktop <## "remote host 1 created"
-  desktop <## "connection code:"
-  fingerprint <- getTermLine desktop
-
+  -- A new host is started [automatically] by UI
  desktop ##> "/start remote host 1"
  desktop <## "ok"
+  desktop <## "remote host 1 started"
+  desktop <## "connection code:"
+  oobLink <- getTermLine desktop
+  OOB {caFingerprint = oobFingerprint} <- either (fail . mappend "OOB link failed: ") pure $ decodeOOBLink (fromString oobLink)
+  -- Desktop displays OOB QR code

+  mobile ##> "/set device name Mobile"
+  mobile <## "ok"
  mobile ##> "/start remote ctrl"
  mobile <## "ok"
  mobile <## "remote controller announced"
  mobile <## "connection code:"
-  fingerprint' <- getTermLine mobile
-  fingerprint' `shouldBe` fingerprint
-  mobile ##> ("/register remote ctrl " <> fingerprint' <> " " <> "My desktop")
+  annFingerprint <- getTermLine mobile
+  -- The user scans OOB QR code and confirms it matches the announced stuff
+  fromString annFingerprint `shouldBe` strEncode oobFingerprint
+
+  mobile ##> ("/register remote ctrl " <> oobLink)
  mobile <## "remote controller 1 registered"
  mobile ##> "/accept remote ctrl 1"
  mobile <## "ok" -- alternative scenario: accepted before controller start