voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

continue with TCP leaks

This commit is contained in:
voidlizard 2024-11-01 15:38:48 +03:00
parent fa74de1fdb
commit 8af3a21be1
1 changed files with 9 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
hbs2-core/lib/HBS2/Net/Messaging/TCP.hs
View File

@ -19,9 +19,9 @@ import HBS2.Prelude.Plated
import HBS2.Net.Messaging.Stream import HBS2.Net.Messaging.Stream
import HBS2.System.Logger.Simple import HBS2.System.Logger.Simple
import HBS2.Misc.PrettyStuff
import Control.Concurrent.STM (flushTQueue) import Control.Concurrent.STM (flushTQueue)
import Control.Exception (try,SomeException)
import Control.Monad import Control.Monad
import Data.Bits import Data.Bits
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
@ -389,7 +389,10 @@ fireTCP MessagingTCP{..} pip what = do
when fire do when fire do
debug $ "Fire TCP" <+> pretty pa debug $ "Fire TCP" <+> pretty pa
atomically (modifyTVar _tcpFired succ) atomically (modifyTVar _tcpFired succ)
void $ async (what >> atomically (modifyTVar _tcpFired pred)) void $ async do
r <- U.try @_ @SomeException what
atomically (modifyTVar _tcpFired pred)
either U.throwIO dontHandle r
runMessagingTCP :: forall m . MonadIO m => MessagingTCP -> m () runMessagingTCP :: forall m . MonadIO m => MessagingTCP -> m ()
runMessagingTCP env@MessagingTCP{..} = liftIO do runMessagingTCP env@MessagingTCP{..} = liftIO do
@ -438,6 +441,10 @@ runMessagingTCP env@MessagingTCP{..} = liftIO do
co' <- atomically $ readTVar (view tcpPeerConn env) <&> HashMap.lookup pip co' <- atomically $ readTVar (view tcpPeerConn env) <&> HashMap.lookup pip
when (isNothing co') do
debug $ red "No session for" <+> pretty pip
pure ()
maybe1 co' (void $ fireTCP env pip (connectPeerTCP env pip)) $ \co -> do maybe1 co' (void $ fireTCP env pip (connectPeerTCP env pip)) $ \co -> do
q' <- atomically $ readTVar (view tcpConnQ env) <&> HashMap.lookup co q' <- atomically $ readTVar (view tcpConnQ env) <&> HashMap.lookup co
maybe1 q' none $ \q -> do maybe1 q' none $ \q -> do