From 40ba94ce72fb4273641c56fd4c60cd133a24925a Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Fri, 17 Nov 2023 19:56:14 +0200 Subject: [PATCH] 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> --- rfcs/2023-10-25-remote-control.md | 42 +-------- src/Simplex/Messaging/Agent.hs | 31 +++---- src/Simplex/Messaging/Agent/Env/SQLite.hs | 6 +- src/Simplex/Messaging/Util.hs | 5 +- src/Simplex/RemoteControl/Client.hs | 106 ++++++++++++++-------- src/Simplex/RemoteControl/Invitation.hs | 51 +++++------ src/Simplex/RemoteControl/Types.hs | 9 ++ tests/RemoteControl.hs | 96 ++++++++++++++------ 8 files changed, 195 insertions(+), 151 deletions(-) diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/2023-10-25-remote-control.md index 097377322..444185307 100644 --- a/rfcs/2023-10-25-remote-control.md +++ b/rfcs/2023-10-25-remote-control.md @@ -86,52 +86,16 @@ base64url = ; 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 = ; 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. diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index e3b1bccf4..6a0701136 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 () diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index cbdae289c..6f2347391 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -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 diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 2dca0956a..373a19172 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -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 () diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index efbda4998..9f2c75463 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -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 diff --git a/src/Simplex/RemoteControl/Invitation.hs b/src/Simplex/RemoteControl/Invitation.hs index 224417ea0..f5deac9a8 100644 --- a/src/Simplex/RemoteControl/Invitation.hs +++ b/src/Simplex/RemoteControl/Invitation.hs @@ -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) diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 78e7d8956..7f99079b2 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -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 diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index efd7a42b4..d70fbc7e7 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -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'