summaryrefslogtreecommitdiff
path: root/src/Network.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-08-13 16:28:33 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-08-27 12:01:16 +0200
commit251452dfb0c239ac1bc9f70c620a2cdef18ae739 (patch)
treec6b167fa397a901637aeb740ed01009f0bd3b87e /src/Network.hs
parent0ef84b829ef2b27ce73dc84ad549d6099b28c377 (diff)
Network: send announce using protocol control request
Diffstat (limited to 'src/Network.hs')
-rw-r--r--src/Network.hs23
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