summaryrefslogtreecommitdiff
path: root/src/Erebos/Discovery.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Discovery.hs')
-rw-r--r--src/Erebos/Discovery.hs147
1 files changed, 115 insertions, 32 deletions
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
index f0535fe..cbb12ca 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
@@ -29,19 +31,35 @@ import Erebos.Service
import Erebos.Storable
-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
, dconnTarget :: Ref
, dconnAddress :: Maybe Text
#ifdef ENABLE_ICE_SUPPORT
- , dconnIceSession :: Maybe IceRemoteInfo
+ , dconnIceInfo :: Maybe IceRemoteInfo
#endif
}
@@ -50,7 +68,7 @@ emptyConnection dconnSource dconnTarget = DiscoveryConnection {..}
where
dconnAddress = Nothing
#ifdef ENABLE_ICE_SUPPORT
- dconnIceSession = Nothing
+ dconnIceInfo = Nothing
#endif
instance Storable DiscoveryService where
@@ -59,8 +77,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
@@ -74,7 +97,7 @@ instance Storable DiscoveryService where
storeRawRef "target" $ dconnTarget conn
storeMbText "address" $ dconnAddress conn
#ifdef ENABLE_ICE_SUPPORT
- storeMbRef "ice-session" $ dconnIceSession conn
+ storeMbRef "ice-info" $ dconnIceInfo conn
#endif
load' = loadRec $ msum
@@ -83,8 +106,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"
@@ -100,7 +131,7 @@ instance Storable DiscoveryService where
<*> loadRawRef "target"
<*> loadMbText "address"
#ifdef ENABLE_ICE_SUPPORT
- <*> loadMbRef "ice-session"
+ <*> loadMbRef "ice-info"
#endif
data DiscoveryPeer = DiscoveryPeer
@@ -115,6 +146,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
@@ -124,7 +163,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
@@ -140,9 +179,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
@@ -156,16 +226,19 @@ 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 }
+ DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceInfo = Just rinfo }
case res of
Right _ -> return ()
Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err
@@ -178,6 +251,7 @@ instance Service DiscoveryService where
, dpIceSession = Just ice
}
#else
+ -> do
return ()
#endif
@@ -208,15 +282,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 { dconnIceInfo = Just rinfo }
+ case res of
+ Right _ -> do
+ case dconnIceInfo 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
@@ -250,7 +328,7 @@ instance Service DiscoveryService where
| Just dp <- M.lookup (refDigest $ dconnTarget conn) dpeers
, Just ice <- dpIceSession dp
- , Just rinfo <- dconnIceSession conn -> do
+ , Just rinfo <- dconnIceInfo conn -> do
liftIO $ iceConnect ice rinfo $ void $ serverPeerIce server ice
| otherwise -> svcPrint $ "Discovery: connection request failed"
@@ -271,6 +349,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
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-02 09:32:32 +0000