diff options
| -rw-r--r-- | src/Erebos/Discovery.hs | 14 |
1 files changed, 13 insertions, 1 deletions
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 63f5cf1..3c15f94 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -292,7 +292,12 @@ instance Service DiscoveryService where DiscoverySearch edgst -> do dpeer <- M.lookup (either refDigest id edgst) . dgsPeers <$> svcGetGlobal - replyPacket $ DiscoveryResult edgst $ maybe [] dpAddress dpeer + peer <- asks svcPeer + attrs <- asks svcAttributes + let offerTunnel + | discoveryProvideTunnel attrs peer = (++ [ DiscoveryTunnel ]) + | otherwise = id + replyPacket $ DiscoveryResult edgst $ maybe [] (offerTunnel . dpAddress) dpeer DiscoveryResult _ [] -> do -- not found @@ -345,6 +350,9 @@ instance Service DiscoveryService where #endif tryAddresses rest + DiscoveryTunnel : _ -> do + discoverySetupTunnelResponse dgst + addr : rest -> do svcPrint $ "Discovery: unsupported address in result: " ++ T.unpack (toText addr) tryAddresses rest @@ -629,6 +637,10 @@ receiveFromTunnel server taddr = do discoverySetupTunnel :: Peer -> RefDigest -> IO () discoverySetupTunnel via target = do runPeerService via $ do + discoverySetupTunnelResponse target + +discoverySetupTunnelResponse :: RefDigest -> ServiceHandler DiscoveryService () +discoverySetupTunnelResponse target = do self <- refDigest . storedRef . idData <$> svcSelf stream <- openStream svcModify $ \s -> s { dpsOurTunnelRequests = ( target, stream ) : dpsOurTunnelRequests s } |