From e6a5ec99e0f94ec33c0e52e6cf64cfbb7f7d5e97 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 10 Sep 2023 13:29:05 +0200 Subject: Network: fork per-connection thread as soon as possible --- src/Network.hs | 49 +++++++++++++++++++++++++------------------------ 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/src/Network.hs b/src/Network.hs index 2e2546b..5455c07 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -274,31 +274,32 @@ startServer opt serverOrigHead logd' serverServices = do peer <- mkPeer server paddr return (M.insert paddr peer pvalue, peer) - atomically $ do - readTVar (peerConnection peer) >>= \case - Left packets -> writeFlowBulk (connData conn) $ reverse packets - Right _ -> return () - writeTVar (peerConnection peer) (Right conn) - - forkServerThread server $ forever $ do - (secure, TransportPacket header objs) <- readFlowIO $ connData conn - prefs <- forM objs $ storeObject $ peerInStorage peer - identity <- readMVar serverIdentity_ - let svcs = map someServiceID serverServices - handlePacket identity secure peer chanSvc svcs header prefs - - case mbpid of - Just dgst -> do + forkServerThread server $ do + atomically $ do + readTVar (peerConnection peer) >>= \case + Left packets -> writeFlowBulk (connData conn) $ reverse packets + Right _ -> return () + writeTVar (peerConnection peer) (Right conn) + + case mbpid of + Just dgst -> do + identity <- readMVar serverIdentity_ + atomically $ runPacketHandler False peer $ do + wref <- newWaitingRef dgst $ handleIdentityAnnounce identity peer + readTVarP (peerIdentityVar peer) >>= \case + PeerIdentityUnknown idwait -> do + addHeader $ AnnounceSelf $ refDigest $ storedRef $ idData identity + writeTVarP (peerIdentityVar peer) $ PeerIdentityRef wref idwait + liftSTM $ writeTChan serverChanPeer peer + _ -> return () + Nothing -> return () + + forever $ do + (secure, TransportPacket header objs) <- readFlowIO $ connData conn + prefs <- forM objs $ storeObject $ peerInStorage peer identity <- readMVar serverIdentity_ - atomically $ runPacketHandler False peer $ do - wref <- newWaitingRef dgst $ handleIdentityAnnounce identity peer - readTVarP (peerIdentityVar peer) >>= \case - PeerIdentityUnknown idwait -> do - addHeader $ AnnounceSelf $ refDigest $ storedRef $ idData identity - writeTVarP (peerIdentityVar peer) $ PeerIdentityRef wref idwait - liftSTM $ writeTChan serverChanPeer peer - _ -> return () - Nothing -> return () + let svcs = map someServiceID serverServices + handlePacket identity secure peer chanSvc svcs header prefs ReceivedAnnounce addr _ -> do void $ serverPeer' server addr -- cgit v1.2.3