extract xrcp protocol (#878)

* xrcp: files and folders * extract remote up to rev-http * Remove unused files --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2026-03-30 18:35:59 +00:00 · 2023-10-31 21:31:53 +02:00
parent 0410948b56
commit 8e2ffcb297
5 changed files with 462 additions and 1 deletions
--- a/src/Simplex/RemoteControl/Discovery.hs
+++ b/src/Simplex/RemoteControl/Discovery.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Simplex.RemoteControl.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.RemoteControl.Discovery.Multicast (setMembership)
+import Simplex.RemoteControl.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
+import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient)
+import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
+import Simplex.Messaging.Util (ifM, tshow)
+import Simplex.Messaging.Version (mkVersionRange)
+import UnliftIO
+import UnliftIO.Concurrent
+
+-- | mDNS multicast group
+pattern MULTICAST_ADDR_V4 :: (IsString a, Eq a) => a
+pattern MULTICAST_ADDR_V4 = "224.0.0.251"
+
+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 = "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.
+announceCtrl :: MonadUnliftIO m => (MVar () -> MVar rc -> Transport.TLS -> IO ()) -> Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> m () -> m rc
+announceCtrl runCtrl tasks (sigKey, announce@Announce {caFingerprint, serviceAddress=(host, _port)}) credentials finishAction = do
+  ctrlStarted <- newEmptyMVar
+  started <- newEmptyTMVarIO
+  ctrlFinished <- newEmptyMVar
+  _ <- forkIO $ readMVar ctrlFinished >> finishAction -- attach external cleanup action to session lock
+  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 " <> ident
+    cancel announcer
+    runCtrl ctrlFinished ctrlStarted tls `catchAny` (logError . tshow)
+    logInfo $ "Client finished for " <> ident
+  _ <- forkIO $ waitCatch tlsServer >> void (tryPutMVar ctrlFinished ())
+  tasks `registerAsync` tlsServer
+  logInfo $ "Waiting for client for " <> ident
+  readMVar ctrlStarted
+  where
+    ident = decodeUtf8 $ strEncode caFingerprint
+
+-- | 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
+
+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
+        { TLS.serverWantClientCert = False,
+          TLS.serverShared = def {TLS.sharedCredentials = credentials},
+          TLS.serverHooks = def,
+          TLS.serverSupported = supportedParameters
+        }
+
+withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a
+withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close)
+
+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
+  joinMulticast subscribers raw (listenerHostAddr4 sock)
+  pure sock
+
+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
+  N.SockAddrInet _port host -> host
+  _ -> error "MULTICAST_ADDR_V4 is V4"
+
+recvAnnounce :: (MonadIO m) => UDP.ListenSocket -> m (N.SockAddr, ByteString)
+recvAnnounce sock = liftIO $ do
+  (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
+  pure (source, invite)
+
+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)
--- a/src/Simplex/RemoteControl/Discovery/Multicast.hsc
+++ b/src/Simplex/RemoteControl/Discovery/Multicast.hsc
@@ -0,0 +1,48 @@
+module Simplex.RemoteControl.Discovery.Multicast
+  ( setMembership
+  ) where
+
+import Foreign (Ptr, allocaBytes, castPtr, pokeByteOff)
+import Foreign.C.Types (CInt (..))
+import Network.Socket
+
+#include <HsNet.h>
+
+{- | Toggle multicast group membership.
+
+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 (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 -> 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
+
+#ifdef mingw32_HOST_OS
+
+foreign import stdcall unsafe "setsockopt"
+    c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
+
+c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt
+c_IP_ADD_MEMBERSHIP  = 12
+c_IP_DROP_MEMBERSHIP = 13
+
+#else
+
+foreign import ccall unsafe "setsockopt"
+    c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
+
+c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt
+c_IP_ADD_MEMBERSHIP  = #const IP_ADD_MEMBERSHIP
+c_IP_DROP_MEMBERSHIP = #const IP_DROP_MEMBERSHIP
+
+#endif
+
+c_IPPROTO_IP :: CInt
+c_IPPROTO_IP = #const IPPROTO_IP
--- a/src/Simplex/RemoteControl/Types.hs
+++ b/src/Simplex/RemoteControl/Types.hs
@@ -0,0 +1,198 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GADTs #-}
+
+module Simplex.RemoteControl.Types where
+
+import Control.Monad
+import Crypto.Error (eitherCryptoError)
+import qualified Crypto.PubKey.Ed25519 as Ed25519
+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.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.Encoding (Encoding (..))
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Version (VersionRange, mkVersionRange)
+import UnliftIO
+
+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
+
+-- XXX: Move to utils?
+type Tasks = TVar [Async ()]
+
+asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m ()
+asyncRegistered tasks action = async action >>= registerAsync tasks
+
+registerAsync :: MonadIO m => Tasks -> Async () -> m ()
+registerAsync tasks = atomically . modifyTVar tasks . (:)
+
+cancelTasks :: (MonadIO m) => Tasks -> m ()
+cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel