Network: automatically find broadcast addresses

5 files changed, 113 insertions, 27 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 73c395a..fd1db20 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -83,7 +83,9 @@ executable erebos
   hs-source-dirs:      src
   default-language:    Haskell2010
   c-sources:           src/ICE/pjproject.c
+                       src/Network/ifaddrs.c
   includes:            src/ICE/pjproject.h
   include-dirs:        src/ICE
+                       src
   build-tools:         c2hs
   pkgconfig-depends:   libpjproject >= 2.9
diff --git a/src/Main.hs b/src/Main.hs
index 54c5714..8d6f8de 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -22,6 +22,7 @@ import Data.Typeable
 
 import Network.Socket
 
+import System.Console.GetOpt
 import System.Console.Haskeline
 import System.Environment
 
@@ -39,6 +40,26 @@ import Storage
 import Storage.Merge
 import Sync
 
+data Options = Options
+    { optServer :: ServerOptions
+    }
+
+defaultOptions :: Options
+defaultOptions = Options
+    { optServer = defaultServerOptions
+    }
+
+options :: [OptDescr (Options -> Options)]
+options =
+    [ Option ['p'] ["port"]
+        (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "PORT")
+        "local port to bind"
+    , Option ['s'] ["silent"]
+        (NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))
+        "do not send announce packets for local discovery"
+    ]
+    where so f opts = opts { optServer = f $ optServer opts }
+
 main :: IO ()
 main = do
     st <- liftIO $ openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR"
@@ -88,12 +109,16 @@ main = do
                         BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< interactiveIdentityUpdate idt
                     | otherwise -> error "invalid identity"
 
-        [bhost] -> interactiveLoop st (Just bhost)
-        []      -> interactiveLoop st Nothing
-        _       -> error "Unrecognized options"
+        args -> do
+            opts <- case getOpt Permute options args of
+                (o, [], []) -> return (foldl (flip id) defaultOptions o)
+                (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
+                    where header = "Usage: erebos [OPTION...]"
+            interactiveLoop st opts
 
-interactiveLoop :: Storage -> Maybe String -> IO ()
-interactiveLoop st bhost = runInputT defaultSettings $ do
+
+interactiveLoop :: Storage -> Options -> IO ()
+interactiveLoop st opts = runInputT defaultSettings $ do
     erebosHead <- liftIO $ loadLocalStateHead st
     outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
 
@@ -103,10 +128,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
     let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str
                                                         _ -> str ++ "\n";
     server <- liftIO $ do
-        let sopt = defaultServerOptions
-                { serverLocalDiscovery = bhost
-                }
-        startServer sopt erebosHead extPrintLn
+        startServer (optServer opts) erebosHead extPrintLn
             [ SomeService @AttachService Proxy
             , SomeService @SyncService Proxy
             , SomeService @ContactService Proxy
@@ -312,8 +334,8 @@ cmdDiscoveryInit = void $ do
 
     (hostname, port) <- (words <$> asks ciLine) >>= return . \case
         hostname:p:_ -> (hostname, p)
-        [hostname] -> (hostname, discoveryPort)
-        [] -> ("discovery.erebosprotocol.net", discoveryPort)
+        [hostname] -> (hostname, show discoveryPort)
+        [] -> ("discovery.erebosprotocol.net", show discoveryPort)
     addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
     peer <- liftIO $ serverPeer server (addrAddress addr)
     sendToPeer self peer $ DiscoverySelf (T.pack "ICE") 0
diff --git a/src/Network.hs b/src/Network.hs
index f857ef9..1edc70c 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -31,6 +31,10 @@ import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Typeable
+import Data.Word
+
+import Foreign.Ptr
+import Foreign.Storable
 
 import GHC.Conc.Sync (unsafeIOToSTM)
 
@@ -48,8 +52,8 @@ import Storage.Merge
 import Sync
 
 
-discoveryPort :: ServiceName
-discoveryPort = "29665"
+discoveryPort :: PortNumber
+discoveryPort = 29665
 
 announceIntervalSeconds :: Int
 announceIntervalSeconds = 60
@@ -72,12 +76,14 @@ getNextPeerChange :: Server -> IO Peer
 getNextPeerChange = atomically . readTChan . serverChanPeer
 
 data ServerOptions = ServerOptions
-    { serverLocalDiscovery :: Maybe String
+    { serverPort :: PortNumber
+    , serverLocalDiscovery :: Bool
     }
 
 defaultServerOptions :: ServerOptions
 defaultServerOptions = ServerOptions
-    { serverLocalDiscovery = Nothing
+    { serverPort = discoveryPort
+    , serverLocalDiscovery = True
     }
 
 
@@ -245,6 +251,8 @@ startServer opt origHead logd' services = do
         either (atomically . logd) return =<< runExceptT =<<
             atomically (readTQueue $ serverIOActions server)
 
+    broadcastAddreses <- getBroadcastAddresses discoveryPort
+
     let open addr = do
             sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
             putMVar ssocket sock
@@ -255,15 +263,12 @@ startServer opt origHead logd' services = do
             return sock
 
         loop sock = do
-            case serverLocalDiscovery opt of
-                Just bhost -> do
-                    void $ forkIO $ forever $ do
-                        readMVar midentity >>= \identity -> do
-                            st <- derivePartialStorage storage
-                            baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
-                            void $ S.sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ TransportHeader [ AnnounceSelf $ partialRef st $ storedRef $ idData identity ]) (addrAddress baddr)
-                        threadDelay $ announceIntervalSeconds * 1000 * 1000
-                Nothing -> return ()
+            when (serverLocalDiscovery opt) $ void $ forkIO $ forever $ do
+                readMVar midentity >>= \identity -> do
+                    st <- derivePartialStorage storage
+                    let packet = BL.toStrict $ serializeObject $ transportToObject $ TransportHeader [ AnnounceSelf $ partialRef st $ storedRef $ idData identity ]
+                    mapM_ (void . S.sendTo sock packet) broadcastAddreses
+                threadDelay $ announceIntervalSeconds * 1000 * 1000
 
             let announceUpdate identity = do
                     st <- derivePartialStorage storage
@@ -344,9 +349,7 @@ startServer opt origHead logd' services = do
               { addrFlags = [AI_PASSIVE]
               , addrSocketType = Datagram
               }
-        addr:_ <- getAddrInfo (Just hints) Nothing
-            -- use ephemeral port when local discovery is disabled
-            (Just $ if isJust (serverLocalDiscovery opt) then discoveryPort else "0")
+        addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort opt)
         bracket (open addr) close loop
 
     void $ forkIO $ forever $ do
@@ -797,3 +800,18 @@ sendToPeerWith identity peer fobj = do
          Right (Just obj) -> sendToPeer identity peer obj
          Right Nothing -> return ()
          Left err -> throwError err
+
+
+foreign import ccall unsafe "Network/ifaddrs.h broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32)
+foreign import ccall unsafe "stdlib.h free" cFree :: Ptr Word32 -> IO ()
+
+getBroadcastAddresses :: PortNumber -> IO [SockAddr]
+getBroadcastAddresses port = do
+    ptr <- cBroadcastAddresses
+    let parse i = do
+            w <- peekElemOff ptr i
+            if w == 0 then return []
+                      else (SockAddrInet port w:) <$> parse (i + 1)
+    addrs <- parse 0
+    cFree ptr
+    return addrs
diff --git a/src/Network/ifaddrs.c b/src/Network/ifaddrs.c
new file mode 100644
index 0000000..37c3e00
--- /dev/null
+++ b/src/Network/ifaddrs.c
@@ -0,0 +1,41 @@
+#include "ifaddrs.h"
+
+#include <arpa/inet.h>
+#include <ifaddrs.h>
+#include <net/if.h>
+#include <stdlib.h>
+#include <sys/types.h>
+#include <endian.h>
+
+uint32_t * broadcast_addresses(void)
+{
+	struct ifaddrs * addrs;
+	if (getifaddrs(&addrs) < 0)
+		return 0;
+
+	size_t capacity = 16, count = 0;
+	uint32_t * ret = malloc(sizeof(uint32_t) * capacity);
+
+	for (struct ifaddrs * ifa = addrs; ifa; ifa = ifa->ifa_next) {
+		if (ifa->ifa_addr && ifa->ifa_addr->sa_family == AF_INET &&
+				ifa->ifa_flags & IFF_BROADCAST) {
+			if (count + 2 >= capacity) {
+				capacity *= 2;
+				uint32_t * nret = realloc(ret, sizeof(uint32_t) * capacity);
+				if (nret) {
+					ret = nret;
+				} else {
+					free(ret);
+					return 0;
+				}
+			}
+
+			ret[count] = ((struct sockaddr_in*)ifa->ifa_broadaddr)->sin_addr.s_addr;
+			count++;
+		}
+	}
+
+	freeifaddrs(addrs);
+	ret[count] = 0;
+	return ret;
+}
diff --git a/src/Network/ifaddrs.h b/src/Network/ifaddrs.h
new file mode 100644
index 0000000..06d26ec
--- /dev/null
+++ b/src/Network/ifaddrs.h
@@ -0,0 +1,3 @@
+#include <stdint.h>
+
+uint32_t * broadcast_addresses(void);