From 59a2580c4cecb4acc53b812dc5fc8df091bf8516 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 23 Mar 2025 13:45:01 +0100 Subject: Relay ICE info even without other ICE support --- src/Erebos/Discovery.hs | 77 ++++++++++++++++++++++++------------------------- 1 file changed, 37 insertions(+), 40 deletions(-) diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 548d274..f97c792 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -59,6 +59,8 @@ data DiscoveryConnection = DiscoveryConnection , dconnAddress :: Maybe Text #ifdef ENABLE_ICE_SUPPORT , dconnIceInfo :: Maybe IceRemoteInfo +#else + , dconnIceInfo :: Maybe (Stored Object) #endif } @@ -66,9 +68,7 @@ emptyConnection :: Ref -> Ref -> DiscoveryConnection emptyConnection dconnSource dconnTarget = DiscoveryConnection {..} where dconnAddress = Nothing -#ifdef ENABLE_ICE_SUPPORT dconnIceInfo = Nothing -#endif instance Storable DiscoveryService where store' x = storeRec $ do @@ -95,9 +95,7 @@ instance Storable DiscoveryService where storeRawRef "source" $ dconnSource conn storeRawRef "target" $ dconnTarget conn storeMbText "address" $ dconnAddress conn -#ifdef ENABLE_ICE_SUPPORT storeMbRef "ice-info" $ dconnIceInfo conn -#endif load' = loadRec $ msum [ do @@ -129,9 +127,7 @@ instance Storable DiscoveryService where <$> loadRawRef "source" <*> loadRawRef "target" <*> loadMbText "address" -#ifdef ENABLE_ICE_SUPPORT <*> loadMbRef "ice-info" -#endif data DiscoveryPeer = DiscoveryPeer { dpPriority :: Int @@ -162,13 +158,19 @@ instance Service DiscoveryService where peer <- asks svcPeer let insertHelper new old | dpPriority new > dpPriority old = new | otherwise = old - matchedAddrs <- fmap catMaybes $ forM addrs $ \addr -> case words (T.unpack addr) of - [ipaddr, port] | DatagramAddress paddr <- peerAddress peer -> do + matchedAddrs <- fmap catMaybes $ forM addrs $ \addr -> if + | addr == T.pack "ICE" -> do + return $ Just addr + + | [ ipaddr, port ] <- words (T.unpack addr) + , DatagramAddress paddr <- peerAddress peer -> do saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) return $ if paddr == addrAddress saddr then Just addr else Nothing - _ -> return Nothing + + | otherwise -> return Nothing + forM_ (idDataF =<< unfoldOwners pid) $ \s -> svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) DiscoveryPeer { dpPriority = fromMaybe 0 priority @@ -178,39 +180,34 @@ instance Service DiscoveryService where , dpIceSession = Nothing #endif } - let matchedAddrs' = matchedAddrs -#ifdef ENABLE_ICE_SUPPORT - ++ filter (== T.pack "ICE") addrs -#endif attrs <- asks svcAttributes - replyPacket $ DiscoveryAcknowledged matchedAddrs' + replyPacket $ DiscoveryAcknowledged matchedAddrs (discoveryStunServer attrs) (discoveryStunPort attrs) (discoveryTurnServer attrs) (discoveryTurnPort attrs) - DiscoveryAcknowledged addrs stunServer stunPort turnServer turnPort -> do + DiscoveryAcknowledged _ 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 + 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 ) + 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 + cfg <- liftIO $ iceCreateConfig + (toIceServer stunServer stunPort) + (toIceServer turnServer turnPort) + svcSet cfg #endif return () @@ -273,11 +270,11 @@ instance Service DiscoveryService where svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr DiscoveryConnectionRequest conn -> do -#ifdef ENABLE_ICE_SUPPORT self <- svcSelf let rconn = emptyConnection (dconnSource conn) (dconnTarget conn) if refDigest (dconnTarget conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) then do +#ifdef ENABLE_ICE_SUPPORT -- request for us, create ICE sesssion server <- asks svcServer peer <- asks svcPeer @@ -294,6 +291,9 @@ instance Service DiscoveryService where Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err Nothing -> do svcPrint $ "Discovery: ICE request from peer without ICE configuration" +#else + return () +#endif else do -- request to some of our peers, relay @@ -305,17 +305,14 @@ instance Service DiscoveryService where | Just dpeer <- dpPeer dp -> do sendToPeer dpeer $ DiscoveryConnectionRequest conn | otherwise -> svcPrint $ "Discovery: failed to relay connection request" -#else - return () -#endif DiscoveryConnectionResponse conn -> do -#ifdef ENABLE_ICE_SUPPORT self <- svcSelf dpeers <- svcGetGlobal if refDigest (dconnSource conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) then do -- response to our request, try to connect to the peer +#ifdef ENABLE_ICE_SUPPORT server <- asks svcServer if | Just addr <- dconnAddress conn , [ipaddr, port] <- words (T.unpack addr) -> do @@ -331,15 +328,15 @@ instance Service DiscoveryService where liftIO $ iceConnect ice rinfo $ void $ serverPeerIce server ice | otherwise -> svcPrint $ "Discovery: connection request failed" +#else + return () +#endif else do -- response to relayed request case M.lookup (refDigest $ dconnSource conn) dpeers of Just dp | Just dpeer <- dpPeer dp -> do sendToPeer dpeer $ DiscoveryConnectionResponse conn _ -> svcPrint $ "Discovery: failed to relay connection response" -#else - return () -#endif serviceNewPeer = do server <- asks svcServer -- cgit v1.2.3 From 03f37ea3a7e77eb79381ca41c6612c38bd5727d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Mon, 24 Mar 2025 21:55:39 +0100 Subject: ICE: fix deadlock when creating session without STUN/TURN --- src/Erebos/ICE.chs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs index 2a6c174..6f61451 100644 --- a/src/Erebos/ICE.chs +++ b/src/Erebos/ICE.chs @@ -19,7 +19,7 @@ module Erebos.ICE ( ) where import Control.Arrow -import Control.Concurrent.MVar +import Control.Concurrent import Control.Monad import Control.Monad.Except import Control.Monad.Identity @@ -143,7 +143,11 @@ iceCreateConfig stun turn = iceCreateSession :: IceConfig -> IceSessionRole -> (IceSession -> IO ()) -> IO IceSession iceCreateSession icfg@(IceConfig fcfg) role cb = do rec sptr <- newStablePtr sess - cbptr <- newStablePtr $ cb sess + cbptr <- newStablePtr $ do + -- The callback may be called directly from pj_ice_strans_create or later + -- from a different thread; make sure we use a different thread here + -- to avoid deadlock on accessing 'sess'. + forkIO $ cb sess sess <- IceSession <$> (withForeignPtr fcfg $ \cfg -> {#call ice_create #} (castPtr cfg) (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr) -- cgit v1.2.3 From 91de9a3ffbe1fcc1147cdcac02380b2fe35d3b8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 26 Mar 2025 20:13:52 +0100 Subject: Disable -Wx-partial for now --- erebos.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/erebos.cabal b/erebos.cabal index 97a95ec..5a17a40 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -45,6 +45,7 @@ source-repository head common common ghc-options: -Wall + -Wno-x-partial -fdefer-typed-holes if flag(ci) -- cgit v1.2.3 From ed93546c519b35d5ece89c1fece94d8347e26f28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 26 Mar 2025 20:14:51 +0100 Subject: ICE: use pj_ice_strans_sendto2 --- src/Erebos/ICE/pjproject.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Erebos/ICE/pjproject.c b/src/Erebos/ICE/pjproject.c index 2374340..e79fb9d 100644 --- a/src/Erebos/ICE/pjproject.c +++ b/src/Erebos/ICE/pjproject.c @@ -397,7 +397,7 @@ void ice_send(pj_ice_strans * strans, const char * data, size_t len) return; } - pj_status_t status = pj_ice_strans_sendto(strans, 1, data, len, + pj_status_t status = pj_ice_strans_sendto2(strans, 1, data, len, &ice.def_addr, pj_sockaddr_get_len(&ice.def_addr)); if (status != PJ_SUCCESS && status != PJ_EPENDING) ice_perror("error sending data", status); -- cgit v1.2.3 From e3372f86d6935454b38c738784f9e2de8ac0a844 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 26 Mar 2025 20:38:03 +0100 Subject: Discovery: do not announce self without any local address --- src/Erebos/Discovery.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index f97c792..15ac9c4 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -352,4 +352,5 @@ instance Service DiscoveryService where #endif ] - sendToPeer peer $ DiscoverySelf addrs Nothing + when (not $ null addrs) $ do + sendToPeer peer $ DiscoverySelf addrs Nothing -- cgit v1.2.3 From abac0f38fb591fc00efc174e292a1b32e8496266 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 27 Mar 2025 20:24:58 +0100 Subject: Bump dependencies, support GHC 9.12 Changelog: Support GHC 9.12 --- erebos.cabal | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/erebos.cabal b/erebos.cabal index 5a17a40..5edd5f7 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -55,7 +55,7 @@ common common -Wno-error=unused-imports build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, + base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, default-extensions: DefaultSignatures @@ -143,21 +143,21 @@ library binary >=0.8 && <0.11, bytestring >=0.10 && <0.13, clock >=0.8 && < 0.9, - containers >= 0.6 && <0.8, + containers ^>= { 0.6, 0.7, 0.8 }, crypton ^>= { 1.0 }, deepseq >= 1.4 && <1.6, directory >= 1.3 && <1.4, filepath >=1.4 && <1.6, fsnotify ^>= { 0.4 }, - hashable >=1.3 && <1.5, - hashtables >=1.2 && <1.4, + hashable ^>= { 1.3, 1.4, 1.5 }, + hashtables ^>= { 1.2, 1.3, 1.4 }, iproute >=1.7.12 && <1.8, memory >=0.14 && <0.19, mtl >=2.2 && <2.4, - network >= 3.1 && <3.2, + network ^>= { 3.1, 3.2 }, stm >=2.5 && <2.6, text >= 1.2 && <2.2, - time >= 1.8 && <1.14, + time ^>= { 1.8, 1.9, 1.10, 1.11, 1.12, 1.13, 1.14 }, uuid >=1.3 && <1.4, zlib >=0.6 && <0.8 @@ -195,7 +195,7 @@ executable erebos mtl, network, process >=1.6 && <1.7, - template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 }, + template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 }, text, time, transformers >= 0.5 && <0.7, -- cgit v1.2.3 From 0cd184a6e2d6f184eaf771c9e28b6647d6fef18d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 27 Mar 2025 20:27:41 +0100 Subject: Switch source repositary location to HTTPS --- erebos.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/erebos.cabal b/erebos.cabal index 5edd5f7..df146d5 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -40,7 +40,7 @@ Flag ci source-repository head type: git - location: git://erebosprotocol.net/erebos + location: https://code.erebosprotocol.net/erebos common common ghc-options: -- cgit v1.2.3 From 82b82ce6417b23916466acaa83cac28c9d58dc4c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 27 Mar 2025 21:05:35 +0100 Subject: Relax crypton lower bound for Debian trixie --- erebos.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/erebos.cabal b/erebos.cabal index df146d5..e72c0a0 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -144,7 +144,7 @@ library bytestring >=0.10 && <0.13, clock >=0.8 && < 0.9, containers ^>= { 0.6, 0.7, 0.8 }, - crypton ^>= { 1.0 }, + crypton ^>= { 0.34, 1.0 }, deepseq >= 1.4 && <1.6, directory >= 1.3 && <1.4, filepath >=1.4 && <1.6, -- cgit v1.2.3 From 63e1b79f48e31da10e93169444c3426b631247b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 27 Mar 2025 21:19:54 +0100 Subject: Build with fsnotify-0.3 Present in Debian bookworm. --- erebos.cabal | 2 +- src/Erebos/Storage.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/erebos.cabal b/erebos.cabal index e72c0a0..15f19ed 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -148,7 +148,7 @@ library deepseq >= 1.4 && <1.6, directory >= 1.3 && <1.4, filepath >=1.4 && <1.6, - fsnotify ^>= { 0.4 }, + fsnotify ^>= { 0.3, 0.4 }, hashable ^>= { 1.3, 1.4, 1.5 }, hashtables ^>= { 1.2, 1.3, 1.4 }, iproute >=1.7.12 && <1.8, diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs index 61bb2fa..c1e9664 100644 --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -567,7 +567,7 @@ watchHeadRaw st tid hid sel cb = do True -> return ilist False -> do void $ watchDir manager (headTypePath spath tid) (const True) $ \case - Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do + ev@Added {} | Just ihid <- HeadID <$> U.fromString (takeFileName (eventPath ev)) -> do loadHeadRaw st tid ihid >>= \case Just ref -> do (_, _, iwl) <- readMVar mvar -- cgit v1.2.3