diff options
| -rw-r--r-- | main/Main.hs | 17 | ||||
| -rw-r--r-- | main/Test.hs | 7 | ||||
| -rw-r--r-- | main/WebSocket.hs | 1 | ||||
| -rw-r--r-- | src/Erebos/Discovery.hs | 14 |
4 files changed, 34 insertions, 5 deletions
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 diff --git a/main/Test.hs b/main/Test.hs index 62c7229..b07bd87 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -227,6 +227,11 @@ directMessageAttributes out = DirectMessageAttributes { dmOwnerMismatch = afterCommit $ outLine out "dm-owner-mismatch" } +discoveryAttributes :: DiscoveryAttributes +discoveryAttributes = (defaultServiceAttributes Proxy) + { discoveryProvideTunnel = const True + } + dmReceivedWatcher :: Output -> Stored DirectMessage -> IO () dmReceivedWatcher out smsg = do let msg = fromStored smsg @@ -510,7 +515,7 @@ cmdStartServer = do "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" "chatroom" -> return $ someService @ChatroomService Proxy "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" - "discovery" -> return $ someService @DiscoveryService Proxy + "discovery" -> return $ someServiceAttr $ discoveryAttributes "dm" -> return $ someServiceAttr $ directMessageAttributes out "sync" -> return $ someService @SyncService Proxy "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) diff --git a/main/WebSocket.hs b/main/WebSocket.hs index fbdd65f..5c49aa1 100644 --- a/main/WebSocket.hs +++ b/main/WebSocket.hs @@ -1,4 +1,5 @@ module WebSocket ( + WebSocketAddress(..), startWebsocketServer, ) where 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 |