From 173816717bca3d07e894c0fd8877f84eb9c3a4f7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 5 Jul 2025 17:31:07 +0200
Subject: Option to configure when tunnel is offered

---
 src/Erebos/Discovery.hs | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

(limited to 'src/Erebos')

diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
index 5de9869..168a9c5 100644
--- a/src/Erebos/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -59,6 +59,7 @@ data DiscoveryAttributes = DiscoveryAttributes
     , discoveryStunServer :: Maybe Text
     , discoveryTurnPort :: Maybe Word16
     , discoveryTurnServer :: Maybe Text
+    , discoveryProvideTunnel :: Peer -> Bool
     }
 
 defaultDiscoveryAttributes :: DiscoveryAttributes
@@ -67,6 +68,7 @@ defaultDiscoveryAttributes = DiscoveryAttributes
     , discoveryStunServer = Nothing
     , discoveryTurnPort = Nothing
     , discoveryTurnServer = Nothing
+    , discoveryProvideTunnel = const False
     }
 
 data DiscoveryConnection = DiscoveryConnection
@@ -326,6 +328,7 @@ instance Service DiscoveryService where
 
         DiscoveryConnectionRequest conn -> do
             self <- svcSelf
+            attrs <- asks svcAttributes
             let rconn = emptyConnection (dconnSource conn) (dconnTarget conn)
             if either refDigest id (dconnTarget conn) `elem` identityDigests self
               then if
@@ -369,14 +372,17 @@ instance Service DiscoveryService where
                     svcPrint $ "Discovery: unsupported connection request"
 
               else do
-                    -- request to some of our peers, relay
-                    mbdp <- M.lookup (either refDigest id $ dconnTarget conn) . dgsPeers <$> svcGetGlobal
-                    streams <- receivedStreams
-                    case mbdp of
+                -- request to some of our peers, relay
+                peer <- asks svcPeer
+                mbdp <- M.lookup (either refDigest id $ dconnTarget conn) . dgsPeers <$> svcGetGlobal
+                streams <- receivedStreams
+                case mbdp of
                         Nothing -> replyPacket $ DiscoveryConnectionResponse rconn
                         Just dp
                             | Just dpeer <- dpPeer dp -> if
                                 | dconnTunnel conn -> if
+                                    | not (discoveryProvideTunnel attrs peer) -> do
+                                        replyPacket $ DiscoveryConnectionResponse rconn
                                     | fromSource : _ <- streams -> do
                                         void $ liftIO $ forkIO $ runPeerService @DiscoveryService dpeer $ do
                                             toTarget <- openStream
-- 
cgit v1.2.3