From ef8bab8568b5263797d5534202ac192839663ce7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 22 Aug 2026 15:39:40 +0200 Subject: Discovery on localhost Changelog: Discovery is now working also on localhost without need for external interface. --- src/Erebos/Discovery.hs | 77 ++++++++++++++++++++++++++++++++----------- src/Erebos/Network/Address.hs | 10 ++++++ 2 files changed, 68 insertions(+), 19 deletions(-) (limited to 'src/Erebos') diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 9f25b37..da55dc3 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -60,7 +60,8 @@ data DiscoveryService | DiscoveryConnectionResponse DiscoveryConnection data DiscoveryAddress - = DiscoveryIP InetAddress PortNumber + = DiscoveryLocalhost PortNumber + | DiscoveryIP InetAddress PortNumber | DiscoveryICE | DiscoveryTunnel | DiscoveryOther Text @@ -185,12 +186,18 @@ instance Storable DiscoveryService where instance StorableText DiscoveryAddress where toText = \case + DiscoveryLocalhost port -> T.unwords [ "localhost", T.pack $ show port ] DiscoveryIP addr port -> T.unwords [ T.pack $ show addr, T.pack $ show port ] DiscoveryICE -> "ICE" DiscoveryTunnel -> "tunnel" DiscoveryOther str -> str fromText str = return $ if + | [ addrStr, portStr ] <- T.words str + , addrStr == "localhost" + , Just port <- readMaybe $ T.unpack portStr + -> DiscoveryLocalhost port + | [ addrStr, portStr ] <- T.words str , Just addr <- readMaybe $ T.unpack addrStr , Just port <- readMaybe $ T.unpack portStr @@ -219,6 +226,7 @@ data DiscoveryPeer = DiscoveryPeer { dpPriority :: Int , dpPeer :: Maybe Peer , dpAddress :: [ DiscoveryAddress ] + , dpLocalhost :: Maybe PortNumber , dpIceSession :: Maybe IceSession } @@ -227,6 +235,7 @@ emptyPeer = DiscoveryPeer { dpPriority = 0 , dpPeer = Nothing , dpAddress = [] + , dpLocalhost = Nothing , dpIceSession = Nothing } @@ -314,24 +323,28 @@ instance Service DiscoveryService where peer <- asks svcPeer paddrs <- getPeerAddresses peer + let matchedAddrs = flip filter addrs $ \case + DiscoveryICE -> True + DiscoveryIP ipaddr port -> + DatagramAddress (inetToSockAddr ( ipaddr, port )) `elem` paddrs + _ -> False + localhostPort = getLocalhostPortFromPeerAddresses paddrs + debugLog $ unwords [ "new peer" , show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ] , show $ map (refDigest . storedRef) $ idDataF $ finalOwner pid , show paddrs + , show (map toText matchedAddrs) + , show localhostPort ] - let matchedAddrs = flip filter addrs $ \case - DiscoveryICE -> True - DiscoveryIP ipaddr port -> - DatagramAddress (inetToSockAddr ( ipaddr, port )) `elem` paddrs - _ -> False - forM_ (idDataF =<< unfoldOwners pid) $ \sdata -> do let dp = DiscoveryPeer { dpPriority = fromMaybe 0 priority , dpPeer = Just peer , dpAddress = matchedAddrs + , dpLocalhost = localhostPort , dpIceSession = Nothing } rv = ResultValue @@ -360,10 +373,19 @@ instance Service DiscoveryService where st <- getStorage forM_ dgsts $ \dgst -> do when (dgst `M.member` peerSearchingFor) $ do - offerTunnel <- offerTunnelBetween attrs peer sp >>= return . \case - True -> (++ [ DiscoveryTunnel ]) - False -> id - let discoveryAddrs = offerTunnel matchedAddrs + discoveryAddrs <- concat <$> sequence + [ case localhostPort of + Just port -> getPeerAddresses sp >>= \case + spaddrs + | isJust $ getLocalhostPortFromPeerAddresses spaddrs + -> return [ DiscoveryLocalhost port ] + _ -> return [] + _ -> return [] + , return matchedAddrs + , offerTunnelBetween attrs peer sp >>= return . \case + True -> [ DiscoveryTunnel ] + False -> [] + ] let ( results, via ) | dgst == (refDigest $ storedRef $ idData pid) = ( discoveryAddrs, [] ) @@ -403,6 +425,7 @@ instance Service DiscoveryService where let dgst = either refDigest id edgst peer <- asks svcPeer pid <- asks svcPeerIdentity + paddrs <- getPeerAddresses peer (M.lookup dgst . dgsPeers <$> svcGetGlobal) >>= \case Just rv | direct <- (\p -> Just p <* guard (p /= peer)) =<< dpPeer =<< rvDirect rv @@ -412,14 +435,19 @@ instance Service DiscoveryService where , isJust direct || not (null rvia) -> do attrs <- asks svcAttributes - offerTunnel <- case direct of - Just dpeer -> offerTunnelBetween attrs peer dpeer >>= return . \case - True -> (++ [ DiscoveryTunnel ]) - False -> id - Nothing -> return id - let results - | isJust direct = offerTunnel $ maybe [] dpAddress $ rvDirect rv - | otherwise = [] + results <- if + | isJust direct -> concat <$> sequence + [ case ( dpLocalhost =<< rvDirect rv, getLocalhostPortFromPeerAddresses paddrs ) of + ( Just port, Just _ ) -> return [ DiscoveryLocalhost port ] + _ -> return [] + , return $ maybe [] dpAddress $ rvDirect rv + , case direct of + Just dpeer -> offerTunnelBetween attrs peer dpeer >>= return . \case + True -> [ DiscoveryTunnel ] + False -> [] + Nothing -> return [] + ] + | otherwise -> return [] via <- liftIO $ fmap catMaybes $ mapM (viaFromPeer attrs peer) rvia replyPacket $ DiscoveryResult edgst results via debugLog $ "search by " <> show (refDigest $ storedRef $ idData pid) <> @@ -464,6 +492,14 @@ instance Service DiscoveryService where let runAsService = runPeerService @DiscoveryService @IO discoveryPeer let tryAddresses = \case + DiscoveryLocalhost port : _ -> do + void $ liftIO $ forkIO $ do + let saddr = makeLocalhostAddress port + peer <- serverPeer server saddr + runAsService $ do + let upd rv = rv { rvDirect = Just $ (fromMaybe emptyPeer $ rvDirect rv) { dpPeer = Just peer } } + svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe mempty) dgst $ dgsPeers s } + DiscoveryIP ipaddr port : _ -> do void $ liftIO $ forkIO $ do let saddr = inetToSockAddr ( ipaddr, port ) @@ -883,3 +919,6 @@ discoverySetupTunnelResponse target = do (emptyConnection (Right self) (Right target)) { dconnTunnel = True } + +getLocalhostPortFromPeerAddresses :: [ PeerAddress ] -> Maybe PortNumber +getLocalhostPortFromPeerAddresses = msum . map (\case DatagramAddress a -> getLocalhostPort a; _ -> Nothing) diff --git a/src/Erebos/Network/Address.hs b/src/Erebos/Network/Address.hs index 63f6af1..8dedecd 100644 --- a/src/Erebos/Network/Address.hs +++ b/src/Erebos/Network/Address.hs @@ -2,6 +2,8 @@ module Erebos.Network.Address ( InetAddress(..), inetFromSockAddr, inetToSockAddr, + makeLocalhostAddress, + getLocalhostPort, SockAddr, PortNumber, ) where @@ -63,3 +65,11 @@ inetFromSockAddr saddr = first InetAddress <$> IP.fromSockAddr saddr inetToSockAddr :: ( InetAddress, PortNumber ) -> SockAddr inetToSockAddr = IP.toSockAddr . first fromInetAddress + + +makeLocalhostAddress :: PortNumber -> SockAddr +makeLocalhostAddress port = SockAddrInet6 port 0 ( 0, 0, 0, 1 ) 0 + +getLocalhostPort :: SockAddr -> Maybe PortNumber +getLocalhostPort (SockAddrInet6 port _ ( 0, 0, 0, 1 ) _) = Just port +getLocalhostPort _ = Nothing -- cgit v1.2.3