From ecb23c66e007cef40e3eb3194e130a3458e6fd57 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Tue, 7 Nov 2023 22:30:28 +0200 Subject: [PATCH] Extract public RC types (#887) --- src/Simplex/Messaging/Agent.hs | 1 + src/Simplex/RemoteControl/Client.hs | 129 +------------------- src/Simplex/RemoteControl/Discovery.hs | 65 +--------- src/Simplex/RemoteControl/Types.hs | 160 ++++++++++++++++++------- 4 files changed, 121 insertions(+), 234 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 9e0b140f2..195c93833 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -163,6 +163,7 @@ import Simplex.Messaging.Util import Simplex.Messaging.Version import Simplex.RemoteControl.Client import Simplex.RemoteControl.Invitation +import Simplex.RemoteControl.Types import UnliftIO.Async (async, race_) import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay) import UnliftIO.STM diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index a58283b3e..dd7142c9b 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -5,25 +5,16 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.RemoteControl.Client - ( RCHostPairing (..), - RCHostClient (action), - RCHostSession (..), - RCHostHello (..), - HostSessKeys (..), + ( RCHostClient (action), RCHostConnection, - SessionCode, newRCHostPairing, connectRCHost, cancelHostClient, - RCCtrlPairing (..), RCCtrlClient (action), - RCCtrlSession (..), - CtrlSessKeys (..), RCCtrlConnection, connectRCCtrlURI, connectKnownRCCtrlMulticast, @@ -40,7 +31,6 @@ import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) 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 import qualified Data.ByteString.Lazy as LB @@ -59,7 +49,6 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.SNTRUP761 import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding -import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Transport (TLS (tlsUniq), cGet, cPut) import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost, defaultTransportClientConfig, runTransportClient) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) @@ -83,21 +72,6 @@ xrcpBlockSize = 16384 helloBlockSize :: Int helloBlockSize = 12288 -data RCHostHello = RCHostHello - { v :: Version, - ca :: C.KeyHash, - app :: J.Value, - kem :: KEMPublicKey - } - deriving (Show) - -$(JQ.deriveJSON defaultJSON ''RCHostHello) - -data RCCtrlHello = RCCtrlHello {} - deriving (Show) - -$(JQ.deriveJSON defaultJSON {J.nullaryToObject = True} ''RCCtrlHello) - newRCHostPairing :: IO RCHostPairing newRCHostPairing = do ((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca" @@ -116,13 +90,8 @@ data RCHClient_ = RCHClient_ tlsEnded :: TMVar (Either RCErrorType ()) } --- tlsunique channel binding -type SessionCode = ByteString - type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) -type RCStepTMVar a = TMVar (Either RCErrorType a) - connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> ExceptT RCErrorType IO RCHostConnection connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo = do r <- newEmptyTMVarIO @@ -430,99 +399,3 @@ cancelCtrlClient :: RCCtrlClient -> IO () cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do atomically $ putTMVar endSession () uninterruptibleCancel action - --- | Long-term part of controller (desktop) connection to host (mobile) -data RCHostPairing = RCHostPairing - { caKey :: C.APrivateSignKey, - caCert :: C.SignedCertificate, - idPrivKey :: C.PrivateKeyEd25519, - knownHost :: Maybe KnownHostPairing - } - -data KnownHostPairing = KnownHostPairing - { hostFingerprint :: C.KeyHash, -- this is only changed in the first session, long-term identity of connected remote host - storedSessKeys :: StoredHostSessKeys - } - -data StoredHostSessKeys = StoredHostSessKeys - { hostDHPublicKey :: C.PublicKeyX25519, -- sent by host in HELLO block. Matches one of the DH keys in RCCtrlPairing - kemSharedKey :: KEMSharedKey - } - --- | Long-term part of host (mobile) connection to controller (desktop) -data RCCtrlPairing = RCCtrlPairing - { caKey :: C.APrivateSignKey, - caCert :: C.SignedCertificate, - ctrlFingerprint :: C.KeyHash, -- long-term identity of connected remote controller - idPubKey :: C.PublicKeyEd25519, - storedSessKeys :: StoredCtrlSessKeys, - prevStoredSessKeys :: Maybe StoredCtrlSessKeys - } - -data StoredCtrlSessKeys = StoredCtrlSessKeys - { dhPrivKey :: C.PrivateKeyX25519, - kemSharedKey :: Maybe KEMSharedKey -- this is Nothing only for a new pairing, and once connected it is always Just. - } - -data RCHostKeys = RCHostKeys - { sessKeys :: C.KeyPair 'C.Ed25519, - dhKeys :: C.KeyPair 'C.X25519 - } - --- Connected session with Host -data RCHostSession = RCHostSession - { tls :: TLS, - sessionKeys :: HostSessKeys - } - -data HostSessKeys = HostSessKeys - { hybridKey :: KEMHybridSecret, - idPrivKey :: C.PrivateKeyEd25519, - sessPrivKey :: C.PrivateKeyEd25519 - } - --- Host: RCCtrlPairing + RCInvitation => (RCCtrlSession, RCCtrlPairing) - -data RCCtrlSession = RCCtrlSession - { tls :: TLS, - sessionKeys :: CtrlSessKeys - } - -data CtrlSessKeys = CtrlSessKeys - { hybridKey :: KEMHybridSecret, - idPubKey :: C.PublicKeyEd25519, - sessPubKey :: C.PublicKeyEd25519 - } - -data RCHostEncHello = RCHostEncHello - { dhPubKey :: C.PublicKeyX25519, - nonce :: C.CbNonce, - encBody :: ByteString - } - deriving (Show) - -instance Encoding RCHostEncHello where - smpEncode RCHostEncHello {dhPubKey, nonce, encBody} = - "HELLO " <> smpEncode (dhPubKey, nonce, Tail encBody) - smpP = do - (dhPubKey, nonce, Tail encBody) <- "HELLO " *> smpP - pure RCHostEncHello {dhPubKey, nonce, encBody} - -data RCCtrlEncHello - = RCCtrlEncHello {kem :: KEMCiphertext, nonce :: C.CbNonce, encBody :: ByteString} - | RCCtrlEncError {nonce :: C.CbNonce, encMessage :: ByteString} - deriving (Show) - -instance Encoding RCCtrlEncHello where - smpEncode = \case - RCCtrlEncHello {kem, nonce, encBody} -> "HELLO " <> smpEncode (kem, nonce, Tail encBody) - RCCtrlEncError {nonce, encMessage} -> "ERROR " <> smpEncode (nonce, Tail encMessage) - smpP = - A.takeTill (== ' ') >>= \case - "HELLO" -> do - (kem, nonce, Tail encBody) <- _smpP - pure RCCtrlEncHello {kem, nonce, encBody} - "ERROR" -> do - (nonce, Tail encMessage) <- _smpP - pure RCCtrlEncError {nonce, encMessage} - _ -> fail "bad RCCtrlEncHello" diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs index 7e1f992f4..ab4400ed3 100644 --- a/src/Simplex/RemoteControl/Discovery.hs +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -17,26 +17,19 @@ import Data.ByteString (ByteString) import Data.Default (def) import Data.Maybe (listToMaybe, mapMaybe) import Data.String (IsString) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) -import Data.Word (Word16) import Network.Info (IPv4 (..), NetworkInterface (..), getNetworkInterfaces) import qualified Network.Socket as N import qualified Network.TLS as TLS import qualified Network.UDP as UDP -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.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer) import Simplex.Messaging.Util (ifM, tshow) -import Simplex.Messaging.Version (VersionRange) import Simplex.RemoteControl.Discovery.Multicast (setMembership) import Simplex.RemoteControl.Types import UnliftIO -import UnliftIO.Concurrent -- | mDNS multicast group pattern MULTICAST_ADDR_V4 :: (IsString a, Eq a) => a @@ -77,50 +70,6 @@ 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 rc -> MVar () -> Transport.TLS -> IO ()) -> - Tasks -> - TMVar (Maybe N.PortNumber) -> - Maybe (Text, VersionRange) -> - Maybe Text -> - C.PrivateKeyEd25519 -> - CtrlSessionKeys -> - -- | Session address to announce - TransportHost -> - m () -> - m rc -announceCtrl runCtrl tasks started app_ device_ idkey sk@CtrlSessionKeys {ca, credentials} host finishAction = do - ctrlStarted <- newEmptyMVar - ctrlFinished <- newEmptyMVar - _ <- forkIO $ readMVar ctrlFinished >> finishAction -- attach external cleanup action to session lock - announcer <- - async . liftIO $ - atomically (readTMVar started) >>= \case - Nothing -> pure () -- TLS server failed to start, skipping announcer - Just givenPort -> do - logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort) - runAnnouncer app_ device_ idkey sk (host, givenPort) -- (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)}) - tasks `registerAsync` announcer - let hooks = undefined -- TODO - tlsServer <- startTLSServer started credentials hooks $ \tls -> do - logInfo $ "Incoming connection for " <> ident - cancel announcer - runCtrl ctrlStarted ctrlFinished 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 ca - -runAnnouncer :: Maybe (Text, VersionRange) -> Maybe Text -> C.PrivateKeyEd25519 -> CtrlSessionKeys -> (TransportHost, N.PortNumber) -> IO () -runAnnouncer app_ device_ idSigKey sk (host, port) = error "runAnnouncer: make invites, encrypt and send" - -- | Send replay-proof announce datagrams -- runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO () -- runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce @@ -199,15 +148,3 @@ 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) -> - HostSessionKeys -> - (HostCryptoHandle -> Transport.TLS -> m a) -> - m a -connectTLSClient (host, port) HostSessionKeys {ca} client = - runTransportClient defaultTransportClientConfig Nothing host (show port) (Just ca) $ \tls -> do - -- TODO: set up host side using - let hch = HostCryptoHandle - client hch tls diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 757119950..7d7db0d3b 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -10,23 +10,21 @@ module Simplex.RemoteControl.Types where -import Crypto.Random (ChaChaDRG) -import qualified Data.Aeson.TH as J +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 Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Time.Clock.System (SystemTime, getSystemTime) -import qualified Network.TLS as TLS import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.SNTRUP761.Bindings (KEMPublicKey, KEMSecretKey, sntrup761Keypair) +import Simplex.Messaging.Crypto.SNTRUP761 +import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) -import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON) +import Simplex.Messaging.Transport (TLS) import Simplex.Messaging.Util (safeDecodeUtf8) -import Simplex.Messaging.Version (VersionRange, mkVersionRange) +import Simplex.Messaging.Version (Version, VersionRange, mkVersionRange) import UnliftIO data RCErrorType @@ -94,48 +92,126 @@ instance Encoding IpProbe where smpP = IpProbe <$> (smpP <* "I") *> smpP --- * Controller +-- * Session --- | A bunch of keys that should be generated by a controller to start a new remote session and produce invites -data CtrlSessionKeys = CtrlSessionKeys - { ts :: SystemTime, +data RCHostHello = RCHostHello + { v :: Version, ca :: C.KeyHash, - credentials :: TLS.Credentials, - sSigKey :: C.PrivateKeyEd25519, - dhKey :: C.PrivateKeyX25519, - kem :: (KEMPublicKey, KEMSecretKey) + app :: J.Value, + kem :: KEMPublicKey + } + deriving (Show) + +$(JQ.deriveJSON defaultJSON ''RCHostHello) + +data RCCtrlHello = RCCtrlHello {} + deriving (Show) + +$(JQ.deriveJSON defaultJSON {J.nullaryToObject = True} ''RCCtrlHello) + +-- | Long-term part of controller (desktop) connection to host (mobile) +data RCHostPairing = RCHostPairing + { caKey :: C.APrivateSignKey, + caCert :: C.SignedCertificate, + idPrivKey :: C.PrivateKeyEd25519, + knownHost :: Maybe KnownHostPairing } -newCtrlSessionKeys :: TVar ChaChaDRG -> (C.APrivateSignKey, C.SignedCertificate) -> IO CtrlSessionKeys -newCtrlSessionKeys rng (caKey, caCert) = do - ts <- getSystemTime - (_, C.APrivateDhKey C.SX25519 dhKey) <- C.generateDhKeyPair C.SX25519 - (_, C.APrivateSignKey C.SEd25519 sSigKey) <- C.generateSignatureKeyPair C.SEd25519 - - let parent = (C.signatureKeyPair caKey, caCert) - sessionCreds <- genCredentials (Just parent) (0, 24) "Session" - let (ca, credentials) = tlsCredentials $ sessionCreds :| [parent] - kem <- sntrup761Keypair rng - - pure CtrlSessionKeys {ts, ca, credentials, sSigKey, dhKey, kem} - -data CtrlCryptoHandle = CtrlCryptoHandle - --- TODO - --- * Host - -data HostSessionKeys = HostSessionKeys - { ca :: C.KeyHash - -- TODO +data KnownHostPairing = KnownHostPairing + { hostFingerprint :: C.KeyHash, -- this is only changed in the first session, long-term identity of connected remote host + storedSessKeys :: StoredHostSessKeys } -data HostCryptoHandle = HostCryptoHandle +data StoredHostSessKeys = StoredHostSessKeys + { hostDHPublicKey :: C.PublicKeyX25519, -- sent by host in HELLO block. Matches one of the DH keys in RCCtrlPairing + kemSharedKey :: KEMSharedKey + } --- TODO +-- | Long-term part of host (mobile) connection to controller (desktop) +data RCCtrlPairing = RCCtrlPairing + { caKey :: C.APrivateSignKey, + caCert :: C.SignedCertificate, + ctrlFingerprint :: C.KeyHash, -- long-term identity of connected remote controller + idPubKey :: C.PublicKeyEd25519, + storedSessKeys :: StoredCtrlSessKeys, + prevStoredSessKeys :: Maybe StoredCtrlSessKeys + } + +data StoredCtrlSessKeys = StoredCtrlSessKeys + { dhPrivKey :: C.PrivateKeyX25519, + kemSharedKey :: Maybe KEMSharedKey -- this is Nothing only for a new pairing, and once connected it is always Just. + } + +data RCHostKeys = RCHostKeys + { sessKeys :: C.KeyPair 'C.Ed25519, + dhKeys :: C.KeyPair 'C.X25519 + } + +-- Connected session with Host +data RCHostSession = RCHostSession + { tls :: TLS, + sessionKeys :: HostSessKeys + } + +data HostSessKeys = HostSessKeys + { hybridKey :: KEMHybridSecret, + idPrivKey :: C.PrivateKeyEd25519, + sessPrivKey :: C.PrivateKeyEd25519 + } + +-- Host: RCCtrlPairing + RCInvitation => (RCCtrlSession, RCCtrlPairing) + +data RCCtrlSession = RCCtrlSession + { tls :: TLS, + sessionKeys :: CtrlSessKeys + } + +data CtrlSessKeys = CtrlSessKeys + { hybridKey :: KEMHybridSecret, + idPubKey :: C.PublicKeyEd25519, + sessPubKey :: C.PublicKeyEd25519 + } + +data RCHostEncHello = RCHostEncHello + { dhPubKey :: C.PublicKeyX25519, + nonce :: C.CbNonce, + encBody :: ByteString + } + deriving (Show) + +instance Encoding RCHostEncHello where + smpEncode RCHostEncHello {dhPubKey, nonce, encBody} = + "HELLO " <> smpEncode (dhPubKey, nonce, Tail encBody) + smpP = do + (dhPubKey, nonce, Tail encBody) <- "HELLO " *> smpP + pure RCHostEncHello {dhPubKey, nonce, encBody} + +data RCCtrlEncHello + = RCCtrlEncHello {kem :: KEMCiphertext, nonce :: C.CbNonce, encBody :: ByteString} + | RCCtrlEncError {nonce :: C.CbNonce, encMessage :: ByteString} + deriving (Show) + +instance Encoding RCCtrlEncHello where + smpEncode = \case + RCCtrlEncHello {kem, nonce, encBody} -> "HELLO " <> smpEncode (kem, nonce, Tail encBody) + RCCtrlEncError {nonce, encMessage} -> "ERROR " <> smpEncode (nonce, Tail encMessage) + smpP = + A.takeTill (== ' ') >>= \case + "HELLO" -> do + (kem, nonce, Tail encBody) <- _smpP + pure RCCtrlEncHello {kem, nonce, encBody} + "ERROR" -> do + (nonce, Tail encMessage) <- _smpP + pure RCCtrlEncError {nonce, encMessage} + _ -> fail "bad RCCtrlEncHello" -- * Utils +-- | tlsunique channel binding +type SessionCode = ByteString + +type RCStepTMVar a = TMVar (Either RCErrorType a) + type Tasks = TVar [Async ()] asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m () @@ -147,4 +223,4 @@ registerAsync tasks = atomically . modifyTVar tasks . (:) cancelTasks :: MonadIO m => Tasks -> m () cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel -$(J.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RCErrorType) +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RCErrorType)