summaryrefslogtreecommitdiff
path: root/src/Network/Protocol.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/Protocol.hs
parent0ef84b829ef2b27ce73dc84ad549d6099b28c377 (diff)
Network: send announce using protocol control request
Diffstat (limited to 'src/Network/Protocol.hs')
-rw-r--r--src/Network/Protocol.hs43
1 files changed, 33 insertions, 10 deletions
diff --git a/src/Network/Protocol.hs b/src/Network/Protocol.hs
index 054c0fb..488080e 100644
--- a/src/Network/Protocol.hs
+++ b/src/Network/Protocol.hs
@@ -10,6 +10,7 @@ module Network.Protocol (
ChannelState(..),
+ ControlRequest(..),
erebosNetworkProtocol,
Connection,
@@ -40,6 +41,7 @@ import System.Clock
import Channel
import Flow
+import Identity
import Service
import Storage
@@ -95,9 +97,10 @@ transportFromObject _ = Nothing
data GlobalState addr = (Eq addr, Show addr) => GlobalState
- { gConnections :: TVar [Connection addr]
+ { gIdentity :: TVar UnifiedIdentity
+ , gConnections :: TVar [Connection addr]
, gDataFlow :: SymFlow (addr, ByteString)
- , gConnectionFlow :: Flow addr (Connection addr)
+ , gControlFlow :: Flow (ControlRequest addr) (Connection addr)
, gLog :: String -> STM ()
, gStorage :: PartialStorage
, gNowVar :: TVar TimeSpec
@@ -155,12 +158,18 @@ data SentPacket = SentPacket
}
+data ControlRequest addr = RequestConnection addr
+ | SendAnnounce addr
+
+
erebosNetworkProtocol :: (Eq addr, Ord addr, Show addr)
- => (String -> STM ())
+ => UnifiedIdentity
+ -> (String -> STM ())
-> SymFlow (addr, ByteString)
- -> Flow addr (Connection addr)
+ -> Flow (ControlRequest addr) (Connection addr)
-> IO ()
-erebosNetworkProtocol gLog gDataFlow gConnectionFlow = do
+erebosNetworkProtocol initialIdentity gLog gDataFlow gControlFlow = do
+ gIdentity <- newTVarIO initialIdentity
gConnections <- newTVarIO []
gStorage <- derivePartialStorage =<< memoryStorage
@@ -204,7 +213,7 @@ getConnection GlobalState {..} addr = do
let conn = Connection {..}
writeTVar gConnections (conn : conns)
- writeFlow gConnectionFlow conn
+ writeFlow gControlFlow conn
return conn
processIncomming :: GlobalState addr -> STM (IO ())
@@ -331,15 +340,29 @@ processOutgoing gs@GlobalState {..} = do
writeTVar cSentPackets rest
return $ sendBytes conn sp
- let establishNewConnection = do
- _ <- getConnection gs =<< readFlow gConnectionFlow
- return $ return ()
+ let handleControlRequests = readFlow gControlFlow >>= \case
+ RequestConnection addr -> do
+ _ <- getConnection gs addr
+ identity <- readTVar gIdentity
+ let packet = BL.toStrict $ serializeObject $ transportToObject gStorage $ TransportHeader
+ [ AnnounceSelf $ refDigest $ storedRef $ idData identity
+ ]
+ writeFlow gDataFlow (addr, packet)
+ return $ return ()
+
+ SendAnnounce addr -> do
+ identity <- readTVar gIdentity
+ let packet = BL.toStrict $ serializeObject $ transportToObject gStorage $ TransportHeader
+ [ AnnounceSelf $ refDigest $ storedRef $ idData identity
+ ]
+ writeFlow gDataFlow (addr, packet)
+ return $ return ()
conns <- readTVar gConnections
msum $ concat $
[ map retransmitPacket conns
, map sendNextPacket conns
- , [ establishNewConnection ]
+ , [ handleControlRequests ]
]
processAcknowledgements :: GlobalState addr -> Connection addr -> [TransportHeaderItem] -> STM ()