implement some of the robust discovery rfc (#3283)

* implement robust discovery

* remove qualified

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

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 <$> strP),
-      "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP),
+      -- "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP),
       "/list remote ctrls" $> ListRemoteCtrls,
       "/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal),
       "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal),

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
   }

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.Text.Encoding (decodeUtf8, encodeUtf8)
-import Data.Word (Word32)
+import Data.Word (Word16, Word32)
-import Network.HTTP2.Server (responseStreaming)
 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
+  rhId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert
-  localName <- chatReadVar localDeviceName
+  rh <- withStore $ \db -> getRemoteHost db rhId
-  let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = localName}
+  pure $ remoteHostInfo rh False
-  pure RemoteHostInfo {remoteHostId, storePath, displayName = remoteName, remoteCtrlOOB, sessionActive = 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) <$> withStore' getRemoteHosts
-  map (rhInfo active rcName) <$> withStore' getRemoteHosts
   where
-    rhInfo active rcName rh@RemoteHost {remoteHostId} =
+    rhInfo active rh@RemoteHost {remoteHostId} =
-      remoteHostInfo rh (M.member remoteHostId active) rcName
+      remoteHostInfo rh (M.member remoteHostId active)
 
-remoteHostInfo :: RemoteHost -> Bool -> Text -> RemoteHostInfo
+remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo
-remoteHostInfo RemoteHost {remoteHostId, storePath, displayName, caCert} sessionActive rcName =
+remoteHostInfo RemoteHost {remoteHostId, storePath, displayName} sessionActive =
-  let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName}
+  RemoteHostInfo {remoteHostId, storePath, displayName, sessionActive}
-   in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, 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 :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> m ()
-discoverRemoteCtrls discovered = Discovery.withListener $ receive >=> process
+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
+        (SockAddrInet _sockPort sockAddr, sigAnnBytes) -> case smpDecode sigAnnBytes of
-          -- TODO it is probably better to report errors to view here
+          Right (SignedAnnounce ann _sig) -> pure (sockAddr, ann)
-          Left _ -> receive sock
+          Left _ -> receive sock -- TODO it is probably better to report errors to view here
-          Right fingerprint -> pure (sockAddr, fingerprint)
         _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)
+        (atomically $ TM.member caFingerprint discovered)
-        (logDebug $ "Fingerprint already known: " <> tshow (addr, fingerprint))
+        (logDebug $ "Fingerprint already known: " <> tshow (addr, caFingerprint))
         ( do
-            logInfo $ "New fingerprint announced: " <> tshow (addr, fingerprint)
+            logInfo $ "New fingerprint announced: " <> tshow (addr, caFingerprint)
-            atomically $ TM.insert fingerprint addr discovered
+            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
+      withStore' (`getRemoteCtrlByFingerprint` caFingerprint) >>= \case
-        Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required
+        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"

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
+module Simplex.Chat.Remote.Discovery where
-  ( -- * Announce
-    announceRevHTTP2,
-    runAnnouncer,
-    startTLSServer,
-    runHTTP2Client,
-
-    -- * Discovery
-    connectRevHTTP2,
-    withListener,
-    openListener,
-    recvAnnounce,
-    connectTLSClient,
-    attachHTTP2Server,
-  )
-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.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
-import Simplex.Messaging.Util (ifM, tshow, whenM)
+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 -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-announceRevHTTP2 tasks invite credentials finishAction = do
+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
+  announcer <- async . liftIO $ atomically (takeTMVar started) >>= \case
-    logInfo $ "Starting announcer for " <> tshow (strEncode invite)
+    Nothing -> pure () -- TLS server failed to start, skipping announcer
-    runAnnouncer (strEncode invite)
+    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)
+    logInfo $ "Client finished for " <> ident
-  -- BUG: this should be handled in HTTP2Client wrapper
+  -- BUG: this should be handled in HTTP2Client wrapper, partially handled in startTLSServer
-  _ <- forkIO $ do
+  _ <- forkIO $ waitCatch tlsServer >> void (tryPutMVar finished ())
-    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 ()
   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
+-- | Send replay-proof announce datagrams
-runAnnouncer :: ByteString -> IO ()
+runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO ()
-runAnnouncer inviteBS = do
+runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce
-  bracket (UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) UDP.close $ \sock -> do
+  where
-    let raw = UDP.udpSocket sock
+    loop announce sock = do
-    N.setSocketOption raw N.Broadcast 1
+      UDP.send sock $ smpEncode (signAnnounce announceKey announce)
-    N.setSocketOption raw N.ReuseAddr 1
-    forever $ do
-      UDP.send sock inviteBS
       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 (Maybe N.PortNumber) -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
-startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
+startTLSServer started credentials server = async . liftIO $ do
-startTLSServer started credentials = async . liftIO . runTransportServer started DISCOVERY_PORT serverParams defaultTransportServerConfig
+  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
+withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a
-withListener = bracket openListener closeListener
+withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close)
 
-openListener :: (MonadIO m) => m UDP.ListenSocket
+withListener :: MonadUnliftIO m => TMVar Int -> (UDP.ListenSocket -> m a) -> m a
-openListener = liftIO $ do
+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
+  -- N.setSocketOption raw N.Broadcast 1
-  void $ setMembership raw (listenerHostAddr4 sock) True
+  joinMulticast subscribers raw (listenerHostAddr4 sock)
   pure sock
 
-closeListener :: MonadIO m => UDP.ListenSocket -> m ()
+closeListener :: MonadIO m => TMVar Int -> UDP.ListenSocket -> m ()
-closeListener sock = liftIO $ do
+closeListener subscribers sock = liftIO $
-  UDP.stop sock
+  partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock
-  void $ setMembership (UDP.listenSocket sock) (listenerHostAddr4 sock) False
+
+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 :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (HTTP2Request -> m ()) -> m ()
-connectRevHTTP2 host fingerprint = connectTLSClient host fingerprint . attachHTTP2Server
+connectRevHTTP2 serviceAddress fingerprint = connectTLSClient serviceAddress fingerprint . attachHTTP2Server
 
-connectTLSClient :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a
+connectTLSClient :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (Transport.TLS -> m a) -> m a
-connectTLSClient host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host DISCOVERY_PORT (Just caFingerprint)
+connectTLSClient (host, port) caFingerprint = runTransportClient defaultTransportClientConfig Nothing host (show port) (Just caFingerprint)
 
 attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
 attachHTTP2Server processRequest tls = do

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 ->
+  withFdSocket sock $ \fd -> do
-    (/= 0) <$> c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq})
+    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
 

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 :: HTTP2Client -> dh -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient
-createRemoteHostClient httpClient desktopName = do
+createRemoteHostClient httpClient todo'dhKey desktopName = do
   logDebug "Sending initial hello"
   sendRemoteCommand' httpClient localEncoding Nothing RCHello {deviceName = desktopName} >>= \case
     RRHello {encoding, deviceName = mobileName, encryptFiles} -> do

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)

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.Connection -> SignedOOB -> IO RemoteCtrlInfo
-insertRemoteCtrl db RemoteCtrlOOB {fingerprint, displayName} = do
+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}

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"]

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"
+    port <- maybe (error "TLS server failed to start") pure ok
-    Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler
+    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
+  host <- async $ Discovery.withListener subscribers $ \sock -> do
-    (N.SockAddrInet _port addr, invite) <- Discovery.recvAnnounce sock
+    (N.SockAddrInet _port addr, sigAnn) <- Discovery.recvAnnounce sock
-    strDecode invite `shouldBe` Right fingerprint
+    SignedAnnounce Announce {caFingerprint, serviceAddress=(hostAddr, port)} _sig <- either fail pure $ smpDecode sigAnn
-    logNote "Host: connecting"
+    caFingerprint `shouldBe` fingerprint
-    server <- async $ Discovery.connectTLSClient (THIPv4 $ N.hostAddressToTuple addr) fingerprint $ \tls -> do
+    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:"
+  -- A new host is started [automatically] by UI
-  fingerprint <- getTermLine desktop
-
   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
+  annFingerprint <- getTermLine mobile
-  fingerprint' `shouldBe` fingerprint
+  -- The user scans OOB QR code and confirms it matches the announced stuff
-  mobile ##> ("/register remote ctrl " <> fingerprint' <> " " <> "My desktop")
+  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