agent: xrcp implementation for connection via link (no multicast) (#884)

* WIP: start working on connection invites

startSession/OOB is broken now - the port isn't coming from the actualy assigned one.

* Add invite types

* clean old invite-related types

* apply renames

* Move SessionKeys from Invitation

* Stub host-side keys and handle

* move keys and handles to Types

* add Simplex.RemoteControl.Client

* more keys

* progress

* crypto for sessions

* progress to multicast

* multicast crypto

* add RC TLS server

* agent api for remote control

* WIP: tls client

* fix test

* update encoding to include nonce

* add TODO

* update

* Use network-info to find TransportHost

* request and submit tls client certificate

* WIP: add missing bits for testing RC client

* RCEncryptedHello encoding

* add block encoding

* refactor

* validate known host certificate

* remove some spaghetti

* functional API to host/ctrl clients

* refactor connectRCCtrl_

* refactor connectRCHost

* question

* add type

* fix RC session

* update doc

* update doc 2

* add block on confirmation

* remove unused parameter

* export CtrlSessKeys

* export

* fix parsing

* move test of xrcp handshake

* move KEM to HELLO step

* fix JSON

* type

---------

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

src/Simplex/Messaging/Agent.hs

@@ -93,6 +93,10 @@ module Simplex.Messaging.Agent
     xftpSendFile,
     xftpDeleteSndFileInternal,
     xftpDeleteSndFileRemote,
+    rcNewHostPairing,
+    rcConnectHost,
+    rcConnectCtrlURI,
+    rcConnectCtrlMulticast,
     foregroundAgent,
     suspendAgent,
     execAgentStoreSQL,
@@ -111,6 +115,7 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Crypto.Random (MonadRandom)
+import qualified Data.Aeson as J
 import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -156,6 +161,8 @@ import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import Simplex.RemoteControl.Client
+import Simplex.RemoteControl.Invitation
 import UnliftIO.Async (async, race_)
 import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
 import UnliftIO.STM
@@ -379,6 +386,38 @@ xftpDeleteSndFileInternal c = withAgentEnv c . deleteSndFileInternal c
 xftpDeleteSndFileRemote :: AgentErrorMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
 xftpDeleteSndFileRemote c = withAgentEnv c .:. deleteSndFileRemote c
 
+-- | Create new remote host pairing
+rcNewHostPairing :: MonadIO m => m RCHostPairing
+rcNewHostPairing = liftIO newRCHostPairing
+
+-- | start TLS server for remote host with optional multicast
+rcConnectHost :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value -> Bool -> m RCHostConnection
+rcConnectHost c = withAgentEnv c .:. rcConnectHost'
+
+rcConnectHost' :: AgentMonad m => RCHostPairing -> J.Value -> Bool -> m RCHostConnection
+rcConnectHost' pairing ctrlAppInfo _multicast = do
+  drg <- asks random
+  liftError RCP $ connectRCHost drg pairing ctrlAppInfo
+
+-- | connect to remote controller via URI
+rcConnectCtrlURI :: AgentErrorMonad m => AgentClient -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
+rcConnectCtrlURI c = withAgentEnv c .:. rcConnectCtrlURI'
+
+rcConnectCtrlURI' :: AgentMonad m => RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
+rcConnectCtrlURI' signedInv pairing_ hostAppInfo = do
+  drg <- asks random
+  liftError RCP $ connectRCCtrlURI drg signedInv pairing_ hostAppInfo
+
+-- | connect to known remote controller via multicast
+rcConnectCtrlMulticast :: AgentErrorMonad m => AgentClient -> NonEmpty RCCtrlPairing -> J.Value -> m RCCtrlConnection
+rcConnectCtrlMulticast c = withAgentEnv c .: rcConnectCtrlMulticast'
+
+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
+
 -- | Activate operations
 foregroundAgent :: MonadUnliftIO m => AgentClient -> m ()
 foregroundAgent c = withAgentEnv c $ foregroundAgent' c

src/Simplex/Messaging/Agent/Protocol.hs

@@ -211,6 +211,7 @@ import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTra
 import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import Simplex.RemoteControl.Types
 import Text.Read
 import UnliftIO.Exception (Exception)
 
@@ -1419,6 +1420,8 @@ data AgentErrorType
     NTF {ntfErr :: ErrorType}
   | -- | XFTP protocol errors forwarded to agent clients
     XFTP {xftpErr :: XFTPErrorType}
+  | -- | XRCP protocol errors forwarded to agent clients
+    RCP {rcpErr :: RCErrorType}
   | -- | SMP server errors
     BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
   | -- | errors of other agents
@@ -1524,6 +1527,7 @@ instance StrEncoding AgentErrorType where
       <|> "SMP " *> (SMP <$> strP)
       <|> "NTF " *> (NTF <$> strP)
       <|> "XFTP " *> (XFTP <$> strP)
+      <|> "RCP " *> (RCP <$> strP)
       <|> "BROKER " *> (BROKER <$> textP <* " RESPONSE " <*> (RESPONSE <$> textP))
       <|> "BROKER " *> (BROKER <$> textP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
       <|> "BROKER " *> (BROKER <$> textP <* A.space <*> parseRead1)
@@ -1540,6 +1544,7 @@ instance StrEncoding AgentErrorType where
     SMP e -> "SMP " <> strEncode e
     NTF e -> "NTF " <> strEncode e
     XFTP e -> "XFTP " <> strEncode e
+    RCP e -> "RCP " <> strEncode e
     BROKER srv (RESPONSE e) -> "BROKER " <> text srv <> " RESPONSE " <> text e
     BROKER srv (TRANSPORT e) -> "BROKER " <> text srv <> " TRANSPORT " <> serializeTransportError e
     BROKER srv e -> "BROKER " <> text srv <> " " <> bshow e

src/Simplex/Messaging/Client.hs

@@ -237,7 +237,7 @@ defaultNetworkConfig =
 
 transportClientConfig :: NetworkConfig -> TransportClientConfig
 transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
-  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors}
+  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing}
 
 -- | protocol client configuration.
 data ProtocolClientConfig = ProtocolClientConfig

src/Simplex/Messaging/Crypto.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
@@ -678,6 +679,10 @@ class CryptoSignature s where
   signatureBytes :: s -> ByteString
   decodeSignature :: ByteString -> Either String s
 
+instance CryptoSignature (Signature s) => StrEncoding (Signature s) where
+  strEncode = serializeSignature
+  strDecode = decodeSignature
+
 instance CryptoSignature ASignature where
   signatureBytes (ASignature _ sig) = signatureBytes sig
   decodeSignature s

src/Simplex/Messaging/Crypto/SNTRUP761.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Simplex.Messaging.Crypto.SNTRUP761 where
 
@@ -8,21 +9,36 @@ import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
 import Simplex.Messaging.Crypto
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 
 -- Hybrid shared secret for crypto_box is defined as SHA256(DHSecret || KEMSharedKey),
 -- similar to https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/
 
+class KEMSharedSecret kem where kemSecretBytes :: kem -> ScrubbedBytes
+
 newtype KEMHybridSecret = KEMHybridSecret ScrubbedBytes
 
+newtype KEMHybridOrDHSecret = KEMHybridOrDHSecret ScrubbedBytes
+
+instance KEMSharedSecret KEMHybridSecret where kemSecretBytes (KEMHybridSecret secret) = secret
+
+instance KEMSharedSecret KEMHybridOrDHSecret where kemSecretBytes (KEMHybridOrDHSecret secret) = secret
+
 -- | NaCl @crypto_box@ decrypt with a shared hybrid DH + KEM secret and 192-bit nonce.
-kcbDecrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Either CryptoError ByteString
-kcbDecrypt (KEMHybridSecret secret) = sbDecrypt_ secret
+kcbDecrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Either CryptoError ByteString
+kcbDecrypt = sbDecrypt_ . kemSecretBytes
 
 -- | NaCl @crypto_box@ encrypt with a shared hybrid DH + KEM secret and 192-bit nonce.
-kcbEncrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
-kcbEncrypt (KEMHybridSecret secret) = sbEncrypt_ secret
+kcbEncrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
+kcbEncrypt = sbEncrypt_ . kemSecretBytes
 
-kemHybridSecret :: DhSecret 'X25519 -> KEMSharedKey -> KEMHybridSecret
-kemHybridSecret (DhSecretX25519 k1) (KEMSharedKey k2) =
-  KEMHybridSecret $ BA.convert (hash $ BA.convert k1 <> k2 :: Digest SHA256)
+kemHybridSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> KEMSharedKey -> KEMHybridSecret
+kemHybridSecret k pk (KEMSharedKey kem) =
+  let DhSecretX25519 dh = C.dh' k pk
+   in KEMHybridSecret $ BA.convert (hash $ BA.convert dh <> kem :: Digest SHA256)
+
+kemHybridOrDHSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> Maybe KEMSharedKey -> KEMHybridOrDHSecret
+kemHybridOrDHSecret k pk = \case
+  Just kem -> KEMHybridOrDHSecret $ kemSecretBytes $ kemHybridSecret k pk kem
+  Nothing -> let DhSecretX25519 dh = C.dh' k pk in KEMHybridOrDHSecret $ BA.convert dh

src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs

@@ -4,6 +4,7 @@ module Simplex.Messaging.Crypto.SNTRUP761.Bindings where
 
 import Control.Concurrent.STM
 import Crypto.Random (ChaChaDRG)
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Bifunctor (bimap)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
@@ -16,14 +17,20 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 
 newtype KEMPublicKey = KEMPublicKey ByteString
+  deriving (Show)
 
 newtype KEMSecretKey = KEMSecretKey ScrubbedBytes
+  deriving (Show)
 
 newtype KEMCiphertext = KEMCiphertext ByteString
+  deriving (Show)
 
 newtype KEMSharedKey = KEMSharedKey ScrubbedBytes
+  deriving (Show)
 
-sntrup761Keypair :: TVar ChaChaDRG -> IO (KEMPublicKey, KEMSecretKey)
+type KEMKeyPair = (KEMPublicKey, KEMSecretKey)
+
+sntrup761Keypair :: TVar ChaChaDRG -> IO KEMKeyPair
 sntrup761Keypair drg =
   bimap KEMPublicKey KEMSecretKey
     <$> BA.allocRet
@@ -51,14 +58,17 @@ sntrup761Dec (KEMCiphertext c) (KEMSecretKey sk) =
       KEMSharedKey
         <$> BA.alloc c_SNTRUP761_SIZE (\kPtr -> c_sntrup761_dec kPtr cPtr skPtr)
 
-instance Encoding KEMPublicKey where
-  smpEncode (KEMPublicKey pk) = smpEncode (BA.convert pk :: ByteString)
-  smpP = KEMPublicKey . BA.convert <$> smpP @ByteString
-
 instance StrEncoding KEMPublicKey where
   strEncode (KEMPublicKey pk) = strEncode (BA.convert pk :: ByteString)
   strP = KEMPublicKey . BA.convert <$> strP @ByteString
 
 instance Encoding KEMCiphertext where
-  smpEncode (KEMCiphertext c) = smpEncode (BA.convert c :: ByteString)
-  smpP = KEMCiphertext . BA.convert <$> smpP @ByteString
+  smpEncode (KEMCiphertext c) = smpEncode . Large $ BA.convert c
+  smpP = KEMCiphertext . BA.convert . unLarge <$> smpP
+
+instance ToJSON KEMPublicKey where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON KEMPublicKey where
+  parseJSON = strParseJSON "KEMPublicKey"

src/Simplex/Messaging/Encoding.hs

@@ -11,6 +11,7 @@ module Simplex.Messaging.Encoding
   ( Encoding (..),
     Tail (..),
     Large (..),
+    _smpP,
     smpEncodeList,
     smpListP,
     lenEncode,
@@ -143,6 +144,9 @@ instance Encoding SystemTime where
   smpP = MkSystemTime <$> smpP <*> pure 0
   {-# INLINE smpP #-}
 
+_smpP :: Encoding a => Parser a
+_smpP = A.space *> smpP
+
 -- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
 smpEncodeList :: Encoding a => [a] -> ByteString
 smpEncodeList xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs

src/Simplex/Messaging/Protocol.hs

@@ -1203,9 +1203,6 @@ instance ProtocolEncoding ErrorType BrokerMsg where
       | B.null queueId -> Left $ CMD NO_ENTITY
       | otherwise -> Right cmd
 
-_smpP :: Encoding a => Parser a
-_smpP = A.space *> smpP
-
 -- | Parse SMP protocol commands and broker messages
 parseProtocol :: forall err msg. ProtocolEncoding err msg => Version -> ByteString -> Either err msg
 parseProtocol v s =

src/Simplex/Messaging/Transport/Client.hs

@@ -110,12 +110,13 @@ instance IsString (NonEmpty TransportHost) where fromString = parseString strDec
 data TransportClientConfig = TransportClientConfig
   { socksProxy :: Maybe SocksProxy,
     tcpKeepAlive :: Maybe KeepAliveOpts,
-    logTLSErrors :: Bool
+    logTLSErrors :: Bool,
+    clientCredentials :: Maybe (X.CertificateChain, T.PrivKey)
   }
   deriving (Eq, Show)
 
 defaultTransportClientConfig :: TransportClientConfig
-defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True
+defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing
 
 clientTransportConfig :: TransportClientConfig -> TransportConfig
 clientTransportConfig TransportClientConfig {logTLSErrors} =
@@ -126,9 +127,9 @@ runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig ->
 runTransportClient = runTLSTransportClient supportedParameters Nothing
 
 runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
-runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive} proxyUsername host port keyHash client = do
+runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials} proxyUsername host port keyHash client = do
   let hostName = B.unpack $ strEncode host
-      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
+      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials
       connectTCP = case socksProxy of
         Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
         _ -> connectTCPClient hostName
@@ -205,14 +206,19 @@ instance ToJSON SocksProxy where
 instance FromJSON SocksProxy where
   parseJSON = strParseJSON "SocksProxy"
 
-mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
-mkTLSClientParams supported caStore_ host port keyHash_ = do
-  let p = B.pack port
+mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> T.ClientParams
+mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ =
   (T.defaultParamsClient host p)
-    { T.clientShared = maybe def (\caStore -> def {T.sharedCAStore = caStore}) caStore_,
-      T.clientHooks = maybe def (\keyHash -> def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p}) keyHash_,
+    { T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
+      T.clientHooks =
+        def
+          { T.onServerCertificate = maybe def (\cafp _ _ _ -> validateCertificateChain cafp host p) cafp_,
+            T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_
+          },
       T.clientSupported = supported
     }
+  where
+    p = B.pack port
 
 validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
 validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]

src/Simplex/Messaging/Transport/Credentials.hs

@@ -13,7 +13,7 @@ import Data.ASN1.Types (getObjectID)
 import Data.ASN1.Types.String (ASN1StringEncoding (UTF8))
 import Data.Hourglass (Hours (..), timeAdd)
 import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as NE
+import qualified Data.List.NonEmpty as L
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import qualified Data.X509 as X509
@@ -34,9 +34,9 @@ tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credentials)
 tlsCredentials credentials = (C.KeyHash rootFP, TLS.Credentials [(X509.CertificateChain certs, privateToTls $ snd leafKey)])
   where
     Fingerprint rootFP = getFingerprint root X509.HashSHA256
-    leafKey = fst $ NE.head credentials
-    root = snd $ NE.last credentials
-    certs = map snd $ NE.toList credentials
+    leafKey = fst $ L.head credentials
+    root = snd $ L.last credentials
+    certs = map snd $ L.toList credentials
 
 privateToTls :: C.APrivateSignKey -> TLS.PrivKey
 privateToTls (C.APrivateSignKey _ k) = case k of

src/Simplex/Messaging/Transport/HTTP2/Client.hs

@@ -66,7 +66,7 @@ defaultHTTP2ClientConfig =
   HTTP2ClientConfig
     { qSize = 64,
       connTimeout = 10000000,
-      transportConfig = TransportClientConfig Nothing Nothing True,
+      transportConfig = TransportClientConfig Nothing Nothing True Nothing,
       bufferSize = defaultHTTP2BufferSize,
       bodyHeadSize = 16384,
       suportedTLSParams = http2TLSParams