dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-05-24 16:45:16 +00:00
Code Issues Packages Projects Releases Wiki Activity

ntf server: better batching and logging (#780)

Browse Source 
* ntf server: better batching and logging

* reduce batch delay for ntf server

* comments

* 5.1.3, ntf 1.4.2

* more logging

* more logging

* split large batches, more logging

* remove some logs
This commit is contained in:
Evgeny Poberezkin
2023-06-26 20:14:35 +01:00
committed by GitHub
parent 3a74558e84
commit 4a927d1ae2
19 changed files with 149 additions and 123 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Messaging/Client.hs
+9 -6
View File
@@ -219,8 +219,10 @@ data ProtocolClientConfig = ProtocolClientConfig
defaultTransport :: (ServiceName, ATransport),
-- | network configuration
networkConfig :: NetworkConfig,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange
-- | client-server protocol version range
serverVRange :: VersionRange,
-- | delay between sending batches of commands (microseconds)
batchDelay :: Maybe Int
}
-- | Default protocol client configuration.
@@ -230,7 +232,8 @@ defaultClientConfig =
{ qSize = 64,
defaultTransport = ("443", transport @TLS),
networkConfig = defaultNetworkConfig,
smpServerVRange = supportedSMPServerVRange
serverVRange = supportedSMPServerVRange,
batchDelay = Nothing
}
data Request err msg = Request
@@ -276,7 +279,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getProtocolClient :: forall err msg. Protocol err msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg))
getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do
case chooseTransportHost networkConfig (host srv) of
Right useHost ->
(atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
@@ -329,7 +332,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
client :: forall c. Transport c => TProxy c -> PClient err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient err msg)) -> c -> IO ()
client _ c cVar h =
runExceptT (protocolClientHandshake @err @msg h (keyHash srv) smpServerVRange) >>= \case
runExceptT (protocolClientHandshake @err @msg h (keyHash srv) serverVRange) >>= \case
Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
Right th@THandle {sessionId, thVersion} -> do
sessionTs <- getCurrentTime
@@ -341,7 +344,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
`finally` disconnected c'
send :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPut h batchDelay
receive :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ