@@ -87,12 +87,29 @@ maxBatchSize = 100
8787-- Cap on gossip events accepted or emitted in a single federation exchange.
8888maxGossipEvents : Int
8989maxGossipEvents = 100
90+-- N13: Cap on newly-online keys per gossip batch that trigger forward sweeps.
91+-- Without this, a single gossip request with 100 `online` events triggers 100
92+-- mailbox scans (O(100 × |messages|)). Capping at 10 limits the amplification
93+-- while still allowing reasonable multi-key presence announcements. Remaining
94+-- newly-online keys are still written to `*presence` — only the forward sweep
95+-- is deferred until the next presence re-announce or a poll triggers
96+-- `forwardQueuedToServer` naturally.
97+maxNewlyOnlineForwards : Int
98+maxNewlyOnlineForwards = 10
9099-- Cap on events returned by one long-poll response.
91100maxPollEvents : Int
92101maxPollEvents = 50
93102-- Per-peer ceiling on outstanding forward attempts.
94103maxForwardsPerServer : Int
95104maxForwardsPerServer = 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
96113-- Global ceiling on the `*forwards` outbox. `maxForwardsPerServer` bounds any one
97114-- peer, but a recipient gossiped as present on many servers fans one blob out to
98115-- all of them, so the total is bounded only by (peers x per-peer cap). This caps
@@ -180,6 +197,15 @@ maxPresencePerServer = 5000
180197-- the same argument for sessions on `maxSessions`, and PROTOCOL.md §10.
181198maxMessagesPerRecipient : Int
182199maxMessagesPerRecipient = 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
183209-- Validity window for an auth challenge before it must be re-issued (1 min).
184210challengeExpiry : Int<Ms>
185211challengeExpiry = 60000
@@ -518,8 +544,15 @@ capPerServer = \items server maxN -> union (filter (\x -> not (x.server == serve
518544-- no timestamp (the same reason `retryPendingForwards` has to sort on the blob).
519545-- Applied by both writers that grow `*forwards` (`forwardQueuedToServer` and
520546-- `handleSendMessages`); the retry sweep only ever shrinks it.
547+--
548+-- N4: Sort by `(retries, encryptedBlob)` for determinism. Without the secondary
549+-- key, a `sortBy retries` alone is unstable when many entries share `retries: 0`,
550+-- and any of them could be dropped — including a fresh forward for a healthy
551+-- peer. The blob is a unique secondary key (the dedup invariant guarantees
552+-- `(toKey, encryptedBlob, toServer)` uniqueness), so the sort is total and
553+-- deterministic.
521554capForwards : [ForwardEntry] -> [ForwardEntry]
522−capForwards = \fwds -> take maxForwardsTotal (sortBy (\f -> f.retries) fwds)
555+capForwards = \fwds -> take maxForwardsTotal (sortBy (\f -> {retries: f.retries, blob: f.encryptedBlob}) fwds)
523556
524557-- Random hex token: one random hex char per recursive call. `n` is the
525558-- desired length in characters (so n=48 yields 24 random bytes of entropy).
@@ -916,6 +949,13 @@ currentSeq = \rows -> fold (\acc r -> max acc r.value) (0 : Timestamp) rows
916949-- and the fresh `seqTs` below would otherwise make `union` keep both rows and
917950-- double-deliver. Re-reading `*messages` per call also collapses duplicate blobs
918951-- appearing twice within one batch.
952+--
953+-- N3: This O(n) scan is a CPU amplification vector. A batch of 100 identical
954+-- blobs to the same recipient triggers 100 × O(|messages|) comparisons. With
955+-- |messages| = 10000, that's 1M comparisons per request, bounded by the 60/min
956+-- rate limit. A real fix needs an index on (toKey, encryptedBlob) or a
957+-- hash-based dedup set — both require runtime support not available in Knot
958+-- today. Documented as an accepted DoS surface.
919959appendMessage : PubkeyHex -> BlobHex -> Int<Ms> -> IO {rw *messages, rw *seqCounter} {}
920960appendMessage = \toKey encryptedBlob t -> do
921961 msgs <- *messages
@@ -927,14 +967,32 @@ appendMessage = \toKey encryptedBlob t -> do
927967 -- for this recipient so the post-append count lands exactly on the ceiling.
928968 -- `- 1` reserves the slot the new row is about to take.
929969 --
930− -- Eviction keys on `encryptedBlob` rather than the row itself because
931− -- (toKey, encryptedBlob) is unique by this function's own dedup invariant
932− -- (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.
933975 let forRecipient = filter (\m -> m.toKey == toKey) msgs
934976 let excess = max 0 (count forRecipient - (maxMessagesPerRecipient - 1))
935− let evicted = map (\m -> m.encryptedBlob) (take excess (sortBy (\m -> m.receivedAt) forRecipient))
936− let kept = filter (\m -> not (m.toKey == toKey && elem m.encryptedBlob evicted)) msgs
937− *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: []}])
938996
939997-- Record that `server` has accepted a federated forward of this message, so a
940998-- later presence re-announce of `toKey` doesn't re-forward the same blob to a peer
@@ -988,6 +1046,12 @@ pruneExpired = \t -> atomic do
9881046 -- Prune forwards whose message was removed by the TTL sweep above.
9891047 -- ForwardEntry carries no timestamp, so match against the surviving
9901048 -- 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.
9911055 fw <- *forwards
9921056 *forwards = filter (\f -> any (\m -> m.toKey == f.toKey && m.encryptedBlob == f.encryptedBlob) surviving) fw
9931057 ff <- *forwardFailures
@@ -1050,56 +1114,70 @@ sendBatchedGossip = \peers events -> case localServerName of
10501114-- comes online: any messages already buffered for that pubkey are enqueued
10511115-- as forwards to the newly-known server.
10521116
1053−-- Attempt every forward in `batch` to one peer, in order, and report whether any
1054−-- attempt was a genuine peer failure. Drops successful entries from `*forwards` and
1055−-- records the peer on the message's `deliveredTo`; on failure bumps the retry count
1056−-- 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`.
10571122--
10581123-- INVARIANT — this must not touch `*forwardFailures`. The caller records at most one
1059−-- failure per peer per sweep, from the Bool returned here; recording per failing
1060−-- *message* would let one unreachable peer with N buffered messages take N backoff
1061−-- steps in a single sweep and pin itself at `retryBackoffMax` for `forwardFailureMaxAge`.
1062−-- 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*.
10631128--
10641129-- A 404 is NOT a peer failure. `handleForwardMessage` answers 404 `no_presence`
10651130-- whenever the recipient is not *currently* online at that peer, which is an
10661131-- expected, retryable outcome (PROTOCOL.md §7) — the peer is healthy and answering.
1067−-- But `fetch` returns `Err` for every status >= 400, so treating any `Err` as a
1068−-- failure would feed a routine 404 into `recordFailure`, and `*forwardFailures` is
1069−-- shared with gossip: one stale-presence 404 would suppress all forwards *and* all
1070−-- gossip to that peer for a full backoff step (30 s–8 min). So a 404 leaves the peer
1071−-- unpenalized and the forward row untouched — no retry bump either, since the row is
1072−-- 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.
10731145--
10741146-- Recursive rather than `forEach` because the result has to be accumulated across
10751147-- iterations; `sortBy` fixes the iteration order that `head`/`drop 1` then walk.
1076−retryForwardsTo : Text -> [ForwardEntry] -> IO {rw *forwards, rw *messages, network} Bool
1148+retryForwardsTo : Text -> [ForwardEntry] -> IO {rw *forwards, rw *messages, network} {anyFailed: Bool, anySucceeded: Bool}
10771149retryForwardsTo = \server batch -> case head batch of
1078− Nothing {} -> yield (False {})
1150+ Nothing {} -> yield {anyFailed: False {}, anySucceeded: False {}}
10791151 Just {value: f} -> do
10801152 result <- fetch (federationUrl server) (ForwardMessage {f.toKey, f.encryptedBlob})
10811153 let status = case result of
10821154 Err {error: e} -> e.status
10831155 Ok _ -> 200
10841156 let success = status < 400
1085− -- 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).
10861159 let deferred = status == 404
10871160 let isMatch = forwardMatches f.toKey f.encryptedBlob server
10881161 let isDone = \x -> isMatch x && (success || x.retries + 1 >= maxForwardRetries)
10891162 atomic (do
1090− when (not deferred) (do
1091− cur <- *forwards
1092− *forwards = map (\x -> if isMatch x
1093− then {x.toServer, x.toKey, x.encryptedBlob, retries: x.retries + 1}
1094− 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)
10951171 when success (markDelivered f.toKey f.encryptedBlob server))
1096− restFailed <- retryForwardsTo server (drop 1 batch)
1097− 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}
10981174
10991175-- Walk pending forwards grouped by destination and retry each peer's backlog (up
11001176-- to maxBatchSize per peer) via `/federation/forward`. One failure record per peer
1101−-- per sweep: a sweep in which every attempt succeeded clears the peer's backoff, a
1102−-- 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`.
11031181retryPendingForwards : IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} {}
11041182retryPendingForwards = do
11051183 t <- now
@@ -1121,13 +1199,17 @@ retryPendingForwards = do
11211199 -- `maxForwardRetries` (dropped). `ForwardEntry` carries no timestamp, so key on
11221200 -- the unique blob.
11231201 let batch = take maxBatchSize (sortBy (\f -> f.encryptedBlob) (filter (\f -> f.toServer == server) fwds))
1124− anyFailed <- retryForwardsTo server batch
1125− -- `count batch > 0` guards the clear: `maxBatchSize` is startup-overridable,
1126− -- and at 0 every batch is empty — an empty sweep must not be read as a
1127− -- success and reset a failing peer's backoff.
1128− 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
11291211 then recordFailure server t
1130− else when (count batch > 0) (clearFailure server t)))
1212+ else when (count batch > 0 && result.anySucceeded) (clearFailure server t)))
11311213
11321214-- Forward queued messages to a server when a remote key comes online.
11331215-- Skips messages already delivered to `server` (tracked via Message.deliveredTo)
@@ -1150,6 +1232,32 @@ forwardQueuedToServer = \pubkey serverName -> atomic (do
11501232 let newFwds = map (\m -> {toServer: server, m.toKey, m.encryptedBlob, retries: 0}) (take budget (sortBy (\m -> m.receivedAt) candidates))
11511233 *forwards = capForwards (union fwds newFwds))
11521234
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+
11531261-- ============================================
11541262-- Handler: challenge / verify
11551263-- ============================================
@@ -1200,68 +1308,82 @@ handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp -> do
12001308 -- relay server cannot replay the signature to a different server. We verify
12011309 -- against our own configured hostname (port stripped), which a relay cannot forge.
12021310 --
1203− -- Signature verification is deferred until *after* the challenge lookup confirms
1204− -- a matching challenge exists (inside the atomic below). This avoids spending
1205− -- expensive Ed25519 CPU on /auth/verify calls that have no matching challenge,
1206− -- which would otherwise be a cheap CPU-DoS vector. The trade-off is that
1207− -- `verify` runs inside the STM transaction and may re-run on retries — but
1208− -- retries only happen on concurrent writes to *challenges/*sessions, which
1209− -- 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.
12101320 let signedText = "skrepka-auth-v1:" ++ authHost serverHost ++ ":" ++ challenge
1211− result <- atomic (do
1321+ challengeOk <- atomic (do
12121322 ch <- *challenges
12131323 let same = \c -> c.pubkey == pubkey && c.challenge == challenge
1214− let matchingChallenge = findFirst same ch
1215− case matchingChallenge of
1216− Nothing {} -> yield (Nothing {})
1217− Just {value: c} -> do
1218− if not (c.expiresAt > t && matchIp clientIp c.ip)
1219− then yield (Nothing {})
1220− else do
1221− -- Verify the signature only now that a matching, unexpired, IP-bound
1222− -- challenge exists.
1223− let sigValid = case bytesFromHex pubkey of
1224− Just {value: pk} -> case bytesFromHex signature of
1225− Just {value: sigBytes} -> verify pk (textToBytes signedText) sigBytes
1226− _ -> False {}
1227− _ -> False {}
1228− if not sigValid
1229− then yield (Nothing {})
1230− else do
1231− -- Consume the challenge and optionally revoke other sessions + challenges.
1232− -- When `revokeOthers` is set, drop all other sessions AND outstanding
1233− -- challenges for this pubkey, so a captured challenge cannot be
1234− -- redeemed for a new session after revocation (Q35).
1235− *challenges = if revokeOthers
1236− then filter (\x -> not (x.pubkey == pubkey)) ch
1237− else filter (\x -> not same x) ch
1238− ses <- *sessions
1239− let pruned = if revokeOthers
1240− then filter (\s -> s.pubkey != pubkey) ses
1241− else capPerKey ses pubkey maxSessionsPerKey
1242− let newSession = {token, pubkey, expiresAt: expiry, ip: clientIp}
1243− -- LRU-evicts the soonest-to-expire session when the pool is full; this global
1244− -- eviction is Sybil-floodable, see the LIMITATION note on `maxSessions`.
1245− let pooled = union pruned [newSession]
1246− -- Count what `capList` is about to shed, so the handler can warn about it
1247− -- below. That flood has no other observable signature: evicted users just
1248− -- start seeing 401s and silently re-authenticate, which looks like normal
1249− -- traffic in the access log. A sustained nonzero rate here is the alert.
1250− let evicted = max 0 (count pooled - maxSessions)
1251− *sessions = capList pooled maxSessions
1252− peers <- refreshLocalPresence pubkey expiry
1253− yield (Just {value: {peers, evicted}}))
1254− case result of
1255− Nothing {} -> yield (Err {error: {status: 401, message: "invalid"}})
1256− Just {value: r} -> do
1257− -- Warn outside the `atomic` block, never inside: an STM transaction can
1258− -- retry, and a console write is not rolled back with it — logging inside
1259− -- would emit one line per retry attempt rather than one per eviction.
1260− -- Include the requesting pubkey and IP for audit (Q38): an operator
1261− -- investigating a Sybil flood needs to know which identities are responsible.
1262− 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 ++ ")"))
1263− when federationEnabled (fork (sendBatchedGossip r.peers [{eventType: "online", pubkey: Just {value: pubkey}}]))
1264− 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}})
12651387
12661388-- ============================================
12671389-- Handler: poll
@@ -1300,11 +1422,16 @@ handlePoll = \cursor authorization clientIp -> do
13001422 -- so peers don't time us out mid-session.
13011423 let stale = not any (\p -> p.pubkey == pubkey && isLocalServer p.server && p.expiresAt - t >= sessionExpiry / 2) pres
13021424 refreshPeers <- if stale then refreshLocalPresence pubkey (t + sessionExpiry) else yield []
1303− 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}}))
13041430 case setup of
13051431 Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
13061432 Just {value: s} -> do
1307− 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}}]))
13081435 pollResult <- doPoll s t
13091436 yield (Ok {value: pollResult})
13101437
@@ -1415,10 +1542,15 @@ handleSendMessages = \messages authorization clientIp -> do
14151542 Nothing {} -> do
14161543 committed <- atomic (do
14171544 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.
14181550 let staged = map (\m -> {
14191551 m.to,
14201552 m.encryptedBlob,
1421− 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))
14221554 }) messages
14231555 forEach staged (\c -> do
14241556 -- Read `*messages` *before* the append: `delivered` below must see the
@@ -1523,7 +1655,7 @@ forkForwardsTo = \to encryptedBlob servers -> forEach servers (\server -> when (
15231655-- fromServer) row touched by this batch, then re-adds fresh-TTL rows for
15241656-- pubkeys with an `online` event (so Online wins on collision). For keys
15251657-- that transition offline → online, flushes any locally-buffered messages via
1526−-- `forwardQueuedToServer`. Events with an unrecognized `eventType` or no
1658+-- `forwardQueuedToAll`. Events with an unrecognized `eventType` or no
15271659-- `pubkey` are skipped (forward-compat) rather than rejecting the batch.
15281660--
15291661-- SECURITY: this is the gossip-redirect ingress described in the section header
@@ -1534,7 +1666,7 @@ handleRecvGossip : [GossipEvent] -> ServerName -> IO {r *messages, rw *forwards,
15341666handleRecvGossip = \events fromServer -> do
15351667 t <- now
15361668 -- Widen the peer-supplied `ServerName` once (see `type ServerName`);
1537− -- `forwardQueuedToServer` below still takes the refined name.
1669+ -- `forwardQueuedToAll` below still takes the refined name.
15381670 let from = (fromServer : Text)
15391671 if not federationEnabled
15401672 then yield (Err {error: {status: 403, message: "federation_disabled"}})
@@ -1557,12 +1689,13 @@ handleRecvGossip = \events fromServer -> do
15571689 Ok {value: pk} -> if e.eventType == "online"
15581690 then {
15591691 touched: union acc.touched [pk],
1560− added: union acc.added [{pubkey: pk, server: from, expiresAt: t + onlineGossipTtl}]
1692+ added: union acc.added [{pubkey: pk, server: from, expiresAt: t + onlineGossipTtl}],
1693+ offline: acc.offline
15611694 }
15621695 else if e.eventType == "offline"
1563− then {acc.added, touched: union acc.touched [pk]}
1696+ then {acc.added, touched: union acc.touched [pk], offline: union acc.offline [pk]}
15641697 else acc
1565− Nothing {} -> acc) {touched: ([] : [PubkeyHex]), added: ([] : [PresenceEntry])} events
1698+ Nothing {} -> acc) {touched: ([] : [PubkeyHex]), added: ([] : [PresenceEntry]), offline: ([] : [PubkeyHex])} events
15661699 let kept = filter (\p -> p.server != from || not elem p.pubkey collected.touched) pres
15671700 let merged = union kept collected.added
15681701 -- Cap the gossip-learned rows: per-peer first, so one peer cannot crowd every
@@ -1574,8 +1707,28 @@ handleRecvGossip = \events fromServer -> do
15741707 let localRows = filter (\p -> isLocalServer p.server) merged
15751708 let remoteRows = filter (\p -> not isLocalServer p.server) merged
15761709 *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
1716+ -- N14: Cancel pending forwards to `from` for offline keys. Without this,
1717+ -- forwards to a peer that just went offline retry for up to 80 minutes,
1718+ -- wasting maxForwardsPerServer slots and generating failed HTTP requests.
1719+ -- The message stays in *messages, so it's re-forwarded if the key
1720+ -- re-appears on another peer.
1721+ when (count offlineOnly > 0) (do
1722+ fwds <- *forwards
1723+ *forwards = filter (\f -> not (f.toServer == from && elem f.toKey offlineOnly)) fwds)
15771724 yield (filter (\pk -> not any (\p -> p.pubkey == pk && p.server == from && p.expiresAt > t) pres) (map (\p -> p.pubkey) collected.added)))
1578− fork (forEach newlyOnline (\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)
15791732 yield (Ok {value: {}})
15801733
15811734-- POST /federation/forward: receive a single federated message destined for