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

@@ -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

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')) $

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)

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)

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'