remote: add multicast discovery w/ encrypted announce (#895)

* Implement multicast discovery * replace rcConnectMulticast with explicit discoverRCCtrl * add multicast source/invitation host check * remove JSON encoding for multicast invitations * add specific error for announcing "new" controllers * rename * set size, rename --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2026-05-24 23:26:00 +00:00 · 2023-11-17 19:56:14 +02:00
parent c501f4f9cc
commit 40ba94ce72
8 changed files with 195 additions and 151 deletions
@@ -86,52 +86,16 @@ base64url = <base64url encoded binary> ; RFC4648, section 5
 Multicast session announcement is a binary encoded packet with this syntax:

 ```abnf
-sessionAddressPacket = dhPubKey nonce encrypted(unpaddedSize serviceAddress sessSignature idSignature packetPad)
-dhPubKey = length x509encoded
+sessionAddressPacket = dhPubKey nonce encrypted(unpaddedSize sessionAddress packetPad)
+dhPubKey = length x509encoded ; same as announced
 nonce = length *OCTET
-serviceAddress = largeLength serviceAddressJSON
-sessSignature = length *OCTET ; signs the preceding announcement packet
-idSignature = length *OCTET ; signs the preceding announcement packet including sessSignature
+sessionAddress = largeLength sessionAddressUri ; as above
 length = 1*1 OCTET ; for binary data up to 255 bytes
 largeLength = 2*2 OCTET ; for binary data up to 65535 bytes
 packetPad = <pad packet size to 1450 bytes> ; possibly, we may need to move KEM agreement one step later,
 ; with encapsulation key in HELLO block and KEM ciphertext in reply to HELLO.
 ```

-addressJSON is a JSON string valid against this JTD (RFC 8927) schema:
-
-```json
-{
-  "definitions": {
-    "versionRange": {
-      "type": "string",
-      "metadata": {
-        "format": "[0-9]+(-[0-9]+)?"
-      }
-    },
-    "base64url": {
-      "type": "string",
-      "metadata": {
-        "format": "base64url"
-      }
-    }
-  },
-  "properties": {
-    "ca": {"ref": "base64url"},
-    "host": {"type": "string"},
-    "port": {"type": "uint16"},
-    "v": {"ref": "versionRange"},
-    "ts": {"type": "uint64"},
-    "skey": {"ref": "base64url"},
-    "idkey": {"ref": "base64url"}
-  },
-  "optionalProperties": {
-    "app": {"properties": {}, "additionalProperties": true}
-  },
-  "additionalProperties": true
-}
-```
-
 ### Establishing session TLS connection

 Host connects to controller via TCP session and validates CA credentials during TLS handshake. Controller acts as a TCP server in this connection, to avoid host device listening on a port, which might create an attack vector. During TLS handshake the controller's TCP server MUST present a self-signed two-certificate chain where the fingerprint of the first certificate MUST be the same as in the announcement.
@@ -95,8 +95,8 @@ module Simplex.Messaging.Agent
    xftpDeleteSndFileRemote,
    rcNewHostPairing,
    rcConnectHost,
-    rcConnectCtrlURI,
-    rcConnectCtrlMulticast,
+    rcConnectCtrl,
+    rcDiscoverCtrl,
    foregroundAgent,
    suspendAgent,
    execAgentStoreSQL,
@@ -396,28 +396,27 @@ rcConnectHost :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value ->
 rcConnectHost c = withAgentEnv c .:. rcConnectHost'

 rcConnectHost' :: AgentMonad m => RCHostPairing -> J.Value -> Bool -> m RCHostConnection
-rcConnectHost' pairing ctrlAppInfo _multicast = do
+rcConnectHost' pairing ctrlAppInfo multicast = do
  drg <- asks random
-  liftError RCP $ connectRCHost drg pairing ctrlAppInfo
+  liftError RCP $ connectRCHost drg pairing ctrlAppInfo multicast

 -- | connect to remote controller via URI
-rcConnectCtrlURI :: AgentErrorMonad m => AgentClient -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
-rcConnectCtrlURI c = withAgentEnv c .:. rcConnectCtrlURI'
+rcConnectCtrl :: AgentErrorMonad m => AgentClient -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
+rcConnectCtrl c = withAgentEnv c .:. rcConnectCtrl'

-rcConnectCtrlURI' :: AgentMonad m => RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
-rcConnectCtrlURI' signedInv pairing_ hostAppInfo = do
+rcConnectCtrl' :: AgentMonad m => RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
+rcConnectCtrl' verifiedInv pairing_ hostAppInfo = do
  drg <- asks random
-  liftError RCP $ connectRCCtrlURI drg signedInv pairing_ hostAppInfo
+  liftError RCP $ connectRCCtrl drg verifiedInv pairing_ hostAppInfo

 -- | connect to known remote controller via multicast
-rcConnectCtrlMulticast :: AgentErrorMonad m => AgentClient -> NonEmpty RCCtrlPairing -> J.Value -> m RCCtrlConnection
-rcConnectCtrlMulticast c = withAgentEnv c .: rcConnectCtrlMulticast'
+rcDiscoverCtrl :: AgentErrorMonad m => AgentClient -> NonEmpty RCCtrlPairing -> m (RCCtrlPairing, RCVerifiedInvitation)
+rcDiscoverCtrl c = withAgentEnv c . rcDiscoverCtrl'

-rcConnectCtrlMulticast' :: AgentMonad m => NonEmpty RCCtrlPairing -> J.Value -> m RCCtrlConnection
-rcConnectCtrlMulticast' pairings hostAppInfo = do
-  drg <- asks random
-  subscribers <- newTVarIO 0 -- TODO: get from agent
-  liftError RCP $ connectKnownRCCtrlMulticast drg subscribers pairings hostAppInfo
+rcDiscoverCtrl' :: AgentMonad m => NonEmpty RCCtrlPairing -> m (RCCtrlPairing, RCVerifiedInvitation)
+rcDiscoverCtrl' pairings = do
+  subs <- asks multicastSubscribers
+  liftError RCP $ discoverRCCtrl subs pairings

 -- | Activate operations
 foregroundAgent :: MonadUnliftIO m => AgentClient -> m ()
@@ -182,7 +182,8 @@ data Env = Env
    clientCounter :: TVar Int,
    randomServer :: TVar StdGen,
    ntfSupervisor :: NtfSupervisor,
-    xftpAgent :: XFTPAgent
+    xftpAgent :: XFTPAgent,
+    multicastSubscribers :: TMVar Int
  }

 newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env
@@ -192,7 +193,8 @@ newSMPAgentEnv config@AgentConfig {initialClientId} store = do
  randomServer <- newTVarIO =<< liftIO newStdGen
  ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
  xftpAgent <- atomically newXFTPAgent
-  pure Env {config, store, random, clientCounter, randomServer, ntfSupervisor, xftpAgent}
+  multicastSubscribers <- newTMVarIO 0
+  pure Env {config, store, random, clientCounter, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}

 createAgentStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
 createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app
@@ -19,7 +19,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Time (NominalDiffTime)
 import GHC.Conc
-import UnliftIO.Async
+import UnliftIO hiding (handle)
 import qualified UnliftIO.Exception as UE

 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -136,6 +136,9 @@ safeDecodeUtf8 = decodeUtf8With onError
  where
    onError _ _ = Just '?'

+timeoutThrow :: (MonadUnliftIO m, MonadError e m) => e -> Int -> m a -> m a
+timeoutThrow e ms action = timeout ms action >>= maybe (throwError e) pure
+
 threadDelay' :: Int64 -> IO ()
 threadDelay' time
  | time <= 0 = pure ()
@@ -16,8 +16,8 @@ module Simplex.RemoteControl.Client
    cancelHostClient,
    RCCtrlClient (action),
    RCCtrlConnection,
-    connectRCCtrlURI,
-    connectKnownRCCtrlMulticast,
+    connectRCCtrl,
+    discoverRCCtrl,
    confirmCtrlSession,
    cancelCtrlClient,
    RCStepTMVar,
@@ -45,8 +45,9 @@ import qualified Data.Text as T
 import Data.Time.Clock.System (getSystemTime)
 import qualified Data.X509 as X509
 import Data.X509.Validation (Fingerprint (..), getFingerprint)
-import Network.Socket (PortNumber)
+import Network.Socket (PortNumber, SockAddr (..), hostAddressToTuple)
 import qualified Network.TLS as TLS
+import qualified Network.UDP as UDP
 import Simplex.Messaging.Agent.Client ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Lazy (LazyByteString)
@@ -54,16 +55,18 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Crypto.SNTRUP761
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Transport (TLS (..), cGet, cPut)
 import Simplex.Messaging.Transport.Buffer (peekBuffered)
-import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost, defaultTransportClientConfig, runTransportClient)
+import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient)
 import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
-import Simplex.RemoteControl.Discovery (getLocalAddress, startTLSServer)
+import Simplex.RemoteControl.Discovery (getLocalAddress, recvAnnounce, startTLSServer, withListener, withSender)
 import Simplex.RemoteControl.Invitation
 import Simplex.RemoteControl.Types
 import UnliftIO
+import UnliftIO.Concurrent

 currentRCVersion :: Version
 currentRCVersion = 1
@@ -77,6 +80,9 @@ xrcpBlockSize = 16384
 helloBlockSize :: Int
 helloBlockSize = 12288

+encInvitationSize :: Int
+encInvitationSize = 900
+
 newRCHostPairing :: IO RCHostPairing
 newRCHostPairing = do
  ((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca"
@@ -90,33 +96,40 @@ data RCHostClient = RCHostClient

 data RCHClient_ = RCHClient_
  { startedPort :: TMVar (Maybe PortNumber),
+    announcer :: TMVar (Async (Either RCErrorType ())),
    hostCAHash :: TMVar C.KeyHash,
    endSession :: TMVar ()
  }

 type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))

-connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> ExceptT RCErrorType IO RCHostConnection
-connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo = do
+connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> ExceptT RCErrorType IO RCHostConnection
+connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo multicast = do
  r <- newEmptyTMVarIO
  host <- getLocalAddress >>= maybe (throwError RCENoLocalAddress) pure
-  c@RCHClient_ {startedPort} <- liftIO mkClient
+  c@RCHClient_ {startedPort, announcer} <- liftIO mkClient
  hostKeys <- liftIO genHostKeys
  action <- runClient c r hostKeys `putRCError` r
  -- wait for the port to make invitation
  -- TODO can't we actually find to which interface the server got connected to get host there?
  portNum <- atomically $ readTMVar startedPort
-  signedInv <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys host) portNum
+  signedInv@RCSignedInvitation {invitation} <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys host) portNum
+  when multicast $ case knownHost of
+    Nothing -> throwError RCENewController
+    Just KnownHostPairing {hostDhPubKey} -> do
+      ann <- async . liftIO . runExceptT $ announceRC drg 60 idPrivKey hostDhPubKey hostKeys invitation
+      atomically $ putTMVar announcer ann
  pure (signedInv, RCHostClient {action, client_ = c}, r)
  where
    mkClient :: IO RCHClient_
    mkClient = do
      startedPort <- newEmptyTMVarIO
+      announcer <- newEmptyTMVarIO
      endSession <- newEmptyTMVarIO
      hostCAHash <- newEmptyTMVarIO
-      pure RCHClient_ {startedPort, hostCAHash, endSession}
+      pure RCHClient_ {startedPort, announcer, hostCAHash, endSession}
    runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ())
-    runClient RCHClient_ {startedPort, hostCAHash, endSession} r hostKeys = do
+    runClient RCHClient_ {startedPort, announcer, hostCAHash, endSession} r hostKeys = do
      tlsCreds <- liftIO $ genTLSCredentials caKey caCert
      startTLSServer startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls ->
        void . runExceptT $ do
@@ -133,6 +146,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
          sendRCPacket tls ctrlEncHello
          logDebug "Sent ctrl HELLO"
          whenM (atomically $ tryPutTMVar r' $ Right (RCHostSession {tls, sessionKeys}, helloBody, pairing')) $ do
+            atomically (tryReadTMVar announcer) >>= mapM_ uninterruptibleCancel
            -- can use `RCHostSession` until `endSession` is signalled
            logDebug "Holding session"
            atomically $ takeTMVar endSession
@@ -171,8 +185,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
                idkey = C.publicKey idPrivKey,
                dh = fst dhKeys
              }
-          signedInv = signInviteURL (snd sessKeys) idPrivKey inv
-      pure signedInv
+      pure $ signInvitation (snd sessKeys) idPrivKey inv

 genTLSCredentials :: C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials
 genTLSCredentials caKey caCert = do
@@ -186,8 +199,9 @@ certFingerprint caCert = C.KeyHash fp
    Fingerprint fp = getFingerprint caCert X509.HashSHA256

 cancelHostClient :: RCHostClient -> IO ()
-cancelHostClient RCHostClient {action, client_ = RCHClient_ {endSession}} = do
+cancelHostClient RCHostClient {action, client_ = RCHClient_ {announcer, endSession}} = do
  atomically $ putTMVar endSession ()
+  atomically (tryTakeTMVar announcer) >>= mapM_ uninterruptibleCancel
  uninterruptibleCancel action

 prepareHostSession :: TVar ChaChaDRG -> C.KeyHash -> RCHostPairing -> RCHostKeys -> RCHostEncHello -> ExceptT RCErrorType IO (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing)
@@ -233,14 +247,9 @@ data RCCClient_ = RCCClient_

 type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)))

-connectRCCtrlURI :: TVar ChaChaDRG -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
-connectRCCtrlURI drg signedInv@RCSignedInvitation {invitation} pairing_ hostAppInfo = do
-  unless (verifySignedInviteURI signedInv) $ throwError RCECtrlAuth
-  connectRCCtrl drg invitation pairing_ hostAppInfo
-
 -- app should determine whether it is a new or known pairing based on CA fingerprint in the invitation
-connectRCCtrl :: TVar ChaChaDRG -> RCInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
-connectRCCtrl drg inv@RCInvitation {ca, idkey} pairing_ hostAppInfo = do
+connectRCCtrl :: TVar ChaChaDRG -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
+connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ hostAppInfo = do
  pairing' <- maybe (liftIO newCtrlPairing) updateCtrlPairing pairing_
  connectRCCtrl_ drg pairing' inv hostAppInfo
  where
@@ -351,24 +360,47 @@ prepareCtrlSession
      message <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encMessage
      throwError $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message

-- The application should save updated RCHostPairing after user confirmation of the session
-- TMVar resolves when TLS is connected
-connectKnownRCCtrlMulticast :: TVar ChaChaDRG -> TVar Int -> NonEmpty RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
-connectKnownRCCtrlMulticast drg _subscribers pairings hostAppInfo = do
-  -- start multicast
-  -- receive packets
-  let loop = undefined -- catch and log errors, fail on timeout
-      receive = undefined
-      parse = undefined
-  (pairing, inv) <- loop $ receive >>= parse >>= findRCCtrlPairing pairings
-  connectRCCtrl drg inv pairing hostAppInfo
+-- * Multicast discovery

-findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCInvitation)
+announceRC :: TVar ChaChaDRG -> Int -> C.PrivateKeyEd25519 -> C.PublicKeyX25519 -> RCHostKeys -> RCInvitation -> ExceptT RCErrorType IO ()
+announceRC drg maxCount idPrivKey knownDhPub RCHostKeys {sessKeys, dhKeys} inv = withSender $ \sender -> do
+  replicateM_ maxCount $ do
+    logDebug "Announcing..."
+    nonce <- atomically $ C.pseudoRandomCbNonce drg
+    encInvitation <- liftEitherWith undefined $ C.cbEncrypt sharedKey nonce sigInvitation encInvitationSize
+    liftIO . UDP.send sender $ smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation}
+    threadDelay 1000000
+  where
+    sigInvitation = strEncode $ signInvitation sPrivKey idPrivKey inv
+    (_sPub, sPrivKey) = sessKeys
+    sharedKey = C.dh' knownDhPub dhPrivKey
+    (dhPubKey, dhPrivKey) = dhKeys
+
+discoverRCCtrl :: TMVar Int -> NonEmpty RCCtrlPairing -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
+discoverRCCtrl subscribers pairings =
+  timeoutThrow RCENotDiscovered 30000000 $ withListener subscribers $ \listener ->
+    loop $ do
+      (source, bytes) <- recvAnnounce listener
+      encInvitation <- liftEitherWith (const RCEInvitation) $ smpDecode bytes
+      r@(_, RCVerifiedInvitation RCInvitation {host}) <- findRCCtrlPairing pairings encInvitation
+      case source of
+        SockAddrInet _ ha | THIPv4 (hostAddressToTuple ha) == host -> pure ()
+        _ -> throwError RCEInvitation
+      pure r
+  where
+    loop :: ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
+    loop action =
+      liftIO (runExceptT action) >>= \case
+        Left err -> logError (tshow err) >> loop action
+        Right res -> pure res
+
+findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
 findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do
  (pairing, signedInvStr) <- liftEither $ decrypt (L.toList pairings)
-  signedInv@RCSignedInvitation {invitation} <- liftEitherWith RCESyntax $ smpDecode signedInvStr
-  unless (verifySignedInvitationMulticast signedInv) $ throwError RCECtrlAuth
-  pure (pairing, invitation)
+  signedInv <- liftEitherWith RCESyntax $ strDecode signedInvStr
+  inv@(RCVerifiedInvitation RCInvitation {dh = invDh}) <- maybe (throwError RCEInvitation) pure $ verifySignedInvitation signedInv
+  unless (invDh == dhPubKey) $ throwError RCEInvitation
+  pure (pairing, inv)
  where
    decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
    decrypt [] = Left RCECtrlNotFound
@@ -380,6 +412,8 @@ findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do
      let key = C.dh' dhPubKey dhPrivKey
       in eitherToMaybe $ C.cbDecrypt key nonce encInvitation

+-- * Controller handle operations
+
 -- application should call this function when TMVar resolves
 confirmCtrlSession :: RCCtrlClient -> Bool -> IO ()
 confirmCtrlSession RCCtrlClient {client_ = RCCClient_ {confirmSession}} res = do
@@ -3,13 +3,17 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}

-module Simplex.RemoteControl.Invitation where
+module Simplex.RemoteControl.Invitation
+  ( RCInvitation (..)
+  , signInvitation
+  , RCSignedInvitation (..)
+  , verifySignedInvitation
+  , RCVerifiedInvitation (..)
+  , RCEncInvitation (..)
+  ) where

 import qualified Data.Aeson as J
-import qualified Data.Aeson.TH as JQ
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
@@ -21,7 +25,7 @@ import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery, urlDecode)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (defaultJSON, parseAll)
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Version (VersionRange)

@@ -119,38 +123,32 @@ instance StrEncoding RCSignedInvitation where
    idsig <- requiredP sigs "idsig" $ parseAll strP
    pure RCSignedInvitation {invitation, ssig, idsig}

-signInviteURL :: C.PrivateKey C.Ed25519 -> C.PrivateKey C.Ed25519 -> RCInvitation -> RCSignedInvitation
-signInviteURL sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig}
+signInvitation :: C.PrivateKey C.Ed25519 -> C.PrivateKey C.Ed25519 -> RCInvitation -> RCSignedInvitation
+signInvitation sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig}
  where
-    inviteUrl = strEncode invitation
+    uri = strEncode invitation
    ssig =
-      case C.sign (C.APrivateSignKey C.SEd25519 sKey) inviteUrl of
+      case C.sign (C.APrivateSignKey C.SEd25519 sKey) uri of
        C.ASignature C.SEd25519 s -> s
        _ -> error "signing with ed25519"
-    inviteUrlSigned = mconcat [inviteUrl, "&ssig=", strEncode ssig]
+    inviteUrlSigned = mconcat [uri, "&ssig=", strEncode ssig]
    idsig =
      case C.sign (C.APrivateSignKey C.SEd25519 idKey) inviteUrlSigned of
        C.ASignature C.SEd25519 s -> s
        _ -> error "signing with ed25519"

-verifySignedInviteURI :: RCSignedInvitation -> Bool
-verifySignedInviteURI RCSignedInvitation {invitation, ssig, idsig} =
-  C.verify aSKey aSSig inviteURL && C.verify aIdKey aIdSig inviteURLS
+newtype RCVerifiedInvitation = RCVerifiedInvitation RCInvitation
+  deriving (Show)
+
+verifySignedInvitation :: RCSignedInvitation -> Maybe RCVerifiedInvitation
+verifySignedInvitation RCSignedInvitation {invitation, ssig, idsig} =
+  if C.verify' skey ssig inviteURL && C.verify' idkey idsig inviteURLS
+    then Just $ RCVerifiedInvitation invitation
+    else Nothing
  where
    RCInvitation {skey, idkey} = invitation
    inviteURL = strEncode invitation
    inviteURLS = mconcat [inviteURL, "&ssig=", strEncode ssig]
-    aSKey = C.APublicVerifyKey C.SEd25519 skey
-    aSSig = C.ASignature C.SEd25519 ssig
-    aIdKey = C.APublicVerifyKey C.SEd25519 idkey
-    aIdSig = C.ASignature C.SEd25519 idsig
-
-instance Encoding RCSignedInvitation where
-  smpEncode RCSignedInvitation {} = error "TODO: RCSignedInvitation.smpEncode"
-  smpP = error "TODO: RCSignedInvitation.smpP"
-
-verifySignedInvitationMulticast :: RCSignedInvitation -> Bool
-verifySignedInvitationMulticast RCSignedInvitation {invitation, ssig, idsig} = undefined

 data RCEncInvitation = RCEncInvitation
  { dhPubKey :: C.PublicKeyX25519,
@@ -169,8 +167,3 @@ instance Encoding RCEncInvitation where

 requiredP :: MonadFail m => SimpleQuery -> ByteString -> (ByteString -> Either String a) -> m a
 requiredP q k f = maybe (fail $ "missing " <> show k) (either fail pure . f) $ lookup k q
-
-- optionalP :: MonadFail m => SimpleQuery -> ByteString -> (ByteString -> Either String a) -> m (Maybe a)
-- optionalP q k f = maybe (pure Nothing) (either fail (pure . Just) . f) $ lookup k q
-
-$(JQ.deriveJSON defaultJSON ''RCInvitation)
@@ -31,11 +31,14 @@ data RCErrorType
  = RCEInternal {internalErr :: String}
  | RCEIdentity
  | RCENoLocalAddress
+  | RCENewController
+  | RCENotDiscovered
  | RCETLSStartFailed
  | RCEException {exception :: String}
  | RCECtrlAuth
  | RCECtrlNotFound
  | RCECtrlError {ctrlErr :: String}
+  | RCEInvitation
  | RCEVersion
  | RCEEncrypt
  | RCEDecrypt
@@ -48,11 +51,14 @@ instance StrEncoding RCErrorType where
    RCEInternal err -> "INTERNAL" <> text err
    RCEIdentity -> "IDENTITY"
    RCENoLocalAddress -> "NO_LOCAL_ADDR"
+    RCENewController -> "NEW_CONTROLLER"
+    RCENotDiscovered -> "NOT_DISCOVERED"
    RCETLSStartFailed -> "CTRL_TLS_START"
    RCEException err -> "EXCEPTION" <> text err
    RCECtrlAuth -> "CTRL_AUTH"
    RCECtrlNotFound -> "CTRL_NOT_FOUND"
    RCECtrlError err -> "CTRL_ERROR" <> text err
+    RCEInvitation -> "INVITATION"
    RCEVersion -> "VERSION"
    RCEEncrypt -> "ENCRYPT"
    RCEDecrypt -> "DECRYPT"
@@ -65,11 +71,14 @@ instance StrEncoding RCErrorType where
      "INTERNAL" -> RCEInternal <$> textP
      "IDENTITY" -> pure RCEIdentity
      "NO_LOCAL_ADDR" -> pure RCENoLocalAddress
+      "NEW_CONTROLLER" -> pure RCENewController
+      "NOT_DISCOVERED" -> pure RCENotDiscovered
      "CTRL_TLS_START" -> pure RCETLSStartFailed
      "EXCEPTION" -> RCEException <$> textP
      "CTRL_AUTH" -> pure RCECtrlAuth
      "CTRL_NOT_FOUND" -> pure RCECtrlNotFound
      "CTRL_ERROR" -> RCECtrlError <$> textP
+      "INVITATION" -> pure RCEInvitation
      "VERSION" -> pure RCEVersion
      "ENCRYPT" -> pure RCEEncrypt
      "DECRYPT" -> pure RCEDecrypt
@@ -6,9 +6,12 @@ module RemoteControl where

 import AgentTests.FunctionalAPITests (runRight)
 import Control.Logger.Simple
-import Crypto.Random (drgNew)
+import Crypto.Random (ChaChaDRG, drgNew)
 import qualified Data.Aeson as J
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Simplex.RemoteControl.Client as RC
+import Simplex.RemoteControl.Invitation (RCSignedInvitation, verifySignedInvitation)
+import Simplex.RemoteControl.Types
 import Test.Hspec
 import UnliftIO
 import UnliftIO.Concurrent
@@ -18,6 +21,8 @@ remoteControlTests = do
  describe "New controller/host pairing" $ do
    it "should connect to new pairing" testNewPairing
    it "should connect to existing pairing" testExistingPairing
+  describe "Multicast discovery" $ do
+    it "should find paired host and connect" testMulticast

 testNewPairing :: IO ()
 testNewPairing = do
@@ -26,7 +31,7 @@ testNewPairing = do
  invVar <- newEmptyMVar
  ctrlSessId <- async . runRight $ do
    logNote "c 1"
-    (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app")
+    (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") False
    logNote "c 2"
    putMVar invVar (inv, hc)
    logNote "c 3"
@@ -39,12 +44,13 @@ testNewPairing = do
    liftIO $ RC.cancelHostClient hc
    pure sessId

-  (inv, hc) <- takeMVar invVar
+  (signedInv, hc) <- takeMVar invVar
  -- logNote $ decodeUtf8 $ strEncode inv
+  inv <- maybe (fail "bad invite") pure $ verifySignedInvitation signedInv

  hostSessId <- async . runRight $ do
    logNote "h 1"
-    (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv Nothing (J.String "app")
+    (rcCtrlClient, r) <- RC.connectRCCtrl drg inv Nothing (J.String "app")
    logNote "h 2"
    Right (sessId', _tls, r') <- atomically $ takeTMVar r
    logNote "h 3"
@@ -69,44 +75,78 @@ testExistingPairing = do
  drg <- drgNew >>= newTVarIO
  invVar <- newEmptyMVar
  hp <- liftIO $ RC.newRCHostPairing
-  ctrl <- runCtrl drg hp invVar
+  ctrl <- runCtrl drg False hp invVar
  inv <- takeMVar invVar
  let cp_ = Nothing
-  host <- runHost drg cp_ inv
+  host <- runHostURI drg cp_ inv
  timeout 5000000 (waitBoth ctrl host) >>= \case
    Nothing -> fail "timeout"
    Just (hp', cp') -> do
-      ctrl' <- runCtrl drg hp' invVar
+      ctrl' <- runCtrl drg False hp' invVar
      inv' <- takeMVar invVar
-      host' <- runHost drg (Just cp') inv'
+      host' <- runHostURI drg (Just cp') inv'
      timeout 5000000 (waitBoth ctrl' host') >>= \case
        Nothing -> fail "timeout"
        Just (_hp2, cp2) -> do
-          ctrl2 <- runCtrl drg hp' invVar -- old host pairing used to test controller not updating state
+          ctrl2 <- runCtrl drg False hp' invVar -- old host pairing used to test controller not updating state
          inv2 <- takeMVar invVar
-          host2 <- runHost drg (Just cp2) inv2
+          host2 <- runHostURI drg (Just cp2) inv2
          timeout 5000000 (waitBoth ctrl2 host2) >>= \case
            Nothing -> fail "timeout"
            Just (hp3, cp3) -> do
-              ctrl3 <- runCtrl drg hp3 invVar
+              ctrl3 <- runCtrl drg False hp3 invVar
              inv3 <- takeMVar invVar
-              host3 <- runHost drg (Just cp3) inv3
+              host3 <- runHostURI drg (Just cp3) inv3
              timeout 5000000 (waitBoth ctrl3 host3) >>= \case
                Nothing -> fail "timeout"
                Just _ -> pure ()
-  where
-    runCtrl drg hp invVar = async . runRight $ do
-      (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app")
-      putMVar invVar inv
-      Right (_sessId, _tls, r') <- atomically $ takeTMVar r
-      Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r'
-      threadDelay 250000
-      liftIO $ RC.cancelHostClient hc
-      pure hp'
-    runHost drg cp_ inv = async . runRight $ do
-      (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv cp_ (J.String "app")
-      Right (_sessId', _tls, r') <- atomically $ takeTMVar r
-      liftIO $ RC.confirmCtrlSession rcCtrlClient True
-      Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r'
-      threadDelay 250000
-      pure cp'
+
+testMulticast :: IO ()
+testMulticast = do
+  drg <- drgNew >>= newTVarIO
+  subscribers <- newTMVarIO 0
+  invVar <- newEmptyMVar
+  hp <- liftIO RC.newRCHostPairing
+  ctrl <- runCtrl drg False hp invVar
+  inv <- takeMVar invVar
+  let cp_ = Nothing
+  host <- runHostURI drg cp_ inv
+  timeout 5000000 (waitBoth ctrl host) >>= \case
+    Nothing -> fail "timeout"
+    Just (hp', cp') -> do
+      ctrl' <- runCtrl drg True hp' invVar
+      _inv <- takeMVar invVar
+      host' <- runHostMulticast drg subscribers cp'
+      timeout 5000000 (waitBoth ctrl' host') >>= \case
+        Nothing -> fail "timeout"
+        Just _ -> pure ()
+
+runCtrl :: TVar ChaChaDRG -> Bool -> RCHostPairing -> MVar RCSignedInvitation -> IO (Async RCHostPairing)
+runCtrl drg multicast hp invVar = async . runRight $ do
+  (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") multicast
+  putMVar invVar inv
+  Right (_sessId, _tls, r') <- atomically $ takeTMVar r
+  Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r'
+  threadDelay 250000
+  liftIO $ RC.cancelHostClient hc
+  pure hp'
+
+runHostURI :: TVar ChaChaDRG -> Maybe RCCtrlPairing -> RCSignedInvitation -> IO (Async RCCtrlPairing)
+runHostURI drg cp_ signedInv = async . runRight $ do
+  inv <- maybe (fail "bad invite") pure $ verifySignedInvitation signedInv
+  (rcCtrlClient, r) <- RC.connectRCCtrl drg inv cp_ (J.String "app")
+  Right (_sessId', _tls, r') <- atomically $ takeTMVar r
+  liftIO $ RC.confirmCtrlSession rcCtrlClient True
+  Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r'
+  threadDelay 250000
+  pure cp'
+
+runHostMulticast :: TVar ChaChaDRG -> TMVar Int -> RCCtrlPairing -> IO (Async RCCtrlPairing)
+runHostMulticast drg subscribers cp = async . runRight $ do
+  (pairing, inv) <- RC.discoverRCCtrl subscribers (cp :| [])
+  (rcCtrlClient, r) <- RC.connectRCCtrl drg inv (Just pairing) (J.String "app")
+  Right (_sessId', _tls, r') <- atomically $ takeTMVar r
+  liftIO $ RC.confirmCtrlSession rcCtrlClient True
+  Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r'
+  threadDelay 250000
+  pure cp'