diff options
Diffstat (limited to 'src/Erebos/Discovery.hs')
| -rw-r--r-- | src/Erebos/Discovery.hs | 135 |
1 files changed, 109 insertions, 26 deletions
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 6422a59..1ba11c5 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -2,6 +2,7 @@ module Erebos.Discovery ( DiscoveryService(..), + DiscoveryAttributes(..), DiscoveryConnection(..) ) where @@ -16,6 +17,7 @@ import Data.Map.Strict qualified as M import Data.Maybe import Data.Text (Text) import Data.Text qualified as T +import Data.Word import Network.Socket @@ -28,12 +30,28 @@ import Erebos.Service import Erebos.Storage -data DiscoveryService = DiscoverySelf [ Text ] (Maybe Int) - | DiscoveryAcknowledged Text - | DiscoverySearch Ref - | DiscoveryResult Ref [ Text ] - | DiscoveryConnectionRequest DiscoveryConnection - | DiscoveryConnectionResponse DiscoveryConnection +data DiscoveryService + = DiscoverySelf [ Text ] (Maybe Int) + | DiscoveryAcknowledged [ Text ] (Maybe Text) (Maybe Word16) (Maybe Text) (Maybe Word16) + | DiscoverySearch Ref + | DiscoveryResult Ref [ Text ] + | DiscoveryConnectionRequest DiscoveryConnection + | DiscoveryConnectionResponse DiscoveryConnection + +data DiscoveryAttributes = DiscoveryAttributes + { discoveryStunPort :: Maybe Word16 + , discoveryStunServer :: Maybe Text + , discoveryTurnPort :: Maybe Word16 + , discoveryTurnServer :: Maybe Text + } + +defaultDiscoveryAttributes :: DiscoveryAttributes +defaultDiscoveryAttributes = DiscoveryAttributes + { discoveryStunPort = Nothing + , discoveryStunServer = Nothing + , discoveryTurnPort = Nothing + , discoveryTurnServer = Nothing + } data DiscoveryConnection = DiscoveryConnection { dconnSource :: Ref @@ -58,8 +76,13 @@ instance Storable DiscoveryService where DiscoverySelf addrs priority -> do mapM_ (storeText "self") addrs mapM_ (storeInt "priority") priority - DiscoveryAcknowledged addr -> do - storeText "ack" addr + DiscoveryAcknowledged addrs stunServer stunPort turnServer turnPort -> do + if null addrs then storeEmpty "ack" + else mapM_ (storeText "ack") addrs + storeMbText "stun-server" stunServer + storeMbInt "stun-port" stunPort + storeMbText "turn-server" turnServer + storeMbInt "turn-port" turnPort DiscoverySearch ref -> storeRawRef "search" ref DiscoveryResult ref addr -> do storeRawRef "result" ref @@ -82,8 +105,16 @@ instance Storable DiscoveryService where guard (not $ null addrs) DiscoverySelf addrs <$> loadMbInt "priority" - , DiscoveryAcknowledged - <$> loadText "ack" + , do + addrs <- loadTexts "ack" + mbEmpty <- loadMbEmpty "ack" + guard (not (null addrs) || isJust mbEmpty) + DiscoveryAcknowledged + <$> pure addrs + <*> loadMbText "stun-server" + <*> loadMbInt "stun-port" + <*> loadMbText "turn-server" + <*> loadMbInt "turn-port" , DiscoverySearch <$> loadRawRef "search" , DiscoveryResult <$> loadRawRef "result" @@ -114,6 +145,14 @@ data DiscoveryPeer = DiscoveryPeer instance Service DiscoveryService where serviceID _ = mkServiceID "dd59c89c-69cc-4703-b75b-4ddcd4b3c23c" + type ServiceAttributes DiscoveryService = DiscoveryAttributes + defaultServiceAttributes _ = defaultDiscoveryAttributes + +#ifdef ENABLE_ICE_SUPPORT + type ServiceState DiscoveryService = Maybe IceConfig + emptyServiceState _ = Nothing +#endif + type ServiceGlobalState DiscoveryService = Map RefDigest DiscoveryPeer emptyServiceGlobalState _ = M.empty @@ -123,7 +162,7 @@ instance Service DiscoveryService where peer <- asks svcPeer let insertHelper new old | dpPriority new > dpPriority old = new | otherwise = old - mbaddr <- fmap (listToMaybe . catMaybes) $ forM addrs $ \addr -> case words (T.unpack addr) of + matchedAddrs <- fmap catMaybes $ forM addrs $ \addr -> case words (T.unpack addr) of [ipaddr, port] | DatagramAddress paddr <- peerAddress peer -> do saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) return $ if paddr == addrAddress saddr @@ -139,9 +178,40 @@ instance Service DiscoveryService where , dpIceSession = Nothing #endif } - replyPacket $ DiscoveryAcknowledged $ fromMaybe (T.pack "ICE") mbaddr - - DiscoveryAcknowledged _ -> do + let matchedAddrs' = matchedAddrs +#ifdef ENABLE_ICE_SUPPORT + ++ filter (== T.pack "ICE") addrs +#endif + attrs <- asks svcAttributes + replyPacket $ DiscoveryAcknowledged matchedAddrs' + (discoveryStunServer attrs) + (discoveryStunPort attrs) + (discoveryTurnServer attrs) + (discoveryTurnPort attrs) + + DiscoveryAcknowledged addrs stunServer stunPort turnServer turnPort -> do +#ifdef ENABLE_ICE_SUPPORT + when (T.pack "ICE" `elem` addrs) $ do + paddr <- asks (peerAddress . svcPeer) >>= return . \case + (DatagramAddress saddr) -> case IP.fromSockAddr saddr of + Just (IP.IPv6 ipv6, _) + | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6 + -> Just $ T.pack $ show (IP.toIPv4w ipv4) + Just (addr, _) + -> Just $ T.pack $ show addr + _ -> Nothing + _ -> Nothing + + let toIceServer Nothing Nothing = Nothing + toIceServer Nothing (Just port) = ( , port) <$> paddr + toIceServer (Just server) Nothing = Just ( server, 0 ) + toIceServer (Just server) (Just port) = Just ( server, port ) + + cfg <- liftIO $ iceCreateConfig + (toIceServer stunServer stunPort) + (toIceServer turnServer turnPort) + svcSet cfg +#endif return () DiscoverySearch ref -> do @@ -155,13 +225,16 @@ instance Service DiscoveryService where -- TODO: check if we really requested that server <- asks svcServer self <- svcSelf + mbIceConfig <- svcGet discoveryPeer <- asks svcPeer let runAsService = runPeerService @DiscoveryService discoveryPeer liftIO $ void $ forkIO $ forM_ addrs $ \addr -> if - | addr == T.pack "ICE" -> do + | addr == T.pack "ICE" #ifdef ENABLE_ICE_SUPPORT - ice <- iceCreate PjIceSessRoleControlling $ \ice -> do + , Just config <- mbIceConfig + -> do + ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do rinfo <- iceRemoteInfo ice res <- runExceptT $ sendToPeer discoveryPeer $ DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceSession = Just rinfo } @@ -177,6 +250,7 @@ instance Service DiscoveryService where , dpIceSession = Just ice } #else + -> do return () #endif @@ -207,15 +281,19 @@ instance Service DiscoveryService where -- request for us, create ICE sesssion server <- asks svcServer peer <- asks svcPeer - liftIO $ void $ iceCreate PjIceSessRoleControlled $ \ice -> do - rinfo <- iceRemoteInfo ice - res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceSession = Just rinfo } - case res of - Right _ -> do - case dconnIceSession conn of - Just prinfo -> iceConnect ice prinfo $ void $ serverPeerIce server ice - Nothing -> putStrLn $ "Discovery: connection request without ICE remote info" - Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err + svcGet >>= \case + Just config -> do + liftIO $ void $ iceCreateSession config PjIceSessRoleControlled $ \ice -> do + rinfo <- iceRemoteInfo ice + res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceSession = Just rinfo } + case res of + Right _ -> do + case dconnIceSession conn of + Just prinfo -> iceConnect ice prinfo $ void $ serverPeerIce server ice + Nothing -> putStrLn $ "Discovery: connection request without ICE remote info" + Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err + Nothing -> do + svcPrint $ "Discovery: ICE request from peer without ICE configuration" else do -- request to some of our peers, relay @@ -270,6 +348,11 @@ instance Service DiscoveryService where let addrToText saddr = do ( addr, port ) <- IP.fromSockAddr saddr Just $ T.pack $ show addr <> " " <> show port - addrs <- catMaybes . map addrToText <$> liftIO (getServerAddresses server) + addrs <- concat <$> sequence + [ catMaybes . map addrToText <$> liftIO (getServerAddresses server) +#ifdef ENABLE_ICE_SUPPORT + , return [ T.pack "ICE" ] +#endif + ] sendToPeer peer $ DiscoverySelf addrs Nothing |