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

---
 main/Main.hs | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

(limited to 'main/Main.hs')

diff --git a/main/Main.hs b/main/Main.hs
index 064cf54..403e5e9 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -145,6 +145,11 @@ options =
         (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnServer = Just (read value) }) "<server>")
         "offer <server> (domain name or IP address) to discovery peers for TURN protocol"
 #endif
+    , Option [] [ "discovery-tunnel" ]
+        (OptArg (\value -> \opts -> do
+            fun <- provideTunnelFun value
+            serviceAttr (\attrs -> return attrs { discoveryProvideTunnel = fun }) opts) "<peer-type>")
+        "offer to provide tunnel for peers of given <peer-type>, possible values: all, none, websocket"
     , Option [] ["dm-bot-echo"]
         (ReqArg (\prefix -> \opts -> return opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
         "automatically reply to direct messages with the same text prefixed with <prefix>"
@@ -173,6 +178,18 @@ options =
             return sopt { soptService = service }
         return opts { optServices = services' }
 
+    provideTunnelFun :: Maybe String -> Writer [ String ] (Peer -> Bool)
+    provideTunnelFun Nothing = return $ const True
+    provideTunnelFun (Just "all") = return $ const True
+    provideTunnelFun (Just "none") = return $ const False
+    provideTunnelFun (Just "websocket") = return $ \peer ->
+        case peerAddress peer of
+            CustomPeerAddress addr | Just WebSocketAddress {} <- cast addr -> True
+            _ -> False
+    provideTunnelFun (Just name) = do
+        tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ]
+        return $ const False
+
 servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ]
 servicesOptions = concatMap helper $ "all" : map soptName availableServices
   where
-- 
cgit v1.2.3