From 9f1aab636b55516fb52822104d671b21ec33a621 Mon Sep 17 00:00:00 2001 From: sh Date: Mon, 6 Jul 2026 12:33:48 +0000 Subject: [PATCH 01/43] smp-server: add leak diagnostics logging Add an exception-guarded periodic thread that logs a single greppable "LEAKDIAG" line censusing every growable in-memory structure: live threads, per-client endThreads and subscriptions (by SubThread state), subscriber maps, ntf store, store entity/loaded counts, and proxy agent maps with in-flight sentCommands. Interval via SMP_LEAKDIAG_SEC (default 60), no RTS flags required. Adds pClientSentCommandsCount and getAgentLeakStats accessors. --- src/Simplex/Messaging/Client.hs | 6 ++ src/Simplex/Messaging/Client/Agent.hs | 29 +++++++ src/Simplex/Messaging/Server.hs | 113 +++++++++++++++++++++++++- 3 files changed, 147 insertions(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 6f5234558..bfb9ad2b7 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -35,6 +35,7 @@ module Simplex.Messaging.Client ProxiedRelay (..), getProtocolClient, closeProtocolClient, + pClientSentCommandsCount, protocolClientServer, protocolClientServer', transportHost', @@ -167,6 +168,7 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Protocol.Types import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.SimplexName (SimplexDomain) +import qualified Data.Map.Strict as M import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport @@ -737,6 +739,10 @@ useWebPort cfg presetDomains ProtocolServer {host = h :| _} = case smpWebPortSer SWPPreset -> isPresetDomain presetDomains h SWPOff -> False +-- | Count of in-flight (awaiting-response) commands on a client - for leak diagnostics. +pClientSentCommandsCount :: ProtocolClient v err msg -> IO Int +pClientSentCommandsCount ProtocolClient {client_ = PClient {sentCommands}} = M.size <$> readTVarIO sentCommands + isPresetDomain :: [HostName] -> TransportHost -> Bool isPresetDomain presetDomains = \case THDomainName h -> any (`isSuffixOf` h) presetDomains diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 0d59f00b8..e2a4916e6 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -31,6 +31,8 @@ module Simplex.Messaging.Client.Agent removeActiveSubs, removePendingSub, removePendingSubs, + AgentLeakStats (..), + getAgentLeakStats, ) where @@ -158,6 +160,33 @@ data SMPClientAgent p = SMPClientAgent type OwnServer = Bool +-- | Sizes of every per-server/per-session map in the client agent, plus total in-flight +-- forwarded commands - for leak diagnostics on the proxy path. +data AgentLeakStats = AgentLeakStats + { alSmpClients :: Int, + alSmpSessions :: Int, + alActiveServiceSubs :: Int, + alActiveQueueSubs :: Int, + alPendingServiceSubs :: Int, + alPendingQueueSubs :: Int, + alSmpSubWorkers :: Int, + alSentCommands :: Int + } + +getAgentLeakStats :: SMPClientAgent p -> IO AgentLeakStats +getAgentLeakStats SMPClientAgent {smpClients, smpSessions, activeServiceSubs, activeQueueSubs, pendingServiceSubs, pendingQueueSubs, smpSubWorkers} = do + alSmpClients <- msize smpClients + sess <- readTVarIO smpSessions + alActiveServiceSubs <- msize activeServiceSubs + alActiveQueueSubs <- msize activeQueueSubs + alPendingServiceSubs <- msize pendingServiceSubs + alPendingQueueSubs <- msize pendingQueueSubs + alSmpSubWorkers <- msize smpSubWorkers + alSentCommands <- foldM (\ !a (_, c) -> (a +) <$> pClientSentCommandsCount c) 0 (M.elems sess) + pure AgentLeakStats {alSmpClients, alSmpSessions = M.size sess, alActiveServiceSubs, alActiveQueueSubs, alPendingServiceSubs, alPendingQueueSubs, alSmpSubWorkers, alSentCommands} + where + msize m = M.size <$> readTVarIO m + newSMPClientAgent :: SParty p -> SMPClientAgentConfig -> Maybe DBService -> TVar ChaChaDRG -> IO (SMPClientAgent p) newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} dbService randomDrg = do active <- newTVarIO True diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 16ad58ab3..2d2ef3074 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -99,7 +99,7 @@ import qualified Network.TLS as TLS import Numeric.Natural (Natural) import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, smpProxyError, temporaryClientError) -import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient) +import Simplex.Messaging.Client.Agent (AgentLeakStats (..), OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getAgentLeakStats, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -129,6 +129,7 @@ import Simplex.Messaging.Transport.Server import Simplex.Messaging.Util import Simplex.Messaging.Version import System.Environment (lookupEnv) +import Text.Read (readMaybe) import System.Exit (exitFailure, exitSuccess) import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode) import System.Mem.Weak (deRefWeak) @@ -175,6 +176,23 @@ data ClientSubAction type PrevClientSub s = (Client s, ClientSubAction, (EntityId, BrokerMsg)) +-- accumulator for per-client leak diagnostics (summed across all connected clients) +data ClientAgg = ClientAgg + { aggEndThreads :: !Int, -- Weak ThreadId registrations in endThreads (forkClient leak) + aggEndThreadSeq :: !Int, -- total forkClient forks ever (fork rate) + aggProcThreads :: !Int, + aggSubs :: !Int, -- entries in per-client subscriptions map + aggNoSub :: !Int, + aggPending :: !Int, -- SubPending: forked delivery threads not yet completed (blocked-thread candidates) + aggThread :: !Int, -- SubThread: live delivery threads + aggProhibit :: !Int, + aggNtfSubs :: !Int, + aggSvcSubsCount :: !Int, + aggRcvQ :: !Int, + aggSndQ :: !Int, -- full sndQ => forkDeliver blocks (leak trigger) + aggMsgQ :: !Int + } + smpServer :: forall s. MsgStoreClass s => TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> M s () smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOptions} attachHTTP_ = do s <- asks server @@ -192,6 +210,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ( serverThread "server subscribers" s subscribers subscriptions serviceSubsCount (Just cancelSub) : serverThread "server ntfSubscribers" s ntfSubscribers ntfSubscriptions ntfServiceSubsCount Nothing : deliverNtfsThread s + : leakDiagnosticsThread s : sendPendingEvtsThread s : receiveFromProxyAgent pa : expireNtfsThread cfg @@ -497,6 +516,98 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt printMessageStats "STORE: messages" msgStats Left e -> logError $ "STORE: expireOldMessages, error expiring messages, " <> tshow e + -- Periodic comprehensive leak diagnostics: sizes of every growable structure in the + -- server, summed across clients, plus the proxy agent. Interval seconds via SMP_LEAKDIAG_SEC + -- (default 60). A single greppable "LEAKDIAG ..." line per interval; whichever counter grows + -- monotonically over time is the leak. + leakDiagnosticsThread :: Server s -> M s () + leakDiagnosticsThread srv = do + secStr <- liftIO $ lookupEnv "SMP_LEAKDIAG_SEC" + let sec = max 5 $ fromMaybe 60 (secStr >>= readMaybe) + ms <- asks msgStore + ns <- asks ntfStore + ProxyAgent {smpAgent} <- asks proxyAgent + labelMyThread "leakDiagnosticsThread" + -- never let a diagnostics error crash the server (this thread is in raceAny_) + liftIO $ forever $ do + threadDelay $ sec * 1000000 + tryAny (logLeakStats srv ms ns smpAgent) >>= either (logError . ("LEAKDIAG error: " <>) . tshow) (const $ pure ()) + + logLeakStats :: Server s -> s -> NtfStore -> SMPClientAgent 'Sender -> IO () + logLeakStats srv ms (NtfStore nsv) smpAgent = do +#if MIN_VERSION_base(4,18,0) + nThreads <- length <$> listThreads +#else + let nThreads = 0 :: Int +#endif + cls <- IM.elems <$> getServerClients srv + cc <- foldM accClient emptyAgg cls + (smpQ, smpS, smpC, smpT, smpP) <- subAgg (subscribers srv) + (ntfQ, ntfS, ntfC, ntfT, ntfP) <- subAgg (ntfSubscribers srv) + ntfMap <- readTVarIO nsv + ntfMsgs <- foldM (\ !a v -> (a +) . length <$> readTVarIO v) (0 :: Int) (M.elems ntfMap) + EntityCounts {queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount} <- getEntityCounts @(StoreQueue s) (queueStore ms) + LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount, queueLockCount, notifierLockCount} <- loadedQueueCounts ms + AgentLeakStats {alSmpClients, alSmpSessions, alActiveServiceSubs, alActiveQueueSubs, alPendingServiceSubs, alPendingQueueSubs, alSmpSubWorkers, alSentCommands} <- getAgentLeakStats smpAgent + logNote $ + T.concat + [ "LEAKDIAG", + f "threads" nThreads, f "clients" (length cls), + f "endThreads" (aggEndThreads cc), f "endThreadSeq" (aggEndThreadSeq cc), f "procThreads" (aggProcThreads cc), + f "subs" (aggSubs cc), f "subs_nosub" (aggNoSub cc), f "subs_pending" (aggPending cc), f "subs_thread" (aggThread cc), f "subs_prohibit" (aggProhibit cc), + f "ntfSubsClient" (aggNtfSubs cc), f "svcSubsCount" (aggSvcSubsCount cc), + f "rcvQ" (aggRcvQ cc), f "sndQ" (aggSndQ cc), f "msgQ" (aggMsgQ cc), + f "smp_qSubscribers" smpQ, f "smp_svcSubscribers" smpS, f "smp_subClients" smpC, f "smp_totalSvcSubs" smpT, f "smp_pendingEvents" smpP, + f "ntf_qSubscribers" ntfQ, f "ntf_svcSubscribers" ntfS, f "ntf_subClients" ntfC, f "ntf_totalSvcSubs" ntfT, f "ntf_pendingEvents" ntfP, + f "ntfStore_keys" (M.size ntfMap), f "ntfStore_msgs" ntfMsgs, + f "store_queues" queueCount, f "store_notifiers" notifierCount, f "store_rcvServices" rcvServiceCount, f "store_ntfServices" ntfServiceCount, f "store_rcvSvcQueues" rcvServiceQueuesCount, f "store_ntfSvcQueues" ntfServiceQueuesCount, + f "loaded_queues" loadedQueueCount, f "loaded_notifiers" loadedNotifierCount, f "open_journals" openJournalCount, f "queue_locks" queueLockCount, f "notifier_locks" notifierLockCount, + f "proxy_smpClients" alSmpClients, f "proxy_smpSessions" alSmpSessions, f "proxy_activeSvcSubs" alActiveServiceSubs, f "proxy_activeQSubs" alActiveQueueSubs, f "proxy_pendingSvcSubs" alPendingServiceSubs, f "proxy_pendingQSubs" alPendingQueueSubs, f "proxy_subWorkers" alSmpSubWorkers, f "proxy_sentCommands" alSentCommands + ] + where + f :: Show a => Text -> a -> Text + f k v = " " <> k <> "=" <> tshow v + emptyAgg = ClientAgg 0 0 0 0 0 0 0 0 0 0 0 0 0 + accClient !agg Client {subscriptions, ntfSubscriptions, serviceSubsCount, procThreads, endThreads, endThreadSeq, rcvQ, sndQ, msgQ} = do + et <- IM.size <$> readTVarIO endThreads + es <- readTVarIO endThreadSeq + pt <- readTVarIO procThreads + subs <- readTVarIO subscriptions + (no, pe, th, pr) <- foldM accSub (0, 0, 0, 0) (M.elems subs) + nt <- M.size <$> readTVarIO ntfSubscriptions + sc <- fst <$> readTVarIO serviceSubsCount + (rl, sl, ml) <- atomically $ (,,) <$> lengthTBQueue rcvQ <*> lengthTBQueue sndQ <*> lengthTBQueue msgQ + pure + agg + { aggEndThreads = aggEndThreads agg + et, + aggEndThreadSeq = aggEndThreadSeq agg + es, + aggProcThreads = aggProcThreads agg + pt, + aggSubs = aggSubs agg + M.size subs, + aggNoSub = aggNoSub agg + no, + aggPending = aggPending agg + pe, + aggThread = aggThread agg + th, + aggProhibit = aggProhibit agg + pr, + aggNtfSubs = aggNtfSubs agg + nt, + aggSvcSubsCount = aggSvcSubsCount agg + fromIntegral sc, + aggRcvQ = aggRcvQ agg + fromIntegral rl, + aggSndQ = aggSndQ agg + fromIntegral sl, + aggMsgQ = aggMsgQ agg + fromIntegral ml + } + accSub (no, pe, th, pr) Sub {subThread} = case subThread of + ServerSub t -> + readTVarIO t >>= \case + NoSub -> pure (no + 1, pe, th, pr) + SubPending -> pure (no, pe + 1, th, pr) + SubThread _ -> pure (no, pe, th + 1, pr) + ProhibitSub -> pure (no, pe, th, pr + 1) + subAgg ServerSubscribers {queueSubscribers, serviceSubscribers, subClients, totalServiceSubs, pendingEvents} = do + q <- M.size <$> getSubscribedClients queueSubscribers + s' <- M.size <$> getSubscribedClients serviceSubscribers + sc <- IS.size <$> readTVarIO subClients + ts <- fst <$> readTVarIO totalServiceSubs + pe <- IM.size <$> readTVarIO pendingEvents + pure (q, s', sc, ts, pe) + expireNtfsThread :: ServerConfig s -> M s () expireNtfsThread ServerConfig {notificationExpiration = expCfg} = do ns <- asks ntfStore From dcfb2921cff9a25539c3f15ea7c8ce0cff8df3d0 Mon Sep 17 00:00:00 2001 From: sh Date: Mon, 6 Jul 2026 12:33:48 +0000 Subject: [PATCH 02/43] tests: add smp-server memory leak load bench Standalone smp-mem-bench executable that starts an in-process SMP server and drives churn workloads, reporting GHC live-heap residency per checkpoint after a forced major GC. Store selectable via BENCHSTORE (pgmsg/pgjournal/journal). Phases: plain, svc, svcrace, ntf, conc, svcsubs, getp, link, and leak repros - stuck (delivery threads blocked forever on a full sndQ), certchurn (serviceLocks/services grow per distinct service certificate), and ntfexp (NtfStore keys retained after notifications expire). --- bench/MemBench.hs | 452 ++++++++++++++++++++++++++++++++++++++++++++++ simplexmq.cabal | 44 +++++ 2 files changed, 496 insertions(+) create mode 100644 bench/MemBench.hs diff --git a/bench/MemBench.hs b/bench/MemBench.hs new file mode 100644 index 000000000..e1d432f79 --- /dev/null +++ b/bench/MemBench.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +-- | Memory-leak load driver for the SMP server. +-- +-- Starts an in-process SMP server (beta.2 code) and hammers a chosen command +-- path in a churn loop, printing GHC live-heap residency (measured after a +-- forced major GC) every checkpoint. A path whose residency climbs with the +-- iteration count is leaking; a flat path is clean. +-- +-- Usage: smp-mem-bench +-- phases: plain | svc | svcrace | ntf +module Main (main) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (concurrently_, mapConcurrently_, withAsync) +import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) +import Control.Concurrent.STM +import Control.Monad +import Crypto.Random (ChaChaDRG) +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Char8 (ByteString) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.X509.Validation as XV +import GHC.Stats +import SMPClient +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (notificationExpiration)) +import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) +import Simplex.Messaging.Transport +import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) +import System.Environment (getArgs, lookupEnv) +import System.Mem (performMajorGC) +import System.Timeout (timeout) +import Text.Printf (printf) + +type H = THandleSMP TLS 'TClient + +-- store config: PostgreSQL (matches production) when built with -fserver_postgres, else journal +benchCfg :: AServerConfig +#if defined(dbServerPostgres) +benchCfg = cfgMS (ASType SQSPostgres SMSPostgres) +#else +benchCfg = cfg +#endif + +-- command helpers (copied from tests/ServerTests.hs) ------------------------ + +pattern Resp :: CorrId -> QueueId -> BrokerMsg -> Transmission (Either ErrorType BrokerMsg) +pattern Resp corrId queueId command <- (corrId, queueId, Right command) + +pattern New :: RcvPublicAuthKey -> RcvPublicDhKey -> Command 'Creator +pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) Nothing) + +pattern New0 :: RcvPublicAuthKey -> RcvPublicDhKey -> Command 'Creator +pattern New0 rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMOnlyCreate (Just (QRMessaging Nothing)) Nothing) + +pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg +pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId Nothing Nothing) + +pattern Ids_ :: RecipientId -> SenderId -> RcvPublicDhKey -> ServiceId -> BrokerMsg +pattern Ids_ rId sId srvDh serviceId <- IDS (QIK rId sId srvDh _sndSecure _linkId (Just serviceId) Nothing) + +pattern Msg :: MsgId -> MsgBody -> BrokerMsg +pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} + +_SEND :: MsgBody -> Command 'Sender +_SEND = SEND noMsgFlags + +_SEND' :: MsgBody -> Command 'Sender +_SEND' = SEND MsgFlags {notification = True} + +sendRecv :: forall p. PartyI p => H -> (Maybe TAuthorizations, ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg)) +sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do + let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) + Right () <- tPut1 h (sgn, tToSend) + tGet1 h + +signSendRecv :: forall p. PartyI p => H -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg)) +signSendRecv h pk t = do + [r] <- signSendRecv_ h pk Nothing t + pure r + +serviceSignSendRecv :: forall p. PartyI p => H -> C.APrivateAuthKey -> C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg)) +serviceSignSendRecv h pk serviceKey t = do + [r] <- signSendRecv_ h pk (Just serviceKey) t + pure r + +signSendRecv_ :: forall p. PartyI p => H -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg))) +signSendRecv_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) + Right () <- tPut1 h (authorize tForAuth, tToSend) + tGetClient h + where + authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of + C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t' + C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t' + C.SX25519 -> (\THAuthClient {peerServerPubKey = k} -> TAAuthenticator $ C.cbAuthenticate k pk (C.cbNonce corrId) t') <$> thAuth params +#if !MIN_VERSION_base(4,18,0) + _sx448 -> undefined +#endif + where + t' = case (serviceKey_, thAuth params >>= clientService) of + (Just _, Just THClientService {serviceCertHash = XV.Fingerprint fp}) -> fp <> t + _ -> t + +tPut1 :: H -> SentRawTransmission -> IO (Either TransportError ()) +tPut1 h t = do + [r] <- tPut h [Right t] + pure r + +tGet1 :: H -> IO (Transmission (Either ErrorType BrokerMsg)) +tGet1 h = do + [r] <- tGetClient h + pure r + +-- read and discard any pending transmissions until quiet, to resync after a race +drainAll :: H -> IO () +drainAll h = timeout 40000 (tGet1 h) >>= maybe (pure ()) (const $ drainAll h) + +-- measurement --------------------------------------------------------------- + +liveBytesMiB :: IO Double +liveBytesMiB = do + performMajorGC + s <- getRTSStats + pure $ fromIntegral (gcdetails_live_bytes (gc s)) / (1024 * 1024) + +report :: String -> Int -> Double -> Double -> IO () +report phase i base cur = + printf "%-8s iter=%7d live=%9.1f MiB delta=%+9.1f MiB (%+.4f KiB/iter)\n" + phase i cur (cur - base) (if i == 0 then 0 else (cur - base) * 1024 / fromIntegral i) + +withCheckpoints :: String -> Int -> Int -> (Int -> IO ()) -> IO () +withCheckpoints phase iters cp step = do + base <- liveBytesMiB + report phase 0 base base + forM_ ([1 .. iters] :: [Int]) $ \i -> do + step i + when (i `mod` cp == 0) $ liveBytesMiB >>= report phase i base + +-- phases -------------------------------------------------------------------- + +-- regular recipient: create+subscribe, send, receive, ack, delete (churn) +runPlain :: TVar ChaChaDRG -> Int -> Int -> IO () +runPlain g iters cp = + testSMPClient @TLS $ \recip -> + testSMPClient @TLS $ \sndr -> + withCheckpoints "plain" iters cp $ \i -> do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let corr = B.pack (show i) + Resp _ _ (Ids rId sId _srvDh) <- signSendRecv recip rKey (corr, NoEntity, New rPub dhPub) + Resp _ _ OK <- sendRecv sndr (Nothing, corr, sId, _SEND "hello") + Resp _ _ (Msg mId _) <- tGet1 recip + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, ACK mId) + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, DEL) + pure () + +-- recipient-service: create queue as service, send, service receives, ack, delete (churn) +runSvc :: TVar ChaChaDRG -> Int -> Int -> IO () +runSvc g iters cp = do + creds <- genCredentials g Nothing (0, 2400) "localhost" + let (_fp, tlsCred) = tlsCredentials (creds :| []) + serviceKeys@(_, servicePK) <- atomically $ C.generateKeyPair g + testSMPClient @TLS $ \sndr -> + testSMPServiceClient @TLS (tlsCred, serviceKeys) $ \sh -> + withCheckpoints "svc" iters cp $ \i -> do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let corr = B.pack (show i) + Resp _ _ (Ids_ rId sId _srvDh _serviceId) <- serviceSignSendRecv sh rKey servicePK (corr, NoEntity, New rPub dhPub) + Resp _ _ OK <- sendRecv sndr (Nothing, corr, sId, _SEND "hello") + Resp _ _ (Msg mId _) <- tGet1 sh + Resp _ _ OK <- signSendRecv sh rKey (corr, rId, ACK mId) + Resp _ _ OK <- signSendRecv sh rKey (corr, rId, DEL) + pure () + +-- recipient-service with concurrent SEND vs DEL to probe the TOCTOU orphan +runSvcRace :: TVar ChaChaDRG -> Int -> Int -> IO () +runSvcRace g iters cp = do + creds <- genCredentials g Nothing (0, 2400) "localhost" + let (_fp, tlsCred) = tlsCredentials (creds :| []) + serviceKeys@(_, servicePK) <- atomically $ C.generateKeyPair g + testSMPClient @TLS $ \sndr -> + testSMPServiceClient @TLS (tlsCred, serviceKeys) $ \sh -> + withCheckpoints "svcrace" iters cp $ \i -> do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let corr = B.pack (show i) + Resp _ _ (Ids_ rId sId _srvDh _serviceId) <- serviceSignSendRecv sh rKey servicePK (corr, NoEntity, New rPub dhPub) + -- race an in-flight SEND (creates delivery Sub) against queue deletion + concurrently_ + (void $ sendRecv sndr (Nothing, corr, sId, _SEND "hello")) + (void $ signSendRecv sh rKey (corr, rId, DEL)) + drainAll sh + +-- notifications: enable ntf on live queues and send ntf-flagged messages without draining +runNtf :: TVar ChaChaDRG -> Int -> Int -> IO () +runNtf g iters cp = + testSMPClient @TLS $ \recip -> + testSMPClient @TLS $ \sndr -> + withCheckpoints "ntf" iters cp $ \i -> do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (nPub, _nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvNtfPubDh, _dhNtfPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let corr = B.pack (show i) + Resp _ _ (Ids rId sId _srvDh) <- signSendRecv recip rKey (corr, NoEntity, New rPub dhPub) + Resp _ _ (NID _nId _) <- signSendRecv recip rKey (corr, rId, NKEY nPub rcvNtfPubDh) + -- ntf-flagged send stores a notification; no notifier subscribed -> stays in ntfStore + Resp _ _ OK <- sendRecv sndr (Nothing, corr, sId, _SEND' "hello") + Resp _ _ (Msg mId _) <- tGet1 recip + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, ACK mId) + pure () + +-- reusable steps ------------------------------------------------------------ + +genKeys :: TVar ChaChaDRG -> IO (RcvPublicAuthKey, C.APrivateAuthKey, RcvPublicDhKey) +genKeys g = do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + pure (rPub, rKey, dhPub) + +plainStep :: TVar ChaChaDRG -> H -> H -> Int -> IO () +plainStep g recip sndr i = do + (rPub, rKey, dhPub) <- genKeys g + let corr = B.pack (show i) + Resp _ _ (Ids rId sId _) <- signSendRecv recip rKey (corr, NoEntity, New rPub dhPub) + Resp _ _ OK <- sendRecv sndr (Nothing, corr, sId, _SEND "hello") + Resp _ _ (Msg mId _) <- tGet1 recip + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, ACK mId) + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, DEL) + pure () + +ntfStep :: TVar ChaChaDRG -> H -> H -> Int -> IO () +ntfStep g recip sndr i = do + (rPub, rKey, dhPub) <- genKeys g + (nPub, _nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvNtfPubDh, _dh :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let corr = B.pack (show i) + Resp _ _ (Ids rId sId _) <- signSendRecv recip rKey (corr, NoEntity, New rPub dhPub) + Resp _ _ (NID _ _) <- signSendRecv recip rKey (corr, rId, NKEY nPub rcvNtfPubDh) + Resp _ _ OK <- sendRecv sndr (Nothing, corr, sId, _SEND' "hello") + Resp _ _ (Msg mId _) <- tGet1 recip + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, ACK mId) + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, DEL) + pure () + +-- concurrency/scale: many client connections running a mixed workload +runConc :: TVar ChaChaDRG -> Int -> Int -> IO () +runConc g iters _cp = do + let nW = 8 + per = max 1 (iters `div` nW) + base <- liveBytesMiB + report "conc" 0 base base + counter <- newTVarIO (0 :: Int) + let target = nW * per + monitor = do + threadDelay 2000000 + c <- readTVarIO counter + cur <- liveBytesMiB + report "conc" c base cur + when (c < target) monitor + worker w = + testSMPClient @TLS $ \recip -> + testSMPClient @TLS $ \sndr -> + forM_ ([1 .. per] :: [Int]) $ \i -> do + (if i `mod` 3 == 0 then ntfStep else plainStep) g recip sndr (w * per + i) + atomically $ modifyTVar' counter (+ 1) + withAsync monitor $ \_ -> mapConcurrently_ worker ([0 .. nW - 1] :: [Int]) + cur <- liveBytesMiB + report "conc" target base cur + +-- service SUBS reconnect: a fixed set of service queues, reconnect+resubscribe each iteration +runSvcSubs :: TVar ChaChaDRG -> Int -> Int -> IO () +runSvcSubs g iters cp = do + creds <- genCredentials g Nothing (0, 2400) "localhost" + let (_fp, tlsCred) = tlsCredentials (creds :| []) + serviceKeys@(_, servicePK) <- atomically $ C.generateKeyPair g + let aServicePK = C.APrivateAuthKey C.SEd25519 servicePK + nQueues = 20 + -- create nQueues associated with the service (persisted in the store) + (serviceId, rIds) <- testSMPServiceClient @TLS (tlsCred, serviceKeys) $ \sh -> do + xs <- forM ([1 .. nQueues] :: [Int]) $ \j -> do + (rPub, rKey, dhPub) <- genKeys g + Resp _ _ (Ids_ rId _sId _ sid) <- serviceSignSendRecv sh rKey servicePK (B.pack ("c" <> show j), NoEntity, New rPub dhPub) + pure (rId, sid) + pure (snd (head xs), map fst xs) + let idsHash = queueIdsHash rIds + base <- liveBytesMiB + report "svcsubs" 0 base base + -- each iteration: fresh service connection, SUBS to resubscribe all queues, then disconnect + forM_ ([1 .. iters] :: [Int]) $ \i -> do + testSMPServiceClient @TLS (tlsCred, serviceKeys) $ \sh -> + void $ signSendRecv_ sh aServicePK Nothing (B.pack (show i), serviceId, SUBS (fromIntegral nQueues) idsHash) + when (i `mod` cp == 0) $ liveBytesMiB >>= report "svcsubs" i base + +-- GET path: create-only (unsubscribed) queue, send, GET (poll), ack, delete +runGet :: TVar ChaChaDRG -> Int -> Int -> IO () +runGet g iters cp = + testSMPClient @TLS $ \recip -> + testSMPClient @TLS $ \sndr -> + withCheckpoints "getp" iters cp $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + let corr = B.pack (show i) + Resp _ _ (Ids rId sId _) <- signSendRecv recip rKey (corr, NoEntity, New0 rPub dhPub) + Resp _ _ OK <- sendRecv sndr (Nothing, corr, sId, _SEND "hello") + Resp _ _ (Msg mId _) <- signSendRecv recip rKey (corr, rId, GET) + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, ACK mId) + Resp _ _ OK <- signSendRecv recip rKey (corr, rId, DEL) + pure () + +-- forkDeliver blocked in SubPending: a subscriber that never reads its sndQ. +-- Deliveries to a full sndQ fork a deliverThread that blocks forever -> threads/subs_thread grow. +runStuck :: TVar ChaChaDRG -> Int -> Int -> IO () +runStuck g iters cp = + testSMPClient @TLS $ \sndr -> + testSMPClient @TLS $ \recip -> do + -- phase 1: create + subscribe `iters` queues (recip reads only the IDS responses, no messages yet) + qs <- forM ([1 .. iters] :: [Int]) $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + Resp _ _ (Ids _rId sId _) <- signSendRecv recip rKey (B.pack ('c' : show i), NoEntity, New rPub dhPub) + pure sId + -- phase 2: send one message to each; recip never reads -> server delivery threads block on the full sndQ + base <- liveBytesMiB + report "stuck" 0 base base + forM_ (zip ([1 ..] :: [Int]) qs) $ \(i, sId) -> do + _ <- sendRecv sndr (Nothing, B.pack ('s' : show i), sId, _SEND "x") + when (i `mod` cp == 0) $ liveBytesMiB >>= report "stuck" i base + threadDelay 20000000 -- hold the subscriber open so diagnostics can sample the blocked threads + +-- serviceLocks + services never evicted: connect as a messaging service with a fresh certificate +-- each iteration. getCreateService (run in the handshake) adds a services row + serviceLocks entry +-- that is never removed -> store_rcvServices grows. +runCertChurn :: TVar ChaChaDRG -> Int -> Int -> IO () +runCertChurn g iters cp = do + base <- liveBytesMiB + report "certchurn" 0 base base + forM_ ([1 .. iters] :: [Int]) $ \i -> do + creds <- genCredentials g Nothing (0, 2400) "localhost" + let (_fp, tlsCred) = tlsCredentials (creds :| []) + serviceKeys <- atomically $ C.generateKeyPair g + testSMPServiceClient @TLS (tlsCred, serviceKeys) $ \_sh -> pure () + when (i `mod` cp == 0) $ liveBytesMiB >>= report "certchurn" i base + +-- LINK path coverage: create a queue with short-link data, update it (LSET), secure it via the +-- link (LKEY), delete the link data (LDEL), delete the queue. Exercises the links map on create +-- and delete. (Not a leak repro: the links-not-removed-on-delete bug only bites useCache=True.) +runLink :: TVar ChaChaDRG -> Int -> Int -> IO () +runLink g iters cp = + testSMPClient @TLS $ \r -> + testSMPClient @TLS $ \s -> + withCheckpoints "link" iters cp $ \i -> do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + C.CbNonce corrId <- atomically $ C.randomCbNonce g + let sId = EntityId $ B.take 24 $ C.sha3_384 corrId -- sender ID must be derived from corrId + ld = (EncDataBytes "fixed data", EncDataBytes "user data") + qrd = QRMessaging $ Just (sId, ld) + Resp _ NoEntity (IDS (QIK rId _sId _srvDh _qm (Just lnkId) _svc _ntf)) <- + signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) + Resp _ _ OK <- signSendRecv r rKey (B.pack ('a' : show i), rId, LSET lnkId ld) + Resp _ _ (LNK _sId2 _ld') <- signSendRecv s sKey (B.pack ('b' : show i), lnkId, LKEY sPub) + Resp _ _ OK <- signSendRecv r rKey (B.pack ('c' : show i), rId, LDEL) + Resp _ _ OK <- signSendRecv r rKey (B.pack ('d' : show i), rId, DEL) + pure () + +-- Note: the two proxy leaks are NOT reproducible in this load bench and are intentionally not +-- included. The sentCommands/PFWD-timeout leak needs a relay that keeps the session up but drops +-- RFWD (a mock relay). The empty-SessionVar leak is a precise disconnect-during-connect race +-- (reproduced deterministically by the SMPProxyTests unit test, not by a load loop). Both are +-- observable on a live proxy via the LEAKDIAG proxy_sentCommands / proxy_smpClients counters. + +-- NtfStore key-retention leak: store notifications in many notifier queues, then let them expire. +-- With the fix, deleteExpiredNtfs removes the emptied outer keys, so LEAKDIAG ntfStore_keys rises +-- during creation then falls to ~0 after expiry; without it, the empty keys are retained. +-- Run with the short-expiry config (see main) so expiry fires within the run. +runNtfExp :: TVar ChaChaDRG -> Int -> Int -> IO () +runNtfExp g iters _cp = + testSMPClient @TLS $ \recip -> + testSMPClient @TLS $ \sndr -> do + forM_ ([1 .. iters] :: [Int]) $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + (nPub, _nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvNtfPubDh, _dh :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let corr = B.pack (show i) + Resp _ _ (Ids rId sId _) <- signSendRecv recip rKey (corr, NoEntity, New0 rPub dhPub) + Resp _ _ (NID _nId _) <- signSendRecv recip rKey (corr, rId, NKEY nPub rcvNtfPubDh) + Resp _ _ OK <- sendRecv sndr (Nothing, corr, sId, _SEND' "hi") + pure () + base <- liveBytesMiB + report "ntfexp" iters base base + -- hold while notifications expire; LEAKDIAG samples ntfStore_keys over this window + forM_ ([1 .. 12] :: [Int]) $ \k -> threadDelay 5000000 >> (liveBytesMiB >>= report "ntfexp" (iters * 10 + k) base) + +-- store config selectable via BENCHSTORE env: pgmsg (default, useCache=False) | pgjournal (useCache=True) | journal +srvStoreCfg :: Maybe String -> AServerConfig +srvStoreCfg = \case +#if defined(dbServerPostgres) + Just "pgjournal" -> cfgMS (ASType SQSPostgres SMSJournal) + Just "journal" -> cfgMS (ASType SQSMemory SMSJournal) + _ -> cfgMS (ASType SQSPostgres SMSPostgres) +#else + _ -> cfg +#endif + +main :: IO () +main = do + args <- getArgs + let (phase, iters) = case args of + (p : n : _) -> (p, read n) + [p] -> (p, 20000) + _ -> ("svc", 20000) + cp = max 1 (iters `div` 20) + g <- C.newRandom + storeEnv <- lookupEnv "BENCHSTORE" + -- ntfexp uses a short notification-expiration so deleteExpiredNtfs fires within the run + let srvCfg = case phase of + "ntfexp" -> updateCfg (srvStoreCfg storeEnv) $ \c -> c {notificationExpiration = ExpirationConfig {ttl = 2, checkInterval = 3}} + _ -> srvStoreCfg storeEnv + setLogLevel LogInfo + withGlobalLogging LogConfig {lc_file = Nothing, lc_stderr = True} $ + withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> do + threadDelay 250000 + case phase of + "plain" -> runPlain g iters cp + "svc" -> runSvc g iters cp + "svcrace" -> runSvcRace g iters cp + "ntf" -> runNtf g iters cp + "conc" -> runConc g iters cp + "svcsubs" -> runSvcSubs g iters cp + "getp" -> runGet g iters cp + "stuck" -> runStuck g iters cp + "certchurn" -> runCertChurn g iters cp + "link" -> runLink g iters cp + "ntfexp" -> runNtfExp g iters cp + _ -> error $ "unknown phase: " <> phase diff --git a/simplexmq.cabal b/simplexmq.cabal index 8d331c4a3..c732c55d3 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -657,3 +657,47 @@ test-suite simplexmq-test if flag(client_postgres) || flag(server_postgres) build-depends: postgresql-simple ==0.7.* + +executable smp-mem-bench + if flag(client_library) + buildable: False + main-is: MemBench.hs + other-modules: + SMPClient + Util + hs-source-dirs: + bench + tests + default-extensions: + StrictData + ghc-options: -Wall -Wno-unused-imports -Wno-unused-top-binds -Wno-name-shadowing -threaded -rtsopts "-with-rtsopts=-T" + build-depends: + base + , async + , bytestring + , containers + , crypton + , crypton-x509 + , crypton-x509-store + , crypton-x509-validation + , directory + , hspec ==2.11.* + , hspec-core ==2.11.* + , mtl + , network + , process + , simple-logger + , simplexmq + , sqlcipher-simple + , stm + , text + , time + , tls >=1.9.0 && <1.10 + , transformers + , unliftio + , unliftio-core + if flag(server_postgres) + cpp-options: -DdbServerPostgres + build-depends: + postgresql-simple ==0.7.* + default-language: Haskell2010 From 77699740f44a770428ee589d7e78f1a352d4a9c4 Mon Sep 17 00:00:00 2001 From: sh Date: Mon, 6 Jul 2026 12:33:48 +0000 Subject: [PATCH 03/43] smp-server: fix notification store key retention leak deleteExpiredNtfs trimmed each notifier's message list but never removed the outer NtfStore map key, so one empty entry per notifier queue that ever received a notification was retained forever (grows with the active notifier set, never shrinks). Remove the outer key when its list becomes empty, and make storeNtf fully atomic so it cannot race the removal and write a notification to an orphaned TVar. Verified with the load bench (ntfexp): after expiry ntfStore_keys drops from the queue count to 0 instead of staying flat. --- src/Simplex/Messaging/Server/NtfStore.hs | 28 ++++++++++-------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/src/Simplex/Messaging/Server/NtfStore.hs b/src/Simplex/Messaging/Server/NtfStore.hs index b73fd4860..711072303 100644 --- a/src/Simplex/Messaging/Server/NtfStore.hs +++ b/src/Simplex/Messaging/Server/NtfStore.hs @@ -33,13 +33,10 @@ data MsgNtf = MsgNtf } storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO () -storeNtf (NtfStore ns) nId ntf = do - TM.lookupIO nId ns >>= atomically . maybe newNtfs (`modifyTVar'` (ntf :)) +storeNtf (NtfStore ns) nId ntf = -- TODO [ntfdb] coalesce messages here once the client is updated to process multiple messages -- for single notification. - -- when (isJust prevNtf) $ incStat $ msgNtfReplaced stats - where - newNtfs = TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :)) + atomically $ TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :)) deleteNtfs :: NtfStore -> NotifierId -> IO Int deleteNtfs (NtfStore ns) nId = atomically (TM.lookupDelete nId ns) >>= maybe (pure 0) (fmap length . readTVarIO) @@ -48,18 +45,17 @@ deleteExpiredNtfs :: NtfStore -> Int64 -> IO Int deleteExpiredNtfs (NtfStore ns) old = foldM (\expired -> fmap (expired +) . expireQueue) 0 . M.keys =<< readTVarIO ns where - expireQueue nId = TM.lookupIO nId ns >>= maybe (pure 0) expire - expire v = readTVarIO v >>= \case - [] -> pure 0 - _ -> - atomically $ readTVar v >>= \case - [] -> pure 0 - -- check the last message first, it is the earliest - ntfs | systemSeconds (ntfTs $ last $ ntfs) < old -> do + expireQueue nId = atomically $ TM.lookup nId ns >>= maybe (pure 0) (expire nId) + expire nId v = readTVar v >>= \case + [] -> TM.delete nId ns >> pure 0 + -- check the last message first, it is the earliest + ntfs + | systemSeconds (ntfTs $ last ntfs) < old -> do let !ntfs' = filter (\MsgNtf {ntfTs = ts} -> systemSeconds ts >= old) ntfs - writeTVar v ntfs' - pure $! length ntfs - length ntfs' - _ -> pure 0 + if null ntfs' + then TM.delete nId ns >> pure (length ntfs) + else writeTVar v ntfs' >> pure (length ntfs - length ntfs') + | otherwise -> pure 0 data NtfLogRecord = NLRv1 NotifierId MsgNtf From 0a91f1bbc8304fc539912b7f87c6ad77cc77c614 Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 15:08:22 +0000 Subject: [PATCH 04/43] smp-server: add server port to leak diagnostics --- src/Simplex/Messaging/Server.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 2d2ef3074..c57863148 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -76,7 +76,7 @@ import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe) import Data.Semigroup (Sum (..)) import qualified Data.Set as S import Data.Text (Text) @@ -527,14 +527,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ms <- asks msgStore ns <- asks ntfStore ProxyAgent {smpAgent} <- asks proxyAgent + -- listening port identifies the server when several run in one process (bench topologies) + let srvPort = maybe "?" (\(p, _, _) -> p) $ listToMaybe transports labelMyThread "leakDiagnosticsThread" -- never let a diagnostics error crash the server (this thread is in raceAny_) liftIO $ forever $ do threadDelay $ sec * 1000000 - tryAny (logLeakStats srv ms ns smpAgent) >>= either (logError . ("LEAKDIAG error: " <>) . tshow) (const $ pure ()) + tryAny (logLeakStats srvPort srv ms ns smpAgent) >>= either (logError . ("LEAKDIAG error: " <>) . tshow) (const $ pure ()) - logLeakStats :: Server s -> s -> NtfStore -> SMPClientAgent 'Sender -> IO () - logLeakStats srv ms (NtfStore nsv) smpAgent = do + logLeakStats :: ServiceName -> Server s -> s -> NtfStore -> SMPClientAgent 'Sender -> IO () + logLeakStats srvPort srv ms (NtfStore nsv) smpAgent = do #if MIN_VERSION_base(4,18,0) nThreads <- length <$> listThreads #else @@ -552,6 +554,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt logNote $ T.concat [ "LEAKDIAG", + " srv=" <> T.pack srvPort, f "threads" nThreads, f "clients" (length cls), f "endThreads" (aggEndThreads cc), f "endThreadSeq" (aggEndThreadSeq cc), f "procThreads" (aggProcThreads cc), f "subs" (aggSubs cc), f "subs_nosub" (aggNoSub cc), f "subs_pending" (aggPending cc), f "subs_thread" (aggThread cc), f "subs_prohibit" (aggProhibit cc), From 2e97f493ecf57480470c6b20bec159eff09bade9 Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 15:08:22 +0000 Subject: [PATCH 05/43] tests: add latency transport for smp-server bench --- bench/NetLag.hs | 95 +++++++++++++++++++++++++++++++++++++++++++++++++ simplexmq.cabal | 1 + 2 files changed, 96 insertions(+) create mode 100644 bench/NetLag.hs diff --git a/bench/NetLag.hs b/bench/NetLag.hs new file mode 100644 index 000000000..f7a58b50f --- /dev/null +++ b/bench/NetLag.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | A latency-injecting Transport for the memory-leak bench. +-- +-- 'LagTLS' is a newtype over 'TLS' that delegates every 'Transport' method, adding a +-- configurable delay before each read and write and optionally swallowing writes. It is +-- wire-identical to 'TLS' - 'transportName' is only used for thread labels and logging, so a +-- peer speaking plain TLS interoperates with it unchanged. +-- +-- Used as the destination relay's listener transport so that proxy->relay traffic can be +-- delayed without touching the proxy, the clients, or any production code: +-- +-- > withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> +-- > withSmpServerConfigOn (transport @LagTLS) cfgJ2 testPort2 $ \_ -> ... +-- +-- 'setDropSnd' keeps the TLS session healthy while responses vanish, which is what the +-- proxy sentCommands leak needs: the relay must stay up and stop answering, so the proxy's +-- RFWD requests time out without the client being torn down. +-- +-- Delays apply to the SMP handshake as well as to post-handshake traffic (both go through +-- cGet/cPut), so phases that need an established session must connect first and arm the lag +-- afterwards. +module NetLag + ( LagTLS, + setLag, + setDropSnd, + clearLag, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Monad (unless, when) +import Data.ByteString.Char8 (ByteString) +import Simplex.Messaging.Transport +import System.IO.Unsafe (unsafePerformIO) + +newtype LagTLS (p :: TransportPeer) = LagTLS (TLS p) + +data LagCtl = LagCtl + { rcvDelayUs :: TVar Int, + sndDelayUs :: TVar Int, + dropSnd :: TVar Bool + } + +-- A single process-wide control: getTransportConnection has nowhere to thread per-listener +-- state through, and the bench runs one lagged relay at a time. +lagCtl :: LagCtl +lagCtl = unsafePerformIO $ LagCtl <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO False +{-# NOINLINE lagCtl #-} + +-- | One-way delays in microseconds: inbound (peer -> this transport) and outbound. +setLag :: Int -> Int -> IO () +setLag rcv snd' = atomically $ do + writeTVar (rcvDelayUs lagCtl) rcv + writeTVar (sndDelayUs lagCtl) snd' + +-- | Silently discard everything written. The session stays open and the peer keeps waiting. +setDropSnd :: Bool -> IO () +setDropSnd b = atomically $ writeTVar (dropSnd lagCtl) b + +clearLag :: IO () +clearLag = setLag 0 0 >> setDropSnd False + +delayBy :: TVar Int -> IO () +delayBy v = do + d <- readTVarIO v + when (d > 0) $ threadDelay d + +instance Transport LagTLS where + transportName _ = "LagTLS" + transportConfig (LagTLS t) = transportConfig t + getTransportConnection cfg sent chain ctx = LagTLS <$> getTransportConnection cfg sent chain ctx + certificateSent (LagTLS t) = certificateSent t + getPeerCertChain (LagTLS t) = getPeerCertChain t + getSessionALPN (LagTLS t) = getSessionALPN t + tlsUnique (LagTLS t) = tlsUnique t + closeConnection (LagTLS t) = closeConnection t + + cGet :: LagTLS p -> Int -> IO ByteString + cGet (LagTLS t) n = delayBy (rcvDelayUs lagCtl) >> cGet t n + + cPut :: LagTLS p -> ByteString -> IO () + cPut (LagTLS t) s = do + delayBy (sndDelayUs lagCtl) + drop' <- readTVarIO (dropSnd lagCtl) + unless drop' $ cPut t s + + getLn :: LagTLS p -> IO ByteString + getLn (LagTLS t) = delayBy (rcvDelayUs lagCtl) >> getLn t diff --git a/simplexmq.cabal b/simplexmq.cabal index c732c55d3..66b1429f3 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -663,6 +663,7 @@ executable smp-mem-bench buildable: False main-is: MemBench.hs other-modules: + NetLag SMPClient Util hs-source-dirs: From 689ff8901fe42d8a796467d8ff185d2a149fc12b Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 15:08:22 +0000 Subject: [PATCH 06/43] tests: add proxy and TLS memory leak bench phases --- bench/MemBench.hs | 411 +++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 392 insertions(+), 19 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index e1d432f79..eb0b18686 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -20,32 +20,54 @@ -- iteration count is leaking; a flat path is clean. -- -- Usage: smp-mem-bench --- phases: plain | svc | svcrace | ntf +-- +-- Single-server phases (server on testPort): +-- plain | svc | svcrace | ntf | conc | svcsubs | getp | stuck | certchurn | link | ntfexp +-- tlsstall | tlshalf | tlschurn | tlspartial -- TLS/TCP stack +-- +-- Two-server phases (proxy on testPort, lagged destination relay on testPort2): +-- proxyfwd | proxytmo | proxychurn | proxysess +-- +-- Env: BENCHSTORE selects the store (see srvStoreCfg); SMP_LEAKDIAG_SEC sets the LEAKDIAG +-- interval (defaulted to 10s here). In two-server phases each LEAKDIAG line is tagged with the +-- listening port - "srv=5001" is the proxy, "srv=5002" the relay - because process-wide RTS +-- residency cannot attribute growth to one server. module Main (main) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_, mapConcurrently_, withAsync) +import Control.Concurrent.Async (concurrently_, forConcurrently_, mapConcurrently_, wait, withAsync) import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) +import qualified Control.Exception as E import Control.Concurrent.STM import Control.Monad +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Crypto.Random (ChaChaDRG) import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) +import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) +import Data.Time.Clock (getCurrentTime) import qualified Data.X509.Validation as XV import GHC.Stats +import qualified Network.Socket as N +import NetLag (LagTLS, clearLag, setDropSnd, setLag) import SMPClient +import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (notificationExpiration)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (maxJournalMsgCount, msgQueueQuota, notificationExpiration)) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport +import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTransportClient) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) -import System.Environment (getArgs, lookupEnv) +import Simplex.Messaging.Version (mkVersionRange) +import System.Environment (getArgs, lookupEnv, setEnv) import System.Mem (performMajorGC) import System.Timeout (timeout) import Text.Printf (printf) +import Text.Read (readMaybe) type H = THandleSMP TLS 'TClient @@ -408,6 +430,330 @@ runNtfExp g iters _cp = -- hold while notifications expire; LEAKDIAG samples ntfStore_keys over this window forM_ ([1 .. 12] :: [Int]) $ \k -> threadDelay 5000000 >> (liveBytesMiB >>= report "ntfexp" (iters * 10 + k) base) +-- two-server topology: proxy + lagged relay --------------------------------- +-- +-- The destination relay listens on LagTLS (see bench/NetLag.hs), so proxy->relay latency and +-- response-dropping are controlled from the bench without touching production code. The proxy +-- and all clients use plain TLS - LagTLS is wire-identical, only the local read/write path +-- differs. +-- +-- Both servers log LEAKDIAG lines tagged with their listening port ("srv=5001" is the proxy, +-- "srv=5002" the relay), which is how per-server counters are attributed: process-wide RTS +-- residency conflates both servers with the bench clients. + +proxySrv :: SMPServer +proxySrv = SMPServer testHost testPort testKeyHash + +relaySrv :: SMPServer +relaySrv = SMPServer testHost2 testPort2 testKeyHash + +-- an address with nothing listening, for connect-failure churn +deadSrv :: Int -> SMPServer +deadSrv i = SMPServer testHost2 (show (20000 + i)) testKeyHash + +withProxyTopology :: Maybe String -> IO a -> IO a +withProxyTopology storeEnv action = + withSmpServerConfigOn (transport @TLS) (proxySrvCfg storeEnv) testPort $ \_ -> + withSmpServerConfigOn (transport @LagTLS) (relaySrvCfg storeEnv) testPort2 $ \_ -> + threadDelay 250000 >> action + +proxySrvCfg :: Maybe String -> AServerConfig +proxySrvCfg = \case +#if defined(dbServerPostgres) + Just "pgjournal" -> proxyCfgMS (ASType SQSPostgres SMSJournal) + Just "journal" -> proxyCfgMS (ASType SQSMemory SMSJournal) + _ -> proxyCfgMS (ASType SQSPostgres SMSPostgres) +#else + _ -> proxyCfg +#endif + +-- second store paths/db, so the relay does not collide with the proxy in one process. +-- Quota is raised (as SMPProxyTests does) so that forwarding under latency is not cut short by +-- QUOTA before the phase has run long enough to show a trend. +relaySrvCfg :: Maybe String -> AServerConfig +relaySrvCfg storeEnv = updateCfg (baseCfg storeEnv) $ \c -> c {msgQueueQuota = 128, maxJournalMsgCount = 256} + where + baseCfg = \case +#if defined(dbServerPostgres) + Just "journal" -> cfgJ2QS SQSMemory + _ -> cfgJ2QS SQSPostgres +#else + _ -> cfgJ2 +#endif + +-- a client connected to the proxy, able to issue PRXY/PFWD +proxyClient :: TVar ChaChaDRG -> Int64 -> IO SMPClient +proxyClient g n = do + ts <- getCurrentTime + getProtocolClient g NRMInteractive (n, proxySrv, Nothing) benchClientCfg [] Nothing ts (\_ -> pure ()) + >>= either (fail . show) pure + +benchClientCfg :: ProtocolClientConfig SMPVersion +benchClientCfg = defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} + +runExceptT' :: Show e => ExceptT e IO a -> IO a +runExceptT' a = runExceptT a >>= either (fail . show) pure + +-- a subscribed queue on the destination relay, with everything needed to drain it +data RelayQueue = RelayQueue + { rqSndId :: SenderId, + rqRcvId :: RecipientId, + rqRcvKey :: C.APrivateAuthKey, + rqClient :: SMPClient, + rqMsgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg) + } + +newRelayQueue :: TVar ChaChaDRG -> IO RelayQueue +newRelayQueue g = do + ts <- getCurrentTime + rqMsgQ <- newTBQueueIO 4096 + rqClient <- + getProtocolClient g NRMInteractive (99, relaySrv, Nothing) benchClientCfg [] (Just rqMsgQ) ts (\_ -> pure ()) + >>= either (fail . show) pure + (rPub, rqRcvKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rdhPub, _rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + QIK {sndId = rqSndId, rcvId = rqRcvId} <- + runExceptT' $ createSMPQueue rqClient NRMInteractive Nothing (rPub, rqRcvKey) rdhPub Nothing SMSubscribe (QRMessaging Nothing) Nothing + pure RelayQueue {rqSndId, rqRcvId, rqRcvKey, rqClient, rqMsgQ} + +-- receive and ack one delivered message, so a steady-forwarding phase does not hit QUOTA +ackOne :: RelayQueue -> IO () +ackOne RelayQueue {rqRcvId, rqRcvKey, rqClient, rqMsgQ} = do + b <- atomically $ readTBQueue rqMsgQ + case b of + (_, _, [(_, STEvent (Right (MSG RcvMessage {msgId})))]) -> + runExceptT' $ ackSMPMessage rqClient rqRcvKey rqRcvId msgId + _ -> pure () + +-- baseline: steady forwarding through the proxy under moderate latency. +-- proxy_sentCommands (LEAKDIAG srv=5001) should stay flat - every RFWD is answered. +runProxyFwd :: TVar ChaChaDRG -> Int -> Int -> IO () +runProxyFwd g iters cp = do + rq <- newRelayQueue g + pc <- proxyClient g 1 + sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relaySrv Nothing + setLag proxyLagUs proxyLagUs + -- a silently failing send would look identical to a clean one in the residency trace, + -- so the baseline phase must fail loudly instead of counting errors as "flat" + withCheckpoints "proxyfwd" iters cp $ \i -> do + runExceptT (proxySMPMessage pc NRMInteractive sess Nothing (rqSndId rq) noMsgFlags "hello") >>= \case + Right (Right ()) -> pure () + r -> fail $ "proxyfwd: forward failed at iteration " <> show i <> ": " <> show r + ackOne rq + clearLag + where + proxyLagUs = 50000 -- 50ms each way + +-- HEADLINE REPRO: the relay keeps the session up but stops answering, so every RFWD the proxy +-- forwards times out. getResponse (Client.hs) sets `pending = False` and bumps the error count +-- but never deletes from `sentCommands` - the only removal is in processMsg when a response +-- actually arrives. Each stuck entry retains its RFWD command payload (EncFwdTransmission, +-- paddedProxiedTLength = 16226 bytes), and the session is never torn down because dropping the +-- client needs timeoutErrorCount >= smpPingCount AND 15 minutes of total silence, while the +-- proxy (party SSender) never pings. +-- +-- Expect LEAKDIAG srv=5001 proxy_sentCommands to climb by `concurrency` per round and stay +-- there, with residency growing ~16 KiB per stuck command. +runProxyTmo :: TVar ChaChaDRG -> Int -> Int -> IO () +runProxyTmo g iters _cp = do + rq <- newRelayQueue g + -- establish the proxy->relay session and prove it works before breaking it + pcs <- mapM (proxyClient g . fromIntegral) [1 .. nClients] + sess <- runExceptT' $ connectSMPProxiedRelay (head pcs) NRMInteractive relaySrv Nothing + -- prove forwarding works before breaking it, so a setup failure cannot masquerade as the leak + runExceptT (proxySMPMessage (head pcs) NRMInteractive sess Nothing (rqSndId rq) noMsgFlags "warmup") >>= \case + Right (Right ()) -> pure () + r -> fail $ "proxytmo: warmup forward failed, topology is broken: " <> show r + base <- liveBytesMiB + report "proxytmo" 0 base base + setDropSnd True + timeouts <- newTVarIO (0 :: Int) + let rounds = max 1 (iters `div` batch) + forM_ ([1 .. rounds] :: [Int]) $ \r -> do + -- all of these time out together; each leaves one entry in the proxy's sentCommands + forConcurrently_ ([1 .. batch] :: [Int]) $ \k -> do + let pc = pcs !! (k `mod` nClients) + r' <- runExceptT (proxySMPMessage pc NRMInteractive sess Nothing (rqSndId rq) noMsgFlags "stuck") + -- only a response timeout leaves a stuck sentCommands entry; anything else means the + -- phase is measuring something other than the leak it claims to reproduce + case r' of + Left PCEResponseTimeout -> atomically $ modifyTVar' timeouts (+ 1) + _ -> pure () + n <- readTVarIO timeouts + cur <- liveBytesMiB + report "proxytmo" (r * batch) base cur + -- Measured, not assumed: this stays flat at one batch rather than accumulating. The + -- bench clients give up at 20s (2 * interactive tcpTimeout) but the proxy still answers + -- them with PROXY (BROKER TIMEOUT) once its own RFWD expires at 30s, and that late + -- response deletes their entries in processMsg. Only the proxy->relay side leaks, so + -- process residency is NOT a doubled count of the payload. + clientStuck <- sum <$> mapM pClientSentCommandsCount pcs + printf "proxytmo timeouts=%d of %d attempted, benchClient_sentCommands=%d\n" n (r * batch) clientStuck + setDropSnd False + where + nClients = 8 + batch = 64 + +-- PRXY to many distinct relay addresses that refuse the connection. Each failure stores +-- `Left (err, Just expiry)` in the agent's smpClients map; removal is lazy (only on a later +-- lookup of the same server), so addresses never requested again are retained. +-- Expect LEAKDIAG srv=5001 proxy_smpClients to grow monotonically. +runProxyChurn :: TVar ChaChaDRG -> Int -> Int -> IO () +runProxyChurn g iters cp = do + pc <- proxyClient g 1 + withCheckpoints "proxychurn" iters cp $ \i -> + void $ runExceptT (connectSMPProxiedRelay pc NRMInteractive (deadSrv i) Nothing) + +-- PRXY against a relay that accepts TCP but never completes TLS, with the requesting client +-- disconnecting mid-connect. +-- +-- NOT A CONFIRMED REPRO. This was written to probe the empty-SessionVar path in +-- getSMPServerClient'', and it does not reach it: measured over 100 iterations, the proxy ends +-- with proxy_smpClients=0, proxy_smpSessions=0, clients=0 and a thread count at baseline, both +-- 5s and 55s after the loop (i.e. before and after the 45s tcpConnectTimeout expires). The +-- withGetSessVar bracketOnError in Session.hs drops the empty var on the async exception, so +-- the race stays closed on this path. +-- +-- Residency does climb ~108 KiB/iter, but with every server-side counter flat that growth is +-- bench-harness retention, not a server leak - do not read it as one. The phase is kept as +-- connect-abort churn coverage; reproducing the empty-SessionVar leak still needs the +-- deterministic unit-test-style race, as bench/MemBench.hs already noted for the proxy leaks. +runProxySess :: TVar ChaChaDRG -> Int -> Int -> IO () +runProxySess g iters cp = + withStallingServerOn stallPort $ do + base <- liveBytesMiB + report "proxysess" 0 base base + forM_ ([1 .. iters] :: [Int]) $ \i -> do + pc <- proxyClient g (1000 + fromIntegral i) + -- start the relay connect, then drop the requesting client before it can finish + withAsync (void $ runExceptT (connectSMPProxiedRelay pc NRMInteractive stallSrv Nothing)) $ \_ -> + threadDelay 50000 + closeProtocolClient pc + when (i `mod` cp == 0) $ liveBytesMiB >>= report "proxysess" i base + where + stallPort = "5009" + stallSrv = SMPServer testHost2 stallPort testKeyHash + +-- TLS/TCP stack -------------------------------------------------------------- + +-- These phases hold every connection open at once, so they are bounded by file descriptors +-- rather than by memory. Cap and say so - a silent truncation would read as "20000 connections +-- were fine" when only a fraction were ever opened. +maxHeldConns :: Int +maxHeldConns = 512 + +heldConns :: String -> Int -> IO Int +heldConns phase iters + | iters <= maxHeldConns = pure iters + | otherwise = do + printf "%s: capping held connections at %d (requested %d) to stay within the fd limit\n" phase maxHeldConns iters + pure maxHeldConns + +rawConnect :: N.ServiceName -> IO N.Socket +rawConnect port = do + let hints = N.defaultHints {N.addrSocketType = N.Stream} + addr : _ <- N.getAddrInfo (Just hints) (Just "127.0.0.1") (Just port) + sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr) + N.connect sock (N.addrAddress addr) + pure sock + +-- Occupancy or leak? Hold `n` connections open at once, measure peak residency, then release +-- them all and measure again once the server has had time to drop its per-connection state. +-- Recovery to baseline means the phase measured the legitimate cost of a held connection; a +-- residency that stays elevated is a leak. Without this second measurement the two are +-- indistinguishable - the first version of these phases reported peak occupancy alone, which +-- reads like a leak and is not one. +holdRelease :: String -> Int -> (IO () -> Int -> IO ()) -> IO () +holdRelease phase n conn = do + base <- liveBytesMiB + report phase 0 base base + release <- newTVarIO False + connected <- newTVarIO (0 :: Int) + let held = do + atomically $ modifyTVar' connected (+ 1) + atomically $ readTVar release >>= \r -> unless r retry + withAsync (forConcurrently_ ([1 .. n] :: [Int]) (conn held)) $ \as -> do + atomically $ readTVar connected >>= \c -> when (c < n) retry + peak <- liveBytesMiB + report phase n base peak + atomically $ writeTVar release True + wait as + printf "%s: peak=%.1f MiB (%+.2f KiB/conn)\n" phase peak ((peak - base) * 1024 / fromIntegral n) + -- Sample recovery repeatedly rather than once. A single early sample cannot tell a leak + -- from state the server has not reaped yet: the relevant server windows are 60s + -- (tlsSetupTimeout) and 60s (test smpHandshakeTimeout). Retention that keeps falling is + -- slow reaping; retention that plateaus above baseline is a leak. + foldM_ + ( \prev afterSec -> do + threadDelay $ (afterSec - prev) * 1000000 + cur <- liveBytesMiB + printf + "%s: +%3ds recovered=%.1f MiB retained=%+.2f MiB (%+.3f KiB/conn)\n" + phase + afterSec + cur + (cur - base) + ((cur - base) * 1024 / fromIntegral n) + pure afterSec + ) + (0 :: Int) + ([5, 25, 60, 120] :: [Int]) + +-- TCP connections that never send a ClientHello. Each occupies a server thread, an fd and a +-- SocketState entry until tlsSetupTimeout (60s) or until the peer closes. +-- +-- RESULT (200 conns): peak 48.2 KiB/conn, 0.31 KiB/conn retained from +25s onwards. Clean. +runTlsStall :: Int -> Int -> IO () +runTlsStall iters0 _cp = do + iters <- heldConns "tlsstall" iters0 + holdRelease "tlsstall" iters $ \held _ -> + E.bracket (rawConnect testPort) N.close $ \_ -> held + +-- TLS completes but the SMP handshake never starts: held until smpHandshakeTimeout (60s in the +-- test config) with no Client record ever allocated, so it is invisible to the LEAKDIAG client +-- counters - watch threads and CPSockets instead. +-- +-- RESULT (200 conns): peak 203.1 KiB/conn, but 0.71 KiB/conn retained from +25s onwards. Clean. +-- Note the shape of the recovery curve: at +5s it still reads 124.6 KiB/conn, so a single early +-- sample reports this as a 24 MiB leak when it is teardown latency (gracefulClose holds each +-- connection up to 5s). The occupancy is still worth knowing - 200 abandoned half-open +-- connections pin ~40 MiB for ~25s with no authentication required. +runTlsHalf :: Int -> Int -> IO () +runTlsHalf iters0 _cp = do + iters <- heldConns "tlshalf" iters0 + holdRelease "tlshalf" iters $ \held _ -> + runTransportClient tcConfig Nothing (head' testHost) testPort (Just testKeyHash) $ + \(_h :: TLS 'TClient) -> held + where + tcConfig = defaultTransportClientConfig {clientALPN = Just alpnSupportedSMPHandshakes} :: TransportClientConfig + head' (h :| _) = h + +-- full connect + SMP handshake + disconnect churn. Exercises the accept path, per-connection +-- TBuffer allocation and the gracefulClose teardown residue. +runTlsChurn :: Int -> Int -> IO () +runTlsChurn iters cp = do + base <- liveBytesMiB + report "tlschurn" 0 base base + forM_ ([1 .. iters] :: [Int]) $ \i -> do + testSMPClient @TLS $ \(_h :: THandleSMP TLS 'TClient) -> pure () + when (i `mod` cp == 0) $ liveBytesMiB >>= report "tlschurn" i base + +-- post-handshake, send a partial block and idle. The server's transportTimeout is hardcoded +-- Nothing, so its receive thread blocks in cGet indefinitely; only inactive-client expiry +-- (6h by default, and only without subscriptions) would ever reap it. +-- RESULT (200 conns): peak 264.6 KiB/conn, 0.87 KiB/conn retained from +25s onwards. Clean - +-- the server has no read timeout here (transportTimeout is hardcoded Nothing at +-- Transport/Server.hs:104) so it never reaps these itself, but it does release everything +-- promptly once the peer disconnects. The exposure is occupancy while the peer stays connected: +-- a client that completes the SMP handshake and then sends one byte pins ~265 KiB indefinitely, +-- reapable only by inactive-client expiry (6h default, and only for clients with no +-- subscriptions). +runTlsPartial :: Int -> Int -> IO () +runTlsPartial iters0 _cp = do + iters <- heldConns "tlspartial" iters0 + holdRelease "tlspartial" iters $ \held _ -> + testSMPClient @TLS $ \h -> cPut (connection h) "partial" >> held + -- store config selectable via BENCHSTORE env: pgmsg (default, useCache=False) | pgjournal (useCache=True) | journal srvStoreCfg :: Maybe String -> AServerConfig srvStoreCfg = \case @@ -433,20 +779,47 @@ main = do let srvCfg = case phase of "ntfexp" -> updateCfg (srvStoreCfg storeEnv) $ \c -> c {notificationExpiration = ExpirationConfig {ttl = 2, checkInterval = 3}} _ -> srvStoreCfg storeEnv + -- LEAKDIAG counters are the only per-server signal in multi-server topologies, so sample + -- them often enough to be useful over a bench run + leakDiagSec <- fromMaybe 10 . (>>= readMaybe) <$> lookupEnv "SMP_LEAKDIAG_SEC" + setEnv "SMP_LEAKDIAG_SEC" (show leakDiagSec) setLogLevel LogInfo withGlobalLogging LogConfig {lc_file = Nothing, lc_stderr = True} $ - withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> do - threadDelay 250000 - case phase of - "plain" -> runPlain g iters cp - "svc" -> runSvc g iters cp - "svcrace" -> runSvcRace g iters cp - "ntf" -> runNtf g iters cp - "conc" -> runConc g iters cp - "svcsubs" -> runSvcSubs g iters cp - "getp" -> runGet g iters cp - "stuck" -> runStuck g iters cp - "certchurn" -> runCertChurn g iters cp - "link" -> runLink g iters cp - "ntfexp" -> runNtfExp g iters cp - _ -> error $ "unknown phase: " <> phase + if phase `elem` proxyPhases + then withProxyTopology storeEnv $ settle leakDiagSec $ case phase of + "proxyfwd" -> runProxyFwd g iters cp + "proxytmo" -> runProxyTmo g iters cp + "proxychurn" -> runProxyChurn g iters cp + "proxysess" -> runProxySess g iters cp + _ -> error $ "unknown proxy phase: " <> phase + else withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> settle leakDiagSec $ do + threadDelay 250000 + case phase of + "plain" -> runPlain g iters cp + "svc" -> runSvc g iters cp + "svcrace" -> runSvcRace g iters cp + "ntf" -> runNtf g iters cp + "conc" -> runConc g iters cp + "svcsubs" -> runSvcSubs g iters cp + "getp" -> runGet g iters cp + "stuck" -> runStuck g iters cp + "certchurn" -> runCertChurn g iters cp + "link" -> runLink g iters cp + "ntfexp" -> runNtfExp g iters cp + "tlsstall" -> runTlsStall iters cp + "tlshalf" -> runTlsHalf iters cp + "tlschurn" -> runTlsChurn iters cp + "tlspartial" -> runTlsPartial iters cp + _ -> error $ "unknown phase: " <> phase + +proxyPhases :: [String] +proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "proxysess"] + +-- Hold the servers up past one LEAKDIAG interval after the phase finishes, so the end state is +-- always sampled at least once. Short phases would otherwise exit before any line is emitted, +-- leaving the per-server counters - the only attribution in a two-server topology - unobservable. +settle :: Int -> IO a -> IO a +settle leakDiagSec run = do + r <- run + threadDelay $ (leakDiagSec + 2) * 1000000 + pure r From 1f7557a30d90515c30918325ce432dcce7ef96ac Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 15:08:22 +0000 Subject: [PATCH 07/43] docs: add smp-server memory leak findings --- docs/leak-findings.md | 162 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 162 insertions(+) create mode 100644 docs/leak-findings.md diff --git a/docs/leak-findings.md b/docs/leak-findings.md new file mode 100644 index 000000000..752a38bcd --- /dev/null +++ b/docs/leak-findings.md @@ -0,0 +1,162 @@ +# SMP server leak findings + +From `bench/MemBench.hs` extended with a proxy plus relay topology and a transport that adds +latency and drops replies. + +Two leaks on the proxy path, both client reachable. Two related bugs. TLS/TCP stack clean. + +--- + +## Leak 1: forwarded commands never removed on timeout + +### Issue + +Entries go into `sentCommands` in `mkTransmission_` (`Client.hs:1418`). The only removal is in +`processMsg` (`Client.hs:706`), which runs when a reply arrives. `getResponse` (`Client.hs:1383`) +handles the timeout but does not receive the map, so it cannot delete. + +The session does not drop either: that needs 15 minutes of total silence, and the proxy never +pings. Each entry holds the forwarded command, 16226 bytes. + +`proxytmo 448`: `proxy_sentCommands` goes 64, 128, 192, 256, 320, 384, 448. Monotonic. +About 20 KiB per entry. + +### Impact + +20 KiB per unanswered forward, held for the life of the relay session (days). + +`PRXY` is unauthenticated unless `newQueueBasicAuth` is set (`Server.hs:1534`), and it names an +arbitrary destination. A client can supply a relay that accepts and stays silent. Answering some +requests and dropping others keeps the session alive, since any reply resets the drop counters. + +100k stuck commands is 2 GiB. No rate cap, see Bug 3. + +Also fires with no attacker: any round trip above 30 seconds. + +### Fix + +```haskell +Nothing -> do + TM.delete corrId sentCommands -- new + modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout +``` + +Pass `sentCommands` and the request's `corrId` into `getResponse`. Double delete is harmless. + +Same leak with no timeout at `Client.hs:1366` and `1368`, where the request is inserted before +an early error return. + +--- + +## Leak 2: failed relay connects never cleared + +### Issue + +A failed connect is cached in `smpClients` as `Left (error, expiry)`, removed only on a later +lookup of the same server (`Client/Agent.hs:250`, `:411`). Nothing sweeps on a timer. + +The address comes from the client via `PRXY`. Host, port and key hash are arbitrary, so distinct +keys are effectively unlimited. + +`proxychurn 300`: `proxy_smpClients = 300`, none removed. A 1000 run settles at ~19 KiB per +entry, created in about 1 second. + +### Impact + +19 KiB per address, never freed while the process runs. + +About 19 MiB/s when the address refuses immediately. An address that blackholes instead waits +out the 45 second connect timeout, which throttles it heavily. + +Same unauthenticated `PRXY` as Leak 1. + +### Fix + +Sweep the map on a timer, dropping entries past their expiry. The timestamp is already stored. + +--- + +## Bug 3: proxy concurrency limit is inert + +### Issue + +`Server.hs:1590`: + +```haskell +bracket_ wait signal . forkClient clnt label $ action +``` + +`.` binds tighter than `$`, so `signal` runs when the thread starts, not when it finishes. Only +forking is limited. + +### Impact + +No memory cost. Removes the cap on how fast Leak 1 grows, and `procThreads` reads near zero at +any load. + +### Fix + +```haskell +wait >> forkClient clnt label (action `finally` signal) +``` + +This enables the limit for the first time. Default is 32, and `wait` blocks the client's whole +command loop when hit, so check the value first. + +--- + +## Bug 4: stale endThreads entry when a command finishes fast + +### Issue + +`forkClient` (`Server.hs:1480`) registers the thread after `forkIO`. If the action finishes +first, its delete misses and the insert is never undone. + +100k forks: 20% stale at `-N1`, 12% at `-N4`, 0% when the action blocks 1ms. Real callers +(`PFWD`, `PRXY`, `RSLV`) wait on the network. Reachable at speed via an oversized `PFWD` that +fails the block size check without IO. + +### Impact + +About 320 bytes per entry, freed on disconnect. 10k fast failing commands on one connection is +roughly 640 KB. Minor. The real cost is that `endThreads` no longer distinguishes stuck commands +from counter error. + +### Fix + +```haskell +atomically $ modifyTVar' endThreads $ IM.insert tId Nothing -- before forkIO +atomically $ modifyTVar' endThreads $ IM.adjust (const (Just w)) tId +``` + +`adjust` is a no-op if the action already removed the key. + +--- + +## Clean + +200 connections opened at once, closed, then measured again: + +| test | peak per conn | after 25s | +| ------------------------------------- | ------------- | --------- | +| TCP connect, never start TLS | 48.2 KiB | 0.31 KiB | +| TLS done, no SMP handshake | 203.1 KiB | 0.71 KiB | +| Handshake done, one byte, then quiet | 264.6 KiB | 0.87 KiB | + +All recovered. Also clean: 400 connect/disconnect rounds, and steady forwarding at 50ms each way. + +At +5s the middle two still read ~120 KiB per connection, which looks like a 24 MiB leak but is +`gracefulClose` waiting up to 5s per connection. Falling means reclaimed, flat above baseline +means leaked. + +Peaks still matter. 200 abandoned half open connections hold ~40 MiB for ~25s, unauthenticated. +A client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays +connected: no read timeout, `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs:104`). + +## Not reproduced + +Empty session variable leak. After 100 rounds `proxysess` ends with `proxy_smpClients=0` and +`proxy_smpSessions=0`, checked before and after the 45 second connect timeout. `bracketOnError` +in `withGetSessVar` drops the empty entry. + +The ~108 KiB per round it shows is harness overhead, not a server finding. From c5f8ef47b4bac8754f354aac71eaf34cf3c5188d Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 15:37:33 +0000 Subject: [PATCH 08/43] tests: sweep proxy latency in memory leak bench --- bench/MemBench.hs | 61 +++++++++++++++++++++++++++++++------------ docs/leak-findings.md | 25 ++++++++++++++++++ 2 files changed, 70 insertions(+), 16 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index eb0b18686..32f68f20d 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -516,33 +516,62 @@ newRelayQueue g = do runExceptT' $ createSMPQueue rqClient NRMInteractive Nothing (rPub, rqRcvKey) rdhPub Nothing SMSubscribe (QRMessaging Nothing) Nothing pure RelayQueue {rqSndId, rqRcvId, rqRcvKey, rqClient, rqMsgQ} --- receive and ack one delivered message, so a steady-forwarding phase does not hit QUOTA -ackOne :: RelayQueue -> IO () -ackOne RelayQueue {rqRcvId, rqRcvKey, rqClient, rqMsgQ} = do - b <- atomically $ readTBQueue rqMsgQ - case b of - (_, _, [(_, STEvent (Right (MSG RcvMessage {msgId})))]) -> - runExceptT' $ ackSMPMessage rqClient rqRcvKey rqRcvId msgId +-- Receive and ack one delivered message, so a steady-forwarding phase does not hit QUOTA. +-- Bounded: the recipient also talks to the lagged relay, so delivery is delayed by the same +-- lag, and an unbounded wait would hang the high-latency runs. +ackOne :: Int -> RelayQueue -> IO () +ackOne tmo RelayQueue {rqRcvId, rqRcvKey, rqClient, rqMsgQ} = + timeout tmo (atomically $ readTBQueue rqMsgQ) >>= \case + Just (_, _, [(_, STEvent (Right (MSG RcvMessage {msgId})))]) -> + void $ runExceptT $ ackSMPMessage rqClient rqRcvKey rqRcvId msgId _ -> pure () -- baseline: steady forwarding through the proxy under moderate latency. -- proxy_sentCommands (LEAKDIAG srv=5001) should stay flat - every RFWD is answered. +-- +-- CONNECTIVITY UNDER LATENCY, swept with BENCHLAG_MS (one way, so a request/response pair costs +-- twice this). Sockets counted from /proc//fd while the phase ran: +-- +-- lag/way delivered sockets proxy->relay connects reconnects timeouts +-- 0ms 12/12 8 1 0 0 +-- 500ms 10/10 8 1 0 0 +-- 5s 6/6 8 1 0 0 +-- 16s 4/4 8 1 0 0 +-- 40s 0/2 8 1 0 1 +-- +-- Nothing accumulates. The socket count is identical whether forwards succeed or time out, the +-- proxy->relay session is opened once and reused throughout, and there are no reconnects at any +-- latency. proxy_smpClients and proxy_smpSessions stay at 1. +-- +-- That robustness is exactly what makes Leak 1 unbounded: the session that holds the stuck +-- sentCommands entries never drops, so nothing ever frees them. A connection that failed under +-- latency would at least bound the damage. +-- +-- Forwards succeed up to 16s each way and fail at 40s; the governing limit is the 30s RFWD +-- timeout. The exact cutoff is not pinned down, because the lag is applied per read/write cycle +-- on the relay rather than per message, so configured lag does not map exactly onto observed +-- round trip. runProxyFwd :: TVar ChaChaDRG -> Int -> Int -> IO () runProxyFwd g iters cp = do rq <- newRelayQueue g pc <- proxyClient g 1 sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relaySrv Nothing - setLag proxyLagUs proxyLagUs - -- a silently failing send would look identical to a clean one in the residency trace, - -- so the baseline phase must fail loudly instead of counting errors as "flat" - withCheckpoints "proxyfwd" iters cp $ \i -> do + -- one-way lag added to every relay read and write, so a request/response cycle costs 2x this. + -- BENCHLAG_MS overrides it to sweep latency; see the connectivity notes below. + lagMs <- fromMaybe 50 . (>>= readMaybe) <$> lookupEnv "BENCHLAG_MS" + printf "proxyfwd: lag=%dms each way (%dms added per request/response)\n" lagMs (2 * lagMs :: Int) + setLag (lagMs * 1000) (lagMs * 1000) + ok <- newTVarIO (0 :: Int) + failed <- newTVarIO (0 :: Int) + -- Under latency a forward can fail without the phase being broken, so record outcomes + -- instead of aborting: the point is which latency band still delivers. + withCheckpoints "proxyfwd" iters cp $ \_i -> do runExceptT (proxySMPMessage pc NRMInteractive sess Nothing (rqSndId rq) noMsgFlags "hello") >>= \case - Right (Right ()) -> pure () - r -> fail $ "proxyfwd: forward failed at iteration " <> show i <> ": " <> show r - ackOne rq + Right (Right ()) -> atomically (modifyTVar' ok (+ 1)) >> ackOne (4 * lagMs * 1000 + 20000000) rq + _ -> atomically $ modifyTVar' failed (+ 1) clearLag - where - proxyLagUs = 50000 -- 50ms each way + (o, f) <- (,) <$> readTVarIO ok <*> readTVarIO failed + printf "proxyfwd: delivered=%d failed=%d\n" o f -- HEADLINE REPRO: the relay keeps the session up but stops answering, so every RFWD the proxy -- forwards times out. getResponse (Client.hs) sets `pending = False` and bumps the error count diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 752a38bcd..530a9dbd6 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -153,6 +153,31 @@ Peaks still matter. 200 abandoned half open connections hold ~40 MiB for ~25s, u A client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays connected: no read timeout, `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs:104`). +## Connectivity and sockets under latency + +Latency swept with `BENCHLAG_MS` on `proxyfwd` (one way, so a request/response pair costs twice +this). Sockets counted from `/proc//fd` during the run. + +| lag each way | delivered | sockets | relay connects | reconnects | timeouts | +| ------------ | --------- | ------- | -------------- | ---------- | -------- | +| 0ms | 12/12 | 8 | 1 | 0 | 0 | +| 500ms | 10/10 | 8 | 1 | 0 | 0 | +| 5s | 6/6 | 8 | 1 | 0 | 0 | +| 16s | 4/4 | 8 | 1 | 0 | 0 | +| 40s | 0/2 | 8 | 1 | 0 | 1 | + +Nothing accumulates. The socket count is the same whether forwards succeed or time out, the +proxy to relay session is opened once and reused, and there are no reconnects at any latency. +`proxy_smpClients` and `proxy_smpSessions` stay at 1 throughout. + +This is the bad news for Leak 1. The session holding the stuck `sentCommands` entries never +drops, so nothing ever frees them. A connection that broke under latency would at least bound +the damage. + +Forwards work up to 16s each way and fail at 40s. The governing limit is the 30s RFWD timeout. +The exact cutoff is not pinned down: the test transport adds delay per read/write cycle rather +than per message, so configured lag does not map exactly onto observed round trip. + ## Not reproduced Empty session variable leak. After 100 rounds `proxysess` ends with `proxy_smpClients=0` and From fc464a9a7f23ccb1129dfaf1dba9a45a54666e4d Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 15:44:40 +0000 Subject: [PATCH 09/43] docs: add ntf server exposure and socket stats bug --- docs/leak-findings.md | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 530a9dbd6..2e15331d6 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -33,6 +33,19 @@ requests and dropping others keeps the session alive, since any reply resets the Also fires with no attacker: any round trip above 30 seconds. +The ntf server uses the same client code, so it is exposed too, but less. Analysis only, not +measured here, since it needs Postgres: + +- Reachable through unanswered `NSUB`. `subscribeSMPQueuesNtfs` (`Client.hs:912`) batches, and + `sendBatch` calls `getResponse` once per request, so an unanswered batch leaks one entry per + queue. Batch size is 1360 (`Client/Agent.hs:131`). +- Much cheaper per entry: an `NSUB` payload rather than a 16226 byte `RFWD`. +- Partly self limiting. Every subscribe path calls `enablePings` (`Client.hs:854, 861, 907, 914, + 934`), so a fully silent server is eventually dropped and the map goes with it. The proxy + never subscribes, so it never pings, which is why only the proxy is unbounded. +- Still leaks against a server that answers pings but not subscribes, since any reply resets the + counters. + ### Fix ```haskell @@ -153,6 +166,35 @@ Peaks still matter. 200 abandoned half open connections hold ~40 MiB for ~25s, u A client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays connected: no read timeout, `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs:104`). +## Bug 5: socketsLeaked over-reports during teardown + +### Issue + +`closeConn` (`Transport/Server.hs:179`) removes the connection from `active`, then calls +`gracefulClose conn 5000`, then increments `closed`: + +```haskell +atomically $ writeTVar closed True >> modifyTVar' clients (IM.delete cId) +gracefulClose conn 5000 `catchAll_` pure () +atomically $ modifyTVar' gracefullyClosed (+ 1) +``` + +`socketsLeaked = accepted - closed - active` (`Transport/Server.hs:225`). For up to 5 seconds a +closing connection is in neither `closed` nor `active`, so it counts as leaked. + +### Impact + +No memory cost. Under connection churn `socketsLeaked` shows a steady nonzero value that is not +a leak, which makes the metric unusable for the thing it is named after. This is the same 5 +second teardown window that made the TLS tests look like they leaked 24 MiB. + +### Fix + +Count the connection as closed before starting `gracefulClose`, or drop it from `active` only +after `gracefulClose` returns. Either ordering keeps the invariant. + +--- + ## Connectivity and sockets under latency Latency swept with `BENCHLAG_MS` on `proxyfwd` (one way, so a request/response pair costs twice From 1d80f8c5ed854f8eb23688b8e7ab1f1bc90d946c Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 17:21:10 +0000 Subject: [PATCH 10/43] tests: measure when proxy leak is bounded vs unbounded --- bench/MemBench.hs | 38 ++++++++++++++++++++++++++++++++++--- bench/NetLag.hs | 24 +++++++++++++++++++---- docs/leak-findings.md | 44 +++++++++++++++++++++++++++++++++++-------- 3 files changed, 91 insertions(+), 15 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 32f68f20d..0ff927fc5 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -51,7 +51,7 @@ import Data.Time.Clock (getCurrentTime) import qualified Data.X509.Validation as XV import GHC.Stats import qualified Network.Socket as N -import NetLag (LagTLS, clearLag, setDropSnd, setLag) +import NetLag (LagTLS, clearLag, setDropEvery, setDropSnd, setLag) import SMPClient import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C @@ -582,7 +582,21 @@ runProxyFwd g iters cp = do -- proxy (party SSender) never pings. -- -- Expect LEAKDIAG srv=5001 proxy_sentCommands to climb by `concurrency` per round and stay --- there, with residency growing ~16 KiB per stuck command. +-- there, with residency growing ~20 KiB per stuck command. +-- +-- MEASURED, three cases, and only the last one is a real leak: +-- +-- 1. Relay slow but still replying (proxyfwd BENCHLAG_MS=16000): the late reply deletes the +-- entry, so the counter oscillates 1,0,1,0 and ends at 0. Latency alone does not leak. +-- 2. Relay stops replying, then traffic stops (BENCHHOLD_SEC, with or without BENCHDROP_EVERY): +-- counter holds, then goes to 0 at ~20 minutes with a disconnect. monitor (Client.hs:668) +-- exits once timeoutErrorCount >= smpPingCount and nothing has arrived for 900s, and it sits +-- in raceAny_ ... `finally` disconnected (Client.hs:649), so the client is torn down and the +-- map goes with it. Bounded. +-- 3. Sustained traffic with some replies dropped (BENCHDROP_EVERY=3, large iters so the phase +-- keeps sending): counter climbs 64,128,...,1280 over 20 minutes, linear, zero disconnects. +-- Received transmissions keep resetting lastReceived and timeoutErrorCount, so the drop +-- condition is never reached. Unbounded. runProxyTmo :: TVar ChaChaDRG -> Int -> Int -> IO () runProxyTmo g iters _cp = do rq <- newRelayQueue g @@ -595,7 +609,12 @@ runProxyTmo g iters _cp = do r -> fail $ "proxytmo: warmup forward failed, topology is broken: " <> show r base <- liveBytesMiB report "proxytmo" 0 base base - setDropSnd True + -- BENCHDROP_EVERY=n drops only every nth relay write instead of all of them. The replies that + -- do get through reset timeoutErrorCount and lastReceived on the proxy's client, so monitor + -- never reaches its drop condition and the session stays healthy while the unanswered + -- commands accumulate. This is the unbounded case; dropping everything is not. + dropEvery <- fromMaybe 0 . (>>= readMaybe) <$> lookupEnv "BENCHDROP_EVERY" + if dropEvery > 0 then setDropEvery dropEvery else setDropSnd True timeouts <- newTVarIO (0 :: Int) let rounds = max 1 (iters `div` batch) forM_ ([1 .. rounds] :: [Int]) $ \r -> do @@ -618,6 +637,19 @@ runProxyTmo g iters _cp = do -- process residency is NOT a doubled count of the payload. clientStuck <- sum <$> mapM pClientSentCommandsCount pcs printf "proxytmo timeouts=%d of %d attempted, benchClient_sentCommands=%d\n" n (r * batch) clientStuck + -- BENCHHOLD_SEC keeps the relay silent afterwards to see whether the proxy ever drops the + -- session and frees the map. monitor (Client.hs:668) exits, and so tears the client down, when + -- timeoutErrorCount >= smpPingCount and nothing has been received for recoverWindow (900s), + -- checked on a 600s loop. So a fully silent relay should be dropped at about 20 minutes. + -- Anything received resets both, which is why a relay that answers selectively is the + -- unbounded case rather than a silent one. + holdSec <- fromMaybe 0 . (>>= readMaybe) <$> lookupEnv "BENCHHOLD_SEC" + when (holdSec > 0) $ do + printf "proxytmo: holding relay silent for %ds to test session drop\n" (holdSec :: Int) + forM_ ([1 .. holdSec `div` 60] :: [Int]) $ \m -> do + threadDelay 60000000 + cur <- liveBytesMiB + printf "proxytmo: hold +%dmin live=%.1f MiB\n" m cur setDropSnd False where nClients = 8 diff --git a/bench/NetLag.hs b/bench/NetLag.hs index f7a58b50f..340650fd9 100644 --- a/bench/NetLag.hs +++ b/bench/NetLag.hs @@ -29,6 +29,7 @@ module NetLag ( LagTLS, setLag, setDropSnd, + setDropEvery, clearLag, ) where @@ -45,13 +46,20 @@ newtype LagTLS (p :: TransportPeer) = LagTLS (TLS p) data LagCtl = LagCtl { rcvDelayUs :: TVar Int, sndDelayUs :: TVar Int, - dropSnd :: TVar Bool + dropSnd :: TVar Bool, + -- drop every nth write, 0 disables. Distinct from dropSnd: dropping everything makes the + -- peer's monitor eventually tear the session down, while dropping a fraction keeps the + -- session healthy indefinitely because any reply resets its counters. + dropEvery :: TVar Int, + sndSeq :: TVar Int } -- A single process-wide control: getTransportConnection has nowhere to thread per-listener -- state through, and the bench runs one lagged relay at a time. lagCtl :: LagCtl -lagCtl = unsafePerformIO $ LagCtl <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO False +lagCtl = + unsafePerformIO $ + LagCtl <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO False <*> newTVarIO 0 <*> newTVarIO 0 {-# NOINLINE lagCtl #-} -- | One-way delays in microseconds: inbound (peer -> this transport) and outbound. @@ -64,8 +72,12 @@ setLag rcv snd' = atomically $ do setDropSnd :: Bool -> IO () setDropSnd b = atomically $ writeTVar (dropSnd lagCtl) b +-- | Silently discard every nth write, passing the rest. 0 disables. +setDropEvery :: Int -> IO () +setDropEvery n = atomically $ writeTVar (dropEvery lagCtl) n + clearLag :: IO () -clearLag = setLag 0 0 >> setDropSnd False +clearLag = setLag 0 0 >> setDropSnd False >> setDropEvery 0 delayBy :: TVar Int -> IO () delayBy v = do @@ -88,7 +100,11 @@ instance Transport LagTLS where cPut :: LagTLS p -> ByteString -> IO () cPut (LagTLS t) s = do delayBy (sndDelayUs lagCtl) - drop' <- readTVarIO (dropSnd lagCtl) + drop' <- atomically $ do + always <- readTVar (dropSnd lagCtl) + every <- readTVar (dropEvery lagCtl) + i <- stateTVar (sndSeq lagCtl) $ \n -> let n' = n + 1 in (n', n') + pure $ always || (every > 0 && i `mod` every == 0) unless drop' $ cPut t s getLn :: LagTLS p -> IO ByteString diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 2e15331d6..54fb44592 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -15,23 +15,51 @@ Entries go into `sentCommands` in `mkTransmission_` (`Client.hs:1418`). The only `processMsg` (`Client.hs:706`), which runs when a reply arrives. `getResponse` (`Client.hs:1383`) handles the timeout but does not receive the map, so it cannot delete. -The session does not drop either: that needs 15 minutes of total silence, and the proxy never -pings. Each entry holds the forwarded command, 16226 bytes. +Each entry holds the forwarded command, 16226 bytes. + +The session survives too. `monitor` (`Client.hs:668`) only tears the client down when +`timeoutErrorCount >= smpPingCount` and nothing has arrived for `recoverWindow` (900s), and +`receive` (`Client.hs:663`) resets both on every inbound transmission. A relay that answers some +requests and drops others therefore keeps the session healthy forever while the dropped ones +accumulate. `proxytmo 448`: `proxy_sentCommands` goes 64, 128, 192, 256, 320, 384, 448. Monotonic. About 20 KiB per entry. ### Impact -20 KiB per unanswered forward, held for the life of the relay session (days). +20 KiB per unanswered forward. How long it is held depends entirely on how the relay +misbehaves, and the three cases differ a lot. -`PRXY` is unauthenticated unless `newQueueBasicAuth` is set (`Server.hs:1534`), and it names an -arbitrary destination. A client can supply a relay that accepts and stays silent. Answering some -requests and dropping others keeps the session alive, since any reply resets the drop counters. +**Slow relay that still replies: transient, not a leak.** A late reply removes the entry, since +`processMsg` deletes on any `corrId` match whether or not the request already timed out. +Measured at 16s each way, where forwards exceed the 30s timeout: `proxy_sentCommands` oscillates +1, 0, 1, 0 and ends at 0. Growth is bounded by in-flight commands. Latency on its own does not +leak. + +**Relay that goes fully silent: bounded at about 20 minutes.** `monitor` (`Client.hs:668`) exits +when `timeoutErrorCount >= smpPingCount` and nothing has arrived for `recoverWindow` (900s), +checked on a 600s loop. It runs inside `raceAny_ ... \`finally\` disconnected` +(`Client.hs:649`), so exiting tears the client down and the map goes with it. Measured: +`proxy_sentCommands` sat at 128 for 20 minutes then went to 0, with one disconnect logged. -100k stuck commands is 2 GiB. No rate cap, see Bug 3. +**Sustained traffic with some replies dropped: unbounded.** `receive` (`Client.hs:665`) resets +both `lastReceived` and `timeoutErrorCount` on every inbound transmission, so as long as traffic +continues and some of it is answered, the drop condition is never met. Measured with 1 in 3 +relay writes dropped and forwarding running continuously: `proxy_sentCommands` climbed 64, 128, +192 ... 1280 over 20 minutes, linear at 64 per minute, with zero disconnects. It goes straight +through the 20 minute point where both idle cases collapsed to 0. -Also fires with no attacker: any round trip above 30 seconds. +At that modest rate, 64 stuck commands per minute is about 1.3 MiB per minute, or 77 MiB per +hour, on a single proxy to relay session. + +Note the traffic has to be ongoing. An attacker who floods and then stops gets their memory +reclaimed after 20 minutes. Holding it requires staying connected and keeping the requests +coming, which is cheap but not free. + +`PRXY` is unauthenticated unless `newQueueBasicAuth` is set (`Server.hs:1534`), and it names an +arbitrary destination, so a client can point the proxy at exactly such a relay. No rate cap, see +Bug 3. The ntf server uses the same client code, so it is exposed too, but less. Analysis only, not measured here, since it needs Postgres: From db4b0dbb6be458d1b630c7a255dfa9ed5cc35bc3 Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 18:36:47 +0000 Subject: [PATCH 11/43] tests: add batched subscribe leak phase --- bench/MemBench.hs | 46 ++++++++++++++++++++++++++++++++++++++++--- docs/leak-findings.md | 35 ++++++++++++++++++++------------ 2 files changed, 65 insertions(+), 16 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 0ff927fc5..bf6d52c1b 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -26,7 +26,7 @@ -- tlsstall | tlshalf | tlschurn | tlspartial -- TLS/TCP stack -- -- Two-server phases (proxy on testPort, lagged destination relay on testPort2): --- proxyfwd | proxytmo | proxychurn | proxysess +-- proxyfwd | proxytmo | proxychurn | proxysess | subtmo -- -- Env: BENCHSTORE selects the store (see srvStoreCfg); SMP_LEAKDIAG_SEC sets the LEAKDIAG -- interval (defaulted to 10s here). In two-server phases each LEAKDIAG line is tagged with the @@ -45,7 +45,8 @@ import Crypto.Random (ChaChaDRG) import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty (..), fromList) import Data.Maybe (fromMaybe) import Data.Time.Clock (getCurrentTime) import qualified Data.X509.Validation as XV @@ -655,6 +656,44 @@ runProxyTmo g iters _cp = do nClients = 8 batch = 64 +-- The batched-subscribe leak, which is how the ntf server is exposed to the same bug as the +-- proxy. subscribeSMPQueues/subscribeSMPQueuesNtfs go through sendBatch, which calls getResponse +-- once per request (Client.hs:1344), so every queue in an unanswered batch leaves its own +-- sentCommands entry. The ntf server batches 1360 at a time (agentSubsBatchSize). +-- +-- Measured on a bench-owned client so the count can be read directly with +-- pClientSentCommandsCount, rather than needing a full ntf server and its Postgres store: the +-- code path under test is identical. +runSubTmo :: TVar ChaChaDRG -> Int -> Int -> IO () +runSubTmo g iters _cp = do + ts <- getCurrentTime + rc <- + getProtocolClient g NRMInteractive (7, relaySrv, Nothing) benchClientCfg [] Nothing ts (\_ -> pure ()) + >>= either (fail . show) pure + -- create the queues while the relay still answers + qs <- forM ([1 .. iters] :: [Int]) $ \_ -> do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dh :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + QIK {rcvId} <- runExceptT' $ createSMPQueue rc NRMInteractive Nothing (rPub, rKey) dhPub Nothing SMOnlyCreate (QRMessaging Nothing) Nothing + pure (rcvId, rKey) + before <- pClientSentCommandsCount rc + base <- liveBytesMiB + report "subtmo" 0 base base + setDropSnd True + rs <- subscribeSMPQueues rc (fromList qs) + let timedOut = length [() | Left PCEResponseTimeout <- toList rs] + stuck <- pClientSentCommandsCount rc + cur <- liveBytesMiB + report "subtmo" iters base cur + printf + "subtmo: queues=%d timedOut=%d sentCommands before=%d after=%d (%+.3f KiB/entry)\n" + iters + timedOut + before + stuck + (if stuck > before then (cur - base) * 1024 / fromIntegral (stuck - before) else 0) + setDropSnd False + -- PRXY to many distinct relay addresses that refuse the connection. Each failure stores -- `Left (err, Just expiry)` in the agent's smpClients map; removal is lazy (only on a later -- lookup of the same server), so addresses never requested again are retained. @@ -852,6 +891,7 @@ main = do "proxytmo" -> runProxyTmo g iters cp "proxychurn" -> runProxyChurn g iters cp "proxysess" -> runProxySess g iters cp + "subtmo" -> runSubTmo g iters cp _ -> error $ "unknown proxy phase: " <> phase else withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> settle leakDiagSec $ do threadDelay 250000 @@ -874,7 +914,7 @@ main = do _ -> error $ "unknown phase: " <> phase proxyPhases :: [String] -proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "proxysess"] +proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "proxysess", "subtmo"] -- Hold the servers up past one LEAKDIAG interval after the phase finishes, so the end state is -- always sampled at least once. Short phases would otherwise exit before any line is emitted, diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 54fb44592..d4fab7bad 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -3,7 +3,10 @@ From `bench/MemBench.hs` extended with a proxy plus relay topology and a transport that adds latency and drops replies. -Two leaks on the proxy path, both client reachable. Two related bugs. TLS/TCP stack clean. +Two leaks on the proxy path, both client reachable. Three related bugs. TLS/TCP stack clean. + +Measured on both the journal store and the PostgreSQL queue and message store, which is the +production configuration. Results are the same on both. --- @@ -61,18 +64,24 @@ coming, which is cheap but not free. arbitrary destination, so a client can point the proxy at exactly such a relay. No rate cap, see Bug 3. -The ntf server uses the same client code, so it is exposed too, but less. Analysis only, not -measured here, since it needs Postgres: - -- Reachable through unanswered `NSUB`. `subscribeSMPQueuesNtfs` (`Client.hs:912`) batches, and - `sendBatch` calls `getResponse` once per request, so an unanswered batch leaks one entry per - queue. Batch size is 1360 (`Client/Agent.hs:131`). -- Much cheaper per entry: an `NSUB` payload rather than a 16226 byte `RFWD`. -- Partly self limiting. Every subscribe path calls `enablePings` (`Client.hs:854, 861, 907, 914, - 934`), so a fully silent server is eventually dropped and the map goes with it. The proxy - never subscribes, so it never pings, which is why only the proxy is unbounded. -- Still leaks against a server that answers pings but not subscribes, since any reply resets the - counters. +The ntf server uses the same client code, so it has the same exposure. Reachable through +unanswered `NSUB`: `subscribeSMPQueuesNtfs` (`Client.hs:912`) batches, and `sendBatch` calls +`getResponse` once per request, so an unanswered batch leaks one entry per queue. Batch size is +1360 (`Client/Agent.hs:131`). + +Measured with `subtmo 200`, which drives the same batched subscribe path on a bench owned client +so the count can be read directly: 200 queues, 200 timed out, `sentCommands` went from 0 to 200. +One entry per queue, at about 1.76 KiB each. At the ntf server's batch size that is roughly +2.3 MiB per unanswered batch. + +Cost per entry is far lower than the proxy case, a subscribe payload rather than a 16226 byte +`RFWD`, but the retention rule is identical. + +Pings are not the mitigation they look like. Subscribe paths call `enablePings` (`Client.hs:854, +861, 907, 914, 934`) and the proxy's send path does not, but that only changes liveness detection +on an otherwise idle connection. It does not bound the leak: in the unbounded case there is +sustained traffic and some replies do arrive, and every arrival resets `lastReceived` and +`timeoutErrorCount` whether or not pings are enabled. ### Fix From 8d2da160bd9708c15b972f21c3570da3ea13c5ff Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 22:18:41 +0000 Subject: [PATCH 12/43] tests: drop phase for already-fixed session var leak --- bench/MemBench.hs | 40 +++++----------------- docs/leak-findings.md | 78 +++++++++++++++++++++++++++---------------- 2 files changed, 57 insertions(+), 61 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index bf6d52c1b..9adbfd7c4 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -26,7 +26,7 @@ -- tlsstall | tlshalf | tlschurn | tlspartial -- TLS/TCP stack -- -- Two-server phases (proxy on testPort, lagged destination relay on testPort2): --- proxyfwd | proxytmo | proxychurn | proxysess | subtmo +-- proxyfwd | proxytmo | proxychurn | subtmo -- -- Env: BENCHSTORE selects the store (see srvStoreCfg); SMP_LEAKDIAG_SEC sets the LEAKDIAG -- interval (defaulted to 10s here). In two-server phases each LEAKDIAG line is tagged with the @@ -704,35 +704,12 @@ runProxyChurn g iters cp = do withCheckpoints "proxychurn" iters cp $ \i -> void $ runExceptT (connectSMPProxiedRelay pc NRMInteractive (deadSrv i) Nothing) --- PRXY against a relay that accepts TCP but never completes TLS, with the requesting client --- disconnecting mid-connect. --- --- NOT A CONFIRMED REPRO. This was written to probe the empty-SessionVar path in --- getSMPServerClient'', and it does not reach it: measured over 100 iterations, the proxy ends --- with proxy_smpClients=0, proxy_smpSessions=0, clients=0 and a thread count at baseline, both --- 5s and 55s after the loop (i.e. before and after the 45s tcpConnectTimeout expires). The --- withGetSessVar bracketOnError in Session.hs drops the empty var on the async exception, so --- the race stays closed on this path. --- --- Residency does climb ~108 KiB/iter, but with every server-side counter flat that growth is --- bench-harness retention, not a server leak - do not read it as one. The phase is kept as --- connect-abort churn coverage; reproducing the empty-SessionVar leak still needs the --- deterministic unit-test-style race, as bench/MemBench.hs already noted for the proxy leaks. -runProxySess :: TVar ChaChaDRG -> Int -> Int -> IO () -runProxySess g iters cp = - withStallingServerOn stallPort $ do - base <- liveBytesMiB - report "proxysess" 0 base base - forM_ ([1 .. iters] :: [Int]) $ \i -> do - pc <- proxyClient g (1000 + fromIntegral i) - -- start the relay connect, then drop the requesting client before it can finish - withAsync (void $ runExceptT (connectSMPProxiedRelay pc NRMInteractive stallSrv Nothing)) $ \_ -> - threadDelay 50000 - closeProtocolClient pc - when (i `mod` cp == 0) $ liveBytesMiB >>= report "proxysess" i base - where - stallPort = "5009" - stallSrv = SMPServer testHost2 stallPort testKeyHash +-- Note: the empty-SessionVar leak is NOT covered here. It was fixed in c9ebf72e by the +-- bracketOnError/dropEmptySessVar in Session.hs withGetSessVar', and SMPProxyTests already has +-- deterministic regression tests for it ("reconnects to relay after sender disconnects +-- mid-connection" and "reconnects after a connect is cancelled mid-flight"). A load phase +-- cannot reproduce a fixed race, and an earlier attempt here only measured harness growth. + -- TLS/TCP stack -------------------------------------------------------------- @@ -890,7 +867,6 @@ main = do "proxyfwd" -> runProxyFwd g iters cp "proxytmo" -> runProxyTmo g iters cp "proxychurn" -> runProxyChurn g iters cp - "proxysess" -> runProxySess g iters cp "subtmo" -> runSubTmo g iters cp _ -> error $ "unknown proxy phase: " <> phase else withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> settle leakDiagSec $ do @@ -914,7 +890,7 @@ main = do _ -> error $ "unknown phase: " <> phase proxyPhases :: [String] -proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "proxysess", "subtmo"] +proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "subtmo"] -- Hold the servers up past one LEAKDIAG interval after the phase finishes, so the end state is -- always sampled at least once. Short phases would otherwise exit before any line is emitted, diff --git a/docs/leak-findings.md b/docs/leak-findings.md index d4fab7bad..e682020de 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -93,8 +93,10 @@ Nothing -> do Pass `sentCommands` and the request's `corrId` into `getResponse`. Double delete is harmless. -Same leak with no timeout at `Client.hs:1366` and `1368`, where the request is inserted before -an early error return. +Two more entry points leak with no timeout involved. `mkTransmission_` inserts the request +before it is sent (`Client.hs:1361`), and `sendRecv` then returns early at `Client.hs:1366` +(transport error) and `Client.hs:1368` (block over `blockSize - 2`) without sending or deleting. +Both need the same delete. --- @@ -102,8 +104,14 @@ an early error return. ### Issue -A failed connect is cached in `smpClients` as `Left (error, expiry)`, removed only on a later -lookup of the same server (`Client/Agent.hs:250`, `:411`). Nothing sweeps on a timer. +A failed connect is cached in `smpClients` as `Left (error, expiry)` (`Client/Agent.hs:275`), +removed only on a later lookup of the same server (`Client/Agent.hs:250`, `:411`). Nothing sweeps +on a timer. Verified by listing every `smpClients` site: the only other removals are +`clientDisconnected` (`:311`, connected clients only) and shutdown (`:427`). + +Conditional on `persistErrorInterval > 0`. At 0 the entry is removed immediately +(`Client/Agent.hs:269-272`) and there is no leak, but production sets 30 +(`Server/Main.hs:607`). The address comes from the client via `PRXY`. Host, port and key hash are arbitrary, so distinct keys are effectively unlimited. @@ -183,26 +191,6 @@ atomically $ modifyTVar' endThreads $ IM.adjust (const (Just w)) tId --- -## Clean - -200 connections opened at once, closed, then measured again: - -| test | peak per conn | after 25s | -| ------------------------------------- | ------------- | --------- | -| TCP connect, never start TLS | 48.2 KiB | 0.31 KiB | -| TLS done, no SMP handshake | 203.1 KiB | 0.71 KiB | -| Handshake done, one byte, then quiet | 264.6 KiB | 0.87 KiB | - -All recovered. Also clean: 400 connect/disconnect rounds, and steady forwarding at 50ms each way. - -At +5s the middle two still read ~120 KiB per connection, which looks like a 24 MiB leak but is -`gracefulClose` waiting up to 5s per connection. Falling means reclaimed, flat above baseline -means leaked. - -Peaks still matter. 200 abandoned half open connections hold ~40 MiB for ~25s, unauthenticated. -A client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays -connected: no read timeout, `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs:104`). - ## Bug 5: socketsLeaked over-reports during teardown ### Issue @@ -232,6 +220,26 @@ after `gracefulClose` returns. Either ordering keeps the invariant. --- +## Clean + +200 connections opened at once, closed, then measured again: + +| test | peak per conn | after 25s | +| ------------------------------------- | ------------- | --------- | +| TCP connect, never start TLS | 48.2 KiB | 0.31 KiB | +| TLS done, no SMP handshake | 203.1 KiB | 0.71 KiB | +| Handshake done, one byte, then quiet | 264.6 KiB | 0.87 KiB | + +All recovered. Also clean: 400 connect/disconnect rounds, and steady forwarding at 50ms each way. + +At +5s the middle two still read ~120 KiB per connection, which looks like a 24 MiB leak but is +`gracefulClose` waiting up to 5s per connection. Falling means reclaimed, flat above baseline +means leaked. + +Peaks still matter. 200 abandoned half open connections hold ~40 MiB for ~25s, unauthenticated. +A client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays +connected: no read timeout, `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs:104`). + ## Connectivity and sockets under latency Latency swept with `BENCHLAG_MS` on `proxyfwd` (one way, so a request/response pair costs twice @@ -257,10 +265,22 @@ Forwards work up to 16s each way and fail at 40s. The governing limit is the 30s The exact cutoff is not pinned down: the test transport adds delay per read/write cycle rather than per message, so configured lag does not map exactly onto observed round trip. -## Not reproduced +## Already fixed: the empty session variable leak -Empty session variable leak. After 100 rounds `proxysess` ends with `proxy_smpClients=0` and -`proxy_smpSessions=0`, checked before and after the 45 second connect timeout. `bracketOnError` -in `withGetSessVar` drops the empty entry. +Worth recording because an earlier version of this report listed it as "not reproduced", which +was the wrong conclusion. It is not reproducible because it is fixed. + +`withGetSessVar'` (`Session.hs:65`) wraps the session var in `bracketOnError` with +`dropEmptySessVar`, so an interrupted connect drops the empty var instead of leaving it to +poison every later request. Fixed in `c9ebf72e` ("smp: fix proxy reconnection to relay after +restart"). + +`SMPProxyTests` already covers both the proxy and the agent variants, and both pass: + +``` +recovers when unresponsive relay restarts (control, no disconnect) [OK] +reconnects to relay after sender disconnects mid-connection [OK] +reconnects after a connect is cancelled mid-flight [OK] +``` -The ~108 KiB per round it shows is harness overhead, not a server finding. +A load phase cannot reproduce a fixed race, so the bench does not try. From f51375100599ffcbbd4e11bbe0544977f0a0fe07 Mon Sep 17 00:00:00 2001 From: sh Date: Wed, 29 Jul 2026 23:27:56 +0000 Subject: [PATCH 13/43] tests: verify socket accounting via control port --- bench/MemBench.hs | 55 ++++++++++++++++++++++++++++++--- docs/leak-findings.md | 71 ++++++++++++++++++++++++------------------- 2 files changed, 90 insertions(+), 36 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 9adbfd7c4..20fafc9a8 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -57,7 +57,7 @@ import SMPClient import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (maxJournalMsgCount, msgQueueQuota, notificationExpiration)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration)) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport @@ -65,6 +65,7 @@ import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTr import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Version (mkVersionRange) import System.Environment (getArgs, lookupEnv, setEnv) +import System.IO (BufferMode (..), IOMode (..), hClose, hGetLine, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode) import System.Mem (performMajorGC) import System.Timeout (timeout) import Text.Printf (printf) @@ -726,6 +727,29 @@ heldConns phase iters printf "%s: capping held connections at %d (requested %d) to stay within the fd limit\n" phase maxHeldConns iters pure maxHeldConns +-- Query the server control port for socket accounting. Used to check Bug 5 directly rather +-- than inferring it: socketsLeaked = accepted - closed - active, and closeConn removes a +-- connection from `active` before gracefulClose (up to 5s) and before it increments `closed`, +-- so a connection in teardown is counted in neither and shows up as leaked. +cpSockets :: N.ServiceName -> IO [String] +cpSockets port = do + sock <- rawConnect port + h <- N.socketToHandle sock ReadWriteMode + hSetBuffering h LineBuffering + hSetNewlineMode h universalNewlineMode + r <- timeout 5000000 $ do + _ <- hGetLine h -- banner line 1 + _ <- hGetLine h -- banner line 2 + hPutStrLn h "auth bench" + _ <- hGetLine h + hPutStrLn h "sockets" + replicateM 5 (hGetLine h) -- "Sockets for port N:" + accepted/closed/active/leaked + hClose h `E.catch` \(_ :: E.SomeException) -> pure () + pure $ fromMaybe [] r + +cpPort :: N.ServiceName +cpPort = "5010" + rawConnect :: N.ServiceName -> IO N.Socket rawConnect port = do let hints = N.defaultHints {N.addrSocketType = N.Stream} @@ -753,8 +777,14 @@ holdRelease phase n conn = do atomically $ readTVar connected >>= \c -> when (c < n) retry peak <- liveBytesMiB report phase n base peak + beforeRel <- cpSockets cpPort + putStrLn $ phase <> ": sockets before release: " <> unwords (map (dropWhile (== ' ')) beforeRel) atomically $ writeTVar release True wait as + -- immediately after n simultaneous teardowns: the widest possible window for the + -- accounting gap in closeConn (active decremented before closed is incremented) + afterRel <- cpSockets cpPort + putStrLn $ phase <> ": sockets right after release: " <> unwords (map (dropWhile (== ' ')) afterRel) printf "%s: peak=%.1f MiB (%+.2f KiB/conn)\n" phase peak ((peak - base) * 1024 / fromIntegral n) -- Sample recovery repeatedly rather than once. A single early sample cannot tell a leak -- from state the server has not reaped yet: the relevant server windows are 60s @@ -811,9 +841,23 @@ runTlsChurn :: Int -> Int -> IO () runTlsChurn iters cp = do base <- liveBytesMiB report "tlschurn" 0 base base - forM_ ([1 .. iters] :: [Int]) $ \i -> do - testSMPClient @TLS $ \(_h :: THandleSMP TLS 'TClient) -> pure () - when (i `mod` cp == 0) $ liveBytesMiB >>= report "tlschurn" i base + -- sample the server's own socket accounting while churn is in flight, then again once it + -- has quiesced, to see whether socketsLeaked is a real leak or a teardown artefact + churning <- newTVarIO True + let sampler = do + threadDelay 1500000 + readTVarIO churning >>= \go -> when go $ do + ls <- cpSockets cpPort + putStrLn $ "tlschurn: during churn: " <> unwords (map (dropWhile (== ' ')) ls) + sampler + withAsync sampler $ \_ -> forM_ ([1 .. iters] :: [Int]) $ \i -> do + testSMPClient @TLS $ \(_h :: THandleSMP TLS 'TClient) -> pure () + when (i `mod` cp == 0) $ liveBytesMiB >>= report "tlschurn" i base + atomically $ writeTVar churning False + -- gracefulClose holds each connection up to 5s, so wait past that before the settled sample + threadDelay 8000000 + ls <- cpSockets cpPort + putStrLn $ "tlschurn: after settling: " <> unwords (map (dropWhile (== ' ')) ls) -- post-handshake, send a partial block and idle. The server's transportTimeout is hardcoded -- Nothing, so its receive thread blocks in cGet indefinitely; only inactive-client expiry @@ -855,6 +899,9 @@ main = do -- ntfexp uses a short notification-expiration so deleteExpiredNtfs fires within the run let srvCfg = case phase of "ntfexp" -> updateCfg (srvStoreCfg storeEnv) $ \c -> c {notificationExpiration = ExpirationConfig {ttl = 2, checkInterval = 3}} + -- tlschurn reads the server's own socket counters over the control port + p | p `elem` (["tlschurn", "tlsstall", "tlshalf", "tlspartial"] :: [String]) -> + updateCfg (srvStoreCfg storeEnv) $ \c -> c {controlPort = Just cpPort, controlPortAdminAuth = Just "bench"} _ -> srvStoreCfg storeEnv -- LEAKDIAG counters are the only per-server signal in multi-server topologies, so sample -- them often enough to be useful over a bench run diff --git a/docs/leak-findings.md b/docs/leak-findings.md index e682020de..b27118bde 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -3,7 +3,7 @@ From `bench/MemBench.hs` extended with a proxy plus relay topology and a transport that adds latency and drops replies. -Two leaks on the proxy path, both client reachable. Three related bugs. TLS/TCP stack clean. +Two leaks on the proxy path, both client reachable. Two related bugs. TLS/TCP stack clean. Measured on both the journal store and the PostgreSQL queue and message store, which is the production configuration. Results are the same on both. @@ -74,6 +74,10 @@ so the count can be read directly: 200 queues, 200 timed out, `sentCommands` wen One entry per queue, at about 1.76 KiB each. At the ntf server's batch size that is roughly 2.3 MiB per unanswered batch. +`subscribeSMPQueues` (measured) and `subscribeSMPQueuesNtfs` (the ntf server's call) are the +same function bar the command constructor: both are `enablePings` followed by +`sendProtocolCommands c NRMBackground cs`. So the measurement transfers directly. + Cost per entry is far lower than the proxy case, a subscribe payload rather than a 16226 byte `RFWD`, but the retention rule is identical. @@ -191,35 +195,6 @@ atomically $ modifyTVar' endThreads $ IM.adjust (const (Just w)) tId --- -## Bug 5: socketsLeaked over-reports during teardown - -### Issue - -`closeConn` (`Transport/Server.hs:179`) removes the connection from `active`, then calls -`gracefulClose conn 5000`, then increments `closed`: - -```haskell -atomically $ writeTVar closed True >> modifyTVar' clients (IM.delete cId) -gracefulClose conn 5000 `catchAll_` pure () -atomically $ modifyTVar' gracefullyClosed (+ 1) -``` - -`socketsLeaked = accepted - closed - active` (`Transport/Server.hs:225`). For up to 5 seconds a -closing connection is in neither `closed` nor `active`, so it counts as leaked. - -### Impact - -No memory cost. Under connection churn `socketsLeaked` shows a steady nonzero value that is not -a leak, which makes the metric unusable for the thing it is named after. This is the same 5 -second teardown window that made the TLS tests look like they leaked 24 MiB. - -### Fix - -Count the connection as closed before starting `gracefulClose`, or drop it from `active` only -after `gracefulClose` returns. Either ordering keeps the invariant. - ---- - ## Clean 200 connections opened at once, closed, then measured again: @@ -233,8 +208,7 @@ after `gracefulClose` returns. Either ordering keeps the invariant. All recovered. Also clean: 400 connect/disconnect rounds, and steady forwarding at 50ms each way. At +5s the middle two still read ~120 KiB per connection, which looks like a 24 MiB leak but is -`gracefulClose` waiting up to 5s per connection. Falling means reclaimed, flat above baseline -means leaked. +teardown still in progress. Falling means reclaimed, flat above baseline means leaked. Peaks still matter. 200 abandoned half open connections hold ~40 MiB for ~25s, unauthenticated. A client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays @@ -265,6 +239,39 @@ Forwards work up to 16s each way and fail at 40s. The governing limit is the 30s The exact cutoff is not pinned down: the test transport adds delay per read/write cycle rather than per message, so configured lag does not map exactly onto observed round trip. +## Checked and not a problem: socketsLeaked accounting + +Recorded because an earlier version of this report listed it as a bug on the strength of code +reading alone, and measuring it did not bear that out. + +`closeConn` (`Transport/Server.hs:179`) removes the connection from `active`, then calls +`gracefulClose conn 5000`, then increments `closed`, and +`socketsLeaked = accepted - closed - active`. That ordering does leave a window where a closing +connection is counted in neither bucket. + +In practice the window never opened. Read over the control port during 600 sequential +connect/disconnect cycles, and again across 200 simultaneous teardowns: + +``` +during churn: accepted: 587 closed: 586 active: 1 leaked: 0 +after settling: accepted: 600 closed: 600 active: 0 leaked: 0 +before mass release: accepted: 200 closed: 0 active: 200 leaked: 0 +after mass release: accepted: 200 closed: 200 active: 0 leaked: 0 +``` + +The 5000 in `gracefulClose conn 5000` is a timeout, not a delay: it returns as soon as the peer's +close is processed, which for a clean disconnect is immediate. A peer that vanishes without +closing could in principle widen the window, but that was not produced here, so it is not +claimed. + +## Note on running the suite + +`should have similar time for auth error, whether queue exists or not` compares wall clock +timings with a 30% tolerance (45% on Postgres), and it fails intermittently when the machine is +busy. Observed twice in four runs while benches were running concurrently, then 4 of 4 and 5 of 5 +clean on an idle machine with and without the changes here. It is load sensitivity in the test, +not a regression. Run the suite on an otherwise idle machine. + ## Already fixed: the empty session variable leak Worth recording because an earlier version of this report listed it as "not reproduced", which From 0b60c8eea525a1fad1415c2da1c90c547a0ec824 Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 30 Jul 2026 06:15:52 +0000 Subject: [PATCH 14/43] tests: measure concurrency cap and fork race reachability --- bench/MemBench.hs | 96 +++++++++++++++++++++++++++++++++++++++---- docs/leak-findings.md | 36 +++++++++++++--- 2 files changed, 119 insertions(+), 13 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 20fafc9a8..2da17b1ac 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -35,7 +35,7 @@ module Main (main) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_, forConcurrently_, mapConcurrently_, wait, withAsync) +import Control.Concurrent.Async (concurrently_, forConcurrently, forConcurrently_, mapConcurrently_, wait, withAsync) import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) import qualified Control.Exception as E import Control.Concurrent.STM @@ -48,7 +48,7 @@ import Data.Int (Int64) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty (..), fromList) import Data.Maybe (fromMaybe) -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (diffUTCTime, getCurrentTime) import qualified Data.X509.Validation as XV import GHC.Stats import qualified Network.Socket as N @@ -57,7 +57,7 @@ import SMPClient import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration, serverClientConcurrency)) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport @@ -454,8 +454,11 @@ deadSrv :: Int -> SMPServer deadSrv i = SMPServer testHost2 (show (20000 + i)) testKeyHash withProxyTopology :: Maybe String -> IO a -> IO a -withProxyTopology storeEnv action = - withSmpServerConfigOn (transport @TLS) (proxySrvCfg storeEnv) testPort $ \_ -> +withProxyTopology storeEnv = withProxyTopologyCfg (proxySrvCfg storeEnv) storeEnv + +withProxyTopologyCfg :: AServerConfig -> Maybe String -> IO a -> IO a +withProxyTopologyCfg pCfg storeEnv action = + withSmpServerConfigOn (transport @TLS) pCfg testPort $ \_ -> withSmpServerConfigOn (transport @LagTLS) (relaySrvCfg storeEnv) testPort2 $ \_ -> threadDelay 250000 >> action @@ -695,6 +698,77 @@ runSubTmo g iters _cp = do (if stuck > before then (cur - base) * 1024 / fromIntegral (stuck - before) else 0) setDropSnd False +-- Bug 4 reachability: forkClient registers the thread in endThreads AFTER forkIO, so an action +-- that finishes before the parent's insert leaves a permanently stale entry. Every ordinary +-- forked command (PFWD, PRXY, RSLV) blocks on the network, and a standalone reproduction of the +-- same registration order showed 0% staleness for any action that blocks even 1ms. +-- +-- This phase probed the fast path I expected to reach it: a PFWD whose encBlock is large enough +-- that re-wrapping it as RFWD exceeds blockSize, so sendProtocolCommand_ would return TELargeMsg +-- at Client.hs:1368 without any IO. +-- +-- RESULT: that path is NOT reachable. The client's own transmission limit caps encBlock before +-- the server's re-wrap can overflow. Largest block the client will send is ~16270 bytes (16275 +-- is rejected by tPut), and at 16270 the proxy still forwards successfully - the relay answers +-- PROXY (PROTOCOL CRYPTO) on the garbage payload, which means the command did full IO. So no +-- size both fits the client and overflows the server. Kept as a boundary check in case block +-- sizes change; BENCHFWD_SZ sets the payload size. +runFastFwd :: TVar ChaChaDRG -> Int -> Int -> IO () +runFastFwd g iters _cp = + testSMPClient @TLS $ \h -> do + (kPub, _kPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + r <- sendRecv h (Nothing, "prxy", NoEntity, PRXY relaySrv Nothing) + sessId <- case r of + Resp _ _ (PKEY sId _ _) -> pure sId + _ -> fail $ "fastfwd: PRXY did not return PKEY: " <> show r + -- oversized: the proxy re-wraps this into RFWD, which then exceeds blockSize + sz <- fromMaybe 16200 . (>>= readMaybe) <$> lookupEnv "BENCHFWD_SZ" + let big = EncTransmission $ B.replicate sz 'x' + base <- liveBytesMiB + report "fastfwd" 0 base base + oks <- forM ([1 .. iters] :: [Int]) $ \i -> do + r' <- E.try @E.SomeException $ sendRecv h (Nothing, B.pack ('f' : show i), EntityId sessId, PFWD currentClientSMPRelayVersion kPub big) + pure $ case r' of + Right (_, _, Right (ERR e)) -> Right (show e) + Right (_, _, resp) -> Right (take 40 $ show resp) + Left e -> Left (take 60 $ show e) + let sent = length [() | Right _ <- oks] + printf "fastfwd: size=%d sent=%d clientRejected=%d sample=%s\n" sz sent (iters - sent) (show $ take 1 oks) + liveBytesMiB >>= report "fastfwd" iters base + -- hold the connection open so LEAKDIAG can sample this client's endThreads + threadDelay 20000000 + +-- Bug 3: serverClientConcurrency is meant to cap concurrent proxied commands per connection, +-- but forkCmd is written `bracket_ wait signal . forkClient clnt label $ action`, which releases +-- the slot as soon as the thread is forked rather than when the work finishes. +-- +-- With the cap set to 1 and the relay silent, N concurrent PFWDs on ONE connection would have to +-- serialise if the cap worked: each would hold the slot for the 30s RFWD timeout, and `wait` +-- blocks the client's whole command loop, so command k+1 could not even be read until k finished. +-- Completion times clustered together instead of spread ~30s apart mean the cap does nothing. +runConcLimit :: TVar ChaChaDRG -> Int -> Int -> IO () +runConcLimit g iters _cp = do + rq <- newRelayQueue g + pc <- proxyClient g 1 + sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relaySrv Nothing + runExceptT (proxySMPMessage pc NRMInteractive sess Nothing (rqSndId rq) noMsgFlags "warmup") >>= \case + Right (Right ()) -> pure () + r -> fail $ "conclimit: warmup failed, topology broken: " <> show r + setDropSnd True + t0 <- getCurrentTime + ends <- forConcurrently ([1 .. iters] :: [Int]) $ \_ -> do + _ <- runExceptT (proxySMPMessage pc NRMInteractive sess Nothing (rqSndId rq) noMsgFlags "x") + getCurrentTime + setDropSnd False + let secs = map (\t -> realToFrac (diffUTCTime t t0) :: Double) ends + printf + "conclimit: n=%d cap=1 completions first=%.1fs last=%.1fs spread=%.1fs\n" + iters + (minimum secs) + (maximum secs) + (maximum secs - minimum secs) + printf "conclimit: serialised would need ~%.0fs; clustered means the cap is not enforced\n" (fromIntegral iters * 30 :: Double) + -- PRXY to many distinct relay addresses that refuse the connection. Each failure stores -- `Left (err, Just expiry)` in the agent's smpClients map; removal is lazy (only on a later -- lookup of the same server), so addresses never requested again are retained. @@ -910,11 +984,19 @@ main = do setLogLevel LogInfo withGlobalLogging LogConfig {lc_file = Nothing, lc_stderr = True} $ if phase `elem` proxyPhases - then withProxyTopology storeEnv $ settle leakDiagSec $ case phase of + then + ( if phase == "conclimit" + then withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {serverClientConcurrency = 1}) storeEnv + else withProxyTopology storeEnv + ) + $ settle leakDiagSec + $ case phase of "proxyfwd" -> runProxyFwd g iters cp "proxytmo" -> runProxyTmo g iters cp "proxychurn" -> runProxyChurn g iters cp "subtmo" -> runSubTmo g iters cp + "conclimit" -> runConcLimit g iters cp + "fastfwd" -> runFastFwd g iters cp _ -> error $ "unknown proxy phase: " <> phase else withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> settle leakDiagSec $ do threadDelay 250000 @@ -937,7 +1019,7 @@ main = do _ -> error $ "unknown phase: " <> phase proxyPhases :: [String] -proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "subtmo"] +proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "subtmo", "conclimit", "fastfwd"] -- Hold the servers up past one LEAKDIAG interval after the phase finishes, so the end state is -- always sampled at least once. Short phases would otherwise exit before any line is emitted, diff --git a/docs/leak-findings.md b/docs/leak-findings.md index b27118bde..e73490574 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -151,6 +151,17 @@ bracket_ wait signal . forkClient clnt label $ action `.` binds tighter than `$`, so `signal` runs when the thread starts, not when it finishes. Only forking is limited. +Measured with `conclimit 8` and `serverClientConcurrency = 1`: eight concurrent PFWDs on one +connection, relay silent. + +``` +conclimit: n=8 cap=1 completions first=20.0s last=20.0s spread=0.0s +``` + +All eight ran concurrently. If the cap were enforced each would hold the slot for the 30s RFWD +timeout and they would need ~240s, and because `wait` blocks the client's command loop the next +command could not even be read until the previous finished. + ### Impact No memory cost. Removes the cap on how fast Leak 1 grows, and `procThreads` reads near zero at @@ -174,15 +185,28 @@ command loop when hit, so check the value first. `forkClient` (`Server.hs:1480`) registers the thread after `forkIO`. If the action finishes first, its delete misses and the insert is never undone. -100k forks: 20% stale at `-N1`, 12% at `-N4`, 0% when the action blocks 1ms. Real callers -(`PFWD`, `PRXY`, `RSLV`) wait on the network. Reachable at speed via an oversized `PFWD` that -fails the block size check without IO. +Reproduced in isolation with a verbatim copy of the registration order, 100k forks: 20% stale at +`-N1`, 12% at `-N4`, and 0% when the action blocks even 1ms. About 320 bytes per stale entry, +measured against the zero stale baseline. `deRefWeak` returns `Nothing` for all of them, so no +thread is retained. + +**No reachable trigger was found in the running server.** Every real forked command blocks on the +network (`PFWD`, `PRXY`, `RSLV`), which the 0% row rules out. The fast path I expected to work +does not exist: an oversized `PFWD` cannot make the proxy's re-wrap exceed `blockSize`, because +the client's own transmission limit caps `encBlock` first. Probed directly, largest block the +client will send is about 16270 bytes, and at that size the proxy still forwards successfully +(the relay answers `PROXY (PROTOCOL CRYPTO)`), so the no-IO return at `Client.hs:1368` is never +taken. + +Two forked paths remain untested as possible fast returns: the `sendPendingEvtsThread` write +when the send queue has drained (`Server.hs:463`), and `deliverServiceMessages` over an empty +store (`Server.hs:1974`). Neither is client controlled in an obvious way. ### Impact -About 320 bytes per entry, freed on disconnect. 10k fast failing commands on one connection is -roughly 640 KB. Minor. The real cost is that `endThreads` no longer distinguishes stuck commands -from counter error. +Latent. The defect is real and cheap to fix, but on current evidence it is not reachable from +the network. If a fast forked path does exist, the cost is about 320 bytes per occurrence, +freed on disconnect, and a misleading `endThreads` counter. ### Fix From 5f9e8c16c0046a19dbd60d5b29b0b9c3ade1dc1a Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 30 Jul 2026 06:37:53 +0000 Subject: [PATCH 15/43] docs: correct endThreads race mechanism and reachability --- docs/leak-findings.md | 80 +++++++++++++++++++++++++++++++++---------- 1 file changed, 61 insertions(+), 19 deletions(-) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index e73490574..6fdefe809 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -185,28 +185,70 @@ command loop when hit, so check the value first. `forkClient` (`Server.hs:1480`) registers the thread after `forkIO`. If the action finishes first, its delete misses and the insert is never undone. -Reproduced in isolation with a verbatim copy of the registration order, 100k forks: 20% stale at -`-N1`, 12% at `-N4`, and 0% when the action blocks even 1ms. About 320 bytes per stale entry, -measured against the zero stale baseline. `deRefWeak` returns `Nothing` for all of them, so no -thread is retained. - -**No reachable trigger was found in the running server.** Every real forked command blocks on the -network (`PFWD`, `PRXY`, `RSLV`), which the 0% row rules out. The fast path I expected to work -does not exist: an oversized `PFWD` cannot make the proxy's re-wrap exceed `blockSize`, because -the client's own transmission limit caps `encBlock` first. Probed directly, largest block the -client will send is about 16270 bytes, and at that size the proxy still forwards successfully -(the relay answers `PROXY (PROTOCOL CRYPTO)`), so the no-IO return at `Client.hs:1368` is never -taken. - -Two forked paths remain untested as possible fast returns: the `sendPendingEvtsThread` write -when the send queue has drained (`Server.hs:463`), and `deliverServiceMessages` over an empty -store (`Server.hs:1974`). Neither is client controlled in an obvious way. +Reproduced in isolation with a verbatim copy of the registration order, including the +`labelMyThread` the child runs before the action. 100k forks: 20% stale at `-N1`, 13% at `-N4`. +About 320 bytes per stale entry. `deRefWeak` returns `Nothing` for all of them, so no thread is +retained. + +### What decides the race + +Not how long the child takes. How long was the obvious guess and it is wrong. Measured over +20k forks, varying only the work the child does before its delete: + +| child does | -N1 | -N4 | +|---|---|---| +| nothing | 17.5% | 10.7% | +| spins 1us | 19.2% | 9.7% | +| spins 10us | 17.3% | 9.7% | +| spins 100us | 17.8% | 9.8% | +| one failing `connect()` | **0%** | **0.1%** | + +A spinning child does not lose the race, it *starves* the parent. What closes the window is the +child giving up the capability: a syscall, a safe FFI call, or an STM retry. So the rule is +"does the child yield before its delete", not "is the child fast". + +### Which paths yield + +There are exactly three `forkClient` call sites. + +- **`forkCmd`** (`Server.hs:1593`), used by `PFWD`/`PRXY` (`:1540`, `:1577`) and `RSLV` + (`:1639`, `:2269`). All do network IO, so all yield. `RSLV` was worth checking separately + because it is client driven at command rate, but `resolveName` has no cache + (`Server/Names.hs:62`): every call goes to `resolveHttp`. Safe. +- **`deliverServiceMessages`** (`Server.hs:1977`). Guarded by `unless hasSub`, and + `clientServiceSubscribed` is a one-way latch set at `Server.hs:2031` that is never reset + within a session. Fires at most once per connection. Safe by rate. +- **`sendPendingEvtsThread.queueEvts`** (`Server.hs:463`). This is the one that does not yield. + The child is `atomically (writeTBQueue sndQ ...)` plus three `IORef` bumps. If the queue is + still full it retries and yields, but if space appeared it commits straight through, which is + the "nothing" row above. + +The earlier oversized-`PFWD` idea does not work: the client's own transmission limit caps +`encBlock` first. Largest block the client will send is about 16270 bytes, and at that size the +proxy still forwards successfully (the relay answers `PROXY (PROTOCOL CRYPTO)`), so the no-IO +return at `Client.hs:1368` is never taken. ### Impact -Latent. The defect is real and cheap to fix, but on current evidence it is not reachable from -the network. If a fast forked path does exist, the cost is about 320 bytes per occurrence, -freed on disconnect, and a misleading `endThreads` counter. +Small and self-limiting, and I have not driven it live. + +The one non-yielding path is rate capped by construction: `sendPending` runs once per +`pendingENDInterval` (15s in production, `Server/Main.hs:581`) for each of two subscriber sets, +and forks at most once per client per run. So at most 2 forks per client per 15s, and only for a +client whose `sndQ` was full at the check and had drained by the time the child ran. At the +measured 18% that is well under one stale entry per client per 15s, about 320 bytes each. + +Everything in `endThreads` is dropped by `clientDisconnected` (`Server.hs:1237`), so nothing +survives the session. + +A client can influence both preconditions by stalling and resuming its socket reads, so I am no +longer claiming this is unreachable. I am also not claiming it is reachable: that needs winning +a sub-millisecond window at two attempts per 15s, and I did not build the repro, because a +session-scoped few hundred bytes does not justify it. The honest status is a real ordering +defect with one candidate trigger and a hard ceiling. + +The practical cost is the misleading `endThreads` counter, which conflates stale entries with +genuinely running forked commands. ### Fix From 1c77a88b5f8e38e781f57d387c9eb9e16abd73d9 Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 30 Jul 2026 07:10:54 +0000 Subject: [PATCH 16/43] tests: add proxy msgQ retention bench and counter --- bench/MemBench.hs | 59 ++++++++++++++++-- docs/leak-findings.md | 89 +++++++++++++++++++++++---- src/Simplex/Messaging/Client/Agent.hs | 8 ++- src/Simplex/Messaging/Server.hs | 4 +- 4 files changed, 139 insertions(+), 21 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 2da17b1ac..626a0017e 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -57,7 +57,8 @@ import SMPClient import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration, serverClientConcurrency)) +import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (msgQSize)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration, serverClientConcurrency, smpAgentCfg)) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport @@ -981,13 +982,18 @@ main = do -- them often enough to be useful over a bench run leakDiagSec <- fromMaybe 10 . (>>= readMaybe) <$> lookupEnv "SMP_LEAKDIAG_SEC" setEnv "SMP_LEAKDIAG_SEC" (show leakDiagSec) + -- msgqfill: proxy agent msgQ size. Default 2 so the bound is reachable; set it to the + -- production 2048 to run the same phase as a control that must not stall. + msgQSz <- fromMaybe 2 . (>>= readMaybe) <$> lookupEnv "BENCHMSGQ" setLogLevel LogInfo withGlobalLogging LogConfig {lc_file = Nothing, lc_stderr = True} $ if phase `elem` proxyPhases then - ( if phase == "conclimit" - then withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {serverClientConcurrency = 1}) storeEnv - else withProxyTopology storeEnv + ( case phase of + "conclimit" -> withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {serverClientConcurrency = 1}) storeEnv + -- shrink the proxy agent's msgQ so its bound is reachable in one run + "msgqfill" -> withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {smpAgentCfg = (smpAgentCfg c) {msgQSize = msgQSz}}) storeEnv + _ -> withProxyTopology storeEnv ) $ settle leakDiagSec $ case phase of @@ -997,6 +1003,7 @@ main = do "subtmo" -> runSubTmo g iters cp "conclimit" -> runConcLimit g iters cp "fastfwd" -> runFastFwd g iters cp + "msgqfill" -> runMsgQFill g iters cp _ -> error $ "unknown proxy phase: " <> phase else withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> settle leakDiagSec $ do threadDelay 250000 @@ -1018,8 +1025,50 @@ main = do "tlspartial" -> runTlsPartial iters cp _ -> error $ "unknown phase: " <> phase +-- Leak 3: the proxy agent's msgQ has no reader. +-- +-- newSMPClientAgent creates one msgQ (Client/Agent.hs:194) and connectClient passes that same +-- queue to every relay client (:296). The ntf server drains its copy (Notifications/Server.hs:537); +-- the SMP server does not - receiveFromProxyAgent reads agentQ only (Server.hs:475). So on a +-- proxy the queue only ever fills. +-- +-- What fills it: processMsg routes a response to msgQ when the request is found but `pending` is +-- already False (Client.hs:713), i.e. the reply arrived after the proxy's own RFWD timeout. A +-- relay that answers late therefore deposits one entry per late reply, permanently. +-- +-- Once full, `process` blocks in writeTBQueue (Client.hs:694). It is the only reader of rcvQ, so +-- every later response from that relay goes unprocessed and every forward times out. msgQ is +-- shared across relays, so this is not confined to the relay that caused it. +-- +-- Phase: force late replies until the queue is full, then clear the lag and try to forward again. +-- A healthy proxy answers; a stalled one cannot. Run with BENCHMSGQ=2048 as the control. +runMsgQFill :: TVar ChaChaDRG -> Int -> Int -> IO () +runMsgQFill g iters _cp = do + rq <- newRelayQueue g + pc <- proxyClient g 1 + sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relaySrv Nothing + -- must exceed the proxy's 30s RFWD timeout each way, or the reply is matched while still + -- pending and never reaches msgQ (measured: 20s each way is too little, 40s is enough) + lagMs <- fromMaybe 40000 . (>>= readMaybe) <$> lookupEnv "BENCHLAG_MS" + printf "msgqfill: lag=%dms each way, %d forwards to strand\n" lagMs iters + setLag (lagMs * 1000) (lagMs * 1000) + forM_ ([1 .. iters] :: [Int]) $ \_ -> + void $ runExceptT (proxySMPMessage pc NRMInteractive sess Nothing (rqSndId rq) noMsgFlags "late") + clearLag + -- let the stranded replies arrive and land in msgQ + printf "msgqfill: lag cleared, waiting %ds for late replies\n" (3 * lagMs `div` 1000) + threadDelay $ 3 * lagMs * 1000 + -- recovery probe: no lag now, so a proxy whose process thread still runs must answer + ok <- newTVarIO (0 :: Int) + forM_ ([1 .. 3] :: [Int]) $ \_ -> + runExceptT (proxySMPMessage pc NRMInteractive sess Nothing (rqSndId rq) noMsgFlags "probe") >>= \case + Right (Right ()) -> atomically $ modifyTVar' ok (+ 1) + _ -> pure () + o <- readTVarIO ok + printf "msgqfill: recovery forwards succeeded=%d/3 (0 means the proxy stalled)\n" o + proxyPhases :: [String] -proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "subtmo", "conclimit", "fastfwd"] +proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "subtmo", "conclimit", "fastfwd", "msgqfill"] -- Hold the servers up past one LEAKDIAG interval after the phase finishes, so the end state is -- always sampled at least once. Short phases would otherwise exit before any line is emitted, diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 6fdefe809..fc21b7997 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -3,7 +3,7 @@ From `bench/MemBench.hs` extended with a proxy plus relay topology and a transport that adds latency and drops replies. -Two leaks on the proxy path, both client reachable. Two related bugs. TLS/TCP stack clean. +Three leaks on the proxy path, all client reachable. Two related bugs. TLS/TCP stack clean. Measured on both the journal store and the PostgreSQL queue and message store, which is the production configuration. Results are the same on both. @@ -89,18 +89,27 @@ sustained traffic and some replies do arrive, and every arrival resets `lastRece ### Fix -```haskell -Nothing -> do - TM.delete corrId sentCommands -- new - modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout -``` +**Do not simply delete on timeout.** I had that here and it is wrong. + +Late responses are load bearing for the agent. When a reply arrives for a request that already +timed out, `processMsg` takes the `wasPending == False` branch and forwards it as `STResponse` +(`Client.hs:713`). `Agent.hs:3093` acts on those: a late `OK`/`SOK` to a `SUB` calls +`processSubOk`, which is what brings the connection back UP, and a late `MSG` is processed as a +real message. Deleting the entry on timeout turns both into `STUnexpectedError` +(`Client.hs:702`), so the agent would report an error instead of recovering the subscription, +and would drop the message. The ntf server ignores `STResponse` (`Notifications/Server.hs:540`) +so it would only gain log noise, but the agent regression is real. -Pass `sentCommands` and the request's `corrId` into `getResponse`. Double delete is harmless. +So the entry has to stay reachable for as long as a late reply is still useful, which rules out +deleting it at the timeout. The fix has to bound the map by age instead: stamp `Request` on +insert and sweep entries whose `pending` is `False` and whose stamp is older than the window in +which a late reply could still matter. That needs a window chosen against the agent's +subscription recovery behaviour, which I have not measured, so I am not proposing a number here. -Two more entry points leak with no timeout involved. `mkTransmission_` inserts the request -before it is sent (`Client.hs:1361`), and `sendRecv` then returns early at `Client.hs:1366` -(transport error) and `Client.hs:1368` (block over `blockSize - 2`) without sending or deleting. -Both need the same delete. +Two entry points do leak with no timeout involved and can be fixed as written, because no reply +is ever coming. `mkTransmission_` inserts the request before it is sent (`Client.hs:1361`) and +`sendRecv` then returns early at `Client.hs:1366` (transport error) and `Client.hs:1368` (block +over `blockSize - 2`) without sending or deleting. Both should delete. --- @@ -138,6 +147,64 @@ Sweep the map on a timer, dropping entries past their expiry. The timestamp is a --- +## Leak 3: the proxy's relay message queue has no reader + +### Issue + +`newSMPClientAgent` creates one `msgQ` (`Client/Agent.hs:194`) and `connectClient` hands that +same queue to every relay client it opens (`:296`). The ntf server drains its copy +(`Notifications/Server.hs:537`). The SMP server never drains its own: +`receiveFromProxyAgent` reads `agentQ` only (`Server.hs:475`). Grepping every `readTBQueue` on a +`msgQ` in `src/` returns three sites, and none of them is the proxy's. + +What fills it: `processMsg` routes a response to `msgQ` when the request is still in +`sentCommands` but `pending` is already `False` (`Client.hs:713`), meaning the reply arrived +after the proxy's own RFWD timeout. So every late reply from a relay deposits one entry that is +never taken out. + +When the queue is full, `processMsgs` blocks in `writeTBQueue` (`Client.hs:694`). That is the +`process` thread, and it is the only reader of `rcvQ`, so once it blocks the proxy stops +handling responses entirely and every subsequent forward times out. + +### Impact + +Measured with the `msgqfill` phase, 4 forwards at 40s each way so the replies land after the +proxy's 30s timeout, then the lag is cleared and 3 more forwards are attempted. Only +`msgQSize` differs between the runs. + +| `msgQSize` | `proxy_msgQ` at end | `proxy_sentCommands` at end | recovery forwards | +|---|---|---|---| +| 2 | 2 (at cap) | 4 and climbing | **0 of 3** | +| 2048 (production) | 4 | 0 | 3 of 3 | + +Two separate things are shown. The queue never drains: at production size it holds the 4 late +replies for the rest of the run. And when it does fill, the stall is permanent, not a slowdown: +the recovery forwards ran with no latency at all and still got nothing back. + +The queue is shared, not per relay. There is one `msgQ` per `SMPClientAgent` and one +`ProxyAgent` per server, so a single relay that answers slowly can stall the proxy's response +handling for every relay it talks to. This part is from the code, not measured: the bench +topology has one relay. + +Reachable the same way as Leak 1. `PRXY` is unauthenticated unless `newQueueBasicAuth` is set, +and names an arbitrary destination, so a client can point the proxy at a relay it controls that +answers just late enough. 2048 late replies is a cheap budget for that. + +Note this is the same relay behaviour I recorded under Leak 1 as "slow relay that still replies: +transient, not a leak". That verdict was right about `sentCommands` and wrong about the session: +the late replies that clear `sentCommands` are exactly the ones that accumulate here. + +### Fix + +Drain it, or do not create it. The SMP server has no use for these transmissions, so the honest +options are to give `ProxyAgent` a reader that discards them, or to make `msgQ` optional in +`SMPClientAgent` and pass `Nothing` for the proxy, which is already supported +(`getProtocolClient` takes `Maybe`, and `sendMsg` logs instead when it is `Nothing`). + +The second is better: a discarding reader would still allocate and copy every batch. + +--- + ## Bug 3: proxy concurrency limit is inert ### Issue diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index e2a4916e6..bcb5b5c58 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -170,11 +170,12 @@ data AgentLeakStats = AgentLeakStats alPendingServiceSubs :: Int, alPendingQueueSubs :: Int, alSmpSubWorkers :: Int, - alSentCommands :: Int + alSentCommands :: Int, + alMsgQ :: Int } getAgentLeakStats :: SMPClientAgent p -> IO AgentLeakStats -getAgentLeakStats SMPClientAgent {smpClients, smpSessions, activeServiceSubs, activeQueueSubs, pendingServiceSubs, pendingQueueSubs, smpSubWorkers} = do +getAgentLeakStats SMPClientAgent {smpClients, smpSessions, activeServiceSubs, activeQueueSubs, pendingServiceSubs, pendingQueueSubs, smpSubWorkers, msgQ} = do alSmpClients <- msize smpClients sess <- readTVarIO smpSessions alActiveServiceSubs <- msize activeServiceSubs @@ -183,7 +184,8 @@ getAgentLeakStats SMPClientAgent {smpClients, smpSessions, activeServiceSubs, ac alPendingQueueSubs <- msize pendingQueueSubs alSmpSubWorkers <- msize smpSubWorkers alSentCommands <- foldM (\ !a (_, c) -> (a +) <$> pClientSentCommandsCount c) 0 (M.elems sess) - pure AgentLeakStats {alSmpClients, alSmpSessions = M.size sess, alActiveServiceSubs, alActiveQueueSubs, alPendingServiceSubs, alPendingQueueSubs, alSmpSubWorkers, alSentCommands} + alMsgQ <- fromIntegral <$> maybe (pure 0) (atomically . lengthTBQueue) msgQ + pure AgentLeakStats {alSmpClients, alSmpSessions = M.size sess, alActiveServiceSubs, alActiveQueueSubs, alPendingServiceSubs, alPendingQueueSubs, alSmpSubWorkers, alSentCommands, alMsgQ} where msize m = M.size <$> readTVarIO m diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index c57863148..6d615958f 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -550,7 +550,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ntfMsgs <- foldM (\ !a v -> (a +) . length <$> readTVarIO v) (0 :: Int) (M.elems ntfMap) EntityCounts {queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount} <- getEntityCounts @(StoreQueue s) (queueStore ms) LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount, queueLockCount, notifierLockCount} <- loadedQueueCounts ms - AgentLeakStats {alSmpClients, alSmpSessions, alActiveServiceSubs, alActiveQueueSubs, alPendingServiceSubs, alPendingQueueSubs, alSmpSubWorkers, alSentCommands} <- getAgentLeakStats smpAgent + AgentLeakStats {alSmpClients, alSmpSessions, alActiveServiceSubs, alActiveQueueSubs, alPendingServiceSubs, alPendingQueueSubs, alSmpSubWorkers, alSentCommands, alMsgQ} <- getAgentLeakStats smpAgent logNote $ T.concat [ "LEAKDIAG", @@ -565,7 +565,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt f "ntfStore_keys" (M.size ntfMap), f "ntfStore_msgs" ntfMsgs, f "store_queues" queueCount, f "store_notifiers" notifierCount, f "store_rcvServices" rcvServiceCount, f "store_ntfServices" ntfServiceCount, f "store_rcvSvcQueues" rcvServiceQueuesCount, f "store_ntfSvcQueues" ntfServiceQueuesCount, f "loaded_queues" loadedQueueCount, f "loaded_notifiers" loadedNotifierCount, f "open_journals" openJournalCount, f "queue_locks" queueLockCount, f "notifier_locks" notifierLockCount, - f "proxy_smpClients" alSmpClients, f "proxy_smpSessions" alSmpSessions, f "proxy_activeSvcSubs" alActiveServiceSubs, f "proxy_activeQSubs" alActiveQueueSubs, f "proxy_pendingSvcSubs" alPendingServiceSubs, f "proxy_pendingQSubs" alPendingQueueSubs, f "proxy_subWorkers" alSmpSubWorkers, f "proxy_sentCommands" alSentCommands + f "proxy_smpClients" alSmpClients, f "proxy_smpSessions" alSmpSessions, f "proxy_activeSvcSubs" alActiveServiceSubs, f "proxy_activeQSubs" alActiveQueueSubs, f "proxy_pendingSvcSubs" alPendingServiceSubs, f "proxy_pendingQSubs" alPendingQueueSubs, f "proxy_subWorkers" alSmpSubWorkers, f "proxy_sentCommands" alSentCommands, f "proxy_msgQ" alMsgQ ] where f :: Show a => Text -> a -> Text From 3dd259de68b27cc85665e22270181df39f35db7e Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 30 Jul 2026 07:47:50 +0000 Subject: [PATCH 17/43] docs: condense leak findings report --- docs/leak-findings.md | 431 +++++++++++++++--------------------------- 1 file changed, 155 insertions(+), 276 deletions(-) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index fc21b7997..c962b6b90 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -1,145 +1,92 @@ # SMP server leak findings -From `bench/MemBench.hs` extended with a proxy plus relay topology and a transport that adds -latency and drops replies. +Found with `bench/MemBench.hs`, extended with a proxy plus relay topology and a transport that +adds latency and drops replies. Measured on both the journal store and PostgreSQL, same results. -Three leaks on the proxy path, all client reachable. Two related bugs. TLS/TCP stack clean. +Three leaks on the proxy path, all client reachable. Two related bugs. TLS/TCP stack is clean. -Measured on both the journal store and the PostgreSQL queue and message store, which is the -production configuration. Results are the same on both. +All three leaks are reached the same way: `PRXY` is unauthenticated unless `newQueueBasicAuth` is +set (`Server.hs:1534`) and names an arbitrary destination, so a client can point the proxy at a +relay it controls. --- -## Leak 1: forwarded commands never removed on timeout +## Leak 1: forwarded commands are never removed on timeout ### Issue Entries go into `sentCommands` in `mkTransmission_` (`Client.hs:1418`). The only removal is in `processMsg` (`Client.hs:706`), which runs when a reply arrives. `getResponse` (`Client.hs:1383`) -handles the timeout but does not receive the map, so it cannot delete. +handles the timeout but never gets the map, so it cannot delete. -Each entry holds the forwarded command, 16226 bytes. +Each entry holds the forwarded command: 16226 bytes for `RFWD`. -The session survives too. `monitor` (`Client.hs:668`) only tears the client down when -`timeoutErrorCount >= smpPingCount` and nothing has arrived for `recoverWindow` (900s), and -`receive` (`Client.hs:663`) resets both on every inbound transmission. A relay that answers some -requests and drops others therefore keeps the session healthy forever while the dropped ones -accumulate. - -`proxytmo 448`: `proxy_sentCommands` goes 64, 128, 192, 256, 320, 384, 448. Monotonic. -About 20 KiB per entry. +The session survives too. `monitor` (`Client.hs:668`) drops the client only when +`timeoutErrorCount >= smpPingCount` and nothing has arrived for 900s, and `receive` +(`Client.hs:663`) resets both on every inbound transmission. ### Impact -20 KiB per unanswered forward. How long it is held depends entirely on how the relay -misbehaves, and the three cases differ a lot. - -**Slow relay that still replies: transient, not a leak.** A late reply removes the entry, since -`processMsg` deletes on any `corrId` match whether or not the request already timed out. -Measured at 16s each way, where forwards exceed the 30s timeout: `proxy_sentCommands` oscillates -1, 0, 1, 0 and ends at 0. Growth is bounded by in-flight commands. Latency on its own does not -leak. - -**Relay that goes fully silent: bounded at about 20 minutes.** `monitor` (`Client.hs:668`) exits -when `timeoutErrorCount >= smpPingCount` and nothing has arrived for `recoverWindow` (900s), -checked on a 600s loop. It runs inside `raceAny_ ... \`finally\` disconnected` -(`Client.hs:649`), so exiting tears the client down and the map goes with it. Measured: -`proxy_sentCommands` sat at 128 for 20 minutes then went to 0, with one disconnect logged. - -**Sustained traffic with some replies dropped: unbounded.** `receive` (`Client.hs:665`) resets -both `lastReceived` and `timeoutErrorCount` on every inbound transmission, so as long as traffic -continues and some of it is answered, the drop condition is never met. Measured with 1 in 3 -relay writes dropped and forwarding running continuously: `proxy_sentCommands` climbed 64, 128, -192 ... 1280 over 20 minutes, linear at 64 per minute, with zero disconnects. It goes straight -through the 20 minute point where both idle cases collapsed to 0. - -At that modest rate, 64 stuck commands per minute is about 1.3 MiB per minute, or 77 MiB per -hour, on a single proxy to relay session. - -Note the traffic has to be ongoing. An attacker who floods and then stops gets their memory -reclaimed after 20 minutes. Holding it requires staying connected and keeping the requests -coming, which is cheap but not free. - -`PRXY` is unauthenticated unless `newQueueBasicAuth` is set (`Server.hs:1534`), and it names an -arbitrary destination, so a client can point the proxy at exactly such a relay. No rate cap, see -Bug 3. - -The ntf server uses the same client code, so it has the same exposure. Reachable through -unanswered `NSUB`: `subscribeSMPQueuesNtfs` (`Client.hs:912`) batches, and `sendBatch` calls -`getResponse` once per request, so an unanswered batch leaks one entry per queue. Batch size is -1360 (`Client/Agent.hs:131`). - -Measured with `subtmo 200`, which drives the same batched subscribe path on a bench owned client -so the count can be read directly: 200 queues, 200 timed out, `sentCommands` went from 0 to 200. -One entry per queue, at about 1.76 KiB each. At the ntf server's batch size that is roughly -2.3 MiB per unanswered batch. - -`subscribeSMPQueues` (measured) and `subscribeSMPQueuesNtfs` (the ntf server's call) are the -same function bar the command constructor: both are `enablePings` followed by -`sendProtocolCommands c NRMBackground cs`. So the measurement transfers directly. - -Cost per entry is far lower than the proxy case, a subscribe payload rather than a 16226 byte -`RFWD`, but the retention rule is identical. - -Pings are not the mitigation they look like. Subscribe paths call `enablePings` (`Client.hs:854, -861, 907, 914, 934`) and the proxy's send path does not, but that only changes liveness detection -on an otherwise idle connection. It does not bound the leak: in the unbounded case there is -sustained traffic and some replies do arrive, and every arrival resets `lastReceived` and -`timeoutErrorCount` whether or not pings are enabled. +About 20 KiB per unanswered forward. How long it is held depends on how the relay misbehaves. -### Fix +| relay behaviour | result | +| --- | --- | +| slow but still replies | not a leak here, the late reply deletes the entry (but see Leak 3) | +| goes fully silent | bounded, `monitor` tears the client down at ~20 min | +| replies to some, drops others | **unbounded** | -**Do not simply delete on timeout.** I had that here and it is wrong. +The third case is the problem. Any arriving reply resets `lastReceived` and `timeoutErrorCount`, +so the drop condition is never met. Measured with 1 in 3 relay writes dropped and forwarding +running: `proxy_sentCommands` climbed 64 to 1280 over 20 minutes, linear at 64/min, zero +disconnects. That is ~1.3 MiB/min, ~77 MiB/hour, on one session. -Late responses are load bearing for the agent. When a reply arrives for a request that already -timed out, `processMsg` takes the `wasPending == False` branch and forwards it as `STResponse` -(`Client.hs:713`). `Agent.hs:3093` acts on those: a late `OK`/`SOK` to a `SUB` calls -`processSubOk`, which is what brings the connection back UP, and a late `MSG` is processed as a -real message. Deleting the entry on timeout turns both into `STUnexpectedError` -(`Client.hs:702`), so the agent would report an error instead of recovering the subscription, -and would drop the message. The ntf server ignores `STResponse` (`Notifications/Server.hs:540`) -so it would only gain log noise, but the agent regression is real. +Traffic has to be ongoing. Flood and stop and it is reclaimed after 20 minutes. -So the entry has to stay reachable for as long as a late reply is still useful, which rules out -deleting it at the timeout. The fix has to bound the map by age instead: stamp `Request` on -insert and sweep entries whose `pending` is `False` and whose stamp is older than the window in -which a late reply could still matter. That needs a window chosen against the agent's -subscription recovery behaviour, which I have not measured, so I am not proposing a number here. +The ntf server uses the same client code and has the same exposure through unanswered `NSUB`. +Measured with `subtmo 200`: 200 queues, 200 timed out, `sentCommands` 0 to 200, ~1.76 KiB each. +At the ntf batch size of 1360 that is ~2.3 MiB per unanswered batch. -Two entry points do leak with no timeout involved and can be fixed as written, because no reply -is ever coming. `mkTransmission_` inserts the request before it is sent (`Client.hs:1361`) and -`sendRecv` then returns early at `Client.hs:1366` (transport error) and `Client.hs:1368` (block -over `blockSize - 2`) without sending or deleting. Both should delete. +Pings do not help. Subscribe paths call `enablePings` and the proxy send path does not, but in +the unbounded case replies are arriving anyway, which resets the counters either way. ---- +### Fix -## Leak 2: failed relay connects never cleared +Do not just delete on timeout. Late replies are load bearing: `processMsg` forwards them as +`STResponse` (`Client.hs:713`), and `Agent.hs:3093` acts on them. A late `OK`/`SOK` to a `SUB` +calls `processSubOk`, which is what brings a connection back UP, and a late `MSG` is processed as +a real message. Deleting on timeout turns both into `STUnexpectedError` (`Client.hs:702`), so the +agent would report an error instead of recovering, and drop the message. -### Issue +Bound the map by age instead: stamp `Request` on insert, sweep entries with `pending == False` +older than the window in which a late reply can still matter. Picking that window needs the +agent's recovery behaviour measured, which is not done here. -A failed connect is cached in `smpClients` as `Left (error, expiry)` (`Client/Agent.hs:275`), -removed only on a later lookup of the same server (`Client/Agent.hs:250`, `:411`). Nothing sweeps -on a timer. Verified by listing every `smpClients` site: the only other removals are -`clientDisconnected` (`:311`, connected clients only) and shutdown (`:427`). +Two entry points can be fixed by deleting, because no reply is ever coming. `mkTransmission_` +inserts before sending (`Client.hs:1361`) and `sendRecv` returns early at `Client.hs:1366` +(transport error) and `Client.hs:1368` (oversized block) without sending or deleting. -Conditional on `persistErrorInterval > 0`. At 0 the entry is removed immediately -(`Client/Agent.hs:269-272`) and there is no leak, but production sets 30 -(`Server/Main.hs:607`). +--- -The address comes from the client via `PRXY`. Host, port and key hash are arbitrary, so distinct -keys are effectively unlimited. +## Leak 2: failed relay connects are never cleared -`proxychurn 300`: `proxy_smpClients = 300`, none removed. A 1000 run settles at ~19 KiB per -entry, created in about 1 second. +### Issue -### Impact +A failed connect is cached in `smpClients` as `Left (error, expiry)` (`Client/Agent.hs:275`) and +removed only on a later lookup of the same server (`:250`, `:411`). Nothing sweeps on a timer. +The other removals are `clientDisconnected` (`:311`, connected clients only) and shutdown +(`:427`). + +Conditional on `persistErrorInterval > 0`. At 0 the entry goes immediately, but production sets +30 (`Server/Main.hs:607`). -19 KiB per address, never freed while the process runs. +### Impact -About 19 MiB/s when the address refuses immediately. An address that blackholes instead waits -out the 45 second connect timeout, which throttles it heavily. +Host, port and key hash come from the client, so distinct addresses are unlimited. Measured: +`proxy_smpClients = 300` after 300 dead addresses, ~19 KiB each, never freed while the process +runs. 1000 entries created in about 1s. -Same unauthenticated `PRXY` as Leak 1. +That is ~19 MiB/s when the address refuses immediately. An address that blackholes waits out the +45s connect timeout, which throttles it heavily. ### Fix @@ -151,57 +98,47 @@ Sweep the map on a timer, dropping entries past their expiry. The timestamp is a ### Issue -`newSMPClientAgent` creates one `msgQ` (`Client/Agent.hs:194`) and `connectClient` hands that -same queue to every relay client it opens (`:296`). The ntf server drains its copy -(`Notifications/Server.hs:537`). The SMP server never drains its own: -`receiveFromProxyAgent` reads `agentQ` only (`Server.hs:475`). Grepping every `readTBQueue` on a -`msgQ` in `src/` returns three sites, and none of them is the proxy's. +`newSMPClientAgent` creates one `msgQ` (`Client/Agent.hs:194`) and `connectClient` gives that same +queue to every relay client (`:296`). The ntf server drains its copy +(`Notifications/Server.hs:537`). The SMP server never drains its own: `receiveFromProxyAgent` +reads `agentQ` only (`Server.hs:475`). There are three `readTBQueue` sites on a `msgQ` in `src/` +and none is the proxy's. -What fills it: `processMsg` routes a response to `msgQ` when the request is still in -`sentCommands` but `pending` is already `False` (`Client.hs:713`), meaning the reply arrived -after the proxy's own RFWD timeout. So every late reply from a relay deposits one entry that is -never taken out. +It fills from late replies. `processMsg` routes a response to `msgQ` when the request is still in +`sentCommands` but `pending` is already `False` (`Client.hs:713`), so every reply arriving after +the proxy's 30s RFWD timeout leaves an entry that nothing takes out. -When the queue is full, `processMsgs` blocks in `writeTBQueue` (`Client.hs:694`). That is the -`process` thread, and it is the only reader of `rcvQ`, so once it blocks the proxy stops -handling responses entirely and every subsequent forward times out. +When it is full, `processMsgs` blocks in `writeTBQueue` (`Client.hs:694`). That is the `process` +thread, the only reader of `rcvQ`, so the proxy stops handling responses entirely. ### Impact -Measured with the `msgqfill` phase, 4 forwards at 40s each way so the replies land after the -proxy's 30s timeout, then the lag is cleared and 3 more forwards are attempted. Only -`msgQSize` differs between the runs. +Measured with the `msgqfill` phase: 4 forwards at 40s each way so replies land after the timeout, +then lag cleared and 3 more attempted. Only `msgQSize` differs. -| `msgQSize` | `proxy_msgQ` at end | `proxy_sentCommands` at end | recovery forwards | -|---|---|---|---| +| `msgQSize` | `proxy_msgQ` at end | `sentCommands` at end | recovery forwards | +| --- | --- | --- | --- | | 2 | 2 (at cap) | 4 and climbing | **0 of 3** | | 2048 (production) | 4 | 0 | 3 of 3 | -Two separate things are shown. The queue never drains: at production size it holds the 4 late -replies for the rest of the run. And when it does fill, the stall is permanent, not a slowdown: -the recovery forwards ran with no latency at all and still got nothing back. +Two things. The queue never drains: at production size it still holds the 4 late replies at the +end of the run. And when it fills the stall is permanent, not slow: the recovery forwards ran +with no latency at all and got nothing back. -The queue is shared, not per relay. There is one `msgQ` per `SMPClientAgent` and one -`ProxyAgent` per server, so a single relay that answers slowly can stall the proxy's response -handling for every relay it talks to. This part is from the code, not measured: the bench -topology has one relay. +One `msgQ` per agent and one `ProxyAgent` per server, so one slow relay stalls the proxy for every +relay it talks to. That part is from the code, not measured: the bench has one relay. -Reachable the same way as Leak 1. `PRXY` is unauthenticated unless `newQueueBasicAuth` is set, -and names an arbitrary destination, so a client can point the proxy at a relay it controls that -answers just late enough. 2048 late replies is a cheap budget for that. +2048 late replies is a cheap budget for an attacker who controls the destination relay. -Note this is the same relay behaviour I recorded under Leak 1 as "slow relay that still replies: -transient, not a leak". That verdict was right about `sentCommands` and wrong about the session: -the late replies that clear `sentCommands` are exactly the ones that accumulate here. +This also corrects Leak 1's "slow relay is not a leak" row. That is right about `sentCommands` and +wrong about the session: the late replies that clear `sentCommands` are the ones that pile up +here. ### Fix -Drain it, or do not create it. The SMP server has no use for these transmissions, so the honest -options are to give `ProxyAgent` a reader that discards them, or to make `msgQ` optional in -`SMPClientAgent` and pass `Nothing` for the proxy, which is already supported -(`getProtocolClient` takes `Maybe`, and `sendMsg` logs instead when it is `Nothing`). - -The second is better: a discarding reader would still allocate and copy every batch. +Make `msgQ` optional in `SMPClientAgent` and pass `Nothing` for the proxy. `getProtocolClient` +already takes a `Maybe` and `sendMsg` logs instead when it is `Nothing`. A discarding reader would +also work but still allocates and copies every batch. --- @@ -218,21 +155,19 @@ bracket_ wait signal . forkClient clnt label $ action `.` binds tighter than `$`, so `signal` runs when the thread starts, not when it finishes. Only forking is limited. -Measured with `conclimit 8` and `serverClientConcurrency = 1`: eight concurrent PFWDs on one -connection, relay silent. +Measured with `conclimit 8` and `serverClientConcurrency = 1`, eight concurrent PFWDs on one +connection, relay silent: ``` conclimit: n=8 cap=1 completions first=20.0s last=20.0s spread=0.0s ``` -All eight ran concurrently. If the cap were enforced each would hold the slot for the 30s RFWD -timeout and they would need ~240s, and because `wait` blocks the client's command loop the next -command could not even be read until the previous finished. +All eight ran at once. Enforced, each would hold the slot for the 30s RFWD timeout, needing ~240s. ### Impact -No memory cost. Removes the cap on how fast Leak 1 grows, and `procThreads` reads near zero at -any load. +No memory cost of its own. Removes the cap on how fast Leak 1 grows, and `procThreads` reads near +zero at any load. ### Fix @@ -240,8 +175,8 @@ any load. wait >> forkClient clnt label (action `finally` signal) ``` -This enables the limit for the first time. Default is 32, and `wait` blocks the client's whole -command loop when hit, so check the value first. +This turns the limit on for the first time. Default is 32 and `wait` blocks the client's whole +command loop when hit, so check that value first. --- @@ -249,73 +184,50 @@ command loop when hit, so check the value first. ### Issue -`forkClient` (`Server.hs:1480`) registers the thread after `forkIO`. If the action finishes -first, its delete misses and the insert is never undone. - -Reproduced in isolation with a verbatim copy of the registration order, including the -`labelMyThread` the child runs before the action. 100k forks: 20% stale at `-N1`, 13% at `-N4`. -About 320 bytes per stale entry. `deRefWeak` returns `Nothing` for all of them, so no thread is -retained. +`forkClient` (`Server.hs:1480`) registers the thread after `forkIO`. If the action finishes first, +its delete misses and the insert is never undone. -### What decides the race +Reproduced in isolation, 100k forks: 20% stale at `-N1`, 13% at `-N4`, ~320 bytes each. +`deRefWeak` returns `Nothing` for all of them, so no thread is retained. -Not how long the child takes. How long was the obvious guess and it is wrong. Measured over -20k forks, varying only the work the child does before its delete: +What decides it is not how long the child takes. Measured over 20k forks, varying only the child's +work before its delete: | child does | -N1 | -N4 | -|---|---|---| +| --- | --- | --- | | nothing | 17.5% | 10.7% | | spins 1us | 19.2% | 9.7% | -| spins 10us | 17.3% | 9.7% | | spins 100us | 17.8% | 9.8% | | one failing `connect()` | **0%** | **0.1%** | -A spinning child does not lose the race, it *starves* the parent. What closes the window is the -child giving up the capability: a syscall, a safe FFI call, or an STM retry. So the rule is -"does the child yield before its delete", not "is the child fast". - -### Which paths yield +A spinning child does not lose the race, it starves the parent. The window closes when the child +gives up the capability: syscall, safe FFI call, or STM retry. -There are exactly three `forkClient` call sites. +Against that rule, of the three call sites: -- **`forkCmd`** (`Server.hs:1593`), used by `PFWD`/`PRXY` (`:1540`, `:1577`) and `RSLV` - (`:1639`, `:2269`). All do network IO, so all yield. `RSLV` was worth checking separately - because it is client driven at command rate, but `resolveName` has no cache - (`Server/Names.hs:62`): every call goes to `resolveHttp`. Safe. -- **`deliverServiceMessages`** (`Server.hs:1977`). Guarded by `unless hasSub`, and - `clientServiceSubscribed` is a one-way latch set at `Server.hs:2031` that is never reset - within a session. Fires at most once per connection. Safe by rate. -- **`sendPendingEvtsThread.queueEvts`** (`Server.hs:463`). This is the one that does not yield. - The child is `atomically (writeTBQueue sndQ ...)` plus three `IORef` bumps. If the queue is - still full it retries and yields, but if space appeared it commits straight through, which is - the "nothing" row above. - -The earlier oversized-`PFWD` idea does not work: the client's own transmission limit caps -`encBlock` first. Largest block the client will send is about 16270 bytes, and at that size the -proxy still forwards successfully (the relay answers `PROXY (PROTOCOL CRYPTO)`), so the no-IO -return at `Client.hs:1368` is never taken. +- `forkCmd` (`Server.hs:1593`) for `PFWD`/`PRXY`/`RSLV`: all do network IO, all yield. `RSLV` was + checked separately since it is client driven at command rate, but `resolveName` has no cache + (`Server/Names.hs:62`). +- `deliverServiceMessages` (`Server.hs:1977`): `clientServiceSubscribed` is a one-way latch + (`Server.hs:2031`), so at most once per connection. +- `sendPendingEvtsThread.queueEvts` (`Server.hs:463`): the only one that can skip yielding. The + child is `writeTBQueue sndQ` plus three `IORef` bumps, so if space appeared it commits straight + through. ### Impact -Small and self-limiting, and I have not driven it live. - -The one non-yielding path is rate capped by construction: `sendPending` runs once per -`pendingENDInterval` (15s in production, `Server/Main.hs:581`) for each of two subscriber sets, -and forks at most once per client per run. So at most 2 forks per client per 15s, and only for a -client whose `sndQ` was full at the check and had drained by the time the child ran. At the -measured 18% that is well under one stale entry per client per 15s, about 320 bytes each. +Small and bounded, and not driven live. -Everything in `endThreads` is dropped by `clientDisconnected` (`Server.hs:1237`), so nothing +The one non-yielding path forks at most twice per client per `pendingENDInterval` (15s, +`Server/Main.hs:581`), and only for a client whose `sndQ` was full at the check and drained by the +time the child ran. `clientDisconnected` (`Server.hs:1237`) drops the whole map, so nothing survives the session. -A client can influence both preconditions by stalling and resuming its socket reads, so I am no -longer claiming this is unreachable. I am also not claiming it is reachable: that needs winning -a sub-millisecond window at two attempts per 15s, and I did not build the repro, because a -session-scoped few hundred bytes does not justify it. The honest status is a real ordering -defect with one candidate trigger and a hard ceiling. +A client can influence both preconditions by stalling and resuming socket reads, so this is not +unreachable, but winning a sub-millisecond window at two attempts per 15s was not demonstrated. -The practical cost is the misleading `endThreads` counter, which conflates stale entries with -genuinely running forked commands. +Practical cost is the misleading `endThreads` counter, which mixes stale entries with genuinely +running forked commands. ### Fix @@ -328,99 +240,66 @@ atomically $ modifyTVar' endThreads $ IM.adjust (const (Just w)) tId --- -## Clean +## Clean: TLS/TCP stack 200 connections opened at once, closed, then measured again: -| test | peak per conn | after 25s | -| ------------------------------------- | ------------- | --------- | -| TCP connect, never start TLS | 48.2 KiB | 0.31 KiB | -| TLS done, no SMP handshake | 203.1 KiB | 0.71 KiB | -| Handshake done, one byte, then quiet | 264.6 KiB | 0.87 KiB | +| test | peak per conn | after 25s | +| --- | --- | --- | +| TCP connect, never start TLS | 48.2 KiB | 0.31 KiB | +| TLS done, no SMP handshake | 203.1 KiB | 0.71 KiB | +| handshake done, one byte, then quiet | 264.6 KiB | 0.87 KiB | All recovered. Also clean: 400 connect/disconnect rounds, and steady forwarding at 50ms each way. -At +5s the middle two still read ~120 KiB per connection, which looks like a 24 MiB leak but is -teardown still in progress. Falling means reclaimed, flat above baseline means leaked. +Sample late. At +5s the middle two still read ~120 KiB per connection, which looks like a 24 MiB +leak but is teardown in progress. Falling means reclaimed, flat above baseline means leaked. -Peaks still matter. 200 abandoned half open connections hold ~40 MiB for ~25s, unauthenticated. -A client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays -connected: no read timeout, `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs:104`). +Peaks still matter: 200 abandoned half open connections hold ~40 MiB for ~25s, unauthenticated. A +client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays +connected, since `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs:104`). -## Connectivity and sockets under latency +## Clean: connectivity and sockets under latency -Latency swept with `BENCHLAG_MS` on `proxyfwd` (one way, so a request/response pair costs twice -this). Sockets counted from `/proc//fd` during the run. +`BENCHLAG_MS` swept on `proxyfwd`, one way. Sockets counted from `/proc//fd`. | lag each way | delivered | sockets | relay connects | reconnects | timeouts | -| ------------ | --------- | ------- | -------------- | ---------- | -------- | -| 0ms | 12/12 | 8 | 1 | 0 | 0 | -| 500ms | 10/10 | 8 | 1 | 0 | 0 | -| 5s | 6/6 | 8 | 1 | 0 | 0 | -| 16s | 4/4 | 8 | 1 | 0 | 0 | -| 40s | 0/2 | 8 | 1 | 0 | 1 | - -Nothing accumulates. The socket count is the same whether forwards succeed or time out, the -proxy to relay session is opened once and reused, and there are no reconnects at any latency. -`proxy_smpClients` and `proxy_smpSessions` stay at 1 throughout. - -This is the bad news for Leak 1. The session holding the stuck `sentCommands` entries never -drops, so nothing ever frees them. A connection that broke under latency would at least bound -the damage. - -Forwards work up to 16s each way and fail at 40s. The governing limit is the 30s RFWD timeout. -The exact cutoff is not pinned down: the test transport adds delay per read/write cycle rather -than per message, so configured lag does not map exactly onto observed round trip. - -## Checked and not a problem: socketsLeaked accounting +| --- | --- | --- | --- | --- | --- | +| 0ms | 12/12 | 8 | 1 | 0 | 0 | +| 500ms | 10/10 | 8 | 1 | 0 | 0 | +| 5s | 6/6 | 8 | 1 | 0 | 0 | +| 16s | 4/4 | 8 | 1 | 0 | 0 | +| 40s | 0/2 | 8 | 1 | 0 | 1 | -Recorded because an earlier version of this report listed it as a bug on the strength of code -reading alone, and measuring it did not bear that out. +Nothing accumulates. Same socket count whether forwards succeed or time out, session opened once +and reused, no reconnects at any latency. -`closeConn` (`Transport/Server.hs:179`) removes the connection from `active`, then calls -`gracefulClose conn 5000`, then increments `closed`, and -`socketsLeaked = accepted - closed - active`. That ordering does leave a window where a closing -connection is counted in neither bucket. +That robustness is what makes Leak 1 unbounded: the session holding the stuck entries never drops. -In practice the window never opened. Read over the control port during 600 sequential -connect/disconnect cycles, and again across 200 simultaneous teardowns: +Forwards work to 16s each way and fail at 40s, governed by the 30s RFWD timeout. The exact cutoff +is not pinned down, since the test transport delays per read/write cycle rather than per message. -``` -during churn: accepted: 587 closed: 586 active: 1 leaked: 0 -after settling: accepted: 600 closed: 600 active: 0 leaked: 0 -before mass release: accepted: 200 closed: 0 active: 200 leaked: 0 -after mass release: accepted: 200 closed: 200 active: 0 leaked: 0 -``` - -The 5000 in `gracefulClose conn 5000` is a timeout, not a delay: it returns as soon as the peer's -close is processed, which for a clean disconnect is immediate. A peer that vanishes without -closing could in principle widen the window, but that was not produced here, so it is not -claimed. +## Checked, not a problem: socketsLeaked accounting -## Note on running the suite +`closeConn` (`Transport/Server.hs:179`) removes from `active`, calls `gracefulClose conn 5000`, +then increments `closed`, and `socketsLeaked = accepted - closed - active`. That ordering leaves a +window where a closing connection is in neither bucket. -`should have similar time for auth error, whether queue exists or not` compares wall clock -timings with a 30% tolerance (45% on Postgres), and it fails intermittently when the machine is -busy. Observed twice in four runs while benches were running concurrently, then 4 of 4 and 5 of 5 -clean on an idle machine with and without the changes here. It is load sensitivity in the test, -not a regression. Run the suite on an otherwise idle machine. +The window never opened in practice. Over 600 sequential cycles and 200 simultaneous teardowns, +read from the control port, `leaked` was 0 at every sample. The 5000 is a timeout, not a delay. -## Already fixed: the empty session variable leak +Listed because an earlier version of this report called it a bug on code reading alone. -Worth recording because an earlier version of this report listed it as "not reproduced", which -was the wrong conclusion. It is not reproducible because it is fixed. +## Already fixed: empty session variable `withGetSessVar'` (`Session.hs:65`) wraps the session var in `bracketOnError` with -`dropEmptySessVar`, so an interrupted connect drops the empty var instead of leaving it to -poison every later request. Fixed in `c9ebf72e` ("smp: fix proxy reconnection to relay after -restart"). +`dropEmptySessVar`, so an interrupted connect drops the empty var. Fixed in `c9ebf72e`. +`SMPProxyTests` covers the proxy and agent variants and both pass. Not reproducible because it is +fixed, not because it never happened. -`SMPProxyTests` already covers both the proxy and the agent variants, and both pass: - -``` -recovers when unresponsive relay restarts (control, no disconnect) [OK] -reconnects to relay after sender disconnects mid-connection [OK] -reconnects after a connect is cancelled mid-flight [OK] -``` +## Running the suite -A load phase cannot reproduce a fixed race, so the bench does not try. +`should have similar time for auth error, whether queue exists or not` compares wall clock with a +30% tolerance (45% on Postgres) and fails intermittently on a busy machine. Seen twice in four +runs under concurrent bench load, then 4/4 and 5/5 clean when idle, with and without these +changes. Run the suite on an idle machine. From 068b9299171ada512cee406b22cf34871dce3548 Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 30 Jul 2026 07:50:30 +0000 Subject: [PATCH 18/43] docs: use plainer wording in leak findings --- docs/leak-findings.md | 103 ++++++++++++++++++++++-------------------- 1 file changed, 53 insertions(+), 50 deletions(-) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index c962b6b90..b7f7a3813 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -32,7 +32,7 @@ About 20 KiB per unanswered forward. How long it is held depends on how the rela | relay behaviour | result | | --- | --- | | slow but still replies | not a leak here, the late reply deletes the entry (but see Leak 3) | -| goes fully silent | bounded, `monitor` tears the client down at ~20 min | +| goes fully silent | bounded, `monitor` closes the client at ~20 min | | replies to some, drops others | **unbounded** | The third case is the problem. Any arriving reply resets `lastReceived` and `timeoutErrorCount`, @@ -51,15 +51,15 @@ the unbounded case replies are arriving anyway, which resets the counters either ### Fix -Do not just delete on timeout. Late replies are load bearing: `processMsg` forwards them as +Do not just delete on timeout. The agent still needs late replies. `processMsg` forwards them as `STResponse` (`Client.hs:713`), and `Agent.hs:3093` acts on them. A late `OK`/`SOK` to a `SUB` calls `processSubOk`, which is what brings a connection back UP, and a late `MSG` is processed as a real message. Deleting on timeout turns both into `STUnexpectedError` (`Client.hs:702`), so the agent would report an error instead of recovering, and drop the message. -Bound the map by age instead: stamp `Request` on insert, sweep entries with `pending == False` -older than the window in which a late reply can still matter. Picking that window needs the -agent's recovery behaviour measured, which is not done here. +Delete by age instead: record the time on `Request` when it is added, and remove entries with +`pending == False` that are older than the point where a late reply is no longer useful. Choosing +that age needs the agent's recovery behaviour measured, which is not done here. Two entry points can be fixed by deleting, because no reply is ever coming. `mkTransmission_` inserts before sending (`Client.hs:1361`) and `sendRecv` returns early at `Client.hs:1366` @@ -72,7 +72,7 @@ inserts before sending (`Client.hs:1361`) and `sendRecv` returns early at `Clien ### Issue A failed connect is cached in `smpClients` as `Left (error, expiry)` (`Client/Agent.hs:275`) and -removed only on a later lookup of the same server (`:250`, `:411`). Nothing sweeps on a timer. +removed only on a later lookup of the same server (`:250`, `:411`). Nothing removes it on a timer. The other removals are `clientDisconnected` (`:311`, connected clients only) and shutdown (`:427`). @@ -85,12 +85,12 @@ Host, port and key hash come from the client, so distinct addresses are unlimite `proxy_smpClients = 300` after 300 dead addresses, ~19 KiB each, never freed while the process runs. 1000 entries created in about 1s. -That is ~19 MiB/s when the address refuses immediately. An address that blackholes waits out the -45s connect timeout, which throttles it heavily. +That is ~19 MiB/s when the address refuses the connection immediately. An address that accepts +nothing and never answers waits out the 45s connect timeout, which slows it right down. ### Fix -Sweep the map on a timer, dropping entries past their expiry. The timestamp is already stored. +Check the map on a timer and remove entries past their expiry. The timestamp is already stored. --- @@ -99,8 +99,8 @@ Sweep the map on a timer, dropping entries past their expiry. The timestamp is a ### Issue `newSMPClientAgent` creates one `msgQ` (`Client/Agent.hs:194`) and `connectClient` gives that same -queue to every relay client (`:296`). The ntf server drains its copy -(`Notifications/Server.hs:537`). The SMP server never drains its own: `receiveFromProxyAgent` +queue to every relay client (`:296`). The ntf server reads its copy +(`Notifications/Server.hs:537`). The SMP server never reads its own: `receiveFromProxyAgent` reads `agentQ` only (`Server.hs:475`). There are three `readTBQueue` sites on a `msgQ` in `src/` and none is the proxy's. @@ -121,14 +121,14 @@ then lag cleared and 3 more attempted. Only `msgQSize` differs. | 2 | 2 (at cap) | 4 and climbing | **0 of 3** | | 2048 (production) | 4 | 0 | 3 of 3 | -Two things. The queue never drains: at production size it still holds the 4 late replies at the -end of the run. And when it fills the stall is permanent, not slow: the recovery forwards ran +Two things. The queue is never emptied: at production size it still holds the 4 late replies at +the end of the run. And when it fills the stall is permanent, not slow: the recovery forwards ran with no latency at all and got nothing back. One `msgQ` per agent and one `ProxyAgent` per server, so one slow relay stalls the proxy for every relay it talks to. That part is from the code, not measured: the bench has one relay. -2048 late replies is a cheap budget for an attacker who controls the destination relay. +Someone who controls the destination relay only needs 2048 late replies to do this. This also corrects Leak 1's "slow relay is not a leak" row. That is right about `sentCommands` and wrong about the session: the late replies that clear `sentCommands` are the ones that pile up @@ -142,7 +142,7 @@ also work but still allocates and copies every batch. --- -## Bug 3: proxy concurrency limit is inert +## Bug 3: proxy concurrency limit does nothing ### Issue @@ -200,34 +200,35 @@ work before its delete: | spins 100us | 17.8% | 9.8% | | one failing `connect()` | **0%** | **0.1%** | -A spinning child does not lose the race, it starves the parent. The window closes when the child -gives up the capability: syscall, safe FFI call, or STM retry. +A child that just spins does not lose the race, it keeps the CPU from the parent. The parent only +wins when the child hands the CPU back, which happens on a syscall, a safe FFI call, or an STM +retry. Against that rule, of the three call sites: - `forkCmd` (`Server.hs:1593`) for `PFWD`/`PRXY`/`RSLV`: all do network IO, all yield. `RSLV` was checked separately since it is client driven at command rate, but `resolveName` has no cache (`Server/Names.hs:62`). -- `deliverServiceMessages` (`Server.hs:1977`): `clientServiceSubscribed` is a one-way latch - (`Server.hs:2031`), so at most once per connection. -- `sendPendingEvtsThread.queueEvts` (`Server.hs:463`): the only one that can skip yielding. The - child is `writeTBQueue sndQ` plus three `IORef` bumps, so if space appeared it commits straight - through. +- `deliverServiceMessages` (`Server.hs:1977`): `clientServiceSubscribed` is set to `True` once + (`Server.hs:2031`) and never reset, so this runs at most once per connection. +- `sendPendingEvtsThread.queueEvts` (`Server.hs:463`): the only one that can finish without + yielding. The child does `writeTBQueue sndQ` and three `IORef` updates, so if space appeared in + the queue it finishes straight away. ### Impact -Small and bounded, and not driven live. +Small, and not reproduced against a running server. -The one non-yielding path forks at most twice per client per `pendingENDInterval` (15s, -`Server/Main.hs:581`), and only for a client whose `sndQ` was full at the check and drained by the -time the child ran. `clientDisconnected` (`Server.hs:1237`) drops the whole map, so nothing -survives the session. +The one path that can skip yielding forks at most twice per client every 15s +(`pendingENDInterval`, `Server/Main.hs:581`), and only when that client's `sndQ` was full at the +check and had emptied by the time the child ran. `clientDisconnected` (`Server.hs:1237`) clears +the whole map, so nothing outlives the session. -A client can influence both preconditions by stalling and resuming socket reads, so this is not -unreachable, but winning a sub-millisecond window at two attempts per 15s was not demonstrated. +A client can affect both of those by pausing and resuming its socket reads, so this is not out of +reach, but hitting a sub-millisecond window at two tries per 15s was not shown. -Practical cost is the misleading `endThreads` counter, which mixes stale entries with genuinely -running forked commands. +The real cost is that the `endThreads` counter is misleading: it mixes stale entries with commands +that are actually still running. ### Fix @@ -252,16 +253,18 @@ atomically $ modifyTVar' endThreads $ IM.adjust (const (Just w)) tId All recovered. Also clean: 400 connect/disconnect rounds, and steady forwarding at 50ms each way. -Sample late. At +5s the middle two still read ~120 KiB per connection, which looks like a 24 MiB -leak but is teardown in progress. Falling means reclaimed, flat above baseline means leaked. +Measure well after closing. At +5s the middle two still read ~120 KiB per connection, which looks +like a 24 MiB leak but is just connections still closing. A number that keeps falling is being +freed; a number that stops above where it started is leaked. -Peaks still matter: 200 abandoned half open connections hold ~40 MiB for ~25s, unauthenticated. A -client that finishes the handshake then sends one byte holds ~265 KiB for as long as it stays -connected, since `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs:104`). +The peaks are still worth knowing. 200 abandoned half open connections hold ~40 MiB for ~25s, with +no authentication needed. A client that finishes the handshake then sends one byte holds ~265 KiB +for as long as it stays connected, because there is no read timeout: `transportTimeout` is +hardcoded `Nothing` (`Transport/Server.hs:104`). ## Clean: connectivity and sockets under latency -`BENCHLAG_MS` swept on `proxyfwd`, one way. Sockets counted from `/proc//fd`. +Latency set with `BENCHLAG_MS` on `proxyfwd`, one way. Sockets counted from `/proc//fd`. | lag each way | delivered | sockets | relay connects | reconnects | timeouts | | --- | --- | --- | --- | --- | --- | @@ -271,31 +274,31 @@ connected, since `transportTimeout` is hardcoded `Nothing` (`Transport/Server.hs | 16s | 4/4 | 8 | 1 | 0 | 0 | | 40s | 0/2 | 8 | 1 | 0 | 1 | -Nothing accumulates. Same socket count whether forwards succeed or time out, session opened once -and reused, no reconnects at any latency. +Nothing builds up. The socket count is the same whether forwards succeed or time out, the session +is opened once and reused, and there are no reconnects at any latency. -That robustness is what makes Leak 1 unbounded: the session holding the stuck entries never drops. +This is why Leak 1 has no upper bound: the session holding the stuck entries never closes. -Forwards work to 16s each way and fail at 40s, governed by the 30s RFWD timeout. The exact cutoff -is not pinned down, since the test transport delays per read/write cycle rather than per message. +Forwards work to 16s each way and fail at 40s, because of the 30s RFWD timeout. The exact cutoff is +not measured, since the test transport adds its delay per read/write rather than per message. ## Checked, not a problem: socketsLeaked accounting `closeConn` (`Transport/Server.hs:179`) removes from `active`, calls `gracefulClose conn 5000`, -then increments `closed`, and `socketsLeaked = accepted - closed - active`. That ordering leaves a -window where a closing connection is in neither bucket. +then increments `closed`, and `socketsLeaked = accepted - closed - active`. In that order there is +a moment where a closing connection is counted in neither number. -The window never opened in practice. Over 600 sequential cycles and 200 simultaneous teardowns, -read from the control port, `leaked` was 0 at every sample. The 5000 is a timeout, not a delay. +It never happened in practice. Over 600 sequential cycles and 200 connections closed at once, read +from the control port, `leaked` was 0 every time. The 5000 is a timeout, not a delay. -Listed because an earlier version of this report called it a bug on code reading alone. +Listed because an earlier version of this report called it a bug based only on reading the code. ## Already fixed: empty session variable `withGetSessVar'` (`Session.hs:65`) wraps the session var in `bracketOnError` with -`dropEmptySessVar`, so an interrupted connect drops the empty var. Fixed in `c9ebf72e`. -`SMPProxyTests` covers the proxy and agent variants and both pass. Not reproducible because it is -fixed, not because it never happened. +`dropEmptySessVar`, so an interrupted connect removes the empty var. Fixed in `c9ebf72e`. +`SMPProxyTests` covers the proxy and agent cases and both pass. It cannot be reproduced because it +is already fixed, not because it never happened. ## Running the suite From ee97ffcab8d649e14245ca9b5a5a6c160c7ad4a4 Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 30 Jul 2026 07:51:24 +0000 Subject: [PATCH 19/43] docs: drop non-findings sections from leak report --- docs/leak-findings.md | 25 ------------------------- 1 file changed, 25 deletions(-) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index b7f7a3813..1c651c5a6 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -281,28 +281,3 @@ This is why Leak 1 has no upper bound: the session holding the stuck entries nev Forwards work to 16s each way and fail at 40s, because of the 30s RFWD timeout. The exact cutoff is not measured, since the test transport adds its delay per read/write rather than per message. - -## Checked, not a problem: socketsLeaked accounting - -`closeConn` (`Transport/Server.hs:179`) removes from `active`, calls `gracefulClose conn 5000`, -then increments `closed`, and `socketsLeaked = accepted - closed - active`. In that order there is -a moment where a closing connection is counted in neither number. - -It never happened in practice. Over 600 sequential cycles and 200 connections closed at once, read -from the control port, `leaked` was 0 every time. The 5000 is a timeout, not a delay. - -Listed because an earlier version of this report called it a bug based only on reading the code. - -## Already fixed: empty session variable - -`withGetSessVar'` (`Session.hs:65`) wraps the session var in `bracketOnError` with -`dropEmptySessVar`, so an interrupted connect removes the empty var. Fixed in `c9ebf72e`. -`SMPProxyTests` covers the proxy and agent cases and both pass. It cannot be reproduced because it -is already fixed, not because it never happened. - -## Running the suite - -`should have similar time for auth error, whether queue exists or not` compares wall clock with a -30% tolerance (45% on Postgres) and fails intermittently on a busy machine. Seen twice in four -runs under concurrent bench load, then 4/4 and 5/5 clean when idle, with and without these -changes. Run the suite on an idle machine. From 588966097aa264ba440feb2c97d9ed863f529ac7 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 9 Sep 2026 07:30:04 +0000 Subject: [PATCH 20/43] smp server: log relay host on proxy forward error --- src/Simplex/Messaging/Server.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 6d615958f..5b8e7eb3a 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -98,7 +98,7 @@ import Network.Socket (ServiceName, Socket, socketToHandle) import qualified Network.TLS as TLS import Numeric.Natural (Natural) import Simplex.Messaging.Agent.Lock -import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, smpProxyError, temporaryClientError) +import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, smpProxyError, temporaryClientError, transportHost') import Simplex.Messaging.Client.Agent (AgentLeakStats (..), OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getAgentLeakStats, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding @@ -1579,7 +1579,9 @@ client Right r -> PRES r <$ inc own pSuccesses Left e -> ERR (smpProxyError e) <$ case e of PCEProtocolError {} -> inc own pSuccesses - _ -> inc own pErrorsOther + _ -> do + logWarn $ "Error forwarding to relay: " <> decodeLatin1 (strEncode $ transportHost' smp) <> " own=" <> tshow own <> " " <> tshow e + inc own pErrorsOther Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION) where forkProxiedCmd :: M s BrokerMsg -> M s (Maybe BrokerMsg) From c3c4fa76047b77673ac08a192217322998fe0404 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 9 Sep 2026 07:30:04 +0000 Subject: [PATCH 21/43] tests: reproduce RSLV fan-out, proxy stuck session --- tests/RSLVTests.hs | 20 ++++++++++++++++++++ tests/SMPClient.hs | 8 ++++++++ tests/SMPProxyTests.hs | 15 +++++++++++++++ 3 files changed, 43 insertions(+) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 2416d851e..fa314daa7 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -11,7 +11,10 @@ module RSLVTests (rslvTests) where +import Control.Concurrent (threadDelay) +import Control.Monad (forM_) import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Data.IORef (readIORef) import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB @@ -82,6 +85,23 @@ rslvTests = do it "PFWD-wrapped RSLV success returns RNAME (record JSON frames over the proxy)" testRslvForwardedSuccess describe "RSLV success path (RNAME response)" $ do it "returns RNAME with NameRecord" testRslvSuccess + describe "RSLV resource use" $ + xit "one connection must not fan out to many concurrent resolver requests" testRslvFanOut + +testRslvFanOut :: IO () +testRslvFanOut = + NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs -> + withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort $ const $ + testSMPClient @TLS $ \(h@THandle {params} :: THandleSMP TLS 'TClient) -> do + let k = 64 :: Int + globalCap = 8 :: Int + forM_ [1 .. k] $ \i -> do + let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId (B.pack $ "fan" <> show i), NoEntity, Cmd SResolver (RSLV (domain "alice.simplex"))) + [Right ()] <- tPut h (Right (Nothing, tToSend) :| []) + pure () + threadDelay 800000 + inFlight <- length . filter ((== ["resolve"]) . take 1) <$> readIORef reqs + inFlight `shouldSatisfy` (<= globalCap) testRslvBackendNotFound :: IO () testRslvBackendNotFound = diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index e5adaa749..0e6ed18ca 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -346,6 +346,14 @@ proxyCfgShortTimeout = nt = NetworkTimeout {backgroundTimeout = 4_000000, interactiveTimeout = 4_000000} in cfg' {smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpConnectTimeout = nt}}}} +proxyCfgForwardTimeout :: AServerConfig +proxyCfgForwardTimeout = + updateCfg proxyCfg $ \cfg' -> + let aCfg = smpAgentCfg cfg' + cCfg = smpCfg aCfg + nt = NetworkTimeout {backgroundTimeout = 1, interactiveTimeout = 1} + in cfg' {smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpTimeout = nt}}}} + withSmpServerStoreMsgLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOn (t, msType) = withSmpServerConfigOn t $ updateCfg (cfgMS msType) $ \cfg' -> cfg' {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile} diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index bb3932232..0a17f9e28 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -63,6 +63,8 @@ smpProxyTests = do testProxyRecoversWithoutDisconnect it "reconnects to relay after sender disconnects mid-connection" $ \_ -> testProxyReconnectAfterRelayRestart + xit "must drop a stuck relay session after forward timeouts" $ \_ -> + testProxyForwardTimeoutStuckSession describe "agent client reconnection" $ do it "reconnects after a connect is cancelled mid-flight" $ \_ -> testAgentClientReconnectAfterCancel @@ -494,6 +496,19 @@ testProxyReconnectAfterRelayRestart = race_ (threadDelay 1000000) requestRelaySession requireProxyReconnect +testProxyForwardTimeoutStuckSession :: IO () +testProxyForwardTimeoutStuckSession = + withSmpServerConfigOn (transport @TLS) proxyCfgForwardTimeout testPort $ \_ -> do + g <- C.newRandom + ts <- getCurrentTime + let srv = SMPServer testHost testPort testKeyHash + vr = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion + pc <- either (fail . show) pure =<< getProtocolClient g NRMInteractive (1, srv, Nothing) defaultSMPClientConfig {serverVRange = vr} [] Nothing ts (\_ -> pure ()) + sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive srv (Just "correct") + sId <- atomically $ SMP.EntityId <$> C.randomBytes 24 g + rs <- forM ([1 .. 10] :: [Int]) $ \_ -> runExceptT' (proxySMPMessage pc NRMInteractive sess Nothing sId noMsgFlags "hi") + rs `shouldSatisfy` elem (Left (ProxyProtocolError (SMP.PROXY SMP.NO_SESSION))) + -- Bug B (same root cause as the proxy, in the messaging agent): getSMPServerClient inserts an -- empty SessionVar into smpClients, then connects inside newProtocolClient's tryAllErrors, which -- rethrows async exceptions. If the connecting thread is cancelled mid-connect, putTMVar is From 1a2145a04f5142ded42d67308a77dd24b9b5d02a Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 9 Sep 2026 11:11:02 +0000 Subject: [PATCH 22/43] docs: add RSLV fan-out to leak findings --- docs/leak-findings.md | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 1c651c5a6..17865ae64 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -241,6 +241,33 @@ atomically $ modifyTVar' endThreads $ IM.adjust (const (Just w)) tId --- +## Bug 5: unauthenticated RSLV resolver fan-out + +### Issue + +`RSLV` is unauthenticated (`Server.hs:1279`, `vc SResolver (RSLV _) = VRVerified Nothing`) and forks +one outbound HTTP/TLS request per command, bounded only by `serverResolverConcurrency` (default +1000, `Env/STM.hs:256`) through the per-client `procThreads` counter (`Env/STM.hs:461`) with no +global cap. `managerConnCount = 10` (`HttpResolver.hs:88`) sizes the keep-alive pool, not +concurrency. One 16 KB block carries ~255 RSLVs. Only when `[NAMES]` is enabled. + +Not proxy related, and off by default, but client reachable when the resolver is on. + +### Impact + +One connection drives up to `serverResolverConcurrency` concurrent outbound TLS handshakes and +sockets; more connections multiply it with no global bound. Measured with `testRslvFanOut`: one +connection sends 64 RSLVs against a resolver that holds each request, and 64 outbound requests are +in flight at once (the test asserts <= 8). CPU (handshakes), threads and FDs scale with the flood. + +### Fix + +Add a global resolver-concurrency limit, a shared semaphore in `NamesEnv` acquired around the +outbound call, separate from the per-client counter, and lower the default. A result cache would +also cut repeat lookups (`resolveName` has none, `Server/Names.hs:61`). + +--- + ## Clean: TLS/TCP stack 200 connections opened at once, closed, then measured again: From 73093408219469a41a8c00282ee4beebc46ad6b9 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 9 Sep 2026 12:06:43 +0000 Subject: [PATCH 23/43] docs: add postgres backend findings --- docs/leak-findings.md | 108 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 108 insertions(+) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 17865ae64..fa83b0db6 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -268,6 +268,114 @@ also cut repeat lookups (`resolveName` has none, `Server/Names.hs:61`). --- +The findings below are from code review of the PostgreSQL backend (`store_messages: database`), +not bench-measured. + +## Bug 6: every SEND is three DB transactions behind a pool of 10 + +### Issue + +With `store_messages: database` the queue store runs `useCache = False` +(`MsgStore/Postgres.hs:100`), so each command hits the DB. A SEND does three separate transactions: +load the queue, `delete_expired_msgs`, then `write_message`. `expireMessagesOnSend` defaults to +`True` (`Main.hs:563`, `Server.hs:2121`), so the middle one runs on every SEND to a non-empty +queue. All transactions draw from one pool of `poolSize` connections (default 10, +`Main/Init.hs:44`). A second pool (`dbPriorityPool`, another `poolSize`) is opened but never used by +the SMP server. + +### Impact + +Max SEND rate is about `poolSize / (3 x per-transaction latency)` regardless of client count; past +that all clients block on the pool. Twice `poolSize` backends are opened, half of them idle. + +### Fix + +Fewer transactions per SEND; make `expireMessagesOnSend` cheaper or default off; drop or use the +priority pool. + +--- + +## Bug 7: unauthenticated batched crypto and per-transmission DB lookup + +### Issue + +`dummyVerifyCmd` (`Server.hs:1457`) runs a real Ed25519/Ed448 verify or an X25519 DH per +transmission whose queue is unknown. SEND is not a batch party (`batchParty` is Recipient/Notifier +only, `Server.hs:1273`), so verification takes the per-transmission path +`mapM (\t -> verifyTransmission ...)` (`Server.hs:1279`): one crypto op and, with +`useCache = False`, one DB `getQueueRec` SELECT per transmission. A 16 KB block holds up to 254 +transmissions (`Protocol.hs:2317`). + +### Impact + +One write by any handshake-completing peer costs ~130-250 asymmetric verifications and ~130-250 DB +SELECTs. The attacker chooses the auth type and that the queue is absent. + +### Fix + +Batch the sender/link lookups as Recipient/Notifier already are; cap unknown-queue verifications +per block. + +--- + +## Bug 8: unauthenticated clientService grows the services table + +### Issue + +The SMP handshake accepts a self-signed service chain (`CCSelf`, `Transport.hs:786`) and verifies +an attacker-supplied cert per connection; `getCreateService` inserts a `services` row on any new +fingerprint (`QueueStore/Postgres.hs:469`). A fresh self-signed cert per handshake is a new +fingerprint. + +### Impact + +One unbounded, persistent `services` row per connection, pre-auth, plus one X509 verification per +connection. + +### Fix + +Require the service to be pre-registered, or authenticate/rate-limit service creation. + +--- + +## Bug 9: Prometheus scrape scans all queues and folds all subscriptions + +### Issue + +Every `prometheus_interval` (default 60s), `getEntityCounts` runs six `COUNT(1)` scans over +`msg_queues`/`services` (`QueueStore/Postgres.hs:154`, called at `Server.hs:812`), and +`getDeliveredMetrics` folds over all clients times all their subscriptions in memory +(`Server.hs:836`). + +### Impact + +Cost scales with the largest dimensions (queues, live subscriptions) and recurs every minute while +Prometheus is enabled. + +### Fix + +Maintain the counts incrementally; avoid the per-scrape full fold. + +--- + +## Bug 10: subscription changes serialize through one thread and one map + +### Issue + +All subscription churn goes through one `subQ` drained by one `serverThread` (`Server.hs:273`) that +mutates the single `queueSubscribers` map held in one TVar. A batched SUB of N queues is N separate +writes to `subQ` (`Server.hs:1848`). + +### Impact + +Subscription throughput is bounded by one thread and one contended TVar under churn. + +### Fix + +Shard the subscriber map, or batch `subQ` events per client. + +--- + ## Clean: TLS/TCP stack 200 connections opened at once, closed, then measured again: From 5297427733e1e1bb03c66473bc7ecbabaf124991 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 9 Sep 2026 13:57:12 +0000 Subject: [PATCH 24/43] docs: mark proxy msgQ leak fixed upstream --- docs/leak-findings.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index fa83b0db6..3f75b4ddd 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -4,6 +4,7 @@ Found with `bench/MemBench.hs`, extended with a proxy plus relay topology and a adds latency and drops replies. Measured on both the journal store and PostgreSQL, same results. Three leaks on the proxy path, all client reachable. Two related bugs. TLS/TCP stack is clean. +Leak 3 has since been fixed in master by #1839 (`7d0820dd`); Leak 1 and Leak 2 remain. All three leaks are reached the same way: `PRXY` is unauthenticated unless `newQueueBasicAuth` is set (`Server.hs:1534`) and names an arbitrary destination, so a client can point the proxy at a @@ -96,6 +97,12 @@ Check the map on a timer and remove entries past their expiry. The timestamp is ## Leak 3: the proxy's relay message queue has no reader +> [!TIP] +> Fixed in master by #1839 (`7d0820dd`), which took the approach proposed below. `msgQ` is now +> `Maybe (TBQueue ...)` (`Client/Agent.hs:143`), the proxy agent is built with `msgQSize = Nothing` +> (`Server/Main.hs:607`), and `sendMsg` logs late replies instead of enqueuing them when there is no +> queue (`Client.hs:722`). The analysis below is kept for context. + ### Issue `newSMPClientAgent` creates one `msgQ` (`Client/Agent.hs:194`) and `connectClient` gives that same From 15606bfff7873491d58204d78631468e3fce9394 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 9 Sep 2026 14:34:48 +0000 Subject: [PATCH 25/43] docs: restructure leak findings with tables --- docs/leak-findings.md | 513 +++++++++++++++++++++++------------------- 1 file changed, 284 insertions(+), 229 deletions(-) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 3f75b4ddd..08ca4f855 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -1,97 +1,128 @@ # SMP server leak findings -Found with `bench/MemBench.hs`, extended with a proxy plus relay topology and a transport that -adds latency and drops replies. Measured on both the journal store and PostgreSQL, same results. +Found with `bench/MemBench.hs` using a proxy-plus-relay topology and a transport that adds latency +and drops replies. Journal store and PostgreSQL gave the same numbers except where a row says +otherwise. -Three leaks on the proxy path, all client reachable. Two related bugs. TLS/TCP stack is clean. -Leak 3 has since been fixed in master by #1839 (`7d0820dd`); Leak 1 and Leak 2 remain. +Eleven findings: three proxy-path memory leaks (Leak 1-3), two `forkClient` bugs (Bug 3-4), an +unauthenticated resolver fan-out (Bug 5), and five PostgreSQL-backend costs (Bug 6-10). The TLS/TCP +stack is clean (last two sections). -All three leaks are reached the same way: `PRXY` is unauthenticated unless `newQueueBasicAuth` is -set (`Server.hs:1534`) and names an arbitrary destination, so a client can point the proxy at a -relay it controls. +## Overview + +| # | Issue | Reachable | Backend | Evidence | Status | +| --- | --- | --- | --- | --- | --- | +| Leak 1 | Forwarded commands not removed on timeout | Client, pre-auth (PRXY) | all | measured | present | +| Leak 2 | Failed relay connects not cleared | Client, pre-auth (PRXY) | all | measured | present | +| Leak 3 | Proxy relay queue has no reader | Client, pre-auth (PRXY) | all | measured | fixed, #1839 | +| Bug 3 | Proxy concurrency limit does nothing | Client, pre-auth (PRXY) | all | measured | present | +| Bug 4 | Stale `endThreads` entry on fast finish | Client, limited window | all | isolation only | present | +| Bug 5 | RSLV resolver fan-out | Client, if `[NAMES]` on | all | measured | present | +| Bug 6 | SEND is three DB transactions | authenticated SEND | postgres | code review | present | +| Bug 7 | Per-transmission verify and DB lookup | Client, pre-auth | postgres | code review | present | +| Bug 8 | Service handshake grows `services` table | Client, pre-auth | postgres | code review | present | +| Bug 9 | Prometheus scrape scans everything | internal, periodic | postgres | code review | present | +| Bug 10 | Subscription churn serialized | authenticated SUB | all | code review | present | + +Leak 1, Leak 2, Leak 3, and Bug 3 share one entry point. `PRXY` is unauthenticated unless +`newQueueBasicAuth` is set (`Server.hs:1534`) and it names an arbitrary destination, so a client can +point the proxy at a relay it controls. --- ## Leak 1: forwarded commands are never removed on timeout -### Issue +| | | +| --- | --- | +| Reachable | any client, pre-auth via PRXY | +| Trigger | relay replies to some forwards, drops others | +| Cost | ~20 KiB per stuck forward, unbounded | +| Measured | yes, 64 to 1280 entries over 20 min on one session | +| Status | present | + +### How it works -Entries go into `sentCommands` in `mkTransmission_` (`Client.hs:1418`). The only removal is in -`processMsg` (`Client.hs:706`), which runs when a reply arrives. `getResponse` (`Client.hs:1383`) -handles the timeout but never gets the map, so it cannot delete. +When the agent forwards a command it stores the in-flight command in `sentCommands`, keyed by +correlation id, so the reply can be matched later. The entry is added in `mkTransmission_` +(`Client.hs:1414`) and removed in `processMsg` (`Client.hs:706`) when the reply arrives. Each `RFWD` +entry holds the whole forwarded command, 16226 bytes (`Protocol.hs:319`). -Each entry holds the forwarded command: 16226 bytes for `RFWD`. +### The bug -The session survives too. `monitor` (`Client.hs:668`) drops the client only when -`timeoutErrorCount >= smpPingCount` and nothing has arrived for 900s, and `receive` -(`Client.hs:663`) resets both on every inbound transmission. +The timeout path, `getResponse` (`Client.hs:1378`), does not hold the map, so a forward that times +out is never removed. The session does not die either: `monitor` (`Client.hs:668`) closes the client +only after `timeoutErrorCount >= smpPingCount` with nothing received for 900s, and `receive` +(`Client.hs:663`) resets both counters on any inbound transmission. ### Impact -About 20 KiB per unanswered forward. How long it is held depends on how the relay misbehaves. +About 20 KiB per unanswered forward. How long it is held depends on the relay. -| relay behaviour | result | +| Relay behaviour | Result | | --- | --- | | slow but still replies | not a leak here, the late reply deletes the entry (but see Leak 3) | | goes fully silent | bounded, `monitor` closes the client at ~20 min | -| replies to some, drops others | **unbounded** | +| replies to some, drops others | unbounded | -The third case is the problem. Any arriving reply resets `lastReceived` and `timeoutErrorCount`, -so the drop condition is never met. Measured with 1 in 3 relay writes dropped and forwarding -running: `proxy_sentCommands` climbed 64 to 1280 over 20 minutes, linear at 64/min, zero -disconnects. That is ~1.3 MiB/min, ~77 MiB/hour, on one session. +The third case is the leak. Any arriving reply resets `lastReceived` and `timeoutErrorCount`, so the +drop condition is never met. Measured with 1 in 3 relay writes dropped: `proxy_sentCommands` climbed +64 to 1280 over 20 minutes, linear at 64/min, zero disconnects. That is ~1.3 MiB/min on one session. +Traffic has to be ongoing; stop the flood and it is reclaimed after 20 minutes. -Traffic has to be ongoing. Flood and stop and it is reclaimed after 20 minutes. +The ntf server runs the same client code and is exposed the same way through unanswered `NSUB`. +Measured with `subtmo 200`: 200 timed-out subscriptions, `sentCommands` 0 to 200, ~1.76 KiB each. At +the ntf batch size of 1360 that is ~2.3 MiB per unanswered batch. -The ntf server uses the same client code and has the same exposure through unanswered `NSUB`. -Measured with `subtmo 200`: 200 queues, 200 timed out, `sentCommands` 0 to 200, ~1.76 KiB each. -At the ntf batch size of 1360 that is ~2.3 MiB per unanswered batch. - -Pings do not help. Subscribe paths call `enablePings` and the proxy send path does not, but in -the unbounded case replies are arriving anyway, which resets the counters either way. +Pings do not help. Subscribe paths call `enablePings` (`Client.hs:953`) and the proxy send path does +not, but in the unbounded case replies are arriving anyway and reset the counters. ### Fix -Do not just delete on timeout. The agent still needs late replies. `processMsg` forwards them as -`STResponse` (`Client.hs:713`), and `Agent.hs:3093` acts on them. A late `OK`/`SOK` to a `SUB` -calls `processSubOk`, which is what brings a connection back UP, and a late `MSG` is processed as -a real message. Deleting on timeout turns both into `STUnexpectedError` (`Client.hs:702`), so the -agent would report an error instead of recovering, and drop the message. - -Delete by age instead: record the time on `Request` when it is added, and remove entries with -`pending == False` that are older than the point where a late reply is no longer useful. Choosing -that age needs the agent's recovery behaviour measured, which is not done here. +Deleting on timeout is wrong: the agent still needs late replies. `processMsg` forwards them as +`STResponse` (`Client.hs:713`) and the agent acts on them, so a late `OK`/`SOK` to a `SUB` brings a +connection back up and a late `MSG` is processed. Deleting would turn both into `STUnexpectedError`. -Two entry points can be fixed by deleting, because no reply is ever coming. `mkTransmission_` -inserts before sending (`Client.hs:1361`) and `sendRecv` returns early at `Client.hs:1366` -(transport error) and `Client.hs:1368` (oversized block) without sending or deleting. +Delete by age instead. Record the insert time on `Request` and remove `pending == False` entries once +a late reply is no longer useful. The cutoff needs the agent's recovery behaviour measured, which is +not done here. Two paths can be deleted immediately because no reply is coming: `sendRecv` returns +early on transport error (`Client.hs:1364`) and on an oversized block (`Client.hs:1366`) without +sending. --- ## Leak 2: failed relay connects are never cleared -### Issue +| | | +| --- | --- | +| Reachable | any client, pre-auth via PRXY | +| Trigger | forward to distinct dead addresses | +| Cost | ~19 KiB per address, held for the process lifetime | +| Measured | yes, 300 entries from 300 dead addresses | +| Status | present | + +### How it works -A failed connect is cached in `smpClients` as `Left (error, expiry)` (`Client/Agent.hs:275`) and -removed only on a later lookup of the same server (`:250`, `:411`). Nothing removes it on a timer. -The other removals are `clientDisconnected` (`:311`, connected clients only) and shutdown -(`:427`). +Relay clients are cached in `smpClients`. A successful connect caches the client; a failed connect +caches the error as `Left (error, expiry)` (`Client/Agent.hs:277`) so repeat lookups fail fast until +the expiry passes. -Conditional on `persistErrorInterval > 0`. At 0 the entry goes immediately, but production sets -30 (`Server/Main.hs:607`). +### The bug + +Nothing removes a failed entry on a timer. It is dropped only when the same server is looked up again +and found expired (`:253`, `:414`). The other removals are `clientDisconnected` (`:314`, connected +clients only) and shutdown (`:430`). Conditional on `persistErrorInterval > 0`; at 0 the entry is +removed at once, but production sets 30 (`Server/Main.hs:608`). ### Impact Host, port and key hash come from the client, so distinct addresses are unlimited. Measured: -`proxy_smpClients = 300` after 300 dead addresses, ~19 KiB each, never freed while the process -runs. 1000 entries created in about 1s. - -That is ~19 MiB/s when the address refuses the connection immediately. An address that accepts -nothing and never answers waits out the 45s connect timeout, which slows it right down. +`proxy_smpClients = 300` after 300 dead addresses, ~19 KiB each, never freed while the process runs. +1000 entries created in about 1s, so ~19 MiB/s when the address refuses immediately. An address that +accepts nothing and never answers waits out the 45s connect timeout, which slows it down. ### Fix -Check the map on a timer and remove entries past their expiry. The timestamp is already stored. +Scan the map on a timer and remove entries past their expiry. The timestamp is already stored. --- @@ -100,81 +131,73 @@ Check the map on a timer and remove entries past their expiry. The timestamp is > [!TIP] > Fixed in master by #1839 (`7d0820dd`), which took the approach proposed below. `msgQ` is now > `Maybe (TBQueue ...)` (`Client/Agent.hs:143`), the proxy agent is built with `msgQSize = Nothing` -> (`Server/Main.hs:607`), and `sendMsg` logs late replies instead of enqueuing them when there is no -> queue (`Client.hs:722`). The analysis below is kept for context. +> (`Server/Main.hs:607`), and `sendMsg` logs late replies instead of enqueuing them (`Client.hs:722`). +> The analysis below is kept for context. + +| | | +| --- | --- | +| Reachable | any client, pre-auth via PRXY | +| Trigger | relay replies land after the 30s RFWD timeout | +| Cost | permanent proxy stall once the queue fills | +| Measured | yes, `msgqfill` phase | +| Status | fixed, #1839 | -### Issue +### How it works -`newSMPClientAgent` creates one `msgQ` (`Client/Agent.hs:194`) and `connectClient` gives that same -queue to every relay client (`:296`). The ntf server reads its copy -(`Notifications/Server.hs:537`). The SMP server never reads its own: `receiveFromProxyAgent` -reads `agentQ` only (`Server.hs:475`). There are three `readTBQueue` sites on a `msgQ` in `src/` -and none is the proxy's. +`newSMPClientAgent` created one `msgQ` and gave that same queue to every relay client. The ntf server +reads its copy (`Notifications/Server.hs`), but the SMP server never read its own: `receiveFromProxyAgent` +reads `agentQ` only. -It fills from late replies. `processMsg` routes a response to `msgQ` when the request is still in -`sentCommands` but `pending` is already `False` (`Client.hs:713`), so every reply arriving after -the proxy's 30s RFWD timeout leaves an entry that nothing takes out. +### The bug -When it is full, `processMsgs` blocks in `writeTBQueue` (`Client.hs:694`). That is the `process` -thread, the only reader of `rcvQ`, so the proxy stops handling responses entirely. +The queue filled from late replies. `processMsg` routes a response to `msgQ` when the request is +still in `sentCommands` but `pending` is already `False` (`Client.hs:713`), so every reply arriving +after the proxy's 30s RFWD timeout left an entry that nothing removed. When full, `processMsgs` +blocked in `writeTBQueue` on the `process` thread, the only reader of `rcvQ`, so the proxy stopped +handling responses entirely. ### Impact -Measured with the `msgqfill` phase: 4 forwards at 40s each way so replies land after the timeout, -then lag cleared and 3 more attempted. Only `msgQSize` differs. +Measured with the `msgqfill` phase: 4 forwards at 40s each way so replies land after the timeout, then +lag cleared and 3 more attempted. Only `msgQSize` differs. | `msgQSize` | `proxy_msgQ` at end | `sentCommands` at end | recovery forwards | | --- | --- | --- | --- | -| 2 | 2 (at cap) | 4 and climbing | **0 of 3** | +| 2 | 2 (at cap) | 4 and climbing | 0 of 3 | | 2048 (production) | 4 | 0 | 3 of 3 | -Two things. The queue is never emptied: at production size it still holds the 4 late replies at -the end of the run. And when it fills the stall is permanent, not slow: the recovery forwards ran -with no latency at all and got nothing back. - -One `msgQ` per agent and one `ProxyAgent` per server, so one slow relay stalls the proxy for every -relay it talks to. That part is from the code, not measured: the bench has one relay. - -Someone who controls the destination relay only needs 2048 late replies to do this. - -This also corrects Leak 1's "slow relay is not a leak" row. That is right about `sentCommands` and -wrong about the session: the late replies that clear `sentCommands` are the ones that pile up -here. - -### Fix - -Make `msgQ` optional in `SMPClientAgent` and pass `Nothing` for the proxy. `getProtocolClient` -already takes a `Maybe` and `sendMsg` logs instead when it is `Nothing`. A discarding reader would -also work but still allocates and copies every batch. +The queue was never emptied, and once full the stall was permanent: the recovery forwards ran with no +latency and got nothing back. One `msgQ` per agent and one `ProxyAgent` per server, so one slow relay +stalled the proxy for every relay it talked to. Someone controlling the destination relay needed only +2048 late replies. This also corrects Leak 1's "slow relay is not a leak" row: those late replies are +what piled up here. --- ## Bug 3: proxy concurrency limit does nothing -### Issue - -`Server.hs:1590`: - -```haskell -bracket_ wait signal . forkClient clnt label $ action -``` - -`.` binds tighter than `$`, so `signal` runs when the thread starts, not when it finishes. Only -forking is limited. +| | | +| --- | --- | +| Reachable | any client, pre-auth via PRXY | +| Trigger | concurrent PFWDs on one connection | +| Cost | none directly, uncaps Leak 1's growth rate | +| Measured | yes, `conclimit` phase | +| Status | present | -Measured with `conclimit 8` and `serverClientConcurrency = 1`, eight concurrent PFWDs on one -connection, relay silent: +### How it works -``` -conclimit: n=8 cap=1 completions first=20.0s last=20.0s spread=0.0s -``` +`forkCmd` (`Server.hs:1591`) is meant to cap in-flight forked commands at `serverClientConcurrency`. +`wait` blocks until a slot is free and `signal` releases it. -All eight ran at once. Enforced, each would hold the slot for the 30s RFWD timeout, needing ~240s. +### The bug -### Impact - -No memory cost of its own. Removes the cap on how fast Leak 1 grows, and `procThreads` reads near -zero at any load. +The code is `bracket_ wait signal . forkClient clnt label $ action` (`Server.hs:1592`). `.` binds +tighter than `$`, so it parses as `bracket_ wait signal (forkClient ... action)`. `forkClient` +returns as soon as the thread is spawned, so `signal` runs at spawn time, not at completion. Only +forking is serialized. Measured with `conclimit 8` and `serverClientConcurrency = 1`, all eight PFWDs +ran at once (`first=20.0s last=20.0s spread=0.0s`); enforced, each would hold the slot for the 30s +RFWD timeout. `procThreads` also reads near zero at any load. The counter is per-connection, so even +when fixed the cap is per-client, not global. ### Fix @@ -182,60 +205,49 @@ zero at any load. wait >> forkClient clnt label (action `finally` signal) ``` -This turns the limit on for the first time. Default is 32 and `wait` blocks the client's whole -command loop when hit, so check that value first. +This enables the limit for the first time. Default is 32 and `wait` blocks the client's whole command +loop when hit, so check that value first. --- ## Bug 4: stale endThreads entry when a command finishes fast -### Issue +| | | +| --- | --- | +| Reachable | client, narrow timing window | +| Trigger | forked child finishes before it is registered | +| Cost | ~320 bytes per stale entry, misleading counter | +| Measured | isolation only, not against a running server | +| Status | present | + +### How it works + +`forkClient` (`Server.hs:1482`) registers the child in `endThreads` for shutdown tracking. It forks +first (`:1485`), the child deletes its own key on exit (`:1487`), and the parent inserts the weak +thread id afterward (`:1488`). -`forkClient` (`Server.hs:1480`) registers the thread after `forkIO`. If the action finishes first, -its delete misses and the insert is never undone. +### The bug -Reproduced in isolation, 100k forks: 20% stale at `-N1`, 13% at `-N4`, ~320 bytes each. -`deRefWeak` returns `Nothing` for all of them, so no thread is retained. +If the child finishes before the parent's insert, the delete finds no key and the later insert is +never undone, leaving a permanent entry. Reproduced over 100k forks: 20% stale at `-N1`, 13% at `-N4`, +~320 bytes each. `deRefWeak` returns `Nothing` for all, so no thread is retained. -What decides it is not how long the child takes. Measured over 20k forks, varying only the child's -work before its delete: +What decides the race is whether the child yields the CPU back, not how long it runs: -| child does | -N1 | -N4 | +| Child does | -N1 | -N4 | | --- | --- | --- | | nothing | 17.5% | 10.7% | | spins 1us | 19.2% | 9.7% | | spins 100us | 17.8% | 9.8% | -| one failing `connect()` | **0%** | **0.1%** | - -A child that just spins does not lose the race, it keeps the CPU from the parent. The parent only -wins when the child hands the CPU back, which happens on a syscall, a safe FFI call, or an STM -retry. - -Against that rule, of the three call sites: - -- `forkCmd` (`Server.hs:1593`) for `PFWD`/`PRXY`/`RSLV`: all do network IO, all yield. `RSLV` was - checked separately since it is client driven at command rate, but `resolveName` has no cache - (`Server/Names.hs:62`). -- `deliverServiceMessages` (`Server.hs:1977`): `clientServiceSubscribed` is set to `True` once - (`Server.hs:2031`) and never reset, so this runs at most once per connection. -- `sendPendingEvtsThread.queueEvts` (`Server.hs:463`): the only one that can finish without - yielding. The child does `writeTBQueue sndQ` and three `IORef` updates, so if space appeared in - the queue it finishes straight away. - -### Impact - -Small, and not reproduced against a running server. +| one failing `connect()` | 0% | 0.1% | -The one path that can skip yielding forks at most twice per client every 15s -(`pendingENDInterval`, `Server/Main.hs:581`), and only when that client's `sndQ` was full at the -check and had emptied by the time the child ran. `clientDisconnected` (`Server.hs:1237`) clears -the whole map, so nothing outlives the session. - -A client can affect both of those by pausing and resuming its socket reads, so this is not out of -reach, but hitting a sub-millisecond window at two tries per 15s was not shown. - -The real cost is that the `endThreads` counter is misleading: it mixes stale entries with commands -that are actually still running. +A child that spins keeps the CPU; the parent wins only when the child hits a syscall, safe FFI call, +or STM retry. Of the three call sites, `forkCmd` (`PFWD`/`PRXY`/`RSLV`) and `deliverServiceMessages` +all do IO and yield, and the service path runs at most once per connection. Only +`sendPendingEvtsThread.queueEvts` can finish without yielding, and it forks at most twice per client +per 15s (`pendingENDInterval`) and only when the client's `sndQ` was full then emptied. +`clientDisconnected` clears the map, so nothing outlives the session. The real cost is that the +`endThreads` counter mixes stale entries with commands still running. ### Fix @@ -250,50 +262,64 @@ atomically $ modifyTVar' endThreads $ IM.adjust (const (Just w)) tId ## Bug 5: unauthenticated RSLV resolver fan-out -### Issue +| | | +| --- | --- | +| Reachable | any client, pre-auth, when `[NAMES]` is enabled | +| Trigger | a block full of RSLV commands | +| Cost | up to 1000 concurrent outbound TLS handshakes per connection | +| Measured | yes, `testRslvFanOut` (64 in flight, asserts <= 8) | +| Status | present | -`RSLV` is unauthenticated (`Server.hs:1279`, `vc SResolver (RSLV _) = VRVerified Nothing`) and forks -one outbound HTTP/TLS request per command, bounded only by `serverResolverConcurrency` (default -1000, `Env/STM.hs:256`) through the per-client `procThreads` counter (`Env/STM.hs:461`) with no -global cap. `managerConnCount = 10` (`HttpResolver.hs:88`) sizes the keep-alive pool, not -concurrency. One 16 KB block carries ~255 RSLVs. Only when `[NAMES]` is enabled. +### How it works -Not proxy related, and off by default, but client reachable when the resolver is on. +`RSLV` resolves a name over an outbound HTTP/TLS request. It is verified as unauthenticated +(`Server.hs:1393`, `vc SResolver (RSLV _) = VRVerified Nothing`) and each command forks one request +(`Server.hs:1638`). One 16 KB block carries ~255 RSLVs. Off by default, on only with `[NAMES]`. -### Impact +### The bug -One connection drives up to `serverResolverConcurrency` concurrent outbound TLS handshakes and -sockets; more connections multiply it with no global bound. Measured with `testRslvFanOut`: one -connection sends 64 RSLVs against a resolver that holds each request, and 64 outbound requests are -in flight at once (the test asserts <= 8). CPU (handshakes), threads and FDs scale with the flood. +The only bound is `serverResolverConcurrency` (default 1000, `Env/STM.hs:255`), applied through the +per-client `procThreads` counter via the same broken `forkCmd` path as Bug 3, so it is neither global +nor effective. `managerConnCount = 10` (`HttpResolver.hs:88`) sizes the keep-alive pool, not +concurrency, so excess requests open extra connections rather than blocking. `resolveName` has no +cache (`Server/Names.hs:61`). One connection drives up to `serverResolverConcurrency` concurrent +outbound handshakes, sockets and FDs; more connections multiply it with no global bound. ### Fix Add a global resolver-concurrency limit, a shared semaphore in `NamesEnv` acquired around the -outbound call, separate from the per-client counter, and lower the default. A result cache would -also cut repeat lookups (`resolveName` has none, `Server/Names.hs:61`). +outbound call, separate from the per-client counter, and lower the default. A result cache would also +cut repeat lookups. --- -The findings below are from code review of the PostgreSQL backend (`store_messages: database`), -not bench-measured. +The findings below are from code review of the PostgreSQL backend (`store_messages: database`), not +bench-measured. ## Bug 6: every SEND is three DB transactions behind a pool of 10 -### Issue +| | | +| --- | --- | +| Reachable | authenticated SEND | +| Trigger | normal message sending | +| Cost | SEND rate capped at ~`poolSize / 3` per transaction latency | +| Evidence | code review | +| Status | present | -With `store_messages: database` the queue store runs `useCache = False` -(`MsgStore/Postgres.hs:100`), so each command hits the DB. A SEND does three separate transactions: -load the queue, `delete_expired_msgs`, then `write_message`. `expireMessagesOnSend` defaults to -`True` (`Main.hs:563`, `Server.hs:2121`), so the middle one runs on every SEND to a non-empty -queue. All transactions draw from one pool of `poolSize` connections (default 10, -`Main/Init.hs:44`). A second pool (`dbPriorityPool`, another `poolSize`) is opened but never used by -the SMP server. +### How it works -### Impact +With `store_messages: database` the queue store runs `useCache = False` (`MsgStore/Postgres.hs:100`), +so each command hits the DB. + +### The bug -Max SEND rate is about `poolSize / (3 x per-transaction latency)` regardless of client count; past -that all clients block on the pool. Twice `poolSize` backends are opened, half of them idle. +A SEND does three separate transactions: load the queue (`QueueStore/Postgres.hs:230`), +`delete_expired_msgs` (`MsgStore/Postgres.hs:289`), then `write_message` (`MsgStore/Postgres.hs:193`). +`expireMessagesOnSend` defaults to `True` (`Main.hs:563`, `Server.hs:2118`), so the middle one runs on +every SEND to a non-empty queue. All draw from one pool of `poolSize` (default 10, `Main/Init.hs:44`). +A second pool, `dbPriorityPool`, is opened (`Agent/Store/Postgres.hs:59`) but the SMP server never +uses it. Max SEND rate is about `poolSize / (3 x per-transaction latency)` regardless of client count; +past that all clients block on the pool, and half the opened backends sit idle. ### Fix @@ -304,78 +330,109 @@ priority pool. ## Bug 7: unauthenticated batched crypto and per-transmission DB lookup -### Issue +| | | +| --- | --- | +| Reachable | any handshake-completing peer, pre-auth | +| Trigger | one 16 KB block of SENDs to unknown queues | +| Cost | ~130-250 asymmetric verifications and DB SELECTs per block | +| Evidence | code review | +| Status | present | -`dummyVerifyCmd` (`Server.hs:1457`) runs a real Ed25519/Ed448 verify or an X25519 DH per -transmission whose queue is unknown. SEND is not a batch party (`batchParty` is Recipient/Notifier -only, `Server.hs:1273`), so verification takes the per-transmission path -`mapM (\t -> verifyTransmission ...)` (`Server.hs:1279`): one crypto op and, with -`useCache = False`, one DB `getQueueRec` SELECT per transmission. A 16 KB block holds up to 254 -transmissions (`Protocol.hs:2317`). +### How it works -### Impact +Recipient and Notifier commands are batch parties (`Protocol.hs:420`), so their queue lookups are +batched. SEND is not, so it takes the per-transmission path +`mapM (\t -> verifyTransmission ...)` (`Server.hs:1281`). -One write by any handshake-completing peer costs ~130-250 asymmetric verifications and ~130-250 DB -SELECTs. The attacker chooses the auth type and that the queue is absent. +### The bug + +Each transmission runs one crypto op and, with `useCache = False`, one `getQueueRec` SELECT +(`Server.hs:1361`). For an unknown queue, `dummyVerifyCmd` (`Server.hs:1459`) still runs a real +Ed25519/Ed448 verify or an X25519 DH. A 16 KB block holds up to 254 transmissions (`Protocol.hs:2292`, +one-byte count), so one write by any peer that completed the handshake costs ~130-250 asymmetric +verifications and ~130-250 SELECTs. The attacker chooses the auth type and that the queue is absent. ### Fix -Batch the sender/link lookups as Recipient/Notifier already are; cap unknown-queue verifications -per block. +Batch the sender lookups as Recipient and Notifier already are; cap unknown-queue verifications per +block. --- -## Bug 8: unauthenticated clientService grows the services table +## Bug 8: unauthenticated service handshake grows the services table -### Issue +| | | +| --- | --- | +| Reachable | any client, pre-auth | +| Trigger | a fresh self-signed service cert per handshake | +| Cost | one persistent `services` row and one X509 verify per connection | +| Evidence | code review | +| Status | present | -The SMP handshake accepts a self-signed service chain (`CCSelf`, `Transport.hs:786`) and verifies -an attacker-supplied cert per connection; `getCreateService` inserts a `services` row on any new -fingerprint (`QueueStore/Postgres.hs:469`). A fresh self-signed cert per handshake is a new -fingerprint. +### How it works -### Impact +The SMP handshake accepts a self-signed service chain (`CCSelf`, `Transport.hs:759`) and verifies the +supplied cert (`Transport.hs:763`). `getClientService` (`Server.hs:864`) then calls `getCreateService`. + +### The bug -One unbounded, persistent `services` row per connection, pre-auth, plus one X509 verification per -connection. +`getCreateService` inserts a `services` row on any new fingerprint (`QueueStore/Postgres.hs:478`), and +a fresh self-signed cert is a new fingerprint every time. The only guard is a role check on an +existing fingerprint, so each connection can create one unbounded, persistent row plus one X509 verify, +all before authentication. ### Fix -Require the service to be pre-registered, or authenticate/rate-limit service creation. +Require the service to be pre-registered, or authenticate and rate-limit service creation. --- ## Bug 9: Prometheus scrape scans all queues and folds all subscriptions -### Issue +| | | +| --- | --- | +| Reachable | internal, fires every `prometheus_interval` | +| Trigger | Prometheus enabled | +| Cost | scales with queue count and live subscriptions, every scrape | +| Evidence | code review | +| Status | present | + +### How it works -Every `prometheus_interval` (default 60s), `getEntityCounts` runs six `COUNT(1)` scans over -`msg_queues`/`services` (`QueueStore/Postgres.hs:154`, called at `Server.hs:812`), and -`getDeliveredMetrics` folds over all clients times all their subscriptions in memory -(`Server.hs:836`). +On each scrape the server refreshes its metrics from live state rather than incremental counters. -### Impact +### The bug -Cost scales with the largest dimensions (queues, live subscriptions) and recurs every minute while -Prometheus is enabled. +`getEntityCounts` runs six `COUNT(1)` scans over `msg_queues` and `services` +(`QueueStore/Postgres.hs:154`, called at `Server.hs:813`), and `getDeliveredMetrics` folds over all +clients times all their subscriptions in memory (`Server.hs:837`, called at `Server.hs:825`). Cost +scales with the largest dimensions and recurs every interval while Prometheus is on. ### Fix -Maintain the counts incrementally; avoid the per-scrape full fold. +Maintain the counts incrementally; drop the per-scrape full fold. --- ## Bug 10: subscription changes serialize through one thread and one map -### Issue +| | | +| --- | --- | +| Reachable | authenticated SUB | +| Trigger | subscription churn, batched SUB of many queues | +| Cost | throughput bounded by one thread and one contended TVar | +| Evidence | code review | +| Status | present | -All subscription churn goes through one `subQ` drained by one `serverThread` (`Server.hs:273`) that -mutates the single `queueSubscribers` map held in one TVar. A batched SUB of N queues is N separate -writes to `subQ` (`Server.hs:1848`). +### How it works -### Impact +Subscription state lives in `queueSubscribers`, one `Map` in one TVar (`Env/STM.hs:377`). Changes are +enqueued to `subQ` and applied by a single `serverThread` (`Server.hs:284`). -Subscription throughput is bounded by one thread and one contended TVar under churn. +### The bug + +All churn passes through that one thread and one TVar, and a batched SUB of N queues is N separate +writes to `subQ` (`Server.hs:1845`), so subscription throughput does not scale with cores or clients. ### Fix @@ -385,9 +442,9 @@ Shard the subscriber map, or batch `subQ` events per client. ## Clean: TLS/TCP stack -200 connections opened at once, closed, then measured again: +200 connections opened at once, closed, then measured again. -| test | peak per conn | after 25s | +| Test | Peak per conn | After 25s | | --- | --- | --- | | TCP connect, never start TLS | 48.2 KiB | 0.31 KiB | | TLS done, no SMP handshake | 203.1 KiB | 0.71 KiB | @@ -395,20 +452,20 @@ Shard the subscriber map, or batch `subQ` events per client. All recovered. Also clean: 400 connect/disconnect rounds, and steady forwarding at 50ms each way. -Measure well after closing. At +5s the middle two still read ~120 KiB per connection, which looks -like a 24 MiB leak but is just connections still closing. A number that keeps falling is being -freed; a number that stops above where it started is leaked. +Measure well after closing. At +5s the middle two still read ~120 KiB per connection, which looks like +a 24 MiB leak but is just connections still closing. A number that keeps falling is being freed; one +that stops above where it started is leaked. -The peaks are still worth knowing. 200 abandoned half open connections hold ~40 MiB for ~25s, with -no authentication needed. A client that finishes the handshake then sends one byte holds ~265 KiB -for as long as it stays connected, because there is no read timeout: `transportTimeout` is -hardcoded `Nothing` (`Transport/Server.hs:104`). +The peaks still matter. 200 abandoned half-open connections hold ~40 MiB for ~25s with no +authentication. A client that finishes the handshake then sends one byte holds ~265 KiB for as long as +it stays connected, because there is no read timeout: `transportTimeout` is hardcoded `Nothing` +(`Transport/Server.hs:104`). ## Clean: connectivity and sockets under latency Latency set with `BENCHLAG_MS` on `proxyfwd`, one way. Sockets counted from `/proc//fd`. -| lag each way | delivered | sockets | relay connects | reconnects | timeouts | +| Lag each way | Delivered | Sockets | Relay connects | Reconnects | Timeouts | | --- | --- | --- | --- | --- | --- | | 0ms | 12/12 | 8 | 1 | 0 | 0 | | 500ms | 10/10 | 8 | 1 | 0 | 0 | @@ -416,10 +473,8 @@ Latency set with `BENCHLAG_MS` on `proxyfwd`, one way. Sockets counted from `/pr | 16s | 4/4 | 8 | 1 | 0 | 0 | | 40s | 0/2 | 8 | 1 | 0 | 1 | -Nothing builds up. The socket count is the same whether forwards succeed or time out, the session -is opened once and reused, and there are no reconnects at any latency. - -This is why Leak 1 has no upper bound: the session holding the stuck entries never closes. - -Forwards work to 16s each way and fail at 40s, because of the 30s RFWD timeout. The exact cutoff is -not measured, since the test transport adds its delay per read/write rather than per message. +Nothing builds up. The socket count is the same whether forwards succeed or time out, the session is +opened once and reused, and there are no reconnects at any latency. This is why Leak 1 has no upper +bound: the session holding the stuck entries never closes. Forwards work to 16s each way and fail at +40s because of the 30s RFWD timeout; the exact cutoff is not measured, since the test transport adds +its delay per read/write rather than per message. From 85d74352cf3086e13503e95bfc9fe03ba505d027 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 9 Sep 2026 14:44:06 +0000 Subject: [PATCH 26/43] docs: add stuck relay session finding --- docs/leak-findings.md | 43 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 39 insertions(+), 4 deletions(-) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 08ca4f855..521cd635c 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -4,9 +4,9 @@ Found with `bench/MemBench.hs` using a proxy-plus-relay topology and a transport and drops replies. Journal store and PostgreSQL gave the same numbers except where a row says otherwise. -Eleven findings: three proxy-path memory leaks (Leak 1-3), two `forkClient` bugs (Bug 3-4), an -unauthenticated resolver fan-out (Bug 5), and five PostgreSQL-backend costs (Bug 6-10). The TLS/TCP -stack is clean (last two sections). +Twelve findings: three proxy-path memory leaks (Leak 1-3), two `forkClient` bugs (Bug 3-4), an +unauthenticated resolver fan-out (Bug 5), five PostgreSQL-backend costs (Bug 6-10), and a stuck proxy +session (Bug 11). The TLS/TCP stack is clean (last two sections). ## Overview @@ -23,8 +23,9 @@ stack is clean (last two sections). | Bug 8 | Service handshake grows `services` table | Client, pre-auth | postgres | code review | present | | Bug 9 | Prometheus scrape scans everything | internal, periodic | postgres | code review | present | | Bug 10 | Subscription churn serialized | authenticated SUB | all | code review | present | +| Bug 11 | Proxy never drops a stuck relay session | Client, pre-auth (PRXY) | all | reproduced | present | -Leak 1, Leak 2, Leak 3, and Bug 3 share one entry point. `PRXY` is unauthenticated unless +Leak 1, Leak 2, Leak 3, Bug 3, and Bug 11 share one entry point. `PRXY` is unauthenticated unless `newQueueBasicAuth` is set (`Server.hs:1534`) and it names an arbitrary destination, so a client can point the proxy at a relay it controls. @@ -440,6 +441,40 @@ Shard the subscriber map, or batch `subQ` events per client. --- +## Bug 11: proxy never drops a stuck relay session + +| | | +| --- | --- | +| Reachable | any client, pre-auth via PRXY | +| Trigger | relay stops answering forwards once the session is open | +| Cost | forwards keep failing, no recovery until the ~20 min monitor drop | +| Evidence | `testProxyForwardTimeoutStuckSession` (pending spec) | +| Status | present | + +### How it works + +Shares Leak 1's mechanism. The forward path never calls `enablePings`, so a dead relay session is +dropped only by `monitor` (`Client.hs:668`), which closes the client when `timeoutErrorCount >= +smpPingCount` (3, `Client.hs:439`) and the last receive is older than `recoverWindow` (900s, +`Client.hs:685`). `receive` (`Client.hs:663`) resets both counters on any inbound byte. + +### The bug + +A broken session is not dropped, so the proxy keeps forwarding to it and every forward fails. This is +the reported symptom: `Error forwarding to relay ... PCEResponseTimeout` continued after the relay was +restarted, because the proxy held the old session instead of reconnecting. Reproduced by +`testProxyForwardTimeoutStuckSession` (`SMPProxyTests.hs:499`): 10 forwards on one timed-out session +expecting a `PROXY NO_SESSION` drop, but all 10 return `BROKER TIMEOUT`. Unlike Leak 1 this is +availability, not memory; the same persistent session is what makes Leak 1 unbounded. + +### Fix + +Drop the relay session after a bounded number of forward timeouts so the next forward returns +`NO_SESSION` and the agent reconnects, instead of waiting out the 900s receive window. Enabling pings +on the forward path would also let `monitor` detect the dead session. + +--- + ## Clean: TLS/TCP stack 200 connections opened at once, closed, then measured again. From a6214163b4e65ea27c9adf7b560bfec4e5e5ea6d Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 12:00:25 +0000 Subject: [PATCH 27/43] bench: fix msgqfill after msgQ became optional --- bench/MemBench.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 626a0017e..8092a6331 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -992,7 +992,7 @@ main = do ( case phase of "conclimit" -> withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {serverClientConcurrency = 1}) storeEnv -- shrink the proxy agent's msgQ so its bound is reachable in one run - "msgqfill" -> withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {smpAgentCfg = (smpAgentCfg c) {msgQSize = msgQSz}}) storeEnv + "msgqfill" -> withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {smpAgentCfg = (smpAgentCfg c) {msgQSize = Just msgQSz}}) storeEnv _ -> withProxyTopology storeEnv ) $ settle leakDiagSec From 2722006e300a6f324b950d12057e9e8fbff96e46 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 12:00:25 +0000 Subject: [PATCH 28/43] bench: let finalizers run before measuring --- bench/MemBench.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 8092a6331..1f2daf548 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -50,6 +50,7 @@ import Data.List.NonEmpty (NonEmpty (..), fromList) import Data.Maybe (fromMaybe) import Data.Time.Clock (diffUTCTime, getCurrentTime) import qualified Data.X509.Validation as XV +import GHC.Profiling (requestHeapCensus) import GHC.Stats import qualified Network.Socket as N import NetLag (LagTLS, clearLag, setDropEvery, setDropSnd, setLag) @@ -160,6 +161,12 @@ drainAll h = timeout 40000 (tGet1 h) >>= maybe (pure ()) (const $ drainAll h) liveBytesMiB :: IO Double liveBytesMiB = do + -- a major GC schedules the finalizers of everything that died since the last one (crypton keys + -- are finalized ScrubbedBytes); let them run, or their weak pointers and closures count as live + performMajorGC + threadDelay 200000 + -- with +RTS -hT this makes the census coincide with the measurement; ignored otherwise + requestHeapCensus performMajorGC s <- getRTSStats pure $ fromIntegral (gcdetails_live_bytes (gc s)) / (1024 * 1024) From 706211dc24f4e1920d8a10a5c3548ec696ddc1d2 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 12:03:25 +0000 Subject: [PATCH 29/43] bench: add server-only memory and load phases --- bench/MemBench.hs | 411 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 401 insertions(+), 10 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 1f2daf548..9a14002a5 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -23,6 +23,7 @@ -- -- Single-server phases (server on testPort): -- plain | svc | svcrace | ntf | conc | svcsubs | getp | stuck | certchurn | link | ntfexp +-- ntfloop | ntfdeliver | subslice | conns | load | cpsave -- PostgreSQL build only -- tlsstall | tlshalf | tlschurn | tlspartial -- TLS/TCP stack -- -- Two-server phases (proxy on testPort, lagged destination relay on testPort2): @@ -59,7 +60,7 @@ import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (msgQSize)) -import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration, serverClientConcurrency, smpAgentCfg)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration, ntfDeliveryInterval, serverClientConcurrency, smpAgentCfg, storeNtfsFile)) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport @@ -67,7 +68,25 @@ import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTr import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Version (mkVersionRange) import System.Environment (getArgs, lookupEnv, setEnv) -import System.IO (BufferMode (..), IOMode (..), hClose, hGetLine, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode) +import System.IO (BufferMode (..), IOMode (..), hClose, hGetLine, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode, withFile) +#if defined(dbServerPostgres) +import Database.PostgreSQL.Simple (ConnectInfo (..)) +import Network.Socket (ServiceName) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) +import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), serverStoreCfg) +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) +import qualified Data.ByteString.Builder as BLD +import Data.List (unfoldr) +import Data.Time.Clock.System (getSystemTime) +import Data.Word (Word64) +import Simplex.Messaging.Encoding.String (strEncode) +import Simplex.Messaging.Server.NtfStore (MsgNtf (..), NtfLogRecord (..)) +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) +import System.Environment (getExecutablePath) +import System.IO (Handle, stdout) +import System.Process (CreateProcess (..), StdStream (..), callProcess, createProcess, proc, waitForProcess) +#endif import System.Mem (performMajorGC) import System.Timeout (timeout) import Text.Printf (printf) @@ -126,10 +145,14 @@ serviceSignSendRecv h pk serviceKey t = do pure r signSendRecv_ :: forall p. PartyI p => H -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg))) -signSendRecv_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do - let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) - Right () <- tPut1 h (authorize tForAuth, tToSend) +signSendRecv_ h pk serviceKey_ t = do + Right () <- tPut1 h (signTransmission h pk serviceKey_ t) tGetClient h + +signTransmission :: forall p. PartyI p => H -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> SentRawTransmission +signTransmission THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) + in (authorize tForAuth, tToSend) where authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t' @@ -171,6 +194,10 @@ liveBytesMiB = do s <- getRTSStats pure $ fromIntegral (gcdetails_live_bytes (gc s)) / (1024 * 1024) +-- memory in partially used blocks (mostly pinned blocks kept by a few live objects), as of the last GC +fragmentationMiB :: IO Double +fragmentationMiB = (/ (1024 * 1024)) . fromIntegral . gcdetails_block_fragmentation_bytes . gc <$> getRTSStats + report :: String -> Int -> Double -> Double -> IO () report phase i base cur = printf "%-8s iter=%7d live=%9.1f MiB delta=%+9.1f MiB (%+.4f KiB/iter)\n" @@ -259,6 +286,178 @@ runNtf g iters cp = Resp _ _ OK <- signSendRecv recip rKey (corr, rId, ACK mId) pure () +#if defined(dbServerPostgres) +-- Notification delivery loop cost with N stored notifiers. +-- +-- deliverNtfsThread (Server.hs:380) runs every ntfDeliveryInterval, 1.5s in production. Each tick +-- takes every NtfStore key, including keys whose list is already empty, and resolves their services +-- with one `notifier_id IN ?` query read in full (QueueStore/Postgres.hs:538). +-- +-- Seeds N notifier queues with SQL and N stored notifications through the server's own restore +-- file, then samples RTS counters with no client traffic. NTFLOOP_DELIVER=0 disables the loop, so +-- the difference between the two runs is the loop's own cost. +runNtfLoop :: Int -> IO () +runNtfLoop n = postgressBracket benchDBConnectInfo $ do + deliver <- (/= Just "0") <$> lookupEnv "NTFLOOP_DELIVER" + secs <- fromMaybe 30 . (>>= readMaybe) <$> lookupEnv "NTFLOOP_SEC" + let productionInterval = 1500000 + disabledInterval = 86400 * 1000000 + srvCfg = updateCfg benchPgCfg $ \c -> + c {storeNtfsFile = Just testStoreNtfsFile, ntfDeliveryInterval = if deliver then productionInterval else disabledInterval} + createDirectoryIfMissing True "tests/tmp" + doesFileExist testStoreNtfsFile >>= (`when` removeFile testStoreNtfsFile) + -- the first start runs the migrations that create msg_queues + withSmpServerConfigOn (transport @TLS) srvCfg benchPort $ \_ -> threadDelay 500000 + seedNotifierQueues n + writeNtfsFile n + printf "ntfloop: n=%d deliver=%s window=%ds\n" n (show deliver) secs + withSmpServerConfigOn (transport @TLS) srvCfg benchPort $ \_ -> do + performMajorGC + base <- getRTSStats + let mib :: Word64 -> Double + mib b = fromIntegral b / (1024 * 1024) + cpuNs s = mutator_cpu_ns s + gc_cpu_ns s + printf "ntfloop: after restore live=%.1f MiB mem_in_use=%.1f MiB max_mem_in_use=%.1f MiB\n" + (mib $ gcdetails_live_bytes $ gc base) (mib $ gcdetails_mem_in_use_bytes $ gc base) (mib $ max_mem_in_use_bytes base) + peak <- newTVarIO (0 :: Word64) + forM_ ([1 .. secs] :: [Int]) $ \t -> do + threadDelay 1000000 + s <- getRTSStats + atomically $ modifyTVar' peak (max $ gcdetails_mem_in_use_bytes $ gc s) + when (t `mod` 5 == 0) $ + printf "ntfloop: t=%3ds alloc=%8.1f MiB/s cpu=%5.2f cores mem_in_use=%8.1f MiB major_gcs=%d\n" + t + (mib (allocated_bytes s - allocated_bytes base) / fromIntegral t) + (fromIntegral (cpuNs s - cpuNs base) / (fromIntegral t * 1e9) :: Double) + (mib $ gcdetails_mem_in_use_bytes $ gc s) + (major_gcs s - major_gcs base) + end <- getRTSStats + pk <- readTVarIO peak + performMajorGC + after <- getRTSStats + printf "ntfloop: SUMMARY n=%d deliver=%s alloc=%.1f MiB/s (%.1f MiB per 1.5s tick) cpu=%.2f cores peak_mem_in_use=%.1f MiB max_mem_in_use=%.1f MiB live_end=%.1f MiB\n" + n + (show deliver) + (mib (allocated_bytes end - allocated_bytes base) / fromIntegral secs) + (1.5 * mib (allocated_bytes end - allocated_bytes base) / fromIntegral secs) + (fromIntegral (cpuNs end - cpuNs base) / (fromIntegral secs * 1e9) :: Double) + (mib pk) + (mib $ max_mem_in_use_bytes end) + (mib $ gcdetails_live_bytes $ gc after) + +-- Its own database, user and port, so a bench run cannot collide with a concurrent test-suite run, +-- which binds testPort and drops and recreates test_server_db and test_server_user. +benchDBConnectInfo :: ConnectInfo +benchDBConnectInfo = testServerDBConnectInfo {connectUser = "mem_bench_user", connectDatabase = "mem_bench_db"} + +benchPort :: ServiceName +benchPort = "15001" + +benchPgCfg :: AServerConfig +benchPgCfg = case cfgMS (ASType SQSPostgres SMSPostgres) of + ASrvCfg SQSPostgres SMSPostgres c -> ASrvCfg SQSPostgres SMSPostgres c {serverStoreCfg = SSCDatabase storeCfg} + c -> c + where + storeCfg = + PostgresStoreCfg + { dbOpts = testStoreDBOpts {connstr = B.pack $ "postgresql://" <> connectUser benchDBConnectInfo <> "@/" <> connectDatabase benchDBConnectInfo}, + dbStoreLogPath = Nothing, + confirmMigrations = MCYesUp, + deletedTTL = 86400 + } + +benchClient :: (H -> IO a) -> IO a +benchClient client = do + Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost + testSMPClient_ useHost benchPort supportedClientSMPRelayVRange Nothing client + +-- NtfStore keys left behind by delivered notifications. +-- +-- With a subscribed ntf client, each tick flushes a notifier's list to [] (addNtfs) but keeps the +-- key, and every key is re-sent to getQueueNtfServices on every tick until deleteExpiredNtfs +-- removes it (hourly on this branch, never on stable). Creates `iters` notifier queues, subscribes +-- one ntf client to all of them, delivers one notification to each, then samples RTS counters while +-- nothing else happens. LEAKDIAG ntfStore_keys shows the retained keys. +runNtfDeliver :: TVar ChaChaDRG -> Int -> IO () +runNtfDeliver g n = do + secs <- fromMaybe 30 . (>>= readMaybe) <$> lookupEnv "NTFLOOP_SEC" + benchClient $ \recip -> benchClient $ \sndr -> benchClient $ \nh -> do + sIds <- forM ([1 .. n] :: [Int]) $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvNtfPubDh, _dh :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let corr = B.pack (show i) + Resp _ _ (Ids rId sId _) <- signSendRecv recip rKey (corr, NoEntity, New0 rPub dhPub) + Resp _ _ (NID nId _) <- signSendRecv recip rKey (corr, rId, NKEY nPub rcvNtfPubDh) + Resp _ _ (SOK Nothing) <- signSendRecv nh nKey (corr, nId, NSUB) + pure sId + forM_ (zip [1 :: Int ..] sIds) $ \(i, sId) -> do + Resp _ _ OK <- sendRecv sndr (Nothing, B.pack (show i), sId, _SEND' "hi") + pure () + let awaitNtfs k = when (k > 0) $ do + rs :: NonEmpty (Transmission (Either ErrorType BrokerMsg)) <- tGetClient nh + awaitNtfs (k - length [() | (_, _, Right NMSG {}) <- toList rs]) + awaitNtfs n + printf "ntfdeliver: n=%d notifications delivered, sampling %ds\n" n secs + performMajorGC + base <- getRTSStats + threadDelay $ secs * 1000000 + end <- getRTSStats + let mib :: Word64 -> Double + mib b = fromIntegral b / (1024 * 1024) + cpuNs st = mutator_cpu_ns st + gc_cpu_ns st + printf "ntfdeliver: SUMMARY n=%d idle alloc=%.1f MiB/s cpu=%.2f cores\n" + n + (mib (allocated_bytes end - allocated_bytes base) / fromIntegral secs) + (fromIntegral (cpuNs end - cpuNs base) / (fromIntegral secs * 1e9) :: Double) + +-- Control-port `save` on the PostgreSQL store. +-- +-- CPSave (Server.hs:1153) runs saveServer False, and its closeMsgStore closes the DB pool +-- (closeDBStore drains and closes every pooled connection). The server keeps running, so the next +-- withConnectionPool waits forever on the empty pool while holding dbSem. +runCpSave :: TVar ChaChaDRG -> IO () +runCpSave g = benchClient $ \h -> do + (rPub, rKey, dhPub) <- genKeys g + Resp _ _ (Ids _ _ _) <- signSendRecv h rKey ("1", NoEntity, New rPub dhPub) + putStrLn "cpsave: NEW before save: IDS" + r <- cpCommand benchCpPort "save" 2 30000000 + printf "cpsave: save replied %s\n" (show r) + (rPub', rKey', dhPub') <- genKeys g + res <- timeout 10000000 $ signSendRecv h rKey' ("2", NoEntity, New rPub' dhPub') + putStrLn $ "cpsave: NEW after save: " <> maybe "no response in 10s (DB access blocked)" (const "responded") res + +benchCpPort :: ServiceName +benchCpPort = "15010" + +-- The IDs are a tag byte followed by i in 23 big-endian bytes, the same bytes the SQL builds with +-- lpad(to_hex(i), 46, '0'), so file entries and rows match without passing IDs between them. +seqId :: Char -> Int -> ByteString +seqId tag i = B.cons tag $ B.replicate (23 - B.length be) '\0' <> be + where + be = B.pack . reverse $ unfoldr (\x -> if x == 0 then Nothing else Just (toEnum (x `mod` 256), x `div` 256)) i + +seedNotifierQueues :: Int -> IO () +seedNotifierQueues n = + callProcess "psql" ["-q", "-v", "ON_ERROR_STOP=1", "-U", "postgres", "-d", connectDatabase benchDBConnectInfo, "-c", sql] + where + hexId :: String -> String + hexId tag = "decode('" <> tag <> "' || lpad(to_hex(i), 46, '0'), 'hex')" + sql = + "INSERT INTO smp_server.msg_queues (recipient_id, recipient_keys, rcv_dh_secret, sender_id, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) SELECT " + <> hexId "01" <> ", '\\x00', '\\x00', " <> hexId "02" <> ", " <> hexId "03" <> ", '\\x00', '\\x00', 'active', 0 FROM generate_series(1, " + <> show n <> ") AS i" + +-- MsgNtf field sizes match mkMessageNotification: 24-byte msg id and nonce, 128-byte padded meta plus 16-byte tag +writeNtfsFile :: Int -> IO () +writeNtfsFile n = do + ts <- getSystemTime + let ntf = MsgNtf {ntfMsgId = B.replicate 24 'm', ntfTs = ts, ntfNonce = C.cbNonce (B.replicate 24 'n'), ntfEncMeta = B.replicate 144 'e'} + withFile testStoreNtfsFile WriteMode $ \h -> + forM_ ([1 .. n] :: [Int]) $ \i -> + BLD.hPutBuilder h $ BLD.byteString (strEncode $ NLRv1 (EntityId $ seqId '\3' i) ntf) <> BLD.char8 '\n' +#endif + -- reusable steps ------------------------------------------------------------ genKeys :: TVar ChaChaDRG -> IO (RcvPublicAuthKey, C.APrivateAuthKey, RcvPublicDhKey) @@ -356,6 +555,181 @@ runGet g iters cp = Resp _ _ OK <- signSendRecv recip rKey (corr, rId, DEL) pure () +#if defined(dbServerPostgres) +-- Server memory per subscription. +-- +-- The server stores the parsed entity ID as the subscription key (Server.hs:1839, :1971, and +-- queueSubscribers via subQ). The ID is an attoparsec slice of the decrypted ~16 KB block, so while +-- any key from a block is subscribed, the whole block stays live. NEW subscriptions are keyed by the +-- server-generated randomId instead. +-- +-- The client runs in a child process (phase subclient), so the live bytes measured here are the +-- server's alone. SUBMODE=sub (default) creates `iters` queues without subscribing, then subscribes +-- them from a second connection, SUBBATCH per block (default 1); SUBKEEP=k keeps k subscriptions per +-- block and deletes the other queues. SUBMODE=new subscribes with NEW; NEWSUB=0 only creates. +runSubSlice :: Int -> IO () +runSubSlice iters = do + mode <- fromMaybe "sub" <$> lookupEnv "SUBMODE" + base <- liveBytesMiB + fragBase <- fragmentationMiB + report "subslice" 0 base base + exe <- getExecutablePath + (Just hIn, Just hOut, _, ph) <- createProcess (proc exe ["subclient", show iters]) {std_in = CreatePipe, std_out = CreatePipe} + kept <- awaitReady hOut + cur <- liveBytesMiB + frag <- fragmentationMiB + report "subslice" iters base cur + printf "subslice: SUMMARY mode=%s subscribed=%d server_live_delta=%.1f MiB per_subscription=%.2f KiB block_fragmentation_per_subscription=%.2f KiB\n" + mode kept (cur - base) ((cur - base) * 1024 / fromIntegral (max 1 kept)) ((frag - fragBase) * 1024 / fromIntegral (max 1 kept)) + hClose hIn + void $ waitForProcess ph + -- the server drops the connection's subscriptions on disconnect + threadDelay 1000000 + after <- liveBytesMiB + printf "subslice: after disconnect server_live_delta=%.1f MiB\n" (after - base) + where + awaitReady :: Handle -> IO Int + awaitReady h = hGetLine h >>= \l -> case words l of + ["READY", k] -> pure $ read k + _ -> awaitReady h + +-- Server memory per idle connection. The child (phase connclient) opens `iters` SMP connections, +-- completes the handshakes, prints READY and holds them until stdin closes, so the live bytes +-- measured here are the server's alone. +runConns :: Int -> IO () +runConns iters = do + base <- liveBytesMiB + report "conns" 0 base base + exe <- getExecutablePath + (Just hIn, Just hOut, _, ph) <- createProcess (proc exe ["connclient", show iters]) {std_in = CreatePipe, std_out = CreatePipe} + n <- awaitReadyLine hOut + cur <- liveBytesMiB + report "conns" n base cur + printf "conns: SUMMARY connections=%d server_live_delta=%.1f MiB per_connection=%.2f KiB\n" n (cur - base) ((cur - base) * 1024 / fromIntegral (max 1 n)) + hClose hIn + void $ waitForProcess ph + threadDelay 2000000 + after <- liveBytesMiB + printf "conns: after disconnect server_live_delta=%.1f MiB\n" (after - base) + +runConnClient :: Int -> IO () +runConnClient iters = do + hSetBuffering stdout LineBuffering + opened <- newTVarIO (0 :: Int) + release <- newEmptyTMVarIO + let hold = benchClient $ \_ -> do + atomically $ modifyTVar' opened (+ 1) + atomically $ readTMVar release + withAsync (forConcurrently_ ([1 .. iters] :: [Int]) $ \_ -> hold) $ \a -> do + atomically $ readTVar opened >>= \n -> when (n < iters) retry + putStrLn $ "READY " <> show iters + void (E.try getLine :: IO (Either E.IOException String)) + atomically $ putTMVar release () + wait a + +awaitReadyLine :: Handle -> IO Int +awaitReadyLine h = hGetLine h >>= \l -> case words l of + ["READY", k] -> pure $ read k + _ -> awaitReadyLine h + +-- Server CPU under a fixed mixed workload, to compare RTS settings. The child (phase loadclient) +-- runs LOAD_WORKERS workers (default 16) for LOAD_SEC seconds (default 60); each worker reconnects +-- every 50 steps so TLS handshakes are part of the load, and every third step also uses notifications. +-- The server keeps the RTS flags given to this process; the child keeps its defaults. +runLoad :: IO () +runLoad = do + performMajorGC + base <- getRTSStats + exe <- getExecutablePath + (_, Just hOut, _, ph) <- createProcess (proc exe ["loadclient", "0"]) {std_out = CreatePipe} + (ops, secs) <- awaitDone hOut + end <- getRTSStats + void $ waitForProcess ph + let cpu f = fromIntegral (f end - f base) / 1e9 :: Double + mutCpu = cpu mutator_cpu_ns + gcCpu = cpu gc_cpu_ns + printf "load: SUMMARY ops=%d secs=%.1f ops_per_sec=%.1f server_cpu_ms_per_op=%.3f mutator_cpu=%.1fs gc_cpu=%.1fs gc_share=%.1f%% gcs=%d major_gcs=%d max_mem_in_use=%.1f MiB\n" + ops secs (fromIntegral ops / secs) ((mutCpu + gcCpu) * 1000 / fromIntegral ops) mutCpu gcCpu (100 * gcCpu / (mutCpu + gcCpu)) + (gcs end - gcs base) (major_gcs end - major_gcs base) (fromIntegral (max_mem_in_use_bytes end) / (1024 * 1024) :: Double) + where + awaitDone :: Handle -> IO (Int, Double) + awaitDone h = hGetLine h >>= \l -> case words l of + ["DONE", o, t] -> pure (read o, read t) + _ -> awaitDone h + +runLoadClient :: TVar ChaChaDRG -> IO () +runLoadClient g = do + hSetBuffering stdout LineBuffering + workers <- fromMaybe 16 . (>>= readMaybe) <$> lookupEnv "LOAD_WORKERS" + secs <- fromMaybe 60 . (>>= readMaybe) <$> lookupEnv "LOAD_SEC" + ops <- newTVarIO (0 :: Int) + start <- getCurrentTime + let deadline = fromIntegral (secs :: Int) + worker w = do + t <- getCurrentTime + when (diffUTCTime t start < deadline) $ do + benchClient $ \recip -> benchClient $ \sndr -> + forM_ ([1 .. 50] :: [Int]) $ \i -> do + (if i `mod` 3 == 0 then ntfStep else plainStep) g recip sndr (w * 1000000 + i) + atomically $ modifyTVar' ops (+ 1) + worker w + forConcurrently_ ([1 .. workers] :: [Int]) worker + end <- getCurrentTime + n <- readTVarIO ops + putStrLn $ "DONE " <> show n <> " " <> show (realToFrac (diffUTCTime end start) :: Double) + +-- Client side of subslice: creates the subscriptions, prints "READY ", and holds the +-- connection until stdin is closed. +runSubClient :: TVar ChaChaDRG -> Int -> IO () +runSubClient g iters = do + hSetBuffering stdout LineBuffering + lookupEnv "SUBMODE" >>= \case + Just "new" -> do + subscribe <- (/= Just "0") <$> lookupEnv "NEWSUB" + benchClient $ \h -> do + forM_ ([1 .. iters] :: [Int]) $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + Resp _ _ Ids {} <- signSendRecv h rKey (B.pack $ "n" <> show i, NoEntity, (if subscribe then New else New0) rPub dhPub) + pure () + ready $ if subscribe then iters else 0 + -- create without subscribing, then SUB on the same connection + Just "newthensub" -> benchClient $ \h -> do + forM_ ([1 .. iters] :: [Int]) $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + Resp _ _ (Ids rId _ _) <- signSendRecv h rKey (B.pack $ "n" <> show i, NoEntity, New0 rPub dhPub) + Resp _ _ (SOK Nothing) <- signSendRecv h rKey (B.pack $ "s" <> show i, rId, SUB) + pure () + ready iters + _ -> do + batch <- fromMaybe 1 . (>>= readMaybe) <$> lookupEnv "SUBBATCH" + keep <- fromMaybe batch . (>>= readMaybe) <$> lookupEnv "SUBKEEP" + qs <- benchClient $ \h -> forM ([1 .. iters] :: [Int]) $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + Resp _ _ (Ids rId _ _) <- signSendRecv h rKey (B.pack $ "c" <> show i, NoEntity, New0 rPub dhPub) + pure (i, rId, rKey) + benchClient $ \h -> do + forM_ (chunks batch qs) $ \b -> do + let sub (i, rId, rKey) = Right $ signTransmission h rKey Nothing (B.pack $ "s" <> show i, rId, SUB) + void $ tPut h (fromList $ map sub b) + awaitResponses h (length b) + forM_ (drop keep b) $ \(i, rId, rKey) -> do + Resp _ _ OK <- signSendRecv h rKey (B.pack $ "d" <> show i, rId, DEL) + pure () + ready $ sum $ map (min keep . length) (chunks batch qs) + where + ready :: Int -> IO () + ready k = do + putStrLn $ "READY " <> show k + void (E.try getLine :: IO (Either E.IOException String)) + chunks n xs = case splitAt n xs of + (c, []) -> [c] + (c, rest) -> c : chunks n rest + awaitResponses :: H -> Int -> IO () + awaitResponses h n = when (n > 0) $ do + rs :: NonEmpty (Transmission (Either ErrorType BrokerMsg)) <- tGetClient h + awaitResponses h (n - length rs) +#endif + -- forkDeliver blocked in SubPending: a subscriber that never reads its sndQ. -- Deliveries to a full sndQ fork a deliverThread that blocks forever -> threads/subs_thread grow. runStuck :: TVar ChaChaDRG -> Int -> Int -> IO () @@ -814,20 +1188,24 @@ heldConns phase iters -- connection from `active` before gracefulClose (up to 5s) and before it increments `closed`, -- so a connection in teardown is counted in neither and shows up as leaked. cpSockets :: N.ServiceName -> IO [String] -cpSockets port = do +cpSockets port = fromMaybe [] <$> cpCommand port "sockets" 5 5000000 -- "Sockets for port N:" + accepted/closed/active/leaked + +-- Run one admin command on the control port and read `n` reply lines, or Nothing on timeout. +cpCommand :: N.ServiceName -> String -> Int -> Int -> IO (Maybe [String]) +cpCommand port cmd n tmo = do sock <- rawConnect port h <- N.socketToHandle sock ReadWriteMode hSetBuffering h LineBuffering hSetNewlineMode h universalNewlineMode - r <- timeout 5000000 $ do + r <- timeout tmo $ do _ <- hGetLine h -- banner line 1 _ <- hGetLine h -- banner line 2 hPutStrLn h "auth bench" _ <- hGetLine h - hPutStrLn h "sockets" - replicateM 5 (hGetLine h) -- "Sockets for port N:" + accepted/closed/active/leaked + hPutStrLn h cmd + replicateM n (hGetLine h) hClose h `E.catch` \(_ :: E.SomeException) -> pure () - pure $ fromMaybe [] r + pure r cpPort :: N.ServiceName cpPort = "5010" @@ -1012,6 +1390,19 @@ main = do "fastfwd" -> runFastFwd g iters cp "msgqfill" -> runMsgQFill g iters cp _ -> error $ "unknown proxy phase: " <> phase +#if defined(dbServerPostgres) + else if phase == "ntfloop" then runNtfLoop iters + else if phase == "ntfdeliver" then postgressBracket benchDBConnectInfo $ withSmpServerConfigOn (transport @TLS) (updateCfg benchPgCfg $ \c -> c {ntfDeliveryInterval = 1500000}) benchPort $ \_ -> runNtfDeliver g iters + else if phase == "cpsave" then + postgressBracket benchDBConnectInfo $ + withSmpServerConfigOn (transport @TLS) (updateCfg benchPgCfg $ \c -> c {controlPort = Just benchCpPort, controlPortAdminAuth = Just "bench"}) benchPort $ \_ -> runCpSave g + else if phase == "subslice" then postgressBracket benchDBConnectInfo $ withSmpServerConfigOn (transport @TLS) benchPgCfg benchPort $ \_ -> runSubSlice iters + else if phase == "subclient" then runSubClient g iters + else if phase == "conns" then postgressBracket benchDBConnectInfo $ withSmpServerConfigOn (transport @TLS) benchPgCfg benchPort $ \_ -> runConns iters + else if phase == "connclient" then runConnClient iters + else if phase == "load" then postgressBracket benchDBConnectInfo $ withSmpServerConfigOn (transport @TLS) benchPgCfg benchPort $ \_ -> runLoad + else if phase == "loadclient" then runLoadClient g +#endif else withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> settle leakDiagSec $ do threadDelay 250000 case phase of From 91d6b775972900f6347498f46401588a9e9c4b89 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 12:03:33 +0000 Subject: [PATCH 30/43] bench: reproduce oversized PFWD leak --- bench/MemBench.hs | 37 ++++++++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 9a14002a5..57ec362bd 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -27,7 +27,7 @@ -- tlsstall | tlshalf | tlschurn | tlspartial -- TLS/TCP stack -- -- Two-server phases (proxy on testPort, lagged destination relay on testPort2): --- proxyfwd | proxytmo | proxychurn | subtmo +-- proxyfwd | proxytmo | proxychurn | subtmo | pfwdbig -- -- Env: BENCHSTORE selects the store (see srvStoreCfg); SMP_LEAKDIAG_SEC sets the LEAKDIAG -- interval (defaulted to 10s here). In two-server phases each LEAKDIAG line is tagged with the @@ -1374,7 +1374,8 @@ main = do withGlobalLogging LogConfig {lc_file = Nothing, lc_stderr = True} $ if phase `elem` proxyPhases then - ( case phase of + pgBracket + . ( case phase of "conclimit" -> withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {serverClientConcurrency = 1}) storeEnv -- shrink the proxy agent's msgQ so its bound is reachable in one run "msgqfill" -> withProxyTopologyCfg (updateCfg (proxySrvCfg storeEnv) $ \c -> c {smpAgentCfg = (smpAgentCfg c) {msgQSize = Just msgQSz}}) storeEnv @@ -1389,6 +1390,7 @@ main = do "conclimit" -> runConcLimit g iters cp "fastfwd" -> runFastFwd g iters cp "msgqfill" -> runMsgQFill g iters cp + "pfwdbig" -> runPfwdBig g iters cp _ -> error $ "unknown proxy phase: " <> phase #if defined(dbServerPostgres) else if phase == "ntfloop" then runNtfLoop iters @@ -1465,8 +1467,37 @@ runMsgQFill g iters _cp = do o <- readTVarIO ok printf "msgqfill: recovery forwards succeeded=%d/3 (0 means the proxy stalled)\n" o +-- Leak 1 without relay cooperation: an oversized PFWD. +-- +-- A client that declares proxyServer = True in its handshake gets no block encryption, so a PFWD +-- whose encBlock is 16260-16266 bytes still fits its block (the PFWD length is not validated). The +-- proxy's RFWD to the relay is then too large for the relay block: sendRecv returns TELargeMsg +-- before sending, and the Request stays in the proxy's sentCommands for the life of the +-- proxy-relay session. LEAKDIAG proxy_sentCommands (srv=5001) counts the entries. +runPfwdBig :: TVar ChaChaDRG -> Int -> Int -> IO () +runPfwdBig g iters cp = do + size <- fromMaybe 16260 . (>>= readMaybe) <$> lookupEnv "PFWDSIZE" + ts <- getCurrentTime + pc <- getProtocolClient g NRMInteractive (1, proxySrv, Nothing) benchClientCfg {proxyServer = True} [] Nothing ts (\_ -> pure ()) + >>= either (fail . show) pure + ProxiedRelay {prSessionId, prVersion} <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relaySrv Nothing + (k, _) <- atomically $ C.generateKeyPair @'C.X25519 g + let pfwd = Cmd SProxiedClient $ PFWD prVersion k $ EncTransmission $ B.replicate size 'a' + r <- runExceptT $ sendProtocolCommand pc NRMInteractive Nothing (EntityId prSessionId) pfwd + printf "pfwdbig: size=%d first response: %s\n" size (show r) + withCheckpoints "pfwdbig" iters cp $ \_ -> + void $ runExceptT $ sendProtocolCommand pc NRMInteractive Nothing (EntityId prSessionId) pfwd + proxyPhases :: [String] -proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "subtmo", "conclimit", "fastfwd", "msgqfill"] +proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "subtmo", "conclimit", "fastfwd", "msgqfill", "pfwdbig"] + +-- proxy topologies use the test databases; create them for the run and drop them after +pgBracket :: IO a -> IO a +#if defined(dbServerPostgres) +pgBracket = postgressBracket testServerDBConnectInfo +#else +pgBracket = id +#endif -- Hold the servers up past one LEAKDIAG interval after the phase finishes, so the end state is -- always sampled at least once. Short phases would otherwise exit before any line is emitted, From 8be468d8adf3b341f6cc95c8baa50ed802446983 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:31:35 +0000 Subject: [PATCH 31/43] smp-server: remove delivered notification keys --- src/Simplex/Messaging/Server.hs | 3 +- src/Simplex/Messaging/Server/NtfStore.hs | 10 +++++ tests/CoreTests/MsgStoreTests.hs | 56 +++++++++++++++++++++++- 3 files changed, 67 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 82d492984..d048b6080 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -388,7 +388,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt runDeliverNtfs ms ns' stats where runDeliverNtfs :: s -> NtfStore -> ServerStats -> IO () - runDeliverNtfs ms (NtfStore ns) stats = do + runDeliverNtfs ms ns'@(NtfStore ns) stats = do ntfs <- M.assocs <$> readTVarIO ns unless (null ntfs) $ getQueueNtfServices @(StoreQueue s) (queueStore ms) ntfs >>= \case @@ -400,6 +400,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt cIds <- IS.toList <$> readTVarIO subClients forM_ cIds $ \cId -> getServerClient cId srv >>= mapM_ (deliverQueueNtfs ntfs') atomically $ modifyTVar' ns (`M.withoutKeys` S.fromList (map fst deleted)) + deleteEmptyNtfs ns' ntfs where deliverQueueNtfs ntfs' c@Client {ntfSubscriptions} = whenM (currentClient readTVarIO c) $ do diff --git a/src/Simplex/Messaging/Server/NtfStore.hs b/src/Simplex/Messaging/Server/NtfStore.hs index 711072303..d3f8ecf90 100644 --- a/src/Simplex/Messaging/Server/NtfStore.hs +++ b/src/Simplex/Messaging/Server/NtfStore.hs @@ -10,6 +10,7 @@ module Simplex.Messaging.Server.NtfStore storeNtf, deleteNtfs, deleteExpiredNtfs, + deleteEmptyNtfs, ) where import Control.Concurrent.STM @@ -22,6 +23,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (EncNMsgMeta, MsgId, NotifierId) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (whenM) newtype NtfStore = NtfStore (TMap NotifierId (TVar [MsgNtf])) @@ -57,6 +59,14 @@ deleteExpiredNtfs (NtfStore ns) old = else writeTVar v ntfs' >> pure (length ntfs - length ntfs') | otherwise -> pure 0 +deleteEmptyNtfs :: NtfStore -> [(NotifierId, TVar [MsgNtf])] -> IO () +deleteEmptyNtfs (NtfStore ns) = mapM_ deleteEmpty + where + deleteEmpty (nId, v) = + whenM (null <$> readTVarIO v) $ + atomically $ + TM.lookup nId ns >>= mapM_ (\v' -> whenM (null <$> readTVar v') $ TM.delete nId ns) + data NtfLogRecord = NLRv1 NotifierId MsgNtf instance StrEncoding MsgNtf where diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 48fc7810a..4297092d2 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -28,22 +28,25 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.List (isPrefixOf, isSuffixOf) +import qualified Data.Map.Strict as M import Data.Maybe (fromJust) import Data.Time.Clock (addUTCTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol (EntityId (..), ErrorType, LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags) +import Simplex.Messaging.Protocol (EntityId (..), ErrorType, LinkId, Message (..), NotifierId, QueueLinkData, RecipientId, SParty (..), noMsgFlags) import Simplex.Messaging.Server (exportMessages, importMessages, printMessageStats) import Simplex.Messaging.Server.Env.STM (MsgStore (..), journalMsgStoreDepth, readWriteQueueStore) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..), expireBeforeEpoch) import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types +import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue) +import qualified Simplex.Messaging.TMap as TM import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile) import System.FilePath (()) import System.IO (IOMode (..), withFile) @@ -83,6 +86,9 @@ msgStoreTests = do describe "Journal message store: queue state backup expiration" $ do it "should remove old queue state backups" testRemoveQueueStateBackups it "should expire messages in idle queues" testExpireIdleQueues + describe "Notification store" $ do + it "should remove keys of expired notifications" testExpireNtfs + it "should remove keys of delivered notifications" testDeleteEmptyNtfs where journalMsgStoreTests :: SpecWith (JournalMsgStore s) journalMsgStoreTests = do @@ -611,6 +617,54 @@ testExpireIdleQueues = do (Nothing, False) <- readQueueState ms statePath pure () +mkMsgNtf :: TVar ChaChaDRG -> Int64 -> IO MsgNtf +mkMsgNtf g ts = do + ntfMsgId <- atomically $ C.randomBytes 24 g + ntfNonce <- atomically $ C.randomCbNonce g + pure MsgNtf {ntfMsgId, ntfTs = MkSystemTime ts 0, ntfNonce, ntfEncMeta = "meta"} + +ntfCounts :: NtfStore -> IO [(NotifierId, Int)] +ntfCounts (NtfStore ns) = M.assocs <$> (mapM (fmap length . readTVarIO) =<< readTVarIO ns) + +testExpireNtfs :: IO () +testExpireNtfs = do + g <- C.newRandom + st@(NtfStore ns) <- NtfStore <$> TM.emptyIO + now <- systemSeconds <$> getSystemTime + let old = now - 100 + nId1 = EntityId "notifier 1" + nId2 = EntityId "notifier 2" + nId3 = EntityId "notifier 3" + storeNtf st nId1 =<< mkMsgNtf g old + storeNtf st nId2 =<< mkMsgNtf g old + storeNtf st nId2 =<< mkMsgNtf g now + atomically $ TM.insertM nId3 (newTVar []) ns + ntfCounts st `shouldReturn` [(nId1, 1), (nId2, 2), (nId3, 0)] + deleteExpiredNtfs st (now - 50) `shouldReturn` 2 + ntfCounts st `shouldReturn` [(nId2, 1)] + storeNtf st nId1 =<< mkMsgNtf g now + deleteExpiredNtfs st (now - 50) `shouldReturn` 0 + ntfCounts st `shouldReturn` [(nId1, 1), (nId2, 1)] + +testDeleteEmptyNtfs :: IO () +testDeleteEmptyNtfs = do + g <- C.newRandom + st@(NtfStore ns) <- NtfStore <$> TM.emptyIO + now <- systemSeconds <$> getSystemTime + let nId1 = EntityId "notifier 1" + nId2 = EntityId "notifier 2" + nId3 = EntityId "notifier 3" + nId4 = EntityId "notifier 4" + forM_ ([nId1, nId2, nId3, nId4] :: [NotifierId]) $ \nId -> storeNtf st nId =<< mkMsgNtf g now + ntfs <- M.assocs <$> readTVarIO ns + let flush nId = forM_ (lookup nId ntfs) $ \v -> atomically $ writeTVar v [] + mapM_ flush ([nId1, nId2, nId4] :: [NotifierId]) + storeNtf st nId2 =<< mkMsgNtf g now + deleteNtfs st nId4 `shouldReturn` 0 + storeNtf st nId4 =<< mkMsgNtf g now + deleteEmptyNtfs st ntfs + ntfCounts st `shouldReturn` [(nId2, 1), (nId3, 1), (nId4, 1)] + testReadFileMissing :: JournalMsgStore s -> IO () testReadFileMissing ms = do g <- C.newRandom From b307a37316531ae3b37edf34a0f47ffe58dce1db Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:30:58 +0000 Subject: [PATCH 32/43] smp-server: copy entity IDs out of received block --- src/Simplex/Messaging/Protocol.hs | 4 +++- tests/CoreTests/BatchingTests.hs | 26 +++++++++++++++++++++++++- 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 14f2a967f..95d2fc113 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -2411,7 +2411,9 @@ tDecodeServer THandleParams {sessionId, thVersion = v, implySessId} = \case where cmdOrErr = parseProtocol @v @err @cmd v command >>= checkCredentials tAuth entityId t :: a -> (CorrId, EntityId, a) - t = (corrId,entityId,) + -- IDs are slices of the ~16 KB received block and are kept as subscription keys, + -- so without a copy one live key retains the whole block + t = (CorrId $ B.copy $ bs corrId,EntityId $ B.copy $ unEntityId entityId,) Left _ -> tError corrId PEBlock | otherwise -> tError corrId PESession Left _ -> tError "" PEBlock diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 960c2113e..8657b1434 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -14,11 +14,13 @@ import Control.Monad import Crypto.Random (ChaChaDRG) import qualified Data.ByteString as B import Data.ByteString.Char8 (ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCString) import qualified Data.List.NonEmpty as L import Data.Time.Clock.System (SystemTime, getSystemTime) import qualified Data.X509 as X import qualified Data.X509.CertificateStore as XS import qualified Data.X509.File as XF +import Foreign.Ptr (plusPtr) import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding @@ -40,6 +42,8 @@ batchingTests = do it "should batch subscription responses with message" testBatchSubResponses it "should break on message that does not fit" testClientBatchWithMessage it "should break on large message" testClientBatchWithLargeMessage + describe "tDecodeServer" $ + it "should copy IDs out of received block" testDecodeServerCopiesIds testBatchSubscriptions :: IO () testBatchSubscriptions = do @@ -166,6 +170,26 @@ testClientBatchWithLargeMessage = do (length rs1', length rs2') `shouldBe` (75, 135) all lenOk [s1', s2'] `shouldBe` True +testDecodeServerCopiesIds :: IO () +testDecodeServerCopiesIds = do + sessId <- atomically . C.randomBytes 32 =<< C.newRandom + subs <- replicateM 2 $ randomSUB sessId + let thParams = testTHandleParams sessId + [TBTransmissions s 2 _] <- pure $ batchTransmissions thParams $ L.fromList subs + forM_ (tParse thParams s) $ \t -> do + let (corrId, entId, _) = tDecodeClient @SMPVersion @ErrorType @Cmd thParams t + Right (_, _, (corrId', entId', _)) <- pure $ tDecodeServer @SMPVersion @ErrorType @Cmd (testTHandleParams sessId) t + (corrId', entId') `shouldBe` (corrId, entId) + sharesBuffer s (bs corrId) `shouldReturn` True + sharesBuffer s (unEntityId entId) `shouldReturn` True + sharesBuffer s (bs corrId') `shouldReturn` False + sharesBuffer s (unEntityId entId') `shouldReturn` False + +sharesBuffer :: ByteString -> ByteString -> IO Bool +sharesBuffer block s = + unsafeUseAsCString block $ \blockPtr -> unsafeUseAsCString s $ \ptr -> + pure $ ptr >= blockPtr && ptr < blockPtr `plusPtr` B.length block + testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) testClientStub = do g <- C.newRandom @@ -237,7 +261,7 @@ randomSEND sessId len = do TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId sId, Cmd SSender $ SEND noMsgFlags msg) pure $ (,tToSend) <$> authTransmission thAuth_ False (Just spKey) nonce tForAuth -testTHandleParams :: ByteString -> THandleParams SMPVersion 'TClient +testTHandleParams :: ByteString -> THandleParams SMPVersion p testTHandleParams sessionId = THandleParams { sessionId, From c2dc2e550edd0f01b3b497b8398cca48590fff95 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:26:14 +0000 Subject: [PATCH 33/43] smp-server: hold command slot until completion --- src/Simplex/Messaging/Server.hs | 10 +++++++--- tests/RSLVTests.hs | 34 ++++++++++++++++++++++++++++++++- 2 files changed, 40 insertions(+), 4 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index d048b6080..d51cd826e 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1590,11 +1590,15 @@ client -- Run a slow command on a thread forkCmd :: (ServerConfig s -> Int) -> CorrId -> EntityId -> M s BrokerMsg -> M s (Maybe a) forkCmd concurrency corrId entId cmdAction = do - bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " cmd") $ - -- commands MUST be processed under a reasonable timeout or the client would halt - cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, entId, t)], []) + -- the forked thread releases the slot when the command completes, the caller only if the fork failed + mask $ \restore -> do + wait + forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " cmd") (restore cmd `finally` signal) + `onException` signal pure Nothing where + -- commands MUST be processed under a reasonable timeout or the client would halt + cmd = cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, entId, t)], []) wait = do limit <- asks (concurrency . config) atomically $ do diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index d62d99cde..3801b164e 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -18,6 +18,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.IORef (IORef, readIORef) import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (getCurrentTime) @@ -49,6 +50,7 @@ import Simplex.Messaging.Protocol tPut, ) import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.SimplexName (SimplexDomain) import Simplex.Messaging.Transport import Simplex.Messaging.Version (mkVersionRange) @@ -104,7 +106,8 @@ rslvTests = do it "RSLV sends the 2LD as its hash" testRslvSendsTheHash it "a name with subnames is sent as text" testSubnameKeepsItsLabels it "a record naming a different name is rejected" testRslvWrongName - describe "RSLV resource use" $ + describe "RSLV resource use" $ do + it "one connection has at most resolver_concurrency lookups in flight" testRslvConnectionCap xit "one connection must not fan out to many concurrent resolver requests" testRslvFanOut testRslvFanOut :: IO () @@ -294,5 +297,34 @@ testRslvWrongName = Left (PCEUnexpectedResponse _) -> pure () _ -> expectationFailure $ "expected Left (PCEUnexpectedResponse ..), got: " <> show r +-- The resolver answers after 3s and the server gives up after 1s, so a request +-- that reached the resolver stays in flight for the whole check. +testRslvConnectionCap :: IO () +testRslvConnectionCap = + NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs -> + withSmpServerConfigOn (transport @TLS) (updateCfg (withNames port memCfg) $ \c -> c {serverResolverConcurrency = connCap}) testPort $ const $ + testSMPClient @TLS $ \h -> do + sendRslvs h "cap" 16 + threadDelay 800000 + length <$> resolvePaths reqs `shouldReturn` connCap + recvResponses h 16 `shouldReturn` replicate 16 (Right (ERR (NAME (RESOLVER "timeout")))) + where + connCap = 4 + +-- | One RSLV per block, so no batch limit applies. +sendRslvs :: THandleSMP TLS 'TClient -> String -> Int -> IO () +sendRslvs h@THandle {params} prefix n = + forM_ [1 .. n] $ \i -> do + let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId (B.pack $ prefix <> show i), NoEntity, Cmd SResolver (RSLV (NQDomain (domain "alice.simplex")))) + [Right ()] <- tPut h (Right (Nothing, tToSend) :| []) + pure () + +recvResponses :: THandleSMP TLS 'TClient -> Int -> IO [Either ErrorType BrokerMsg] +recvResponses h n + | n <= 0 = pure [] + | otherwise = do + rs <- map (\(_, _, r) -> r) . L.toList <$> tGetClient h + (rs <>) <$> recvResponses h (n - length rs) + runExceptT' :: Show e => ExceptT e IO a -> IO a runExceptT' a = runExceptT a >>= either (fail . show) pure From 9f582e65f889d0bada72d01fb8cd1a2a83785490 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:30:36 +0000 Subject: [PATCH 34/43] smp-server: limit concurrent resolver requests --- src/Simplex/Messaging/Server.hs | 2 +- src/Simplex/Messaging/Server/Main.hs | 3 +- src/Simplex/Messaging/Server/Main/Init.hs | 2 ++ src/Simplex/Messaging/Server/Names.hs | 17 ++++++---- .../Messaging/Server/Names/HttpResolver.hs | 6 ++-- tests/NamesResolverServer.hs | 3 +- tests/RSLVTests.hs | 31 +++++++++---------- 7 files changed, 36 insertions(+), 28 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index d51cd826e..2c890e572 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1614,7 +1614,7 @@ client Nothing -> incStat (rslvDisabled st) $> Nothing Just nenv -> pure (Just nenv) -- Runs on a forked thread so RSLV does not block other commands; - -- concurrency is limited by serverResolverConcurrency in forkCmd. + -- concurrency is limited per connection by serverResolverConcurrency in forkCmd and globally in resolveName. resolveNameMsg :: VersionSMP -> NamesEnv -> NameQuery -> M s BrokerMsg resolveNameMsg v nenv q = do st <- asks (rslvStats . serverStats) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 138a25fc0..83bef9db0 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -814,7 +814,8 @@ readNamesConfig ini { resolverEndpoint = either (error . ("[NAMES] resolver_endpoint: " <>)) id (validateUrl endpoint resolverAuth_), resolverAuth = resolverAuth_, resolverTimeoutMs = boundedIniInt 3000 100 60000 "resolver_timeout_ms", - resolverMaxResponseBytes = boundedIniInt 16000 1024 16000 "resolver_max_response_bytes" + resolverMaxResponseBytes = boundedIniInt 16000 1024 16000 "resolver_max_response_bytes", + resolverGlobalConcurrency = boundedIniInt 32 1 1000 "resolver_global_concurrency" } where enabled = fromMaybe False (iniOnOff "NAMES" "enable" ini) diff --git a/src/Simplex/Messaging/Server/Main/Init.hs b/src/Simplex/Messaging/Server/Main/Init.hs index 89df1ad93..ac947f55c 100644 --- a/src/Simplex/Messaging/Server/Main/Init.hs +++ b/src/Simplex/Messaging/Server/Main/Init.hs @@ -167,6 +167,8 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = \# resolver_auth: basic :\n\ \# resolver_timeout_ms: 3000\n\ \# resolver_max_response_bytes: 16000\n\ + \# Max concurrent requests to the resolver from all connections.\n\ + \# resolver_global_concurrency: 32\n\ \# Max concurrent name resolutions per connection (forwarded RSLVs from many\n\ \# clients share one proxy connection, so this is much higher than PROXY client_concurrency).\n" <> ("# resolver_concurrency = " <> tshow defaultNameResolverConcurrency) diff --git a/src/Simplex/Messaging/Server/Names.hs b/src/Simplex/Messaging/Server/Names.hs index 601519c56..17e90c919 100644 --- a/src/Simplex/Messaging/Server/Names.hs +++ b/src/Simplex/Messaging/Server/Names.hs @@ -15,6 +15,7 @@ module Simplex.Messaging.Server.Names ) where +import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem) import qualified Control.Exception as E import Control.Logger.Simple (logError) import Data.Bifunctor (first) @@ -38,19 +39,22 @@ data NamesConfig = NamesConfig { resolverEndpoint :: String, resolverAuth :: Maybe RpcAuth, resolverTimeoutMs :: Int, - resolverMaxResponseBytes :: Int + resolverMaxResponseBytes :: Int, + resolverGlobalConcurrency :: Int } deriving (Show) data NamesEnv = NamesEnv { config :: NamesConfig, - resolverEnv :: ResolverEnv + resolverEnv :: ResolverEnv, + resolverSlots :: QSem } newNamesEnv :: NamesConfig -> IO NamesEnv newNamesEnv config = do - resolverEnv <- newResolverEnv (resolverEndpoint config) (resolverAuth config) (resolverTimeoutMs config) (resolverMaxResponseBytes config) - pure NamesEnv {config, resolverEnv} + resolverEnv <- newResolverEnv (resolverEndpoint config) (resolverAuth config) (resolverTimeoutMs config) (resolverMaxResponseBytes config) (resolverGlobalConcurrency config) + resolverSlots <- newQSem (resolverGlobalConcurrency config) + pure NamesEnv {config, resolverEnv, resolverSlots} closeNamesEnv :: NamesEnv -> IO () closeNamesEnv NamesEnv {resolverEnv} = closeResolverEnv resolverEnv @@ -60,8 +64,9 @@ pingEndpoint NamesEnv {resolverEnv, config} = fromMaybe (Left ResolverTimeout) <$> timeout (resolverTimeoutMs config * 1000) (healthHttp resolverEnv) resolveName :: NamesEnv -> NameQuery -> IO (Either NameErrorType NameResponse) -resolveName env q = do - r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env q)) +resolveName env@NamesEnv {resolverSlots} q = do + -- waiting for a slot counts towards the timeout, so lookups do not queue longer than resolverTimeoutMs + r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (E.bracket_ (waitQSem resolverSlots) (signalQSem resolverSlots) (fetch env q))) case r of Right result -> pure (fromMaybe (Left (RESOLVER "timeout")) result) Left e diff --git a/src/Simplex/Messaging/Server/Names/HttpResolver.hs b/src/Simplex/Messaging/Server/Names/HttpResolver.hs index 0f272bcf4..504348fe8 100644 --- a/src/Simplex/Messaging/Server/Names/HttpResolver.hs +++ b/src/Simplex/Messaging/Server/Names/HttpResolver.hs @@ -85,9 +85,9 @@ data ResolverError | ResolverTimeout deriving (Show) -newResolverEnv :: String -> Maybe RpcAuth -> Int -> Int -> IO ResolverEnv -newResolverEnv baseUrl auth_ timeoutMs maxResponseBytes = do - manager <- HC.newManager tlsManagerSettings {managerConnCount = 10} +newResolverEnv :: String -> Maybe RpcAuth -> Int -> Int -> Int -> IO ResolverEnv +newResolverEnv baseUrl auth_ timeoutMs maxResponseBytes maxConcurrency = do + manager <- HC.newManager tlsManagerSettings {managerConnCount = maxConcurrency} pure ResolverEnv { manager, diff --git a/tests/NamesResolverServer.hs b/tests/NamesResolverServer.hs index 054d55e40..59414dc6b 100644 --- a/tests/NamesResolverServer.hs +++ b/tests/NamesResolverServer.hs @@ -61,7 +61,8 @@ testNamesConfig port = { resolverEndpoint = "http://127.0.0.1:" <> show port, resolverAuth = Nothing, resolverTimeoutMs = 1000, - resolverMaxResponseBytes = 65536 + resolverMaxResponseBytes = 65536, + resolverGlobalConcurrency = 8 } memCfg :: AServerConfig diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 3801b164e..ded51a0a5 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -51,6 +51,7 @@ import Simplex.Messaging.Protocol ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) +import Simplex.Messaging.Server.Names (NamesConfig (..)) import Simplex.Messaging.SimplexName (SimplexDomain) import Simplex.Messaging.Transport import Simplex.Messaging.Version (mkVersionRange) @@ -108,22 +109,7 @@ rslvTests = do it "a record naming a different name is rejected" testRslvWrongName describe "RSLV resource use" $ do it "one connection has at most resolver_concurrency lookups in flight" testRslvConnectionCap - xit "one connection must not fan out to many concurrent resolver requests" testRslvFanOut - -testRslvFanOut :: IO () -testRslvFanOut = - NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs -> - withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort $ const $ - testSMPClient @TLS $ \(h@THandle {params} :: THandleSMP TLS 'TClient) -> do - let k = 64 :: Int - globalCap = 8 :: Int - forM_ [1 .. k] $ \i -> do - let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId (B.pack $ "fan" <> show i), NoEntity, Cmd SResolver (RSLV (NQDomain (domain "alice.simplex")))) - [Right ()] <- tPut h (Right (Nothing, tToSend) :| []) - pure () - threadDelay 800000 - inFlight <- length <$> resolvePaths reqs - inFlight `shouldSatisfy` (<= globalCap) + it "all connections have at most resolver_global_concurrency lookups in flight" testRslvFanOut -- | /v2/resolve answers 200, 400 or 502, so a 404 is a resolver that predates -- the route, not a name that does not exist. @@ -311,6 +297,19 @@ testRslvConnectionCap = where connCap = 4 +testRslvFanOut :: IO () +testRslvFanOut = + NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs -> + withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort $ const $ + testSMPClient @TLS $ \h1 -> testSMPClient @TLS $ \h2 -> do + sendRslvs h1 "a" 32 + sendRslvs h2 "b" 32 + threadDelay 800000 + length <$> resolvePaths reqs `shouldReturn` resolverGlobalConcurrency (NRS.testNamesConfig port) + let timedOut = replicate 32 (Right (ERR (NAME (RESOLVER "timeout")))) + recvResponses h1 32 `shouldReturn` timedOut + recvResponses h2 32 `shouldReturn` timedOut + -- | One RSLV per block, so no batch limit applies. sendRslvs :: THandleSMP TLS 'TClient -> String -> Int -> IO () sendRslvs h@THandle {params} prefix n = From cae0c4a4ada32c1cd6b0efb91b41a790b93cfcb3 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:31:30 +0000 Subject: [PATCH 35/43] smp-server: reuse resolver connection on errors --- src/Simplex/Messaging/Server/Names/HttpResolver.hs | 3 ++- tests/NamesResolverServer.hs | 14 ++++++++++++-- tests/SMPNamesTests.hs | 10 +++++++++- 3 files changed, 23 insertions(+), 4 deletions(-) diff --git a/src/Simplex/Messaging/Server/Names/HttpResolver.hs b/src/Simplex/Messaging/Server/Names/HttpResolver.hs index 504348fe8..caa49229a 100644 --- a/src/Simplex/Messaging/Server/Names/HttpResolver.hs +++ b/src/Simplex/Messaging/Server/Names/HttpResolver.hs @@ -136,8 +136,9 @@ httpGet ResolverEnv {manager, baseUrl, authHdr, timeoutMicro, maxResponseBytes} } result <- E.try $ withResponse req manager $ \res -> do let status = HT.statusCode (responseStatus res) + -- http-client closes the connection unless the body is read to the end if status >= 400 - then pure (Left (HttpStatusErr status)) + then Left (HttpStatusErr status) <$ brReadSome (responseBody res) (maxResponseBytes + 1) else do bs <- brReadSome (responseBody res) (maxResponseBytes + 1) pure $ if BL.length bs > fromIntegral maxResponseBytes then Left BodyTooLarge else Right bs diff --git a/tests/NamesResolverServer.hs b/tests/NamesResolverServer.hs index 59414dc6b..90ce6338f 100644 --- a/tests/NamesResolverServer.hs +++ b/tests/NamesResolverServer.hs @@ -9,6 +9,7 @@ module NamesResolverServer ( withResolverServer, withResolverServerDelayed, + withResolverServerConns, resolveResp, testNamesConfig, memCfg, @@ -36,9 +37,18 @@ withResolverServer :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Tex withResolverServer = withResolverServerDelayed 0 withResolverServerDelayed :: Int -> ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a -withResolverServerDelayed delayMs handler action = do +withResolverServerDelayed delayMs handler action = withResolverServer_ delayMs handler $ \port reqs _ -> action port reqs + +-- | Also counts the TCP connections the resolver accepted. +withResolverServerConns :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IORef Int -> IO a) -> IO a +withResolverServerConns = withResolverServer_ 0 + +withResolverServer_ :: Int -> ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IORef Int -> IO a) -> IO a +withResolverServer_ delayMs handler action = do reqs <- newIORef [] - Warp.withApplication (pure (app reqs)) $ \port -> action port reqs + conns <- newIORef 0 + let settings = Warp.setOnOpen (\_ -> True <$ atomicModifyIORef' conns (\n -> (n + 1, ()))) Warp.defaultSettings + Warp.withApplicationSettings settings (pure (app reqs)) $ \port -> action port reqs conns where app :: IORef [[Text]] -> Application app reqs req send = do diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs index 7f28a0b34..78ae09751 100644 --- a/tests/SMPNamesTests.hs +++ b/tests/SMPNamesTests.hs @@ -5,6 +5,7 @@ module SMPNamesTests (smpNamesTests, testNameRecord, testPricing, registeredBody, availableBody, reservedBody, responseBody, resolved) where +import Control.Monad (forM_) import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB @@ -15,7 +16,7 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Network.HTTP.Types (status200, status400, status404, status500, status502) -import NamesResolverServer (resolveResp, testNamesConfig, withResolverServer, withResolverServerDelayed) +import NamesResolverServer (resolveResp, testNamesConfig, withResolverServer, withResolverServerConns, withResolverServerDelayed) import Simplex.Messaging.Encoding (smpDecode, smpEncode) import Simplex.Messaging.Encoding.String (strDecode) import Simplex.Messaging.Protocol (Command (..), ErrorType (..), NameErrorType (..), NamePricing (..), NameQuery (..), NameRecord (..), NameRegistration (..), NameResponse (..), NameReservedReason (..), ProtocolEncoding (..), USDCents (..)) @@ -302,6 +303,13 @@ resolverSpec = do _ <- resolveName env aliceDomain readIORef reqs >>= \rs -> length rs `shouldBe` 2 + it "keeps the resolver connection alive across error responses" $ + withResolverServerConns (resolveResp status502 "{\"error\":\"upstream\"}") $ \port reqs conns -> do + env <- newNamesEnv (testNamesConfig port) + forM_ [1 .. 5 :: Int] $ \_ -> resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 502") + length <$> readIORef reqs `shouldReturn` 5 + readIORef conns `shouldReturn` 1 + it "addresses the resolver with the full canonical domain name" $ withResolverServer (resolveResp status200 (registeredBody testNameRecord)) $ \port reqs -> do env <- newNamesEnv (testNamesConfig port) From 6953018ed2d8cceb7c73954f89c08051b240be3a Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:30:17 +0000 Subject: [PATCH 36/43] tests: reproduce proxy request leak, stuck relay --- src/Simplex/Messaging/Client.hs | 2 +- tests/SMPProxyTests.hs | 16 ++++++++++++++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 7d74fd80e..856568552 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -151,6 +151,7 @@ import Data.Int (Int64) import Data.List (find, isSuffixOf) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L +import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -168,7 +169,6 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Protocol.Types import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.SimplexName (SimplexDomain, fullDomainName) -import qualified Data.Map.Strict as M import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index ac83f03e1..29ac4a0bd 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -21,6 +21,7 @@ import Control.Logger.Simple import Control.Monad (forM, forM_, forever, replicateM_) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Time.Clock (getCurrentTime) @@ -65,6 +66,8 @@ smpProxyTests = do testProxyReconnectAfterRelayRestart xit "must drop a stuck relay session after forward timeouts" $ \_ -> testProxyForwardTimeoutStuckSession + xit "does not keep oversized forwarded command" $ \_ -> + testForwardOversizedNotKept describe "agent client reconnection" $ do it "reconnects after a connect is cancelled mid-flight" $ \_ -> testAgentClientReconnectAfterCancel @@ -511,6 +514,19 @@ testProxyForwardTimeoutStuckSession = rs <- forM ([1 .. 10] :: [Int]) $ \_ -> runExceptT' (proxySMPMessage pc NRMInteractive sess Nothing sId noMsgFlags "hi") rs `shouldSatisfy` elem (Left (ProxyProtocolError (SMP.PROXY SMP.NO_SESSION))) +testForwardOversizedNotKept :: IO () +testForwardOversizedNotKept = + withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> do + g <- C.newRandom + ts <- getCurrentTime + let proxyClientCfg = defaultSMPClientConfig {serverVRange = supportedProxyClientSMPRelayVRange, agreeSecret = True, proxyServer = True} + c <- either (fail . show) pure =<< getProtocolClient g NRMBackground (1, testSMPServer, Nothing) proxyClientCfg [] Nothing ts (\_ -> pure ()) + (k, _) <- atomically $ C.generateKeyPair @'C.X25519 g + let et = SMP.EncTransmission $ B.replicate smpBlockSize 'a' + runExceptT (forwardSMPTransmission c (SMP.CorrId "123456789012345678901234") currentClientSMPRelayVersion k et) + `shouldReturn` Left (PCETransportError TELargeMsg) + pClientSentCommandsCount c `shouldReturn` 0 + -- Bug B (same root cause as the proxy, in the messaging agent): getSMPServerClient inserts an -- empty SessionVar into smpClients, then connects inside newProtocolClient's tryAllErrors, which -- rethrows async exceptions. If the connecting thread is cancelled mid-connect, putTMVar is From 31268fa83104003ced0bf4ff670ec4c1cd9c6552 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:30:42 +0000 Subject: [PATCH 37/43] smp: remove unsent and timed-out proxy requests --- src/Simplex/Messaging/Client.hs | 20 +++++++++++++------- tests/SMPProxyTests.hs | 2 +- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 856568552..9cc0d0335 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -152,7 +152,7 @@ import Data.List (find, isSuffixOf) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime) @@ -1360,20 +1360,22 @@ sendProtocolCommand c nm = sendProtocolCommand_ c nm Nothing Nothing -- -- Please note: if nonce is passed it is also used as a correlation ID sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg -sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {blockSize, serviceAuth}} nm nonce_ tOut pKey entId cmd = +sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ, sentCommands}, thParams = THandleParams {blockSize, serviceAuth}} nm nonce_ tOut pKey entId cmd = ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (entId, pKey, cmd) where -- two separate "atomically" needed to avoid blocking sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg) - sendRecv t_ r = case t_ of - Left e -> pure . Left $ PCETransportError e + sendRecv t_ r@Request {corrId} = case t_ of + Left e -> notSent e Right t - | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg + | B.length s > blockSize - 2 -> notSent TELargeMsg | otherwise -> do nonBlockingWriteTBQueue sndQ (Just r, s) response <$> getResponse c nm tOut r where s = tEncodeBatch1 serviceAuth t + where + notSent e = Left (PCETransportError e) <$ atomically (TM.delete corrId sentCommands) nonBlockingWriteTBQueue :: TBQueue a -> a -> IO () nonBlockingWriteTBQueue q x = do @@ -1381,7 +1383,7 @@ nonBlockingWriteTBQueue q x = do unless sent $ void $ forkIO $ atomically $ writeTBQueue q x getResponse :: ProtocolClient v err msg -> NetworkRequestMode -> Maybe Int -> Request err msg -> IO (Response err msg) -getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} nm tOut Request {entityId, pending, responseVar} = do +getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount, sentCommands, msgQ}} nm tOut Request {corrId, entityId, pending, responseVar} = do r <- fromMaybe (netTimeoutInt tcpTimeout nm) tOut `timeout` atomically (takeTMVar responseVar) response <- atomically $ do writeTVar pending False @@ -1390,7 +1392,11 @@ getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} n -- See `processMsg`. ((r <|>) <$> tryTakeTMVar responseVar) >>= \case Just r' -> writeTVar timeoutErrorCount 0 $> r' - Nothing -> modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout + Nothing -> do + modifyTVar' timeoutErrorCount (+ 1) + -- a late response is delivered to msgQ, without msgQ it is only logged + when (isNothing msgQ) $ TM.delete corrId sentCommands + pure $ Left PCEResponseTimeout pure Response {entityId, response} mkTransmission :: Protocol v err msg => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg) diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 29ac4a0bd..4ab300c60 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -66,7 +66,7 @@ smpProxyTests = do testProxyReconnectAfterRelayRestart xit "must drop a stuck relay session after forward timeouts" $ \_ -> testProxyForwardTimeoutStuckSession - xit "does not keep oversized forwarded command" $ \_ -> + it "does not keep oversized forwarded command" $ \_ -> testForwardOversizedNotKept describe "agent client reconnection" $ do it "reconnects after a connect is cancelled mid-flight" $ \_ -> From ba3ddee345238c385d1f0397ac5ac934c72c7ced Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:33:02 +0000 Subject: [PATCH 38/43] smp-server: drop relay session after timeouts --- src/Simplex/Messaging/Client.hs | 10 ++++++++-- src/Simplex/Messaging/Server.hs | 7 +++++-- tests/SMPProxyTests.hs | 2 +- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 9cc0d0335..b24f57099 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -35,6 +35,7 @@ module Simplex.Messaging.Client ProxiedRelay (..), getProtocolClient, closeProtocolClient, + closeTimedOutClient, pClientSentCommandsCount, protocolClientServer, protocolClientServer', @@ -660,10 +661,9 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS responseErr = atomically . putTMVar responseVar . Left . PCETransportError receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO () - receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do + receive ProtocolClient {client_ = PClient {rcvQ, lastReceived}} h = forever $ do tGetClient h >>= atomically . writeTBQueue rcvQ getCurrentTime >>= atomically . writeTVar lastReceived - atomically $ writeTVar timeoutErrorCount 0 monitor :: ProtocolClient v err msg -> IO () monitor c@ProtocolClient {client_ = PClient {sendPings, lastReceived, timeoutErrorCount}} = loop smpPingInterval @@ -756,6 +756,12 @@ closeProtocolClient :: ProtocolClient v err msg -> IO () closeProtocolClient = mapM_ (deRefWeak >=> mapM_ killThread) . action {-# INLINE closeProtocolClient #-} +-- | Disconnects client when maxCnt commands in a row timed out, 0 to disable. +closeTimedOutClient :: Int -> ProtocolClient v err msg -> IO () +closeTimedOutClient maxCnt c@ProtocolClient {client_ = PClient {timeoutErrorCount}} = do + cnt <- readTVarIO timeoutErrorCount + when (maxCnt > 0 && cnt >= maxCnt) $ closeProtocolClient c + -- | SMP client error type. data ProtocolClientError err = -- | Correctly parsed SMP server ERR response. diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 2c890e572..aac520b6f 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -98,8 +98,8 @@ import Network.Socket (ServiceName, Socket, socketToHandle) import qualified Network.TLS as TLS import Numeric.Natural (Natural) import Simplex.Messaging.Agent.Lock -import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, smpProxyError, temporaryClientError, transportHost') -import Simplex.Messaging.Client.Agent (AgentLeakStats (..), OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getAgentLeakStats, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient) +import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClient (thParams), ProtocolClientConfig (..), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, closeTimedOutClient, forwardSMPTransmission, smpProxyError, temporaryClientError, transportHost') +import Simplex.Messaging.Client.Agent (AgentLeakStats (..), OwnServer, SMPClientAgent (..), SMPClientAgentConfig (..), SMPClientAgentEvent (..), closeSMPClientAgent, getAgentLeakStats, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -1583,6 +1583,9 @@ client _ -> do logWarn $ "Error forwarding to relay: " <> decodeLatin1 (strEncode $ transportHost' smp) <> " own=" <> tshow own <> " " <> tshow e inc own pErrorsOther + case e of + PCEResponseTimeout -> liftIO $ closeTimedOutClient (smpPingCount $ networkConfig $ smpCfg $ agentCfg a) smp + _ -> pure () Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION) where forkProxiedCmd :: M s BrokerMsg -> M s (Maybe BrokerMsg) diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 4ab300c60..a332a1a54 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -64,7 +64,7 @@ smpProxyTests = do testProxyRecoversWithoutDisconnect it "reconnects to relay after sender disconnects mid-connection" $ \_ -> testProxyReconnectAfterRelayRestart - xit "must drop a stuck relay session after forward timeouts" $ \_ -> + it "must drop a stuck relay session after forward timeouts" $ \_ -> testProxyForwardTimeoutStuckSession it "does not keep oversized forwarded command" $ \_ -> testForwardOversizedNotKept From e57af2f83b99a6bb91a39334138052e4a324c43a Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 13:08:04 +0000 Subject: [PATCH 39/43] bench: isolate concurrent runs with BENCHID --- bench/MemBench.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 57ec362bd..7be41611c 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -83,6 +83,7 @@ import Data.Word (Word64) import Simplex.Messaging.Encoding.String (strEncode) import Simplex.Messaging.Server.NtfStore (MsgNtf (..), NtfLogRecord (..)) import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) +import System.IO.Unsafe (unsafePerformIO) import System.Environment (getExecutablePath) import System.IO (Handle, stdout) import System.Process (CreateProcess (..), StdStream (..), callProcess, createProcess, proc, waitForProcess) @@ -347,11 +348,17 @@ runNtfLoop n = postgressBracket benchDBConnectInfo $ do -- Its own database, user and port, so a bench run cannot collide with a concurrent test-suite run, -- which binds testPort and drops and recreates test_server_db and test_server_user. +-- BENCHID (default 0) offsets the ports and names the database, so concurrent runs do not collide; +-- child processes inherit it. +benchId :: Int +benchId = unsafePerformIO $ fromMaybe 0 . (>>= readMaybe) <$> lookupEnv "BENCHID" +{-# NOINLINE benchId #-} + benchDBConnectInfo :: ConnectInfo -benchDBConnectInfo = testServerDBConnectInfo {connectUser = "mem_bench_user", connectDatabase = "mem_bench_db"} +benchDBConnectInfo = testServerDBConnectInfo {connectUser = "mem_bench_user" <> show benchId, connectDatabase = "mem_bench_db" <> show benchId} benchPort :: ServiceName -benchPort = "15001" +benchPort = show $ 15001 + 100 * benchId benchPgCfg :: AServerConfig benchPgCfg = case cfgMS (ASType SQSPostgres SMSPostgres) of @@ -428,7 +435,7 @@ runCpSave g = benchClient $ \h -> do putStrLn $ "cpsave: NEW after save: " <> maybe "no response in 10s (DB access blocked)" (const "responded") res benchCpPort :: ServiceName -benchCpPort = "15010" +benchCpPort = show $ 15010 + 100 * benchId -- The IDs are a tag byte followed by i in 23 big-endian bytes, the same bytes the SQL builds with -- lpad(to_hex(i), 46, '0'), so file entries and rows match without passing IDs between them. From 37ee78f8c36af280ad7910cfa0aabad2f6de4d2e Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 13:16:38 +0000 Subject: [PATCH 40/43] bench: add production-shaped memory phase --- bench/MemBench.hs | 139 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 138 insertions(+), 1 deletion(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 7be41611c..69e2ca2ce 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -23,7 +23,7 @@ -- -- Single-server phases (server on testPort): -- plain | svc | svcrace | ntf | conc | svcsubs | getp | stuck | certchurn | link | ntfexp --- ntfloop | ntfdeliver | subslice | conns | load | cpsave -- PostgreSQL build only +-- ntfloop | ntfdeliver | subslice | conns | load | prodmix | cpsave -- PostgreSQL build only -- tlsstall | tlshalf | tlschurn | tlspartial -- TLS/TCP stack -- -- Two-server phases (proxy on testPort, lagged destination relay on testPort2): @@ -48,6 +48,7 @@ import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty (..), fromList) +import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import Data.Time.Clock (diffUTCTime, getCurrentTime) import qualified Data.X509.Validation as XV @@ -685,6 +686,140 @@ runLoadClient g = do n <- readTVarIO ops putStrLn $ "DONE " <> show n <> " " <> show (realToFrac (diffUTCTime end start) :: Double) +-- Production-shaped server memory: C connections (PROD_CONNS, default 1000) each subscribing +-- Q queues (PROD_QUEUES, default 20) in batches of up to 100 per block, as the agent resubscribes, +-- plus PROD_NEW subscriptions per connection created with NEW; then PROD_SEC seconds (default 60) +-- of traffic where PROD_SENDERS connections (default 16) send to random queues and every recipient +-- acknowledges its messages. The client runs in a child process (phase prodclient); this process +-- reports the server's live heap, memory in use and RSS when idle and at peak under traffic. +runProdMix :: IO () +runProdMix = do + base <- liveBytesMiB + rssBase <- rssMiB + exe <- getExecutablePath + (Just hIn, Just hOut, _, ph) <- createProcess (proc exe ["prodclient", "0"]) {std_in = CreatePipe, std_out = CreatePipe} + hSetBuffering hIn LineBuffering + (conns, subs) <- awaitLine hOut "READY" >>= \case + [c, n] -> pure (read c, read n) :: IO (Int, Int) + _ -> fail "bad READY line" + idle <- liveBytesMiB + idleStats <- getRTSStats + idleRss <- rssMiB + printf "prodmix: IDLE connections=%d subscriptions=%d live=%.1f MiB (%.2f KiB/conn) mem_in_use=%.1f MiB rss=%.1f MiB (base live=%.1f rss=%.1f)\n" + conns subs (idle - base) ((idle - base) * 1024 / fromIntegral conns) (mib $ gcdetails_mem_in_use_bytes $ gc idleStats) idleRss base rssBase + hPutStrLn hIn "GO" + peak <- newTVarIO (0 :: Double, 0 :: Double, 0 :: Double) + done <- newEmptyTMVarIO + let sampler = do + threadDelay 2000000 + st <- getRTSStats + r <- rssMiB + atomically $ modifyTVar' peak $ \(m, l, rs) -> (max m (mib $ gcdetails_mem_in_use_bytes $ gc st), max l (mib $ gcdetails_live_bytes $ gc st), max rs r) + atomically (isEmptyTMVar done) >>= (`when` sampler) + msgs <- withAsync sampler $ \_ -> do + [n] <- awaitLine hOut "DONE" + atomically $ putTMVar done () + pure (read n :: Int) + (pkMem, pkLive, pkRss) <- readTVarIO peak + end <- getRTSStats + after <- liveBytesMiB + printf "prodmix: TRAFFIC messages=%d peak_mem_in_use=%.1f MiB peak_live_after_gc=%.1f MiB peak_rss=%.1f MiB live_after=%.1f MiB major_gcs=%d gc_cpu=%.1fs mutator_cpu=%.1fs\n" + msgs pkMem pkLive pkRss (after - base) (major_gcs end - major_gcs idleStats) + (fromIntegral (gc_cpu_ns end - gc_cpu_ns idleStats) / 1e9 :: Double) (fromIntegral (mutator_cpu_ns end - mutator_cpu_ns idleStats) / 1e9 :: Double) + hClose hIn + void $ waitForProcess ph + where + mib :: Word64 -> Double + mib b = fromIntegral b / (1024 * 1024) + awaitLine :: Handle -> String -> IO [String] + awaitLine h tag = hGetLine h >>= \l -> case words l of + (t : rest) | t == tag -> pure rest + _ -> awaitLine h tag + +-- resident set size of this process, from /proc +rssMiB :: IO Double +rssMiB = do + ls <- lines <$> readFile "/proc/self/status" + pure $ case [w | l <- ls, ("VmRSS:" : w : _) <- [words l]] of + (kb : _) -> read kb / 1024 + _ -> 0 + +runProdClient :: TVar ChaChaDRG -> IO () +runProdClient g = do + hSetBuffering stdout LineBuffering + let env k d = fromMaybe d . (>>= readMaybe) <$> lookupEnv k + conns <- env "PROD_CONNS" 1000 + nq <- env "PROD_QUEUES" 20 + newPer <- env "PROD_NEW" 2 + secs <- env "PROD_SEC" 60 + senders <- env "PROD_SENDERS" 16 + let creators = 8 :: Int + total = conns * nq + -- queues are created on a few connections first, as if by earlier sessions + created <- forConcurrently ([0 .. creators - 1] :: [Int]) $ \w -> benchClient $ \h -> + forM [i | i <- [0 .. total - 1], i `mod` creators == w] $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + Resp _ _ (Ids rId sId _) <- signSendRecv h rKey (B.pack $ "c" <> show i, NoEntity, New0 rPub dhPub) + pure (rId, sId, rKey) + let qs = concat created + perConn = chunksOf nq qs + subscribed <- newTVarIO (0 :: Int) + go <- newEmptyTMVarIO + stop <- newEmptyTMVarIO + sIdsVar <- newTVarIO ([] :: [SenderId]) + received <- newTVarIO (0 :: Int) + let recipient cqs = benchClient $ \h -> do + forM_ (chunksOf 100 cqs) $ \b -> do + let sub (rId, _, rKey) = Right $ signTransmission h rKey Nothing (B.pack "s", rId, SUB) + void $ tPut h (fromList $ map sub b) + awaitResponses h (length b) + newQs <- forM ([1 .. newPer] :: [Int]) $ \i -> do + (rPub, rKey, dhPub) <- genKeys g + Resp _ _ (Ids rId sId _) <- signSendRecv h rKey (B.pack $ "n" <> show i, NoEntity, New rPub dhPub) + pure (rId, sId, rKey) + let keys = M.fromList [(rId, rKey) | (rId, _, rKey) <- cqs ++ newQs] + atomically $ do + modifyTVar' sIdsVar ([sId | (_, sId, _) <- cqs ++ newQs] ++) + modifyTVar' subscribed (+ (length cqs + length newQs)) + -- acknowledge every delivered message until the run is released + withAsync (forever $ tGetClient h >>= mapM_ (ack h keys)) $ \_ -> atomically $ readTMVar stop + ack h keys = \case + (_, rId, Right (MSG RcvMessage {msgId})) | Just rKey <- M.lookup rId keys -> do + let t = signTransmission h rKey Nothing (B.pack "a", rId, ACK msgId) + void $ tPut h [Right t] + atomically $ modifyTVar' received (+ 1) + _ -> pure () + sender w = benchClient $ \h -> do + atomically $ readTMVar go + sIds <- readTVarIO sIdsVar + let n = length sIds + loop i t0 = do + t <- getCurrentTime + when (diffUTCTime t t0 < fromIntegral (secs :: Int)) $ do + let sId = sIds !! ((i * 7919 + w * 104729) `mod` n) + void $ sendRecv h (Nothing, B.pack (show i), sId, _SEND "hello") + loop (i + 1) t0 + getCurrentTime >>= loop 0 + withAsync (forConcurrently_ perConn recipient) $ \rs -> do + atomically $ readTVar subscribed >>= \n -> when (n < total + conns * newPer) retry + putStrLn $ "READY " <> show conns <> " " <> show (total + conns * newPer) + "GO" <- getLine + atomically $ putTMVar go () + forConcurrently_ ([1 .. senders] :: [Int]) sender + n <- readTVarIO received + putStrLn $ "DONE " <> show n + void (E.try getLine :: IO (Either E.IOException String)) + atomically $ putTMVar stop () + wait rs + where + chunksOf k xs = case splitAt k xs of + (c, []) -> [c | not (null c)] + (c, rest) -> c : chunksOf k rest + awaitResponses :: H -> Int -> IO () + awaitResponses h n = when (n > 0) $ do + rs :: NonEmpty (Transmission (Either ErrorType BrokerMsg)) <- tGetClient h + awaitResponses h (n - length rs) + -- Client side of subslice: creates the subscriptions, prints "READY ", and holds the -- connection until stdin is closed. runSubClient :: TVar ChaChaDRG -> Int -> IO () @@ -1411,6 +1546,8 @@ main = do else if phase == "connclient" then runConnClient iters else if phase == "load" then postgressBracket benchDBConnectInfo $ withSmpServerConfigOn (transport @TLS) benchPgCfg benchPort $ \_ -> runLoad else if phase == "loadclient" then runLoadClient g + else if phase == "prodmix" then postgressBracket benchDBConnectInfo $ withSmpServerConfigOn (transport @TLS) benchPgCfg benchPort $ \_ -> runProdMix + else if phase == "prodclient" then runProdClient g #endif else withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> settle leakDiagSec $ do threadDelay 250000 From 84d91bd445ea6567e47ad982442d5fef169d9f95 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 13:45:07 +0000 Subject: [PATCH 41/43] bench: measure proxy mesh servers separately --- bench/MemBench.hs | 311 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 306 insertions(+), 5 deletions(-) diff --git a/bench/MemBench.hs b/bench/MemBench.hs index 69e2ca2ce..85c672976 100644 --- a/bench/MemBench.hs +++ b/bench/MemBench.hs @@ -36,7 +36,7 @@ module Main (main) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_, forConcurrently, forConcurrently_, mapConcurrently_, wait, withAsync) +import Control.Concurrent.Async (async, concurrently_, forConcurrently, forConcurrently_, mapConcurrently_, wait, withAsync) import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) import qualified Control.Exception as E import Control.Concurrent.STM @@ -49,6 +49,9 @@ import Data.Int (Int64) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty (..), fromList) import qualified Data.Map.Strict as M +import qualified Data.List.NonEmpty as L +import Data.Functor ((<&>)) +import GHC.Conc (listThreads) import Data.Maybe (fromMaybe) import Data.Time.Clock (diffUTCTime, getCurrentTime) import qualified Data.X509.Validation as XV @@ -60,12 +63,12 @@ import SMPClient import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol -import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (msgQSize)) -import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration, ntfDeliveryInterval, serverClientConcurrency, smpAgentCfg, storeNtfsFile)) +import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (msgQSize, persistErrorInterval)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (controlPort, controlPortAdminAuth, maxJournalMsgCount, msgQueueQuota, notificationExpiration, ntfDeliveryInterval, serverClientConcurrency, smpAgentCfg, storeNtfsFile, tbqSize)) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport -import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTransportClient) +import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Version (mkVersionRange) import System.Environment (getArgs, lookupEnv, setEnv) @@ -1548,6 +1551,8 @@ main = do else if phase == "loadclient" then runLoadClient g else if phase == "prodmix" then postgressBracket benchDBConnectInfo $ withSmpServerConfigOn (transport @TLS) benchPgCfg benchPort $ \_ -> runProdMix else if phase == "prodclient" then runProdClient g + else if phase == "srvchild" then runSrvChild (args !! 1) + else if phase == "mesh" then postgressBracket benchDBConnectInfo $ runMesh g iters #endif else withSmpServerConfigOn (transport @TLS) srvCfg testPort $ \_ -> settle leakDiagSec $ do threadDelay 250000 @@ -1632,8 +1637,304 @@ runPfwdBig g iters cp = do withCheckpoints "pfwdbig" iters cp $ \_ -> void $ runExceptT $ sendProtocolCommand pc NRMInteractive Nothing (EntityId prSessionId) pfwd +#if defined(dbServerPostgres) +-- Proxy mesh with each server in its own process, so the live bytes of the proxy and of the relay +-- are measured separately and without the bench clients. Both use the pure PostgreSQL store and the +-- production queue sizes (tbqSize 128, client_concurrency 32 unless MESH_CONC is set, quota 128). +-- Ports and database follow BENCHID, so runs do not need the test lock. +-- +-- MESH selects the scenario, `iters` its size: +-- sessions PRXY to `iters` aliases of the relay (same host and port, distinct second host), so the +-- proxy opens `iters` relay sessions and the relay holds `iters` proxy connections +-- inflight MESH_CONNS client connections each with MESH_K concurrent PFWDs; the relay stops +-- answering (MESH_RELAY=drop, default) or stops reading (MESH_RELAY=stall) +-- rate MESH_CONNS connections sending `iters` PFWD/s in total for MESH_SEC seconds with +-- MESH_LAG_MS one-way relay lag +-- throughput MESH_CONNS connections x MESH_K concurrent PFWDs back to back for MESH_SEC seconds, then +-- the same concurrency sending SEND directly to the relay +-- slowreader `iters` raw connections sending PFWD without ever reading a response +runMesh :: TVar ChaChaDRG -> Int -> IO () +runMesh g n = do + hSetBuffering stdout LineBuffering + scen <- fromMaybe "inflight" <$> lookupEnv "MESH" + withSrvChild "relay" $ \relay -> withSrvChild "proxy" $ \proxy -> do + let measureBoth tag = do + p <- childMeasure proxy + r <- childMeasure relay + printf "mesh %s: proxy %s | relay %s\n" (tag :: String) (showM p) (showM r) + pure (p, r) + case scen of + "sessions" -> meshSessions g n measureBoth + "inflight" -> meshInflight g relay measureBoth + "rate" -> meshRate g n relay measureBoth + "throughput" -> meshThroughput g measureBoth + "slowreader" -> meshSlowReader g n measureBoth + _ -> error $ "unknown MESH scenario: " <> scen + +data ChildMem = ChildMem {cmLive :: Double, cmFrag :: Double, cmInUse :: Double, cmThreads :: Int} + +showM :: ChildMem -> String +showM ChildMem {cmLive, cmFrag, cmInUse, cmThreads} = printf "live=%.1f frag=%.1f in_use=%.1f threads=%d" cmLive cmFrag cmInUse cmThreads + +deltaPer :: String -> Int -> (ChildMem, ChildMem) -> (ChildMem, ChildMem) -> IO () +deltaPer unit k (p0, r0) (p1, r1) = + printf "mesh SUMMARY per %s (n=%d): proxy %+.2f KiB live, %+.2f KiB in_use, %+.2f threads | relay %+.2f KiB live, %+.2f KiB in_use, %+.2f threads\n" + unit k (per cmLive p0 p1) (per cmInUse p0 p1) (perT p0 p1) (per cmLive r0 r1) (per cmInUse r0 r1) (perT r0 r1) + where + per f a b = (f b - f a) * 1024 / fromIntegral (max 1 k) + perT a b = fromIntegral (cmThreads b - cmThreads a) / fromIntegral (max 1 k) :: Double + +data SrvChild = SrvChild {chIn :: Handle, chOut :: Handle} + +withSrvChild :: String -> (SrvChild -> IO a) -> IO a +withSrvChild role action = do + exe <- getExecutablePath + rts <- maybe ["+RTS", "-N", "-F1.2", "-A16m", "-I0.01", "-Iw15", "-T", "-RTS"] words <$> lookupEnv ("MESH_RTS_" <> role) + (Just hIn, Just hOut, _, ph) <- createProcess (proc exe (["srvchild", role] <> rts)) {std_in = CreatePipe, std_out = CreatePipe} + hSetBuffering hIn LineBuffering + let c = SrvChild hIn hOut + (childReply c >> action c) `E.finally` (hClose hIn >> waitForProcess ph) + +childReply :: SrvChild -> IO [String] +childReply c@SrvChild {chOut} = hGetLine chOut >>= \l -> case words l of + "R" : ws -> pure ws + _ -> childReply c + +childCmd :: SrvChild -> String -> IO [String] +childCmd c@SrvChild {chIn} cmd = hPutStrLn chIn cmd >> childReply c + +childMeasure :: SrvChild -> IO ChildMem +childMeasure c = childCmd c "m" >>= \case + [l, f, u, t] -> pure $ ChildMem (read l) (read f) (read u) (read t) + r -> fail $ "bad child reply: " <> unwords r + +-- a server of the mesh; replies to each stdin command with one line starting with "R" +runSrvChild :: String -> IO () +runSrvChild role = do + hSetBuffering stdout LineBuffering + case role of + "proxy" -> withSmpServerConfigOn (transport @TLS) meshProxyCfg benchPort $ \_ -> serve + "relay" -> withSmpServerConfigOn (transport @LagTLS) meshRelayCfg meshRelayPort $ \_ -> serve + _ -> error $ "unknown server role: " <> role + where + serve = putStrLn "R ready" >> loop + loop = (E.try getLine :: IO (Either E.IOException String)) >>= either (const $ pure ()) (\l -> cmd (words l) >> loop) + cmd = \case + ["m"] -> do + live <- liveBytesMiB + frag <- fragmentationMiB + inUse <- (/ (1024 * 1024)) . fromIntegral . gcdetails_mem_in_use_bytes . gc <$> getRTSStats + ts <- length <$> listThreads + printf "R %.3f %.3f %.3f %d\n" live frag (inUse :: Double) ts + ["lag", r, s] -> setLag (read r * 1000) (read s * 1000) >> putStrLn "R ok" + ["drop", b] -> setDropSnd (b == "1") >> putStrLn "R ok" + ["clear"] -> clearLag >> putStrLn "R ok" + c -> putStrLn $ "R unknown " <> unwords c + +meshSrvCfg :: Int -> ServerConfig s -> ServerConfig s +meshSrvCfg conc c = c {tbqSize = 128, msgQueueQuota = 128, serverClientConcurrency = conc} + +meshConc :: Int +meshConc = unsafePerformIO $ fromMaybe 32 . (>>= readMaybe) <$> lookupEnv "MESH_CONC" +{-# NOINLINE meshConc #-} + +meshProxyCfg :: AServerConfig +meshProxyCfg = updateCfg (meshPgCfg "smp_server" $ proxyCfgMS (ASType SQSPostgres SMSPostgres)) $ \c -> + c {smpAgentCfg = (smpAgentCfg c) {persistErrorInterval = 30}} + +meshRelayCfg :: AServerConfig +meshRelayCfg = meshPgCfg "smp_server2" $ cfgMS (ASType SQSPostgres SMSPostgres) + +meshPgCfg :: String -> AServerConfig -> AServerConfig +meshPgCfg sch = \case + ASrvCfg SQSPostgres SMSPostgres c -> ASrvCfg SQSPostgres SMSPostgres (meshSrvCfg meshConc c) {serverStoreCfg = SSCDatabase (meshStoreCfg sch)} + c -> c + +-- the BENCHID database, one schema per server +meshStoreCfg :: String -> PostgresStoreCfg +meshStoreCfg sch = PostgresStoreCfg {dbOpts = testStoreDBOpts {connstr, schema = B.pack sch}, dbStoreLogPath = Nothing, confirmMigrations = MCYesUp, deletedTTL = 86400} + where + connstr = B.pack $ "postgresql://" <> connectUser benchDBConnectInfo <> "@/" <> connectDatabase benchDBConnectInfo + +meshRelayPort :: ServiceName +meshRelayPort = show $ 15002 + 100 * benchId + +meshProxySrv :: SMPServer +meshProxySrv = SMPServer testHost benchPort testKeyHash + +meshRelaySrv :: SMPServer +meshRelaySrv = SMPServer testHost2 meshRelayPort testKeyHash + +envInt :: String -> Int -> IO Int +envInt name def = fromMaybe def . (>>= readMaybe) <$> lookupEnv name + +-- sender IDs of fresh unsubscribed queues on the relay, created directly +relayQueues :: TVar ChaChaDRG -> Int -> IO [SenderId] +relayQueues g k = do + ts <- getCurrentTime + rc <- getProtocolClient g NRMInteractive (98, meshRelaySrv, Nothing) benchClientCfg [] Nothing ts (\_ -> pure ()) >>= either (fail . show) pure + qs <- forM ([1 .. k] :: [Int]) $ \_ -> do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + QIK {sndId} <- runExceptT' $ createSMPQueue rc NRMInteractive Nothing (rPub, rKey) dhPub Nothing SMOnlyCreate (QRMessaging Nothing) Nothing + pure sndId + closeProtocolClient rc + pure qs + +meshProxyClient :: TVar ChaChaDRG -> Int64 -> IO SMPClient +meshProxyClient g n = do + ts <- getCurrentTime + getProtocolClient g NRMInteractive (n, meshProxySrv, Nothing) benchClientCfg [] Nothing ts (\_ -> pure ()) >>= either (fail . show) pure + +-- client connections to the proxy, each with its own PRXY session reference +proxyClients :: TVar ChaChaDRG -> Int -> IO [(SMPClient, ProxiedRelay)] +proxyClients g k = forM ([1 .. k] :: [Int]) $ \i -> do + pc <- meshProxyClient g (fromIntegral i) + sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive meshRelaySrv Nothing + pure (pc, sess) + +forwardOnce :: SMPClient -> ProxiedRelay -> SenderId -> IO Bool +forwardOnce pc sess sId = + runExceptT (proxySMPMessage pc NRMInteractive sess Nothing sId noMsgFlags "hello") <&> \case + Right (Right ()) -> True + Left (PCEProtocolError QUOTA) -> True + _ -> False + +meshSessions :: TVar ChaChaDRG -> Int -> (String -> IO (ChildMem, ChildMem)) -> IO () +meshSessions g n measureBoth = do + pc <- meshProxyClient g 1 + base <- measureBoth "before" + forM_ ([1 .. n] :: [Int]) $ \i -> runExceptT (connectSMPProxiedRelay pc NRMInteractive (alias i) Nothing) >>= \case + Right _ -> pure () + Left e -> fail $ "PRXY " <> show i <> ": " <> show e + cur <- measureBoth (show n <> " relay sessions") + deltaPer "relay session" n base cur + where + alias i = SMPServer (L.head testHost2 :| [THDomainName $ "alias" <> show i <> ".invalid"]) meshRelayPort testKeyHash + +meshInflight :: TVar ChaChaDRG -> SrvChild -> (String -> IO (ChildMem, ChildMem)) -> IO () +meshInflight g relay measureBoth = do + conns <- envInt "MESH_CONNS" 16 + k <- envInt "MESH_K" 32 + mode <- fromMaybe "drop" <$> lookupEnv "MESH_RELAY" + sIds <- relayQueues g 1 + pcs <- proxyClients g conns + forM_ pcs $ \(pc, sess) -> forwardOnce pc sess (head sIds) + base <- measureBoth "before" + void $ childCmd relay $ if mode == "stall" then "lag 60000 0" else "drop 1" + as <- forM pcs $ \(pc, sess) -> forM ([1 .. k] :: [Int]) $ \_ -> async $ forwardOnce pc sess (head sIds) + threadDelay 8000000 + cur <- measureBoth $ printf "%d x %d forwards in flight, relay %s" conns k mode + deltaPer "in-flight forward" (conns * min k meshConc) base cur + mapM_ (mapM_ wait) as + void $ childCmd relay "clear" + threadDelay 45000000 + void $ measureBoth "45s after the clients timed out" + +meshRate :: TVar ChaChaDRG -> Int -> SrvChild -> (String -> IO (ChildMem, ChildMem)) -> IO () +meshRate g rate relay measureBoth = do + conns <- envInt "MESH_CONNS" 64 + secs <- envInt "MESH_SEC" 30 + lagMs <- envInt "MESH_LAG_MS" 100 + sIds <- relayQueues g 256 + pcs <- proxyClients g conns + forM_ pcs $ \(pc, sess) -> forwardOnce pc sess (head sIds) + base <- measureBoth "before" + void $ childCmd relay $ "lag " <> show lagMs <> " " <> show lagMs + ok <- newTVarIO (0 :: Int) + failed <- newTVarIO (0 :: Int) + let perConn = fromIntegral rate / fromIntegral conns :: Double + intervalUs = round (1000000 / perConn) :: Int + sender i (pc, sess) = forM_ ([1 .. round (perConn * fromIntegral secs)] :: [Int]) $ \j -> do + void $ async $ forwardOnce pc sess (sIds !! ((i * 7 + j) `mod` length sIds)) >>= \r -> atomically $ modifyTVar' (if r then ok else failed) (+ 1) + threadDelay intervalUs + sampler = forever $ do + threadDelay 5000000 + (o, f) <- (,) <$> readTVarIO ok <*> readTVarIO failed + void $ measureBoth $ printf "rate=%d/s lag=%dms ok=%d failed=%d" rate lagMs o f + cur <- withAsync sampler $ \_ -> do + mapConcurrently_ (uncurry sender) (zip [0 ..] pcs) + measureBoth "end of sending" + deltaPer "forward/s" rate base cur + void $ childCmd relay "clear" + threadDelay 35000000 + (o, f) <- (,) <$> readTVarIO ok <*> readTVarIO failed + printf "mesh rate: ok=%d failed=%d\n" o f + +meshThroughput :: TVar ChaChaDRG -> (String -> IO (ChildMem, ChildMem)) -> IO () +meshThroughput g measureBoth = do + conns <- envInt "MESH_CONNS" 16 + k <- envInt "MESH_K" 32 + secs <- envInt "MESH_SEC" 20 + sIds <- relayQueues g 1024 + pcs <- proxyClients g conns + forM_ pcs $ \(pc, sess) -> forwardOnce pc sess (head sIds) + void $ measureBoth "before" + let run label go = do + cnt <- newTVarIO (0 :: Int) + t0 <- getCurrentTime + let worker w = loop (0 :: Int) + where + loop j = do + t <- getCurrentTime + when (diffUTCTime t t0 < fromIntegral secs) $ do + r <- go w (sIds !! ((w * 31 + j) `mod` length sIds)) + when r $ atomically $ modifyTVar' cnt (+ 1) + loop (j + 1) + forConcurrently_ ([0 .. conns * k - 1] :: [Int]) worker + c <- readTVarIO cnt + printf "mesh throughput %s: %d ok in %ds = %.0f/s (%d connections x %d concurrent)\n" (label :: String) c secs (fromIntegral c / fromIntegral secs :: Double) conns k + run "via proxy" $ \w sId -> let (pc, sess) = pcs !! (w `mod` conns) in forwardOnce pc sess sId + void $ measureBoth "after proxy run" + ts <- getCurrentTime + rcs <- forM ([1 .. conns] :: [Int]) $ \i -> getProtocolClient g NRMInteractive (fromIntegral i, meshRelaySrv, Nothing) benchClientCfg [] Nothing ts (\_ -> pure ()) >>= either (fail . show) pure + run "direct SEND" $ \w sId -> + runExceptT (sendSMPMessage (rcs !! (w `mod` conns)) NRMInteractive Nothing sId noMsgFlags "hello") <&> \case + Right () -> True + Left (PCEProtocolError QUOTA) -> True + _ -> False + +-- An unauthenticated client that sends valid PFWDs and never reads: the proxy forwards them, and the +-- responses accumulate in its sndQ, then in the forked command threads, then in its rcvQ. +meshSlowReader :: TVar ChaChaDRG -> Int -> (String -> IO (ChildMem, ChildMem)) -> IO () +meshSlowReader g n measureBoth = do + secs <- envInt "MESH_SEC" 30 + sIds <- relayQueues g 1 + (pc, sess) <- head <$> proxyClients g 1 + _ <- forwardOnce pc sess (head sIds) + base <- measureBoth "before" + sent <- newTVarIO (0 :: Int) + let attacker = benchClient $ \h -> do + t <- pfwdTransmission g (thParams' h) sess (head sIds) + forever $ tPut1 h (Nothing, t) >> atomically (modifyTVar' sent (+ 1)) + thParams' THandle {params} = params + -- not awaited: closing TLS sends an alert, which blocks as the proxy no longer reads, so the + -- connections stay until the process exits + void $ async $ forConcurrently_ ([1 .. n] :: [Int]) $ \_ -> attacker + threadDelay $ secs * 1000000 + s <- readTVarIO sent + cur <- measureBoth $ printf "%d non-reading clients, %d PFWD accepted by TCP" n s + deltaPer "non-reading client" n base cur + +-- the PFWD a client builds in proxySMPCommand, as one transmission for a raw connection +pfwdTransmission :: TVar ChaChaDRG -> THandleParams SMPVersion 'TClient -> ProxiedRelay -> SenderId -> IO ByteString +pfwdTransmission g params ProxiedRelay {prSessionId, prVersion, prServerKey} sId = do + let serverThAuth = (\ta -> ta {peerServerPubKey = prServerKey}) <$> thAuth params + serverThParams = smpTHParamsSetVersion prVersion params {sessionId = prSessionId, thAuth = serverThAuth} + (cmdPubKey, cmdPrivKey) <- atomically $ C.generateKeyPair @'C.X25519 g + nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g + let TransmissionForAuth {tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender $ SEND noMsgFlags "hello") + b <- case batchTransmissions serverThParams [Right (Nothing, tToSend)] of + TBTransmission s _ : _ -> pure s + TBTransmissions s _ _ : _ -> pure s + _ -> fail "pfwdTransmission: batch" + et <- either (fail . show) (pure . EncTransmission) $ C.cbEncrypt (C.dh' prServerKey cmdPrivKey) nonce b paddedProxiedTLength + let TransmissionForAuth {tToSend = t} = encodeTransmissionForAuth params (CorrId corrId, EntityId prSessionId, Cmd SProxiedClient $ PFWD prVersion cmdPubKey et) + pure t +#endif + proxyPhases :: [String] -proxyPhases = ["proxyfwd", "proxytmo", "proxychurn", "subtmo", "conclimit", "fastfwd", "msgqfill", "pfwdbig"] +proxyPhases =["proxyfwd", "proxytmo", "proxychurn", "subtmo", "conclimit", "fastfwd", "msgqfill", "pfwdbig"] -- proxy topologies use the test databases; create them for the run and drop them after pgBracket :: IO a -> IO a From 4b217d618f16cbbe57e5d2b59b0ca07dc6ea51d6 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 23:56:47 +0000 Subject: [PATCH 42/43] docs: add smp-server memory findings --- docs/smp-server-memory.md | 243 +++++++++++++++++++++++++++++++ docs/tls-1.9-compact-state.patch | 184 +++++++++++++++++++++++ 2 files changed, 427 insertions(+) create mode 100644 docs/smp-server-memory.md create mode 100644 docs/tls-1.9-compact-state.patch diff --git a/docs/smp-server-memory.md b/docs/smp-server-memory.md new file mode 100644 index 000000000..1ed0f880a --- /dev/null +++ b/docs/smp-server-memory.md @@ -0,0 +1,243 @@ +# SMP server memory at production scale + +Production: ~40k client connections per server, 32 GB RAM shared with PostgreSQL, pure PostgreSQL +store, 14 servers proxying to each other, GHC 9.6.3, `+RTS -N -F1.2 -A16m -I0.01 -Iw15 -s -RTS`. +With `-F1.2` the copying GC needs about 2.2x the live heap plus the nursery, so the server's live +heap has to stay well under ~10 GB. + +A busy connection (20 batch-subscribed queues, 2 created with NEW, message traffic) cost 237 KiB of +server live heap, 9.0 GiB at 40k connections. With the changes below it costs 43 KiB, 1.6 GiB. + +Earlier findings on leaks and PostgreSQL load are in `leak-findings.md` and `smp-server-db-load.md`. + +## Method + +All numbers are server-only: the bench client runs in a child process, so the measuring process holds +only the server. PostgreSQL store, production RTS flags, 16-core machine. Live heap is measured after +two major GCs with finalizers allowed to run in between (`liveBytesMiB` in `bench/MemBench.hs`). + +| Phase | Measures | +| --- | --- | +| `prodmix` | 2000 connections, each SUBs 20 queues in one block and creates 2 with NEW, then 30 s of SEND/MSG/ACK traffic | +| `conns N` | N idle connections after the SMP handshake | +| `subslice N` | per subscription: `SUBMODE=sub` (`SUBBATCH`, `SUBKEEP`), `new`, `newthensub` | +| `load` | server CPU per operation under a fixed mixed workload | +| `ntfloop`, `ntfdeliver` | notification store and its delivery loop | +| `mesh` | proxy and relay in separate processes: relay sessions, forwards in flight, forward rate (`MESH=`) | +| `pfwdbig` | oversized forwards left in the proxy's `sentCommands` | + +```sh +cabal build -fserver_postgres exe:smp-mem-bench +BENCHID=1 PROD_CONNS=2000 PROD_QUEUES=20 PROD_NEW=2 PROD_SEC=30 \ + $(cabal list-bin -fserver_postgres exe:smp-mem-bench) prodmix 0 \ + +RTS -N -F1.2 -A16m -I0.01 -Iw15 -T -ki2k -RTS +``` + +`BENCHID` offsets ports and the database, so runs do not collide with each other or with tests. + +## Results + +`prodmix`, live heap per connection after subscribing and peak memory in use under traffic. Each row +adds to the previous one. + +| Change | KiB/conn | Peak in use | 40k conns | +| --- | --- | --- | --- | +| base (`sh/fix-leak`) | 236.6 | 1075 MiB | 9.0 GiB | +| `-ki2k` | 111.5 | 719 MiB | 4.3 GiB | +| connection commits (`sh/fix-conn-mem`) | 89.8 | 635 MiB | 3.4 GiB | +| unpinned subscription keys, proxy commits (`sh/mem-combined`) | 80.0 | 604-622 MiB | 3.1 GiB | +| patched tls 1.9 | 42.9 | 469 MiB | 1.6 GiB | + +Idle connections (`conns 2000`): 153 KiB at default flags, 68.4 KiB on `sh/mem-combined` with +`-ki2k`, 34.8 KiB with the patched tls. + +Message throughput did not drop in any row. `-ki2k` costs some GC time (below). + +## Findings + +### 1. Thread stacks: 125 KiB per busy connection + +Each connection has several threads that block in shallow loops. A thread starts with a 1 KiB stack +(`-ki1k`). On first overflow the RTS copies up to `-kb` (1 KiB) of frames into a new 32 KiB chunk +(`-kc32k`), which with a 1 KiB initial stack moves the loop frame itself, so the thread never returns +to its first chunk and keeps the 32 KiB chunk while the connection lives. + +| Flags | idle KiB/conn | prodmix KiB/conn | +| --- | --- | --- | +| default | 153 | 236.6 | +| `-kc8k` | 100 | 135.0 | +| `-ki2k` | 91 | 111.5 | + +`-ki2k` leaves the loop frame in the first chunk, so the overflow chunk is freed on return. Cost, 3 +alternating 60 s `load` runs: GC CPU +15% (4.8-5.2 s to 5.7-5.8 s per run), major GCs +43% (the live +heap is smaller, so `-F1.2` triggers major GCs sooner), CPU per operation +0-5% (2.74-3.02 ms to +2.91-3.35 ms, one noisy run). One `load` run with `-kc2k` grew to 6.8 GB RSS; not investigated, so +`-kc` is left at its default. + +Branch `sh/rts-ki2k` sets `-with-rtsopts=-ki2k` for smp-server. Command-line `+RTS` flags still apply. + +### 2. Pinned blocks kept alive by small long-lived objects + +`ByteString`s and crypton's `ScrubbedBytes` are pinned and share 4 KiB blocks. GHC treats a pinned +block as live if any object in it is live, and treats every object in a live pinned block as alive, +including dead `ScrubbedBytes`, whose weak pointers and finalizers then stay allocated (GHC 9.6.3 +`Evac.c:443`, `GCAux.c:73`). A 24-byte value created during request processing, among crypto +temporaries, therefore keeps ~4 KiB and several dead keys alive for as long as it lives. A standalone +program reproduces it (pinned key 2742 B live per key, unpinned 80 B). + +Subscriptions. The subscription key is such a value. + +| `subslice 5000` | before | unpinned keys | +| --- | --- | --- | +| NEW-created | 5.25 KiB | 0.46 KiB | +| one SUB per block | 1.67-2.42 KiB | 0.47 KiB | +| 100 SUBs per block | 0.49 KiB | 0.46 KiB | +| NEW0, then SUB on the same connection | 4.98 KiB | 0.47 KiB | + +Branch `sh/fix-sub-mem` stores the keys of `subscriptions`, `ntfSubscriptions` and `queueSubscribers` +as `ShortByteString` and shares one key between the maps. CPU unchanged. + +TLS session state. tls 1.9 keeps record keys, IVs, TLS 1.3 traffic secrets, verify data and +handshake state for the connection's lifetime, all allocated during the handshake. A heap census per +connection before and after re-allocating them together at the end of the handshake: + +| | tls 1.9 | patched | +| --- | --- | --- | +| weak pointers | ~138 | ~45 | +| memory in pinned blocks, outside the census | ~39 KiB | ~13 KiB | +| idle KiB/conn | 68.4 | 34.8 | +| prodmix KiB/conn | 80.0 | 42.9 | + +The patch (`tls-1.9-compact-state.patch`: `Network.TLS.Handshake.Compact`, called at the end of +`handshake` under the context locks) re-derives the TLS 1.3 record keys from the kept traffic +secrets, copies the IVs, secrets, session ID, verify data, randoms, main and resumption secrets and +the transcript hash, and reseeds the context RNG. It needs a tls fork. Not compacted: the TLS 1.2 bulk +key, keys installed later by KeyUpdate. The transcript hash copy coerces crypton's hidden `Context` +newtype, so it must be checked on crypton upgrades. + +Full test suite with the patched tls: 1431 examples, 0 failures. The same run on unpatched tls had 1 +failure, the XFTP agent's "should resume sending file after restart". + +SMP handshake state (session secret, chain keys) has the same pattern and is not done yet; the +remaining ~13 KiB outside the census is likely there. + +### 3. IDs sliced from the received block: 16 KiB per subscription + +Parsed `corrId` and `entityId` are slices of the ~16 KB decrypted block, and the entity ID was stored +as the subscription key, so one live key kept the block. One SUB per block cost 16.43 KiB per +subscription, one survivor of 100 cost 18.04 KiB. `sh/fix-sub-keys` copies both IDs in +`tDecodeServer` (16.43 to 1.67-2.42 KiB). Unpinned keys (finding 2) also remove it for the maps. + +### 4. Connection structure: 21 KiB per busy connection + +- tls 1.9 stores the receive record state lazily, so each connection kept its last received 16 KB + record. `recvTLS` forces the state after each read. Not needed with tls 2.x. +- The send and message-send loops are one thread, and one server-wide thread expires inactive clients + instead of one per client: 6 threads per connection become 4. + +`sh/fix-conn-mem`: `prodmix` 111.5 to 89.8 KiB with `-ki2k`, 236.6 to 210.5 KiB without. + +### 5. Notification store and its delivery loop + +Keys of notifiers whose notifications were delivered stayed in the store, and the loop in +`deliverNtfsThread` sends every key to `getQueueNtfServices` (one `notifier_id IN ?` query read in +full) every 1.5 s. + +| `ntfloop` (keys, no traffic) | allocation | CPU | peak in use | +| --- | --- | --- | --- | +| 0 | 0 MiB/s | 0 | 280 MiB | +| 100k | 168 MiB/s | 0.42 cores | 530 MiB | +| 300k | 263 MiB/s | 0.76 cores | 913 MiB | + +`ntfdeliver` with 20k delivered notifications: 20000 keys kept, idle server allocating 36 MiB/s at +0.18 cores; with `sh/fix-ntf-store` 0 keys, 0.2 MiB/s, 0.01 cores. + +### 6. Proxy mesh + +The relay processed forwarded commands from a proxy one at a time in the connection's command loop, +with a PostgreSQL round trip each; all users of a proxy share its connection. Forwards the relay has +not reached wait on the proxy, each with a thread and its ~16 KB block. `mesh`, 1000 forwards per +second for 20 s, proxy and relay in separate processes, 2 runs each: + +| | serial | concurrent | +| --- | --- | --- | +| forwards ok / failed | 19,968 / 0 | 19,968 / 0 | +| proxy live heap at end of sending | 192-200 MiB | 13 MiB | +| proxy memory in use | 653-672 MiB | 325 MiB (idle baseline) | +| proxy threads | 4,026-4,137 | 420 | + +Here the backlog drained within the 30 s forward timeout. With a slower relay (a busy database, a +remote relay over SOCKS) the queueing delay exceeds it and forwards fail; not reproduced. + +`sh/fix-proxy-mesh` forks each forwarded command under the per-connection concurrency limit, stops +keeping the forwarded block on the proxy while waiting (53.0 to 36.8 KiB per in-flight forward, +relay not answering) and caps forwards in flight per relay at 512 (`[PROXY] relay_concurrency`). +Forwarded commands use per-command nonces and secrets and are matched by correlation ID, so concurrent +processing is safe; the SimpleX agent keeps one message in flight per queue. The spec requires +responses in order per queue within a connection (`simplex-messaging.md`, "same order within each +queue ID"); serializing forwarded commands per queue ID is not done yet. + +Also in the proxy path (`sh/fix-proxy-leak`): a PFWD of 16260-16266 bytes from a client that declares +`proxyServer = True` failed with `TELargeMsg` before sending and left its 20.2 KiB request in +`sentCommands` for the life of the relay session (2001 PFWDs, 2001 entries); timed-out requests were +kept too; and a relay session that stopped answering was never dropped (10 of 10 forwards timed out). + +### 7. Concurrency limit and name resolution + +`forkCmd` released its slot when the thread was forked, not when the command finished, so +`serverClientConcurrency` and `serverResolverConcurrency` limited nothing: 16 RSLVs with a limit of 4 +all reached the resolver, 64 RSLVs from one connection were 64 concurrent requests, and 5 lookups +answered with 502 opened 5 connections because error bodies were not read. `sh/fix-rslv-fanout` holds +the slot until completion, adds a global limit (`[NAMES] resolver_global_concurrency`, 32) and reads +error bodies. With the limit working, a client that hits it blocks its own command loop. + +### 8. Smaller findings + +- Active-queue statistics are `IntSet`s at 64 B per element (15M elements, 916 MiB for one set), six + of them, reset only when `log_stats` is on. +- Control port `save` closes the PostgreSQL pool while the server keeps running; every later DB + operation blocks (`cpsave` phase: NEW after `save` gets no response). + +### 9. tls 2.x + +tls 2.1.6 (with tls-session-manager 0.0.6, crypton-connection 0.4.3, http-client-tls 0.3.6.4, an +index-state bump and version pins) saves 2-5 KiB per connection: `prodmix` 75.4 KiB against 80.0. +Problems found: + +- After a failed handshake a tls 2 client and a tls 2 server wait for each other in `bye`; this hung + `testServerMultipleIdentities`. Fixed on `sh/tls2` by closing the context without `bye`. +- A tls 2 client that receives a CertificateRequest runs a timed read inside `handshake`; when the + timeout fires in the middle of a record the stream fails ("bad record mac") or hangs. SMP servers + always request client certificates. 1-2 failures per 2000 concurrent connections; present in tls + 2.4.3. A `conns 2000` run with tls 2 on both sides stopped at 53 connections. + +tls 2.x is not recommended; `sh/tls2` is kept for reference. + +## Open + +- Serialize forwarded commands per queue ID on the relay (spec response order). +- A client that sends PFWDs and never reads the responses costs the proxy 6.3 MiB live (11.4 MiB in + use) until the inactive-client expiry (up to 6 hours), 6 GiB per 1000 such clients. +- PRXY to many aliases of one relay opens an unbounded number of relay sessions, each 207 KiB on the + proxy and 149 KiB on the relay: 2.0 GiB and 1.4 GiB per 10k. +- Compact the SMP handshake state after the handshake, as in finding 2. +- Publish the tls fork and reference it from `cabal.project`. +- A SEND right after NEW or SUB can find no subscriber yet (`queueSubscribers` is updated through + `subQ`), so the message waits for the next SUB or ACK. `deliverIfSame` may leave a subscription + without a delivery thread. Both seen as occasional stuck steps in `load`; not memory. +- `[PROXY] relay_concurrency` and `[NAMES] resolver_global_concurrency` are new INI keys. + +## Branches + +| Branch | Base | Content | +| --- | --- | --- | +| `sh/fix-ntf-store` | master | finding 5 | +| `sh/fix-sub-keys` | master | finding 3 | +| `sh/fix-proxy-leak` | master | finding 6, request leak and stuck session | +| `sh/fix-rslv-fanout` | master | finding 7 | +| `sh/fix-conn-mem` | master | finding 4 | +| `sh/fix-sub-mem` | master | finding 2, subscription keys | +| `sh/fix-proxy-mesh` | `sh/fix-proxy-leak` | finding 6, relay concurrency, per-relay limit | +| `sh/rts-ki2k` | master | finding 1 | +| `sh/mem-combined` | `sh/fix-leak` | findings 1-6 together, as measured in Results (local) | +| `sh/tls2` | `sh/mem-combined` | finding 9, not for merge (local) | diff --git a/docs/tls-1.9-compact-state.patch b/docs/tls-1.9-compact-state.patch new file mode 100644 index 000000000..f9c49f0e8 --- /dev/null +++ b/docs/tls-1.9-compact-state.patch @@ -0,0 +1,184 @@ +diff -ruN -x 'dist*' tls-1.9.0-orig/Network/TLS/Crypto.hs tls-fork/Network/TLS/Crypto.hs +--- tls-1.9.0-orig/Network/TLS/Crypto.hs 2026-09-30 18:44:40.083085887 +0000 ++++ tls-fork/Network/TLS/Crypto.hs 2026-09-30 18:44:40.106519923 +0000 +@@ -8,6 +8,7 @@ + , hashUpdate + , hashUpdateSSL + , hashFinal ++ , hashCopy + + , module Network.TLS.Crypto.DH + , module Network.TLS.Crypto.IES +@@ -44,6 +45,8 @@ + import qualified Crypto.Hash as H + import qualified Data.ByteString as B + import qualified Data.ByteArray as B (convert) ++import qualified Data.ByteArray as BA ++import Unsafe.Coerce (unsafeCoerce) + import Crypto.Error + import Crypto.Number.Basic (numBits) + import Crypto.Random +@@ -135,6 +138,17 @@ + hashUpdate (HashContextSSL sha1Ctx md5Ctx) b = + HashContextSSL (H.hashUpdate sha1Ctx b) (H.hashUpdate md5Ctx b) + ++-- | Copies the context into a new allocation. ++hashCopy :: HashContext -> IO HashContext ++hashCopy (HashContext (ContextSimple h)) = HashContext . ContextSimple <$> copyContext h ++hashCopy (HashContextSSL sha1Ctx md5Ctx) = HashContextSSL <$> copyContext sha1Ctx <*> copyContext md5Ctx ++ ++-- H.Context is a newtype over Bytes, with the constructor in a hidden crypton module ++copyContext :: H.Context alg -> IO (H.Context alg) ++copyContext h = do ++ b <- BA.copy h (\_ -> return ()) :: IO BA.Bytes ++ return $! unsafeCoerce b ++ + hashUpdateSSL :: HashCtx + -> (B.ByteString,B.ByteString) -- ^ (for the md5 context, for the sha1 context) + -> HashCtx +diff -ruN -x 'dist*' tls-1.9.0-orig/Network/TLS/Handshake/Compact.hs tls-fork/Network/TLS/Handshake/Compact.hs +--- tls-1.9.0-orig/Network/TLS/Handshake/Compact.hs 1970-01-01 00:00:00.000000000 +0000 ++++ tls-fork/Network/TLS/Handshake/Compact.hs 2026-09-30 18:45:10.137984909 +0000 +@@ -0,0 +1,111 @@ ++{-# LANGUAGE OverloadedStrings #-} ++{-# OPTIONS_HADDOCK hide #-} ++module Network.TLS.Handshake.Compact ++ ( compactContext ++ ) where ++ ++import Control.Concurrent.MVar ++import Control.Exception (evaluate) ++import Crypto.Random (drgNew) ++import qualified Data.ByteString as B ++import Data.IORef ++ ++import Network.TLS.Cipher ++import Network.TLS.Context.Internal ++import Network.TLS.Crypto ++import Network.TLS.Extension (Cookie (..)) ++import Network.TLS.Handshake.State ++import Network.TLS.Imports ++import Network.TLS.KeySchedule (hkdfExpandLabel) ++import Network.TLS.Record.State ++import Network.TLS.RNG ++import Network.TLS.State ++import Network.TLS.Struct ++import Network.TLS.Types ++ ++-- | Re-allocates the state a context keeps after the handshake, next to each other. ++-- Each small pinned value created during the handshake shares a 4K block with short-lived ++-- crypto temporaries, and keeps the whole block alive, with every dead ScrubbedBytes in it. ++compactContext :: Context -> IO () ++compactContext ctx = do ++ tx <- readMVar $ ctxTxState ctx ++ rx <- readMVar $ ctxRxState ctx ++ st <- readMVar $ ctxState ctx ++ hst <- readMVar $ ctxHandshake ctx ++ finished <- readIORef $ ctxFinished ctx ++ peerFinished <- readIORef $ ctxPeerFinished ctx ++ -- key derivation and reseeding allocate temporaries, so they precede the copies ++ txKey <- trafficKey tx ++ rxKey <- trafficKey rx ++ rng <- evaluate $ StateRNG $ fst $ withTLSRNG (stRandomGen st) drgNew ++ tx' <- copyRecordState BulkEncrypt txKey tx ++ rx' <- copyRecordState BulkDecrypt rxKey rx ++ st' <- copyTLSState rng st ++ hst' <- traverse copyHandshakeState hst ++ finished' <- traverse copyBytes finished ++ peerFinished' <- traverse copyBytes peerFinished ++ modifyMVar_ (ctxTxState ctx) $ \_ -> return tx' ++ modifyMVar_ (ctxRxState ctx) $ \_ -> return rx' ++ modifyMVar_ (ctxState ctx) $ \_ -> return st' ++ modifyMVar_ (ctxHandshake ctx) $ \_ -> return hst' ++ writeIORef (ctxFinished ctx) finished' ++ writeIORef (ctxPeerFinished ctx) peerFinished' ++ ++copyBytes :: ByteString -> IO ByteString ++copyBytes = evaluate . B.copy ++ ++-- TLS 1.3 record keys are derived from the traffic secret kept in the record state; ++-- earlier versions keep the bulk key only inside the cipher state. ++trafficKey :: RecordState -> IO (Maybe ByteString) ++trafficKey RecordState{stCipher = Just cipher, stCryptLevel = CryptApplicationSecret, stCryptState = cst} = ++ Just <$> evaluate (hkdfExpandLabel (cipherHash cipher) (cstMacSecret cst) "key" "" (bulkKeySize $ cipherBulk cipher)) ++trafficKey _ = return Nothing ++ ++copyRecordState :: BulkDirection -> Maybe ByteString -> RecordState -> IO RecordState ++copyRecordState dir key_ rs@RecordState{stCryptState = cst} = do ++ iv <- copyBytes $ cstIV cst ++ secret <- copyBytes $ cstMacSecret cst ++ bulkState <- case (key_, stCipher rs) of ++ (Just key, Just cipher) -> bulkInit (cipherBulk cipher) dir <$> copyBytes key ++ _ -> return $ cstKey cst ++ evaluate rs{stCryptState = CryptState{cstKey = bulkState, cstIV = iv, cstMacSecret = secret}} ++ ++copyTLSState :: StateRNG -> TLSState -> IO TLSState ++copyTLSState rng st = do ++ session <- case stSession st of ++ Session sid -> Session <$> traverse copyBytes sid ++ clientVerified <- copyBytes $ stClientVerifiedData st ++ serverVerified <- copyBytes $ stServerVerifiedData st ++ proto <- traverse copyBytes $ stNegotiatedProtocol st ++ alpn <- traverse (traverse copyBytes) $ stClientALPNSuggest st ++ cookie <- traverse (\(Cookie c) -> Cookie <$> copyBytes c) $ stTLS13Cookie st ++ exporter <- traverse copyBytes $ stExporterMasterSecret st ++ evaluate ++ st ++ { stSession = session ++ , stClientVerifiedData = clientVerified ++ , stServerVerifiedData = serverVerified ++ , stNegotiatedProtocol = proto ++ , stClientALPNSuggest = alpn ++ , stTLS13Cookie = cookie ++ , stExporterMasterSecret = exporter ++ , stRandomGen = rng ++ } ++ ++copyHandshakeState :: HandshakeState -> IO HandshakeState ++copyHandshakeState hst = do ++ clientRandom <- ClientRandom <$> copyBytes (unClientRandom $ hstClientRandom hst) ++ serverRandom <- traverse (fmap ServerRandom . copyBytes . unServerRandom) $ hstServerRandom hst ++ mainSecret <- traverse copyBytes $ hstMasterSecret hst ++ digest <- case hstHandshakeDigest hst of ++ HandshakeMessages msgs -> HandshakeMessages <$> traverse copyBytes msgs ++ HandshakeDigestContext h -> HandshakeDigestContext <$> hashCopy h ++ resumption <- traverse (\(BaseSecret s) -> BaseSecret <$> copyBytes s) $ hstTLS13ResumptionSecret hst ++ evaluate ++ hst ++ { hstClientRandom = clientRandom ++ , hstServerRandom = serverRandom ++ , hstMasterSecret = mainSecret ++ , hstHandshakeDigest = digest ++ , hstTLS13ResumptionSecret = resumption ++ } +diff -ruN -x 'dist*' tls-1.9.0-orig/Network/TLS/Handshake.hs tls-fork/Network/TLS/Handshake.hs +--- tls-1.9.0-orig/Network/TLS/Handshake.hs 2026-09-30 18:44:40.083878116 +0000 ++++ tls-fork/Network/TLS/Handshake.hs 2026-09-30 18:45:14.390780619 +0000 +@@ -18,6 +18,7 @@ + import Network.TLS.Struct + + import Network.TLS.Handshake.Common ++import Network.TLS.Handshake.Compact + import Network.TLS.Handshake.Client + import Network.TLS.Handshake.Server + +@@ -27,7 +28,7 @@ + -- This is to be called at the beginning of a connection, and during renegotiation + handshake :: MonadIO m => Context -> m () + handshake ctx = +- liftIO $ withRWLock ctx $ handleException ctx (ctxDoHandshake ctx ctx) ++ liftIO $ withRWLock ctx $ handleException ctx (ctxDoHandshake ctx ctx) >> compactContext ctx + + -- Handshake when requested by the remote end + -- This is called automatically by 'recvData', in a context where the read lock +diff -ruN -x 'dist*' tls-1.9.0-orig/tls.cabal tls-fork/tls.cabal +--- tls-1.9.0-orig/tls.cabal 2026-09-30 18:44:40.090442445 +0000 ++++ tls-fork/tls.cabal 2026-09-30 19:12:16.099341583 +0000 +@@ -85,6 +85,7 @@ + Network.TLS.Handshake.Signature + Network.TLS.Handshake.State + Network.TLS.Handshake.State13 ++ Network.TLS.Handshake.Compact + Network.TLS.Hooks + Network.TLS.IO + Network.TLS.Imports From 49e4912ca1b8255cd65f8451041d642f07b546b0 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 23:56:47 +0000 Subject: [PATCH 43/43] docs: mark fixed leak findings --- docs/leak-findings.md | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/docs/leak-findings.md b/docs/leak-findings.md index 521cd635c..4dd8d69d7 100644 --- a/docs/leak-findings.md +++ b/docs/leak-findings.md @@ -8,22 +8,24 @@ Twelve findings: three proxy-path memory leaks (Leak 1-3), two `forkClient` bugs unauthenticated resolver fan-out (Bug 5), five PostgreSQL-backend costs (Bug 6-10), and a stuck proxy session (Bug 11). The TLS/TCP stack is clean (last two sections). +Memory at production scale, with measurements after these fixes: `smp-server-memory.md`. + ## Overview | # | Issue | Reachable | Backend | Evidence | Status | | --- | --- | --- | --- | --- | --- | -| Leak 1 | Forwarded commands not removed on timeout | Client, pre-auth (PRXY) | all | measured | present | +| Leak 1 | Forwarded commands not removed on timeout | Client, pre-auth (PRXY) | all | measured | fixed, `sh/fix-proxy-leak` | | Leak 2 | Failed relay connects not cleared | Client, pre-auth (PRXY) | all | measured | present | | Leak 3 | Proxy relay queue has no reader | Client, pre-auth (PRXY) | all | measured | fixed, #1839 | -| Bug 3 | Proxy concurrency limit does nothing | Client, pre-auth (PRXY) | all | measured | present | +| Bug 3 | Proxy concurrency limit does nothing | Client, pre-auth (PRXY) | all | measured | fixed, `sh/fix-rslv-fanout` | | Bug 4 | Stale `endThreads` entry on fast finish | Client, limited window | all | isolation only | present | -| Bug 5 | RSLV resolver fan-out | Client, if `[NAMES]` on | all | measured | present | +| Bug 5 | RSLV resolver fan-out | Client, if `[NAMES]` on | all | measured | fixed, `sh/fix-rslv-fanout` | | Bug 6 | SEND is three DB transactions | authenticated SEND | postgres | code review | present | | Bug 7 | Per-transmission verify and DB lookup | Client, pre-auth | postgres | code review | present | | Bug 8 | Service handshake grows `services` table | Client, pre-auth | postgres | code review | present | | Bug 9 | Prometheus scrape scans everything | internal, periodic | postgres | code review | present | | Bug 10 | Subscription churn serialized | authenticated SUB | all | code review | present | -| Bug 11 | Proxy never drops a stuck relay session | Client, pre-auth (PRXY) | all | reproduced | present | +| Bug 11 | Proxy never drops a stuck relay session | Client, pre-auth (PRXY) | all | reproduced | fixed, `sh/fix-proxy-leak` | Leak 1, Leak 2, Leak 3, Bug 3, and Bug 11 share one entry point. `PRXY` is unauthenticated unless `newQueueBasicAuth` is set (`Server.hs:1534`) and it names an arbitrary destination, so a client can