Peer address input in ServiceHandler

2 files changed, 10 insertions, 11 deletions

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