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/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)