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-04-13 03:15:46 +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/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)