use multicast address for announce (#3241)

* use multicast address for announce

* Add explicit multicast group membership

* join multicast group on a correct side

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

simplex-chat.cabal

@@ -128,6 +128,7 @@ library
       Simplex.Chat.Protocol
       Simplex.Chat.Remote
       Simplex.Chat.Remote.Discovery
+      Simplex.Chat.Remote.Multicast
       Simplex.Chat.Remote.Protocol
       Simplex.Chat.Remote.Types
       Simplex.Chat.Store

src/Simplex/Chat/Remote/Discovery.hs

@@ -29,6 +29,7 @@ import Data.String (IsString)
 import qualified Network.Socket as N
 import qualified Network.TLS as TLS
 import qualified Network.UDP as UDP
+import Simplex.Chat.Remote.Multicast (setMembership)
 import Simplex.Chat.Remote.Types (Tasks, registerAsync)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
@@ -43,15 +44,15 @@ import Simplex.Messaging.Util (ifM, tshow, whenM)
 import UnliftIO
 import UnliftIO.Concurrent
 
--- | Link-local broadcast address.
-pattern BROADCAST_ADDR_V4 :: (IsString a, Eq a) => a
-pattern BROADCAST_ADDR_V4 = "0.0.0.0"
+-- | mDNS multicast group
+pattern MULTICAST_ADDR_V4 :: (IsString a, Eq a) => a
+pattern MULTICAST_ADDR_V4 = "224.0.0.251"
 
 pattern ANY_ADDR_V4 :: (IsString a, Eq a) => a
 pattern ANY_ADDR_V4 = "0.0.0.0"
 
-pattern BROADCAST_PORT :: (IsString a, Eq a) => a
-pattern BROADCAST_PORT = "5226"
+pattern DISCOVERY_PORT :: (IsString a, Eq a) => a
+pattern DISCOVERY_PORT = "5226"
 
 -- | Announce tls server, wait for connection and attach http2 client to it.
 --
@@ -88,16 +89,17 @@ announceRevHTTP2 tasks invite credentials finishAction = do
 -- | Broadcast invite with link-local datagrams
 runAnnouncer :: ByteString -> IO ()
 runAnnouncer inviteBS = do
-  bracket (UDP.clientSocket BROADCAST_ADDR_V4 BROADCAST_PORT False) UDP.close $ \sock -> do
-    N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1
-    N.setSocketOption (UDP.udpSocket sock) N.ReuseAddr 1
+  bracket (UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) UDP.close $ \sock -> do
+    let raw = UDP.udpSocket sock
+    N.setSocketOption raw N.Broadcast 1
+    N.setSocketOption raw N.ReuseAddr 1
     forever $ do
       UDP.send sock inviteBS
       threadDelay 1000000
 
 -- XXX: Do we need to start multiple TLS servers for different mobile hosts?
 startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
-startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig
+startTLSServer started credentials = async . liftIO . runTransportServer started DISCOVERY_PORT serverParams defaultTransportServerConfig
   where
     serverParams =
       def
@@ -115,21 +117,34 @@ runHTTP2Client finishedVar clientVar tls =
     (logError "HTTP2 session already started on this listener")
   where
     attachClient = do
-      client <- attachHTTP2Client config ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls
+      client <- attachHTTP2Client config ANY_ADDR_V4 DISCOVERY_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls
       putMVar clientVar client
       readMVar finishedVar
     -- TODO connection timeout
     config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}
 
 withListener :: (MonadUnliftIO m) => (UDP.ListenSocket -> m a) -> m a
-withListener = bracket openListener (liftIO . UDP.stop)
+withListener = bracket openListener closeListener
 
 openListener :: (MonadIO m) => m UDP.ListenSocket
 openListener = liftIO $ do
-  sock <- UDP.serverSocket (ANY_ADDR_V4, read BROADCAST_PORT)
-  N.setSocketOption (UDP.listenSocket sock) N.Broadcast 1
+  sock <- UDP.serverSocket (MULTICAST_ADDR_V4, read DISCOVERY_PORT)
+  logDebug $ "Discovery listener socket: " <> tshow sock
+  let raw = UDP.listenSocket sock
+  N.setSocketOption raw N.Broadcast 1
+  void $ setMembership raw (listenerHostAddr4 sock) True
   pure sock
 
+closeListener :: MonadIO m => UDP.ListenSocket -> m ()
+closeListener sock = liftIO $ do
+  UDP.stop sock
+  void $ setMembership (UDP.listenSocket sock) (listenerHostAddr4 sock) False
+
+listenerHostAddr4 :: UDP.ListenSocket -> N.HostAddress
+listenerHostAddr4 sock = case UDP.mySockAddr sock of
+  N.SockAddrInet _port host -> host
+  _ -> error "MULTICAST_ADDR_V4 is V4"
+
 recvAnnounce :: (MonadIO m) => UDP.ListenSocket -> m (N.SockAddr, ByteString)
 recvAnnounce sock = liftIO $ do
   (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
@@ -139,7 +154,7 @@ connectRevHTTP2 :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (HTTP2Requ
 connectRevHTTP2 host fingerprint = connectTLSClient host fingerprint . attachHTTP2Server
 
 connectTLSClient :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a
-connectTLSClient host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host BROADCAST_PORT (Just caFingerprint)
+connectTLSClient host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host DISCOVERY_PORT (Just caFingerprint)
 
 attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
 attachHTTP2Server processRequest tls = do

src/Simplex/Chat/Remote/Multicast.hsc

@@ -0,0 +1,43 @@
+module Simplex.Chat.Remote.Multicast (setMembership) where
+
+import Foreign (Ptr, allocaBytes, castPtr, pokeByteOff)
+import Foreign.C.Types (CInt (..))
+import Network.Socket
+
+#include <HsNet.h>
+
+{- | Toggle multicast group membership.
+
+NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
+-}
+setMembership :: Socket -> HostAddress -> Bool -> IO Bool
+setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
+  #{poke struct ip_mreq, imr_multiaddr} mReqPtr group
+  #{poke struct ip_mreq, imr_interface} mReqPtr (0 :: HostAddress) -- attempt to contact the group on ANY interface
+  withFdSocket sock $ \fd ->
+    (/= 0) <$> c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq})
+  where
+    flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP
+
+#ifdef mingw32_HOST_OS
+
+foreign import stdcall unsafe "setsockopt"
+    c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
+
+c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt
+c_IP_ADD_MEMBERSHIP  = 12
+c_IP_DROP_MEMBERSHIP = 13
+
+#else
+
+foreign import ccall unsafe "setsockopt"
+    c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
+
+c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt
+c_IP_ADD_MEMBERSHIP  = #const IP_ADD_MEMBERSHIP
+c_IP_DROP_MEMBERSHIP = #const IP_DROP_MEMBERSHIP
+
+#endif
+
+c_IPPROTO_IP :: CInt
+c_IPPROTO_IP = #const IPPROTO_IP