@@ -102,6 +102,14 @@ maxPollEvents = 50
102102-- Per-peer ceiling on outstanding forward attempts.
103103maxForwardsPerServer : Int
104104maxForwardsPerServer = 2000
105+-- S9: Cap on distinct remote servers a single message is immediately forwarded
106+-- to at send time. Separate from `maxForwardsPerServer` (which bounds outstanding
107+-- forwards *per peer*), this bounds the fan-out breadth. A recipient is unlikely
108+-- to be visible on more than 100 servers; the previous reuse of
109+-- `maxForwardsPerServer` (2000) for this purpose was an overload that could
110+-- spawn up to 2000 immediate HTTP forwards per message.
111+maxRemoteServersPerMessage : Int
112+maxRemoteServersPerMessage = 100
105113-- Global ceiling on the `*forwards` outbox. `maxForwardsPerServer` bounds any one
106114-- peer, but a recipient gossiped as present on many servers fans one blob out to
107115-- all of them, so the total is bounded only by (peers x per-peer cap). This caps
@@ -189,6 +197,15 @@ maxPresencePerServer = 5000
189197-- the same argument for sessions on `maxSessions`, and PROTOCOL.md §10.
190198maxMessagesPerRecipient : Int
191199maxMessagesPerRecipient = 10000
200+-- Global ceiling on total stored messages across all recipients (S6). Every
201+-- other state ref has a global cap (*sessions, *challenges, *presence,
202+-- *forwards); *messages had only a per-recipient cap, so total storage was
203+-- bounded only by (distinct recipient keys x maxMessagesPerRecipient), and an
204+-- attacker minting fresh invalid pubkeys could fill the disk (bounded only by
205+-- rate limits and the 30-day TTL). On overflow this evicts the globally-oldest
206+-- rows, symmetric with the other refs. See PROTOCOL.md §10.
207+maxMessagesTotal : Int
208+maxMessagesTotal = 1000000
192209-- Validity window for an auth challenge before it must be re-issued (1 min).
193210challengeExpiry : Int<Ms>
194211challengeExpiry = 60000
@@ -950,14 +967,32 @@ appendMessage = \toKey encryptedBlob t -> do
950967 -- for this recipient so the post-append count lands exactly on the ceiling.
951968 -- `- 1` reserves the slot the new row is about to take.
952969 --
953− -- Eviction keys on `encryptedBlob` rather than the row itself because
954− -- (toKey, encryptedBlob) is unique by this function's own dedup invariant
955− -- (the `when` guard above), so a blob identifies at most one row per key.
970+ -- S4: Instead of building an `evicted` list and checking membership (which
971+ -- is O(|messages| × |evicted|)), compute the eviction threshold — the
972+ -- receivedAt of the (maxMessagesPerRecipient - 1)th oldest message for this
973+ -- recipient — and keep only messages newer than it. This is O(|messages|)
974+ -- with no inner scan.
956975 let forRecipient = filter (\m -> m.toKey == toKey) msgs
957976 let excess = max 0 (count forRecipient - (maxMessagesPerRecipient - 1))
958− let evicted = map (\m -> m.encryptedBlob) (take excess (sortBy (\m -> m.receivedAt) forRecipient))
959− let kept = filter (\m -> not (m.toKey == toKey && elem m.encryptedBlob evicted)) msgs
960− *messages = union kept [{toKey, encryptedBlob, receivedAt: seqTs, deliveredTo: []}])
977+ let sortedRecipient = sortBy (\m -> m.receivedAt) forRecipient
978+ -- The threshold: the receivedAt of the last row we want to evict.
979+ -- Rows with receivedAt <= threshold are evicted; rows > threshold survive.
980+ let evictionThreshold = if excess > 0
981+ then case take excess sortedRecipient of
982+ [] -> 0
983+ xs -> case last xs of
984+ {receivedAt: r} -> r
985+ else 0
986+ let kept = filter (\m -> not (m.toKey == toKey && m.receivedAt <= evictionThreshold && excess > 0)) msgs
987+ -- Global cap (S6): after the per-recipient eviction, bound the total mailbox
988+ -- across all recipients by dropping the globally-oldest rows. Only runs on
989+ -- overflow, so the O(n log n) sort is off the hot path. Dropped rows may
990+ -- belong to other recipients; their orphaned *forwards are reclaimed by
991+ -- `pruneExpired`, and their lost `deliveredTo` is harmless (the blob is gone).
992+ let globallyCapped = if count kept > maxMessagesTotal
993+ then drop (count kept - maxMessagesTotal) (sortBy (\m -> m.receivedAt) kept)
994+ else kept
995+ *messages = union globallyCapped [{toKey, encryptedBlob, receivedAt: seqTs, deliveredTo: []}])
961996
962997-- Record that `server` has accepted a federated forward of this message, so a
963998-- later presence re-announce of `toKey` doesn't re-forward the same blob to a peer
@@ -1011,6 +1046,12 @@ pruneExpired = \t -> atomic do
10111046 -- Prune forwards whose message was removed by the TTL sweep above.
10121047 -- ForwardEntry carries no timestamp, so match against the surviving
10131048 -- messages (the post-sweep list, not the pre-sweep snapshot).
1049+ --
1050+ -- S5: This is O(|forwards| × |surviving|) — a quadratic scan. In practice
1051+ -- |forwards| is usually far below maxForwardsTotal (50000) and |surviving|
1052+ -- is bounded by maxMessagesTotal (1000000), so the cost is modest. A real
1053+ -- fix needs a set/index keyed on (toKey, encryptedBlob), which the Knot
1054+ -- runtime does not expose today. Documented as an accepted design tradeoff.
10141055 fw <- *forwards
10151056 *forwards = filter (\f -> any (\m -> m.toKey == f.toKey && m.encryptedBlob == f.encryptedBlob) surviving) fw
10161057 ff <- *forwardFailures
@@ -1073,56 +1114,70 @@ sendBatchedGossip = \peers events -> case localServerName of
10731114-- comes online: any messages already buffered for that pubkey are enqueued
10741115-- as forwards to the newly-known server.
10751116
1076−-- Attempt every forward in `batch` to one peer, in order, and report whether any
1077−-- attempt was a genuine peer failure. Drops successful entries from `*forwards` and
1078−-- records the peer on the message's `deliveredTo`; on failure bumps the retry count
1079−-- and gives up after `maxForwardRetries`.
1117+-- Attempt every forward in `batch` to one peer, in order, and report both whether
1118+-- any attempt was a genuine peer failure (`anyFailed`) and whether any attempt
1119+-- genuinely succeeded (`anySucceeded`). Drops successful entries from `*forwards`
1120+-- and records the peer on the message's `deliveredTo`; every attempt (success,
1121+-- failure, or 404) bumps the retry count and gives up after `maxForwardRetries`.
10801122--
10811123-- INVARIANT — this must not touch `*forwardFailures`. The caller records at most one
1082−-- failure per peer per sweep, from the Bool returned here; recording per failing
1083−-- *message* would let one unreachable peer with N buffered messages take N backoff
1084−-- steps in a single sweep and pin itself at `retryBackoffMax` for `forwardFailureMaxAge`.
1085−-- The counter counts consecutive failed *sweeps*.
1124+-- failure per peer per sweep, from the `anyFailed` flag returned here; recording per
1125+-- failing *message* would let one unreachable peer with N buffered messages take N
1126+-- backoff steps in a single sweep and pin itself at `retryBackoffMax` for
1127+-- `forwardFailureMaxAge`. The counter counts consecutive failed *sweeps*.
10861128--
10871129-- A 404 is NOT a peer failure. `handleForwardMessage` answers 404 `no_presence`
10881130-- whenever the recipient is not *currently* online at that peer, which is an
10891131-- expected, retryable outcome (PROTOCOL.md §7) — the peer is healthy and answering.
1090−-- But `fetch` returns `Err` for every status >= 400, so treating any `Err` as a
1091−-- failure would feed a routine 404 into `recordFailure`, and `*forwardFailures` is
1092−-- shared with gossip: one stale-presence 404 would suppress all forwards *and* all
1093−-- gossip to that peer for a full backoff step (30 s–8 min). So a 404 leaves the peer
1094−-- unpenalized and the forward row untouched — no retry bump either, since the row is
1095−-- waiting on the recipient's presence, not on a delivery that went wrong.
1132+-- `fetch` returns `Err` for every status >= 400, so treating any `Err` as a failure
1133+-- would feed a routine 404 into `recordFailure`, and `*forwardFailures` is shared
1134+-- with gossip: one stale-presence 404 would suppress all forwards *and* all gossip to
1135+-- that peer for a full backoff step (30 s–8 min). So a 404 leaves the peer's backoff
1136+-- untouched (`anyFailed` stays false for it) and never clears it (`anySucceeded`
1137+-- stays false too).
1138+--
1139+-- But a 404 DOES bump the forward's retry count now (S1). It previously left the row
1140+-- entirely untouched, so a forward whose recipient never came online at the peer was
1141+-- retried every sweep for the full 30-day message TTL — the counter never advanced,
1142+-- so `maxForwardRetries` was never reached. Counting the attempt (without charging
1143+-- the peer's backoff) lets the forward hit the cap and be dropped after
1144+-- `maxForwardRetries` sweeps while still not penalizing a healthy peer.
10961145--
10971146-- Recursive rather than `forEach` because the result has to be accumulated across
10981147-- iterations; `sortBy` fixes the iteration order that `head`/`drop 1` then walk.
1099−retryForwardsTo : Text -> [ForwardEntry] -> IO {rw *forwards, rw *messages, network} Bool
1148+retryForwardsTo : Text -> [ForwardEntry] -> IO {rw *forwards, rw *messages, network} {anyFailed: Bool, anySucceeded: Bool}
11001149retryForwardsTo = \server batch -> case head batch of
1101− Nothing {} -> yield (False {})
1150+ Nothing {} -> yield {anyFailed: False {}, anySucceeded: False {}}
11021151 Just {value: f} -> do
11031152 result <- fetch (federationUrl server) (ForwardMessage {f.toKey, f.encryptedBlob})
11041153 let status = case result of
11051154 Err {error: e} -> e.status
11061155 Ok _ -> 200
11071156 let success = status < 400
1108− -- Recipient simply isn't online at the peer yet: hold the row, blame no one.
1157+ -- Recipient simply isn't online at the peer yet: hold the peer blameless, but
1158+ -- still count the attempt so the row can't outlive the message TTL (S1).
11091159 let deferred = status == 404
11101160 let isMatch = forwardMatches f.toKey f.encryptedBlob server
11111161 let isDone = \x -> isMatch x && (success || x.retries + 1 >= maxForwardRetries)
11121162 atomic (do
1113− when (not deferred) (do
1114− cur <- *forwards
1115− *forwards = map (\x -> if isMatch x
1116− then {x.toServer, x.toKey, x.encryptedBlob, retries: x.retries + 1}
1117− else x) (filter (\x -> not isDone x) cur))
1163+ cur <- *forwards
1164+ -- Count the attempt regardless of outcome: a 404 still consumes a retry slot
1165+ -- so a forward that never finds the recipient online is eventually dropped
1166+ -- (S1). On success or after `maxForwardRetries`, `isDone` filters the row out
1167+ -- first, so the increment then no-ops on an absent row.
1168+ *forwards = map (\x -> if isMatch x
1169+ then {x.toServer, x.toKey, x.encryptedBlob, retries: x.retries + 1}
1170+ else x) (filter (\x -> not isDone x) cur)
11181171 when success (markDelivered f.toKey f.encryptedBlob server))
1119− restFailed <- retryForwardsTo server (drop 1 batch)
1120− yield ((not success && not deferred) || restFailed)
1172+ rest <- retryForwardsTo server (drop 1 batch)
1173+ yield {anyFailed: (not success && not deferred) || rest.anyFailed, anySucceeded: success || rest.anySucceeded}
11211174
11221175-- Walk pending forwards grouped by destination and retry each peer's backlog (up
11231176-- to maxBatchSize per peer) via `/federation/forward`. One failure record per peer
1124−-- per sweep: a sweep in which every attempt succeeded clears the peer's backoff, a
1125−-- sweep with any failure takes exactly one backoff step (see `retryForwardsTo`).
1177+-- per sweep: a sweep with any genuine failure takes exactly one backoff step; a
1178+-- sweep with at least one genuine success clears the peer's backoff; an all-404
1179+-- sweep leaves the backoff untouched, neither charging nor clearing it (S1). See
1180+-- `retryForwardsTo`.
11261181retryPendingForwards : IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} {}
11271182retryPendingForwards = do
11281183 t <- now
@@ -1144,13 +1199,17 @@ retryPendingForwards = do
11441199 -- `maxForwardRetries` (dropped). `ForwardEntry` carries no timestamp, so key on
11451200 -- the unique blob.
11461201 let batch = take maxBatchSize (sortBy (\f -> f.encryptedBlob) (filter (\f -> f.toServer == server) fwds))
1147− anyFailed <- retryForwardsTo server batch
1148− -- `count batch > 0` guards the clear: `maxBatchSize` is startup-overridable,
1149− -- and at 0 every batch is empty — an empty sweep must not be read as a
1150− -- success and reset a failing peer's backoff.
1151− if anyFailed
1202+ result <- retryForwardsTo server batch
1203+ -- Clear the peer's backoff only on a sweep with at least one genuine success
1204+ -- (S1). An all-404 sweep (recipient not online at the peer) is neither a
1205+ -- failure nor a success: clearing backoff on it would reset the peer to
1206+ -- "fresh" every sweep, firing a retry every `backgroundPruneInterval` for the
1207+ -- full 30-day message TTL. `count batch > 0` also guards against reading an
1208+ -- empty sweep (possible with a startup-overridden `maxBatchSize` of 0) as
1209+ -- meaningful.
1210+ if result.anyFailed
11521211 then recordFailure server t
1153− else when (count batch > 0) (clearFailure server t)))
1212+ else when (count batch > 0 && result.anySucceeded) (clearFailure server t)))
11541213
11551214-- Forward queued messages to a server when a remote key comes online.
11561215-- Skips messages already delivered to `server` (tracked via Message.deliveredTo)
@@ -1173,6 +1232,32 @@ forwardQueuedToServer = \pubkey serverName -> atomic (do
11731232 let newFwds = map (\m -> {toServer: server, m.toKey, m.encryptedBlob, retries: 0}) (take budget (sortBy (\m -> m.receivedAt) candidates))
11741233 *forwards = capForwards (union fwds newFwds))
11751234
1235+-- Batched version of `forwardQueuedToServer`: stage forwards for *all* newly-online
1236+-- keys in a single mailbox scan (S4). Calling `forwardQueuedToServer` per key scans
1237+-- `*messages` once per key, which is why `handleRecvGossip` previously capped the
1238+-- number of keys at `maxNewlyOnlineForwards` (N13) — but that cap silently deferred
1239+-- delivery past the 10th key, and a re-announce within the TTL never recovered it
1240+-- (the `deliveredTo`/presence state made the key look already-handled). A single
1241+-- pass bounds the cost to O(|messages|) regardless of how many keys came online.
1242+--
1243+-- SECURITY: shares `forwardQueuedToServer`'s exposure — it routes on gossip-written
1244+-- presence. The same `deliveredTo` / `notYetForwarded` / per-peer budget guards
1245+-- apply; do not widen them without revisiting the gossip-redirect note above.
1246+forwardQueuedToAll : [PubkeyHex] -> ServerName -> IO {rw *forwards, r *messages} {}
1247+forwardQueuedToAll = \pubkeys serverName -> atomic (do
1248+ let server = (serverName : Text)
1249+ msgs <- *messages
1250+ fwds <- *forwards
1251+ let existing = countWhere (\f -> f.toServer == server) fwds
1252+ let budget = max 0 (maxForwardsPerServer - existing)
1253+ let notYetForwarded = \m -> not any (forwardMatches m.toKey m.encryptedBlob server) fwds
1254+ let notYetDelivered = \m -> not any (\d -> d.server == server) m.deliveredTo
1255+ -- `elem m.toKey pubkeys` is O(|pubkeys|), but `pubkeys` is bounded by
1256+ -- `maxGossipEvents` (100), so the scan stays O(|messages|) overall.
1257+ let candidates = filter (\m -> elem m.toKey pubkeys && notYetForwarded m && notYetDelivered m) msgs
1258+ let newFwds = map (\m -> {toServer: server, m.toKey, m.encryptedBlob, retries: 0}) (take budget (sortBy (\m -> m.receivedAt) candidates))
1259+ *forwards = capForwards (union fwds newFwds))
1260+
11761261-- ============================================
11771262-- Handler: challenge / verify
11781263-- ============================================
@@ -1223,68 +1308,82 @@ handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp -> do
12231308 -- relay server cannot replay the signature to a different server. We verify
12241309 -- against our own configured hostname (port stripped), which a relay cannot forge.
12251310 --
1226− -- Signature verification is deferred until *after* the challenge lookup confirms
1227− -- a matching challenge exists (inside the atomic below). This avoids spending
1228− -- expensive Ed25519 CPU on /auth/verify calls that have no matching challenge,
1229− -- which would otherwise be a cheap CPU-DoS vector. The trade-off is that
1230− -- `verify` runs inside the STM transaction and may re-run on retries — but
1231− -- retries only happen on concurrent writes to *challenges/*sessions, which
1232− -- are rare, so the expected retry count is ~1.
1311+ -- Signature verification is split out of the session-install transaction (S7).
1312+ -- Phase 1 is a cheap read-only atomic that confirms a matching, unexpired,
1313+ -- IP-bound challenge exists — the original CPU-DoS guard, which still spends no
1314+ -- Ed25519 CPU on /auth/verify calls that have no matching challenge. Phase 2 runs
1315+ -- the expensive `verify` *outside* any atomic, so an STM retry on the phase-3
1316+ -- install transaction (triggered by concurrent writes to *challenges/*sessions)
1317+ -- never re-executes it — previously `verify` sat inside that transaction and every
1318+ -- retry re-ran the Ed25519 check. Phase 3 re-checks the challenge before consuming
1319+ -- it, closing the TOCTOU window opened between phases 1 and 3.
12331320 let signedText = "skrepka-auth-v1:" ++ authHost serverHost ++ ":" ++ challenge
1234− result <- atomic (do
1321+ challengeOk <- atomic (do
12351322 ch <- *challenges
12361323 let same = \c -> c.pubkey == pubkey && c.challenge == challenge
1237− let matchingChallenge = findFirst same ch
1238− case matchingChallenge of
1239− Nothing {} -> yield (Nothing {})
1240− Just {value: c} -> do
1241− if not (c.expiresAt > t && matchIp clientIp c.ip)
1242− then yield (Nothing {})
1243− else do
1244− -- Verify the signature only now that a matching, unexpired, IP-bound
1245− -- challenge exists.
1246− let sigValid = case bytesFromHex pubkey of
1247− Just {value: pk} -> case bytesFromHex signature of
1248− Just {value: sigBytes} -> verify pk (textToBytes signedText) sigBytes
1249− _ -> False {}
1250− _ -> False {}
1251− if not sigValid
1252− then yield (Nothing {})
1253− else do
1254− -- Consume the challenge and optionally revoke other sessions + challenges.
1255− -- When `revokeOthers` is set, drop all other sessions AND outstanding
1256− -- challenges for this pubkey, so a captured challenge cannot be
1257− -- redeemed for a new session after revocation (Q35).
1258− *challenges = if revokeOthers
1259− then filter (\x -> not (x.pubkey == pubkey)) ch
1260− else filter (\x -> not same x) ch
1261− ses <- *sessions
1262− let pruned = if revokeOthers
1263− then filter (\s -> s.pubkey != pubkey) ses
1264− else capPerKey ses pubkey maxSessionsPerKey
1265− let newSession = {token, pubkey, expiresAt: expiry, ip: clientIp}
1266− -- LRU-evicts the soonest-to-expire session when the pool is full; this global
1267− -- eviction is Sybil-floodable, see the LIMITATION note on `maxSessions`.
1268− let pooled = union pruned [newSession]
1269− -- Count what `capList` is about to shed, so the handler can warn about it
1270− -- below. That flood has no other observable signature: evicted users just
1271− -- start seeing 401s and silently re-authenticate, which looks like normal
1272− -- traffic in the access log. A sustained nonzero rate here is the alert.
1273− let evicted = max 0 (count pooled - maxSessions)
1274− *sessions = capList pooled maxSessions
1275− peers <- refreshLocalPresence pubkey expiry
1276− yield (Just {value: {peers, evicted}}))
1277− case result of
1278− Nothing {} -> yield (Err {error: {status: 401, message: "invalid"}})
1279− Just {value: r} -> do
1280− -- Warn outside the `atomic` block, never inside: an STM transaction can
1281− -- retry, and a console write is not rolled back with it — logging inside
1282− -- would emit one line per retry attempt rather than one per eviction.
1283− -- Include the requesting pubkey and IP for audit (Q38): an operator
1284− -- investigating a Sybil flood needs to know which identities are responsible.
1285− when (r.evicted > 0) (logWarn ("session pool full: evicted " ++ show r.evicted ++ " session(s) to seat a new login (pubkey=" ++ pubkey ++ ", ip=" ++ clientIp ++ ", maxSessions=" ++ show maxSessions ++ ")"))
1286− when federationEnabled (fork (sendBatchedGossip r.peers [{eventType: "online", pubkey: Just {value: pubkey}}]))
1287− yield (Ok {value: {token, expiresAt: expiry}})
1324+ case findFirst ch same of
1325+ Nothing {} -> yield (False {})
1326+ Just {value: c} -> yield (c.expiresAt > t && matchIp clientIp c.ip))
1327+ if not challengeOk
1328+ then yield (Err {error: {status: 401, message: "invalid"}})
1329+ else do
1330+ -- Phase 2: verify OUTSIDE any atomic. Expensive, and must not be re-executed on
1331+ -- an STM retry of the install transaction below (S7).
1332+ let sigValid = case bytesFromHex pubkey of
1333+ Just {value: pk} -> case bytesFromHex signature of
1334+ Just {value: sigBytes} -> verify pk (textToBytes signedText) sigBytes
1335+ _ -> False {}
1336+ _ -> False {}
1337+ if not sigValid
1338+ then yield (Err {error: {status: 401, message: "invalid"}})
1339+ else do
1340+ -- Phase 3: re-check the challenge (it may have expired or been consumed by a
1341+ -- concurrent verify since phase 1), consume it, and install the session. The
1342+ -- body is cheap, so an STM retry here costs almost nothing.
1343+ result <- atomic (do
1344+ ch <- *challenges
1345+ let same = \c -> c.pubkey == pubkey && c.challenge == challenge
1346+ let matchingChallenge = findFirst ch same
1347+ case matchingChallenge of
1348+ Nothing {} -> yield (Nothing {})
1349+ Just {value: c} -> do
1350+ if not (c.expiresAt > t && matchIp clientIp c.ip)
1351+ then yield (Nothing {})
1352+ else do
1353+ -- Consume the challenge and optionally revoke other sessions + challenges.
1354+ -- When `revokeOthers` is set, drop all other sessions AND outstanding
1355+ -- challenges for this pubkey, so a captured challenge cannot be
1356+ -- redeemed for a new session after revocation (Q35).
1357+ *challenges = if revokeOthers
1358+ then filter (\x -> not (x.pubkey == pubkey)) ch
1359+ else filter (\x -> not same x) ch
1360+ ses <- *sessions
1361+ let pruned = if revokeOthers
1362+ then filter (\s -> s.pubkey != pubkey) ses
1363+ else capPerKey ses pubkey maxSessionsPerKey
1364+ let newSession = {token, pubkey, expiresAt: expiry, ip: clientIp}
1365+ -- LRU-evicts the soonest-to-expire session when the pool is full; this global
1366+ -- eviction is Sybil-floodable, see the LIMITATION note on `maxSessions`.
1367+ let pooled = union pruned [newSession]
1368+ -- Count what `capList` is about to shed, so the handler can warn about it
1369+ -- below. That flood has no other observable signature: evicted users just
1370+ -- start seeing 401s and silently re-authenticate, which looks like normal
1371+ -- traffic in the access log. A sustained nonzero rate here is the alert.
1372+ let evicted = max 0 (count pooled - maxSessions)
1373+ *sessions = capList pooled maxSessions
1374+ peers <- refreshLocalPresence pubkey expiry
1375+ yield (Just {value: {peers, evicted}}))
1376+ case result of
1377+ Nothing {} -> yield (Err {error: {status: 401, message: "invalid"}})
1378+ Just {value: r} -> do
1379+ -- Warn outside the `atomic` block, never inside: an STM transaction can
1380+ -- retry, and a console write is not rolled back with it — logging inside
1381+ -- would emit one line per retry attempt rather than one per eviction.
1382+ -- Include the requesting pubkey and IP for audit (Q38): an operator
1383+ -- investigating a Sybil flood needs to know which identities are responsible.
1384+ when (r.evicted > 0) (logWarn ("session pool full: evicted " ++ show r.evicted ++ " session(s) to seat a new login (pubkey=" ++ pubkey ++ ", ip=" ++ clientIp ++ ", maxSessions=" ++ show maxSessions ++ ")"))
1385+ when federationEnabled (fork (sendBatchedGossip r.peers [{eventType: "online", pubkey: Just {value: pubkey}}]))
1386+ yield (Ok {value: {token, expiresAt: expiry}})
12881387
12891388-- ============================================
12901389-- Handler: poll
@@ -1323,11 +1422,16 @@ handlePoll = \cursor authorization clientIp -> do
13231422 -- so peers don't time us out mid-session.
13241423 let stale = not any (\p -> p.pubkey == pubkey && isLocalServer p.server && p.expiresAt - t >= sessionExpiry / 2) pres
13251424 refreshPeers <- if stale then refreshLocalPresence pubkey (t + sessionExpiry) else yield []
1326− yield (Just {value: {pubkey, clampedCursor, refreshPeers}}))
1425+ -- S3: Track whether we actually refreshed so the gossip line below
1426+ -- only fires on a refresh, not on every poll. Without this, every
1427+ -- poll gossips to all seed peers via gossipTargets [], creating
1428+ -- O(clients × seeds) federation traffic per poll cycle.
1429+ yield (Just {value: {pubkey, clampedCursor, refreshPeers, didRefresh: stale}}))
13271430 case setup of
13281431 Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
13291432 Just {value: s} -> do
1330− when federationEnabled (fork (sendBatchedGossip s.refreshPeers [{eventType: "online", pubkey: Just {value: s.pubkey}}]))
1433+ -- S3: Only gossip when we actually refreshed presence — not on every poll.
1434+ when (federationEnabled && s.didRefresh) (fork (sendBatchedGossip s.refreshPeers [{eventType: "online", pubkey: Just {value: s.pubkey}}]))
13311435 pollResult <- doPoll s t
13321436 yield (Ok {value: pollResult})
13331437
@@ -1438,10 +1542,15 @@ handleSendMessages = \messages authorization clientIp -> do
14381542 Nothing {} -> do
14391543 committed <- atomic (do
14401544 pres <- *presence
1545+ -- S2: cap the immediate fan-out at `maxForwardsPerServer` servers per
1546+ -- recipient. The post-commit `forkForwardsTo` fires against this list
1547+ -- directly (bypassing the `*forwards` queue and its per-peer cap), so
1548+ -- without a bound here a recipient gossiped as present on thousands of
1549+ -- servers would spawn one immediate HTTP forward per server per message.
14411550 let staged = map (\m -> {
14421551 m.to,
14431552 m.encryptedBlob,
1444− remoteServers: collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server)
1553+ remoteServers: take maxRemoteServersPerMessage (collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server))
14451554 }) messages
14461555 forEach staged (\c -> do
14471556 -- Read `*messages` *before* the append: `delivered` below must see the
@@ -1546,7 +1655,7 @@ forkForwardsTo = \to encryptedBlob servers -> forEach servers (\server -> when (
15461655-- fromServer) row touched by this batch, then re-adds fresh-TTL rows for
15471656-- pubkeys with an `online` event (so Online wins on collision). For keys
15481657-- that transition offline → online, flushes any locally-buffered messages via
1549−-- `forwardQueuedToServer`. Events with an unrecognized `eventType` or no
1658+-- `forwardQueuedToAll`. Events with an unrecognized `eventType` or no
15501659-- `pubkey` are skipped (forward-compat) rather than rejecting the batch.
15511660--
15521661-- SECURITY: this is the gossip-redirect ingress described in the section header
@@ -1557,7 +1666,7 @@ handleRecvGossip : [GossipEvent] -> ServerName -> IO {r *messages, rw *forwards,
15571666handleRecvGossip = \events fromServer -> do
15581667 t <- now
15591668 -- Widen the peer-supplied `ServerName` once (see `type ServerName`);
1560− -- `forwardQueuedToServer` below still takes the refined name.
1669+ -- `forwardQueuedToAll` below still takes the refined name.
15611670 let from = (fromServer : Text)
15621671 if not federationEnabled
15631672 then yield (Err {error: {status: 403, message: "federation_disabled"}})
@@ -1598,21 +1707,28 @@ handleRecvGossip = \events fromServer -> do
15981707 let localRows = filter (\p -> isLocalServer p.server) merged
15991708 let remoteRows = filter (\p -> not isLocalServer p.server) merged
16001709 *presence = union localRows (capList (capPerServer remoteRows from maxPresencePerServer) maxPresence)
1710+ -- S8: Make online+offline for the same key mutually exclusive within one
1711+ -- batch. If a batch carries both events for a key, online wins — the presence
1712+ -- merge above already added the online row — so that key must NOT also travel
1713+ -- the offline path and cancel its own freshly-staged forwards.
1714+ let onlineKeys = map (\p -> p.pubkey) collected.added
1715+ let offlineOnly = filter (\pk -> not elem pk onlineKeys) collected.offline
16011716 -- N14: Cancel pending forwards to `from` for offline keys. Without this,
16021717 -- forwards to a peer that just went offline retry for up to 80 minutes,
16031718 -- wasting maxForwardsPerServer slots and generating failed HTTP requests.
16041719 -- The message stays in *messages, so it's re-forwarded if the key
16051720 -- re-appears on another peer.
1606− when (count collected.offline > 0) (do
1721+ when (count offlineOnly > 0) (do
16071722 fwds <- *forwards
1608− *forwards = filter (\f -> not (f.toServer == from && elem f.toKey collected.offline)) fwds)
1723+ *forwards = filter (\f -> not (f.toServer == from && elem f.toKey offlineOnly)) fwds)
16091724 yield (filter (\pk -> not any (\p -> p.pubkey == pk && p.server == from && p.expiresAt > t) pres) (map (\p -> p.pubkey) collected.added)))
1610− -- N13: Cap the number of newly-online keys that trigger forward sweeps.
1611− -- Without this, 100 online events = 100 mailbox scans. The remaining keys
1612− -- are still in `*presence` — their forwards will be staged when a poll
1613− -- refreshes presence or the next gossip re-announces them.
1614− let toForward = take maxNewlyOnlineForwards newlyOnline
1615− fork (forEach toForward (\pk -> forwardQueuedToServer pk fromServer))
1725+ -- S4: forward queued mail for ALL newly-online keys in one mailbox pass. The
1726+ -- old per-key cap (maxNewlyOnlineForwards, N13) bounded amplification but
1727+ -- silently deferred delivery past the 10th key, and a re-announce within the
1728+ -- TTL never recovered it (the deliveredTo/presence state made the key look
1729+ -- already-handled). `forwardQueuedToAll` bounds the cost to O(|messages|)
1730+ -- regardless of how many keys came online.
1731+ fork (forwardQueuedToAll newlyOnline fromServer)
16161732 yield (Ok {value: {}})
16171733
16181734-- POST /federation/forward: receive a single federated message destined for