summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Network.hs49
1 files 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