diff options
Diffstat (limited to 'src/Network.hs')
| -rw-r--r-- | src/Network.hs | 23 |
1 files changed, 7 insertions, 16 deletions
diff --git a/src/Network.hs b/src/Network.hs index 28a8ce5..c5ba393 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -25,7 +25,6 @@ import Control.Monad.Except import Control.Monad.State import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL import Data.Function import Data.IP qualified as IP import Data.List @@ -68,7 +67,7 @@ data Server = Server , serverThreads :: MVar [ThreadId] , serverSocket :: MVar Socket , serverRawPath :: SymFlow (PeerAddress, BC.ByteString) - , serverNewConnection :: Flow (Connection PeerAddress) PeerAddress + , serverControlFlow :: Flow (Connection PeerAddress) (ControlRequest PeerAddress) , serverDataResponse :: TQueue (Peer, Maybe PartialRef) , serverIOActions :: TQueue (ExceptT String IO ()) , serverServices :: [SomeService] @@ -184,7 +183,7 @@ startServer opt serverOrigHead logd' serverServices = do serverThreads <- newMVar [] serverSocket <- newEmptyMVar (serverRawPath, protocolRawPath) <- newFlowIO - (serverNewConnection, protocolNewConnection) <- newFlowIO + (serverControlFlow, protocolControlFlow) <- newFlowIO serverDataResponse <- newTQueueIO serverIOActions <- newTQueueIO serverServiceStates <- newTMVarIO M.empty @@ -217,10 +216,7 @@ startServer opt serverOrigHead logd' serverServices = do loop sock = do when (serverLocalDiscovery opt) $ forkServerThread server $ forever $ do - readMVar serverIdentity_ >>= \identity -> do - st <- derivePartialStorage serverStorage - let packet = BL.toStrict $ serializeObject $ transportToObject st $ TransportHeader [ AnnounceSelf $ refDigest $ storedRef $ idData identity ] - mapM_ (void . S.sendTo sock packet) broadcastAddreses + atomically $ writeFlowBulk serverControlFlow $ map (SendAnnounce . DatagramAddress) broadcastAddreses threadDelay $ announceIntervalSeconds * 1000 * 1000 let announceUpdate identity = do @@ -264,7 +260,7 @@ startServer opt serverOrigHead logd' serverServices = do PeerIceSession ice -> iceSend ice msg forkServerThread server $ forever $ do - conn <- readFlowIO serverNewConnection + conn <- readFlowIO serverControlFlow let paddr = connAddress conn peer <- modifyMVar serverPeers $ \pvalue -> do case M.lookup paddr pvalue of @@ -286,7 +282,7 @@ startServer opt serverOrigHead logd' serverServices = do let svcs = map someServiceID serverServices handlePacket identity secure peer chanSvc svcs header prefs - erebosNetworkProtocol logd protocolRawPath protocolNewConnection + erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd protocolRawPath protocolControlFlow forkServerThread server $ withSocketsDo $ do let hints = defaultHints @@ -642,13 +638,8 @@ serverPeer' server paddr = do Nothing -> do peer <- mkPeer server paddr return (M.insert paddr peer pvalue, (peer, True)) - when hello $ do - identity <- serverIdentity server - atomically $ do - writeFlow (serverNewConnection server) paddr - sendToPeerPlain peer [] $ TransportPacket - (TransportHeader [ AnnounceSelf $ refDigest $ storedRef $ idData identity ]) - [] + when hello $ atomically $ do + writeFlow (serverControlFlow server) (RequestConnection paddr) return peer |