mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-17 05:55:04 +00:00
agent: do not mark subscriptions on expired sessions as active, mark delayed subscriptions as active on the same session, do not cancel sending expired commands (#1127)
* agent: do not mark subscriptions on expired sessions as active, do mark delayed subscriptions as active on the same session, SUBOK response in the next SMP protocol version
* client: prevent sub actions from zombie sessions (#1122)
* client: prevent sub actions from zombie sessions
* error handling
* add AERR to pass background errors to client
* switch to activeClientSession
* put closeClient under activeClientSession
* rename
* remove AERR, do not skip processing
* move check and state update to one transaction
* catch extra UPs
* fix
* check queue is still pending before making it active
---------
Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
* do not forward agent error
* revert not expiring sending subs
* fixes
* track subscription responses better
* add pending connection
* Revert "revert not expiring sending subs"
This reverts commit 4310a69391.
* do not expire sending commands
* rename
* fix race
* function
---------
Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
co-authored by
Alexander Bondarenko
Alexander Bondarenko
parent
1339a8da11
commit
91cc48aabe
@@ -70,6 +70,7 @@ module Simplex.Messaging.Client
|
||||
proxyUsername,
|
||||
temporaryClientError,
|
||||
ServerTransmission,
|
||||
TransmissionType (..),
|
||||
ClientCommand,
|
||||
|
||||
-- * For testing
|
||||
@@ -80,9 +81,11 @@ module Simplex.Messaging.Client
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
@@ -110,7 +113,7 @@ import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
|
||||
import Simplex.Messaging.Transport.KeepAlive
|
||||
import Simplex.Messaging.Transport.WebSockets (WS)
|
||||
import Simplex.Messaging.Util (bshow, diffToMicroseconds, raceAny_, threadDelay', whenM)
|
||||
import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, raceAny_, threadDelay', tshow, whenM)
|
||||
import Simplex.Messaging.Version
|
||||
import System.Timeout (timeout)
|
||||
|
||||
@@ -129,15 +132,14 @@ data PClient v err msg = PClient
|
||||
transportSession :: TransportSession msg,
|
||||
transportHost :: TransportHost,
|
||||
tcpTimeout :: Int,
|
||||
rcvConcurrency :: Int,
|
||||
sendPings :: TVar Bool,
|
||||
lastReceived :: TVar UTCTime,
|
||||
timeoutErrorCount :: TVar Int,
|
||||
clientCorrId :: TVar ChaChaDRG,
|
||||
sentCommands :: TMap CorrId (Request err msg),
|
||||
sndQ :: TBQueue (TVar Bool, ByteString),
|
||||
sndQ :: TBQueue ByteString,
|
||||
rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
|
||||
msgQ :: Maybe (TBQueue (ServerTransmission v msg))
|
||||
msgQ :: Maybe (TBQueue (ServerTransmission v err msg))
|
||||
}
|
||||
|
||||
smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> STM SMPClient
|
||||
@@ -170,7 +172,6 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
|
||||
transportHost = "localhost",
|
||||
tcpTimeout = 15_000_000,
|
||||
rcvConcurrency = 8,
|
||||
sendPings,
|
||||
lastReceived,
|
||||
timeoutErrorCount,
|
||||
@@ -188,7 +189,9 @@ type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg
|
||||
type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg)
|
||||
|
||||
-- | Type synonym for transmission from some SPM server queue.
|
||||
type ServerTransmission v msg = (TransportSession msg, Version v, SessionId, Bool, EntityId, msg)
|
||||
type ServerTransmission v err msg = (TransportSession msg, Version v, SessionId, TransmissionType msg, EntityId, Either (ProtocolClientError err) msg)
|
||||
|
||||
data TransmissionType msg = TTEvent | TTUncorrelatedResponse | TTExpiredResponse (ProtoCommand msg)
|
||||
|
||||
data HostMode
|
||||
= -- | prefer (or require) onion hosts when connecting via SOCKS proxy
|
||||
@@ -287,6 +290,8 @@ defaultSMPClientConfig = defaultClientConfig (Just supportedSMPHandshakes) suppo
|
||||
data Request err msg = Request
|
||||
{ corrId :: CorrId,
|
||||
entityId :: EntityId,
|
||||
command :: ProtoCommand msg,
|
||||
pending :: TVar Bool,
|
||||
responseVar :: TMVar (Either (ProtocolClientError err) msg)
|
||||
}
|
||||
|
||||
@@ -333,7 +338,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 v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmission v msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmission v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do
|
||||
case chooseTransportHost networkConfig (host srv) of
|
||||
Right useHost ->
|
||||
@@ -341,7 +346,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
|
||||
Left e -> pure $ Left e
|
||||
where
|
||||
NetworkConfig {tcpConnectTimeout, tcpTimeout, rcvConcurrency, smpPingInterval} = networkConfig
|
||||
NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
|
||||
mkProtocolClient :: TransportHost -> UTCTime -> STM (PClient v err msg)
|
||||
mkProtocolClient transportHost ts = do
|
||||
connected <- newTVar False
|
||||
@@ -363,7 +368,6 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
timeoutErrorCount,
|
||||
clientCorrId,
|
||||
sentCommands,
|
||||
rcvConcurrency,
|
||||
sndQ,
|
||||
rcvQ,
|
||||
msgQ
|
||||
@@ -402,11 +406,11 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
atomically $ do
|
||||
writeTVar (connected c) True
|
||||
putTMVar cVar $ Right c'
|
||||
raceAny_ ([send c' th, process c', receive c' th] <> [ping c' | smpPingInterval > 0])
|
||||
raceAny_ ([send c' th, process c', receive c' th] <> [monitor c' | smpPingInterval > 0])
|
||||
`finally` disconnected c'
|
||||
|
||||
send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
|
||||
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= \(active, s) -> whenM (readTVarIO active) (void $ tPutLog h s)
|
||||
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= void . tPutLog h
|
||||
|
||||
receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
|
||||
receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do
|
||||
@@ -414,8 +418,8 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
getCurrentTime >>= atomically . writeTVar lastReceived
|
||||
atomically $ writeTVar timeoutErrorCount 0
|
||||
|
||||
ping :: ProtocolClient v err msg -> IO ()
|
||||
ping c@ProtocolClient {client_ = PClient {sendPings, lastReceived, timeoutErrorCount}} = loop smpPingInterval
|
||||
monitor :: ProtocolClient v err msg -> IO ()
|
||||
monitor c@ProtocolClient {client_ = PClient {sendPings, lastReceived, timeoutErrorCount}} = loop smpPingInterval
|
||||
where
|
||||
loop :: Int64 -> IO ()
|
||||
loop delay = do
|
||||
@@ -439,27 +443,34 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
|
||||
processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO ()
|
||||
processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
|
||||
| isResponse =
|
||||
| not $ B.null $ bs corrId =
|
||||
atomically (TM.lookup corrId sentCommands) >>= \case
|
||||
Nothing -> sendMsg respOrErr
|
||||
Just Request {entityId, responseVar} -> atomically $ do
|
||||
TM.delete corrId sentCommands
|
||||
putTMVar responseVar $ response entityId
|
||||
| otherwise = sendMsg respOrErr
|
||||
Nothing -> sendMsg TTUncorrelatedResponse
|
||||
Just Request {entityId, command, pending, responseVar} -> do
|
||||
wasPending <-
|
||||
atomically $ do
|
||||
TM.delete corrId sentCommands
|
||||
ifM
|
||||
(swapTVar pending False)
|
||||
(True <$ tryPutTMVar responseVar (response entityId))
|
||||
(pure False)
|
||||
unless wasPending $ sendMsg $ if entityId == entId then TTExpiredResponse command else TTUncorrelatedResponse
|
||||
| otherwise = sendMsg TTEvent
|
||||
where
|
||||
isResponse = not $ B.null $ bs corrId
|
||||
response entityId
|
||||
| entityId == entId =
|
||||
case respOrErr of
|
||||
Left e -> Left $ PCEResponseError e
|
||||
Right r -> case protocolError r of
|
||||
Just e -> Left $ PCEProtocolError e
|
||||
_ -> Right r
|
||||
| entityId == entId = clientResp
|
||||
| otherwise = Left . PCEUnexpectedResponse $ bshow respOrErr
|
||||
sendMsg :: Either err msg -> IO ()
|
||||
sendMsg = \case
|
||||
Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c isResponse entId msg) msgQ
|
||||
Left e -> putStrLn $ "SMP client error: " <> show e
|
||||
clientResp = case respOrErr of
|
||||
Left e -> Left $ PCEResponseError e
|
||||
Right r -> case protocolError r of
|
||||
Just e -> Left $ PCEProtocolError e
|
||||
_ -> Right r
|
||||
sendMsg :: TransmissionType msg -> IO ()
|
||||
sendMsg tType = case msgQ of
|
||||
Just q -> atomically $ writeTBQueue q $ serverTransmission c tType entId clientResp
|
||||
Nothing -> case clientResp of
|
||||
Left e -> logError $ "SMP client error: " <> tshow e
|
||||
Right _ -> logWarn $ "SMP client unprocessed event"
|
||||
|
||||
proxyUsername :: TransportSession msg -> ByteString
|
||||
proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
|
||||
@@ -558,11 +569,11 @@ processSUBResponse c (Response rId r) = case r of
|
||||
Left e -> pure $ Left e
|
||||
|
||||
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
|
||||
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c False rId msg) (msgQ $ client_ c)
|
||||
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c TTEvent rId (Right msg)) (msgQ $ client_ c)
|
||||
|
||||
serverTransmission :: ProtocolClient v err msg -> Bool -> RecipientId -> msg -> ServerTransmission v msg
|
||||
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} isResponse entityId message =
|
||||
(transportSession, thVersion, sessionId, isResponse, entityId, message)
|
||||
serverTransmission :: ProtocolClient v err msg -> TransmissionType msg -> RecipientId -> Either (ProtocolClientError err) msg -> ServerTransmission v err msg
|
||||
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} tType entityId msgOrErr =
|
||||
(transportSession, thVersion, sessionId, tType, entityId, msgOrErr)
|
||||
|
||||
-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
|
||||
--
|
||||
@@ -687,7 +698,7 @@ sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
|
||||
type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg)
|
||||
|
||||
-- | Send multiple commands with batching and collect responses
|
||||
sendProtocolCommands :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
|
||||
sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
|
||||
sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
|
||||
bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
|
||||
validate . concat =<< mapM (sendBatch c) bs
|
||||
@@ -704,30 +715,28 @@ sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSiz
|
||||
where
|
||||
diff = L.length cs - length rs
|
||||
|
||||
streamProtocolCommands :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
|
||||
streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
|
||||
streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs cb = do
|
||||
bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
|
||||
mapM_ (cb <=< sendBatch c) bs
|
||||
|
||||
sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
|
||||
sendBatch c@ProtocolClient {client_ = PClient {rcvConcurrency, sndQ}} b = do
|
||||
sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
|
||||
case b of
|
||||
TBError e Request {entityId} -> do
|
||||
putStrLn "send error: large message"
|
||||
pure [Response entityId $ Left $ PCETransportError e]
|
||||
TBTransmissions s n rs
|
||||
| n > 0 -> do
|
||||
active <- newTVarIO True
|
||||
atomically $ writeTBQueue sndQ (active, s)
|
||||
mapConcurrently (getResponse c active) rs
|
||||
atomically $ writeTBQueue sndQ s
|
||||
mapConcurrently (getResponse c) rs
|
||||
| otherwise -> pure []
|
||||
TBTransmission s r -> do
|
||||
active <- newTVarIO True
|
||||
atomically $ writeTBQueue sndQ (active, s)
|
||||
(: []) <$> getResponse c active r
|
||||
atomically $ writeTBQueue sndQ s
|
||||
(: []) <$> getResponse c r
|
||||
|
||||
-- | Send Protocol command
|
||||
sendProtocolCommand :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} pKey entId cmd =
|
||||
ExceptT $ uncurry sendRecv =<< mkTransmission c (pKey, entId, cmd)
|
||||
where
|
||||
@@ -738,30 +747,30 @@ sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, thParams = THand
|
||||
Right t
|
||||
| B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
|
||||
| otherwise -> do
|
||||
active <- newTVarIO True
|
||||
atomically (writeTBQueue sndQ (active, s))
|
||||
response <$> getResponse c active r
|
||||
atomically $ writeTBQueue sndQ s
|
||||
response <$> getResponse c r
|
||||
where
|
||||
s
|
||||
| batch = tEncodeBatch1 t
|
||||
| otherwise = tEncode t
|
||||
|
||||
-- TODO switch to timeout or TimeManager that supports Int64
|
||||
getResponse :: ProtocolClient v err msg -> TVar Bool -> Request err msg -> IO (Response err msg)
|
||||
getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount, sentCommands}} active Request {corrId, entityId, responseVar} = do
|
||||
response <-
|
||||
timeout tcpTimeout (atomically (takeTMVar responseVar)) >>= \case
|
||||
Just r -> atomically (writeTVar timeoutErrorCount 0) $> r
|
||||
Nothing -> do
|
||||
atomically (writeTVar active False >> TM.delete corrId sentCommands)
|
||||
atomically $ modifyTVar' timeoutErrorCount (+ 1)
|
||||
pure $ Left PCEResponseTimeout
|
||||
getResponse :: ProtocolClient v err msg -> Request err msg -> IO (Response err msg)
|
||||
getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} Request {entityId, pending, responseVar} = do
|
||||
r <- tcpTimeout `timeout` atomically (takeTMVar responseVar)
|
||||
response <- atomically $ do
|
||||
writeTVar pending False
|
||||
-- Try to read response again in case it arrived after timeout expired
|
||||
-- but before `pending` was set to False above.
|
||||
-- See `processMsg`.
|
||||
((r <|>) <$> tryTakeTMVar responseVar) >>= \case
|
||||
Just r' -> writeTVar timeoutErrorCount 0 $> r'
|
||||
Nothing -> modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout
|
||||
pure Response {entityId, response}
|
||||
|
||||
mkTransmission :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
|
||||
mkTransmission ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} (pKey_, entId, cmd) = do
|
||||
mkTransmission :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
|
||||
mkTransmission ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} (pKey_, entityId, command) = do
|
||||
corrId <- atomically getNextCorrId
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, entId, cmd)
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, entityId, command)
|
||||
auth = authTransmission (thAuth thParams) pKey_ corrId tForAuth
|
||||
r <- atomically $ mkRequest corrId
|
||||
pure ((,tToSend) <$> auth, r)
|
||||
@@ -770,7 +779,16 @@ mkTransmission ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCo
|
||||
getNextCorrId = CorrId <$> C.randomBytes 24 clientCorrId -- also used as nonce
|
||||
mkRequest :: CorrId -> STM (Request err msg)
|
||||
mkRequest corrId = do
|
||||
r <- Request corrId entId <$> newEmptyTMVar
|
||||
pending <- newTVar True
|
||||
responseVar <- newEmptyTMVar
|
||||
let r =
|
||||
Request
|
||||
{ corrId,
|
||||
entityId,
|
||||
command,
|
||||
pending,
|
||||
responseVar
|
||||
}
|
||||
TM.insert corrId r sentCommands
|
||||
pure r
|
||||
|
||||
|
||||
Reference in New Issue
Block a user