From 8bcaaf5524504f01bd5643d74848cec625370aa9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Mon, 28 Jul 2025 16:48:15 +0200 Subject: Peer address input in ServiceHandler --- main/Main.hs | 17 ++++++++--------- main/Test.hs | 4 ++-- 2 files changed, 10 insertions(+), 11 deletions(-) (limited to 'main') diff --git a/main/Main.hs b/main/Main.hs index e2e585a..6a6c565 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -172,17 +172,16 @@ 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 :: Maybe String -> Writer [ String ] (Peer -> PeerAddress -> Bool) + provideTunnelFun Nothing = return $ \_ _ -> True + provideTunnelFun (Just "all") = return $ \_ _ -> True + provideTunnelFun (Just "none") = return $ \_ _ -> False + provideTunnelFun (Just "websocket") = return $ \_ -> \case + CustomPeerAddress addr | Just WebSocketAddress {} <- cast addr -> True + _ -> False provideTunnelFun (Just name) = do tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ] - return $ const False + return $ \_ _ -> False servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ] servicesOptions = concatMap helper $ "all" : map soptName availableServices diff --git a/main/Test.hs b/main/Test.hs index b1c8f01..093d3ac 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -229,7 +229,7 @@ directMessageAttributes out = DirectMessageAttributes discoveryAttributes :: DiscoveryAttributes discoveryAttributes = (defaultServiceAttributes Proxy) - { discoveryProvideTunnel = const False + { discoveryProvideTunnel = \_ _ -> False } dmReceivedWatcher :: Output -> Stored DirectMessage -> IO () @@ -524,7 +524,7 @@ cmdStartServer = do ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes - { discoveryProvideTunnel = const $ "tunnel" `elem` params + { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params } ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out ( "sync", _ ) -> return $ someService @SyncService Proxy -- cgit v1.2.3