From febf9019e25e3de35f1b005da59e8434e12ae54b Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Tue, 28 Nov 2023 16:12:29 +0200 Subject: [PATCH] remote: add controller address preferences (#905) * remote: add controller address preferences * suppress localhost from breaking multicast discovery w/o prefs * rewrite findCtrlAddress * refactor * refactor2 * add tests --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- src/Simplex/Messaging/Agent.hs | 13 ++--- src/Simplex/RemoteControl/Client.hs | 20 ++++---- src/Simplex/RemoteControl/Discovery.hs | 66 +++++++++++--------------- src/Simplex/RemoteControl/Types.hs | 10 ++++ tests/RemoteControl.hs | 40 +++++++++++++++- 5 files changed, 94 insertions(+), 55 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 6a0701136..ae4819762 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -119,7 +119,7 @@ import qualified Data.Aeson as J import Data.Bifunctor (bimap, first, second) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Composition ((.:), (.:.), (.::)) +import Data.Composition ((.:), (.:.), (.::), (.::.)) import Data.Foldable (foldl') import Data.Functor (($>)) import Data.List (find) @@ -132,6 +132,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock import Data.Time.Clock.System (systemToUTCTime) +import Data.Word (Word16) import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpReceiveFile', xftpSendFile') import Simplex.FileTransfer.Description (ValidFileDescription) import Simplex.FileTransfer.Protocol (FileParty (..)) @@ -392,13 +393,13 @@ 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 :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> m RCHostConnection +rcConnectHost c = withAgentEnv c .::. rcConnectHost' -rcConnectHost' :: AgentMonad m => RCHostPairing -> J.Value -> Bool -> m RCHostConnection -rcConnectHost' pairing ctrlAppInfo multicast = do +rcConnectHost' :: AgentMonad m => RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> m RCHostConnection +rcConnectHost' pairing ctrlAppInfo multicast rcAddr_ port_ = do drg <- asks random - liftError RCP $ connectRCHost drg pairing ctrlAppInfo multicast + liftError RCP $ connectRCHost drg pairing ctrlAppInfo multicast rcAddr_ port_ -- | connect to remote controller via URI rcConnectCtrl :: AgentErrorMonad m => AgentClient -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index 9f2c75463..9d525c344 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -43,6 +43,7 @@ import qualified Data.List.NonEmpty as L import Data.Maybe (isNothing) import qualified Data.Text as T import Data.Time.Clock.System (getSystemTime) +import Data.Word (Word16) import qualified Data.X509 as X509 import Data.X509.Validation (Fingerprint (..), getFingerprint) import Network.Socket (PortNumber, SockAddr (..), hostAddressToTuple) @@ -101,26 +102,29 @@ data RCHClient_ = RCHClient_ endSession :: TMVar () } -type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) +type RCHostConnection = (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) -connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> ExceptT RCErrorType IO RCHostConnection -connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo multicast = do +connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> ExceptT RCErrorType IO RCHostConnection +connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo multicast rcAddrPrefs_ port_ = do r <- newEmptyTMVarIO - host <- getLocalAddress >>= maybe (throwError RCENoLocalAddress) pure + found@(RCCtrlAddress {address} :| _) <- findCtrlAddress 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@RCSignedInvitation {invitation} <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys host) portNum + signedInv@RCSignedInvitation {invitation} <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys address) 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) + pure (found, signedInv, RCHostClient {action, client_ = c}, r) where + findCtrlAddress :: ExceptT RCErrorType IO (NonEmpty RCCtrlAddress) + findCtrlAddress = do + found' <- liftIO $ getLocalAddress rcAddrPrefs_ + maybe (throwError RCENoLocalAddress) pure $ L.nonEmpty found' mkClient :: IO RCHClient_ mkClient = do startedPort <- newEmptyTMVarIO @@ -131,7 +135,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ()) runClient RCHClient_ {startedPort, announcer, hostCAHash, endSession} r hostKeys = do tlsCreds <- liftIO $ genTLSCredentials caKey caCert - startTLSServer startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> + startTLSServer port_ startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> void . runExceptT $ do r' <- newEmptyTMVarIO whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs index ab4400ed3..2155a1fba 100644 --- a/src/Simplex/RemoteControl/Discovery.hs +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -7,21 +7,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} --- XXX: remove non-discovery functions module Simplex.RemoteControl.Discovery where +import Control.Applicative ((<|>)) import Control.Logger.Simple import Control.Monad -import Crypto.Random (getRandomBytes) import Data.ByteString (ByteString) import Data.Default (def) -import Data.Maybe (listToMaybe, mapMaybe) +import Data.List (delete, find) +import Data.Maybe (mapMaybe) import Data.String (IsString) +import qualified Data.Text as T +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 Simplex.Messaging.Encoding (Encoding (..)) import Simplex.Messaging.Transport (supportedParameters) import qualified Simplex.Messaging.Transport as Transport import Simplex.Messaging.Transport.Client (TransportHost (..)) @@ -41,49 +42,36 @@ pattern ANY_ADDR_V4 = "0.0.0.0" pattern DISCOVERY_PORT :: (IsString a, Eq a) => a pattern DISCOVERY_PORT = "5227" -getLocalAddress :: MonadIO m => m (Maybe TransportHost) -getLocalAddress = listToMaybe . mapMaybe usable <$> liftIO getNetworkInterfaces +getLocalAddress :: Maybe RCCtrlAddress -> IO [RCCtrlAddress] +getLocalAddress preferred_ = + maybe id preferAddress preferred_ . mkLastLocalHost . mapMaybe toCtrlAddr <$> getNetworkInterfaces where - usable NetworkInterface {ipv4 = IPv4 ha} = case N.hostAddressToTuple ha of + toCtrlAddr NetworkInterface {name, ipv4 = IPv4 ha} = case N.hostAddressToTuple ha of (0, 0, 0, 0) -> Nothing -- "no" address (255, 255, 255, 255) -> Nothing -- broadcast - (127, _, _, _) -> Nothing -- localhost (169, 254, _, _) -> Nothing -- link-local - ok -> Just $ THIPv4 ok + ok -> Just RCCtrlAddress {address = THIPv4 ok, interface = T.pack name} -getLocalAddressMulticast :: MonadIO m => TMVar Int -> m (Maybe TransportHost) -getLocalAddressMulticast 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 $ THIPv4 (N.hostAddressToTuple host) - (_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket" - timeout 1000000 expect +mkLastLocalHost :: [RCCtrlAddress] -> [RCCtrlAddress] +mkLastLocalHost addrs = case find localHost addrs of + Nothing -> addrs + Just lh -> delete lh addrs <> [lh] + where + localHost RCCtrlAddress {address = a} = a == THIPv4 (127, 0, 0, 1) -mkIpProbe :: MonadIO m => m IpProbe -mkIpProbe = do - randomNonce <- liftIO $ getRandomBytes 32 - pure IpProbe {versionRange = ipProbeVersionRange, randomNonce} +preferAddress :: RCCtrlAddress -> [RCCtrlAddress] -> [RCCtrlAddress] +preferAddress RCCtrlAddress {address, interface} addrs = + case find matchAddr addrs <|> find matchIface addrs of + Nothing -> addrs + Just p -> p : delete p addrs + where + matchAddr RCCtrlAddress {address = a} = a == address + matchIface RCCtrlAddress {interface = i} = i == interface --- | 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: move to RemoteControl.Client -startTLSServer :: MonadUnliftIO m => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> m (Async ()) -startTLSServer startedOnPort credentials hooks server = async . liftIO $ do +startTLSServer :: MonadUnliftIO m => Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> m (Async ()) +startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ do started <- newEmptyTMVarIO - bracketOnError (startTCPServer started "0") (\_e -> setPort Nothing) $ \socket -> + bracketOnError (startTCPServer started $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket -> ifM (atomically $ readTMVar started) (runServer started socket) diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 7f99079b2..e1598f25c 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -14,6 +14,7 @@ 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.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Simplex.Messaging.Crypto as C @@ -23,6 +24,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON) import Simplex.Messaging.Transport (TLS) +import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util (safeDecodeUtf8) import Simplex.Messaging.Version (Version, VersionRange, mkVersionRange) import UnliftIO @@ -134,6 +136,12 @@ data KnownHostPairing = KnownHostPairing hostDhPubKey :: C.PublicKeyX25519 } +data RCCtrlAddress = RCCtrlAddress + { address :: TransportHost, -- allows any interface when found exactly + interface :: Text + } + deriving (Show, Eq) + -- | Long-term part of host (mobile) connection to controller (desktop) data RCCtrlPairing = RCCtrlPairing { caKey :: C.APrivateSignKey, @@ -226,3 +234,5 @@ cancelTasks :: MonadIO m => Tasks -> m () cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RCErrorType) + +$(JQ.deriveJSON defaultJSON ''RCCtrlAddress) diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index d70fbc7e7..ffea63785 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,7 +10,9 @@ import Control.Logger.Simple import Crypto.Random (ChaChaDRG, drgNew) import qualified Data.Aeson as J import Data.List.NonEmpty (NonEmpty (..)) +import Simplex.Messaging.Encoding.String (StrEncoding (..)) import qualified Simplex.RemoteControl.Client as RC +import Simplex.RemoteControl.Discovery (mkLastLocalHost, preferAddress) import Simplex.RemoteControl.Invitation (RCSignedInvitation, verifySignedInvitation) import Simplex.RemoteControl.Types import Test.Hspec @@ -18,12 +21,45 @@ import UnliftIO.Concurrent remoteControlTests :: Spec remoteControlTests = do + describe "preferred bindings should go first" testPreferAddress 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 +testPreferAddress :: Spec +testPreferAddress = do + it "suppresses localhost" $ + mkLastLocalHost addrs + `shouldBe` [ "10.20.30.40" @ "eth0", + "10.20.30.42" @ "wlan0", + "127.0.0.1" @ "lo" + ] + it "finds by address" $ do + preferAddress ("127.0.0.1" @ "lo23") addrs' `shouldBe` addrs -- localhost is back on top + preferAddress ("10.20.30.42" @ "wlp2s0") addrs' + `shouldBe` [ "10.20.30.42" @ "wlan0", + "10.20.30.40" @ "eth0", + "127.0.0.1" @ "lo" + ] + it "finds by interface" $ do + preferAddress ("127.1.2.3" @ "lo") addrs' `shouldBe` addrs + preferAddress ("0.0.0.0" @ "eth0") addrs' `shouldBe` addrs' + it "survives duplicates" $ do + preferAddress ("0.0.0.0" @ "eth1") addrsDups `shouldBe` addrsDups + preferAddress ("0.0.0.0" @ "eth0") ifaceDups `shouldBe` ifaceDups + where + th @ interface = RCCtrlAddress {address = either error id $ strDecode th, interface} + addrs = + [ "127.0.0.1" @ "lo", -- localhost may go first and break things + "10.20.30.40" @ "eth0", + "10.20.30.42" @ "wlan0" + ] + addrs' = mkLastLocalHost addrs + addrsDups = "10.20.30.40" @ "eth1" : addrs' + ifaceDups = "10.20.30.41" @ "eth0" : addrs' + testNewPairing :: IO () testNewPairing = do drg <- drgNew >>= newTVarIO @@ -31,7 +67,7 @@ testNewPairing = do invVar <- newEmptyMVar ctrlSessId <- async . runRight $ do logNote "c 1" - (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") False + (_found, inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") False Nothing Nothing logNote "c 2" putMVar invVar (inv, hc) logNote "c 3" @@ -123,7 +159,7 @@ testMulticast = do 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 + (_found, inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") multicast Nothing Nothing putMVar invVar inv Right (_sessId, _tls, r') <- atomically $ takeTMVar r Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r'