@@ -1,79 +1,42 @@
1−-- Skrepka Relay Server
1+-- Skrepka Relay Server (simplified)
2−-- Single-server implementation of the Skrepka protocol (v0.1)
2+-- Single-server implementation of the Skrepka protocol (v0.1).
3−-- Binary data (keys, signatures, blobs) uses hex encoding (bytesToHex/bytesFromHex)
3+-- This is a deliberately simplified rewrite: every collection is a single flat list,
4−--
4+-- rate limiters use a plain count-per-window, no caches, no histograms, no TCO accumulator
5−-- Architecture:
5+-- helpers. Performance under load is significantly worse than the sharded original;
6−-- Clients authenticate via Ed25519 challenge-response, then poll for messages via long-polling.
6+-- correctness and clarity are the only goals here.
7−-- Messages are E2E encrypted blobs routed by recipient pubkey.
8−-- Federation: servers gossip presence info and forward messages for keys homed elsewhere.
9−-- Presence tracks which server a pubkey was last seen on (online/offline via gossip).
10−-- All state is in-memory; background tasks handle pruning and retry of failed federation ops.
12-- ============================================
8-- ============================================
13-- Configuration
9-- Configuration
14-- ============================================
10-- ============================================
16−-- Server identity and federation credentials
17serverHost = "localhost"
12serverHost = "localhost"
18listenPort = 8080
13listenPort = 8080
19−federationScheme = "https://" -- scheme for federation HTTP calls
14+federationScheme = "https://"
20−-- Ed25519 federation signing keys (hex-encoded). When both are set, outbound federation
21−-- requests are signed instead of using verify callbacks (eliminates the round-trip).
22−-- Inbound requests with "Signed" auth are verified locally; "Bearer" auth falls back
23−-- to the existing verify callback for backward compatibility with older peers.
24−-- Empty = signing disabled, use verify callbacks only.
25serverFederationPrivateKeyHex = ""
15serverFederationPrivateKeyHex = ""
26serverFederationPublicKeyHex = ""
16serverFederationPublicKeyHex = ""
27−-- NOTE: listenHost is not configurable — Knot's listen primitive only accepts a port.
17+
28−-- To restrict the bind address (e.g., 127.0.0.1 behind a reverse proxy), use
29−-- firewall rules (e.g., iptables -A INPUT -p tcp --dport 8080 -s 127.0.0.1 -j ACCEPT)
30−-- or a container network namespace.
31−-- TODO: If Knot adds a listen-with-host API, add listenHost = "0.0.0.0" config here.
32−-- NOTE: Outbound federation HTTP calls have no runtime-level timeout. The fetchFederation
33−-- wrapper tracks in-flight requests per server and skips servers with outstanding requests
34−-- older than federationFetchTimeoutMs (see shouldRetryServerEx). This prevents a single
35−-- slow peer from consuming all concurrency slots, though truly hung connections still hold
36−-- one slot until the forked task terminates.
37−-- Message and data size limits
38−-- IMPORTANT: Knot has no HTTP-layer request body size limit. Field-level length checks
39−-- (maxBlobLen, maxPubkeyLen, etc.) validate after JSON parsing, so a multi-GB body is
40−-- fully parsed before rejection. Deploy behind a reverse proxy with a body size limit:
41−-- Caddy: request_body { max_size 256KB }
42−-- nginx: client_max_body_size 256k;
43−-- HAProxy: tune.maxrewrite 256k
44−-- Without this, the server is vulnerable to large-payload DoS attacks. The maxBlobLen
45−-- limit (64KB hex = 32KB binary) bounds legitimate message payloads; batch requests
46−-- may be larger but are authenticated via maintenance secret.
47−-- TODO: If Knot adds HTTP-layer configuration, enforce a request body size limit natively.
48messageMaxAge : Int<Ms>
18messageMaxAge : Int<Ms>
49−messageMaxAge = 2592000000 -- 30 days
19+messageMaxAge = 2592000000
50maxPresenceTtl : Int<S>
20maxPresenceTtl : Int<S>
51−maxPresenceTtl = 3600 -- max presence TTL from gossip
21+maxPresenceTtl = 3600
52maxPubkeyLen = 256
22maxPubkeyLen = 256
53maxBlobLen = 65536
23maxBlobLen = 65536
54maxSignatureLen = 256
24maxSignatureLen = 256
55−maxIpLen = 45 -- max length of an IP address string (IPv6 = 45 chars); used in matchIp instead of maxServerNameLen
25+maxIpLen = 45
56maxMessageIds = 100
26maxMessageIds = 100
57−maxBatchSize = 100 -- max messages per batch request (bounds recursion depth in sendBatchInner)
27+maxBatchSize = 100
58−maxMessagePriority = 10 -- max priority value (clamped on ingress)
28+maxMessagePriority = 10
59maxGossipEvents = 100
29maxGossipEvents = 100
60maxPollEvents = 50
30maxPollEvents = 50
61−-- Fraction of maxPollEvents reserved for priority-0 messages (normal priority).
62−-- Prevents high-priority floods from completely starving normal messages.
63−-- With maxPollEvents=50 and reservedPollFraction=5, at least 10 slots (50/5)
64−-- are reserved for priority-0 when both priority levels have pending messages.
65−-- 0 = disable reservation (old behavior: strict priority ordering).
66−reservedPollFraction = 5
67maxPresenceEntries = 10000
31maxPresenceEntries = 10000
68maxMessagesPerRecipient = 500
32maxMessagesPerRecipient = 500
69−maxMessages = 100000 -- global cap on total stored messages across all recipients
33+maxMessages = 100000
70−-- Global capacity limits for in-memory collections
71clockSkewTolerance : Int<Ms>
34clockSkewTolerance : Int<Ms>
72−clockSkewTolerance = 5000 -- 5 seconds tolerance for clock skew between federated servers
35+clockSkewTolerance = 5000
73maxForwardsEntries = 10000
36maxForwardsEntries = 10000
74−maxForwardsPerKey = 50 -- max pending forwards per recipient pubkey (prevents one key from starving others)
37+maxForwardsPerKey = 50
75−maxForwardsPerSenderPerKey = 10 -- max pending forwards per sender-recipient pair (prevents one sender from monopolizing a recipient's queue)
38+maxForwardsPerSenderPerKey = 10
76−maxForwardsPerServer = 2000 -- max pending forwards per destination server (prevents one unreachable peer from starving others)
39+maxForwardsPerServer = 2000
77maxServerNameLen = 128
40maxServerNameLen = 128
78maxMessageIdLen = 128
41maxMessageIdLen = 128
79maxCorrelationIdLen = 128
42maxCorrelationIdLen = 128
@@ -81,301 +44,95 @@ maxTokenLen = 256
81maxChallenges = 10000
44maxChallenges = 10000
82maxSessions = 10000
45maxSessions = 10000
83maxAckedIds = 10000
46maxAckedIds = 10000
84−maxAckOverflow = 200 -- overflow buffer for acks that couldn't be sent yet
85maxDeliveredIds = 10000
47maxDeliveredIds = 10000
86−-- Per-key limits and rate limiting
87maxChallengesPerKey = 5
48maxChallengesPerKey = 5
88maxSessionsPerKey = 10
49maxSessionsPerKey = 10
89challengeExpiry : Int<Ms>
50challengeExpiry : Int<Ms>
90−challengeExpiry = 60000 -- 1 minute
51+challengeExpiry = 60000
91−maxChallengeRatePerKey = 5 -- max challenge requests per key per window
52+maxChallengeRatePerKey = 5
92−maxChallengeRateEntries = 1000
93challengeRateWindowMs : Int<Ms>
53challengeRateWindowMs : Int<Ms>
94challengeRateWindowMs = 1000
54challengeRateWindowMs = 1000
95−maxSendRatePerKey = 20 -- max messages sent per key per window
55+maxSendRatePerKey = 20
96sendRateWindowMs : Int<Ms>
56sendRateWindowMs : Int<Ms>
97sendRateWindowMs = 1000
57sendRateWindowMs = 1000
98−maxSendRateEntries = 1000
99−-- Per-key revoke rate limiting (separate from challenge to prevent challenge floods from blocking revocations)
100−maxRevokeRatePerKey = 5 -- max revoke requests per key per window
101−revokeRateWindowMs : Int<Ms>
102−revokeRateWindowMs = 1000
103−maxRevokeRateEntries = 1000
104−-- Per-recipient receive rate limiting
105−maxRecvRatePerKey = 10 -- max messages received by a key per window (across all senders)
58+maxRecvRatePerKey = 10
106recvRateWindowMs : Int<Ms>
59recvRateWindowMs : Int<Ms>
107recvRateWindowMs = 1000
60recvRateWindowMs = 1000
108−maxRecvRateEntries = 1000
109−-- Per-sender-per-recipient rate limiting (prevents one sender from filling a recipient's mailbox)
110−maxPairRatePerPair = 30 -- max messages per sender-recipient pair per window
61+maxPairRatePerPair = 30
111pairRateWindowMs : Int<Ms>
62pairRateWindowMs : Int<Ms>
112−pairRateWindowMs = 60000 -- 1 minute
63+pairRateWindowMs = 60000
113−maxPairRateEntries = 5000
114−-- Federation rate limiting (per-server)
115−maxFederationRatePerServer = 50 -- max federation requests per server per window
64+maxFederationRatePerServer = 50
116federationRateWindowMs : Int<Ms>
65federationRateWindowMs : Int<Ms>
117federationRateWindowMs = 1000
66federationRateWindowMs = 1000
118−maxFederationRateEntries = 100
67+maxLookupRatePerKey = 5
119−-- Per-server-per-recipient rate limiting for federation forwards
68+lookupRateWindowMs : Int<Ms>
120−maxFederationPairRatePerPair = 10 -- max forwards per fromServer-recipient pair per window
69+lookupRateWindowMs = 1000
121−federationPairRateWindowMs : Int<Ms>
70+maxClientWriteRatePerKey = 10
122−federationPairRateWindowMs = 60000 -- 1 minute
71+clientWriteRateWindowMs : Int<Ms>
123−maxFederationPairRateEntries = 5000
72+clientWriteRateWindowMs = 1000
124−-- Global request rate limiting
73+maxIpRatePerIp = 10
125−maxActiveRequests = 500 -- max concurrent requests before rejecting with overloaded (0 = disable)
74+ipRateWindowMs : Int<Ms>
126−maxGlobalRequestRate = 1000 -- max total requests per window
76+maxGlobalRequestRate = 1000
127globalRateWindowMs : Int<Ms>
77globalRateWindowMs : Int<Ms>
128globalRateWindowMs = 1000
78globalRateWindowMs = 1000
129−-- Auth-tier global rate limiting (prevents auth flooding from starving client operations)
130−maxAuthGlobalRate = 200 -- max auth requests (challenge + verify + revoke) per window
79+maxAuthGlobalRate = 200
131authGlobalRateWindowMs : Int<Ms>
80authGlobalRateWindowMs : Int<Ms>
132authGlobalRateWindowMs = 1000
81authGlobalRateWindowMs = 1000
133−-- Session and gossip timing
82+
134sessionExpiry : Int<Ms>
83sessionExpiry : Int<Ms>
135−sessionExpiry = 3600000 -- 1 hour
84+sessionExpiry = 3600000
136−maxSessionLifetime : Int<Ms>
137−maxSessionLifetime = 86400000 -- 24 hours; absolute session lifetime (forces re-auth even if sliding window keeps refreshing)
138onlineGossipTtl : Int<S>
85onlineGossipTtl : Int<S>
139−onlineGossipTtl = 5400 -- 1.5 hours; 1.5x sessionExpiry to prevent presence expiring before session refresh gossips
86+onlineGossipTtl = 5400
140offlineGossipMinTtl : Int<S>
87offlineGossipMinTtl : Int<S>
141−offlineGossipMinTtl = 60 -- minimum TTL for offline gossip events
88+offlineGossipMinTtl = 60
142−maxFederationConcurrency = 10 -- max concurrent outbound federation requests per cycle
143−maxForwardRetriesPerServer = 100
144−maxForwardRetries = 10 -- max retries per individual forward entry before dropping
89+maxForwardRetries = 10
145−maxAckRetries = 10 -- max retries per ack entry before dropping to deliveredIds
90+maxAckRetries = 10
146−maxGossipHops = 5 -- max hops a gossip event can propagate across servers
91+maxGossipHops = 5
147−maxThirdPartyGossipHops = 2 -- max re-broadcast hops for relayed (third-party) gossip events
148−gossipOriginHops = 2 -- hops set when this server originates a gossip event
92+gossipOriginHops = 2
149−gossipDedupWindow : Int<Ms>
93+
150−gossipDedupWindow = 60000 -- suppress re-broadcast of identical gossip events within this window
151−maxRecentGossip = 1000
152−-- Exponential backoff for failed federation forwards
153retryBackoffBase : Int<Ms>
94retryBackoffBase : Int<Ms>
154−retryBackoffBase = 30000 -- 30 seconds
95+retryBackoffBase = 30000
155retryBackoffMax : Int<Ms>
96retryBackoffMax : Int<Ms>
156−retryBackoffMax = 480000 -- 8 minutes
97+retryBackoffMax = 480000
157−maxForwardFailures = 1000 -- max tracked server failure records
98+
158−maxServerDowntime : Int<Ms>
99+verificationTokenExpiry : Int<Ms>
159−maxServerDowntime = 86400000 -- 24 hours; stop retrying a server after this duration of consecutive failures
100+verificationTokenExpiry = 30000
160−-- Federation in-flight tracking: skip servers with outstanding requests older than this threshold
101+maxPendingVerifications = 10000
161federationFetchTimeoutMs : Int<Ms>
103federationFetchTimeoutMs : Int<Ms>
162−federationFetchTimeoutMs = 30000 -- 30 seconds; consider server unresponsive if fetch hasn't returned
104+federationFetchTimeoutMs = 30000
163−-- Verify callback latency threshold: warn when federation verify round-trips exceed this.
164−-- Shorter than federationFetchTimeoutMs because verify is a single lightweight POST
165−-- (no payload); slow verifies indicate network issues or overloaded peers.
166−federationVerifyTimeoutMs : Int<Ms>
167−federationVerifyTimeoutMs = 10000 -- 10 seconds
168−maxFederationInFlight = 100
169−-- Federation circuit breaker: pause all outbound federation when this many unique peer
170−-- servers have active (non-expired) failure records. Prevents wasted retries and log spam
171−-- when the local network is down. Set to 0 to disable.
172−federationCircuitBreakerThreshold = 3
173−-- Federation replay dedup: track recent (server, timestamp) pairs to reject exact replays
174−maxRecentFederationRequests = 1000
175−-- Forward nonce dedup: tracks (messageId, toKey) pairs to catch replays
176−-- beyond the lifetime of messages/ackedIds/deliveredIds
177−maxForwardNonces = 100000
178−maxNoncesPerBucket = maxForwardNonces / 16 + 1 -- per-bucket cap for 16-way sharded nonces
179−forwardNonceRetention : Int<Ms>
180−forwardNonceRetention = messageMaxAge * 2 -- 60 days; extends 30 days beyond message dedup
181−-- Message reconciliation: full scan runs every Nth prune cycle or when cheap drift check detects mismatch.
182−-- Cheap check (sum rcBucket totals vs totalMessageCount) runs every cycle; full scan only when needed.
183−reconciliationFullCycleInterval = 50 -- full reconciliation every 50th prune cycle (~25 min)
184−-- Cheap drift threshold: only trigger full message reconciliation when the cheap check
185−-- (sum of rcBucket totals vs totalMessageCount) exceeds this threshold. Small drifts from
186−-- concurrent bucket pruning self-correct on the next cycle. 0 = always reconcile on drift.
187−reconciliationDriftThreshold = 10
188−-- Lightweight reconciliation interval: presence/session/forward counter reconciliation
189−-- runs every Nth prune cycle. Between cycles, cached counters are trusted. Message
190−-- reconciliation has its own interval (reconciliationFullCycleInterval).
191−lightReconciliationInterval = 5
193−-- Federation latency metric window
194−federationLatencyWindowMs : Int<Ms>
195−federationLatencyWindowMs = 300000 -- 5 minutes; reset latency metrics after this interval
197−-- Federation latency histogram thresholds (ms). Counts how many calls fell into each bucket:
198−-- [0, t1), [t1, t2), [t2, t3), [t3, +inf). Operators use these to approximate P95/P99.
199−federationLatencyT1 : Int<Ms>
200−federationLatencyT1 = 100 -- fast (local network / same datacenter)
201−federationLatencyT2 : Int<Ms>
202−federationLatencyT2 = 500 -- normal (cross-region)
203−federationLatencyT3 : Int<Ms>
204−federationLatencyT3 = 2000 -- slow (degraded or distant peer)
206−-- Server build version: included in /health and /stats responses for deployment verification.
207−-- Update this string when deploying a new build so operators can confirm which version is running.
208−serverBuildVersion = "2026-04-26g"
210−-- Federation protocol version: included in gossip/forward/ack requests.
211−-- Peers log warnings when they receive requests from older versions.
212−-- Backward compatible: older peers ignore unknown fields (Knot's JSON parser
213−-- drops unknown keys). 0 = pre-versioning peer (field missing or unset).
214−federationProtocolVersion = 15
216−-- Max seenBy list length in gossip events (bounds memory and bandwidth per event)
219−-- Per-peer gossip event volume limiting (prevents flooding via large batches of unique pubkeys)
220−maxGossipEventsPerServer = 500 -- max total gossip events per server per window
221−gossipEventRateWindowMs : Int<Ms>
222−gossipEventRateWindowMs = 60000 -- 1 minute
223−maxGossipEventRateEntries = 100
224−-- Gossip batch backoff: when a single gossip request carries more than this many fresh events,
225−-- delay re-broadcast by a random interval up to gossipBatchBackoffMs. Prevents amplification
226−-- storms when peers recover from downtime and send bursts of presence updates.
227−gossipBatchBackoffThreshold = 50
228−gossipBatchBackoffMs : Int<Ms>
229−gossipBatchBackoffMs = 5000 -- max random delay before re-gossiping large batches
230−-- Global federation connection cap (bounds total concurrent outbound connections across all paths)
231−maxGlobalFederationConcurrency = 30
232−-- Peer blocklist: max blocked servers tracked at runtime (managed via /maintenance/block, /maintenance/unblock)
233−maxBlockedPeers = 100
234−-- Peer allowlist: when non-empty, only these servers can federate with us (managed via /maintenance/allow, /maintenance/unallow)
235−maxAllowedPeers = 100
237−-- Drain timeout: max time for drain flush operations before force-completing
238−drainTimeoutMs : Int<Ms>
239−drainTimeoutMs = 120000 -- 2 minutes; covers forward retries + ack sends + gossip + in-flight wait
240−-- Background task intervals
241backgroundPruneInterval : Int<Ms>
106backgroundPruneInterval : Int<Ms>
242−backgroundPruneInterval = 30000 -- 30 seconds; also retries failed forwards/acks
107+backgroundPruneInterval = 30000
243pollTimeoutMs : Int<Ms>
108pollTimeoutMs : Int<Ms>
244−pollTimeoutMs = 25000 -- long-poll heartbeat interval (how long a poll blocks before returning empty)
109+pollTimeoutMs = 25000
245−maxPollsPerKey = 3 -- max concurrent long-poll connections per pubkey
110+maxPollsPerKey = 3
246maxActivePolls = 5000
111maxActivePolls = 5000
247maxWatchKeys = 50
112maxWatchKeys = 50
248presenceRefreshInterval : Int<Ms>
113presenceRefreshInterval : Int<Ms>
249−presenceRefreshInterval = 300000 -- 5 minutes
114+presenceRefreshInterval = 300000
250−-- Refresh entries expiring within 1.5 refresh intervals. At 2x, entries with 8-10 min
115+
251−-- remaining would be refreshed every cycle (wasteful gossip). 1.5x catches entries
252−-- likely to expire before the next refresh without over-refreshing healthy ones.
253−presenceRefreshThreshold : Int<Ms>
254−presenceRefreshThreshold = presenceRefreshInterval + presenceRefreshInterval / 2
255−federationEnabled = True {}
256−-- WARNING: DNS rebinding risk — federationUrl resolves DNS at fetch time, not at
257−-- ServerName validation time. A hostname passing isBadServerName could rebind to a
258−-- private IP between validation and fetch. Mitigate at the network layer (e.g.,
259−-- firewall rules blocking outbound connections to RFC1918 ranges from the server process).
260−-- TODO: If Knot adds a resolved-IP introspection API (e.g., fetchWithResolvedIp),
261−-- validate the resolved IP against isBadServerName before completing the request.
262−federationUrl = \server -> federationScheme ++ server
263−-- Callback verification: outbound federation requests include a random single-use token;
264−-- the receiver calls back to /federation/verify to confirm the sender actually issued it.
265−maxPendingVerifications = 10000
266−verificationTokenExpiry : Int<Ms>
267−verificationTokenExpiry = 30000 -- 30 seconds
268−-- Peer public key cache (for Ed25519 federation signing)
269−maxPeerPublicKeys = 100
270−peerKeyTtlMs : Int<Ms>
271−peerKeyTtlMs = 86400000 -- 24 hours; peer keys change rarely (server restart or rotation)
272−peerKeyRefetchCooldownMs : Int<Ms>
273−peerKeyRefetchCooldownMs = 60000 -- 1 minute; minimum interval between re-fetch attempts per server
274−-- Require ClientIp header on auth requests. When True, challenge requests with
275−-- empty clientIp are rejected. Prevents unbound sessions if the reverse proxy is
276−-- temporarily misconfigured (no ClientIp header forwarding). Sessions created without
277−-- IP binding permanently accept requests from any IP.
278−requireClientIp = True {}
279−-- IP-based rate limiting (reverse proxy sets ClientIp header)
280−maxIpRatePerIp = 10 -- max auth requests per IP per window
281−ipRateWindowMs : Int<Ms>
282−ipRateWindowMs = 1000
283−maxIpRateEntries = 5000
284−-- Per-IP unique key tracking (detects key-rotation abuse: single IP authenticating many distinct pubkeys)
285−maxUniqueKeysPerIp = 20 -- max distinct pubkeys per IP per window before throttling
286−uniqueKeyIpWindowMs : Int<Ms>
287−uniqueKeyIpWindowMs = 60000 -- 1 minute
288−maxUniqueKeyIpEntries = 5000
289−-- Lookup rate limiting (per-key, on presence lookups)
290−maxLookupRatePerKey = 5 -- max lookups per key per window
291−lookupRateWindowMs : Int<Ms>
292−lookupRateWindowMs = 1000
293−maxLookupRateEntries = 1000
294−-- Client write operation rate limiting (per-key, on ack/delete — separate from read-only lookups)
295−maxClientWriteRatePerKey = 10 -- max ack/delete requests per key per window
296−clientWriteRateWindowMs : Int<Ms>
297−clientWriteRateWindowMs = 1000
298−maxClientWriteRateEntries = 1000
299−-- Federation verify rate limiting (per-IP, tighter than general IP rate)
300−maxVerifyRatePerIp = 5 -- max verify requests per IP per window
301−verifyRateWindowMs : Int<Ms>
302−verifyRateWindowMs = 1000
303−maxVerifyRateEntries = 1000
304−-- Unacked message aging (messages pruned after this regardless of ack status)
305unackedMessageMaxAge : Int<Ms>
116unackedMessageMaxAge : Int<Ms>
306−unackedMessageMaxAge = 604800000 -- 7 days
117+unackedMessageMaxAge = 604800000
307−-- Minimum sender-specified message TTL (prevents abuse with ultra-short TTLs that
308−-- expire before the recipient can poll). 0 in the request = use unackedMessageMaxAge.
309minMessageTtl : Int<Ms>
118minMessageTtl : Int<Ms>
310−minMessageTtl = 60000 -- 1 minute
119+minMessageTtl = 60000
311−-- Grace period before federation ack can delete the original message (allows local client to poll)
312ackGracePeriod : Int<Ms>
120ackGracePeriod : Int<Ms>
313−ackGracePeriod = 120000 -- 2 minutes; allows clients on slow connections or backgrounded apps
121+ackGracePeriod = 120000
314−-- to poll before federation ack reclaims the origin message
122+
315−-- Deferred ack cleanup capacity
123+federationProtocolVersion = 15
316−maxPendingAckCleanups = 10000
124+serverBuildVersion = "2026-04-27-simple"
317−-- Per-key deferred ack cleanup cap (prevents one noisy key from dominating the queue)
125+
318−maxPendingAckCleanupsPerKey = 100
126+federationEnabled = True {}
319−
127+federationUrl = \server -> federationScheme ++ server
320−-- Message expiration notifications: track expired locally-originated messages so senders
128+requireClientIp = True {}
321−-- can learn their message was never read (returned in poll response).
322−maxSenderExpirations = 10000
323−maxSenderExpirationsPerKey = 100
324−-- Delivery receipts: track when a locally-originated message is polled/acked by the recipient
325−-- so senders can learn their message was delivered (returned in poll response).
326−maxSenderDeliveries = 10000
327−maxSenderDeliveriesPerKey = 100
328−-- Cancel notifications: track when a message is retracted so the recipient can remove it from their UI.
329−-- Populated when /messages/cancel, /federation/cancel, or /federation/cancel-batch succeeds.
330−maxCancelNotifications = 10000
331−maxCancelNotificationsPerKey = 100
332−-- Max pubkeys in a batch lookup request
333−maxBatchLookupKeys = 50
334−-- Max per-sender drop counter entries (bounds memory for per-sender receipt/expiration drop tracking)
335−maxDroppedCountEntries = 1000
336−-- Max pending federation cancel entries (bounds memory for cancel retry queue)
337−maxPendingCancels = 10000
338−-- Max retries per cancel entry before dropping (uses same backoff as forward retries)
339−maxCancelRetries = 10
341−-- Verify callback caching: cache successful verifications per-server to reduce
342−-- outbound HTTP calls. A peer sending N requests/second forces N verify callbacks;
343−-- caching the success for a short window amortizes the cost.
344−-- Adaptive: scales from verificationCacheMinMs to verificationCacheMaxMs based on
345−-- recent request volume from the peer (higher volume = longer cache = fewer callbacks).
346−verificationCacheMinMs : Int<Ms>
347−verificationCacheMinMs = 2000 -- 2 seconds; base cache for low-traffic peers
348−verificationCacheMaxMs : Int<Ms>
349−verificationCacheMaxMs = 10000 -- 10 seconds; max cache for high-traffic peers
350−maxVerificationCache = 100
351−-- Health endpoint rate limiting (global, since /health has no clientIp)
352−maxHealthRate = 100 -- max health checks per window
353−healthRateWindowMs : Int<Ms>
354−healthRateWindowMs = 1000
355−-- Health check thresholds (background task freshness)
356−healthPruneMaxAge : Int<Ms>
357−healthPruneMaxAge = backgroundPruneInterval * 3
358−healthHeartbeatMaxAge : Int<Ms>
359−healthHeartbeatMaxAge = pollTimeoutMs * 3
360−healthWatchdogMaxAge : Int<Ms>
361−healthWatchdogMaxAge = backgroundPruneInterval * 15 -- watchdog runs every ~5 prune intervals
362−-- Forward queue age health threshold: flag unhealthy when multiple destination servers
363−-- have pending forwards older than this. A single stuck peer shouldn't mark the whole
364−-- server unhealthy — only widespread queue buildup indicates a systemic problem.
365−healthForwardQueueMaxAge : Int<Ms>
366−healthForwardQueueMaxAge = retryBackoffMax * 3 -- ~24 minutes; 3x max backoff gives retries time to succeed
367−-- Minimum number of destination servers with stale queues before flagging unhealthy.
368−-- 1 = old behavior (any stale server triggers unhealthy). 2+ = tolerate isolated peer issues.
369−healthForwardQueueMinStaleServers = 2
371-- ============================================
130-- ============================================
373-- ============================================
132-- ============================================
375−-- Event delivered to a polling client: an encrypted message blob
376type PollEvent = {id: MessageIdHex, eventType: Text, payload: {encryptedBlob: BlobHex, timestamp: Timestamp, toKey: PubkeyHex, expiresAt: Timestamp}}
134type PollEvent = {id: MessageIdHex, eventType: Text, payload: {encryptedBlob: BlobHex, timestamp: Timestamp, toKey: PubkeyHex, expiresAt: Timestamp}}
378−-- Gossip events propagate presence changes between federated servers
379data GossipEventType = GossipOnline {} | GossipOffline {} | GossipUnknown {}
136data GossipEventType = GossipOnline {} | GossipOffline {} | GossipUnknown {}
381impl ToJSON GossipEventType where
138impl ToJSON GossipEventType where
@@ -391,18 +148,8 @@ impl FromJSON GossipEventType where
391 else if s == "offline" then GossipOffline {}
148 else if s == "offline" then GossipOffline {}
392 else GossipUnknown {}
149 else GossipUnknown {}
394−-- Wire format for gossip events sent between servers
395−-- seenBy: list of server names that have already received this event.
396−-- Used to suppress redundant re-broadcast: when re-gossiping, skip peers already in seenBy.
397−-- Pre-v11 peers send [] (Knot ignores unknown fields on parse, sends [] for missing lists).
398type GossipEvent = {eventType: GossipEventType, pubkey: PubkeyHex, server: ServerName, timestamp: Timestamp, ttl: Int<S>, seenBy: [Text]}
151type GossipEvent = {eventType: GossipEventType, pubkey: PubkeyHex, server: ServerName, timestamp: Timestamp, ttl: Int<S>, seenBy: [Text]}
400−-- A gossip event that passed validation (timestamp not in future, TTL > 0, not expired)
401−type ValidGossipEntry = {pubkey: PubkeyHex, server: ServerName, expiresAt: Timestamp, timestamp: Timestamp, ttl: Int<S>}
403−-- Status returned to the sender after SendMessage
404−-- Delivered: recipient is online locally; Federated: forwarded to remote server;
405−-- Queued: stored but recipient location unknown; Unauthorized/Rejected: not accepted
406data MessageStatus = MsDelivered {} | MsFederated {} | MsQueued {} | MsUnauthorized {} | MsRejected {} | MsRateLimited {} | MsDuplicate {} | MsDraining {}
153data MessageStatus = MsDelivered {} | MsFederated {} | MsQueued {} | MsUnauthorized {} | MsRejected {} | MsRateLimited {} | MsDuplicate {} | MsDraining {}
408impl ToJSON MessageStatus where
155impl ToJSON MessageStatus where
@@ -416,7 +163,6 @@ impl ToJSON MessageStatus where
416 MsDuplicate {} -> "duplicate"
163 MsDuplicate {} -> "duplicate"
417 MsDraining {} -> "draining")
164 MsDraining {} -> "draining")
419−-- Validated hex-encoded types with maximum length constraints
420isValidBoundedHex : Int -> Text -> Bool
166isValidBoundedHex : Int -> Text -> Bool
421isValidBoundedHex = \maxLen s -> not (tooLong s maxLen) && isValidHex s && s == normalizeHex s
167isValidBoundedHex = \maxLen s -> not (tooLong s maxLen) && isValidHex s && s == normalizeHex s
422type PubkeyHex = Text where isValidBoundedHex maxPubkeyLen
168type PubkeyHex = Text where isValidBoundedHex maxPubkeyLen
@@ -426,8 +172,6 @@ isValidMessageId : Text -> Bool
426isValidMessageId = isValidBoundedHex maxMessageIdLen
172isValidMessageId = isValidBoundedHex maxMessageIdLen
427type MessageIdHex = Text where isValidMessageId
173type MessageIdHex = Text where isValidMessageId
428type OptionalMessageId = Text where \s -> s == "" || isValidMessageId s
174type OptionalMessageId = Text where \s -> s == "" || isValidMessageId s
429−-- ServerName: validated server hostname (rejects private IPs, localhost, etc.)
430−-- AnyServerName: normalized server name without the security checks (used in presence lookups)
431isValidServerName : Text -> Bool
175isValidServerName : Text -> Bool
432isValidServerName = \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s)
176isValidServerName = \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s)
433type ServerName = Text where isValidServerName
177type ServerName = Text where isValidServerName
@@ -435,642 +179,87 @@ type AnyServerName = Text where \s -> not (tooLong s maxServerNameLen) && s == n
436type Timestamp = Int<Ms>
180type Timestamp = Int<Ms>
438−-- Pending challenge for Ed25519 challenge-response auth
439type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp, ip: Text}
182type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp, ip: Text}
440−-- Authenticated session; token is a random hex string
441type Session = {token: Text, pubkey: PubkeyHex, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}
183type Session = {token: Text, pubkey: PubkeyHex, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}
442−-- Stored message; originServer is "" for locally-originated messages, set to sender server for federated forwards.
443−-- Messages with expiresAt <= now are pruned and excluded from polls.
444−-- senderKey: pubkey of the authenticated sender (locally-originated only; "" for federation forwards).
445−-- Used by /messages/cancel to verify the caller is the actual sender.
446−-- priority: 0 = normal (default), higher = more urgent. High-priority messages are
447−-- forwarded first during federation retries. Clamped to [0, 10] on ingress.
448type Message = {messageId: MessageIdHex, toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: Text, receivedAt: Timestamp, expiresAt: Timestamp, senderKey: Text, priority: Int}
184type Message = {messageId: MessageIdHex, toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: Text, receivedAt: Timestamp, expiresAt: Timestamp, senderKey: Text, priority: Int}
449−-- Presence: tracks that a pubkey is online at a given server, with expiry
450type PresenceEntry = {pubkey: PubkeyHex, server: AnyServerName, expiresAt: Timestamp, timestamp: Timestamp}
185type PresenceEntry = {pubkey: PubkeyHex, server: AnyServerName, expiresAt: Timestamp, timestamp: Timestamp}
451−-- Queued federation forward: message waiting to be delivered to a remote server.
452−-- senderKey: pubkey of the authenticated sender (locally-originated only; "" for federation relays).
453−-- Used by fedDeliveryReceipts to generate delivery receipts even if the original message was pruned.
454type ForwardEntry = {messageId: MessageIdHex, toServer: ServerName, createdAt: Timestamp, toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: Text, retries: Int, expiresAt: Timestamp, priority: Int, senderKey: Text}
186type ForwardEntry = {messageId: MessageIdHex, toServer: ServerName, createdAt: Timestamp, toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: Text, retries: Int, expiresAt: Timestamp, priority: Int, senderKey: Text}
455−-- Tracks message IDs that were acked by a polling client, pending federation ack back to origin
456type AckedEntry = {messageId: MessageIdHex, toKey: PubkeyHex, ackedAt: Timestamp, originServer: ServerName, retries: Int}
187type AckedEntry = {messageId: MessageIdHex, toKey: PubkeyHex, ackedAt: Timestamp, originServer: ServerName, retries: Int}
457−-- Terminal state: message delivered and ack confirmed (used for dedup after ack overflow)
458type DeliveredEntry = {messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}
188type DeliveredEntry = {messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}
459−-- Tracks consecutive failures per federation peer for exponential backoff
460type ForwardFailure = {server: Text, failedAt: Timestamp, failures: Int, firstFailedAt: Timestamp}
189type ForwardFailure = {server: Text, failedAt: Timestamp, failures: Int, firstFailedAt: Timestamp}
461−-- Sliding-window rate limit state per pubkey.
190+type RateEntry = {key: Text, windowStart: Timestamp, count: Int}
462−-- prevCount: count from the previous window, used for sliding-window interpolation.
463−-- Effective count = prevCount * (1 - elapsed/windowMs) + count, preventing 2x burst at window boundaries.
464−type SendRateEntry = {pubkey: PubkeyHex, windowStart: Timestamp, count: Int, prevCount: Int}
465−type RecvRateEntry = {pubkey: PubkeyHex, windowStart: Timestamp, count: Int, prevCount: Int}
466−type PairRateEntry = {sender: PubkeyHex, recipient: PubkeyHex, windowStart: Timestamp, count: Int, prevCount: Int}
467−type ChallengeRateEntry = {pubkey: PubkeyHex, windowStart: Timestamp, count: Int, prevCount: Int}
468−-- Sliding-window rate limit state per federation peer server
469−type FederationRateEntry = {server: Text, windowStart: Timestamp, count: Int, prevCount: Int}
470−type FederationPairRateEntry = {server: Text, recipient: PubkeyHex, windowStart: Timestamp, count: Int, prevCount: Int}
471−-- Tracks active long-poll connections to enforce per-key concurrency limits
472type ActivePoll = {pubkey: PubkeyHex, startedAt: Timestamp}
191type ActivePoll = {pubkey: PubkeyHex, startedAt: Timestamp}
473data AuthResult = Authorized {pubkey: PubkeyHex, ip: Text} | Unauthorized {}
192data AuthResult = Authorized {pubkey: PubkeyHex, ip: Text} | Unauthorized {}
474−data ForwardResult = ForwardDuplicate {} | ForwardRejected {} | ForwardStored {}
476−type IpRateEntry = {ip: Text, windowStart: Timestamp, count: Int, prevCount: Int}
477−type LookupRateEntry = {pubkey: PubkeyHex, windowStart: Timestamp, count: Int, prevCount: Int}
478−-- Tracks recently re-broadcast gossip events to suppress amplification from duplicate cycles
479−type RecentGossipEntry = {pubkey: PubkeyHex, server: Text, timestamp: Timestamp, seenAt: Timestamp}
480−type PeerStatus = {server: Text, failures: Int, lastFailedAt: Timestamp, firstFailedAt: Timestamp, backoffMs: Int, retriable: Bool, pendingForwards: Int, avgLatencyMs: Int, maxLatencyMs: Int, latencySamples: Int, gossipEventsPerMin: Int}
481−type KeyPresenceEntry = {server: Text, expiresAt: Timestamp}
482−type RecipientCount = {pubkey: PubkeyHex, count: Int}
483−type FederationInFlightEntry = {server: Text, count: Int, firstStartedAt: Timestamp}
484−-- Tracks recent federation request (server, timestamp) pairs for replay detection
485−type RecentFederationRequest = {server: Text, timestamp: Timestamp, seenAt: Timestamp}
486−type GossipEventRateEntry = {server: Text, windowStart: Timestamp, count: Int, prevCount: Int}
487−-- Tracks unique pubkeys authenticated per IP (key-rotation abuse detection)
488−type UniqueKeyIpEntry = {ip: Text, keys: [PubkeyHex], windowStart: Timestamp}
490−-- Forward nonce for extended replay protection
194+type SenderExpiration = {senderKey: Text, messageId: MessageIdHex, toKey: PubkeyHex, expiredAt: Timestamp}
491−type ForwardNonce = {messageId: MessageIdHex, toKey: PubkeyHex, seenAt: Timestamp}
195+type SenderDelivery = {senderKey: Text, messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}
196+type CancelNotification = {toKey: PubkeyHex, messageId: MessageIdHex, cancelledAt: Timestamp}
197+type PendingFederationCancel = {messageId: MessageIdHex, toKey: PubkeyHex, toServer: ServerName, createdAt: Timestamp, retries: Int}
494type BatchMessage = {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int}
199type BatchMessage = {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int}
495type BatchResult = {messageId: OptionalMessageId, status: MessageStatus}
200type BatchResult = {messageId: OptionalMessageId, status: MessageStatus}
497−-- Batch cancel types
498type BatchCancelEntry = {messageId: MessageIdHex, to: PubkeyHex}
202type BatchCancelEntry = {messageId: MessageIdHex, to: PubkeyHex}
499type BatchCancelResult = {messageId: MessageIdHex, cancelled: Bool}
203type BatchCancelResult = {messageId: MessageIdHex, cancelled: Bool}
501−-- Pending federation cancel: queued when /messages/cancel or /messages/cancel-batch
502−-- fails to deliver a cancel to a remote server. Retried during the prune cycle.
503−type PendingFederationCancel = {messageId: MessageIdHex, toKey: PubkeyHex, toServer: ServerName, createdAt: Timestamp, retries: Int}
505−-- Sender expiration notification: tracks when a locally-originated message expired unread.
506−-- Pruned after messageMaxAge. Included in the sender's next poll response.
507−type SenderExpiration = {senderKey: Text, messageId: MessageIdHex, toKey: PubkeyHex, expiredAt: Timestamp}
509−-- Sender delivery receipt: tracks when a locally-originated message was polled/acked by
510−-- the recipient. Included in the sender's next poll response for delivery confirmation.
511−-- Only for locally-originated messages (senderKey != ""); federated messages have no senderKey.
512−type SenderDelivery = {senderKey: Text, messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}
514−-- Cancel notification: tracks when a message was retracted by the sender. Delivered to
515−-- the recipient via their next poll response so clients can remove the message from the UI.
516−-- Keyed by toKey (recipient). cancelledAt is when the cancel was processed on this server.
517−type CancelNotification = {toKey: PubkeyHex, messageId: MessageIdHex, cancelledAt: Timestamp}
519-- ============================================
205-- ============================================
520−-- Persisted State
206+-- Persisted State (all flat lists, no sharding)
521-- ============================================
207-- ============================================
522−-- All state is in-memory (no disk persistence). Prefixed with * (mutable refs).
523−-- Atomic blocks provide transactional consistency for reads + writes.
525*challenges : [Challenge]
209*challenges : [Challenge]
526−
210+*sessions : [Session]
527−-- Sessions sharded into 16 buckets by first hex char of token.
211+*messages : [Message]
528−-- Hot-path auth scans only one bucket (~1/16 of sessions).
212+*presence : [PresenceEntry]
529−-- TODO: If Knot adds indexed arrays or maps, replace the 16 manual bucket
530−-- refs and their if-else dispatch chains with a single indexed collection.
531−-- This would eliminate ~1500 lines of mechanical boilerplate:
532−-- - 10 sharded collections (sessions, messages, presence, forwards, acked,
533−-- delivered, nonces, recipientCounts, messageSignals, fwdBuckets)
534−-- - Each has: 16 mutable refs, read/write/readAll/writeAll/countAll/transform functions
535−-- - writeAll* functions share an identical 16-way partition fold pattern
536−-- - The partition fold and 16-write pattern could become: partitionByBucket items getKey writeBucket
537−*sessionBucket0 : [Session]
538−*sessionBucket1 : [Session]
539−*sessionBucket2 : [Session]
540−*sessionBucket3 : [Session]
541−*sessionBucket4 : [Session]
542−*sessionBucket5 : [Session]
543−*sessionBucket6 : [Session]
544−*sessionBucket7 : [Session]
545−*sessionBucket8 : [Session]
546−*sessionBucket9 : [Session]
547−*sessionBucket10 : [Session]
548−*sessionBucket11 : [Session]
549−*sessionBucket12 : [Session]
550−*sessionBucket13 : [Session]
551−*sessionBucket14 : [Session]
552−*sessionBucket15 : [Session]
554−-- Messages sharded into 16 buckets by first hex char of recipient pubkey (toKey).
555−-- Hot-path operations (poll, send, ack) scan only one bucket (~1/16 of messages).
556−*messageBucket0 : [Message]
557−*messageBucket1 : [Message]
558−*messageBucket2 : [Message]
559−*messageBucket3 : [Message]
560−*messageBucket4 : [Message]
561−*messageBucket5 : [Message]
562−*messageBucket6 : [Message]
563−*messageBucket7 : [Message]
564−*messageBucket8 : [Message]
565−*messageBucket9 : [Message]
566−*messageBucket10 : [Message]
567−*messageBucket11 : [Message]
568−*messageBucket12 : [Message]
569−*messageBucket13 : [Message]
570−*messageBucket14 : [Message]
571−*messageBucket15 : [Message]
573−*totalMessageCount : Int
575−-- Presence sharded into 16 buckets by first hex char of pubkey.
576−-- Hot-path operations (send, lookup, poll) scan only one bucket (~1/16 of entries).
577−*presenceBucket0 : [PresenceEntry]
578−*presenceBucket1 : [PresenceEntry]
579−*presenceBucket2 : [PresenceEntry]
580−*presenceBucket3 : [PresenceEntry]
581−*presenceBucket4 : [PresenceEntry]
582−*presenceBucket5 : [PresenceEntry]
583−*presenceBucket6 : [PresenceEntry]
584−*presenceBucket7 : [PresenceEntry]
585−*presenceBucket8 : [PresenceEntry]
586−*presenceBucket9 : [PresenceEntry]
587−*presenceBucket10 : [PresenceEntry]
588−*presenceBucket11 : [PresenceEntry]
589−*presenceBucket12 : [PresenceEntry]
590−*presenceBucket13 : [PresenceEntry]
591−*presenceBucket14 : [PresenceEntry]
592−*presenceBucket15 : [PresenceEntry]
594−*totalPresenceCount : Int
596−-- Cached set of known peer server names (updated on prune and gossip, avoids full presence scans)
597−*knownPeerServers : [Text]
599−-- Monotonic counter ensuring unique receivedAt ordering even within the same millisecond
600−*seqCounter : Timestamp
602−-- Forwards sharded into 16 buckets by pubkeyBucket(toKey).
603−-- Hot-path operations (sendMessageCore dedup, ackPolledMessages) scan one bucket.
604−*fwdBucket0 : [ForwardEntry]
213+*forwards : [ForwardEntry]
605−*fwdBucket1 : [ForwardEntry]
606−*fwdBucket2 : [ForwardEntry]
607−*fwdBucket3 : [ForwardEntry]
608−*fwdBucket4 : [ForwardEntry]
609−*fwdBucket5 : [ForwardEntry]
610−*fwdBucket6 : [ForwardEntry]
611−*fwdBucket7 : [ForwardEntry]
612−*fwdBucket8 : [ForwardEntry]
613−*fwdBucket9 : [ForwardEntry]
614−*fwdBucket10 : [ForwardEntry]
615−*fwdBucket11 : [ForwardEntry]
616−*fwdBucket12 : [ForwardEntry]
617−*fwdBucket13 : [ForwardEntry]
618−*fwdBucket14 : [ForwardEntry]
619−*fwdBucket15 : [ForwardEntry]
621−*totalForwardCount : Int
623−-- Messages acked by local recipients, pending federation ack to origin server.
624−-- Sharded into 16 buckets by pubkeyBucket(toKey) for O(n/16) dedup in sendMessageCore.
625−*ackedBucket0 : [AckedEntry]
214+*ackedIds : [AckedEntry]
626−*ackedBucket1 : [AckedEntry]
215+*deliveredIds : [DeliveredEntry]
627−*ackedBucket2 : [AckedEntry]
628−*ackedBucket3 : [AckedEntry]
629−*ackedBucket4 : [AckedEntry]
630−*ackedBucket5 : [AckedEntry]
631−*ackedBucket6 : [AckedEntry]
632−*ackedBucket7 : [AckedEntry]
633−*ackedBucket8 : [AckedEntry]
634−*ackedBucket9 : [AckedEntry]
635−*ackedBucket10 : [AckedEntry]
636−*ackedBucket11 : [AckedEntry]
637−*ackedBucket12 : [AckedEntry]
638−*ackedBucket13 : [AckedEntry]
639−*ackedBucket14 : [AckedEntry]
640−*ackedBucket15 : [AckedEntry]
642−*lastPrunedAt : Timestamp
644*forwardFailures : [ForwardFailure]
216*forwardFailures : [ForwardFailure]
646−*sendRates : [SendRateEntry]
648−*lastPresenceRefresh : Timestamp
650−-- Round-robin presence refresh: tracks which bucket group (0-3) to scan next.
651−-- Each refresh cycle scans 4 buckets (0-3, 4-7, 8-11, 12-15), cycling through
652−-- all 16 over 4 refresh intervals. Spreads gossip traffic across prune cycles.
653−-- NOTE: group only advances when shouldRefresh is true (enough time passed since
654−-- lastPresenceRefresh), so skipped/delayed prune cycles don't cause bucket gaps.
655−*presenceRefreshGroup : Int
657−-- Round-robin nonce pruning: tracks which bucket group (0-3) to scan next.
658−-- Each prune cycle scans 4 of 16 nonce buckets, cycling through all 16 over 4 cycles.
659−-- Nonces have 60-day retention so 30-second pruning granularity is unnecessary.
660−*noncePruneGroup : Int
662−*challengeRates : [ChallengeRateEntry]
664−-- Separate revoke rate limiter (prevents challenge floods from exhausting revoke budget)
665−*revokeRates : [ChallengeRateEntry]
667−-- Heartbeat signal: incremented periodically to wake all blocking long-polls
668−*pollWakeup : Timestamp
670−-- Per-bucket message signals (16 buckets, keyed by first hex digit of pubkey).
671−-- Updated when a message is stored for a recipient; polls for that pubkey's
672−-- bucket watch for changes to avoid waking unrelated polls.
673−*messageSignal0 : Timestamp
674−*messageSignal1 : Timestamp
675−*messageSignal2 : Timestamp
676−*messageSignal3 : Timestamp
677−*messageSignal4 : Timestamp
678−*messageSignal5 : Timestamp
679−*messageSignal6 : Timestamp
680−*messageSignal7 : Timestamp
681−*messageSignal8 : Timestamp
682−*messageSignal9 : Timestamp
683−*messageSignal10 : Timestamp
684−*messageSignal11 : Timestamp
685−*messageSignal12 : Timestamp
686−*messageSignal13 : Timestamp
687−*messageSignal14 : Timestamp
688−*messageSignal15 : Timestamp
690*activePolls : [ActivePoll]
217*activePolls : [ActivePoll]
692−-- Overflow buffer: acks evicted from ackedIds before they could be sent to origin
219+*sendRates : [RateEntry]
693−*ackOverflow : [AckedEntry]
220+*recvRates : [RateEntry]
694−
221+*pairRates : [RateEntry]
695−-- Final dedup set: messages confirmed delivered (ack sent or overflow drained).
222+*challengeRates : [RateEntry]
696−-- Sharded into 16 buckets by pubkeyBucket(toKey) for O(n/16) dedup in sendMessageCore.
223+*lookupRates : [RateEntry]
697−*delivBucket0 : [DeliveredEntry]
224+*clientWriteRates : [RateEntry]
698−*delivBucket1 : [DeliveredEntry]
699−*delivBucket2 : [DeliveredEntry]
700−*delivBucket3 : [DeliveredEntry]
701−*delivBucket4 : [DeliveredEntry]
702−*delivBucket5 : [DeliveredEntry]
703−*delivBucket6 : [DeliveredEntry]
704−*delivBucket7 : [DeliveredEntry]
705−*delivBucket8 : [DeliveredEntry]
706−*delivBucket9 : [DeliveredEntry]
707−*delivBucket10 : [DeliveredEntry]
708−*delivBucket11 : [DeliveredEntry]
709−*delivBucket12 : [DeliveredEntry]
710−*delivBucket13 : [DeliveredEntry]
711−*delivBucket14 : [DeliveredEntry]
712−*delivBucket15 : [DeliveredEntry]
714−*federationRates : [FederationRateEntry]
225+*federationRates : [RateEntry]
715−
226+*ipRates : [RateEntry]
716−*federationPairRates : [FederationPairRateEntry]
718*globalRateCount : Int
228*globalRateCount : Int
719−*globalRatePrevCount : Int
721*globalRateWindowStart : Timestamp
229*globalRateWindowStart : Timestamp
230+*authGlobalRateCount : Int
231+*authGlobalRateWindowStart : Timestamp
723−-- Health endpoint rate limiting state (separate from global rate to avoid starving real requests)
233+*seqCounter : Timestamp
724−*healthRateCount : Int
234+*pollWakeup : Timestamp
725−*healthRateWindowStart : Timestamp
726−*healthRatePrevCount : Int
728−-- Background task cycle counters (exposed via /stats for health monitoring)
731−*heartbeatCount : Int
733−*startedAt : Timestamp
235+*lastPrunedAt : Timestamp
735*lastHeartbeatAt : Timestamp
236*lastHeartbeatAt : Timestamp
736−
237+*lastPresenceRefresh : Timestamp
737−-- Drain phase: 0=normal (accepting), 1=soft drain (block new auth, serve existing sessions),
238+*startedAt : Timestamp
738−-- 2=full drain (reject all client requests). Allows staged shutdown:
739−-- phase 1 lets active clients finish while preventing new connections.
742−-- Drain generation: monotonically increasing counter, bumped on each drain initiation.
743−-- Flush forks check this before writing to prevent stale drain operations (started before
744−-- an undrain+redrain cycle) from interfering with the current drain's state.
745−*drainGeneration : Int
747−-- Shutdown requested: when True, background loops exit after drain completes.
748−-- Set by /maintenance/shutdown; cannot be undone (requires process restart).
749−*shutdownRequested : Bool
751−*pruneRunning : Timestamp
753−*pruneGeneration : Int
755−-- Tracks the duration of the last completed prune cycle (ms) for dynamic stuck detection.
756−-- Updated after each successful prune. Initial 0 = use fixed 5x fallback.
757−*lastPruneDuration : Int<Ms>
759−*ipRates : [IpRateEntry]
761−*lookupRates : [LookupRateEntry]
763−-- Separate rate limiter for client write operations (ack, delete) — prevents ack bursts from starving lookups
764−*clientWriteRates : [LookupRateEntry]
766−*recvRates : [RecvRateEntry]
768−*pairRates : [PairRateEntry]
770−*recentGossip : [RecentGossipEntry]
772−*lastFederationSuccessAt : Timestamp
774−-- Per-recipient message counts sharded into 16 buckets by pubkeyBucket.
775−-- Each pubkey maps to exactly one bucket, so lookups scan ~1/16 of entries.
776−*rcBucket0 : [RecipientCount]
777−*rcBucket1 : [RecipientCount]
778−*rcBucket2 : [RecipientCount]
779−*rcBucket3 : [RecipientCount]
780−*rcBucket4 : [RecipientCount]
781−*rcBucket5 : [RecipientCount]
782−*rcBucket6 : [RecipientCount]
783−*rcBucket7 : [RecipientCount]
784−*rcBucket8 : [RecipientCount]
785−*rcBucket9 : [RecipientCount]
786−*rcBucket10 : [RecipientCount]
787−*rcBucket11 : [RecipientCount]
788−*rcBucket12 : [RecipientCount]
789−*rcBucket13 : [RecipientCount]
790−*rcBucket14 : [RecipientCount]
791−*rcBucket15 : [RecipientCount]
793−-- Tracks outstanding federation fetches per server (detects hung connections)
794−*federationInFlight : [FederationInFlightEntry]
796−-- Federation latency tracking (for /stats)
797−*federationLatencyTotal : Int<Ms>
798−*federationLatencyCount : Int
799−*federationLatencyMax : Int<Ms>
801−-- Federation latency histogram: counts calls in each bucket for percentile approximation.
802−-- Buckets: [0,T1), [T1,T2), [T2,T3), [T3,+inf). Reset with latency window.
803−*federationLatencyBucket0 : Int
804−*federationLatencyBucket1 : Int
805−*federationLatencyBucket2 : Int
806−*federationLatencyBucket3 : Int
808−-- Federation verify callback metrics (exposed in /stats, reset with latency window)
809−*slowVerifyCount : Int
810−*verifyFailCount : Int
812−-- Per-peer federation latency tracking: windowed average and max for /stats/peers.
813−-- Reset with the global federation latency window (federationLatencyWindowMs).
814−*peerLatencies : [{server: Text, totalMs: Int, count: Int, maxMs: Int, windowStart: Timestamp}]
815−maxPeerLatencyEntries = 100
817−-- Server instance generation (epoch timestamp, for cursor staleness detection)
818*serverGeneration : Int
239*serverGeneration : Int
820−-- Timestamp when drain federation ops completed (0 if in progress or not draining)
241+*drainPhase : Int
821*drainCompletedAt : Timestamp
242*drainCompletedAt : Timestamp
823−-- Last time federation latency metrics were reset (for windowed averages)
824−*federationLatencyResetAt : Timestamp
826−-- Suppresses latency metric recording during startup probe phase (prevents
827−-- unauthenticated probe results from skewing initial /stats readings)
828−*startupProbeActive : Bool
830−-- Total session count across all buckets (avoids O(16) recount on monitoring paths)
831−*totalSessionCount : Int
833−-- Auth-tier global rate limiting state
834−*authGlobalRateCount : Int
835−*authGlobalRatePrevCount : Int
836−*authGlobalRateWindowStart : Timestamp
838−-- Max concurrent background prune forks (prevents resource exhaustion from stuck recovery)
839−*activePruneForks : Int
841−-- Signal for drain timeout (set by forked timer, watched by STM retry in waitForInFlightDrain)
842−*drainTimedOut : Bool
844−-- Recent federation requests for replay detection (dedup by server+timestamp)
845−*recentFederationRequests : [RecentFederationRequest]
847−-- Pending verification tokens for federation callback auth (single-use, short-lived)
848−-- scope binds the token to a specific request type (gossip/forward/ack) to prevent cross-use
849*pendingVerifications : [{token: Text, createdAt: Timestamp, scope: Text}]
244*pendingVerifications : [{token: Text, createdAt: Timestamp, scope: Text}]
851−-- Forward nonce dedup sharded into 16 buckets by pubkeyBucket(toKey).
852−-- Reduces hot-path scan in handleForwardMessage from O(100k) to O(6k).
853−*nonceBucket0 : [ForwardNonce]
854−*nonceBucket1 : [ForwardNonce]
855−*nonceBucket2 : [ForwardNonce]
856−*nonceBucket3 : [ForwardNonce]
857−*nonceBucket4 : [ForwardNonce]
858−*nonceBucket5 : [ForwardNonce]
859−*nonceBucket6 : [ForwardNonce]
860−*nonceBucket7 : [ForwardNonce]
861−*nonceBucket8 : [ForwardNonce]
862−*nonceBucket9 : [ForwardNonce]
863−*nonceBucket10 : [ForwardNonce]
864−*nonceBucket11 : [ForwardNonce]
865−*nonceBucket12 : [ForwardNonce]
866−*nonceBucket13 : [ForwardNonce]
867−*nonceBucket14 : [ForwardNonce]
868−*nonceBucket15 : [ForwardNonce]
870−-- Nonce eviction replay protection: per-bucket cutoff tracking.
871−-- Each bucket independently tracks the seenAt of its oldest retained nonce after LRU
872−-- eviction. Forwards with timestamps older than the *bucket-specific* cutoff are rejected.
873−-- Previous design used a single global cutoff, which incorrectly rejected valid forwards:
874−-- bucket 3 evicting nonces from 5 min ago would set a cutoff that also rejected forwards
875−-- for bucket 12 (which might have nonces from 30 days ago, all retained).
876−-- 0 = no eviction has occurred in this bucket, accept all timestamps.
877−*nonceEvictionCutoff0 : Timestamp
878−*nonceEvictionCutoff1 : Timestamp
879−*nonceEvictionCutoff2 : Timestamp
880−*nonceEvictionCutoff3 : Timestamp
881−*nonceEvictionCutoff4 : Timestamp
882−*nonceEvictionCutoff5 : Timestamp
883−*nonceEvictionCutoff6 : Timestamp
884−*nonceEvictionCutoff7 : Timestamp
885−*nonceEvictionCutoff8 : Timestamp
886−*nonceEvictionCutoff9 : Timestamp
887−*nonceEvictionCutoff10 : Timestamp
888−*nonceEvictionCutoff11 : Timestamp
889−*nonceEvictionCutoff12 : Timestamp
890−*nonceEvictionCutoff13 : Timestamp
891−*nonceEvictionCutoff14 : Timestamp
892−*nonceEvictionCutoff15 : Timestamp
894−-- Federation verify per-IP rate limiting (tighter than general IP rate)
895−*verifyIpRates : [IpRateEntry]
897−-- Per-peer gossip event volume rate limiting
898−*gossipEventRates : [GossipEventRateEntry]
900−-- Global federation connection counter (tracks total concurrent outbound connections)
901−*federationActiveConnections : Int
903−-- Blocked federation peers (managed at runtime via /maintenance/block and /maintenance/unblock)
904−*blockedPeers : [Text]
906−-- Allowed federation peers (when non-empty, only these servers can federate with us)
907−-- Managed via /maintenance/allow and /maintenance/unallow. Empty = open federation.
908−*allowedPeers : [Text]
910−-- Deferred ack cleanups: origin message reclamation queued by federation ack handlers,
911−-- processed by the prune cycle after ackGracePeriod elapses (replaces fork+sleep pattern).
912−*pendingAckCleanups : [{messageId: MessageIdHex, toKey: PubkeyHex, cleanupAfter: Timestamp}]
914−-- Cached successful verify callbacks per-server (short-lived, reduces outbound HTTP calls)
915−*verificationCache : [{server: Text, scope: Text, verifiedAt: Timestamp}]
917−-- Cached peer Ed25519 public keys for signature-based federation auth.
918−-- Fetched from GET /federation/pubkey on first contact, cached with peerKeyTtlMs TTL.
919−-- failedAt tracks last failed fetch to enforce peerKeyRefetchCooldownMs.
920−*peerPublicKeys : [{server: Text, pubkey: Text, fetchedAt: Timestamp, failedAt: Timestamp}]
922−-- Per-IP unique key tracking: detects when a single IP authenticates many distinct pubkeys
923−-- (key-rotation abuse bypassing per-key rate limits). Pruned with other rate limiters.
924−*uniqueKeyIpRates : [UniqueKeyIpEntry]
926−-- Sender expiration notifications: messages that expired unread, queued for the sender's next poll.
927−-- Populated during prune for locally-originated messages (senderKey != "").
928*senderExpirations : [SenderExpiration]
246*senderExpirations : [SenderExpiration]
930−-- Sender delivery receipts: messages polled/acked by the recipient, queued for the sender's next poll.
931−-- Populated during ackPolledMessages and handleAckMessages for locally-originated messages.
932*senderDeliveries : [SenderDelivery]
247*senderDeliveries : [SenderDelivery]
934−-- Cancel notifications: messages retracted by the sender, queued for the recipient's next poll.
935−-- Populated during handleCancelMessage, handleFederationCancel, handleFederationBatchCancel.
936*cancelNotifications : [CancelNotification]
248*cancelNotifications : [CancelNotification]
938−-- Pending federation cancels: queued when cancel delivery to a remote server fails.
939−-- Retried during the prune cycle alongside forward retries and ack retries.
940*pendingFederationCancels : [PendingFederationCancel]
249*pendingFederationCancels : [PendingFederationCancel]
942−-- Per-sender drop counters: tracks how many delivery receipts / expiration notifications
943−-- were evicted before the sender could poll them. Keyed by senderKey so each sender sees
944−-- only their own drops (not a global counter that conflates all senders). Drained on poll.
945−*droppedDeliveryReceipts : [{senderKey: Text, count: Int, lastUpdated: Timestamp}]
946−*droppedExpirationNotifs : [{senderKey: Text, count: Int, lastUpdated: Timestamp}]
948−-- Maintenance secret: set via /maintenance/rotate-secret at startup.
949−-- When empty, maintenance and stats endpoints are disabled.
950*runtimeMaintenanceSecret : Text
251*runtimeMaintenanceSecret : Text
952−-- Runtime-configurable rate limit overrides (0 = use compile-time default).
253+*blockedPeers : [Text]
953−-- Adjusted via /maintenance/rate-limits POST endpoint without recompile+restart.
254+*allowedPeers : [Text]
954−*rateOverrideGlobalRequest : Int
255+
955−*rateOverrideIpRate : Int
256+*pruneCount : Int
956−*rateOverrideSendRate : Int
257+*heartbeatCount : Int
957−*rateOverrideFederationRate : Int
958−*rateOverrideAuthGlobal : Int
959−*rateOverrideRecvRate : Int
960−*rateOverrideChallengeRate : Int
961−*rateOverridePairRate : Int
962−*rateOverrideLookupRate : Int
963−*rateOverrideClientWriteRate : Int
965−-- Runtime-configurable operational parameter overrides (0 = use compile-time default).
966−-- Adjusted via /maintenance/config POST endpoint without recompile+restart.
967−*configOverrideMaxMessagesPerRecipient : Int
968−*configOverrideMaxGossipHops : Int
969−*configOverridePollTimeoutMs : Int
970−*configOverrideAckGracePeriod : Int
972−-- Rate-limit rejection counters: track how many requests were rejected by each rate limiter.
973−-- Exposed via /stats for operators to tune rate limits without parsing logs.
974−-- Reset on each federation latency window reset (same cadence as other metrics).
975−*rateLimitedGlobal : Int
977−*rateLimitedAuth : Int
978−*rateLimitedPerKey : Int
979−*rateLimitedFederation : Int
981−-- Cancel metrics: track message cancellation volume for operator visibility.
982−-- Reset with federation latency window (same cadence as other windowed metrics).
983−*clientCancelCount : Int
984−*federationCancelCount : Int
986−-- Monotonic counter bumped on any presence change (gossip, auth, logout, prune, restore, drain)
987−-- Polls compare against this to skip expensive presence lookups when nothing changed.
988−*presenceVersion : Timestamp
990−-- Active request counter: tracks concurrent requests for backpressure visibility.
991−-- Incremented at request start, decremented after handler completes.
992−-- If serveInner panics (Knot lacks try-finally), the counter leaks. The prune cycle
993−-- reconciles by checking lastRequestCompletedAt: if no request has completed in
994−-- 3x pollTimeoutMs but activeRequests > 0, the counter is reset.
995−*activeRequests : Int
996−*peakActiveRequests : Int
997−*lastRequestCompletedAt : Timestamp
999−-- Client operation latency tracking (for /stats, reset with federation latency window)
1000−*clientPollLatencyTotal : Int<Ms>
1001−*clientPollLatencyCount : Int
1002−*clientPollLatencyMax : Int<Ms>
1003−*clientSendLatencyTotal : Int<Ms>
1004−*clientSendLatencyCount : Int
1005−*clientSendLatencyMax : Int<Ms>
1007−-- Client latency histogram buckets (poll and send): [0,50ms), [50,200ms), [200,1000ms), [1000+ms)
1008−-- Approximates P50/P95/P99 for client-facing operations. Reset with federation latency window.
1009−*clientPollLatencyBucket0 : Int
1010−*clientPollLatencyBucket1 : Int
1011−*clientPollLatencyBucket2 : Int
1012−*clientPollLatencyBucket3 : Int
1013−*clientSendLatencyBucket0 : Int
1014−*clientSendLatencyBucket1 : Int
1015−*clientSendLatencyBucket2 : Int
1016−*clientSendLatencyBucket3 : Int
1018−-- Client latency histogram thresholds (ms)
1019−clientLatencyT1 : Int<Ms>
1020−clientLatencyT1 = 50
1021−clientLatencyT2 : Int<Ms>
1022−clientLatencyT2 = 200
1023−clientLatencyT3 : Int<Ms>
1024−clientLatencyT3 = 1000
1026−-- Auth (challenge + verify) latency tracking (for /stats, reset with latency window)
1027−*clientAuthLatencyTotal : Int<Ms>
1028−*clientAuthLatencyCount : Int
1029−*clientAuthLatencyMax : Int<Ms>
1031−-- Last time the background watchdog loop ran (for health check liveness detection)
1032−*lastWatchdogAt : Timestamp
1034−-- Cached health result: returned when /health is rate-limited instead of false all-healthy.
1035−-- Updated on every successful (non-rate-limited) health check.
1036−*cachedHealthOk : Bool
1037−*cachedHealthPrune : Bool
1038−*cachedHealthHeartbeat : Bool
1039−*cachedHealthCapacity : Bool
1040−*cachedHealthFederation : Bool
1041−*cachedHealthWatchdog : Bool
1042−*cachedHealthNonce : Bool
1043−*cachedHealthCapacityWarning : Bool
1044−*cachedHealthForwardQueue : Bool
1045−-- Cached count of federation peers with active failure records (degraded connectivity)
1046−*cachedHealthDegradedPeers : Int
1047−-- Cached request pressure health (activeRequests < 90% of maxActiveRequests)
1048−*cachedHealthRequestPressure : Bool
1049−-- Cached count of destination servers with stale forward queues (updated during prune cycle).
1050−-- Used by health checks to avoid scanning all 16 forward buckets on every /health request.
1051−*cachedForwardStaleCount : Int
1053−-- Cached adaptive rate scale factor (0-100%). Updated every prune cycle.
1054−-- Avoids 3 STM reads per rate check on the hot path. 100 = no scaling (default).
1055−*cachedAdaptiveScale : Int
1057−-- Nonce eviction counter: tracks total LRU nonce evictions within the current metrics window.
1058−-- Exposed in /stats capacity for operators to monitor replay-window health.
1059−-- Reset with federation latency window (same cadence as other windowed metrics).
1060−*nonceEvictionCount : Int
1062−-- Gossip send metrics (windowed, reset with federation latency metrics)
1063−*gossipSendSuccess : Int
1064−*gossipSendFail : Int
1066-- ============================================
259-- ============================================
1067−-- Routes
260+-- Routes (response shapes preserved; removed metric fields are zero-filled)
1068-- ============================================
261-- ============================================
1070−-- Authentication: Ed25519 challenge-response flow
1071−-- 1. Client POSTs pubkey to /auth/challenge, gets a random challenge string
1072−-- 2. Client signs the challenge with their private key and POSTs to /auth/verify
1073−-- 3. Server verifies signature, returns a session token
1074route AuthApi where
263route AuthApi where
1076 POST {pubkey: PubkeyHex} /challenge headers {clientIp: Text}
265 POST {pubkey: PubkeyHex} /challenge headers {clientIp: Text}
@@ -1082,241 +271,151 @@ route AuthApi where
1082 POST {targetToken: Text} /revoke headers {authorization: Text, clientIp: Text}
271 POST {targetToken: Text} /revoke headers {authorization: Text, clientIp: Text}
1083 -> {ok: Bool, authorized: Bool}
272 -> {ok: Bool, authorized: Bool}
1084 = RevokeSession
273 = RevokeSession
1085− -- Voluntary disconnect: removes session and gossips offline if last session for this key
1086 POST {} /logout headers {authorization: Text, clientIp: Text}
274 POST {} /logout headers {authorization: Text, clientIp: Text}
1087 -> {ok: Bool, authorized: Bool}
275 -> {ok: Bool, authorized: Bool}
1088 = Logout
276 = Logout
1090−-- Client-facing API (requires session token in Authorization header)
1091route ClientApi where
278route ClientApi where
1092− -- Long-poll for new messages; cursor tracks last-seen receivedAt timestamp
1093 POST {cursor: Timestamp, generation: Int, watchKeys: [PubkeyHex]} /poll headers {authorization: Text, clientIp: Text}
279 POST {cursor: Timestamp, generation: Int, watchKeys: [PubkeyHex]} /poll headers {authorization: Text, clientIp: Text}
1094 -> {events: [PollEvent], cursor: Timestamp, authorized: Bool, rateLimited: Bool, draining: Bool, generation: Int, presenceUpdates: [{pubkey: PubkeyHex, online: Bool}], heartbeat: Bool, retryAfterMs: Int, cursorReset: Bool, hasMore: Bool, cursorStale: Bool, messageExpirations: [{messageId: MessageIdHex, toKey: PubkeyHex, expiredAt: Timestamp}], messageDeliveries: [{messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}], droppedDeliveryReceipts: Int, droppedExpirationNotifs: Int, loadPct: Int, messageCancellations: [{messageId: MessageIdHex, cancelledAt: Timestamp}]}
280 -> {events: [PollEvent], cursor: Timestamp, authorized: Bool, rateLimited: Bool, draining: Bool, generation: Int, presenceUpdates: [{pubkey: PubkeyHex, online: Bool}], heartbeat: Bool, retryAfterMs: Int, cursorReset: Bool, hasMore: Bool, cursorStale: Bool, messageExpirations: [{messageId: MessageIdHex, toKey: PubkeyHex, expiredAt: Timestamp}], messageDeliveries: [{messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}], droppedDeliveryReceipts: Int, droppedExpirationNotifs: Int, loadPct: Int, messageCancellations: [{messageId: MessageIdHex, cancelledAt: Timestamp}]}
1096 /messages
282 /messages
1097− -- Send an E2E encrypted message to a recipient pubkey.
1098− -- expiresInMs: optional sender-specified TTL in milliseconds (0 or negative = server default).
1099− -- Clamped to [minMessageTtl, unackedMessageMaxAge]. Allows ephemeral messages.
1100− -- priority: optional urgency level (0 = normal, higher = more urgent, clamped to [0, maxMessagePriority]).
1101− -- High-priority messages are forwarded first during federation retries.
1102 POST {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int} / headers {authorization: Text, clientIp: Text}
283 POST {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int} / headers {authorization: Text, clientIp: Text}
1103 -> {status: MessageStatus, messageId: OptionalMessageId, retryAfterMs: Int, error: Text, loadPct: Int}
284 -> {status: MessageStatus, messageId: OptionalMessageId, retryAfterMs: Int, error: Text, loadPct: Int}
1104 = SendMessage
285 = SendMessage
1105− -- Check delivery status of a sent message (caller must know recipient to prove ownership)
1106 POST {to: PubkeyHex, messageId: MessageIdHex} /status headers {authorization: Text, clientIp: Text}
286 POST {to: PubkeyHex, messageId: MessageIdHex} /status headers {authorization: Text, clientIp: Text}
1107 -> {status: Text, authorized: Bool}
287 -> {status: Text, authorized: Bool}
1108 = MessageStatus
288 = MessageStatus
1109− -- Explicitly acknowledge received messages by ID (alternative to cursor-based ack in poll)
1110 POST {messageIds: [MessageIdHex]} /ack headers {authorization: Text, clientIp: Text}
289 POST {messageIds: [MessageIdHex]} /ack headers {authorization: Text, clientIp: Text}
1111 -> {ok: Bool, authorized: Bool, ackedCount: Int, error: Text}
290 -> {ok: Bool, authorized: Bool, ackedCount: Int, error: Text}
1112 = AckMessages
291 = AckMessages
1113− -- Send multiple messages in one request (auth checked once; each message rate-limited independently)
1114 POST {messages: [BatchMessage]} /batch headers {authorization: Text, clientIp: Text}
292 POST {messages: [BatchMessage]} /batch headers {authorization: Text, clientIp: Text}
1115 -> {results: [BatchResult], authorized: Bool, retryAfterMs: Int}
293 -> {results: [BatchResult], authorized: Bool, retryAfterMs: Int}
1116 = SendBatch
294 = SendBatch
1117− -- List pending messages without acking (useful after cursor loss or device migration).
1118− -- offset: skip the first N messages (for pagination, default 0).
1119 POST {offset: Int} /list headers {authorization: Text, clientIp: Text}
295 POST {offset: Int} /list headers {authorization: Text, clientIp: Text}
1120 -> {messages: [{messageId: MessageIdHex, timestamp: Timestamp, receivedAt: Timestamp}], authorized: Bool, count: Int, error: Text}
296 -> {messages: [{messageId: MessageIdHex, timestamp: Timestamp, receivedAt: Timestamp}], authorized: Bool, count: Int, error: Text}
1121 = ListMessages
297 = ListMessages
1122− -- Delete pending messages by ID (recipient-only; messages don't store sender pubkey)
1123 POST {messageIds: [MessageIdHex]} /delete headers {authorization: Text, clientIp: Text}
298 POST {messageIds: [MessageIdHex]} /delete headers {authorization: Text, clientIp: Text}
1124 -> {ok: Bool, authorized: Bool, deletedCount: Int, error: Text}
299 -> {ok: Bool, authorized: Bool, deletedCount: Int, error: Text}
1125 = DeleteMessages
300 = DeleteMessages
1126− -- Cancel (retract) a sent message before the recipient reads it.
1127− -- Caller provides messageId and recipient pubkey — knowing the messageId proves
1128− -- sender identity (either client-generated or returned only to the sender).
1129− -- Removes from recipient mailbox, cancels pending forwards, sends federation acks.
1130 POST {messageId: MessageIdHex, to: PubkeyHex} /cancel headers {authorization: Text, clientIp: Text}
301 POST {messageId: MessageIdHex, to: PubkeyHex} /cancel headers {authorization: Text, clientIp: Text}
1131 -> {ok: Bool, authorized: Bool, cancelled: Bool, error: Text}
302 -> {ok: Bool, authorized: Bool, cancelled: Bool, error: Text}
1132 = CancelMessage
303 = CancelMessage
1133− -- Cancel (retract) multiple sent messages in one request.
1134− -- Each cancel is processed independently; partial success is possible.
1135 POST {cancels: [BatchCancelEntry]} /cancel-batch headers {authorization: Text, clientIp: Text}
304 POST {cancels: [BatchCancelEntry]} /cancel-batch headers {authorization: Text, clientIp: Text}
1136 -> {results: [BatchCancelResult], authorized: Bool, error: Text}
305 -> {results: [BatchCancelResult], authorized: Bool, error: Text}
1137 = CancelBatch
306 = CancelBatch
1138− -- Look up which server a pubkey is present on (for federation routing)
1139 GET /lookup/{pubkey: PubkeyHex} headers {authorization: Text, clientIp: Text}
307 GET /lookup/{pubkey: PubkeyHex} headers {authorization: Text, clientIp: Text}
1140 -> {server: AnyServerName, authorized: Bool, error: Text}
308 -> {server: AnyServerName, authorized: Bool, error: Text}
1141 = LookupPresence
309 = LookupPresence
1142− -- Batch lookup: look up presence for multiple pubkeys in one request
1143 POST {pubkeys: [PubkeyHex]} /lookup/batch headers {authorization: Text, clientIp: Text}
310 POST {pubkeys: [PubkeyHex]} /lookup/batch headers {authorization: Text, clientIp: Text}
1144 -> {results: [{pubkey: PubkeyHex, server: AnyServerName}], authorized: Bool, error: Text}
311 -> {results: [{pubkey: PubkeyHex, server: AnyServerName}], authorized: Bool, error: Text}
1145 = BatchLookupPresence
312 = BatchLookupPresence
1147−-- Server-to-server federation API (authenticated via domain callback verification)
1148−-- correlationId: optional trace ID for cross-server request tracing (empty = not provided).
1149−-- Peers that don't support it send "" — logged when present but not enforced.
1150−-- protocolVersion: federation protocol version of the sending server (0 = pre-versioning).
1151−-- Older peers omit this field; Knot defaults missing Int fields to 0.
1152route FederationApi where
314route FederationApi where
1153 /federation
315 /federation
1154− -- Receive presence gossip events from a peer server
1155 POST {events: [GossipEvent], hopsRemaining: Int, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /gossip headers {authorization: Text}
316 POST {events: [GossipEvent], hopsRemaining: Int, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /gossip headers {authorization: Text}
1156 -> {ok: Bool, error: Text, retryAfterMs: Int}
317 -> {ok: Bool, error: Text, retryAfterMs: Int}
1157 = RecvGossip
318 = RecvGossip
1158− -- Receive a forwarded message from a peer server on behalf of a sender.
1159− -- NOTE: senderKey is intentionally NOT included in the forward protocol. The sender's
1160− -- identity is inside the E2E encrypted blob — exposing it in plaintext would break the
1161− -- privacy model (the server never learns who sent a message). /messages/cancel for
1162− -- federated messages requires the client to include sender identity in the encrypted
1163− -- payload; the server cannot verify sender identity for federation-forwarded messages.
1164 POST {toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: ServerName, messageId: MessageIdHex, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, expiresAt: Timestamp, priority: Int, protocolVersion: Int} /forward headers {authorization: Text}
319 POST {toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: ServerName, messageId: MessageIdHex, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, expiresAt: Timestamp, priority: Int, protocolVersion: Int} /forward headers {authorization: Text}
1165 -> {ok: Bool, error: Text, retryAfterMs: Int}
320 -> {ok: Bool, error: Text, retryAfterMs: Int}
1166 = ForwardMessage
321 = ForwardMessage
1167− -- Acknowledge delivery of messages back to the origin server
1168 POST {messageIds: [MessageIdHex], originServer: ServerName, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /ack headers {authorization: Text}
322 POST {messageIds: [MessageIdHex], originServer: ServerName, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /ack headers {authorization: Text}
1169 -> {ok: Bool, error: Text, ackedCount: Int, results: [{messageId: MessageIdHex, found: Bool}], retryAfterMs: Int}
323 -> {ok: Bool, error: Text, ackedCount: Int, results: [{messageId: MessageIdHex, found: Bool}], retryAfterMs: Int}
1170 = FederationAck
324 = FederationAck
1171− -- Cancel (retract) a previously forwarded message. The origin server sends this
1172− -- when the sender cancels a message via /messages/cancel. The receiving server
1173− -- deletes the message if it hasn't been polled by the recipient yet.
1174− -- Security: the handler checks msg.originServer == fromServer, and fromServer is
1175− -- authenticated via the verify callback (the receiver calls back to fromServer to
1176− -- confirm the token). A relay peer cannot forge fromServer because the callback
1177− -- would go to the wrong server, which wouldn't have the token. This prevents a
1178− -- malicious relay from cancelling messages it forwarded on behalf of the origin.
1179 POST {messageId: MessageIdHex, toKey: PubkeyHex, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /cancel headers {authorization: Text}
325 POST {messageId: MessageIdHex, toKey: PubkeyHex, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /cancel headers {authorization: Text}
1180 -> {ok: Bool, error: Text, cancelled: Bool, retryAfterMs: Int}
326 -> {ok: Bool, error: Text, cancelled: Bool, retryAfterMs: Int}
1181 = FederationCancel
327 = FederationCancel
1182− -- Batch cancel: cancel multiple previously forwarded messages in one request.
1183 POST {cancels: [{messageId: MessageIdHex, toKey: PubkeyHex}], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /cancel-batch headers {authorization: Text}
328 POST {cancels: [{messageId: MessageIdHex, toKey: PubkeyHex}], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /cancel-batch headers {authorization: Text}
1184 -> {ok: Bool, error: Text, results: [BatchCancelResult], retryAfterMs: Int}
329 -> {ok: Bool, error: Text, results: [BatchCancelResult], retryAfterMs: Int}
1185 = FederationBatchCancel
330 = FederationBatchCancel
1186− -- Batch forward: forward multiple messages in one request (reduces HTTP round-trips).
1187− -- Each message is processed independently; partial success is possible.
1188− -- Results are returned per-message so the sender knows which forwards succeeded.
1189 POST {forwards: [{toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: ServerName, messageId: MessageIdHex, expiresAt: Timestamp, priority: Int}], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /forward-batch headers {authorization: Text}
331 POST {forwards: [{toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: ServerName, messageId: MessageIdHex, expiresAt: Timestamp, priority: Int}], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /forward-batch headers {authorization: Text}
1190 -> {ok: Bool, error: Text, results: [{messageId: MessageIdHex, ok: Bool}], retryAfterMs: Int}
332 -> {ok: Bool, error: Text, results: [{messageId: MessageIdHex, ok: Bool}], retryAfterMs: Int}
1191 = FederationBatchForward
333 = FederationBatchForward
1192− -- Delivery receipt: destination server notifies origin that a federated message was
1193− -- polled/acked by the recipient. Origin server records it as a sender delivery receipt.
1194− -- Best-effort: failures are not retried (ack path already confirms delivery at the
1195− -- protocol level; receipts are a UX enhancement for sender-side delivery indicators).
1196 POST {messageIds: [MessageIdHex], toKeys: [PubkeyHex], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /delivery-receipt headers {authorization: Text}
334 POST {messageIds: [MessageIdHex], toKeys: [PubkeyHex], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /delivery-receipt headers {authorization: Text}
1197 -> {ok: Bool, error: Text, receivedCount: Int, retryAfterMs: Int}
335 -> {ok: Bool, error: Text, receivedCount: Int, retryAfterMs: Int}
1198 = FederationDeliveryReceipt
336 = FederationDeliveryReceipt
1200−-- Federation callback verification: the receiving server calls back to the sender
1201−-- to confirm a request token is genuine. No shared secret needed.
1202−-- NOTE: Tokens are not bound to the caller's IP. A MITM that intercepts a token
1203−-- can replay it from a different IP within the 30-second TTL (verificationTokenExpiry).
1204−-- Mitigations: (1) tokens are single-use (consumed on first verify), (2) per-IP rate
1205−-- limiting (verifyIpRates) constrains brute-force probing, (3) the verify cache
1206−-- (verificationCacheMs=2s) limits the replay window after the first legitimate verify.
1207−-- Binding to IP would break federation through NAT/proxy topologies where the
1208−-- verifying server's egress IP differs from the initial request's source IP.
1209route FederationVerifyApi where
338route FederationVerifyApi where
1210 POST {token: Text, scope: Text} /federation/verify headers {clientIp: Text} -> {ok: Bool} = VerifyToken
339 POST {token: Text, scope: Text} /federation/verify headers {clientIp: Text} -> {ok: Bool} = VerifyToken
1212−-- Ed25519 federation public key endpoint: peers fetch this to verify signed requests.
1213−-- Unauthenticated (like /health and /ready). Rate-limited via health rate limiter.
1214route FederationPubkeyApi where
341route FederationPubkeyApi where
1215 GET /federation/pubkey -> {pubkey: Text, ok: Bool} = FederationPubkey
342 GET /federation/pubkey -> {pubkey: Text, ok: Bool} = FederationPubkey
1217−-- Triggers pruning of expired state and retry of pending federation ops
1218route MaintenanceApi where
344route MaintenanceApi where
1219 POST {} /maintenance/prune headers {authorization: Text}
345 POST {} /maintenance/prune headers {authorization: Text}
1220 -> {ok: Bool}
346 -> {ok: Bool}
1222− -- phase: 0 or 2 = full drain (backward compat), 1 = soft drain (auth-only block)
1223 POST {phase: Int} /maintenance/drain headers {authorization: Text}
348 POST {phase: Int} /maintenance/drain headers {authorization: Text}
1224 -> {ok: Bool, drained: Int, phase: Int}
349 -> {ok: Bool, drained: Int, phase: Int}
1226 POST {} /maintenance/undrain headers {authorization: Text}
351 POST {} /maintenance/undrain headers {authorization: Text}
1227 -> {ok: Bool}
352 -> {ok: Bool}
1228 = Undrain
353 = Undrain
1229− -- Graceful shutdown: triggers full drain + sets shutdown flag so background loops exit.
1230− -- Call this instead of drain when the process should stop after flush completes.
1231 POST {} /maintenance/shutdown headers {authorization: Text}
354 POST {} /maintenance/shutdown headers {authorization: Text}
1232 -> {ok: Bool, drained: Int}
355 -> {ok: Bool, drained: Int}
1233 = Shutdown
356 = Shutdown
1234− -- Block a federation peer (rejects all inbound/outbound federation with this server)
1235 POST {server: ServerName} /maintenance/block headers {authorization: Text}
357 POST {server: ServerName} /maintenance/block headers {authorization: Text}
1236 -> {ok: Bool, blocked: Int}
358 -> {ok: Bool, blocked: Int}
1237 = BlockPeer
359 = BlockPeer
1238− -- Unblock a previously blocked peer
1239 POST {server: ServerName} /maintenance/unblock headers {authorization: Text}
360 POST {server: ServerName} /maintenance/unblock headers {authorization: Text}
1240 -> {ok: Bool, unblocked: Bool}
361 -> {ok: Bool, unblocked: Bool}
1241 = UnblockPeer
362 = UnblockPeer
1242− -- List currently blocked peers
1243 GET /maintenance/blocked headers {authorization: Text}
363 GET /maintenance/blocked headers {authorization: Text}
1244 -> {peers: [Text], ok: Bool}
364 -> {peers: [Text], ok: Bool}
1245 = ListBlocked
365 = ListBlocked
1246− -- Test federation connectivity to a specific peer via verify callback round-trip
1247 POST {server: ServerName} /maintenance/ping headers {authorization: Text}
366 POST {server: ServerName} /maintenance/ping headers {authorization: Text}
1248 -> {ok: Bool, latencyMs: Int, error: Text}
367 -> {ok: Bool, latencyMs: Int, error: Text}
1249 = PingPeer
368 = PingPeer
1250− -- List sessions for a specific pubkey (admin debugging)
1251 GET /maintenance/sessions/{pubkey: PubkeyHex} headers {authorization: Text}
369 GET /maintenance/sessions/{pubkey: PubkeyHex} headers {authorization: Text}
1252 -> {sessions: [{token: Text, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}], count: Int, ok: Bool}
370 -> {sessions: [{token: Text, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}], count: Int, ok: Bool}
1253 = AdminListSessions
371 = AdminListSessions
1254− -- Revoke all sessions for a specific pubkey (abuse response)
1255 POST {pubkey: PubkeyHex} /maintenance/sessions/revoke-all headers {authorization: Text}
372 POST {pubkey: PubkeyHex} /maintenance/sessions/revoke-all headers {authorization: Text}
1256 -> {ok: Bool, revokedCount: Int}
373 -> {ok: Bool, revokedCount: Int}
1257 = AdminRevokeSessions
374 = AdminRevokeSessions
1258− -- Purge all pending messages for a specific pubkey (inbox bombing response)
1259 POST {pubkey: PubkeyHex} /maintenance/messages/purge headers {authorization: Text}
375 POST {pubkey: PubkeyHex} /maintenance/messages/purge headers {authorization: Text}
1260 -> {ok: Bool, purgedCount: Int}
376 -> {ok: Bool, purgedCount: Int}
1261 = AdminPurgeMessages
377 = AdminPurgeMessages
1262− -- Revoke all sessions from a specific IP address (key-rotation abuse response)
1263 POST {ip: Text} /maintenance/sessions/revoke-ip headers {authorization: Text}
378 POST {ip: Text} /maintenance/sessions/revoke-ip headers {authorization: Text}
1264 -> {ok: Bool, revokedCount: Int, affectedKeys: Int}
379 -> {ok: Bool, revokedCount: Int, affectedKeys: Int}
1265 = AdminRevokeIp
380 = AdminRevokeIp
1266− -- List all active session pubkeys grouped by IP (admin debugging, abuse investigation).
1267− -- Helps detect suspicious multi-key activity without knowing the pubkey in advance.
1268− -- limit: max entries to return (default 100, capped at 500). 0 = default.
1269 POST {limit: Int} /maintenance/sessions/list headers {authorization: Text}
381 POST {limit: Int} /maintenance/sessions/list headers {authorization: Text}
1270 -> {sessions: [{pubkey: PubkeyHex, count: Int, ips: [Text], latestExpiry: Timestamp}], ok: Bool, total: Int}
382 -> {sessions: [{pubkey: PubkeyHex, count: Int, ips: [Text], latestExpiry: Timestamp}], ok: Bool, total: Int}
1271 = AdminListAllSessions
383 = AdminListAllSessions
1272− -- Read current effective rate limits (compile-time defaults + runtime overrides)
1273 GET /maintenance/rate-limits headers {authorization: Text}
384 GET /maintenance/rate-limits headers {authorization: Text}
1274 -> {ok: Bool, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int}
385 -> {ok: Bool, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int}
1275 = GetRateLimits
386 = GetRateLimits
1276− -- Update rate limits at runtime (0 = reset to compile-time default)
1277 POST {globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int} /maintenance/rate-limits headers {authorization: Text}
387 POST {globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int} /maintenance/rate-limits headers {authorization: Text}
1278 -> {ok: Bool}
388 -> {ok: Bool}
1279 = SetRateLimits
389 = SetRateLimits
1280− -- Flush forward nonces (recovery from corruption or capacity issues)
1281 POST {} /maintenance/nonces/flush headers {authorization: Text}
390 POST {} /maintenance/nonces/flush headers {authorization: Text}
1282 -> {ok: Bool, flushedCount: Int}
391 -> {ok: Bool, flushedCount: Int}
1283 = FlushNonces
392 = FlushNonces
1284− -- Allow a federation peer (when allowlist is non-empty, only allowed peers can federate)
1285 POST {server: ServerName} /maintenance/allow headers {authorization: Text}
393 POST {server: ServerName} /maintenance/allow headers {authorization: Text}
1286 -> {ok: Bool, allowed: Int}
394 -> {ok: Bool, allowed: Int}
1287 = AllowPeer
395 = AllowPeer
1288− -- Remove a server from the federation allowlist
1289 POST {server: ServerName} /maintenance/unallow headers {authorization: Text}
396 POST {server: ServerName} /maintenance/unallow headers {authorization: Text}
1290 -> {ok: Bool, removed: Bool}
397 -> {ok: Bool, removed: Bool}
1291 = UnallowPeer
398 = UnallowPeer
1292− -- List currently allowed federation peers (empty = open federation)
1293 GET /maintenance/allowed headers {authorization: Text}
399 GET /maintenance/allowed headers {authorization: Text}
1294 -> {peers: [Text], ok: Bool}
400 -> {peers: [Text], ok: Bool}
1295 = ListAllowed
401 = ListAllowed
1296− -- Force counter reconciliation (message counts, presence, sessions).
1297− -- Returns drift values; non-zero means counters were corrected.
1298 POST {} /maintenance/reconcile headers {authorization: Text}
402 POST {} /maintenance/reconcile headers {authorization: Text}
1299 -> {ok: Bool, messageDrift: Int, presenceDrift: Int, sessionDrift: Int}
403 -> {ok: Bool, messageDrift: Int, presenceDrift: Int, sessionDrift: Int}
1300 = Reconcile
404 = Reconcile
1301− -- Rotate maintenance secret at runtime (zero-downtime rotation).
1302− -- Authenticated with the current secret; sets a new runtime secret that overrides
1303− -- the compile-time default. Pass empty newSecret to revert to compile-time secret.
1304 POST {newSecret: Text} /maintenance/rotate-secret headers {authorization: Text}
405 POST {newSecret: Text} /maintenance/rotate-secret headers {authorization: Text}
1305 -> {ok: Bool, error: Text}
406 -> {ok: Bool, error: Text}
1306 = RotateSecret
407 = RotateSecret
1307− -- Read current effective operational config (compile-time defaults + runtime overrides)
1308 GET /maintenance/config headers {authorization: Text}
408 GET /maintenance/config headers {authorization: Text}
1309 -> {ok: Bool, maxMessagesPerRecipient: Int, maxGossipHops: Int, pollTimeoutMs: Int, ackGracePeriod: Int}
409 -> {ok: Bool, maxMessagesPerRecipient: Int, maxGossipHops: Int, pollTimeoutMs: Int, ackGracePeriod: Int}
1310 = GetConfig
410 = GetConfig
1311route HealthApi where
412route HealthApi where
1312 GET /health headers {authorization: Text} -> {ok: Bool, version: Text, pruneHealthy: Bool, heartbeatHealthy: Bool, capacityHealthy: Bool, capacityWarning: Bool, federationHealthy: Bool, watchdogHealthy: Bool, nonceHealthy: Bool, forwardQueueHealthy: Bool, requestPressureHealthy: Bool, draining: Bool, degradedPeers: Int} = Health
413 GET /health headers {authorization: Text} -> {ok: Bool, version: Text, pruneHealthy: Bool, heartbeatHealthy: Bool, capacityHealthy: Bool, capacityWarning: Bool, federationHealthy: Bool, watchdogHealthy: Bool, nonceHealthy: Bool, forwardQueueHealthy: Bool, requestPressureHealthy: Bool, draining: Bool, degradedPeers: Int} = Health
1314−-- Returns counts of in-memory collections (requires maintenance secret)
415+type PeerStatus = {server: Text, failures: Int, lastFailedAt: Timestamp, firstFailedAt: Timestamp, backoffMs: Int, retriable: Bool, pendingForwards: Int, avgLatencyMs: Int, maxLatencyMs: Int, latencySamples: Int, gossipEventsPerMin: Int}
1315−-- TODO: If Knot adds raw text response support, add a /metrics endpoint
416+type KeyPresenceEntry = {server: Text, expiresAt: Timestamp}
1316−-- returning Prometheus exposition format for direct integration with standard
417+type RecipientCount = {pubkey: PubkeyHex, count: Int}
1317−-- monitoring stacks. Currently /stats returns JSON which requires a custom scraper.
418+
1318−-- Stats response grouped into nested objects for monitoring dashboard ergonomics.
1319−-- BREAKING CHANGE from flat format — existing scrapers must update field paths.
1320route StatsApi where
419route StatsApi where
1321 GET /stats headers {authorization: Text}
420 GET /stats headers {authorization: Text}
1322 -> {ok: Bool, version: Text, capacity: {sessions: Int, sessionsMax: Int, sessionsPct: Int, messages: Int, messagesMax: Int, messagesPct: Int, totalMessageCount: Int, presence: Int, presenceMax: Int, presencePct: Int, forwards: Int, forwardsMax: Int, forwardsPct: Int, challenges: Int, challengesMax: Int, ackedIds: Int, ackedIdsMax: Int, ackOverflow: Int, ackOverflowMax: Int, deliveredIds: Int, deliveredIdsMax: Int, forwardNonces: Int, forwardNoncesMax: Int, nonceEvictions: Int, activePolls: Int, activePollsMax: Int, recipientCounts: Int, messageBucketMax: Int, messageBucketMin: Int}, federation: {enabled: Bool, inFlight: Int, hungSlots: Int, avgLatencyMs: Int, maxLatencyMs: Int, callCount: Int, slowVerifies: Int, verifyFailures: Int, forwardFailures: Int, oldestForwardAge: Int, oldestAckAge: Int, recentGossip: Int, blockedPeers: Int, drainCompletedAt: Timestamp, forwardServers: Int, maxForwardQueueDepth: Int, topFailingPeers: [{server: Text, failures: Int}], pendingCancels: Int, gossipSuccess: Int, gossipFail: Int, latencyBuckets: {lt100: Int, lt500: Int, lt2000: Int, gte2000: Int}}, rates: {send: Int, challenge: Int, federation: Int, federationPair: Int, global: Int, ip: Int, lookup: Int, recv: Int, pair: Int, gossipEvent: Int, verifyIp: Int, uniqueKeyIp: Int, pendingAckCleanups: Int, senderExpirations: Int, senderDeliveries: Int, rejectedGlobal: Int, rejectedIp: Int, rejectedAuth: Int, rejectedPerKey: Int, rejectedFederation: Int, clientCancels: Int, federationCancels: Int}, timing: {pruneCount: Int, pruneRunning: Timestamp, heartbeatCount: Int, uptime: Int, lastPruneAt: Timestamp, lastHeartbeatAt: Timestamp, draining: Bool, drainPhase: Int, totalEntries: Int, activeRequests: Int, peakActiveRequests: Int, pollAvgMs: Int, pollMaxMs: Int, pollCount: Int, pollLatencyBuckets: {lt50: Int, lt200: Int, lt1000: Int, gte1000: Int}, sendAvgMs: Int, sendMaxMs: Int, sendCount: Int, sendLatencyBuckets: {lt50: Int, lt200: Int, lt1000: Int, gte1000: Int}, authAvgMs: Int, authMaxMs: Int, authCount: Int}}
421 -> {ok: Bool, version: Text, capacity: {sessions: Int, sessionsMax: Int, sessionsPct: Int, messages: Int, messagesMax: Int, messagesPct: Int, totalMessageCount: Int, presence: Int, presenceMax: Int, presencePct: Int, forwards: Int, forwardsMax: Int, forwardsPct: Int, challenges: Int, challengesMax: Int, ackedIds: Int, ackedIdsMax: Int, ackOverflow: Int, ackOverflowMax: Int, deliveredIds: Int, deliveredIdsMax: Int, forwardNonces: Int, forwardNoncesMax: Int, nonceEvictions: Int, activePolls: Int, activePollsMax: Int, recipientCounts: Int, messageBucketMax: Int, messageBucketMin: Int}, federation: {enabled: Bool, inFlight: Int, hungSlots: Int, avgLatencyMs: Int, maxLatencyMs: Int, callCount: Int, slowVerifies: Int, verifyFailures: Int, forwardFailures: Int, oldestForwardAge: Int, oldestAckAge: Int, recentGossip: Int, blockedPeers: Int, drainCompletedAt: Timestamp, forwardServers: Int, maxForwardQueueDepth: Int, topFailingPeers: [{server: Text, failures: Int}], pendingCancels: Int, gossipSuccess: Int, gossipFail: Int, latencyBuckets: {lt100: Int, lt500: Int, lt2000: Int, gte2000: Int}}, rates: {send: Int, challenge: Int, federation: Int, federationPair: Int, global: Int, ip: Int, lookup: Int, recv: Int, pair: Int, gossipEvent: Int, verifyIp: Int, uniqueKeyIp: Int, pendingAckCleanups: Int, senderExpirations: Int, senderDeliveries: Int, rejectedGlobal: Int, rejectedIp: Int, rejectedAuth: Int, rejectedPerKey: Int, rejectedFederation: Int, clientCancels: Int, federationCancels: Int}, timing: {pruneCount: Int, pruneRunning: Timestamp, heartbeatCount: Int, uptime: Int, lastPruneAt: Timestamp, lastHeartbeatAt: Timestamp, draining: Bool, drainPhase: Int, totalEntries: Int, activeRequests: Int, peakActiveRequests: Int, pollAvgMs: Int, pollMaxMs: Int, pollCount: Int, pollLatencyBuckets: {lt50: Int, lt200: Int, lt1000: Int, gte1000: Int}, sendAvgMs: Int, sendMaxMs: Int, sendCount: Int, sendLatencyBuckets: {lt50: Int, lt200: Int, lt1000: Int, gte1000: Int}, authAvgMs: Int, authMaxMs: Int, authCount: Int}}
@@ -1327,197 +426,70 @@ route StatsApi where
1327 GET /stats/key/{pubkey: PubkeyHex} headers {authorization: Text}
426 GET /stats/key/{pubkey: PubkeyHex} headers {authorization: Text}
1328 -> {messages: Int, presence: [KeyPresenceEntry], sessions: Int, forwards: Int, forwardDetails: [{server: Text, retries: Int, createdAt: Timestamp}], activePolls: Int, ok: Bool}
427 -> {messages: Int, presence: [KeyPresenceEntry], sessions: Int, forwards: Int, forwardDetails: [{server: Text, retries: Int, createdAt: Timestamp}], activePolls: Int, ok: Bool}
1329 = StatsKey
428 = StatsKey
1330− -- Top recipients by pending message count (for abuse investigation — find inbox-bombing targets).
1331− -- limit: max recipients to return (default 20, capped at 100). 0 = default.
1332 POST {limit: Int} /stats/top-recipients headers {authorization: Text}
429 POST {limit: Int} /stats/top-recipients headers {authorization: Text}
1333 -> {recipients: [RecipientCount], ok: Bool, total: Int}
430 -> {recipients: [RecipientCount], ok: Bool, total: Int}
1334 = TopRecipients
431 = TopRecipients
1335− -- Per-server forward queue breakdown: shows pending forwards grouped by destination server.
1336− -- Use to identify which peers have queue buildup (unreachable or slow peers).
1337 GET /stats/forwards headers {authorization: Text}
432 GET /stats/forwards headers {authorization: Text}
1338 -> {servers: [{server: Text, count: Int, oldestAge: Int, totalRetries: Int}], ok: Bool, total: Int}
433 -> {servers: [{server: Text, count: Int, oldestAge: Int, totalRetries: Int}], ok: Bool, total: Int}
1339 = StatsForwards
434 = StatsForwards
1340− -- Effective rate limits after adaptive scaling: shows the current scale factor and
1341− -- each rate limit as it's actually applied (compile-time default * runtime override * adaptive scale).
1342− -- Helps operators understand why requests are being rejected under load.
1343 GET /stats/rates headers {authorization: Text}
435 GET /stats/rates headers {authorization: Text}
1344 -> {ok: Bool, scalePct: Int, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int}
436 -> {ok: Bool, scalePct: Int, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int}
1345 = StatsRates
437 = StatsRates
1347−-- Prometheus-compatible metrics endpoint. Returns key metrics in a JSON field containing
1348−-- Prometheus exposition format text. A lightweight scraper/adapter extracts the "metrics"
1349−-- field and serves it as text/plain to Prometheus. This is the best we can do since Knot
1350−-- routes always return JSON (no raw text response support).
1351−-- Rate-limited via health rate limiter (same as /ready and /federation/pubkey).
1352route MetricsApi where
439route MetricsApi where
1353 GET /metrics headers {authorization: Text} -> {metrics: Text, ok: Bool} = Metrics
440 GET /metrics headers {authorization: Text} -> {metrics: Text, ok: Bool} = Metrics
1355−-- Readiness probe: returns false during startup warmup (before first prune completes),
1356−-- true once the server is fully operational. Unlike /health, this is unauthenticated
1357−-- and doesn't check subsystem liveness — it only indicates whether the server has
1358−-- completed initialization. Use for Kubernetes readinessProbe or load balancer warmup.
1359route ReadyApi where
442route ReadyApi where
1360 GET /ready -> {ready: Bool} = Ready
443 GET /ready -> {ready: Bool} = Ready
1362route Api = AuthApi | ClientApi | FederationApi | FederationVerifyApi | FederationPubkeyApi | MaintenanceApi | HealthApi | StatsApi | MetricsApi | ReadyApi
445route Api = AuthApi | ClientApi | FederationApi | FederationVerifyApi | FederationPubkeyApi | MaintenanceApi | HealthApi | StatsApi | MetricsApi | ReadyApi
1364-- ============================================
447-- ============================================
1365−-- Helpers
448+-- Generic helpers
1366-- ============================================
449-- ============================================
1368−-- JSON structured log helper for machine-parseable events.
1369−-- Outputs: {"level":"<level>","event":"<event>","msg":"<message>"}
1370−-- Use for key operational events that monitoring pipelines need to parse
1371−-- (rate limit rejections, federation failures, capacity warnings).
1372−-- Plain-text logInfo/logWarn/logError remain for human-readable context.
1373−-- Values are escaped (quotes and backslashes) to produce valid JSON even
1374−-- when msg contains user-controlled data (e.g., error strings, server names).
1375−logEvent = \level event msg ->
1376− let formatted = "{\"level\":\"" ++ escapeJsonString level ++ "\",\"event\":\"" ++ escapeJsonString event ++ "\",\"msg\":\"" ++ escapeJsonString msg ++ "\"}"
1377− in if level == "error" then logError formatted
1378− else if level == "warn" then logWarn formatted
1379− else logInfo formatted
1381−-- Structured key=value logging: formats message as "k1=v1 k2=v2 ..." for consistent
1382−-- machine-parseable log entries. Wraps logEvent with key-value pair formatting.
1383−-- Use for events where individual fields need to be extracted by log pipelines.
1384−logKV = \level event kvs ->
1385− logEvent level event (joinKVPairs kvs)
1387−joinKVPairs = \kvs -> fold (\acc kv -> if acc == "" then kv else acc ++ " " ++ kv) "" kvs
1389−-- Log a warning when a federation peer sends a request with an older protocol version.
1390−-- protocolVersion == 0 means pre-versioning peer (field missing). Only logs once per
1391−-- request — callers invoke this before delegating to the handler.
1392−warnOldProtocol = \fromServer pv ->
1393− when (pv > 0 && pv < federationProtocolVersion)
1394− (logWarn ("federation: peer " ++ fromServer ++ " using protocol v" ++ show pv ++ " (current: v" ++ show federationProtocolVersion ++ ")"))
1396−-- Log per-server detail for stale in-flight entries (hung connection debugging).
1397−-- Emits one structured event per server with slot count and duration.
1398−logStaleInFlight = \entries t ->
1399− case headOf entries of
1400− Nothing {} -> yield {}
1401− Just {value: r} -> do
1402− logEvent "error" "stale_inflight" (r.server ++ " " ++ show r.count ++ " slots hung for " ++ show (t - r.firstStartedAt) ++ "ms")
1403− logStaleInFlight (do e <- entries; where e.server != r.server; yield e) t
1405−-- Fast path: check if a string contains only safe JSON characters (hex digits,
1406−-- alphanumerics, common punctuation). If so, no escaping is needed.
1407−-- Returns False on the first unsafe character. Tail-recursive (TCO-safe in Knot).
1408−isJsonSafe : Text -> Bool
1410− if s == "" then True {}
1411− else let c = take 1 s in
1412− if contains c "0123456789abcdefABCDEF_-.:/ " then isJsonSafe (drop 1 s)
1413− else if contains c "ghijklmnopqrstuvwxyzGHIJKLMNOPQRSTUVWXYZ" then isJsonSafe (drop 1 s)
1416−-- Escape special characters for safe JSON string embedding.
1417−-- Handles: backslash, double quote, and control characters (\n, \r, \t).
1418−-- Non-printable characters outside this set are stripped (same allowlist as
1419−-- stripNonPrintable) to prevent log injection via error strings from federation peers.
1420−-- Fast path: strings containing only safe chars (hex, alphanumeric, common punctuation)
1421−-- are returned unchanged, avoiding O(n) per-character recursion for validated types.
1422−-- Uses an accumulator parameter for tail recursion (TCO-safe in Knot):
1423−-- the recursive call is in tail position, not wrapped by ++.
1424−escapeJsonString : Text -> Text
1425−escapeJsonString = \s ->
1427− else if isJsonSafe s then s
1428− else escapeJsonStringAcc s ""
1430−escapeJsonStringAcc : Text -> Text -> Text
1431−escapeJsonStringAcc = \s acc ->
1432− if s == "" then acc
1433− else let c = take 1 s in
1434− if c == "\\" then escapeJsonStringAcc (drop 1 s) (acc ++ "\\\\")
1435− else if c == "\"" then escapeJsonStringAcc (drop 1 s) (acc ++ "\\\"")
1436− else if c == "\n" then escapeJsonStringAcc (drop 1 s) (acc ++ "\\n")
1437− else if c == "\r" then escapeJsonStringAcc (drop 1 s) (acc ++ "\\r")
1438− else if c == "\t" then escapeJsonStringAcc (drop 1 s) (acc ++ "\\t")
1439− else if contains c printableAscii then escapeJsonStringAcc (drop 1 s) (acc ++ c)
1440− else escapeJsonStringAcc (drop 1 s) acc
1442any : [a] -> (a -> Bool) -> Bool
451any : [a] -> (a -> Bool) -> Bool
1443any = \xs pred -> fold (\acc x -> if acc then acc else pred x) (False {}) xs
452any = \xs pred -> fold (\acc x -> if acc then acc else pred x) (False {}) xs
1444none : [a] -> (a -> Bool) -> Bool
453none : [a] -> (a -> Bool) -> Bool
1445none = \xs pred -> not (any xs pred)
454none = \xs pred -> not (any xs pred)
1446when = \cond action -> if cond then action else yield {}
455when = \cond action -> if cond then action else yield {}
1447−whenOk = \result action -> case result of
1450clamp = \lo hi x -> if x < lo then lo else if x > hi then hi else x
456clamp = \lo hi x -> if x < lo then lo else if x > hi then hi else x
1451−-- Union that skips empty lists (avoids allocation overhead on empty buckets).
1452−-- When one side is empty, returns the other without copying.
1453−unionNE = \a b -> if count a == 0 then b else if count b == 0 then a else union a b
1454min = \a b -> if a < b then a else b
457min = \a b -> if a < b then a else b
1455max = \a b -> if a > b then a else b
458max = \a b -> if a > b then a else b
1457−-- Per-sender drop counter helpers: increment a per-key counter and drain it for a specific key.
1458−-- Used to track per-sender delivery receipt / expiration notification drops.
1459−-- LRU eviction: when at capacity, evict the entry least recently updated (oldest lastUpdated).
1460−-- Previous strategy evicted by lowest count, which could discard active senders with few drops.
1461−incrementDropCounter = \entries key n t ->
1462− if any entries (\e -> e.senderKey == key)
1463− then do e <- entries; yield (if e.senderKey == key then {senderKey: e.senderKey, count: e.count + n, lastUpdated: t} else e)
1464− else if count entries >= maxDroppedCountEntries
1465− then union (evictOneOldest entries (\e -> e.lastUpdated)) [{senderKey: key, count: n, lastUpdated: t}]
1466− else union entries [{senderKey: key, count: n, lastUpdated: t}]
1468−drainDropCounter = \entries key ->
1469− case headOf (do e <- entries; where e.senderKey == key; yield e) of
1470− Nothing {} -> {count: 0, remaining: entries}
1471− Just {value: e} -> {count: e.count, remaining: do x <- entries; where x.senderKey != key; yield x}
1473−-- Queue a cancel notification for a recipient. Called when a message is cancelled
1474−-- so the recipient's next poll delivers the retraction. Per-key cap prevents one
1475−-- targeted recipient from consuming the whole notification queue.
1476−queueCancelNotification : PubkeyHex -> MessageIdHex -> Timestamp -> IO ()
1477−queueCancelNotification = \toKey messageId t -> atomic do
1478− cn <- *cancelNotifications
1479− let forKey = count (do c <- cn; where c.toKey == toKey; yield c)
1480− if forKey >= maxCancelNotificationsPerKey then yield {}
1482− let updated = union cn [{toKey: toKey, messageId: messageId, cancelledAt: t}]
1483− set *cancelNotifications = if count updated > maxCancelNotifications
1484− then evictOneOldest updated (\c -> c.cancelledAt)
1487−-- Batch version: queue cancel notifications for multiple entries at once.
1488−queueCancelNotificationBatch = \entries t ->
1489− case headOf entries of
1490− Nothing {} -> yield {}
1491− Just {value: e} -> do
1492− let rest = do x <- entries; where x.messageId != e.messageId || x.toKey != e.toKey; yield x
1493− queueCancelNotification e.toKey e.messageId t
1494− queueCancelNotificationBatch rest t
1496−-- NOTE: fold always traverses the full list even after finding the first element.
1497−-- This is O(n) where O(1) suffices, but Knot lacks list destructuring (case xs of
1498−-- (x : rest) -> ...) that would allow short-circuit. Used pervasively on hot paths
1499−-- (sendMessageCore, handleForwardMessage, gossip). If Knot adds list pattern matching
1500−-- or a built-in head/uncons primitive, replace this to eliminate the O(n) overhead.
1501headOf = \items -> fold (\acc x -> case acc of
460headOf = \items -> fold (\acc x -> case acc of
1502 Nothing {} -> Just {value: x}
461 Nothing {} -> Just {value: x}
1503 _ -> acc) Nothing {} items
462 _ -> acc) Nothing {} items
464+minBy = \items getKey -> fold (\acc x -> case acc of
465+ Nothing {} -> Just {value: x}
466+ Just {value: v} -> if getKey x < getKey v then Just {value: x} else acc) Nothing {} items
1505maxBy = \items getKey -> fold (\acc x -> case acc of
468maxBy = \items getKey -> fold (\acc x -> case acc of
1506 Nothing {} -> Just {value: x}
469 Nothing {} -> Just {value: x}
1507 Just {value: v} -> if getKey x > getKey v then Just {value: x} else acc) Nothing {} items
470 Just {value: v} -> if getKey x > getKey v then Just {value: x} else acc) Nothing {} items
1509−minBy = \items getKey -> fold (\acc x -> case acc of
472+-- Drop the single oldest entry by key (LRU-style eviction)
473+evictOldest = \items getKey ->
474+ case minBy items getKey of
1510− Nothing {} -> Just {value: x}
476+ Just {value: oldest} ->
1511− Just {value: v} -> if getKey x < getKey v then Just {value: x} else acc) Nothing {} items
477+ let key = getKey oldest in
478+ let r = fold (\acc x ->
479+ if not acc.done && getKey x == key then {items: acc.items, done: True {}}
480+ else {items: union acc.items [x], done: acc.done}) {items: [], done: False {}} items
483+capList = \items maxN getKey ->
484+ if count items > maxN then evictOldest items getKey else items
1513−-- Hex encoding utilities for token generation
486+-- Hex tokens
1514hexDigit : Int -> Text
487hexDigit : Int -> Text
1515hexDigit = \n -> take 1 (drop (clamp 0 15 n) "0123456789abcdef")
488hexDigit = \n -> take 1 (drop (clamp 0 15 n) "0123456789abcdef")
1517byteToHex : Int -> Text
490byteToHex : Int -> Text
1518byteToHex = \n -> hexDigit (n / 16) ++ hexDigit (n - (n / 16) * 16)
491byteToHex = \n -> hexDigit (n / 16) ++ hexDigit (n - (n / 16) * 16)
1520−-- Encode a 24-bit integer as 6 hex characters (3 bytes)
1521intTo3Hex : Int -> Text
493intTo3Hex : Int -> Text
1522intTo3Hex = \n ->
494intTo3Hex = \n ->
1523 let b0 = n / 65536 in
495 let b0 = n / 65536 in
@@ -1526,57 +498,53 @@ intTo3Hex = \n ->
1526 let b2 = r0 - b1 * 256 in
498 let b2 = r0 - b1 * 256 in
1527 byteToHex b0 ++ byteToHex b1 ++ byteToHex b2
499 byteToHex b0 ++ byteToHex b1 ++ byteToHex b2
1529−-- Generate a random hex token (n chunks of 3 bytes each = 6n hex chars)
1530genTokenN = \n -> if n <= 0 then yield "" else do
501genTokenN = \n -> if n <= 0 then yield "" else do
1531 chunk <- randomInt 16777216
502 chunk <- randomInt 16777216
1532 rest <- genTokenN (n - 1)
503 rest <- genTokenN (n - 1)
1533 yield (intTo3Hex chunk ++ rest)
504 yield (intTo3Hex chunk ++ rest)
1535−-- Token generation parameters (linked to safeCompareLen for consistency)
1537−tokenHexLen = 6 * tokenChunks -- 48; each chunk produces 6 hex chars (3 bytes)
1539−-- Default token: tokenChunks chunks = tokenHexLen hex chars = 24 bytes of randomness
1540−genToken = genTokenN tokenChunks
506+genToken = genTokenN 8
1542tooLong : Text -> Int -> Bool
508tooLong : Text -> Int -> Bool
1543tooLong = \s maxLen -> drop maxLen s != ""
509tooLong = \s maxLen -> drop maxLen s != ""
1545−-- Sanitize correlationId: truncate to maxCorrelationIdLen and strip non-printable characters
511+-- Printable ASCII allowlist
1546−-- to prevent log injection attacks. A malicious peer could inject fake [ERROR] entries or
1547−-- use ANSI escape codes to manipulate terminal output. Only printable ASCII (0x20-0x7E)
1548−-- is kept; all other bytes (null, control chars, escape sequences, DEL, high bytes) are
1549−-- stripped. This is stricter than the original \n/\r/\t filter.
1550−sanitizeCorrelationId : Text -> Text
1551−sanitizeCorrelationId = \cid -> stripNonPrintable (take maxCorrelationIdLen cid)
1553−-- Printable ASCII characters (0x20 through 0x7E): space, symbols, digits, letters, punctuation.
1554−-- Used as an allowlist by stripNonPrintable. Excludes DEL (0x7F) and all control chars (0x00-0x1F).
1555printableAscii : Text
512printableAscii : Text
1556printableAscii = " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
513printableAscii = " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
1558−-- Strip all non-printable characters from a string (allowlist approach).
515+-- Strip non-printable characters via simple recursion (no accumulator)
1559−-- Keeps only characters in the printable ASCII range (0x20-0x7E).
1560−-- Uses an accumulator parameter for tail recursion (TCO-safe in Knot):
1561−-- the recursive call is in tail position, not wrapped by ++.
1562stripNonPrintable : Text -> Text
516stripNonPrintable : Text -> Text
1563−stripNonPrintable = \s -> stripNonPrintableAcc s ""
517+stripNonPrintable = \s ->
519+ else let c = take 1 s in
520+ if contains c printableAscii then c ++ stripNonPrintable (drop 1 s)
521+ else stripNonPrintable (drop 1 s)
1565−stripNonPrintableAcc : Text -> Text -> Text
523+sanitizeCorrelationId : Text -> Text
1566−stripNonPrintableAcc = \s acc ->
524+sanitizeCorrelationId = \cid -> stripNonPrintable (take maxCorrelationIdLen cid)
526+-- Escape JSON string via simple recursion
527+escapeJsonString : Text -> Text
528+escapeJsonString = \s ->
1567− if s == "" then acc
529+ if s == "" then ""
1568 else let c = take 1 s in
530 else let c = take 1 s in
531+ if c == "\\" then "\\\\" ++ escapeJsonString (drop 1 s)
532+ else if c == "\"" then "\\\"" ++ escapeJsonString (drop 1 s)
533+ else if c == "\n" then "\\n" ++ escapeJsonString (drop 1 s)
534+ else if c == "\r" then "\\r" ++ escapeJsonString (drop 1 s)
535+ else if c == "\t" then "\\t" ++ escapeJsonString (drop 1 s)
1569− if contains c printableAscii then stripNonPrintableAcc (drop 1 s) (acc ++ c)
536+ else if contains c printableAscii then c ++ escapeJsonString (drop 1 s)
1570− else stripNonPrintableAcc (drop 1 s) acc
537+ else escapeJsonString (drop 1 s)
539+logEvent = \level event msg ->
540+ let formatted = "{\"level\":\"" ++ escapeJsonString level ++ "\",\"event\":\"" ++ escapeJsonString event ++ "\",\"msg\":\"" ++ escapeJsonString msg ++ "\"}"
541+ in if level == "error" then logError formatted
542+ else if level == "warn" then logWarn formatted
543+ else logInfo formatted
1572isHexChar : Text -> Bool
545isHexChar : Text -> Bool
1573isHexChar = \c -> contains c "0123456789abcdef"
546isHexChar = \c -> contains c "0123456789abcdef"
1575−-- Validates that a string is composed of valid hex character pairs.
1576−-- Recursive with drop 2 per call; the recursive call is in tail position so
1577−-- Knot's TCO compiles it to a loop. Max depth is bounded by isValidBoundedHex's
1578−-- tooLong check: maxBlobLen/2 = 32768 frames for the largest input (BlobHex).
1579−-- If TCO is ever disabled, this would stack overflow on large blobs.
1580isValidHexPairs : Text -> Bool
548isValidHexPairs : Text -> Bool
1581isValidHexPairs = \s ->
549isValidHexPairs = \s ->
1582 if s == "" then True {}
550 if s == "" then True {}
@@ -1599,75 +567,13 @@ isAllowedServerChar = \c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"
1599containsBadUrlChar : Text -> Bool
567containsBadUrlChar : Text -> Bool
1600containsBadUrlChar = \s -> any (chars s) (\c -> not (isAllowedServerChar c))
568containsBadUrlChar = \s -> any (chars s) (\c -> not (isAllowedServerChar c))
1602−-- Carrier-grade NAT range: 100.64.0.0/10 (RFC 6598)
1603−isCgnatRange : Text -> Bool
570+isAllDots : Text -> Bool
1604−isCgnatRange = \s ->
571+isAllDots = \s -> if s == "" then True {} else if take 1 s == "." then isAllDots (drop 1 s) else False {}
1606− && let d4 = take 1 (drop 4 s) in
1607− let d5 = take 1 (drop 5 s) in
1608− let d6 = take 1 (drop 6 s) in
1609− let d7 = take 1 (drop 7 s) in
1610− let twoDigitOctet = d6 == "." && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s) in
1611− let threeDigitOctet = d7 == "." && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s) in
1612− ((contains d4 "789" && isDigitChar d5 && twoDigitOctet)
1613− || (d4 == "6" && contains d5 "456789" && twoDigitOctet)
1614− || (d4 == "1" && contains d5 "01" && isDigitChar d6 && threeDigitOctet)
1615− || (d4 == "1" && d5 == "2" && contains d6 "01234567" && threeDigitOctet))
1617−containsMultipleColons : Text -> Bool
1618−containsMultipleColons = \s -> count (do c <- chars s; where c == ":"; yield c) > 1
1620−hasPatternAfterDot : (Text -> Bool) -> Text -> Bool
1621−hasPatternAfterDot = \pred s ->
1622− if s == "" then False {}
1623− else if take 1 s == "." && pred (drop 1 s) then True {}
1624− else hasPatternAfterDot pred (drop 1 s)
1626−isOctalStart : Text -> Bool
1627−isOctalStart = \s -> take 1 s == "0" && isDigitChar (take 1 (drop 1 s)) && isAllDigitsOrDotsUntilColonOrEnd (drop 2 s)
1628−hasOctalOctet : Text -> Bool
1629−hasOctalOctet = \s -> isOctalStart s || hasPatternAfterDot isOctalStart s
1631−-- Detect percent-encoded characters (e.g., %31%32%37.0.0.1 = 127.0.0.1)
1632−-- Blocks URL-encoded hostnames that could bypass isBadServerName SSRF protection.
1633−containsPercentEncoding : Text -> Bool
1634−containsPercentEncoding = \s ->
1635− if s == "" then False {}
1636− else if take 1 s == "%" && isHexChar (take 1 (drop 1 s)) && isHexChar (take 1 (drop 2 s)) then True {}
1637− else containsPercentEncoding (drop 1 s)
1639−-- Detect double percent-encoding (%25XX -> %XX after one decode pass).
1640−-- If any proxy in the path decodes once, the second layer resolves to a private IP.
1641−-- Example: %2531%2532%2537.0.0.1 -> %31%32%37.0.0.1 -> 127.0.0.1
1642−containsDoubleEncoding : Text -> Bool
1643−containsDoubleEncoding = \s ->
1644− if s == "" then False {}
1645− else if take 3 s == "%25" then True {}
1646− else containsDoubleEncoding (drop 1 s)
1648−isHexStart : Text -> Bool
1649−isHexStart = \s -> take 2 s == "0x" || take 2 s == "0X"
1650−hasHexPrefix : Text -> Bool
1651−hasHexPrefix = \s -> isHexStart s || hasPatternAfterDot isHexStart s
1653−isAllDigitsOrDotsUntilColonOrEnd : Text -> Bool
1654−isAllDigitsOrDotsUntilColonOrEnd = \s ->
1655− if s == "" then True {}
1656− else if take 1 s == ":" then True {}
1657− else if isDigitChar (take 1 s) || take 1 s == "." then isAllDigitsOrDotsUntilColonOrEnd (drop 1 s)
1660−isTrailingDots : Text -> Bool
1661−isTrailingDots = \s ->
1662− if s == "" then True {}
1663− else if take 1 s == ":" then True {}
1664− else if take 1 s == "." then isTrailingDots (drop 1 s)
1667stripTrailingDot : Text -> Text
573stripTrailingDot : Text -> Text
1668stripTrailingDot = \s ->
574stripTrailingDot = \s ->
1669 if s == "" then ""
575 if s == "" then ""
1670− else if take 1 s == "." && isTrailingDots (drop 1 s) then stripTrailingDot (drop 1 s)
576+ else if isAllDots s then ""
1671 else take 1 s ++ stripTrailingDot (drop 1 s)
577 else take 1 s ++ stripTrailingDot (drop 1 s)
1673normalizeServerName : Text -> Text
579normalizeServerName : Text -> Text
@@ -1678,197 +584,116 @@ serverHostN = normalizeServerName serverHost
1678isLocalServer : Text -> Bool
584isLocalServer : Text -> Bool
1679isLocalServer = \s -> s == serverHostN
585isLocalServer = \s -> s == serverHostN
1681−containsSuffixN : Text -> Int -> Text -> Bool
1682−containsSuffixN = \suffix suffixLen s ->
1683− if s == "" then False {}
1684− else if take suffixLen s == suffix && (drop suffixLen s == "" || take 1 (drop suffixLen s) == ":") then True {}
1685− else containsSuffixN suffix suffixLen (drop 1 s)
1687containsSuffix : Text -> Text -> Bool
587containsSuffix : Text -> Text -> Bool
1688−containsSuffix = \suffix s -> containsSuffixN suffix (count (chars suffix)) s
588+containsSuffix = \suffix s ->
1689−
589+ let suffixLen = count (chars suffix) in
1690−is172Private : Text -> Bool
590+ let sLen = count (chars s) in
1691−is172Private = \sn ->
591+ sLen >= suffixLen && drop (sLen - suffixLen) s == suffix
1692− take 4 sn == "172."
592+
1693− && let d1 = take 1 (drop 4 sn) in
593+-- Block private/reserved/internal hostnames (SSRF defense). Simplified vs original:
1694− let d2 = take 1 (drop 5 sn) in
594+-- still rejects the high-value cases (loopback, RFC1918, link-local, metadata services)
1695− take 1 (drop 6 sn) == "."
595+-- but skips obscure encoding tricks (octal, hex, percent-encoding).
1696− && isDigitChar (take 1 (drop 7 sn))
1697− && ((d1 == "1" && contains d2 "6789")
1698− || (d1 == "2" && isDigitChar d2)
1699− || (d1 == "3" && contains d2 "01"))
1701−isHighOctetPrefix : Text -> Bool
1702−isHighOctetPrefix = \sn ->
1704− && let d2 = take 1 (drop 1 sn) in
1705− let d3 = take 1 (drop 2 sn) in
1706− take 1 (drop 3 sn) == "."
1707− && isDigitChar (take 1 (drop 4 sn))
1708− && ((d2 == "2" && contains d3 "456789")
1709− || (contains d2 "34" && isDigitChar d3)
1710− || (d2 == "5" && contains d3 "012345"))
1712−matchesHostname : Text -> Text -> Bool
1713−matchesHostname = \sn name ->
1714− let nameLen = count (chars name) in
1715− take nameLen sn == name && (drop nameLen sn == "" || take 1 (drop nameLen sn) == ":")
1717−matchesHostnameOrSubdomain : Text -> Text -> Bool
1718−matchesHostnameOrSubdomain = \sn name ->
1719− matchesHostname sn name || containsSuffix ("." ++ name) sn
1721−hasDotBeforePort : Text -> Bool
1722−hasDotBeforePort = \s ->
1723− if s == "" then False {}
1724− else if take 1 s == ":" then False {}
1725− else if take 1 s == "." then True {}
1726− else hasDotBeforePort (drop 1 s)
1728−-- DNS rebinding / SSRF protection: reject server names that resolve to private/reserved addresses.
1729−-- Blocks localhost, private RFC1918 ranges, link-local, loopback, CGNAT, documentation ranges,
1730−-- IPv6 shorthand, octal/hex IP tricks, bare IPs without dots, and .arpa domains.
1731isBadServerName : Text -> Bool
596isBadServerName : Text -> Bool
1732isBadServerName = \sn ->
597isBadServerName = \sn ->
1733 let fc = take 1 sn in
598 let fc = take 1 sn in
1734− fc == ""
599+ fc == "" || fc == "." || fc == ":"
1737 || containsBadUrlChar sn
600 || containsBadUrlChar sn
1738− || not (hasDotBeforePort sn)
601+ || sn == "localhost"
1739− || matchesHostnameOrSubdomain sn "localhost"
602+ || containsSuffix ".localhost" sn
1740− || matchesHostname sn "localhost.localdomain"
603+ || containsSuffix ".local" sn
1741− || matchesHostnameOrSubdomain sn "local"
604+ || containsSuffix ".internal" sn
1742− || containsSuffix ".localhost" sn -- RFC 6761: foo.localhost resolves to loopback
1743− || matchesHostnameOrSubdomain sn "internal"
1744− || matchesHostnameOrSubdomain sn "metadata"
1745− || take 4 sn == "127." || take 3 sn == "10."
1746− || take 8 sn == "192.168."
1747− || take 8 sn == "169.254." -- link-local; also covers AWS EC2 metadata endpoint 169.254.169.254
1748− || take 2 sn == "0." || fc == "["
1750− || take 7 sn == "198.18." || take 7 sn == "198.19."
1751− || take 8 sn == "192.0.0."
1752− || take 8 sn == "192.0.2."
1753− || take 10 sn == "192.88.99."
1754− || take 11 sn == "198.51.100."
1755− || take 10 sn == "203.0.113."
1756− || take 2 sn == "::"
1758− || containsMultipleColons sn
1759− || hasOctalOctet sn
1761− || (isDigitChar fc && isAllDigitsOrDotsUntilColonOrEnd sn)
1762− || isHighOctetPrefix sn
1763 || containsSuffix ".arpa" sn
605 || containsSuffix ".arpa" sn
1764 || containsSuffix ".onion" sn
606 || containsSuffix ".onion" sn
1765− || containsSuffix ".i2p" sn
607+ || take 4 sn == "127."
1766− || containsSuffix ".corp" sn
608+ || take 3 sn == "10."
1767− || containsSuffix ".home" sn
609+ || take 8 sn == "192.168."
1768− || containsSuffix ".lan" sn
610+ || take 8 sn == "169.254."
1769− || containsSuffix ".intranet" sn
611+ || take 2 sn == "0."
1770− || containsSuffix ".test" sn
612+ || take 2 sn == "::"
1771− || containsSuffix ".example" sn
613+ || fc == "["
1772− || containsSuffix ".invalid" sn
614+
1773− || containsPercentEncoding sn
615+-- ============================================
1774− || containsDoubleEncoding sn
616+-- Auth helpers
1775− -- Kubernetes / service mesh internal DNS
617+-- ============================================
1776− || containsSuffix ".svc" sn
618+
1777− || containsSuffix ".cluster.local" sn
619+safeCompareLen = maxTokenLen + 16
1778− -- HashiCorp Consul service discovery
620+
1779− || containsSuffix ".consul" sn
621+-- Simple non-TCO constant-time comparison: compares character-by-character.
1780− || containsSuffix ".node.consul" sn
622+-- Returns True iff strings are non-empty and equal up to safeCompareLen.
1781− || containsSuffix ".service.consul" sn
623+safeCompareLoop : Text -> Text -> Int -> Int
1782− -- Cloud provider internal DNS (SSRF targets for metadata/internal services)
624+safeCompareLoop = \s1 s2 n ->
1783− || containsSuffix ".compute.internal" sn -- GCP internal DNS
625+ if n <= 0 then 0
1784− || containsSuffix ".ec2.internal" sn -- AWS EC2 internal DNS
626+ else
1785− || containsSuffix ".amazonaws.com" sn -- AWS service endpoints (S3, SQS, etc.)
627+ let c1 = take 1 s1 in
1786− || matchesHostname sn "metadata.google.internal" -- GCP metadata server
628+ let c2 = take 1 s2 in
1787− || containsSuffix ".internal.cloudapp.net" sn -- Azure VM internal DNS
629+ let d = if c1 == c2 then 0 else 1 in
1788− || matchesHostname sn "metadata.azure.com" -- Azure Instance Metadata Service (IMDS v2)
630+ let endMismatch = if c1 == "" then (if c2 == "" then 0 else 1) else (if c2 == "" then 1 else 0) in
1789− -- NOTE: Unicode/IDN defense is provided by containsBadUrlChar above, which rejects
631+ d + endMismatch + safeCompareLoop (drop 1 s1) (drop 1 s2) (n - 1)
1790− -- any character not in [0-9a-z-.:] via isAllowedServerChar. This blocks homoglyph
632+
1791− -- attacks (e.g., Greek omicron in "lοcalhost") assuming Knot's Text type preserves
633+safeCompare : Text -> Text -> Bool
1792− -- Unicode codepoints in take/contains operations. If Knot ever normalizes Unicode
634+safeCompare = \a b ->
1793− -- (NFKC/NFC) before comparison, add an explicit ASCII-range byte check here.
635+ if take 1 a == "" || take 1 b == "" then False {}
1794−
636+ else safeCompareLoop a b safeCompareLen == 0
1795−-- Look up a non-expired session matching the given token (constant-time comparison).
637+
1796−-- Caller passes the appropriate session bucket (sharded by token prefix).
638+matchIp : Text -> Text -> Bool
1797−authenticateSession : [Session] -> Text -> Timestamp -> AuthResult
639+matchIp = \clientIp sessionIp ->
1798−authenticateSession = \sessions token t ->
640+ if sessionIp == "" then True {}
1799− case headOf (do s <- sessions; where s.expiresAt > t && t - s.createdAt < maxSessionLifetime && safeCompare s.token token; yield s) of
641+ else if clientIp == "" then False {}
1800− Nothing {} -> Unauthorized {}
642+ else safeCompare clientIp sessionIp
1801− Just {value: s} -> Authorized {pubkey: s.pubkey, ip: s.ip}
1803−-- Fast re-authentication for poll Phase 3: pre-filters by known pubkey before
1804−-- running safeCompare. Reduces safeCompare calls from O(bucket_size) to
1805−-- O(sessions_for_key_in_bucket) (~1-2 vs ~600). Safe in this context because
1806−-- the pubkey was already verified in Phase 1.
1807−-- Theoretical race: if the session is revoked between Phase 1 and Phase 3 and a
1808−-- new session with the same token is created for a different pubkey, the pre-filter
1809−-- would miss it. This requires guessing a 24-byte (192-bit) random token, which is
1810−-- computationally infeasible (2^-192 collision probability).
1811−reauthenticateSession : [Session] -> Text -> PubkeyHex -> Timestamp -> Bool
1812−reauthenticateSession = \sessions token pubkey t ->
1813− any sessions (\s -> s.pubkey == pubkey && s.expiresAt > t && t - s.createdAt < maxSessionLifetime && safeCompare s.token token)
1815−-- Extract bearer token from "Authorization: Bearer <token>" header.
1816−-- Rejects empty tokens early to avoid unnecessary session bucket scans.
1817extractToken = \authHeader ->
644extractToken = \authHeader ->
1818 let token = drop 7 authHeader in
645 let token = drop 7 authHeader in
1819 if toLower (take 7 authHeader) == "bearer " && token != "" && not (tooLong token maxTokenLen)
646 if toLower (take 7 authHeader) == "bearer " && token != "" && not (tooLong token maxTokenLen)
1820 then Just {value: token}
647 then Just {value: token}
1821 else Nothing {}
648 else Nothing {}
1823−-- Constant-time secret comparison (prevents timing attacks on maintenance secret)
1824verifySecret : Text -> Text -> Bool
650verifySecret : Text -> Text -> Bool
1825−verifySecret = \token secret ->
1826− secret != "" && safeCompare token secret
651+verifySecret = \token secret -> secret != "" && safeCompare token secret
1828−verifyAuthWith : (Text -> Bool) -> Text -> Bool
1829−verifyAuthWith = \check authorization ->
1830− case extractToken authorization of
1831− Nothing {} -> False {}
1832− Just {value: token} -> check token
1834−-- Check maintenance auth against the runtime secret set via /maintenance/rotate-secret.
1835−-- Returns False when no secret has been set (maintenance endpoints disabled).
1836verifyMaintenanceAuth : Text -> IO Bool
653verifyMaintenanceAuth : Text -> IO Bool
1837verifyMaintenanceAuth = \authorization -> do
654verifyMaintenanceAuth = \authorization -> do
1838 secret <- *runtimeMaintenanceSecret
655 secret <- *runtimeMaintenanceSecret
1839 if secret == "" then yield False
656 if secret == "" then yield False
657+ else case extractToken authorization of
658+ Nothing {} -> yield False
1840− else yield (verifyAuthWith (\token -> verifySecret token secret) authorization)
659+ Just {value: token} -> yield (verifySecret token secret)
661+authenticateSession : [Session] -> Text -> Timestamp -> AuthResult
662+authenticateSession = \sessions token t ->
663+ case headOf (do s <- sessions; where s.expiresAt > t && safeCompare s.token token; yield s) of
664+ Nothing {} -> Unauthorized {}
665+ Just {value: s} -> Authorized {pubkey: s.pubkey, ip: s.ip}
667+withSessionAuth = \authorization t clientIp onUnauth onAuth -> do
668+ case extractToken authorization of
669+ Nothing {} -> onUnauth
670+ Just {value: token} -> do
671+ sessions <- *sessions
672+ case authenticateSession sessions token t of
673+ Unauthorized {} -> onUnauth
674+ Authorized {pubkey, ip} ->
675+ if not (matchIp clientIp ip) then onUnauth
1842−-- Check if a server is on the blocklist
1843isBlockedPeer : Text -> [Text] -> Bool
678isBlockedPeer : Text -> [Text] -> Bool
1844isBlockedPeer = \server blocked -> any blocked (\b -> b == server)
679isBlockedPeer = \server blocked -> any blocked (\b -> b == server)
1846−-- Check if a server passes the allowlist (empty allowlist = all allowed)
1847isAllowedByAllowlist : Text -> [Text] -> Bool
681isAllowedByAllowlist : Text -> [Text] -> Bool
1848isAllowedByAllowlist = \server allowed -> count allowed == 0 || any allowed (\a -> a == server)
682isAllowedByAllowlist = \server allowed -> count allowed == 0 || any allowed (\a -> a == server)
1850−-- Split text at the first colon. Returns {before, after}. Used to parse "Signed <sig>:<nonce>".
1851−-- Safe: signature hex and nonce are both [0-9a-f]+ (no colons), so exactly one colon separates them.
1852splitOnColon : Text -> {before: Text, after: Text}
684splitOnColon : Text -> {before: Text, after: Text}
1853−splitOnColon = \s -> splitOnColonInner s 0
685+splitOnColon = \s ->
1855−splitOnColonInner : Text -> Int -> {before: Text, after: Text}
1856−splitOnColonInner = \s pos ->
1857− if drop pos s == "" then {before: s, after: ""}
686+ if s == "" then {before: "", after: ""}
1858− else if take 1 (drop pos s) == ":" then {before: take pos s, after: drop (pos + 1) s}
687+ else if take 1 s == ":" then {before: "", after: drop 1 s}
1859− else splitOnColonInner s (pos + 1)
688+ else
1860−
689+ let r = splitOnColon (drop 1 s) in
1861−-- Generate a single-use token for outbound federation auth.
690+ {before: take 1 s ++ r.before, after: r.after}
1862−-- scope binds the token to a request type ("gossip", "forward", "ack") so a token
691+
1863−-- issued for one operation cannot authorize a different one.
1864−-- When signing is enabled, includes a random nonce in the signed message to prevent
1865−-- replay attacks (two requests with the same timestamp+scope produce different signatures).
1866−-- Format: "Signed <sig>:<nonce>" — backward compatible (old format has no colon).
1867generateFederationAuth : Text -> Timestamp -> IO {network} Text
692generateFederationAuth : Text -> Timestamp -> IO {network} Text
1868generateFederationAuth = \scope requestTimestamp ->
693generateFederationAuth = \scope requestTimestamp ->
1869 if serverFederationPrivateKeyHex != ""
694 if serverFederationPrivateKeyHex != ""
1871− nonce <- genTokenN tokenChunks
696+ nonce <- genTokenN 8
1872 let message = textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ serverHostN ++ "|" ++ nonce)
697 let message = textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ serverHostN ++ "|" ++ nonce)
1873 let sig = sign (bytesFromHex serverFederationPrivateKeyHex) message
698 let sig = sign (bytesFromHex serverFederationPrivateKeyHex) message
1874 yield ("Signed " ++ bytesToHex sig ++ ":" ++ nonce)
699 yield ("Signed " ++ bytesToHex sig ++ ":" ++ nonce)
@@ -1878,1567 +703,176 @@ generateFederationAuth = \scope requestTimestamp ->
1878 atomic do
703 atomic do
1879 pending <- *pendingVerifications
704 pending <- *pendingVerifications
1880 let updated = union pending [{token: token, createdAt: t, scope: scope}]
705 let updated = union pending [{token: token, createdAt: t, scope: scope}]
1881− set *pendingVerifications = if count updated > maxPendingVerifications
706+ set *pendingVerifications = capList updated maxPendingVerifications (\p -> p.createdAt)
1882− then evictOneOldest updated (\p -> p.createdAt)
1884 yield ("Bearer " ++ token)
707 yield ("Bearer " ++ token)
1886−-- Verify an inbound federation token. Checks a short-lived per-server cache first
1887−-- to reduce outbound HTTP calls (a peer sending N requests/second would otherwise
1888−-- force N verify callbacks). Cache hit means the server was verified within the last
1889−-- verificationCacheMs — the token itself is still single-use (consumed on first verify),
1890−-- but subsequent requests from the same server in the same window are trusted.
1891−-- No retry: a failed verify rejects the request. The peer's federation rate limit + circuit breaker
1892−-- handle unreliable peers; retrying here doubles verify traffic and blocks with a 1s sleep per op,
1893−-- which a malicious peer can exploit for amplification.
1894−-- Adaptive verify cache TTL: scales with recent request volume from a peer.
1895−-- Peers sending many requests/second benefit from longer cache (fewer callbacks).
1896−-- Uses peerLatencies.count as a proxy for request volume (tracks verify calls per window).
1897−-- Returns TTL in ms between verificationCacheMinMs and verificationCacheMaxMs.
1898−adaptiveVerifyCacheTtl : Text -> [{server: Text, totalMs: Int, count: Int, maxMs: Int, windowStart: Timestamp}] -> Int<Ms>
1899−adaptiveVerifyCacheTtl = \server peerLats ->
1900− case headOf (do p <- peerLats; where p.server == server; yield p) of
1901− Nothing {} -> verificationCacheMinMs
1903− -- Scale: 0-5 calls = min, 50+ calls = max, linear interpolation between
1904− let scale = clamp 0 100 (p.count * 100 / 50)
1905− in verificationCacheMinMs + (verificationCacheMaxMs - verificationCacheMinMs) * scale / 100
1907verifyFederationCallback : Text -> Text -> Text -> IO {network} Bool
709verifyFederationCallback : Text -> Text -> Text -> IO {network} Bool
1908verifyFederationCallback = \fromServer authorization scope ->
710verifyFederationCallback = \fromServer authorization scope ->
1909− case extractToken authorization of
711+ case extractToken authorization of
1910− Nothing {} -> yield (False {})
712+ Nothing {} -> yield False
1911− Just {value: token} -> do
713+ Just {value: token} -> do
1912− -- Check verify cache: skip the outbound HTTP call if we recently verified this server+scope
1914− cached <- atomic do
1915− cache <- *verificationCache
1916− peerLats <- *peerLatencies
1917− let cacheTtl = adaptiveVerifyCacheTtl fromServer peerLats
1918− yield (any cache (\c -> c.server == fromServer && c.scope == scope && t - c.verifiedAt < cacheTtl))
1919− if cached then yield (True {})
1922− result <- fetchFederation fromServer (VerifyToken {token: token, scope: scope})
714+ result <- fetch (federationUrl fromServer) (VerifyToken {token: token, scope: scope})
1924− let verifyLatency = endTime - startTime
1925− when (verifyLatency > federationVerifyTimeoutMs) (do
1926− logWarn ("federation: slow verify callback to " ++ fromServer ++ " (" ++ show verifyLatency ++ "ms, threshold: " ++ show federationVerifyTimeoutMs ++ "ms)")
1928− svc <- *slowVerifyCount
1929− set *slowVerifyCount = svc + 1)
1930− case result of
715+ case result of
1932− logWarn ("federation: verify callback to " ++ fromServer ++ " failed: " ++ show e)
1934− vfc <- *verifyFailCount
1935− set *verifyFailCount = vfc + 1
1936− yield (False {})
716+ Err _ -> yield False
1938− when r.ok (atomic do
1939− cache <- *verificationCache
1940− peerLats <- *peerLatencies
1941− let cacheTtl = adaptiveVerifyCacheTtl fromServer peerLats
1942− let cleaned = do c <- cache; where t - c.verifiedAt < cacheTtl; yield c
1943− let updated = union cleaned [{server: fromServer, scope: scope, verifiedAt: t}]
1944− set *verificationCache = if count updated > maxVerificationCache
1945− then evictOneOldest updated (\c -> c.verifiedAt)
1947− yield r.ok
717+ Ok r -> yield r.ok
1949−-- ============================================
719+-- Verify Ed25519 signed federation request, with optional nonce.
1950−-- Session Bucket Helpers
720+verifyFederationSignature : Text -> Text -> Text -> Text -> Timestamp -> IO {network} Bool
1951−-- ============================================
721+verifyFederationSignature = \fromServer signatureHex nonce scope requestTimestamp -> do
1952−-- Sessions are sharded into 16 buckets by the first hex char of the token.
722+ result <- fetch (federationUrl fromServer) (FederationPubkey {})
1953−-- This reduces auth scan from O(n) to O(n/16) on the hot path.
723+ case result of
1954−
724+ Err _ -> yield False
1955−tokenBucket : Text -> Int
725+ Ok r ->
1956−tokenBucket = \token -> clamp 0 15 (hexCharIndex (take 1 token))
1958−readSessionBucket : Int -> IO [Session]
1959−readSessionBucket = \b ->
1960− if b == 0 then do s <- *sessionBucket0; yield s
1961− else if b == 1 then do s <- *sessionBucket1; yield s
1962− else if b == 2 then do s <- *sessionBucket2; yield s
1963− else if b == 3 then do s <- *sessionBucket3; yield s
1964− else if b == 4 then do s <- *sessionBucket4; yield s
1965− else if b == 5 then do s <- *sessionBucket5; yield s
1966− else if b == 6 then do s <- *sessionBucket6; yield s
1967− else if b == 7 then do s <- *sessionBucket7; yield s
1968− else if b == 8 then do s <- *sessionBucket8; yield s
1969− else if b == 9 then do s <- *sessionBucket9; yield s
1970− else if b == 10 then do s <- *sessionBucket10; yield s
1971− else if b == 11 then do s <- *sessionBucket11; yield s
1972− else if b == 12 then do s <- *sessionBucket12; yield s
1973− else if b == 13 then do s <- *sessionBucket13; yield s
1974− else if b == 14 then do s <- *sessionBucket14; yield s
1975− else do s <- *sessionBucket15; yield s
1977−writeSessionBucket : Int -> [Session] -> IO ()
1978−writeSessionBucket = \b sessions ->
1979− if b == 0 then set *sessionBucket0 = sessions
1980− else if b == 1 then set *sessionBucket1 = sessions
1981− else if b == 2 then set *sessionBucket2 = sessions
1982− else if b == 3 then set *sessionBucket3 = sessions
1983− else if b == 4 then set *sessionBucket4 = sessions
1984− else if b == 5 then set *sessionBucket5 = sessions
1985− else if b == 6 then set *sessionBucket6 = sessions
1986− else if b == 7 then set *sessionBucket7 = sessions
1987− else if b == 8 then set *sessionBucket8 = sessions
1988− else if b == 9 then set *sessionBucket9 = sessions
1989− else if b == 10 then set *sessionBucket10 = sessions
1990− else if b == 11 then set *sessionBucket11 = sessions
1991− else if b == 12 then set *sessionBucket12 = sessions
1992− else if b == 13 then set *sessionBucket13 = sessions
1993− else if b == 14 then set *sessionBucket14 = sessions
1994− else set *sessionBucket15 = sessions
1996−-- Read all 16 session buckets (for per-key operations, prune, stats).
1997−-- Right-nested union is intentional: union copies the left operand, so right-nesting
1998−-- copies small buckets onto the growing accumulator (O(n) total), while left-nesting
1999−-- would copy the growing accumulator repeatedly (O(n * 16)).
2000−readAllSessions : IO [Session]
2001−readAllSessions = do
2002− s0 <- *sessionBucket0
2003− s1 <- *sessionBucket1
2004− s2 <- *sessionBucket2
2005− s3 <- *sessionBucket3
2006− s4 <- *sessionBucket4
2007− s5 <- *sessionBucket5
2008− s6 <- *sessionBucket6
2009− s7 <- *sessionBucket7
2010− s8 <- *sessionBucket8
2011− s9 <- *sessionBucket9
2012− s10 <- *sessionBucket10
2013− s11 <- *sessionBucket11
2014− s12 <- *sessionBucket12
2015− s13 <- *sessionBucket13
2016− s14 <- *sessionBucket14
2017− s15 <- *sessionBucket15
2018− yield (unionNE s0 (unionNE s1 (unionNE s2 (unionNE s3 (unionNE s4 (unionNE s5 (unionNE s6 (unionNE s7 (unionNE s8 (unionNE s9 (unionNE s10 (unionNE s11 (unionNE s12 (unionNE s13 (unionNE s14 s15)))))))))))))))
2020−-- Count sessions across all 16 buckets without materializing the full list
2021−countAllSessions : IO Int
2022−countAllSessions = do
2023− s0 <- *sessionBucket0
2024− s1 <- *sessionBucket1
2025− s2 <- *sessionBucket2
2026− s3 <- *sessionBucket3
2027− s4 <- *sessionBucket4
2028− s5 <- *sessionBucket5
2029− s6 <- *sessionBucket6
2030− s7 <- *sessionBucket7
2031− s8 <- *sessionBucket8
2032− s9 <- *sessionBucket9
2033− s10 <- *sessionBucket10
2034− s11 <- *sessionBucket11
2035− s12 <- *sessionBucket12
2036− s13 <- *sessionBucket13
2037− s14 <- *sessionBucket14
2038− s15 <- *sessionBucket15
2039− yield (count s0 + count s1 + count s2 + count s3 + count s4 + count s5 + count s6 + count s7 + count s8 + count s9 + count s10 + count s11 + count s12 + count s13 + count s14 + count s15)
2041−-- Short-circuit scan: check if any session bucket contains a session for the given pubkey.
2042−-- Stops reading buckets as soon as one matching session is found (O(n/16) best case
2043−-- vs O(n) for readAllSessions when the user has sessions in early buckets).
2044−hasSessionForKey : PubkeyHex -> Int -> IO Bool
2045−hasSessionForKey = \pubkey b ->
2046− if b > 15 then yield (False {})
2048− bucket <- readSessionBucket b
2049− if any bucket (\s -> s.pubkey == pubkey) then yield (True {})
2050− else hasSessionForKey pubkey (b + 1)
2052−-- Check if a pubkey has any non-expired session across all buckets (short-circuits on first match).
2053−-- Fast-path: returns False immediately when totalSessionCount is 0, avoiding 16 bucket reads.
2054−hasActiveSessionForKey : PubkeyHex -> Timestamp -> Int -> IO Bool
2055−hasActiveSessionForKey = \pubkey t b ->
2056− if b > 15 then yield (False {})
2058− bucket <- readSessionBucket b
2059− if any bucket (\s -> s.pubkey == pubkey && s.expiresAt > t) then yield (True {})
2060− else hasActiveSessionForKey pubkey t (b + 1)
2062−-- Filter a list of pubkeys to those with active (non-expired) sessions.
2063−-- Checks each key independently (short-circuits per key), avoids materializing all sessions.
2064−-- Fast-path: returns empty list when no sessions exist (totalSessionCount == 0).
2065−filterActiveSessionKeys : [PubkeyHex] -> Timestamp -> IO [PubkeyHex]
2066−filterActiveSessionKeys = \keys t ->
2067− totalSessions <- *totalSessionCount
2068− if totalSessions == 0 then yield []
2069− else case headOf keys of
2070− Nothing {} -> yield []
2071− Just {value: k} -> do
2072− let rest = do x <- keys; where x != k; yield x
2073− hasActive <- hasActiveSessionForKey k t 0
2074− remaining <- filterActiveSessionKeys rest t
2075− if hasActive then yield (union [k] remaining) else yield remaining
2077−-- Collect all sessions for a specific pubkey across all buckets without materializing the full
2078−-- session list. Each bucket is read independently (O(n/16) per bucket), avoiding the O(n)
2079−-- readAllSessions union. Used by handleAdminListSessions.
2080−collectSessionsForKey : PubkeyHex -> Int -> IO [Session]
2081−collectSessionsForKey = \pubkey b ->
2082− if b > 15 then yield []
726+ if not r.ok || r.pubkey == "" then yield False
2084− bucket <- readSessionBucket b
728+ let msg = if nonce == ""
2085− let matching = do s <- bucket; where s.pubkey == pubkey; yield s
729+ then scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer
2086− rest <- collectSessionsForKey pubkey (b + 1)
730+ else scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer ++ "|" ++ nonce
2087− yield (union matching rest)
731+ in yield (verify (bytesFromHex r.pubkey) (textToBytes msg) (bytesFromHex signatureHex))
2089−-- Count sessions for a specific pubkey across all buckets (avoids materializing full session list).
733+withFederationAuth = \authorization t respond fromServer scope requestTimestamp precondition action -> do
2090−-- Used in verify fast path to skip readAllSessions.
734+ blocked <- *blockedPeers
2091−countSessionsForKey : PubkeyHex -> IO Int
735+ if isBlockedPeer fromServer blocked
2092−countSessionsForKey = \pubkey -> countSessionsInBucket pubkey 0
736+ then yield (respond {ok: False {}, error: "blocked", retryAfterMs: 0})
2094−countSessionsInBucket : PubkeyHex -> Int -> IO Int
2095−countSessionsInBucket = \pubkey b ->
2096− if b > 15 then yield 0
2098− bucket <- readSessionBucket b
2099− let n = count (do s <- bucket; where s.pubkey == pubkey; yield s)
2100− rest <- countSessionsInBucket pubkey (b + 1)
2103−-- Remove all sessions for a pubkey across all 16 buckets, returning total revoked.
2104−-- Each bucket is filtered in-place (avoids readAllSessions + writeAllSessions repartition).
2105−revokeSessionsForKey : PubkeyHex -> Int -> IO Int
2106−revokeSessionsForKey = \pubkey b ->
2107− if b > 15 then yield 0
2109− bucket <- readSessionBucket b
2110− let kept = do s <- bucket; where s.pubkey != pubkey; yield s
2111− let removed = count bucket - count kept
2112− when (removed > 0) (writeSessionBucket b kept)
2113− rest <- revokeSessionsForKey pubkey (b + 1)
2114− yield (removed + rest)
2116−-- Apply a filter/transform to every session bucket and return the total count.
2117−-- Combines transform + count in one pass, avoiding a redundant 16-bucket traversal.
2118−pruneAndCountAllSessions : ([Session] -> [Session]) -> IO Int
2119−pruneAndCountAllSessions = \f -> pruneAndCountSessionBucket f 0
2121−pruneAndCountSessionBucket : ([Session] -> [Session]) -> Int -> IO Int
2122−pruneAndCountSessionBucket = \f b ->
2123− if b > 15 then yield 0
2125− bucket <- readSessionBucket b
2126− let pruned = f bucket
2127− writeSessionBucket b pruned
2128− rest <- pruneAndCountSessionBucket f (b + 1)
2129− yield (count pruned + rest)
2131−-- Apply a filter/transform to every session bucket
2132−transformAllSessionBuckets : ([Session] -> [Session]) -> IO ()
2133−transformAllSessionBuckets = \f -> do
2134− b0 <- *sessionBucket0; set *sessionBucket0 = f b0
2135− b1 <- *sessionBucket1; set *sessionBucket1 = f b1
2136− b2 <- *sessionBucket2; set *sessionBucket2 = f b2
2137− b3 <- *sessionBucket3; set *sessionBucket3 = f b3
2138− b4 <- *sessionBucket4; set *sessionBucket4 = f b4
2139− b5 <- *sessionBucket5; set *sessionBucket5 = f b5
2140− b6 <- *sessionBucket6; set *sessionBucket6 = f b6
2141− b7 <- *sessionBucket7; set *sessionBucket7 = f b7
2142− b8 <- *sessionBucket8; set *sessionBucket8 = f b8
2143− b9 <- *sessionBucket9; set *sessionBucket9 = f b9
2144− b10 <- *sessionBucket10; set *sessionBucket10 = f b10
2145− b11 <- *sessionBucket11; set *sessionBucket11 = f b11
2146− b12 <- *sessionBucket12; set *sessionBucket12 = f b12
2147− b13 <- *sessionBucket13; set *sessionBucket13 = f b13
2148− b14 <- *sessionBucket14; set *sessionBucket14 = f b14
2149− b15 <- *sessionBucket15; set *sessionBucket15 = f b15
2151−-- Single-pass partition of sessions by token bucket and write to all 16 buckets.
2152−-- Mirrors writeAllPresence for the session sharding scheme.
2153−writeAllSessions : [Session] -> IO ()
2154−writeAllSessions = \sessions -> do
2155− let partitioned = fold (\acc s ->
2156− let b = tokenBucket s.token in
2157− {b0: if b == 0 then union [s] acc.b0 else acc.b0,
2158− b1: if b == 1 then union [s] acc.b1 else acc.b1,
2159− b2: if b == 2 then union [s] acc.b2 else acc.b2,
2160− b3: if b == 3 then union [s] acc.b3 else acc.b3,
2161− b4: if b == 4 then union [s] acc.b4 else acc.b4,
2162− b5: if b == 5 then union [s] acc.b5 else acc.b5,
2163− b6: if b == 6 then union [s] acc.b6 else acc.b6,
2164− b7: if b == 7 then union [s] acc.b7 else acc.b7,
2165− b8: if b == 8 then union [s] acc.b8 else acc.b8,
2166− b9: if b == 9 then union [s] acc.b9 else acc.b9,
2167− b10: if b == 10 then union [s] acc.b10 else acc.b10,
2168− b11: if b == 11 then union [s] acc.b11 else acc.b11,
2169− b12: if b == 12 then union [s] acc.b12 else acc.b12,
2170− b13: if b == 13 then union [s] acc.b13 else acc.b13,
2171− b14: if b == 14 then union [s] acc.b14 else acc.b14,
2172− b15: if b == 15 then union [s] acc.b15 else acc.b15})
2173− {b0: [], b1: [], b2: [], b3: [], b4: [], b5: [], b6: [], b7: [], b8: [], b9: [], b10: [], b11: [], b12: [], b13: [], b14: [], b15: []} sessions
2174− writeSessionBucket 0 partitioned.b0
2175− writeSessionBucket 1 partitioned.b1
2176− writeSessionBucket 2 partitioned.b2
2177− writeSessionBucket 3 partitioned.b3
2178− writeSessionBucket 4 partitioned.b4
2179− writeSessionBucket 5 partitioned.b5
2180− writeSessionBucket 6 partitioned.b6
2181− writeSessionBucket 7 partitioned.b7
2182− writeSessionBucket 8 partitioned.b8
2183− writeSessionBucket 9 partitioned.b9
2184− writeSessionBucket 10 partitioned.b10
2185− writeSessionBucket 11 partitioned.b11
2186− writeSessionBucket 12 partitioned.b12
2187− writeSessionBucket 13 partitioned.b13
2188− writeSessionBucket 14 partitioned.b14
2189− writeSessionBucket 15 partitioned.b15
2191−-- Evict the single oldest session across all 16 buckets, writing only the affected bucket.
2192−-- Two-pass: pass 1 finds the bucket containing the global minimum expiresAt,
2193−-- pass 2 removes the oldest entry from that bucket. Avoids readAllSessions + writeAllSessions.
2194−evictOldestSessionFromBuckets : Int -> Maybe {bucketIdx: Int, minExpiry: Timestamp} -> IO ()
2195−evictOldestSessionFromBuckets = \b candidate ->
2197− then case candidate of
2198− Nothing {} -> yield {}
2199− Just {value: c} -> do
2200− bucket <- readSessionBucket c.bucketIdx
2201− writeSessionBucket c.bucketIdx (evictOneOldest bucket (\s -> s.expiresAt))
2203− bucket <- readSessionBucket b
738+ allowed <- *allowedPeers
2204− let bucketMin = minBy bucket (\s -> s.expiresAt)
739+ if not (isAllowedByAllowlist fromServer allowed)
2205− let newCandidate = case bucketMin of
740+ then yield (respond {ok: False {}, error: "not_allowed", retryAfterMs: 0})
2206− Nothing {} -> candidate
2207− Just {value: s} -> case candidate of
2208− Nothing {} -> Just {bucketIdx: b, minExpiry: s.expiresAt}
2209− Just {value: c} -> if s.expiresAt < c.minExpiry then Just {bucketIdx: b, minExpiry: s.expiresAt} else candidate
2210− evictOldestSessionFromBuckets (b + 1) newCandidate
2212−-- ============================================
2213−-- Presence Bucket Helpers
2214−-- ============================================
2215−-- Presence is sharded into 16 buckets by the first hex char of the pubkey.
2216−-- Hot-path operations (send, lookup, poll) scan only one bucket (~1/16 of entries).
2218−readPresenceBucket : Int -> IO [PresenceEntry]
2219−readPresenceBucket = \b ->
2220− if b == 0 then do s <- *presenceBucket0; yield s
2221− else if b == 1 then do s <- *presenceBucket1; yield s
2222− else if b == 2 then do s <- *presenceBucket2; yield s
2223− else if b == 3 then do s <- *presenceBucket3; yield s
2224− else if b == 4 then do s <- *presenceBucket4; yield s
2225− else if b == 5 then do s <- *presenceBucket5; yield s
2226− else if b == 6 then do s <- *presenceBucket6; yield s
2227− else if b == 7 then do s <- *presenceBucket7; yield s
2228− else if b == 8 then do s <- *presenceBucket8; yield s
2229− else if b == 9 then do s <- *presenceBucket9; yield s
2230− else if b == 10 then do s <- *presenceBucket10; yield s
2231− else if b == 11 then do s <- *presenceBucket11; yield s
2232− else if b == 12 then do s <- *presenceBucket12; yield s
2233− else if b == 13 then do s <- *presenceBucket13; yield s
2234− else if b == 14 then do s <- *presenceBucket14; yield s
2235− else do s <- *presenceBucket15; yield s
2237−writePresenceBucket : Int -> [PresenceEntry] -> IO ()
2238−writePresenceBucket = \b entries ->
2239− if b == 0 then set *presenceBucket0 = entries
2240− else if b == 1 then set *presenceBucket1 = entries
2241− else if b == 2 then set *presenceBucket2 = entries
2242− else if b == 3 then set *presenceBucket3 = entries
2243− else if b == 4 then set *presenceBucket4 = entries
2244− else if b == 5 then set *presenceBucket5 = entries
2245− else if b == 6 then set *presenceBucket6 = entries
2246− else if b == 7 then set *presenceBucket7 = entries
2247− else if b == 8 then set *presenceBucket8 = entries
2248− else if b == 9 then set *presenceBucket9 = entries
2249− else if b == 10 then set *presenceBucket10 = entries
2250− else if b == 11 then set *presenceBucket11 = entries
2251− else if b == 12 then set *presenceBucket12 = entries
2252− else if b == 13 then set *presenceBucket13 = entries
2253− else if b == 14 then set *presenceBucket14 = entries
2254− else set *presenceBucket15 = entries
2256−readAllPresence : IO [PresenceEntry]
2257−readAllPresence = do
2258− p0 <- *presenceBucket0
2259− p1 <- *presenceBucket1
2260− p2 <- *presenceBucket2
2261− p3 <- *presenceBucket3
2262− p4 <- *presenceBucket4
2263− p5 <- *presenceBucket5
2264− p6 <- *presenceBucket6
2265− p7 <- *presenceBucket7
2266− p8 <- *presenceBucket8
2267− p9 <- *presenceBucket9
2268− p10 <- *presenceBucket10
2269− p11 <- *presenceBucket11
2270− p12 <- *presenceBucket12
2271− p13 <- *presenceBucket13
2272− p14 <- *presenceBucket14
2273− p15 <- *presenceBucket15
2274− yield (unionNE p0 (unionNE p1 (unionNE p2 (unionNE p3 (unionNE p4 (unionNE p5 (unionNE p6 (unionNE p7 (unionNE p8 (unionNE p9 (unionNE p10 (unionNE p11 (unionNE p12 (unionNE p13 (unionNE p14 p15)))))))))))))))
2276−countAllPresence : IO Int
2277−countAllPresence = do
2278− p0 <- *presenceBucket0
2279− p1 <- *presenceBucket1
2280− p2 <- *presenceBucket2
2281− p3 <- *presenceBucket3
2282− p4 <- *presenceBucket4
2283− p5 <- *presenceBucket5
2284− p6 <- *presenceBucket6
2285− p7 <- *presenceBucket7
2286− p8 <- *presenceBucket8
2287− p9 <- *presenceBucket9
2288− p10 <- *presenceBucket10
2289− p11 <- *presenceBucket11
2290− p12 <- *presenceBucket12
2291− p13 <- *presenceBucket13
2292− p14 <- *presenceBucket14
2293− p15 <- *presenceBucket15
2294− yield (count p0 + count p1 + count p2 + count p3 + count p4 + count p5 + count p6 + count p7 + count p8 + count p9 + count p10 + count p11 + count p12 + count p13 + count p14 + count p15)
2296−-- Read only the presence buckets at the given indices (avoids reading all 16)
2297−readSelectedPresenceBuckets : [Int] -> IO [PresenceEntry]
2298−readSelectedPresenceBuckets = \buckets ->
2299− case headOf buckets of
2300− Nothing {} -> yield []
2301− Just {value: b} -> do
2302− let rest = do x <- buckets; where x != b; yield x
2303− entries <- readPresenceBucket b
2304− remaining <- readSelectedPresenceBuckets rest
2305− yield (union entries remaining)
2307−-- Write presence entries to only the specified bucket indices. Entries are filtered
2308−-- by pubkeyBucket so each bucket gets only its entries. Unspecified buckets are untouched.
2309−writeSelectedPresenceBuckets : [Int] -> [PresenceEntry] -> IO ()
2310−writeSelectedPresenceBuckets = \buckets entries ->
2311− case headOf buckets of
2312− Nothing {} -> yield {}
2313− Just {value: b} -> do
2314− let rest = do x <- buckets; where x != b; yield x
2315− let bucketEntries = do e <- entries; where pubkeyBucket e.pubkey == b; yield e
2316− writePresenceBucket b bucketEntries
2317− writeSelectedPresenceBuckets rest entries
2319−-- Single-pass partitioning: each entry's bucket is computed once (vs 16x in the list-comprehension approach).
2320−-- The per-element 16-field record allocation is unavoidable without Knot-level indexed arrays:
2321−-- the alternative (16 list-comprehension passes, each computing pubkeyBucket) is O(16n) bucket
2322−-- computations vs O(n) here, and sortBy-based splitting is O(n log n) vs O(n) here.
2323−-- This pattern is optimal given Knot's current data structure primitives.
2324−writeAllPresence : [PresenceEntry] -> IO ()
2325−writeAllPresence = \entries -> do
2326− let partitioned = fold (\acc p ->
2327− let b = pubkeyBucket p.pubkey in
2328− {b0: if b == 0 then union [p] acc.b0 else acc.b0,
2329− b1: if b == 1 then union [p] acc.b1 else acc.b1,
2330− b2: if b == 2 then union [p] acc.b2 else acc.b2,
2331− b3: if b == 3 then union [p] acc.b3 else acc.b3,
2332− b4: if b == 4 then union [p] acc.b4 else acc.b4,
2333− b5: if b == 5 then union [p] acc.b5 else acc.b5,
2334− b6: if b == 6 then union [p] acc.b6 else acc.b6,
2335− b7: if b == 7 then union [p] acc.b7 else acc.b7,
2336− b8: if b == 8 then union [p] acc.b8 else acc.b8,
2337− b9: if b == 9 then union [p] acc.b9 else acc.b9,
2338− b10: if b == 10 then union [p] acc.b10 else acc.b10,
2339− b11: if b == 11 then union [p] acc.b11 else acc.b11,
2340− b12: if b == 12 then union [p] acc.b12 else acc.b12,
2341− b13: if b == 13 then union [p] acc.b13 else acc.b13,
2342− b14: if b == 14 then union [p] acc.b14 else acc.b14,
2343− b15: if b == 15 then union [p] acc.b15 else acc.b15})
2344− {b0: [], b1: [], b2: [], b3: [], b4: [], b5: [], b6: [], b7: [], b8: [], b9: [], b10: [], b11: [], b12: [], b13: [], b14: [], b15: []} entries
2345− writePresenceBucket 0 partitioned.b0
2346− writePresenceBucket 1 partitioned.b1
2347− writePresenceBucket 2 partitioned.b2
2348− writePresenceBucket 3 partitioned.b3
2349− writePresenceBucket 4 partitioned.b4
2350− writePresenceBucket 5 partitioned.b5
2351− writePresenceBucket 6 partitioned.b6
2352− writePresenceBucket 7 partitioned.b7
2353− writePresenceBucket 8 partitioned.b8
2354− writePresenceBucket 9 partitioned.b9
2355− writePresenceBucket 10 partitioned.b10
2356− writePresenceBucket 11 partitioned.b11
2357− writePresenceBucket 12 partitioned.b12
2358− writePresenceBucket 13 partitioned.b13
2359− writePresenceBucket 14 partitioned.b14
2360− writePresenceBucket 15 partitioned.b15
2362−transformAllPresenceBuckets : ([PresenceEntry] -> [PresenceEntry]) -> IO ()
2363−transformAllPresenceBuckets = \f -> do
2364− b0 <- *presenceBucket0; set *presenceBucket0 = f b0
2365− b1 <- *presenceBucket1; set *presenceBucket1 = f b1
2366− b2 <- *presenceBucket2; set *presenceBucket2 = f b2
2367− b3 <- *presenceBucket3; set *presenceBucket3 = f b3
2368− b4 <- *presenceBucket4; set *presenceBucket4 = f b4
2369− b5 <- *presenceBucket5; set *presenceBucket5 = f b5
2370− b6 <- *presenceBucket6; set *presenceBucket6 = f b6
2371− b7 <- *presenceBucket7; set *presenceBucket7 = f b7
2372− b8 <- *presenceBucket8; set *presenceBucket8 = f b8
2373− b9 <- *presenceBucket9; set *presenceBucket9 = f b9
2374− b10 <- *presenceBucket10; set *presenceBucket10 = f b10
2375− b11 <- *presenceBucket11; set *presenceBucket11 = f b11
2376− b12 <- *presenceBucket12; set *presenceBucket12 = f b12
2377− b13 <- *presenceBucket13; set *presenceBucket13 = f b13
2378− b14 <- *presenceBucket14; set *presenceBucket14 = f b14
2379− b15 <- *presenceBucket15; set *presenceBucket15 = f b15
2381−-- Scan presence buckets for local entries nearing expiry.
2382−-- Supports partial scans (startBucket to endBucket) for round-robin refresh:
2383−-- instead of scanning all 16 buckets every refresh cycle, the caller can
2384−-- scan 4 buckets per cycle, cycling through all 16 over 4 refresh intervals.
2385−findNearExpiryPresence : Int -> Int -> Timestamp -> IO [PresenceEntry]
2386−findNearExpiryPresence = \b endBucket t ->
2387− if b > endBucket then yield []
2389− bucket <- readPresenceBucket b
2390− let nearExpiry = do p <- bucket; where isLocalServer p.server && p.expiresAt > t && p.expiresAt - t < presenceRefreshThreshold; yield p
2391− rest <- findNearExpiryPresence (b + 1) endBucket t
2392− yield (union nearExpiry rest)
2394−-- ============================================
2395−-- Message Bucket Helpers
2396−-- ============================================
2397−-- Messages are sharded into 16 buckets by the first hex char of the recipient pubkey.
2398−-- This reduces poll/send/ack scans from O(n) to O(n/16) on the hot path.
2400−readMessageBucket : Int -> IO [Message]
2401−readMessageBucket = \b ->
2402− if b == 0 then do s <- *messageBucket0; yield s
2403− else if b == 1 then do s <- *messageBucket1; yield s
2404− else if b == 2 then do s <- *messageBucket2; yield s
2405− else if b == 3 then do s <- *messageBucket3; yield s
2406− else if b == 4 then do s <- *messageBucket4; yield s
2407− else if b == 5 then do s <- *messageBucket5; yield s
2408− else if b == 6 then do s <- *messageBucket6; yield s
2409− else if b == 7 then do s <- *messageBucket7; yield s
2410− else if b == 8 then do s <- *messageBucket8; yield s
2411− else if b == 9 then do s <- *messageBucket9; yield s
2412− else if b == 10 then do s <- *messageBucket10; yield s
2413− else if b == 11 then do s <- *messageBucket11; yield s
2414− else if b == 12 then do s <- *messageBucket12; yield s
2415− else if b == 13 then do s <- *messageBucket13; yield s
2416− else if b == 14 then do s <- *messageBucket14; yield s
2417− else do s <- *messageBucket15; yield s
2419−writeMessageBucket : Int -> [Message] -> IO ()
2420−writeMessageBucket = \b msgs ->
2421− if b == 0 then set *messageBucket0 = msgs
2422− else if b == 1 then set *messageBucket1 = msgs
2423− else if b == 2 then set *messageBucket2 = msgs
2424− else if b == 3 then set *messageBucket3 = msgs
2425− else if b == 4 then set *messageBucket4 = msgs
2426− else if b == 5 then set *messageBucket5 = msgs
2427− else if b == 6 then set *messageBucket6 = msgs
2428− else if b == 7 then set *messageBucket7 = msgs
2429− else if b == 8 then set *messageBucket8 = msgs
2430− else if b == 9 then set *messageBucket9 = msgs
2431− else if b == 10 then set *messageBucket10 = msgs
2432− else if b == 11 then set *messageBucket11 = msgs
2433− else if b == 12 then set *messageBucket12 = msgs
2434− else if b == 13 then set *messageBucket13 = msgs
2435− else if b == 14 then set *messageBucket14 = msgs
2436− else set *messageBucket15 = msgs
2438−-- Read all 16 message buckets (for cold-path operations: federation ack, forward candidates, stats).
2439−-- Uses unionNE to skip empty buckets (avoids allocation overhead on sparse servers).
2440−readAllMessages : IO [Message]
2441−readAllMessages = do
2442− m0 <- *messageBucket0
2443− m1 <- *messageBucket1
2444− m2 <- *messageBucket2
2445− m3 <- *messageBucket3
2446− m4 <- *messageBucket4
2447− m5 <- *messageBucket5
2448− m6 <- *messageBucket6
2449− m7 <- *messageBucket7
2450− m8 <- *messageBucket8
2451− m9 <- *messageBucket9
2452− m10 <- *messageBucket10
2453− m11 <- *messageBucket11
2454− m12 <- *messageBucket12
2455− m13 <- *messageBucket13
2456− m14 <- *messageBucket14
2457− m15 <- *messageBucket15
2458− yield (unionNE m0 (unionNE m1 (unionNE m2 (unionNE m3 (unionNE m4 (unionNE m5 (unionNE m6 (unionNE m7 (unionNE m8 (unionNE m9 (unionNE m10 (unionNE m11 (unionNE m12 (unionNE m13 (unionNE m14 m15)))))))))))))))
2460−-- Apply a filter/transform to every message bucket
2461−transformAllMessageBuckets : ([Message] -> [Message]) -> IO ()
2462−transformAllMessageBuckets = \f -> do
2463− b0 <- *messageBucket0; set *messageBucket0 = f b0
2464− b1 <- *messageBucket1; set *messageBucket1 = f b1
2465− b2 <- *messageBucket2; set *messageBucket2 = f b2
2466− b3 <- *messageBucket3; set *messageBucket3 = f b3
2467− b4 <- *messageBucket4; set *messageBucket4 = f b4
2468− b5 <- *messageBucket5; set *messageBucket5 = f b5
2469− b6 <- *messageBucket6; set *messageBucket6 = f b6
2470− b7 <- *messageBucket7; set *messageBucket7 = f b7
2471− b8 <- *messageBucket8; set *messageBucket8 = f b8
2472− b9 <- *messageBucket9; set *messageBucket9 = f b9
2473− b10 <- *messageBucket10; set *messageBucket10 = f b10
2474− b11 <- *messageBucket11; set *messageBucket11 = f b11
2475− b12 <- *messageBucket12; set *messageBucket12 = f b12
2476− b13 <- *messageBucket13; set *messageBucket13 = f b13
2477− b14 <- *messageBucket14; set *messageBucket14 = f b14
2478− b15 <- *messageBucket15; set *messageBucket15 = f b15
2480−-- Read only the message buckets at the given indices (avoids reading all 16)
2481−readSelectedBuckets : [Int] -> IO [Message]
2482−readSelectedBuckets = \buckets ->
2483− case headOf buckets of
2484− Nothing {} -> yield []
2485− Just {value: b} -> do
2486− let rest = do x <- buckets; where x != b; yield x
2487− msgs <- readMessageBucket b
2488− remaining <- readSelectedBuckets rest
2489− yield (union msgs remaining)
2491−-- Transform only the message buckets at the given indices
2492−transformSelectedBuckets : [Int] -> ([Message] -> [Message]) -> IO ()
2493−transformSelectedBuckets = \buckets f ->
2494− case headOf buckets of
2495− Nothing {} -> yield {}
2496− Just {value: b} -> do
2497− let rest = do x <- buckets; where x != b; yield x
2498− msgs <- readMessageBucket b
2499− writeMessageBucket b (f msgs)
2500− transformSelectedBuckets rest f
2502−-- Collect unique bucket indices for a set of pubkeys
2503−-- O(1) per step with union [b] acc (set, order irrelevant, max 16 entries)
2504−uniqueBucketsFor = \items getKey ->
2506− let b = pubkeyBucket (getKey x) in
2507− if any acc (\i -> i == b) then acc else union [b] acc) [] items
2509−-- Prune a single message bucket and atomically adjust shared counters.
2510−-- Each bucket prune decrements totalMessageCount and its rcBucket by exactly
2511−-- what was removed, preserving concurrent modifications from poll-ack or send.
2512−-- Uses per-message expiresAt (respects sender-specified TTL).
2513−-- Also queues expiration notifications for locally-originated messages (senderKey != "")
2514−-- so the sender can learn their message expired unread via the next poll response.
2515−pruneMessageBucket = \b t -> atomic do
2516− bucket <- readMessageBucket b
2517− let kept = do m <- bucket; where m.expiresAt > t; yield m
2518− let removedCount = count bucket - count kept
2519− writeMessageBucket b kept
2520− if removedCount > 0 then do
2521− tc <- *totalMessageCount
2522− set *totalMessageCount = max 0 (tc - removedCount)
2523− rc <- readRcBucket b
2524− let removed = do m <- bucket; where m.expiresAt <= t; yield m
2525− writeRcBucket b (batchDecrementRecipientCounts rc (countByRecipient removed))
2526− -- Queue expiration notifications for locally-originated messages with known sender
2527− let localExpired = do m <- removed; where m.senderKey != "" && m.originServer == ""; yield {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, expiredAt: t}
2528− when (count localExpired > 0) (do
2529− se <- *senderExpirations
2530− -- Per-key cap: limit expirations per sender to prevent one noisy key from dominating the queue
2531− let perKeyCapped = fold (\acc e ->
2532− let existingForKey = count (do x <- se; where x.senderKey == e.senderKey; yield x)
2533− + count (do x <- acc; where x.senderKey == e.senderKey; yield x)
2534− in if existingForKey >= maxSenderExpirationsPerKey then acc else union acc [e]) [] localExpired
2535− let perKeyDropped = count localExpired - count perKeyCapped
2536− let combined = union se perKeyCapped
2537− let overCap = count combined > maxSenderExpirations
2539− -- Batch eviction: evict 2% of capacity to amortize O(n) scan cost
2540− let evictCount = max 1 (count combined - maxSenderExpirations + maxSenderExpirations / 50)
2541− let eviction = evictSmallest combined evictCount (\e -> e.expiredAt)
2542− set *senderExpirations = eviction.kept
2543− den <- *droppedExpirationNotifs
2544− let denAfterCap = fold (\acc ev -> incrementDropCounter acc ev.senderKey 1 t) den eviction.evicted
2545− -- Also record per-key drops for senders that hit maxSenderExpirationsPerKey
2546− let perKeyDroppedEntries = do e <- localExpired; where none perKeyCapped (\c -> c.messageId == e.messageId && c.toKey == e.toKey); yield e
2547− set *droppedExpirationNotifs = fold (\acc e -> incrementDropCounter acc e.senderKey 1 t) denAfterCap perKeyDroppedEntries
2549− set *senderExpirations = combined
2550− when (perKeyDropped > 0) (do
2551− den <- *droppedExpirationNotifs
2552− let perKeyDroppedEntries = do e <- localExpired; where none perKeyCapped (\c -> c.messageId == e.messageId && c.toKey == e.toKey); yield e
2553− set *droppedExpirationNotifs = fold (\acc e -> incrementDropCounter acc e.senderKey 1 t) den perKeyDroppedEntries))
2556−-- Prune all 16 message buckets with concurrency: fork non-empty buckets, then wait
2557−-- for all forks to complete via a counter-based barrier before returning. This ensures
2558−-- forward retries (which run after pruning) see fully pruned message state.
2559−-- Each bucket's atomic block only contends on *totalMessageCount (a single Int);
2560−-- rcBuckets and message buckets are per-bucket and independent.
2561−*pendingBucketPrunes : Int
2563−pruneMessageBucketsConcurrent = \b t ->
2565− -- Wait for all forked bucket prunes to complete via STM retry barrier.
2566− -- Each fork decrements *pendingBucketPrunes; when it reaches 0, all are done.
2568− pending <- *pendingBucketPrunes
2569− if pending > 0 then retry else yield {}
2571− bucket <- readMessageBucket b
2572− if count bucket == 0 then pruneMessageBucketsConcurrent (b + 1) t
2574− atomic do
742+ verified <- if take 7 authorization == "Signed "
2575− p <- *pendingBucketPrunes
743+ then
2576− set *pendingBucketPrunes = p + 1
744+ let payload = drop 7 authorization in
2577− fork (do
745+ if payload == "" || tooLong payload (maxSignatureLen + 25)
2578− pruneMessageBucket b t
746+ then yield False
2580− p <- *pendingBucketPrunes
748+ let parts = splitOnColon payload in
2581− set *pendingBucketPrunes = max 0 (p - 1))
749+ verifyFederationSignature fromServer parts.before parts.after scope requestTimestamp
2582− pruneMessageBucketsConcurrent (b + 1) t
750+ else verifyFederationCallback fromServer authorization scope
2583−
751+ if not verified
2584−-- Per-bucket message reconciliation: reads one bucket per atomic block instead of all 16
752+ then yield (respond {ok: False {}, error: "unauthorized", retryAfterMs: 0})
2585−-- at once, reducing lock contention during reconciliation. Each pubkey maps to exactly one
753+ else if requestTimestamp > 0 && (requestTimestamp > t + clockSkewTolerance || requestTimestamp < t - clockSkewTolerance)
2586−-- bucket, so per-bucket recipient counts are disjoint — each bucket's counts are written
754+ then yield (respond {ok: False {}, error: "clock_skew", retryAfterMs: 0})
2587−-- to the corresponding rcBucket without overlap.
755+ else if not precondition
2588−-- Delta-based counter adjustment: snapshots totalMessageCount before scanning, computes the
756+ then yield (respond {ok: False {}, error: "invalid_request", retryAfterMs: 0})
2589−-- drift (actual - snapshot), then applies the drift atomically to the live counter. This is
757+ else do
2590−-- commutative with concurrent sendMessageCore: if sendMessageCore increments by N between our
758+ limited <- checkServerRateGate fromServer t
2591−-- snapshot and final adjustment, the live counter becomes (snapshot + N + drift) = (actual + N),
759+ if limited
2592−-- which is correct. The old approach overwrote with the absolute recount, losing concurrent N.
760+ then yield (respond {ok: False {}, error: "rate_limited", retryAfterMs: federationRateWindowMs})
2593−-- Per-bucket atomic reconciliation: each bucket is reconciled independently, computing
2594−-- its own delta and applying it to totalMessageCount atomically. This is safe with
2595−-- concurrent prune decrements: if a forked pruneMessageBucket modifies totalMessageCount
2596−-- between our bucket N and bucket N+1, each bucket's delta is applied independently and
2597−-- the shared counter converges. The old snapshot-then-delta approach could overcorrect
2598−-- when concurrent decrements occurred between snapshot and final write.
2599−reconcileMessageCountsDelta : IO Int
2600−reconcileMessageCountsDelta = reconcileMessageCountsPerBucket 0 0
2602−reconcileMessageCountsPerBucket = \b totalDrift ->
2603− if b > 15 then yield totalDrift
2605− bucketDrift <- atomic do
2606− bucket <- readMessageBucket b
2607− oldCounts <- readRcBucket b
2608− let tracked = fold (\a c -> a + c.count) 0 oldCounts
2609− -- Skip the O(n log n) countByRecipient sort when the bucket total matches.
2610− -- Per-key imbalances (key A +1, key B -1) are missed but caught by
2611− -- the periodic full cycle (every reconciliationFullCycleInterval prune cycles).
2612− if count bucket == tracked then yield 0
2613− else do
761+ else action
2614− let counts = countByRecipient bucket
2615− let actual = fold (\a c -> a + c.count) 0 counts
2616− writeRcBucket b counts
2617− -- Apply per-bucket drift to totalMessageCount atomically
2618− let drift = actual - tracked
2619− when (drift != 0) (do
2620− stored <- *totalMessageCount
2621− set *totalMessageCount = max 0 (stored + drift))
2623− reconcileMessageCountsPerBucket (b + 1) (totalDrift + bucketDrift)
2625-- ============================================
763-- ============================================
2626−-- Recipient Count Helpers
764+-- Rate limiting (plain count-per-window, no sliding interpolation)
2627-- ============================================
765-- ============================================
2628−-- Per-recipient message counts avoid O(n) scan of all messages on send/forward.
2629−-- Sharded into 16 buckets (rcBucket0-15) by pubkeyBucket, reducing scan from
2630−-- O(unique_recipients) to O(unique_recipients/16). Each pubkey maps to exactly
2631−-- one bucket, so lookups never cross shards.
2632−-- TODO: If Knot adds a map/dictionary type, replace [RecipientCount] with a
2633−-- Map<PubkeyHex, Int> for O(1) lookups.
2635−-- O(n/16) per lookup (one sharded bucket). fold continues past the match, but each
2636−-- post-match step is a single comparison + branch (no allocation). headOf would also
2637−-- traverse the full list (its fold doesn't short-circuit either) while adding intermediate
2638−-- list allocation from the filter, so fold is the better choice within Knot's constraints.
2639−getRecipientCount : PubkeyHex -> [RecipientCount] -> Int
2640−getRecipientCount = \pubkey counts ->
2641− fold (\acc c -> if c.pubkey == pubkey then c.count else acc) 0 counts
2643−-- Single-pass recipient count adjustment: fold once instead of any + list comprehension (O(n) vs O(2n))
2644−adjustRecipientCount : [RecipientCount] -> PubkeyHex -> Int -> [RecipientCount]
2645−adjustRecipientCount = \counts pubkey delta ->
2646− if delta == 0 then counts
2647− else let result = fold (\acc c ->
2648− if c.pubkey == pubkey
2649− then if c.count + delta > 0
2650− then {items: union acc.items [{pubkey: c.pubkey, count: c.count + delta}], found: True {}}
2651− else {items: acc.items, found: True {}}
2652− else {items: union acc.items [c], found: acc.found})
2653− {items: [], found: False {}} counts
2654− in if result.found then result.items
2655− else if delta > 0 then union counts [{pubkey: pubkey, count: delta}]
2658−-- Count items per toKey using sort-then-scan: O(n log n) sort + O(n) linear scan.
2659−-- Replaces the previous O(n*k) fold-with-any approach. For a bucket with 6000 messages
2660−-- and 500 unique recipients, this reduces comparisons from ~3M to ~80k.
2661−-- sortBy groups equal toKeys together; countSortedGroups scans consecutive equal keys.
2662−countByRecipient = \items ->
2663− let sorted = sortBy (\m -> m.toKey) items in
2664− countSortedGroups sorted
2666−-- Single-pass fold over sorted items: counts consecutive runs of the same toKey.
2667−-- O(n) total: one fold step per item, O(1) prepend per group boundary.
2668−-- Replaces the previous headOf+filter pattern which was O(n) per step = O(n²) total.
2669−-- Uses "union [new] acc" (prepend, O(1)) instead of "union acc [new]" (copy, O(k)).
2670−countSortedGroups = \items ->
2671− let result = fold (\acc m ->
2672− if acc.currentKey == ""
2673− then {currentKey: m.toKey, currentCount: 1, groups: acc.groups}
2674− else if m.toKey == acc.currentKey
2675− then {currentKey: acc.currentKey, currentCount: acc.currentCount + 1, groups: acc.groups}
2676− else {currentKey: m.toKey, currentCount: 1, groups: union [{pubkey: acc.currentKey, count: acc.currentCount}] acc.groups})
2677− {currentKey: "", currentCount: 0, groups: []} items
2678− in if result.currentKey == "" then result.groups
2679− else union [{pubkey: result.currentKey, count: result.currentCount}] result.groups
2681−-- Batch-decrement recipient counts: fold over removedCounts applying adjustRecipientCount.
2682−-- Fast path: returns counts unchanged when removedCounts is empty (common in prune cycles
2683−-- with no expired messages). When non-empty, each adjustRecipientCount is a single pass
2684−-- over counts (O(n*m) total, same as before, but avoids the getRecipientCount lookup
2685−-- overhead for entries in counts that have no matching removal).
2686−batchDecrementRecipientCounts : [RecipientCount] -> [RecipientCount] -> [RecipientCount]
2687−batchDecrementRecipientCounts = \counts removedCounts ->
2688− if count removedCounts == 0 then counts
2689− else fold (\acc rc -> adjustRecipientCount acc rc.pubkey (0 - rc.count)) counts removedCounts
2691−-- Recipient count bucket helpers (sharded by pubkeyBucket, same as messages)
2692−readRcBucket : Int -> IO [RecipientCount]
2693−readRcBucket = \b ->
2694− if b == 0 then do s <- *rcBucket0; yield s
2695− else if b == 1 then do s <- *rcBucket1; yield s
2696− else if b == 2 then do s <- *rcBucket2; yield s
2697− else if b == 3 then do s <- *rcBucket3; yield s
2698− else if b == 4 then do s <- *rcBucket4; yield s
2699− else if b == 5 then do s <- *rcBucket5; yield s
2700− else if b == 6 then do s <- *rcBucket6; yield s
2701− else if b == 7 then do s <- *rcBucket7; yield s
2702− else if b == 8 then do s <- *rcBucket8; yield s
2703− else if b == 9 then do s <- *rcBucket9; yield s
2704− else if b == 10 then do s <- *rcBucket10; yield s
2705− else if b == 11 then do s <- *rcBucket11; yield s
2706− else if b == 12 then do s <- *rcBucket12; yield s
2707− else if b == 13 then do s <- *rcBucket13; yield s
2708− else if b == 14 then do s <- *rcBucket14; yield s
2709− else do s <- *rcBucket15; yield s
2711−writeRcBucket : Int -> [RecipientCount] -> IO ()
2712−writeRcBucket = \b counts ->
2713− if b == 0 then set *rcBucket0 = counts
2714− else if b == 1 then set *rcBucket1 = counts
2715− else if b == 2 then set *rcBucket2 = counts
2716− else if b == 3 then set *rcBucket3 = counts
2717− else if b == 4 then set *rcBucket4 = counts
2718− else if b == 5 then set *rcBucket5 = counts
2719− else if b == 6 then set *rcBucket6 = counts
2720− else if b == 7 then set *rcBucket7 = counts
2721− else if b == 8 then set *rcBucket8 = counts
2722− else if b == 9 then set *rcBucket9 = counts
2723− else if b == 10 then set *rcBucket10 = counts
2724− else if b == 11 then set *rcBucket11 = counts
2725− else if b == 12 then set *rcBucket12 = counts
2726− else if b == 13 then set *rcBucket13 = counts
2727− else if b == 14 then set *rcBucket14 = counts
2728− else set *rcBucket15 = counts
2730−-- Count total recipients across all 16 rc buckets (for stats)
2731−countAllRcEntries : Int -> IO Int
2732−countAllRcEntries = \b ->
2733− if b > 15 then yield 0
2735− bucket <- readRcBucket b
2736− rest <- countAllRcEntries (b + 1)
2737− yield (count bucket + rest)
2739−-- Merge two sorted-by-count-desc lists, keeping only the top N by count.
2740−-- O(n+m) merge pass + O(result) truncation. Used by topRecipientsByBucket.
2741−mergeTopN : [RecipientCount] -> [RecipientCount] -> Int -> [RecipientCount]
2742−mergeTopN = \acc newItems limit ->
2743− let combined = fold (\a c ->
2744− if any a (\x -> x.pubkey == c.pubkey) then a
2745− else union a [c]) acc newItems
2746− in let sorted = sortBy (\c -> 0 - c.count) combined
2747− in takeRelation limit sorted
2749−-- Top-N recipients by message count, scanning one rcBucket at a time.
2750−-- Avoids materializing all 16 rcBuckets into a single list (O(16 * bucket_size)
2751−-- vs O(total_recipients)). Each bucket's entries are merged into a running top-N.
2752−topRecipientsByBucket : Int -> Int -> [RecipientCount] -> IO [RecipientCount]
2753−topRecipientsByBucket = \b limit acc ->
2754− if b > 15 then yield acc
2756− bucket <- readRcBucket b
2757− let merged = mergeTopN acc bucket limit
2758− topRecipientsByBucket (b + 1) limit merged
2760−-- Sum total message count from rcBuckets (cheap: sums .count fields, doesn't scan messages)
2761−sumRcBucketTotals : Int -> IO Int
2762−sumRcBucketTotals = \b ->
2763− if b > 15 then yield 0
2765− bucket <- readRcBucket b
2766− let bucketTotal = fold (\acc c -> acc + c.count) 0 bucket
2767− rest <- sumRcBucketTotals (b + 1)
2768− yield (bucketTotal + rest)
2770−-- Check message dedup only (without counting — count comes from rcBuckets)
767+-- Returns {limited, entries}. Increments count when the key fits within the window.
2771−checkMessageDup : [Message] -> Text -> PubkeyHex -> Bool
768+checkRate = \entries key maxRate windowMs maxEntries t ->
2772−checkMessageDup = \messages messageId toKey ->
769+ let entry = headOf (do r <- entries; where r.key == key; yield r) in
2773− messageId != "" && any messages (\m -> m.messageId == messageId && m.toKey == toKey)
770+ case entry of
2775−-- ============================================
772+ if 1 >= maxRate
2776−-- Forward Nonce Bucket Helpers
773+ then {limited: True {}, entries: entries}
2777−-- ============================================
774+ else {limited: False {}, entries: capList (union entries [{key: key, windowStart: t, count: 1}]) maxEntries (\r -> r.windowStart)}
2778−-- Forward nonces sharded into 16 buckets by pubkeyBucket(toKey).
775+ Just {value: r} ->
2779−-- Hot-path (handleForwardMessage, sendMessageCore) scans one bucket (~1/16 of nonces).
776+ if t - r.windowStart >= windowMs
2780−
777+ then {limited: False {}, entries: do x <- entries; yield (if x.key == key then {key: x.key, windowStart: t, count: 1} else x)}
2781−readNonceBucket : Int -> IO [ForwardNonce]
778+ else if r.count >= maxRate
2782−readNonceBucket = \b ->
779+ then {limited: True {}, entries: entries}
2783− if b == 0 then do s <- *nonceBucket0; yield s
780+ else {limited: False {}, entries: do x <- entries; yield (if x.key == key then {key: x.key, windowStart: x.windowStart, count: x.count + 1} else x)}
2784− else if b == 1 then do s <- *nonceBucket1; yield s
2785− else if b == 2 then do s <- *nonceBucket2; yield s
2786− else if b == 3 then do s <- *nonceBucket3; yield s
2787− else if b == 4 then do s <- *nonceBucket4; yield s
2788− else if b == 5 then do s <- *nonceBucket5; yield s
2789− else if b == 6 then do s <- *nonceBucket6; yield s
2790− else if b == 7 then do s <- *nonceBucket7; yield s
2791− else if b == 8 then do s <- *nonceBucket8; yield s
2792− else if b == 9 then do s <- *nonceBucket9; yield s
2793− else if b == 10 then do s <- *nonceBucket10; yield s
2794− else if b == 11 then do s <- *nonceBucket11; yield s
2795− else if b == 12 then do s <- *nonceBucket12; yield s
2796− else if b == 13 then do s <- *nonceBucket13; yield s
2797− else if b == 14 then do s <- *nonceBucket14; yield s
2798− else do s <- *nonceBucket15; yield s
2800−writeNonceBucket : Int -> [ForwardNonce] -> IO ()
2801−writeNonceBucket = \b nonces ->
2802− if b == 0 then set *nonceBucket0 = nonces
2803− else if b == 1 then set *nonceBucket1 = nonces
2804− else if b == 2 then set *nonceBucket2 = nonces
2805− else if b == 3 then set *nonceBucket3 = nonces
2806− else if b == 4 then set *nonceBucket4 = nonces
2807− else if b == 5 then set *nonceBucket5 = nonces
2808− else if b == 6 then set *nonceBucket6 = nonces
2809− else if b == 7 then set *nonceBucket7 = nonces
2810− else if b == 8 then set *nonceBucket8 = nonces
2811− else if b == 9 then set *nonceBucket9 = nonces
2812− else if b == 10 then set *nonceBucket10 = nonces
2813− else if b == 11 then set *nonceBucket11 = nonces
2814− else if b == 12 then set *nonceBucket12 = nonces
2815− else if b == 13 then set *nonceBucket13 = nonces
2816− else if b == 14 then set *nonceBucket14 = nonces
2817− else set *nonceBucket15 = nonces
2819−readAllNonces : IO [ForwardNonce]
2821− n0 <- *nonceBucket0
2822− n1 <- *nonceBucket1
2823− n2 <- *nonceBucket2
2824− n3 <- *nonceBucket3
2825− n4 <- *nonceBucket4
2826− n5 <- *nonceBucket5
2827− n6 <- *nonceBucket6
2828− n7 <- *nonceBucket7
2829− n8 <- *nonceBucket8
2830− n9 <- *nonceBucket9
2831− n10 <- *nonceBucket10
2832− n11 <- *nonceBucket11
2833− n12 <- *nonceBucket12
2834− n13 <- *nonceBucket13
2835− n14 <- *nonceBucket14
2836− n15 <- *nonceBucket15
2837− yield (unionNE n0 (unionNE n1 (unionNE n2 (unionNE n3 (unionNE n4 (unionNE n5 (unionNE n6 (unionNE n7 (unionNE n8 (unionNE n9 (unionNE n10 (unionNE n11 (unionNE n12 (unionNE n13 (unionNE n14 n15)))))))))))))))
2839−countAllNonces : Int -> IO Int
2840−countAllNonces = \b ->
2841− if b > 15 then yield 0
2843− bucket <- readNonceBucket b
2844− rest <- countAllNonces (b + 1)
2845− yield (count bucket + rest)
2847−-- Write nonces to all 16 buckets via single-pass partitioning
2848−writeAllNonces : [ForwardNonce] -> IO ()
2849−writeAllNonces = \nonces -> do
2850− let partitioned = fold (\acc n ->
2851− let b = pubkeyBucket n.toKey in
2852− {b0: if b == 0 then union [n] acc.b0 else acc.b0,
2853− b1: if b == 1 then union [n] acc.b1 else acc.b1,
2854− b2: if b == 2 then union [n] acc.b2 else acc.b2,
2855− b3: if b == 3 then union [n] acc.b3 else acc.b3,
2856− b4: if b == 4 then union [n] acc.b4 else acc.b4,
2857− b5: if b == 5 then union [n] acc.b5 else acc.b5,
2858− b6: if b == 6 then union [n] acc.b6 else acc.b6,
2859− b7: if b == 7 then union [n] acc.b7 else acc.b7,
2860− b8: if b == 8 then union [n] acc.b8 else acc.b8,
2861− b9: if b == 9 then union [n] acc.b9 else acc.b9,
2862− b10: if b == 10 then union [n] acc.b10 else acc.b10,
2863− b11: if b == 11 then union [n] acc.b11 else acc.b11,
2864− b12: if b == 12 then union [n] acc.b12 else acc.b12,
2865− b13: if b == 13 then union [n] acc.b13 else acc.b13,
2866− b14: if b == 14 then union [n] acc.b14 else acc.b14,
2867− b15: if b == 15 then union [n] acc.b15 else acc.b15})
2868− {b0: [], b1: [], b2: [], b3: [], b4: [], b5: [], b6: [], b7: [], b8: [], b9: [], b10: [], b11: [], b12: [], b13: [], b14: [], b15: []} nonces
2869− writeNonceBucket 0 partitioned.b0
2870− writeNonceBucket 1 partitioned.b1
2871− writeNonceBucket 2 partitioned.b2
2872− writeNonceBucket 3 partitioned.b3
2873− writeNonceBucket 4 partitioned.b4
2874− writeNonceBucket 5 partitioned.b5
2875− writeNonceBucket 6 partitioned.b6
2876− writeNonceBucket 7 partitioned.b7
2877− writeNonceBucket 8 partitioned.b8
2878− writeNonceBucket 9 partitioned.b9
2879− writeNonceBucket 10 partitioned.b10
2880− writeNonceBucket 11 partitioned.b11
2881− writeNonceBucket 12 partitioned.b12
2882− writeNonceBucket 13 partitioned.b13
2883− writeNonceBucket 14 partitioned.b14
2884− writeNonceBucket 15 partitioned.b15
2886−-- Prune nonces across all 16 buckets (used by flush and restore)
2887−pruneAllNonceBuckets : Int -> Timestamp -> IO ()
2888−pruneAllNonceBuckets = \b t ->
2889− if b > 15 then yield {}
2891− bucket <- readNonceBucket b
2892− writeNonceBucket b (do n <- bucket; where t - n.seenAt < forwardNonceRetention; yield n)
2893− pruneAllNonceBuckets (b + 1) t
2895−-- Round-robin nonce pruning: scan 4 of 16 buckets per call.
2896−-- With 60-day retention and 30-second prune intervals, full coverage every ~2 minutes
2897−-- is sufficient. Reduces prune cycle cost by 75% vs scanning all 16 buckets.
2898−pruneNonceBucketsRoundRobin : Timestamp -> IO ()
2899−pruneNonceBucketsRoundRobin = \t -> do
2900− group <- *noncePruneGroup
2901− let startBucket = (group * 4) - ((group * 4) / 16) * 16
2902− pruneNonceBucketRange startBucket (startBucket + 3) t
2903− set *noncePruneGroup = if group >= 3 then 0 else group + 1
2905−pruneNonceBucketRange : Int -> Int -> Timestamp -> IO ()
2906−pruneNonceBucketRange = \b endB t ->
2907− if b > endB || b > 15 then yield {}
2909− bucket <- readNonceBucket b
2910− let pruned = do n <- bucket; where t - n.seenAt < forwardNonceRetention; yield n
2911− when (count pruned < count bucket) (writeNonceBucket b pruned)
2912− pruneNonceBucketRange (b + 1) endB t
2914−-- Per-bucket nonce eviction cutoff read/write helpers.
2915−readNonceCutoff : Int -> IO Timestamp
2916−readNonceCutoff = \b ->
2917− if b == 0 then do s <- *nonceEvictionCutoff0; yield s
2918− else if b == 1 then do s <- *nonceEvictionCutoff1; yield s
2919− else if b == 2 then do s <- *nonceEvictionCutoff2; yield s
2920− else if b == 3 then do s <- *nonceEvictionCutoff3; yield s
2921− else if b == 4 then do s <- *nonceEvictionCutoff4; yield s
2922− else if b == 5 then do s <- *nonceEvictionCutoff5; yield s
2923− else if b == 6 then do s <- *nonceEvictionCutoff6; yield s
2924− else if b == 7 then do s <- *nonceEvictionCutoff7; yield s
2925− else if b == 8 then do s <- *nonceEvictionCutoff8; yield s
2926− else if b == 9 then do s <- *nonceEvictionCutoff9; yield s
2927− else if b == 10 then do s <- *nonceEvictionCutoff10; yield s
2928− else if b == 11 then do s <- *nonceEvictionCutoff11; yield s
2929− else if b == 12 then do s <- *nonceEvictionCutoff12; yield s
2930− else if b == 13 then do s <- *nonceEvictionCutoff13; yield s
2931− else if b == 14 then do s <- *nonceEvictionCutoff14; yield s
2932− else do s <- *nonceEvictionCutoff15; yield s
2934−writeNonceCutoff : Int -> Timestamp -> IO ()
2935−writeNonceCutoff = \b val ->
2936− if b == 0 then set *nonceEvictionCutoff0 = val
2937− else if b == 1 then set *nonceEvictionCutoff1 = val
2938− else if b == 2 then set *nonceEvictionCutoff2 = val
2939− else if b == 3 then set *nonceEvictionCutoff3 = val
2940− else if b == 4 then set *nonceEvictionCutoff4 = val
2941− else if b == 5 then set *nonceEvictionCutoff5 = val
2942− else if b == 6 then set *nonceEvictionCutoff6 = val
2943− else if b == 7 then set *nonceEvictionCutoff7 = val
2944− else if b == 8 then set *nonceEvictionCutoff8 = val
2945− else if b == 9 then set *nonceEvictionCutoff9 = val
2946− else if b == 10 then set *nonceEvictionCutoff10 = val
2947− else if b == 11 then set *nonceEvictionCutoff11 = val
2948− else if b == 12 then set *nonceEvictionCutoff12 = val
2949− else if b == 13 then set *nonceEvictionCutoff13 = val
2950− else if b == 14 then set *nonceEvictionCutoff14 = val
2951− else set *nonceEvictionCutoff15 = val
2953−-- Reset all 16 per-bucket nonce eviction cutoffs to 0 (accept all timestamps).
2954−-- Called by nonce flush to clear stale cutoffs when all nonces are removed.
2955−resetAllNonceCutoffs : Int -> IO ()
2956−resetAllNonceCutoffs = \b ->
2957− if b > 15 then yield {}
2959− writeNonceCutoff b 0
2960− resetAllNonceCutoffs (b + 1)
2962−-- Record a forward nonce and handle capacity eviction with LRU logging.
2963−-- Usable inside or outside atomic blocks (reads/writes nonce bucket refs).
2964−-- Returns eviction info for deferred logging when called inside atomic.
2965−updateForwardNonce : Int -> MessageIdHex -> PubkeyHex -> Timestamp -> IO {lruEvicted: Int, oldestRetainedAge: Int}
2966−updateForwardNonce = \nb messageId toKey t -> do
2967− fwdNonces <- readNonceBucket nb
2968− let updatedNonces = union fwdNonces [{messageId: messageId, toKey: toKey, seenAt: t}]
2969− let evictedNonces = if count updatedNonces > maxNoncesPerBucket
2970− then evictNonces updatedNonces maxNoncesPerBucket forwardNonceRetention t
2972− let lruEvicted = count updatedNonces - count evictedNonces
2973− let oldestRetainedAge = if lruEvicted > 0
2974− then case minBy evictedNonces (\n -> n.seenAt) of Nothing {} -> 0; Just {value: n} -> t - n.seenAt
2976− writeNonceBucket nb evictedNonces
2977− -- Update per-bucket nonce eviction cutoff: set to the oldest retained nonce in this bucket.
2978− -- Per-bucket cutoffs are correct because each forward is checked against its own bucket's
2979− -- cutoff (keyed by pubkeyBucket(toKey)). The previous global cutoff was wrong: bucket 3
2980− -- evicting recent nonces would tighten the cutoff for bucket 12 (with older retained nonces).
2981− when (lruEvicted > 0) (do
2982− let bucketMin = case minBy evictedNonces (\n -> n.seenAt) of Nothing {} -> 0; Just {value: n} -> n.seenAt
2983− writeNonceCutoff nb bucketMin
2984− nec <- *nonceEvictionCount
2985− set *nonceEvictionCount = nec + lruEvicted)
2986− yield {lruEvicted: lruEvicted, oldestRetainedAge: oldestRetainedAge}
2988−-- Log nonce LRU eviction if any occurred. Call outside atomic blocks.
2989−logNonceEviction : Int -> Int -> Int -> IO ()
2990−logNonceEviction = \nb lruEvicted oldestRetainedAge ->
2991− when (lruEvicted > 0) (do
2992− let level = if oldestRetainedAge < messageMaxAge then "error" else "warn"
2993− logKV level "nonce_lru_eviction" ["bucket=" ++ show nb, "evicted=" ++ show lruEvicted, "capacity=" ++ show maxNoncesPerBucket, "oldestRetainedMs=" ++ show oldestRetainedAge])
2995−-- Full record-and-log helper for use outside atomic blocks.
2996−-- Wraps updateForwardNonce in atomic to prevent lost nonces from concurrent calls.
2997−-- Without this, two concurrent sendMessageCore calls (via handleSendMessage) can both
2998−-- read the same nonce bucket, each append their nonce, and the second write silently
2999−-- drops the first nonce — reopening a replay window for that message.
3000−-- Safe when called from inside an existing atomic block (Knot atomic is reentrant).
3001−recordForwardNonce : MessageIdHex -> PubkeyHex -> Timestamp -> IO ()
3002−recordForwardNonce = \messageId toKey t -> do
3003− let nb = pubkeyBucket toKey
3004− result <- atomic do updateForwardNonce nb messageId toKey t
3005− logNonceEviction nb result.lruEvicted result.oldestRetainedAge
3007−-- ============================================
782+checkGlobalRate = \t -> atomic do
3008−-- Forward Bucket Helpers
783+ ws <- *globalRateWindowStart
3009−-- ============================================
784+ c <- *globalRateCount
3010−-- Forwards sharded into 16 buckets by pubkeyBucket(toKey).
785+ if t - ws >= globalRateWindowMs then do
3011−
786+ set *globalRateWindowStart = t
3012−readFwdBucket : Int -> IO [ForwardEntry]
787+ set *globalRateCount = 1
3013−readFwdBucket = \b ->
788+ yield False
3014− if b == 0 then do s <- *fwdBucket0; yield s
3015− else if b == 1 then do s <- *fwdBucket1; yield s
3016− else if b == 2 then do s <- *fwdBucket2; yield s
3017− else if b == 3 then do s <- *fwdBucket3; yield s
3018− else if b == 4 then do s <- *fwdBucket4; yield s
3019− else if b == 5 then do s <- *fwdBucket5; yield s
3020− else if b == 6 then do s <- *fwdBucket6; yield s
3021− else if b == 7 then do s <- *fwdBucket7; yield s
789+ else if c >= maxGlobalRequestRate then yield True
3022− else if b == 8 then do s <- *fwdBucket8; yield s
3023− else if b == 9 then do s <- *fwdBucket9; yield s
3024− else if b == 10 then do s <- *fwdBucket10; yield s
3025− else if b == 11 then do s <- *fwdBucket11; yield s
3026− else if b == 12 then do s <- *fwdBucket12; yield s
3027− else if b == 13 then do s <- *fwdBucket13; yield s
3028− else if b == 14 then do s <- *fwdBucket14; yield s
3029− else do s <- *fwdBucket15; yield s
3031−writeFwdBucket : Int -> [ForwardEntry] -> IO ()
3032−writeFwdBucket = \b fwds ->
3033− if b == 0 then set *fwdBucket0 = fwds
3034− else if b == 1 then set *fwdBucket1 = fwds
3035− else if b == 2 then set *fwdBucket2 = fwds
3036− else if b == 3 then set *fwdBucket3 = fwds
3037− else if b == 4 then set *fwdBucket4 = fwds
3038− else if b == 5 then set *fwdBucket5 = fwds
3039− else if b == 6 then set *fwdBucket6 = fwds
3040− else if b == 7 then set *fwdBucket7 = fwds
3041− else if b == 8 then set *fwdBucket8 = fwds
3042− else if b == 9 then set *fwdBucket9 = fwds
3043− else if b == 10 then set *fwdBucket10 = fwds
3044− else if b == 11 then set *fwdBucket11 = fwds
3045− else if b == 12 then set *fwdBucket12 = fwds
3046− else if b == 13 then set *fwdBucket13 = fwds
3047− else if b == 14 then set *fwdBucket14 = fwds
3048− else set *fwdBucket15 = fwds
3050−readAllForwards : IO [ForwardEntry]
3051−readAllForwards = do
3062− f10 <- *fwdBucket10
3063− f11 <- *fwdBucket11
3064− f12 <- *fwdBucket12
3065− f13 <- *fwdBucket13
3066− f14 <- *fwdBucket14
3067− f15 <- *fwdBucket15
3068− yield (unionNE f0 (unionNE f1 (unionNE f2 (unionNE f3 (unionNE f4 (unionNE f5 (unionNE f6 (unionNE f7 (unionNE f8 (unionNE f9 (unionNE f10 (unionNE f11 (unionNE f12 (unionNE f13 (unionNE f14 f15)))))))))))))))
3070−countAllForwards : Int -> IO Int
3071−countAllForwards = \b ->
3072− if b > 15 then yield 0
3074− bucket <- readFwdBucket b
3075− rest <- countAllForwards (b + 1)
3076− yield (count bucket + rest)
3078−-- Compute min and max message counts across all 16 buckets (for stats bucket skew detection).
3079−-- Returns {bucketMin, bucketMax}. O(16) bucket reads.
3080−messageBucketMinMax : IO {bucketMin: Int, bucketMax: Int}
3081−messageBucketMinMax = messageBucketMinMaxInner 0 999999999 0
3083−messageBucketMinMaxInner : Int -> Int -> Int -> IO {bucketMin: Int, bucketMax: Int}
3084−messageBucketMinMaxInner = \b currentMin currentMax ->
3085− if b > 15 then yield {bucketMin: if currentMin == 999999999 then 0 else currentMin, bucketMax: currentMax}
3087− bucket <- readMessageBucket b
791+ set *globalRateCount = c + 1
3088− let c = count bucket
792+ yield False
3089− messageBucketMinMaxInner (b + 1) (min currentMin c) (max currentMax c)
3091−-- Compute forward stats per-bucket without materializing all forwards into one list.
794+checkAuthGlobalRate = \t -> atomic do
3092−-- Returns total count, oldest age, unique server count, and max per-server queue depth.
795+ ws <- *authGlobalRateWindowStart
3093−computeForwardStats : Int -> Timestamp -> IO {totalCount: Int, oldestAge: Int, serverCount: Int, maxDepth: Int, serverCounts: [{server: Text, count: Int}]}
796+ c <- *authGlobalRateCount
3094−computeForwardStats = \b t -> computeForwardStatsInner b t {totalCount: 0, oldestAge: 0, serverCount: 0, maxDepth: 0, serverCounts: []}
797+ if t - ws >= authGlobalRateWindowMs then do
798+ set *authGlobalRateWindowStart = t
799+ set *authGlobalRateCount = 1
801+ else if c >= maxAuthGlobalRate then yield True
803+ set *authGlobalRateCount = c + 1
806+checkIpRateGate = \ip t ->
807+ if ip == "" then yield False
810+ let r = checkRate rates ip maxIpRatePerIp ipRateWindowMs 5000 t
811+ set *ipRates = r.entries
814+checkPubkeyRateGate = \rateRef pubkey maxRate windowMs t -> atomic do
816+ let r = checkRate rates pubkey maxRate windowMs 5000 t
817+ set *rateRef = r.entries
820+checkPairRateGate = \sender recipient t -> atomic do
822+ let r = checkRate rates (sender ++ "|" ++ recipient) maxPairRatePerPair pairRateWindowMs 5000 t
823+ set *pairRates = r.entries
826+checkServerRateGate = \server t -> atomic do
827+ rates <- *federationRates
828+ let r = checkRate rates server maxFederationRatePerServer federationRateWindowMs 5000 t
829+ set *federationRates = r.entries
3096−computeForwardStatsInner = \b t acc ->
832+checkPreAuth = \clientIp t -> do
3097− if b > 15 then yield acc
833+ dp <- *drainPhase
3099− bucket <- readFwdBucket b
3100− let bucketCount = count bucket
3101− let bucketOldest = case minBy bucket (\x -> x.createdAt) of Nothing {} -> 0; Just {value: x} -> t - x.createdAt
3102− -- Aggregate per-server counts: merge this bucket's servers into the running totals
3103− let updatedServerCounts = fold (\sc f ->
3104− if any sc (\s -> s.server == f.toServer)
3105− then do s <- sc; yield (if s.server == f.toServer then {server: s.server, count: s.count + 1} else s)
3106− else union sc [{server: f.toServer, count: 1}]) acc.serverCounts bucket
3107− let newMaxDepth = fold (\mx s -> max mx s.count) acc.maxDepth updatedServerCounts
3108− computeForwardStatsInner (b + 1) t {totalCount: acc.totalCount + bucketCount, oldestAge: max acc.oldestAge bucketOldest, serverCount: count updatedServerCounts, maxDepth: newMaxDepth, serverCounts: updatedServerCounts}
3110−-- Lightweight scan: find the oldest forward entry age across all 16 buckets.
3111−-- O(n) total, no allocation (just tracks max age). Used by health check.
3112−oldestForwardAgeAcrossBuckets : Int -> Timestamp -> Int -> IO Int
3113−oldestForwardAgeAcrossBuckets = \b t acc ->
3114− if b > 15 then yield acc
834+ if dp >= 1 then yield "draining"
3116− bucket <- readFwdBucket b
836+ g <- checkGlobalRate t
3117− let bucketOldest = case minBy bucket (\x -> x.createdAt) of Nothing {} -> 0; Just {value: x} -> t - x.createdAt
837+ if g then yield "global_rate_limited"
3118− oldestForwardAgeAcrossBuckets (b + 1) t (max acc bucketOldest)
3120−-- Count distinct destination servers with stale forward queues (oldest entry > healthForwardQueueMaxAge).
3121−-- Scans all 16 buckets, tracking unique stale servers across buckets.
3122−-- O(total_forwards) scan with O(servers) memory. Used by health check for per-server awareness.
3123−countStaleForwardServers : Int -> Timestamp -> [Text] -> IO Int
3124−countStaleForwardServers = \b t seen ->
3126− then yield (count seen)
3128− bucket <- readFwdBucket b
839+ i <- checkIpRateGate clientIp t
3129− -- Find servers in this bucket with entries older than the threshold
840+ if i then yield "ip_rate_limited"
3130− let newStale = fold (\sacc f ->
3131− let age = t - f.createdAt in
3132− if age > healthForwardQueueMaxAge && none sacc (\s -> s == f.toServer) && none seen (\s -> s == f.toServer)
3133− then union [f.toServer] sacc
3134− else sacc) [] bucket
3135− countStaleForwardServers (b + 1) t (union seen newStale)
3137−-- Remove forward entries matching a server and message IDs, scanning per-bucket.
3138−-- Only rewrites buckets that actually changed (avoids writeAllForwards repartitioning).
3139−-- Returns all removed forward entries across all buckets.
3140−-- Batches the totalForwardCount decrement into a single atomic write at the end
3141−-- to reduce STM contention (vs per-bucket decrements contending on the shared counter).
3142−removeForwardsByServer = \server messageIds b acc ->
3144− let totalRemoved = count acc
3145− when (totalRemoved > 0) (atomic do
3146− tfc <- *totalForwardCount
3147− set *totalForwardCount = max 0 (tfc - totalRemoved))
3150− removed <- atomic do
3151− bucket <- readFwdBucket b
3152− let matched = do f <- bucket; where f.toServer == server && any messageIds (\mid -> f.messageId == mid); yield f
3153− when (count matched > 0) (
3154− writeFwdBucket b (do f <- bucket; where not (f.toServer == server && any messageIds (\mid -> f.messageId == mid)); yield f))
3156− removeForwardsByServer server messageIds (b + 1) (if count removed > 0 then union acc removed else acc)
3158−-- Read only the forward buckets at the given indices (avoids reading all 16)
3159−readSelectedFwdBuckets : [Int] -> IO [ForwardEntry]
3160−readSelectedFwdBuckets = \buckets ->
3161− case headOf buckets of
3162− Nothing {} -> yield []
841+ else yield ""
3163− Just {value: b} -> do
3164− let rest = do x <- buckets; where x != b; yield x
3165− entries <- readFwdBucket b
3166− remaining <- readSelectedFwdBuckets rest
3167− yield (union entries remaining)
3169−-- Write forward entries to only the specified bucket indices. Entries are filtered
3170−-- by pubkeyBucket so each bucket gets only its entries. Unspecified buckets are untouched.
3171−writeSelectedFwdBuckets : [Int] -> [ForwardEntry] -> IO ()
3172−writeSelectedFwdBuckets = \buckets entries ->
3173− case headOf buckets of
3174− Nothing {} -> yield {}
3175− Just {value: b} -> do
3176− let rest = do x <- buckets; where x != b; yield x
3177− let bucketEntries = do e <- entries; where pubkeyBucket e.toKey == b; yield e
3178− writeFwdBucket b bucketEntries
3179− writeSelectedFwdBuckets rest entries
3181−writeAllForwards : [ForwardEntry] -> IO ()
3182−writeAllForwards = \fwds -> do
3183− let partitioned = fold (\acc f ->
3184− let b = pubkeyBucket f.toKey in
3185− {b0: if b == 0 then union [f] acc.b0 else acc.b0,
3186− b1: if b == 1 then union [f] acc.b1 else acc.b1,
3187− b2: if b == 2 then union [f] acc.b2 else acc.b2,
3188− b3: if b == 3 then union [f] acc.b3 else acc.b3,
3189− b4: if b == 4 then union [f] acc.b4 else acc.b4,
3190− b5: if b == 5 then union [f] acc.b5 else acc.b5,
3191− b6: if b == 6 then union [f] acc.b6 else acc.b6,
3192− b7: if b == 7 then union [f] acc.b7 else acc.b7,
3193− b8: if b == 8 then union [f] acc.b8 else acc.b8,
3194− b9: if b == 9 then union [f] acc.b9 else acc.b9,
3195− b10: if b == 10 then union [f] acc.b10 else acc.b10,
3196− b11: if b == 11 then union [f] acc.b11 else acc.b11,
3197− b12: if b == 12 then union [f] acc.b12 else acc.b12,
3198− b13: if b == 13 then union [f] acc.b13 else acc.b13,
3199− b14: if b == 14 then union [f] acc.b14 else acc.b14,
3200− b15: if b == 15 then union [f] acc.b15 else acc.b15})
3201− {b0: [], b1: [], b2: [], b3: [], b4: [], b5: [], b6: [], b7: [], b8: [], b9: [], b10: [], b11: [], b12: [], b13: [], b14: [], b15: []} fwds
3202− writeFwdBucket 0 partitioned.b0
3203− writeFwdBucket 1 partitioned.b1
3204− writeFwdBucket 2 partitioned.b2
3205− writeFwdBucket 3 partitioned.b3
3206− writeFwdBucket 4 partitioned.b4
3207− writeFwdBucket 5 partitioned.b5
3208− writeFwdBucket 6 partitioned.b6
3209− writeFwdBucket 7 partitioned.b7
3210− writeFwdBucket 8 partitioned.b8
3211− writeFwdBucket 9 partitioned.b9
3212− writeFwdBucket 10 partitioned.b10
3213− writeFwdBucket 11 partitioned.b11
3214− writeFwdBucket 12 partitioned.b12
3215− writeFwdBucket 13 partitioned.b13
3216− writeFwdBucket 14 partitioned.b14
3217− writeFwdBucket 15 partitioned.b15
3219-- ============================================
843-- ============================================
3220−-- AckedIds Bucket Helpers
844+-- Federation failure tracking (simple, no circuit breaker)
3221-- ============================================
845-- ============================================
3222−readAckedBucket : Int -> IO [AckedEntry]
3223−readAckedBucket = \b ->
3224− if b == 0 then do s <- *ackedBucket0; yield s else if b == 1 then do s <- *ackedBucket1; yield s
3225− else if b == 2 then do s <- *ackedBucket2; yield s else if b == 3 then do s <- *ackedBucket3; yield s
3226− else if b == 4 then do s <- *ackedBucket4; yield s else if b == 5 then do s <- *ackedBucket5; yield s
3227− else if b == 6 then do s <- *ackedBucket6; yield s else if b == 7 then do s <- *ackedBucket7; yield s
3228− else if b == 8 then do s <- *ackedBucket8; yield s else if b == 9 then do s <- *ackedBucket9; yield s
3229− else if b == 10 then do s <- *ackedBucket10; yield s else if b == 11 then do s <- *ackedBucket11; yield s
3230− else if b == 12 then do s <- *ackedBucket12; yield s else if b == 13 then do s <- *ackedBucket13; yield s
3231− else if b == 14 then do s <- *ackedBucket14; yield s else do s <- *ackedBucket15; yield s
3233−writeAckedBucket : Int -> [AckedEntry] -> IO ()
3234−writeAckedBucket = \b entries ->
3235− if b == 0 then set *ackedBucket0 = entries else if b == 1 then set *ackedBucket1 = entries
3236− else if b == 2 then set *ackedBucket2 = entries else if b == 3 then set *ackedBucket3 = entries
3237− else if b == 4 then set *ackedBucket4 = entries else if b == 5 then set *ackedBucket5 = entries
3238− else if b == 6 then set *ackedBucket6 = entries else if b == 7 then set *ackedBucket7 = entries
3239− else if b == 8 then set *ackedBucket8 = entries else if b == 9 then set *ackedBucket9 = entries
3240− else if b == 10 then set *ackedBucket10 = entries else if b == 11 then set *ackedBucket11 = entries
3241− else if b == 12 then set *ackedBucket12 = entries else if b == 13 then set *ackedBucket13 = entries
3242− else if b == 14 then set *ackedBucket14 = entries else set *ackedBucket15 = entries
3244−readAllAcked : IO [AckedEntry]
3246− a0 <- *ackedBucket0; a1 <- *ackedBucket1; a2 <- *ackedBucket2; a3 <- *ackedBucket3
3247− a4 <- *ackedBucket4; a5 <- *ackedBucket5; a6 <- *ackedBucket6; a7 <- *ackedBucket7
3248− a8 <- *ackedBucket8; a9 <- *ackedBucket9; a10 <- *ackedBucket10; a11 <- *ackedBucket11
3249− a12 <- *ackedBucket12; a13 <- *ackedBucket13; a14 <- *ackedBucket14; a15 <- *ackedBucket15
3250− yield (unionNE a0 (unionNE a1 (unionNE a2 (unionNE a3 (unionNE a4 (unionNE a5 (unionNE a6 (unionNE a7 (unionNE a8 (unionNE a9 (unionNE a10 (unionNE a11 (unionNE a12 (unionNE a13 (unionNE a14 a15)))))))))))))))
3252−writeAllAcked : [AckedEntry] -> IO ()
3253−writeAllAcked = \entries -> do
3254− let p = fold (\acc e -> let b = pubkeyBucket e.toKey in
3255− {b0: if b == 0 then union [e] acc.b0 else acc.b0, b1: if b == 1 then union [e] acc.b1 else acc.b1,
3256− b2: if b == 2 then union [e] acc.b2 else acc.b2, b3: if b == 3 then union [e] acc.b3 else acc.b3,
3257− b4: if b == 4 then union [e] acc.b4 else acc.b4, b5: if b == 5 then union [e] acc.b5 else acc.b5,
3258− b6: if b == 6 then union [e] acc.b6 else acc.b6, b7: if b == 7 then union [e] acc.b7 else acc.b7,
3259− b8: if b == 8 then union [e] acc.b8 else acc.b8, b9: if b == 9 then union [e] acc.b9 else acc.b9,
3260− b10: if b == 10 then union [e] acc.b10 else acc.b10, b11: if b == 11 then union [e] acc.b11 else acc.b11,
3261− b12: if b == 12 then union [e] acc.b12 else acc.b12, b13: if b == 13 then union [e] acc.b13 else acc.b13,
3262− b14: if b == 14 then union [e] acc.b14 else acc.b14, b15: if b == 15 then union [e] acc.b15 else acc.b15})
3263− {b0: [], b1: [], b2: [], b3: [], b4: [], b5: [], b6: [], b7: [], b8: [], b9: [], b10: [], b11: [], b12: [], b13: [], b14: [], b15: []} entries
3264− writeAckedBucket 0 p.b0; writeAckedBucket 1 p.b1; writeAckedBucket 2 p.b2; writeAckedBucket 3 p.b3
3265− writeAckedBucket 4 p.b4; writeAckedBucket 5 p.b5; writeAckedBucket 6 p.b6; writeAckedBucket 7 p.b7
3266− writeAckedBucket 8 p.b8; writeAckedBucket 9 p.b9; writeAckedBucket 10 p.b10; writeAckedBucket 11 p.b11
3267− writeAckedBucket 12 p.b12; writeAckedBucket 13 p.b13; writeAckedBucket 14 p.b14; writeAckedBucket 15 p.b15
3269−countAllAcked : Int -> IO Int
3270−countAllAcked = \b -> if b > 15 then yield 0 else do
3271− bucket <- readAckedBucket b; rest <- countAllAcked (b + 1); yield (count bucket + rest)
3273−-- Per-bucket pruning for acked entries (avoids readAllAcked/writeAllAcked repartitioning).
3274−-- Each bucket is pruned in its own atomic block to reduce lock contention with poll-ack paths.
3275−pruneAllAckedBuckets : Int -> Timestamp -> IO ()
3276−pruneAllAckedBuckets = \b retainCutoff ->
3277− if b > 15 then yield {}
3280− bucket <- readAckedBucket b
3281− writeAckedBucket b (do a <- bucket; where a.ackedAt > retainCutoff; yield a)
3282− pruneAllAckedBuckets (b + 1) retainCutoff
3284−-- Per-bucket pruning for forward entries (avoids readAllForwards/writeAllForwards repartitioning).
3285−-- Each bucket is pruned in its own atomic block to reduce lock contention with sendMessageCore.
3286−-- Returns the total count of surviving entries for totalForwardCount reconciliation.
3287−pruneAllFwdBuckets : Int -> Timestamp -> Bool -> Int -> IO Int
3288−pruneAllFwdBuckets = \b retainCutoff fedEnabled acc ->
3289− if b > 15 then yield acc
3292− bucket <- readFwdBucket b
3293− let pruned = if not fedEnabled then []
3294− else do f <- bucket; where f.createdAt > retainCutoff; yield f
3295− writeFwdBucket b pruned
3296− yield (count pruned)
3297− pruneAllFwdBuckets (b + 1) retainCutoff fedEnabled (acc + kept)
3299−-- Find the oldest (minimum) ackedAt timestamp across all 16 acked buckets.
3300−-- Returns 0 if no acked entries exist. Avoids materializing all buckets into one list.
3301−computeOldestAckedAt : Int -> IO Timestamp
3302−computeOldestAckedAt = \b -> if b > 15 then yield 0 else do
3303− bucket <- readAckedBucket b
3304− let bucketMin = case minBy bucket (\x -> x.ackedAt) of Nothing {} -> 0; Just {value: x} -> x.ackedAt
3305− restMin <- computeOldestAckedAt (b + 1)
3306− yield (if bucketMin == 0 then restMin else if restMin == 0 then bucketMin else min bucketMin restMin)
3308−-- ============================================
847+pow2 : Int -> Int
3309−-- DeliveredIds Bucket Helpers
848+pow2 = \n -> if n <= 0 then 1 else 2 * pow2 (n - 1)
3310−-- ============================================
3311−readDelivBucket : Int -> IO [DeliveredEntry]
3312−readDelivBucket = \b ->
3313− if b == 0 then do s <- *delivBucket0; yield s else if b == 1 then do s <- *delivBucket1; yield s
3314− else if b == 2 then do s <- *delivBucket2; yield s else if b == 3 then do s <- *delivBucket3; yield s
3315− else if b == 4 then do s <- *delivBucket4; yield s else if b == 5 then do s <- *delivBucket5; yield s
3316− else if b == 6 then do s <- *delivBucket6; yield s else if b == 7 then do s <- *delivBucket7; yield s
3317− else if b == 8 then do s <- *delivBucket8; yield s else if b == 9 then do s <- *delivBucket9; yield s
3318− else if b == 10 then do s <- *delivBucket10; yield s else if b == 11 then do s <- *delivBucket11; yield s
3319− else if b == 12 then do s <- *delivBucket12; yield s else if b == 13 then do s <- *delivBucket13; yield s
3320− else if b == 14 then do s <- *delivBucket14; yield s else do s <- *delivBucket15; yield s
3322−writeDelivBucket : Int -> [DeliveredEntry] -> IO ()
3323−writeDelivBucket = \b entries ->
3324− if b == 0 then set *delivBucket0 = entries else if b == 1 then set *delivBucket1 = entries
3325− else if b == 2 then set *delivBucket2 = entries else if b == 3 then set *delivBucket3 = entries
3326− else if b == 4 then set *delivBucket4 = entries else if b == 5 then set *delivBucket5 = entries
3327− else if b == 6 then set *delivBucket6 = entries else if b == 7 then set *delivBucket7 = entries
3328− else if b == 8 then set *delivBucket8 = entries else if b == 9 then set *delivBucket9 = entries
3329− else if b == 10 then set *delivBucket10 = entries else if b == 11 then set *delivBucket11 = entries
3330− else if b == 12 then set *delivBucket12 = entries else if b == 13 then set *delivBucket13 = entries
3331− else if b == 14 then set *delivBucket14 = entries else set *delivBucket15 = entries
3333−readAllDelivered : IO [DeliveredEntry]
3334−readAllDelivered = do
3335− d0 <- *delivBucket0; d1 <- *delivBucket1; d2 <- *delivBucket2; d3 <- *delivBucket3
3336− d4 <- *delivBucket4; d5 <- *delivBucket5; d6 <- *delivBucket6; d7 <- *delivBucket7
3337− d8 <- *delivBucket8; d9 <- *delivBucket9; d10 <- *delivBucket10; d11 <- *delivBucket11
3338− d12 <- *delivBucket12; d13 <- *delivBucket13; d14 <- *delivBucket14; d15 <- *delivBucket15
3339− yield (unionNE d0 (unionNE d1 (unionNE d2 (unionNE d3 (unionNE d4 (unionNE d5 (unionNE d6 (unionNE d7 (unionNE d8 (unionNE d9 (unionNE d10 (unionNE d11 (unionNE d12 (unionNE d13 (unionNE d14 d15)))))))))))))))
3341−writeAllDelivered : [DeliveredEntry] -> IO ()
3342−writeAllDelivered = \entries -> do
3343− let p = fold (\acc e -> let b = pubkeyBucket e.toKey in
3344− {b0: if b == 0 then union [e] acc.b0 else acc.b0, b1: if b == 1 then union [e] acc.b1 else acc.b1,
3345− b2: if b == 2 then union [e] acc.b2 else acc.b2, b3: if b == 3 then union [e] acc.b3 else acc.b3,
3346− b4: if b == 4 then union [e] acc.b4 else acc.b4, b5: if b == 5 then union [e] acc.b5 else acc.b5,
3347− b6: if b == 6 then union [e] acc.b6 else acc.b6, b7: if b == 7 then union [e] acc.b7 else acc.b7,
3348− b8: if b == 8 then union [e] acc.b8 else acc.b8, b9: if b == 9 then union [e] acc.b9 else acc.b9,
3349− b10: if b == 10 then union [e] acc.b10 else acc.b10, b11: if b == 11 then union [e] acc.b11 else acc.b11,
3350− b12: if b == 12 then union [e] acc.b12 else acc.b12, b13: if b == 13 then union [e] acc.b13 else acc.b13,
3351− b14: if b == 14 then union [e] acc.b14 else acc.b14, b15: if b == 15 then union [e] acc.b15 else acc.b15})
3352− {b0: [], b1: [], b2: [], b3: [], b4: [], b5: [], b6: [], b7: [], b8: [], b9: [], b10: [], b11: [], b12: [], b13: [], b14: [], b15: []} entries
3353− writeDelivBucket 0 p.b0; writeDelivBucket 1 p.b1; writeDelivBucket 2 p.b2; writeDelivBucket 3 p.b3
3354− writeDelivBucket 4 p.b4; writeDelivBucket 5 p.b5; writeDelivBucket 6 p.b6; writeDelivBucket 7 p.b7
3355− writeDelivBucket 8 p.b8; writeDelivBucket 9 p.b9; writeDelivBucket 10 p.b10; writeDelivBucket 11 p.b11
3356− writeDelivBucket 12 p.b12; writeDelivBucket 13 p.b13; writeDelivBucket 14 p.b14; writeDelivBucket 15 p.b15
3358−countAllDelivered : Int -> IO Int
3359−countAllDelivered = \b -> if b > 15 then yield 0 else do
3360− bucket <- readDelivBucket b; rest <- countAllDelivered (b + 1); yield (count bucket + rest)
3362−-- Per-bucket pruning for delivered entries (avoids readAllDelivered/writeAllDelivered repartitioning).
3363−pruneAllDeliveredBuckets : Int -> Timestamp -> IO ()
3364−pruneAllDeliveredBuckets = \b retainCutoff ->
3365− if b > 15 then yield {}
3368− bucket <- readDelivBucket b
3369− writeDelivBucket b (do d <- bucket; where d.deliveredAt > retainCutoff; yield d)
3370− pruneAllDeliveredBuckets (b + 1) retainCutoff
3372−-- ============================================
850+retryBackoff : Int -> Int<Ms>
3373−-- Federation In-Flight Tracking
851+retryBackoff = \failures ->
3374−-- ============================================
852+ min retryBackoffMax (retryBackoffBase * pow2 (max 0 (failures - 1)))
3375−-- Tracks outstanding federation fetches per server. Servers with hung requests
3376−-- (older than federationFetchTimeoutMs) are skipped to prevent slot exhaustion.
3378−markFederationInFlight = \server -> do
854+shouldRetryServer : Text -> Timestamp -> [ForwardFailure] -> Bool
855+shouldRetryServer = \server t failures ->
856+ case headOf (do f <- failures; where f.server == server; yield f) of
857+ Nothing {} -> True {}
858+ Just {value: f} -> t - f.failedAt >= retryBackoff f.failures
860+recordFailure = \server -> do
3379 t <- now
861 t <- now
3380 atomic do
862 atomic do
3381− inFlight <- *federationInFlight
863+ failures <- *forwardFailures
3382− let existing = headOf (do r <- inFlight; where r.server == server; yield r)
864+ let existing = headOf (do f <- failures; where f.server == server; yield f)
3383 case existing of
865 case existing of
3384− Nothing {} -> set *federationInFlight =
866+ Nothing {} -> set *forwardFailures = union failures [{server: server, failedAt: t, failures: 1, firstFailedAt: t}]
3385− let updated = union inFlight [{server: server, count: 1, firstStartedAt: t}] in
867+ Just {value: f} -> set *forwardFailures = do x <- failures; yield (if x.server == server then {server: x.server, failedAt: t, failures: min (x.failures + 1) 10, firstFailedAt: x.firstFailedAt} else x)
3386− if count updated > maxFederationInFlight then evictOneOldest updated (\r -> r.firstStartedAt) else updated
868+
3387− Just {} -> set *federationInFlight = do r <- inFlight; yield (if r.server == server then {server: r.server, count: r.count + 1, firstStartedAt: r.firstStartedAt} else r)
869+clearFailure = \server -> atomic do
3388−
870+ failures <- *forwardFailures
3389−clearFederationInFlight = \server -> atomic do
871+ set *forwardFailures = do f <- failures; where f.server != server; yield f
3390− inFlight <- *federationInFlight
872+
3391− set *federationInFlight = do r <- inFlight; yield (if r.server == server then {server: r.server, count: max 0 (r.count - 1), firstStartedAt: if r.count <= 1 then 0 else r.firstStartedAt} else r)
873+-- ============================================
3392−
874+-- Common utility queries
3393−hasHungFederationRequest : Text -> Timestamp -> [FederationInFlightEntry] -> Bool
875+-- ============================================
3394−hasHungFederationRequest = \server t inFlight ->
3395− any inFlight (\r -> r.server == server && r.count > 0 && r.firstStartedAt > 0 && t - r.firstStartedAt >= federationFetchTimeoutMs)
3397−-- Wrapper around fetch for federation calls: tracks in-flight state, global connection count,
3398−-- logs slow responses, and records latency metrics.
3399−-- NOTE: If fetch panics (runtime error), in-flight and connection counters leak until
3400−-- pruneExpired reclaims them (stale threshold: 1.5x federationFetchTimeoutMs). Knot
3401−-- lacks try-finally, so this safety net in pruneExpired is the cleanup mechanism.
3402−fetchFederation = \server request -> do
3403− -- Acquire global federation connection slot
3405− ac <- *federationActiveConnections
3406− set *federationActiveConnections = ac + 1
3407− markFederationInFlight server
3409− result <- fetch (federationUrl server) request
3410− clearFederationInFlight server
3411− -- Release global federation connection slot
3413− ac <- *federationActiveConnections
3414− set *federationActiveConnections = max 0 (ac - 1)
3416− let latency = endTime - startTime
3417− when (latency > federationFetchTimeoutMs)
3418− (logWarn ("federation: slow response from " ++ server ++ " (" ++ show latency ++ "ms)"))
3419− -- Skip latency recording during startup probes (unauthenticated, expected to fail)
3420− probing <- *startupProbeActive
3421− when (not probing) (atomic do
3422− total <- *federationLatencyTotal
3423− cnt <- *federationLatencyCount
3424− mx <- *federationLatencyMax
3425− set *federationLatencyTotal = total + latency
3426− set *federationLatencyCount = cnt + 1
3427− set *federationLatencyMax = if latency > mx then latency else mx
3428− -- Histogram bucket increment
3429− if latency < federationLatencyT1 then do b <- *federationLatencyBucket0; set *federationLatencyBucket0 = b + 1
3430− else if latency < federationLatencyT2 then do b <- *federationLatencyBucket1; set *federationLatencyBucket1 = b + 1
3431− else if latency < federationLatencyT3 then do b <- *federationLatencyBucket2; set *federationLatencyBucket2 = b + 1
3432− else do b <- *federationLatencyBucket3; set *federationLatencyBucket3 = b + 1
3433− -- Per-peer latency tracking
3434− peerLats <- *peerLatencies
3435− let peerEntry = headOf (do p <- peerLats; where p.server == server; yield p)
3436− let isNewWindow = case peerEntry of Nothing {} -> True {}; Just {value: p} -> endTime - p.windowStart >= federationLatencyWindowMs
3437− let updatedPeers = if isNewWindow
3438− then union (do p <- peerLats; where p.server != server; yield p) [{server: server, totalMs: latency, count: 1, maxMs: latency, windowStart: endTime}]
3439− else do p <- peerLats; yield (if p.server == server then {server: p.server, totalMs: p.totalMs + latency, count: p.count + 1, maxMs: max p.maxMs latency, windowStart: p.windowStart} else p)
3440− set *peerLatencies = if count updatedPeers > maxPeerLatencyEntries then evictOneOldest updatedPeers (\p -> p.windowStart) else updatedPeers)
3443clampTtl : Int<S> -> Int<S>
877clampTtl : Int<S> -> Int<S>
3444clampTtl = clamp 1 maxPresenceTtl
878clampTtl = clamp 1 maxPresenceTtl
@@ -3446,5020 +880,1232 @@ clampTtl = clamp 1 maxPresenceTtl
3446clampTimestamp : Timestamp -> Timestamp -> Timestamp
880clampTimestamp : Timestamp -> Timestamp -> Timestamp
3447clampTimestamp = \timestamp t -> clamp (t - messageMaxAge) t timestamp
881clampTimestamp = \timestamp t -> clamp (t - messageMaxAge) t timestamp
3449−-- Compute effective message TTL: 0 = server default, otherwise clamp to [minMessageTtl, unackedMessageMaxAge].
3450−-- Returns the TTL in milliseconds to add to receivedAt for expiresAt.
3451−-- Compute effective message TTL: 0 or negative = server default, otherwise clamp.
3452effectiveMessageTtl : Int<Ms> -> Int<Ms>
883effectiveMessageTtl : Int<Ms> -> Int<Ms>
3453effectiveMessageTtl = \expiresInMs ->
884effectiveMessageTtl = \expiresInMs ->
3454 if expiresInMs <= 0 then unackedMessageMaxAge
885 if expiresInMs <= 0 then unackedMessageMaxAge
3455 else clamp minMessageTtl unackedMessageMaxAge expiresInMs
886 else clamp minMessageTtl unackedMessageMaxAge expiresInMs
3457−-- Ensure strictly monotonic timestamps for message ordering
3458nextSeqTs : Timestamp -> Timestamp -> Timestamp
888nextSeqTs : Timestamp -> Timestamp -> Timestamp
3459nextSeqTs = \t seqCounter -> if t > seqCounter then t else seqCounter + 1
889nextSeqTs = \t seqCounter -> if t > seqCounter then t else seqCounter + 1
3461−-- Deduplicate message IDs, preserving order, capped at maxMessageIds.
3462−-- O(n^2) due to `any acc` inside fold, but bounded by maxMessageIds = 100,
3463−-- so worst case is 10,000 comparisons (acceptable for the hot path).
3464dedupMessageIds : [MessageIdHex] -> [MessageIdHex]
891dedupMessageIds : [MessageIdHex] -> [MessageIdHex]
3465−dedupMessageIds = \messageIds ->
892+dedupMessageIds = \ids ->
3466− let capped = takeRelation maxMessageIds messageIds in
893+ let capped = takeRelation maxMessageIds ids in
3468− if any acc (\a -> a == mid) then acc
894+ fold (\acc mid -> if any acc (\a -> a == mid) then acc else union acc [mid]) [] capped
3469− else union [mid] acc) [] capped
3471−-- Constant-time comparison iteration count. Must be >= the longest secret
3472−-- compared: session tokens are tokenHexLen (48) hex chars, but maintenance
3473−-- secrets can be up to maxTokenLen (256) chars (validated by extractToken).
3474−-- Using maxTokenLen + 16 ensures full comparison for all accepted inputs.
3475−safeCompareLen = maxTokenLen + 16
3477−-- Constant-time string comparison to prevent timing side-channels.
896+presenceForKey = \presence pubkey t ->
3478−-- Always iterates safeCompareLen characters regardless of input length;
897+ do p <- presence; where p.pubkey == pubkey && p.expiresAt > t; yield p
3479−-- rejects empty strings. Tracks both character mismatches and length
3480−-- mismatch (one string ended before the other) within the loop itself,
3481−-- avoiding variable-time count(chars) calls that would leak string length.
3482−safeCompareLoop : Text -> Text -> Int -> Int -> Int -> Int
3483−safeCompareLoop = \s1 s2 n diff lenDiff ->
3485− then diff + lenDiff
3487− let c1 = take 1 s1 in
3488− let c2 = take 1 s2 in
3489− let newDiff = diff + (if c1 == c2 then 0 else 1) in
3490− let endMismatch = if c1 == "" then (if c2 == "" then 0 else 1) else (if c2 == "" then 1 else 0) in
3491− safeCompareLoop (drop 1 s1) (drop 1 s2) (n - 1) newDiff (lenDiff + endMismatch)
3493−safeCompare : Text -> Text -> Bool
899+bestServerForKey = \entries ->
3494−safeCompare = \a b ->
900+ if any entries (\p -> isLocalServer p.server) then serverHostN
3495− if take 1 a == "" || take 1 b == "" then False {}
901+ else case maxBy (do p <- entries; where not (isLocalServer p.server); yield p) (\p -> p.expiresAt) of
3496− else safeCompareLoop a b safeCompareLen 0 0 == 0
902+ Just {value: p} -> p.server
3498−-- Constant-time IP binding check: returns True if IPs match or no binding is configured.
905+hasMessage : MessageIdHex -> PubkeyHex -> [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> Bool
3499−-- When a session was created with an IP (behind a proxy), requests without an IP header
906+hasMessage = \mid toKey items -> any items (\x -> x.messageId == mid && x.toKey == toKey)
3500−-- are rejected — prevents bypass if the proxy is removed mid-session.
3501−-- Uses safeCompareLoop to prevent timing side-channels on IP comparison.
3502−-- Uses maxIpLen (45) instead of maxServerNameLen (128) to avoid wasted iterations.
3503−matchIp : Text -> Text -> Bool
3504−matchIp = \clientIp sessionIp ->
3505− if sessionIp == "" then True {} -- no binding configured for this session
3506− else if clientIp == "" then False {} -- session has IP but request doesn't — proxy disappeared
3507− else safeCompareLoop clientIp sessionIp maxIpLen 0 0 == 0
3509−-- Generic sliding-window rate limiter using the sliding window counter algorithm.
3510−-- Instead of a fixed window that resets abruptly (allowing 2x burst at boundaries),
3511−-- interpolates between the current and previous window's counts:
3512−-- effectiveCount = prevCount * (1 - elapsed/windowMs) + count
3513−-- This smoothly transitions between windows, preventing boundary bursts.
3514−-- Callers provide match/create/update/rotate functions for their entry type.
3515−-- Uses a direct fold for entry lookup (avoids materializing a filtered intermediate list).
3516−checkRateWindow = \entries matchKey makeNew updateCount rotateWindow getCount getPrevCount maxRate windowMs maxEntries t ->
3517− let entry = fold (\acc r -> case acc of Just _ -> acc; Nothing {} -> if matchKey r then Just {value: r} else acc) Nothing {} entries in
3518− let isNewWindow = case entry of Nothing {} -> True {}; Just {value: r} -> t - r.windowStart >= windowMs in
3519− -- Sliding window interpolation: weight previous window's count by remaining fraction
3520− let elapsed = case entry of Nothing {} -> 0; Just {value: r} -> t - r.windowStart in
3521− let prevWeight = case entry of Nothing {} -> 0; Just {value: r} -> if isNewWindow then 0 else getPrevCount r * (windowMs - elapsed) / windowMs in
3522− let currentCount = case entry of Nothing {} -> 0; Just {value: r} -> if isNewWindow then 0 else getCount r in
3523− let effectiveCount = prevWeight + currentCount in
3524− if effectiveCount >= maxRate
3525− then let retryMs = case entry of Nothing {} -> windowMs; Just {value: r} -> max 0 (windowMs - elapsed)
3526− in {limited: True {}, entries: entries, retryAfterMs: retryMs}
3528− let newEntries = if isNewWindow
3529− then let prevCount = case entry of Nothing {} -> 0; Just {value: r} -> getCount r
3530− in union (do r <- entries; where not (matchKey r); yield r) [rotateWindow (makeNew t) prevCount]
3531− else do r <- entries; yield (if matchKey r then updateCount r else r)
3532− in {limited: False {}, entries: if count newEntries > maxEntries then (do r <- newEntries; where t - r.windowStart < windowMs * 2; yield r) else newEntries, retryAfterMs: 0}
3534−-- Rate limiter helpers: wrap common checkRateWindow patterns to reduce boilerplate.
3535−-- Each returns {limited, entries, retryAfterMs} — caller reads/writes the mutable ref.
3536−checkPubkeyRate = \rates pubkey maxRate windowMs maxEntries t ->
3537− checkRateWindow rates (\r -> r.pubkey == pubkey)
3538− (\ts -> {pubkey: pubkey, windowStart: ts, count: 1, prevCount: 0})
3539− (\r -> {pubkey: r.pubkey, windowStart: r.windowStart, count: r.count + 1, prevCount: r.prevCount})
3540− (\r pc -> {pubkey: r.pubkey, windowStart: r.windowStart, count: r.count, prevCount: pc})
3541− (\r -> r.count) (\r -> r.prevCount)
3542− maxRate windowMs maxEntries t
3544−checkIpRate = \rates ip maxRate windowMs maxEntries t ->
3545− checkRateWindow rates (\r -> r.ip == ip)
3546− (\ts -> {ip: ip, windowStart: ts, count: 1, prevCount: 0})
3547− (\r -> {ip: r.ip, windowStart: r.windowStart, count: r.count + 1, prevCount: r.prevCount})
3548− (\r pc -> {ip: r.ip, windowStart: r.windowStart, count: r.count, prevCount: pc})
3549− (\r -> r.count) (\r -> r.prevCount)
3550− maxRate windowMs maxEntries t
3552−checkServerRate = \rates server maxRate windowMs maxEntries t ->
3553− checkRateWindow rates (\r -> r.server == server)
3554− (\ts -> {server: server, windowStart: ts, count: 1, prevCount: 0})
3555− (\r -> {server: r.server, windowStart: r.windowStart, count: r.count + 1, prevCount: r.prevCount})
3556− (\r pc -> {server: r.server, windowStart: r.windowStart, count: r.count, prevCount: pc})
3557− (\r -> r.count) (\r -> r.prevCount)
3558− maxRate windowMs maxEntries t
3560−checkPairRate = \rates sender recipient maxRate windowMs maxEntries t ->
3561− checkRateWindow rates (\r -> r.sender == sender && r.recipient == recipient)
3562− (\ts -> {sender: sender, recipient: recipient, windowStart: ts, count: 1, prevCount: 0})
3563− (\r -> {sender: r.sender, recipient: r.recipient, windowStart: r.windowStart, count: r.count + 1, prevCount: r.prevCount})
3564− (\r pc -> {sender: r.sender, recipient: r.recipient, windowStart: r.windowStart, count: r.count, prevCount: pc})
3565− (\r -> r.count) (\r -> r.prevCount)
3566− maxRate windowMs maxEntries t
3568−-- Per-IP unique key rate check: tracks distinct pubkeys per IP per window.
3569−-- Returns True if the IP has authenticated too many unique keys (key-rotation abuse).
3570−checkUniqueKeyIpRate : [UniqueKeyIpEntry] -> Text -> PubkeyHex -> Timestamp -> {limited: Bool, entries: [UniqueKeyIpEntry]}
3571−checkUniqueKeyIpRate = \entries ip pubkey t ->
3572− if ip == "" then {limited: False {}, entries: entries}
3574− let entry = headOf (do r <- entries; where r.ip == ip; yield r) in
3575− let isNewWindow = case entry of Nothing {} -> True {}; Just {value: r} -> t - r.windowStart >= uniqueKeyIpWindowMs in
3577− then {limited: False {}, entries: union (do r <- entries; where r.ip != ip; yield r) [{ip: ip, keys: [pubkey], windowStart: t}]}
3579− Nothing {} -> {limited: False {}, entries: entries}
3581− let alreadyTracked = any r.keys (\k -> k == pubkey) in
3582− if alreadyTracked then {limited: False {}, entries: entries}
3583− else if count r.keys >= maxUniqueKeysPerIp
3584− then {limited: True {}, entries: entries}
3585− else {limited: False {}, entries: do e <- entries; yield (if e.ip == ip then {ip: e.ip, keys: union [pubkey] e.keys, windowStart: e.windowStart} else e)}
3587−checkServerRecipientRate = \rates server recipient maxRate windowMs maxEntries t ->
3588− checkRateWindow rates (\r -> r.server == server && r.recipient == recipient)
3589− (\ts -> {server: server, recipient: recipient, windowStart: ts, count: 1, prevCount: 0})
3590− (\r -> {server: r.server, recipient: r.recipient, windowStart: r.windowStart, count: r.count + 1, prevCount: r.prevCount})
3591− (\r pc -> {server: r.server, recipient: r.recipient, windowStart: r.windowStart, count: r.count, prevCount: pc})
3592− (\r -> r.count) (\r -> r.prevCount)
3593− maxRate windowMs maxEntries t
3595−-- Extract the item with the smallest key and return both the item and remaining list
3596−extractOldest = \items getKey ->
3598− case acc.candidate of
3599− Nothing {} -> {candidate: Just {value: x}, items: acc.items}
3601− if getKey x < getKey c
3602− then {candidate: Just {value: x}, items: union acc.items [c]}
3603− else {candidate: acc.candidate, items: union acc.items [x]}
3604− ) {candidate: Nothing {}, items: []} items
3606−-- Remove the single item with the smallest key value (LRU-style eviction).
3607−-- Single-pass: first fold finds the min key, second fold filters it out.
3608−-- Two passes over the data but O(1) intermediate state (just the min key),
3609−-- vs extractOldest which builds a full items list during the fold.
3610−evictOneOldest = \items getKey ->
3611− let minResult = fold (\acc x -> case acc of
3612− Nothing {} -> Just {value: getKey x}
3613− Just {value: v} -> if getKey x < v then Just {value: getKey x} else acc) Nothing {} items
3614− in case minResult of
3615− Nothing {} -> items
3616− Just {value: minKey} ->
3617− let r = fold (\acc x ->
3618− if not acc.done && getKey x == minKey then {items: acc.items, done: True {}}
3619− else {items: union acc.items [x], done: acc.done}) {items: [], done: False {}} items
3622−-- Remove the first item matching a predicate. O(n) single pass.
3623−removeFirstMatch = \items pred ->
3624− let r = fold (\acc x ->
3625− if not acc.done && pred x then {items: acc.items, done: True {}}
3626− else {items: union acc.items [x], done: acc.done}
3627− ) {items: [], done: False {}} items
3630−-- Remove the N items with the smallest key value.
3631−-- Single-pass fold maintaining N candidates with smallest keys, then diff.
3632−-- O(n*k) time — avoids the O(k*n²) cost of recursive extractOldest + list rebuilding.
3633−evictSmallest = \items n getKey ->
3634− if n <= 0 then {kept: items, evicted: []}
3635− else if count items <= n then {kept: [], evicted: items}
3637− let result = fold (\acc x ->
3638− if count acc.evict < n
3639− then {evict: union acc.evict [x], maxKey: if getKey x > acc.maxKey then getKey x else acc.maxKey}
3640− else if getKey x >= acc.maxKey then acc
3642− let without = removeFirstMatch acc.evict (\e -> getKey e == acc.maxKey) in
3643− let newEvict = union without [x] in
3644− let newMax = fold (\m e -> if getKey e > m then getKey e else m) (getKey x) newEvict in
3645− {evict: newEvict, maxKey: newMax}
3646− ) {evict: [], maxKey: 0} items
3647− in {kept: diff items result.evict, evicted: result.evict}
3649−-- Single-pass eviction by timestamp cutoff: keeps items where getKey >= cutoff.
3650−-- O(n) vs O(n*k) for evictSmallest. Used for forward nonce eviction on the hot path.
3651−evictByCutoff = \items cutoff getKey ->
3652− do x <- items; where getKey x >= cutoff; yield x
3654−-- Evict nonces with fallback: first try expired-nonce eviction (O(n)), then if still
3655−-- over capacity, evict oldest entries to create 5% headroom via evictSmallest.
3656−-- Headroom prevents re-triggering eviction on the next insert: by evicting down to 95%
3657−-- of maxCount, we amortize the O(n*k) evictSmallest cost across ~5% of capacity inserts
3658−-- instead of paying it on every single insert when at the boundary.
3659−-- Minimizes replay window: expired nonces are removed first (no window), and the
3660−-- headroom-based fallback creates a bounded window proportional to the eviction count.
3661−evictNonces = \items maxCount retention t ->
3662− let afterExpired = evictByCutoff items (t - retention) (\n -> n.seenAt) in
3663− if count afterExpired <= maxCount then afterExpired
3664− else let headroom = max 1 (maxCount / 20) in -- 5% headroom
3665− let evictCount = count afterExpired - maxCount + headroom in
3666− (evictSmallest afterExpired evictCount (\n -> n.seenAt)).kept
3668−-- Enforce per-key capacity: if a key has >= maxPerKey items, evict the oldest for that key.
3669−-- Also prunes expired items.
3670−capPerKey = \items matchKey maxPerKey getExpiry t ->
3671− let active = do x <- items; where getExpiry x > t; yield x in
3672− let forKey = do x <- active; where matchKey x; yield x in
3673− if count forKey >= maxPerKey
3674− then let others = diff active forKey in
3675− union others (evictOneOldest forKey getExpiry)
3678−-- Enforce global capacity: if at maxCount, evict the single oldest item
3679−capGlobal = \items maxCount getKey ->
3680− if count items >= maxCount
3681− then evictOneOldest items getKey
3684−-- Two-tier capacity enforcement: per-key first, then global
3685−capPerKeyAndGlobal = \items matchKey maxPerKey getExpiry t maxGlobal ->
3686− capGlobal (capPerKey items matchKey maxPerKey getExpiry t) maxGlobal getExpiry
3688−removeOneForKey = \items pubkey ->
3689− let forKey = do x <- items; where x.pubkey == pubkey; yield x in
3690− let others = do x <- items; where x.pubkey != pubkey; yield x in
3691− union others (evictOneOldest forKey (\x -> x.startedAt))
3693−-- Extract unique remote (non-local) server names from a list of items.
3694−-- O(n*k) where k = unique servers; acceptable since k is typically small (<20).
3695−-- Knot lacks efficient set/map types, so fold-with-any is the best available approach.
3696−-- NOTE: `union [s] acc` prepends (O(1) per step) vs `union acc [s]` which copies
3697−-- acc (O(|acc|) per step). Since this is a set (order doesn't matter), prepend is
3698−-- preferred for large collections. All set-accumulating folds use this pattern.
3699−collectPeerServers : [a] -> (a -> Text) -> [Text]
908+collectPeers : [a] -> (a -> Text) -> [Text]
3700−collectPeerServers = \items getServer ->
909+collectPeers = \items getServer ->
3701 fold (\acc item ->
910 fold (\acc item ->
3702 let s = getServer item in
911 let s = getServer item in
3703− if isLocalServer s then acc
3704− else if any acc (\a -> a == s) then acc
912+ if isLocalServer s || any acc (\a -> a == s) then acc
3705− else union [s] acc) [] items
913+ else union acc [s]) [] items
915+knownPeerServersFromPresence : [PresenceEntry] -> [Text]
916+knownPeerServersFromPresence = \presence -> collectPeers presence (\p -> p.server)
3707samePubkeyServer = \a b -> a.pubkey == b.pubkey && a.server == b.server
918samePubkeyServer = \a b -> a.pubkey == b.pubkey && a.server == b.server
3708−pubkeyServer = \e -> {pubkey: e.pubkey, server: e.server}
3710−-- Upsert items by key, keeping the fresher entry on conflict (last-write-wins by freshness).
920+-- Last-write-wins merge by (pubkey, server), keeping the entry with the larger expiresAt.
3711−-- union [e] filtered prepends (O(1)) vs union filtered [e] which copies filtered (O(|acc|)).
921+mergePresence = \existing incoming ->
3712−mergeByKey = \sameKey getFreshness initial items ->
3713 fold (\acc e ->
922 fold (\acc e ->
3714− if any acc (\a -> sameKey a e && getFreshness a >= getFreshness e)
923+ if any acc (\a -> samePubkeyServer a e && a.expiresAt >= e.expiresAt) then acc
3717− (do a <- acc; where not (sameKey a e); yield a)) initial items
3719−-- Merge presence entries by (pubkey, server), keeping the one with the latest expiresAt.
3720−-- Deterministic tiebreaker: when two entries for the same (pubkey, server) have equal
3721−-- expiresAt, prefer the one with the lexicographically smaller server name. Without a
3722−-- tiebreaker, the merge result depends on arrival order, causing presence oscillation
3723−-- when two peers gossip the same pubkey simultaneously with the same expiry.
3724−mergeByPubkeyServer = \initial items ->
3726− if any acc (\a -> samePubkeyServer a e && (a.expiresAt > e.expiresAt || (a.expiresAt == e.expiresAt && a.server <= e.server)))
3729− (do a <- acc; where not (samePubkeyServer a e); yield a)) initial items
924+ else union (do x <- acc; where not (samePubkeyServer x e); yield x) [e]) existing incoming
3731−-- Keep entries from setA that are not superseded by a newer-timestamped entry in setB.
3732−-- Deterministic tiebreaker: when timestamps are equal, the entry with the lexicographically
3733−-- smaller server name wins (consistent with mergeByPubkeyServer).
3734−resolveByTimestamp = \setA setB ->
3735− do e <- setA; where none setB (\o -> samePubkeyServer o e && (o.timestamp > e.timestamp || (o.timestamp == e.timestamp && o.server < e.server))); yield e
3737−-- Remove presence entries that have a corresponding offline event with a newer timestamp
3738−removeOffline = \presenceSet trustedOffline t ->
3739− diff presenceSet (do
3741− o <- trustedOffline
3742− where samePubkeyServer p o && min o.timestamp t > p.timestamp
3745−-- Cap presence table after gossip merge. If over capacity, only allow updates to
3746−-- existing entries and reclaim slots from expired ones for new entries.
3747−capGossipPresence = \args ->
3748− if count args.afterOffline <= maxPresenceEntries
3749− then {finalPresence: args.afterOffline, appliedOnline: args.appliedOnline, withinCapacity: True {}}
3751− let updatesOnly = existingPresenceUpdates args.trustedDeduped args.presence in
3752− let updatesOnlyMerged = mergeByPubkeyServer args.presence updatesOnly in
3753− let updatesOnlyAfterOffline = removeOffline updatesOnlyMerged args.trustedOffline args.t in
3754− let reclaimSlots = maxPresenceEntries - count updatesOnlyAfterOffline in
3755− let newEntries = newPresenceEntries args.trustedDeduped args.presence in
3756− let reclaimedEntries = takeRelation reclaimSlots newEntries in
3757− {finalPresence: union updatesOnlyAfterOffline reclaimedEntries,
3758− appliedOnline: union
3759− (appliedOnlineKeys updatesOnly args.presence)
3760− (do e <- reclaimedEntries; yield (pubkeyServer e)),
3761− withinCapacity: False {}}
3763−hasMessage : MessageIdHex -> PubkeyHex -> [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> Bool
926+-- ============================================
3764−hasMessage = \mid toKey items -> any items (\x -> x.messageId == mid && x.toKey == toKey)
927+-- Pruning
928+-- ============================================
3766−-- Validate incoming gossip events: reject local-server events, future timestamps,
3767−-- and already-expired entries. Clamp TTLs and split into online/offline buckets.
3768−-- Timestamp clamping: compute expiresAt from min(timestamp, now) instead of raw timestamp.
3769−-- A peer can send timestamp close to t + clockSkewTolerance (within tolerance), which would
3770−-- inflate effective presence lifetime by up to clockSkewTolerance ms. Clamping to now removes
3771−-- this inflation: the peer's declared TTL is honored, but the expiry clock starts from now,
3772−-- not from a future timestamp.
3773−-- Filter seenBy entries to only known peers + ourselves. Unknown entries are dropped
3774−-- to prevent gossip suppression attacks (a malicious peer injecting arbitrary server
3775−-- names into seenBy to block propagation to those servers).
3776−filterSeenBy : [Text] -> [Text] -> [Text]
3777−filterSeenBy = \seenBy knownPeers ->
3778− do s <- seenBy; where s == serverHostN || any knownPeers (\p -> p == s); yield s
3780−validGossipEvents : [GossipEvent] -> Timestamp -> {online: [ValidGossipEntry], offline: [ValidGossipEntry]}
3781−validGossipEvents = \events t ->
3782− let validate = \e ->
3783− if not (isLocalServer e.server) && e.timestamp <= t + clockSkewTolerance
3784− then let ttl = clampTtl e.ttl in
3785− let effectiveTs = min e.timestamp t in
3786− let expiresAt = effectiveTs + ttl * 1000 in
3788− then [{pubkey: e.pubkey, server: e.server, expiresAt: expiresAt, timestamp: e.timestamp, ttl: ttl}]
3792− case e.eventType of
3793− GossipOnline {} -> {online: union acc.online (validate e), offline: acc.offline}
3794− GossipOffline {} -> {online: acc.online, offline: union acc.offline (validate e)}
3795− _ -> acc) {online: [], offline: []} events
3797−-- Execute an action for each server, forking up to maxFederationConcurrency
3798−-- and processing the remainder sequentially to bound resource usage.
3799−sendToEach : [ServerName] -> (ServerName -> (a {})) -> a {}
3800−sendToEach = \servers action -> sendToEachN servers action maxFederationConcurrency
3802−sendToEachN = \servers action remaining ->
3803− case headOf servers of
3804− Nothing {} -> yield {}
3805− Just {value: server} -> do
3806− let rest = do s <- servers; where s != server; yield s
3807− -- Check global federation connection cap: fall back to sequential when at limit
3808− globalActive <- *federationActiveConnections
3809− let effectiveRemaining = if globalActive >= maxGlobalFederationConcurrency then 0 else remaining
3810− if effectiveRemaining > 0
3812− fork (action server)
3813− sendToEachN rest action (effectiveRemaining - 1)
3816− sendToEachN rest action 0
3818−-- Per-bucket presence pruning: prune a single presence bucket atomically.
3819−-- Returns expired local entries (for offline gossip), peer servers in kept entries,
3820−-- all peer servers (before pruning), and count of removed entries.
3821−prunePresenceBucketN = \b t -> atomic do
3822− bucket <- readPresenceBucket b
3823− let kept = do x <- bucket; where x.expiresAt > t; yield x
3824− let expired = do x <- bucket; where x.expiresAt <= t; yield x
3825− -- Expired local entries: only those without a surviving local presence entry for the same key
3826− -- (all entries for a pubkey live in the same bucket, so this per-bucket check is complete)
3827− let expiredLocal = do x <- expired; where isLocalServer x.server && none kept (\k -> k.pubkey == x.pubkey && isLocalServer k.server); yield x
3828− writePresenceBucket b kept
3829− yield {expiredLocal: expiredLocal, keptPeerServers: collectPeerServers kept (\p -> p.server), allPeerServers: collectPeerServers bucket (\p -> p.server), removedCount: count expired}
3831−-- Recursively prune all 16 presence buckets and aggregate results.
3832−-- Collects raw server lists from each bucket; deduplication is done once
3833−-- at the end by the caller (pruneExpired) to avoid O(n*k) per-bucket merges.
3834−prunePresenceBuckets = \b t ->
3835− if b > 15 then yield {expiredLocal: [], keptPeerServers: [], allPeerServers: [], totalRemoved: 0}
3837− r <- prunePresenceBucketN b t
3838− rest <- prunePresenceBuckets (b + 1) t
3839− yield {expiredLocal: union r.expiredLocal rest.expiredLocal,
3840− keptPeerServers: union r.keptPeerServers rest.keptPeerServers,
3841− allPeerServers: union r.allPeerServers rest.allPeerServers,
3842− totalRemoved: r.removedCount + rest.totalRemoved}
3844−-- Remove all expired entries from every collection. Returns expired local presence
3845−-- entries (for broadcasting offline gossip) and the set of peer servers known before pruning.
3846pruneExpired = \t -> do
930pruneExpired = \t -> do
3847− -- Prune presence per-bucket (16 smaller atomic blocks instead of one large one).
931+ expiredLocalKeys <- atomic do
3848− -- Each bucket is independent: all entries for a pubkey hash to the same bucket,
932+ -- challenges
3849− -- so per-bucket before/after comparison is equivalent to the global check.
933+ ch <- *challenges
3850− presenceResults <- prunePresenceBuckets 0 t
934+ set *challenges = do x <- ch; where x.expiresAt > t; yield x
3851− -- Dedup peer servers once after collecting from all 16 buckets (O(n) total
935+ -- sessions
3852− -- vs O(n*k) if deduped per-bucket during aggregation).
936+ ses <- *sessions
3853− let dedupServers = \servers -> fold (\acc s -> if any acc (\x -> x == s) then acc else union [s] acc) [] servers
937+ set *sessions = do x <- ses; where x.expiresAt > t; yield x
3854− let keptPeers = dedupServers presenceResults.keptPeerServers
938+ -- messages
3855− let allPeers = dedupServers presenceResults.allPeerServers
939+ msgs <- *messages
3856− atomic do
940+ set *messages = do m <- msgs; where m.expiresAt > t; yield m
3857− tpc <- *totalPresenceCount
941+ -- forwards
3858− set *totalPresenceCount = max 0 (tpc - presenceResults.totalRemoved)
942+ fwds <- *forwards
3859− set *knownPeerServers = keptPeers
943+ set *forwards = do f <- fwds; where f.expiresAt > t; yield f
3860− when (presenceResults.totalRemoved > 0) (set *presenceVersion = t)
944+ -- ackedIds, deliveredIds
3861− let presenceResult = {expiredLocal: presenceResults.expiredLocal, peerServers: allPeers}
945+ aids <- *ackedIds
3862− -- Prune auth state (challenges in their own block; sessions counted during transform)
946+ set *ackedIds = do a <- aids; where t - a.ackedAt < messageMaxAge; yield a
3863− atomic do
947+ dids <- *deliveredIds
3864− challenges <- *challenges
948+ set *deliveredIds = do d <- dids; where t - d.deliveredAt < messageMaxAge; yield d
3865− set *challenges = do x <- challenges; where x.expiresAt > t; yield x
949+ -- presence: remember locally-expired keys for offline gossip
3866− -- Prune sessions and count in a single pass (avoids redundant 16-bucket traversal).
950+ pres <- *presence
3867− -- pruneAndCountAllSessions applies the filter to each bucket and sums the survivors.
951+ let keptPres = do p <- pres; where p.expiresAt > t; yield p
3868− sessionCount <- pruneAndCountAllSessions (\bucket -> do x <- bucket; where x.expiresAt > t && t - x.createdAt < maxSessionLifetime; yield x)
952+ let expiredLocal = do p <- pres; where p.expiresAt <= t && isLocalServer p.server && none keptPres (\k -> k.pubkey == p.pubkey && isLocalServer k.server); yield p
3869− atomic do
953+ set *presence = keptPres
3870− set *totalSessionCount = sessionCount
954+ -- forwardFailures
3871− -- Prune messages across all 16 buckets concurrently. Each bucket prune is atomic
955+ ff <- *forwardFailures
3872− -- and touches only its own message bucket + rcBucket. The only shared write is
956+ set *forwardFailures = do f <- ff; where t - f.failedAt < 86400000; yield f
3873− -- *totalMessageCount (a single Int), so STM contention is minimal.
957+ -- activePolls (clean up stale entries beyond 3x poll timeout)
3874− -- Fork first 15 buckets; run the last one in the foreground to bound concurrency.
958+ aps <- *activePolls
3875− -- Uses per-message expiresAt instead of a global cutoff, so sender-specified TTLs
959+ set *activePolls = do p <- aps; where t - p.startedAt < pollTimeoutMs * 3; yield p
3876− -- are respected during pruning.
960+ -- pendingVerifications
3877− pruneMessageBucketsConcurrent 0 t
3878− -- Prune federation state (split into per-collection blocks to reduce lock contention
3879− -- with poll-ack paths that write to ackedIds/deliveredIds concurrently).
3880− let retainCutoff = t - messageMaxAge
3881− -- Forwards: per-bucket pruning (same pattern as acked/delivered).
3882− -- Each bucket is pruned in its own atomic block to reduce lock contention
3883− -- with sendMessageCore which writes to forward buckets on the hot path.
3884− fwdSurvivorCount <- pruneAllFwdBuckets 0 retainCutoff federationEnabled 0
3885− atomic do set *totalForwardCount = fwdSurvivorCount
3886− -- Cache forward queue stale count after pruning (forward buckets are clean now).
3887− -- Health checks read this cached value instead of scanning all 16 buckets each time.
3888− fwdStale <- countStaleForwardServers 0 t []
3889− atomic do set *cachedForwardStaleCount = fwdStale
3890− -- AckedIds: per-bucket pruning (each bucket in its own atomic block to reduce lock
3891− -- contention with poll-ack paths that write to ackedIds concurrently).
3892− pruneAllAckedBuckets 0 retainCutoff
3893− -- DeliveredIds: per-bucket pruning (same pattern as acked)
3894− pruneAllDeliveredBuckets 0 retainCutoff
3895− -- Overflow + failures: smaller collections, grouped together.
3896− -- Stale peer cleanup: servers still in knownPeerServers (have active presence) keep
3897− -- their failure records for the full maxServerDowntime (24h). Servers with no presence
3898− -- are pruned aggressively after 1h — they have no local keys to forward to and their
3899− -- failure records just inflate circuit breaker counts.
3901− forwardFailures <- *forwardFailures
3902− peers <- *knownPeerServers
3903− let isKnown = \server -> any peers (\p -> p == server)
3904− set *forwardFailures = do f <- forwardFailures; where (if isKnown f.server then t - f.failedAt < maxServerDowntime else t - f.failedAt < sessionExpiry); yield f
3905− ackOverflow <- *ackOverflow
3906− set *ackOverflow = do a <- ackOverflow; where a.ackedAt > retainCutoff; yield a
3907− -- Prune rate limiters (split into smaller atomic blocks to reduce lock contention).
3908− -- Retention is 2x windowMs because the sliding window algorithm uses prevCount from the
3909− -- previous window for interpolation. Pruning at 1x windowMs discards prevCount prematurely,
3910− -- allowing a brief 2x burst at the next window boundary — the exact problem sliding windows
3911− -- solve. The entry rotates to a new window (resetting count, storing prevCount) at 1x; the
3912− -- old prevCount is only irrelevant after 2x when the new window itself rotates.
3914− sendRates <- *sendRates
3915− set *sendRates = do r <- sendRates; where t - r.windowStart < sendRateWindowMs * 2; yield r
3916− challengeRates <- *challengeRates
3917− set *challengeRates = do r <- challengeRates; where t - r.windowStart < challengeRateWindowMs * 2; yield r
3918− revokeRates <- *revokeRates
3919− set *revokeRates = do r <- revokeRates; where t - r.windowStart < revokeRateWindowMs * 2; yield r
3920− recvRates <- *recvRates
3921− set *recvRates = do r <- recvRates; where t - r.windowStart < recvRateWindowMs * 2; yield r
3922− pairRates <- *pairRates
3923− set *pairRates = do r <- pairRates; where t - r.windowStart < pairRateWindowMs * 2; yield r
3924− -- Reset auth-tier global rate window
3925− authWS <- *authGlobalRateWindowStart
3926− when (t - authWS >= authGlobalRateWindowMs) (do
3927− set *authGlobalRateWindowStart = t
3928− set *authGlobalRateCount = 0)
3929− -- Reset health rate window
3930− healthWS <- *healthRateWindowStart
3931− when (t - healthWS >= healthRateWindowMs) (do
3932− set *healthRateWindowStart = t
3933− set *healthRateCount = 0)
3935− federationRates <- *federationRates
3936− set *federationRates = do r <- federationRates; where t - r.windowStart < federationRateWindowMs * 2; yield r
3937− federationPairRates <- *federationPairRates
3938− set *federationPairRates = do r <- federationPairRates; where t - r.windowStart < federationPairRateWindowMs * 2; yield r
3939− ipRates <- *ipRates
3940− set *ipRates = do r <- ipRates; where t - r.windowStart < ipRateWindowMs * 2; yield r
3941− lookupRates <- *lookupRates
3942− set *lookupRates = do r <- lookupRates; where t - r.windowStart < lookupRateWindowMs * 2; yield r
3943− clientWriteRates <- *clientWriteRates
3944− set *clientWriteRates = do r <- clientWriteRates; where t - r.windowStart < clientWriteRateWindowMs * 2; yield r
3945− verifyIpRates <- *verifyIpRates
3946− set *verifyIpRates = do r <- verifyIpRates; where t - r.windowStart < verifyRateWindowMs * 2; yield r
3947− uniqueKeyIpRates <- *uniqueKeyIpRates
3948− set *uniqueKeyIpRates = do r <- uniqueKeyIpRates; where t - r.windowStart < uniqueKeyIpWindowMs * 2; yield r
3950− activePolls <- *activePolls
3951− effPollTimeout <- effectivePollTimeoutMs
3952− set *activePolls = do p <- activePolls; where t - p.startedAt < effPollTimeout * 3; yield p
3953− recentGossip <- *recentGossip
3954− set *recentGossip = do r <- recentGossip; where t - r.seenAt < gossipDedupWindow; yield r
3955− -- Clean up stale in-flight entries: remove zeroed entries and reset leaked slots
3956− -- where the forked task died without calling clearFederationInFlight.
3957− -- Uses 1.25x timeout threshold so leaked slots are reclaimed promptly
3958− -- after the skip-hung-server logic (at 1x) has already taken effect.
3959− -- Tighter than the original 1.5x to reduce the window where panicked
3960− -- fetches hold federation slots hostage.
3961− inFlight <- *federationInFlight
3962− let staleThreshold = federationFetchTimeoutMs * 5 / 4
3963− let staleInFlight = do r <- inFlight; where r.count > 0 && r.firstStartedAt > 0 && t - r.firstStartedAt >= staleThreshold; yield r
3964− when (count staleInFlight > 0) (do
3965− logWarn ("pruneExpired: cleaning " ++ show (count staleInFlight) ++ " stale in-flight entries (leaked slots)")
3966− -- Per-server detail for debugging hung connections: log which peers are stuck and for how long
3967− logStaleInFlight staleInFlight t)
3968− -- Also warn about connections approaching the stale threshold (early detection)
3969− let hungThreshold = federationFetchTimeoutMs
3970− let hungInFlight = do r <- inFlight; where r.count > 0 && r.firstStartedAt > 0 && t - r.firstStartedAt >= hungThreshold && t - r.firstStartedAt < staleThreshold; yield r
3971− when (count hungInFlight > 0)
3972− (logEvent "warn" "hung_federation" ("connections approaching stale threshold: " ++ show (count hungInFlight) ++ " slots"))
3973− set *federationInFlight = do r <- inFlight; where r.count > 0 && (r.firstStartedAt == 0 || t - r.firstStartedAt < staleThreshold); yield r
3974− -- Prune stale federation replay dedup entries
3975− recentFedReqs <- *recentFederationRequests
3976− set *recentFederationRequests = do r <- recentFedReqs; where t - r.seenAt < clockSkewTolerance * 2; yield r
3977− -- Prune expired federation verification tokens
3978− pending <- *pendingVerifications
961+ pv <- *pendingVerifications
3979− set *pendingVerifications = do p <- pending; where t - p.createdAt < verificationTokenExpiry; yield p
962+ set *pendingVerifications = do p <- pv; where t - p.createdAt < verificationTokenExpiry; yield p
3980− -- Prune expired peer public key cache entries
3981− peerKeys <- *peerPublicKeys
3982− set *peerPublicKeys = do k <- peerKeys; where t - k.fetchedAt < peerKeyTtlMs; yield k
3983− -- Prune expired forward nonces (round-robin: 4 of 16 buckets per cycle)
3984− pruneNonceBucketsRoundRobin t
3985− -- Prune gossip event rate entries
3986− gossipEventRates <- *gossipEventRates
3987− set *gossipEventRates = do r <- gossipEventRates; where t - r.windowStart < gossipEventRateWindowMs * 2; yield r
3988− -- Prune stale deferred ack cleanups (older than messageMaxAge are never useful)
3989− pendingCleanups <- *pendingAckCleanups
3990− set *pendingAckCleanups = do c <- pendingCleanups; where t - c.cleanupAfter < messageMaxAge; yield c
3991− -- Prune old pending federation cancel entries (same retention as other dedup state)
3992− pendingCancels <- *pendingFederationCancels
3993− set *pendingFederationCancels = do c <- pendingCancels; where t - c.createdAt < messageMaxAge; yield c
3994− -- Prune old sender expiration notifications. Uses unackedMessageMaxAge (7 days)
963+ -- sender notifications
3995− -- instead of sessionExpiry (1 hour) so mobile clients that don't poll for days
3996− -- still receive expiration notifications on their next poll.
3997− senderExp <- *senderExpirations
964+ se <- *senderExpirations
3998− set *senderExpirations = do e <- senderExp; where t - e.expiredAt < unackedMessageMaxAge; yield e
965+ set *senderExpirations = do x <- se; where t - x.expiredAt < unackedMessageMaxAge; yield x
3999− -- Prune old sender delivery receipts (same retention as expirations)
4000− senderDel <- *senderDeliveries
966+ sd <- *senderDeliveries
4001− set *senderDeliveries = do d <- senderDel; where t - d.deliveredAt < unackedMessageMaxAge; yield d
967+ set *senderDeliveries = do x <- sd; where t - x.deliveredAt < unackedMessageMaxAge; yield x
4002− -- Prune old cancel notifications (same retention as delivery receipts)
4003− cancelNotifs <- *cancelNotifications
968+ cn <- *cancelNotifications
4004− set *cancelNotifications = do c <- cancelNotifs; where t - c.cancelledAt < unackedMessageMaxAge; yield c
969+ set *cancelNotifications = do x <- cn; where t - x.cancelledAt < unackedMessageMaxAge; yield x
4005− -- Prune stale per-sender drop counters. Without this, drop counters for senders who
970+ pfc <- *pendingFederationCancels
4006− -- disconnect permanently persist until capacity eviction pushes them out. Same retention
971+ set *pendingFederationCancels = do x <- pfc; where t - x.createdAt < messageMaxAge; yield x
4007− -- as delivery receipts since drop counters track lost receipts/expirations.
972+ yield expiredLocal
4008− ddr <- *droppedDeliveryReceipts
973+ yield expiredLocalKeys
4009− set *droppedDeliveryReceipts = do d <- ddr; where t - d.lastUpdated < unackedMessageMaxAge; yield d
4010− den <- *droppedExpirationNotifs
4011− set *droppedExpirationNotifs = do d <- den; where t - d.lastUpdated < unackedMessageMaxAge; yield d
4012− -- Reconcile global federation connection counter with actual in-flight state
4013− -- (self-heals drift from leaked slots where a forked task died without decrementing)
4014− inFlightRec <- *federationInFlight
4015− set *federationActiveConnections = fold (\acc r -> acc + r.count) 0 inFlightRec
4016− yield presenceResult
4018−-- Skip the first N items of a list (list equivalent of Text's drop).
4019−-- O(n) single pass: fold counts items and only starts accumulating after N.
4020−skipRelation = \n items ->
4021− let r = fold (\acc e ->
4022− if acc.skipped < n then {skipped: acc.skipped + 1, result: acc.result}
4023− else {skipped: acc.skipped, result: union acc.result [e]})
4024− {skipped: 0, result: []} items
4027−splitAtN = \items n ->
975+-- ============================================
4028− fold (\acc e ->
976+-- Federation gossip
4029− if acc.n < n then {n: acc.n + 1, batch: union acc.batch [e], rest: acc.rest}
977+-- ============================================
4030− else {n: acc.n, batch: acc.batch, rest: union acc.rest [e]})
4031− {n: 0, batch: [], rest: []} items
4033−forEachBatch = \items batchSize process ->
4034− if count items == 0 then yield {}
4036− let split = splitAtN items batchSize
4037− process split.batch
4038− forEachBatch split.rest batchSize process
4040−sendBatchedGossipToServer : ServerName -> [GossipEvent] -> Int -> IO {network} {}
4041−sendBatchedGossipToServer = \server allEvents hops -> do
4042− -- Check backoff before sending: skip servers that recently failed (same backoff as forwards).
4043− -- Without this, gossip to a dead peer generates unbounded log spam every refresh cycle.
4045− failures <- *forwardFailures
4046− inFlight <- *federationInFlight
4047− blocked <- *blockedPeers
4048− if not (shouldRetryServerEx server t0 failures inFlight blocked) then yield {}
4050− -- Filter out events this server has already seen (via seenBy tracking).
4051− -- Add ourselves and the target server to seenBy so downstream relays skip both.
4052− -- Cap seenBy at maxSeenByLen and filter to known peers (defense-in-depth against spoofed seenBy).
4053− knownPeersForSeen <- *knownPeerServers
4054− let unseen = do e <- allEvents; where none e.seenBy (\s -> s == server); yield {eventType: e.eventType, pubkey: e.pubkey, server: e.server, timestamp: e.timestamp, ttl: e.ttl, seenBy: filterSeenBy (takeRelation maxSeenByLen (union e.seenBy [server])) knownPeersForSeen}
4055− if count unseen == 0 then yield {}
4056− else forEachBatch unseen maxGossipEvents (\batch -> do
4058− auth <- generateFederationAuth "gossip" t
4059− corrId <- genTokenN 1
4060− result <- fetchFederation server (RecvGossip {
4061− authorization: auth,
4062− events: batch, hopsRemaining: hops, fromServer: serverHostN,
4063− requestTimestamp: t, correlationId: corrId, protocolVersion: federationProtocolVersion})
4066− logWarn ("federation: gossip to " ++ server ++ " failed: " ++ show e)
4067− recordFailure server
4068− atomic do gs <- *gossipSendFail; set *gossipSendFail = gs + 1
4070− clearFailure server
4071− atomic do gs <- *gossipSendSuccess; set *gossipSendSuccess = gs + 1)
4073−-- Sends gossip events to each peer server. Per-server seenBy filtering happens inside
4074−-- sendBatchedGossipToServer: if all events for a server are already in its seenBy list,
4075−-- the function returns immediately without making an HTTP call. Pre-filtering the target
4076−-- list here would save only function call overhead and complicate the seenBy set logic
4077−-- (seenBy is per-event, not per-batch), so we rely on the per-server early-exit instead.
4078sendBatchedGossip : [ServerName] -> [GossipEvent] -> Int -> IO {network} {}
979sendBatchedGossip : [ServerName] -> [GossipEvent] -> Int -> IO {network} {}
4079−sendBatchedGossip = \peerServers allEvents hops ->
980+sendBatchedGossip = \peers events hops ->
4080− sendToEach peerServers (\server -> sendBatchedGossipToServer server allEvents hops)
981+ case headOf peers of
4081−
982+ Nothing {} -> yield {}
4082−broadcastOfflineGossip = \t peerServers expiredLocal ->
983+ Just {value: server} -> do
4083− when (federationEnabled && count peerServers > 0 && count expiredLocal > 0) (do
984+ let rest = do s <- peers; where s != server; yield s
4084− failures <- *forwardFailures
986+ failures <- *forwardFailures
4085− if isFederationCircuitOpen failures t
987+ when (shouldRetryServer server t failures) (do
4086− then logWarn ("federation: circuit breaker open, skipping offline gossip broadcast")
988+ auth <- generateFederationAuth "gossip" t
4087− else do
989+ result <- fetch (federationUrl server) (RecvGossip {
4088− let cappedExpired = takeRelation maxPresenceEntries expiredLocal
990+ authorization: auth,
4089− when (count expiredLocal > maxPresenceEntries)
991+ events: events, hopsRemaining: hops, fromServer: serverHostN,
4090− (logWarn ("gossip: capped offline broadcast to " ++ show maxPresenceEntries ++ " entries (had " ++ show (count expiredLocal) ++ ")"))
992+ requestTimestamp: t, correlationId: "", protocolVersion: federationProtocolVersion})
4091− let gossipEvents = mergeByKey (\a b -> a.pubkey == b.pubkey) (\x -> x.timestamp) [] (offlineGossipEvents cappedExpired)
993+ case result of
4092− sendBatchedGossip peerServers gossipEvents gossipOriginHops)
994+ Err _ -> recordFailure server
4093−
995+ Ok _ -> clearFailure server)
4094−-- Build re-broadcast gossip events from validated entries. The seenBy list includes
996+ sendBatchedGossip rest events hops
4095−-- the fromServer (who sent us these events) and ourselves (serverHostN), so downstream
4096−-- peers that already have this gossip via either path won't receive it again.
4097−-- Optimization: pre-extract unique pubkeys from appliedKeys for a fast-path rejection.
4098−-- Entries whose pubkey doesn't appear in any appliedKey skip the full samePubkeyServer
4099−-- check (two-field comparison). Helps when entries contain many pubkeys not in appliedKeys.
4100−effectiveGossipEvents = \entries appliedKeys eventType seenBy ->
4101− let appliedPubkeys = fold (\acc a -> if any acc (\p -> p == a.pubkey) then acc else union [a.pubkey] acc) [] appliedKeys
4104− where any appliedPubkeys (\pk -> pk == e.pubkey)
4105− where any appliedKeys (\a -> samePubkeyServer a e)
4106− yield {eventType: eventType, pubkey: e.pubkey, server: e.server, timestamp: e.timestamp, ttl: e.ttl, seenBy: seenBy}
4108−mergeGossipPresence = \presence deduped trustedOffline fromServer t ->
4109− let trustedDeduped = trustedGossipEntries deduped presence fromServer t in
4110− let appliedOnline = appliedOnlineKeys trustedDeduped presence in
4111− let merged = mergeByPubkeyServer presence trustedDeduped in
4112− let afterOffline = removeOffline merged trustedOffline t in
4113− let appliedOffline = do p <- diff merged afterOffline; yield (pubkeyServer p) in
4114− let capResult = capGossipPresence {afterOffline: afterOffline, appliedOnline: appliedOnline, trustedDeduped: trustedDeduped, presence: presence, trustedOffline: trustedOffline, t: t} in
4115− {finalPresence: capResult.finalPresence,
4116− appliedKeys: union capResult.appliedOnline appliedOffline,
4117− gossipPeerServers: collectPeerServers capResult.finalPresence (\p -> p.server),
4118− withinCapacity: capResult.withinCapacity}
4120−-- Adaptive rate limiting: scale rate limits down when the server is under heavy load.
4121−-- Returns a scaling factor from 0 to 100 (percentage of full rate to allow).
4122−-- 100% at <=80% utilization, linearly decreasing to 10% at 100% utilization.
4123−-- Uses the highest utilization across messages, sessions, and presence as the
4124−-- bottleneck metric. 10% floor prevents complete lockout (admin can still act).
4125−adaptiveRateScale : Int -> Int -> Int -> Int
4126−adaptiveRateScale = \msgCount sessCount presCount ->
4127− let msgPct = if maxMessages > 0 then msgCount * 100 / maxMessages else 0 in
4128− let sessPct = if maxSessions > 0 then sessCount * 100 / maxSessions else 0 in
4129− let presPct = if maxPresenceEntries > 0 then presCount * 100 / maxPresenceEntries else 0 in
4130− let peak = max msgPct (max sessPct presPct) in
4131− if peak <= 80 then 100
4132− else max 10 (100 - (peak - 80) * 90 / 20)
4134−-- Apply adaptive scaling to a base rate limit. Reads cached counters (O(1), no bucket scans)
4135−-- and scales the rate proportionally. Returns at least 1 to prevent division-by-zero in callers.
4136−-- Apply adaptive scaling to a base rate limit. Reads cached scale factor (O(1), updated
4137−-- every prune cycle) instead of 3 counter reads per call. Returns at least 1 to prevent
4138−-- division-by-zero in callers.
4139−adaptiveRate : Int -> IO Int
4140−adaptiveRate = \baseRate -> do
4141− scale <- *cachedAdaptiveScale
4142− let effectiveScale = if scale <= 0 then 100 else scale
4143− yield (max 1 (baseRate * effectiveScale / 100))
4145−-- Effective rate limit readers: return runtime override if set (> 0), else compile-time default.
4146−-- All per-key and global rates are scaled by adaptiveRate under high utilization.
4147−effectiveGlobalRequestRate = do
4148− o <- *rateOverrideGlobalRequest
4149− adaptiveRate (if o > 0 then o else maxGlobalRequestRate)
4151−effectiveIpRate = do
4152− o <- *rateOverrideIpRate
4153− adaptiveRate (if o > 0 then o else maxIpRatePerIp)
4155−effectiveSendRate = do
4156− o <- *rateOverrideSendRate
4157− adaptiveRate (if o > 0 then o else maxSendRatePerKey)
4159−effectiveFederationRate = do
4160− o <- *rateOverrideFederationRate
4161− -- Federation rates are NOT adaptively scaled: throttling federation under load
4162− -- prevents ack delivery, causing origin servers to retry (amplification loop).
4163− yield (if o > 0 then o else maxFederationRatePerServer)
4165−effectiveAuthGlobalRate = do
4166− o <- *rateOverrideAuthGlobal
4167− adaptiveRate (if o > 0 then o else maxAuthGlobalRate)
4169−effectiveRecvRate = do
4170− o <- *rateOverrideRecvRate
4171− adaptiveRate (if o > 0 then o else maxRecvRatePerKey)
4173−effectiveChallengeRate = do
4174− o <- *rateOverrideChallengeRate
4175− adaptiveRate (if o > 0 then o else maxChallengeRatePerKey)
4177−effectivePairRate = do
4178− o <- *rateOverridePairRate
4179− adaptiveRate (if o > 0 then o else maxPairRatePerPair)
4181−effectiveLookupRate = do
4182− o <- *rateOverrideLookupRate
4183− adaptiveRate (if o > 0 then o else maxLookupRatePerKey)
4185−effectiveClientWriteRate = do
4186− o <- *rateOverrideClientWriteRate
4187− adaptiveRate (if o > 0 then o else maxClientWriteRatePerKey)
4189−-- Effective operational parameter readers: return runtime override if set (> 0), else compile-time default.
4190−-- These are NOT adaptively scaled (they are capacity limits, not rate limits).
4191−effectiveMaxMessagesPerRecipient = do
4192− o <- *configOverrideMaxMessagesPerRecipient
4193− yield (if o > 0 then o else maxMessagesPerRecipient)
4195−effectiveMaxGossipHops = do
4196− o <- *configOverrideMaxGossipHops
4197− yield (if o > 0 then o else maxGossipHops)
4199−effectivePollTimeoutMs = do
4200− o <- *configOverridePollTimeoutMs
4201− yield (if o > 0 then o else pollTimeoutMs)
4203−effectiveAckGracePeriod : IO Int<Ms>
4204−effectiveAckGracePeriod = do
4205− o <- *configOverrideAckGracePeriod
4206− yield (if o > 0 then o else ackGracePeriod)
4208−checkFederationRate = \server t -> atomic do
4209− federationRates <- *federationRates
4210− fedRate <- effectiveFederationRate
4211− let result = checkServerRate federationRates server fedRate federationRateWindowMs maxFederationRateEntries t
4212− set *federationRates = result.entries
4213− when result.limited (do
4214− rlf <- *rateLimitedFederation
4215− set *rateLimitedFederation = rlf + 1)
4216− yield result.limited
4218−checkGlobalRate = \t -> atomic do
4219− windowStart <- *globalRateWindowStart
4220− rateCount <- *globalRateCount
4221− prevCount <- *globalRatePrevCount
4222− effectiveRate <- effectiveGlobalRequestRate
4223− let elapsed = t - windowStart
4224− if elapsed >= globalRateWindowMs
4226− set *globalRateWindowStart = t
4227− set *globalRatePrevCount = rateCount
4228− set *globalRateCount = 1
4231− -- Sliding window: interpolate previous window's count
4232− let prevWeight = prevCount * (globalRateWindowMs - elapsed) / globalRateWindowMs
4233− if prevWeight + rateCount >= effectiveRate
4235− rlg <- *rateLimitedGlobal
4236− set *rateLimitedGlobal = rlg + 1
4239− set *globalRateCount = rateCount + 1
4242−-- Auth-tier global rate limiting (shared budget for challenge + verify + revoke)
998+broadcastOfflineGossip = \t expiredLocal -> do
4243−checkAuthGlobalRate = \t -> atomic do
999+ presence <- *presence
4244− windowStart <- *authGlobalRateWindowStart
1000+ let peers = knownPeerServersFromPresence presence
4245− rateCount <- *authGlobalRateCount
1001+ when (federationEnabled && count peers > 0 && count expiredLocal > 0) (do
4246− prevCount <- *authGlobalRatePrevCount
1002+ let events = do p <- expiredLocal; yield {eventType: GossipOffline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}
4247− authRate <- effectiveAuthGlobalRate
1003+ sendBatchedGossip peers events gossipOriginHops)
4248− let elapsed = t - windowStart
4249− if elapsed >= authGlobalRateWindowMs
4251− set *authGlobalRateWindowStart = t
4252− set *authGlobalRatePrevCount = rateCount
4253− set *authGlobalRateCount = 1
4256− let prevWeight = prevCount * (authGlobalRateWindowMs - elapsed) / authGlobalRateWindowMs
4257− if prevWeight + rateCount >= authRate
4259− rla <- *rateLimitedAuth
4260− set *rateLimitedAuth = rla + 1
4263− set *authGlobalRateCount = rateCount + 1
4266−-- Health endpoint rate limiting (separate from global rate so monitoring doesn't starve real requests)
4267−checkHealthRate = \t -> atomic do
4268− windowStart <- *healthRateWindowStart
4269− rateCount <- *healthRateCount
4270− prevCount <- *healthRatePrevCount
4271− let elapsed = t - windowStart
4272− if elapsed >= healthRateWindowMs
4274− set *healthRateWindowStart = t
4275− set *healthRatePrevCount = rateCount
4276− set *healthRateCount = 1
4279− let prevWeight = prevCount * (healthRateWindowMs - elapsed) / healthRateWindowMs
4280− if prevWeight + rateCount >= maxHealthRate
4281− then yield (True {})
4283− set *healthRateCount = rateCount + 1
4286−-- IP-based rate limiting; skips if clientIp header is empty (no reverse proxy)
4287−checkClientIpRate = \ip t ->
4288− if ip == "" then yield (False {})
4290− ipRates <- *ipRates
4291− ipRate <- effectiveIpRate
4292− let result = checkIpRate ipRates ip ipRate ipRateWindowMs maxIpRateEntries t
4293− set *ipRates = result.entries
4294− when result.limited (do
4295− rli <- *rateLimitedIp
4296− set *rateLimitedIp = rli + 1)
4297− yield result.limited
4299−-- Combined pre-auth gate: drain check, global rate, IP rate. Returns "" if all pass.
4300−-- Blocks at drainPhase >= 1 (soft drain blocks new auth; existing sessions still work).
4301−checkPreAuth = \clientIp t -> do
4303− if dp >= 1 then yield "draining"
4305− globalLimited <- checkGlobalRate t
4306− if globalLimited then yield "global_rate_limited"
4308− ipLimited <- checkClientIpRate clientIp t
4309− if ipLimited then yield "ip_rate_limited"
4312-- ============================================
1005-- ============================================
4313−-- Ed25519 Federation Signing
1006+-- Forward retries and acks
4314-- ============================================
1007-- ============================================
4315−-- When serverFederationPrivateKeyHex is configured, outbound federation requests are
4316−-- signed with Ed25519 instead of using random tokens + verify callbacks. Inbound
4317−-- requests with "Signed" auth are verified locally using the sender's cached public key.
4318−-- "Bearer" auth falls back to the existing verify callback for backward compatibility.
4320−-- GET /federation/pubkey: Return this server's Ed25519 federation public key.
4321−-- Unauthenticated. Rate-limited via health rate limiter (same as /ready).
4322−handleFederationPubkey = \respond -> do
4324− healthLimited <- checkHealthRate t
4325− if healthLimited then yield (respond {pubkey: "", ok: False {}})
4326− else yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})
4328−-- Fetch and cache a peer's Ed25519 public key for signature verification.
4329−-- Returns the hex-encoded public key, or "" if unavailable.
4330−-- Checks cache first (peerKeyTtlMs TTL), fetches from /federation/pubkey on miss.
4331−-- Enforces peerKeyRefetchCooldownMs between re-fetch attempts to prevent DoS.
4332−fetchPeerPublicKey : Text -> Timestamp -> IO {network} Text
4333−fetchPeerPublicKey = \server t -> do
4334− cached <- atomic do
4335− keys <- *peerPublicKeys
4336− yield (headOf (do k <- keys; where k.server == server; yield k))
4338− Just {value: entry} ->
4339− if t - entry.fetchedAt < peerKeyTtlMs && entry.pubkey != ""
4340− then yield entry.pubkey
4341− else if entry.failedAt > 0 && t - entry.failedAt < peerKeyRefetchCooldownMs
4343− else fetchAndCachePeerKey server t
4344− Nothing {} -> fetchAndCachePeerKey server t
4346−-- Fetch a peer's public key from /federation/pubkey and cache the result.
4347−-- On failure, caches the failure timestamp to enforce cooldown.
4348−fetchAndCachePeerKey : Text -> Timestamp -> IO {network} Text
4349−fetchAndCachePeerKey = \server t -> do
4350− result <- fetchFederation server (FederationPubkey {})
4353− logWarn ("federation: pubkey fetch from " ++ server ++ " failed: " ++ show e)
4355− keys <- *peerPublicKeys
4356− let updated = union (do k <- keys; where k.server != server; yield k) [{server: server, pubkey: "", fetchedAt: t, failedAt: t}]
4357− set *peerPublicKeys = if count updated > maxPeerPublicKeys then evictOneOldest updated (\k -> k.fetchedAt) else updated
4360− if r.ok && r.pubkey != "" then do
4362− keys <- *peerPublicKeys
4363− let updated = union (do k <- keys; where k.server != server; yield k) [{server: server, pubkey: r.pubkey, fetchedAt: t, failedAt: 0}]
4364− set *peerPublicKeys = if count updated > maxPeerPublicKeys then evictOneOldest updated (\k -> k.fetchedAt) else updated
4368− keys <- *peerPublicKeys
4369− let updated = union (do k <- keys; where k.server != server; yield k) [{server: server, pubkey: "", fetchedAt: t, failedAt: t}]
4370− set *peerPublicKeys = if count updated > maxPeerPublicKeys then evictOneOldest updated (\k -> k.fetchedAt) else updated
4373−-- Verify an inbound Ed25519 signed federation request.
4374−-- Reconstructs the signed message from (scope, requestTimestamp, fromServer),
4375−-- fetches the peer's public key (cached), and verifies the signature.
4376−-- Verify signature without nonce (backward compatible with old peers).
4377−verifyFederationSignature : Text -> Text -> Text -> Timestamp -> IO {network} Bool
4378−verifyFederationSignature = \fromServer signatureHex scope requestTimestamp -> do
4380− pubkeyHex <- fetchPeerPublicKey fromServer t
4381− if pubkeyHex == "" then yield (False {})
4383− let message = textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer)
4384− yield (verify (bytesFromHex pubkeyHex) message (bytesFromHex signatureHex))
4386−-- Verify signature with nonce (new format: prevents replay of same-millisecond requests).
1009+retryPendingForwards : IO {network} {}
4387−verifyFederationSignatureWithNonce : Text -> Text -> Text -> Text -> Timestamp -> IO {network} Bool
1010+retryPendingForwards = do
4388−verifyFederationSignatureWithNonce = \fromServer signatureHex nonce scope requestTimestamp -> do
4389 t <- now
1011 t <- now
4390− pubkeyHex <- fetchPeerPublicKey fromServer t
1012+ fwds <- *forwards
4391− if pubkeyHex == "" then yield (False {})
1013+ failures <- *forwardFailures
4393− let message = textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer ++ "|" ++ nonce)
4394− yield (verify (bytesFromHex pubkeyHex) message (bytesFromHex signatureHex))
4396−-- Federation auth wrapper. Intentionally does NOT call checkPreAuth because:
4397−-- (a) Soft drain (phase 1) blocks new client auth but must not block federation —
4398−-- peers need to deliver messages and acks to existing recipients during drain.
4399−-- (b) Federation has its own rate limiting via checkFederationRate (per-server)
4400−-- and checkGlobalRate (shared with client routes), so IP rate limiting is redundant.
4401−-- (c) Federation routes don't carry a ClientIp header (peer-to-peer, not client-facing),
4402−-- so IP-based rate limiting doesn't apply.
4403−withFederationAuth = \authorization t respond fromServer scope requestTimestamp precondition clearOnAuth action -> do
4404− -- Check blocklist and allowlist before spending resources on verification
4405 blocked <- *blockedPeers
1014 blocked <- *blockedPeers
4406− if isBlockedPeer fromServer blocked
1015+ -- Group by server
4407− then do
1016+ let servers = collectPeers fwds (\f -> f.toServer)
4408− logWarn ("federation: blocked peer " ++ fromServer ++ " rejected")
1017+ let eligibleServers = do s <- servers; where shouldRetryServer s t failures && not (isBlockedPeer s blocked); yield s
4409− yield (respond {ok: False {}, error: "blocked", retryAfterMs: 0})
1018+ retryServerForwards eligibleServers fwds
4411− allowed <- *allowedPeers
4412− if not (isAllowedByAllowlist fromServer allowed)
4414− logWarn ("federation: peer " ++ fromServer ++ " not in allowlist, rejected")
4415− yield (respond {ok: False {}, error: "not_allowed", retryAfterMs: 0})
4417− -- Dispatch on auth scheme: "Signed " = Ed25519 signature, "Bearer " = verify callback
4418− -- New format "Signed <sig>:<nonce>" includes a random nonce to prevent replay of
4419− -- same-millisecond requests. Old format "Signed <sig>" (no colon) is backward compatible.
4420− verified <- if take 7 authorization == "Signed "
4422− let payload = drop 7 authorization
4423− if payload == "" || tooLong payload (maxSignatureLen + 25)
4424− then yield (False {})
4426− let parts = splitOnColon payload in
4427− if parts.after != ""
4428− then verifyFederationSignatureWithNonce fromServer parts.before parts.after scope requestTimestamp
4429− else verifyFederationSignature fromServer payload scope requestTimestamp
4430− else verifyFederationCallback fromServer authorization scope
4432− then yield (respond {ok: False {}, error: "unauthorized", retryAfterMs: 0})
4433− -- Replay protection: reject requests with timestamps too far from local clock.
4434− -- requestTimestamp == 0 means the peer doesn't support this field yet (accept).
4435− else if requestTimestamp > 0 && (requestTimestamp > t + clockSkewTolerance || requestTimestamp < t - clockSkewTolerance)
4437− logWarn ("federation: clock skew " ++ show (t - requestTimestamp) ++ "ms from " ++ fromServer ++ ", rejecting (tolerance: " ++ show clockSkewTolerance ++ "ms)")
4438− yield (respond {ok: False {}, error: "clock_skew", retryAfterMs: 0})
4439− else if not precondition
4440− then yield (respond {ok: False {}, error: "invalid_request", retryAfterMs: 0})
4442− -- Replay detection: reject duplicate (server, timestamp) pairs within the skew window
4443− replayDetected <- if requestTimestamp > 0
4445− recent <- *recentFederationRequests
4446− let isDup = any recent (\r -> r.server == fromServer && r.timestamp == requestTimestamp)
4447− if isDup then yield (True {})
4449− let cleaned = do r <- recent; where t - r.seenAt < clockSkewTolerance * 2; yield r
4450− let updated = union cleaned [{server: fromServer, timestamp: requestTimestamp, seenAt: t}]
4451− set *recentFederationRequests = if count updated > maxRecentFederationRequests then evictOneOldest updated (\r -> r.seenAt) else updated
4453− else yield (False {})
4456− logWarn ("federation: replay detected from " ++ fromServer ++ " (timestamp: " ++ show requestTimestamp ++ ")")
4457− yield (respond {ok: False {}, error: "replay_detected", retryAfterMs: 0})
4459− globalLimited <- checkGlobalRate t
4462− effGlobal <- effectiveGlobalRequestRate
4463− logEvent "warn" "rate_limited_federation_global" ("peer=" ++ fromServer ++ " limit=" ++ show effGlobal)
4464− -- retryAfterMs provides a structured hint so peers can make smarter retry decisions.
4465− -- Error string still includes the value for backward compatibility with pre-v14 peers.
4466− yield (respond {ok: False {}, error: "rate_limited", retryAfterMs: globalRateWindowMs})
4468− rateLimited <- checkFederationRate fromServer t
4471− effFed <- effectiveFederationRate
4472− logEvent "warn" "rate_limited_federation_per_server" ("peer=" ++ fromServer ++ " limit=" ++ show effFed)
4473− yield (respond {ok: False {}, error: "rate_limited", retryAfterMs: federationRateWindowMs})
4475− when clearOnAuth (clearFailure fromServer)
4478−withSessionAuth = \authorization t clientIp onUnauth onAuth -> do
4479− case extractToken authorization of
4480− Nothing {} -> onUnauth
4481− Just {value: token} -> do
4482− let bucket = tokenBucket token
4483− sessions <- readSessionBucket bucket
4484− case authenticateSession sessions token t of
4485− Unauthorized {} -> onUnauth
4486− Authorized {pubkey, ip} ->
4487− if not (matchIp clientIp ip)
4490− -- Sliding window: refresh session expiry when within half of sessionExpiry.
4491− -- Avoids rewriting the session bucket on every authenticated request (reduces
4492− -- write contention on hot paths like rapid ack/delete sequences). Sessions
4493− -- still stay alive as long as the client is active within any sessionExpiry window.
4494− -- Uses pubkey pre-filter to find the matching session's expiry without safeCompare,
4495− -- since pubkey was already verified by authenticateSession above.
4496− let needsRefresh = any sessions (\s -> s.pubkey == pubkey && s.expiresAt - t < sessionExpiry / 3)
4498− -- Pubkey pre-filter on safeCompare: only runs constant-time comparison for
4499− -- sessions matching the authenticated pubkey (typically 1-2 per bucket),
4500− -- skipping the expensive safeCompare for all unrelated sessions (~600/bucket).
4501− (writeSessionBucket bucket (do s <- sessions; yield (if s.pubkey == pubkey && s.expiresAt - t < sessionExpiry / 3 && safeCompare s.token token then {token: s.token, pubkey: s.pubkey, expiresAt: t + sessionExpiry, ip: s.ip, createdAt: s.createdAt} else s)))
4504−-- Check if a pubkey has no remaining sessions and, if so, clean up local presence.
4505−-- Must be called inside an atomic block after the session has already been removed.
4506−-- Returns {pubkey, gossipOffline, peerServers} indicating whether offline gossip is needed.
4507−checkLastSessionCleanup : PubkeyHex -> Timestamp -> IO {pubkey: PubkeyHex, gossipOffline: Bool, peerServers: [Text]}
4508−checkLastSessionCleanup = \pubkey t -> do
4509− hasRemaining <- hasSessionForKey pubkey 0
4510− if not hasRemaining
4512− let pb = pubkeyBucket pubkey
4513− presenceBkt <- readPresenceBucket pb
4514− let kept = do p <- presenceBkt; where p.pubkey != pubkey || not (isLocalServer p.server); yield p
4515− writePresenceBucket pb kept
4516− let removedCount = count presenceBkt - count kept
4517− tpc <- *totalPresenceCount
4518− set *totalPresenceCount = max 0 (tpc - removedCount)
4519− set *presenceVersion = t
4520− peerServers <- *knownPeerServers
4521− yield {pubkey: pubkey, gossipOffline: True {}, peerServers: peerServers}
4522− else yield {pubkey: pubkey, gossipOffline: False {}, peerServers: []}
4524−-- If the last session was removed, gossip offline to federation peers.
4525−-- Skips gossip during drain (handleDrain already broadcast offline for all local keys).
4526−gossipOfflineIfLastSession : {pubkey: PubkeyHex, gossipOffline: Bool, peerServers: [Text]} -> Text -> IO {network} ()
4527−gossipOfflineIfLastSession = \r label -> do
4528− when r.gossipOffline (do
4532− then logInfo (label ++ ": last session for " ++ r.pubkey ++ " (drain active, skipping redundant offline gossip)")
4534− logInfo (label ++ ": last session for " ++ r.pubkey ++ ", gossiping offline")
4535− when (federationEnabled && count r.peerServers > 0)
4536− (fork (sendBatchedGossip r.peerServers [{eventType: GossipOffline {}, pubkey: r.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}] gossipOriginHops)))
4538−removeForward = \mid srv toKey -> atomic do
4539− let b = pubkeyBucket toKey
4540− fwdBkt <- readFwdBucket b
4541− let kept = forwardsExcluding fwdBkt srv [mid]
4542− writeFwdBucket b kept
4543− let removed = count fwdBkt - count kept
4544− when (removed > 0) (do
4545− tfc <- *totalForwardCount
4546− set *totalForwardCount = max 0 (tfc - removed))
4548−-- Reclaim origin messages after federation ack confirms delivery.
4549−-- Batched by message bucket: all entries for the same bucket are processed in one
4550−-- atomic block (reduces transaction overhead compared to one-per-entry).
4551−ackCleanupForwards = \entries t ->
4552− let bucketIds = uniqueBucketsFor entries (\e -> e.toKey) in
4553− ackCleanupByBucket bucketIds entries t
4555−-- Two-pass ack cleanup: first filter entries to those eligible for cleanup,
4556−-- then single-pass filter messages. Avoids O(entries * messages) nested scan
4557−-- from the fold-with-shrinking-accumulator pattern.
4558−ackCleanupByBucket = \bucketIds entries t -> case headOf bucketIds of
4559− Nothing {} -> yield {}
4560− Just {value: b} -> do
4561− let remainingBuckets = do x <- bucketIds; where x != b; yield x
4562− let bucketEntries = do e <- entries; where pubkeyBucket e.toKey == b; yield e
4564− -- All entries in this batch share pubkeyBucket == b, so only that presence bucket is needed
4565− bucketPresence <- readPresenceBucket b
4566− fwdBkt <- readFwdBucket b
4567− msgs <- readMessageBucket b
4568− tc <- *totalMessageCount
4569− rc <- readRcBucket b
4570− -- Phase 1: filter to entries eligible for cleanup (no local presence, no pending forwards)
4571− let eligible = do rf <- bucketEntries
4572− where not (any bucketPresence (\p -> p.pubkey == rf.toKey && isLocalServer p.server && p.expiresAt > t))
4573− where not (any fwdBkt (\f -> f.messageId == rf.messageId && f.toKey == rf.toKey))
4575− -- Phase 2: single pass over messages — remove those matching any eligible entry past grace period
4576− effGrace <- effectiveAckGracePeriod
4577− let shouldRemove = \m -> any eligible (\rf -> m.messageId == rf.messageId && m.toKey == rf.toKey && t - m.receivedAt >= effGrace)
4578− let cleanMsgs = do m <- msgs; where not (shouldRemove m); yield m
4579− let removedMsgs = do m <- msgs; where shouldRemove m; yield m
4580− let removedCount = count removedMsgs
4581− let newRc = fold (\accRc m -> adjustRecipientCount accRc m.toKey (0 - 1)) rc removedMsgs
4582− writeMessageBucket b cleanMsgs
4583− set *totalMessageCount = max 0 (tc - removedCount)
4584− writeRcBucket b newRc
4585− ackCleanupByBucket remainingBuckets entries t
4588−pow2 = \n -> if n <= 0 then 1 else 2 * pow2 (n - 1)
4590−-- Exponential backoff: base * 2^(failures-1), capped at retryBackoffMax
4591−retryBackoff : Int -> Int<Ms>
4592−retryBackoff = \failures ->
4593− min retryBackoffMax (retryBackoffBase * pow2 (max 0 (failures - 1)))
4595−-- Exponential backoff with deterministic per-server jitter to prevent thundering herd
4596−-- when multiple peers recover simultaneously. Jitter derived from first hex char of
4597−-- server name (0-15) adds 0-47% of base delay, spreading retries across the window.
4598−retryBackoffFor : Int -> Text -> Int<Ms>
4599−retryBackoffFor = \failures server ->
4600− let base = retryBackoff failures in
4601− let jitterFrac = hexCharIndex (take 1 server) in
4602− min retryBackoffMax (base + base * jitterFrac / 32)
4604−shouldRetryServer : Text -> Timestamp -> [ForwardFailure] -> Bool
4605−shouldRetryServer = \server t failures ->
4606− case headOf (do f <- failures; where f.server == server; yield f) of
4607− Nothing {} -> True {}
4608− Just {value: f} -> t - f.firstFailedAt < maxServerDowntime && t - f.failedAt >= retryBackoffFor f.failures server
4610−-- Extended retry check: also skip servers with hung in-flight requests or on the blocklist
4611−shouldRetryServerEx : Text -> Timestamp -> [ForwardFailure] -> [FederationInFlightEntry] -> [Text] -> Bool
4612−shouldRetryServerEx = \server t failures inFlight blocked ->
4613− not (isBlockedPeer server blocked) && shouldRetryServer server t failures && not (hasHungFederationRequest server t inFlight)
4615−-- Global circuit breaker: returns True when too many peers are failing simultaneously,
4616−-- indicating a likely local network issue rather than individual peer problems.
4617−-- When tripped, all outbound federation is paused until the next prune cycle.
4618−isFederationCircuitOpen : [ForwardFailure] -> Timestamp -> Bool
4619−isFederationCircuitOpen = \failures t ->
4620− federationCircuitBreakerThreshold > 0
4621− && count (do f <- failures; where t - f.firstFailedAt < maxServerDowntime; yield f) >= federationCircuitBreakerThreshold
4623−recordFailure = \server -> do
1020+retryServerForwards = \servers fwds ->
4624− t <- now
1021+ case headOf servers of
4625− -- Random jitter (0-25% of base backoff) prevents synchronized retries when
4626− -- multiple operations to the same peer fail in quick succession. Shifts failedAt
4627− -- forward, delaying when shouldRetryServer allows the next attempt. Combined with
4628− -- the deterministic per-server spread in retryBackoffFor, this breaks both
4629− -- cross-server and same-server retry correlation (thundering herd).
4630− jitter <- randomInt (retryBackoffBase / 4)
4632− failures <- *forwardFailures
4633− let existing = headOf (do f <- failures; where f.server == server; yield f)
4634− let updated = case existing of
4635− Nothing {} -> union failures [{server: server, failedAt: t + jitter, failures: 1, firstFailedAt: t}]
4636− Just {value: f} -> union (do x <- failures; where x.server != server; yield x) [{server: server, failedAt: t + jitter, failures: min (f.failures + 1) 10, firstFailedAt: f.firstFailedAt}]
4637− set *forwardFailures = if count updated > maxForwardFailures then evictOneOldest updated (\x -> x.failedAt) else updated
4639−clearFailure = \server -> do
4642− failures <- *forwardFailures
4643− set *forwardFailures = do f <- failures; where f.server != server; yield f
4644− set *lastFederationSuccessAt = t
4646−-- Atomically increment a forward entry's retry count; drop if maxForwardRetries exceeded
4647−incrementForwardRetries = \messageId toServer toKey -> atomic do
4648− let b = pubkeyBucket toKey
4649− fwdBkt <- readFwdBucket b
4650− let shouldDrop = any fwdBkt (\f -> f.messageId == messageId && f.toServer == toServer && f.retries + 1 >= maxForwardRetries)
4653− writeFwdBucket b (do f <- fwdBkt; where not (f.messageId == messageId && f.toServer == toServer); yield f)
4654− tfc <- *totalForwardCount
4655− set *totalForwardCount = max 0 (tfc - 1)
4656− logKV "warn" "federation_forward_dropped" ["messageId=" ++ messageId, "server=" ++ toServer, "retries=" ++ show maxForwardRetries]
4657− else writeFwdBucket b (do f <- fwdBkt; yield (if f.messageId == messageId && f.toServer == toServer then {messageId: f.messageId, toServer: f.toServer, createdAt: f.createdAt, toKey: f.toKey, encryptedBlob: f.encryptedBlob, timestamp: f.timestamp, originServer: f.originServer, retries: f.retries + 1, expiresAt: f.expiresAt, priority: f.priority, senderKey: f.senderKey} else f))
4659−-- Retry forwards for a server using batch forward (1 HTTP round-trip per batch of maxBatchSize).
4660−-- Falls back to single forward if the peer returns an HTTP-level error (old peer without batch support).
4661−retryForwardsForServer : [ForwardEntry] -> Int -> IO {network} {}
4662−retryForwardsForServer = \entries remaining ->
4663− if remaining <= 0 || count entries == 0 then yield {}
4666− -- Pre-filter expired forwards: avoids wasting bandwidth on messages the recipient
4667− -- would discard. Expired entries are cleaned up by the next prune cycle.
4668− let liveEntries = do f <- entries; where f.expiresAt > t; yield f
4669− let expiredCount = count entries - count liveEntries
4670− when (expiredCount > 0) (logInfo ("federation: skipped " ++ show expiredCount ++ " expired forwards during retry"))
4671− if count liveEntries == 0 then yield {}
4673− let server = case headOf liveEntries of Just {value: f} -> f.toServer; Nothing {} -> ""
4674− forEachBatch liveEntries maxBatchSize (\batch -> do
4676− auth <- generateFederationAuth "forward-batch" t
4677− corrId <- genTokenN 1
4678− let batchPayload = do f <- batch; yield {toKey: f.toKey, encryptedBlob: f.encryptedBlob, timestamp: f.timestamp, originServer: f.originServer, messageId: f.messageId, expiresAt: f.expiresAt, priority: f.priority}
4679− result <- fetchFederation server (FederationBatchForward {
4680− forwards: batchPayload, fromServer: serverHostN,
4681− requestTimestamp: t, authorization: auth, correlationId: corrId, protocolVersion: federationProtocolVersion})
4684− logKV "warn" "federation_batch_forward_failed" ["server=" ++ server, "batchSize=" ++ show (count batch), "error=" ++ show e]
4685− recordFailure server
4686− -- HTTP-level failure (connectivity, timeout): don't increment per-message retries.
4687− -- The messages weren't rejected — the server was unreachable. Server backoff
4688− -- (via recordFailure) handles retry scheduling. Per-message retries are only
4689− -- burned on application-level rejections (Ok with per-message results).
4692− if response.ok then do
4693− clearFailure server
4694− -- Process per-message results: remove succeeded, increment retries for failed
4695− retryForwardsBatchResults batch response.results server
4697− logKV "warn" "federation_batch_forward_rejected" ["server=" ++ server, "error=" ++ response.error]
4698− -- Application-level batch rejection (old peer, invalid request): fall back to
4699− -- sequential single-message forwards instead of burning retries. The peer likely
4700− -- doesn't support /federation/forward-batch, so individual forwards may succeed.
4701− retryForwardsSingle batch server)
4703−-- Increment retry counts for all entries in a failed batch
4704−retryForwardsBatchIncrement = \batch server ->
4705− case headOf batch of
4706 Nothing {} -> yield {}
1022 Nothing {} -> yield {}
4707− Just {value: f} -> do
1023+ Just {value: server} -> do
4708− let rest = do x <- batch; where x.messageId != f.messageId; yield x
1024+ let rest = do s <- servers; where s != server; yield s
4709− incrementForwardRetries f.messageId server f.toKey
1025+ let serverFwds = takeRelation maxBatchSize (do f <- fwds; where f.toServer == server; yield f)
4710− retryForwardsBatchIncrement rest server
1026+ sendForwardsToServer serverFwds server
4711−
1027+ retryServerForwards rest fwds
4712−-- Fallback: send forwards individually when batch forward is rejected (old peer).
1028+
4713−-- Each message gets its own auth token and HTTP round-trip. On success, removes the
1029+sendForwardsToServer = \fwds server ->
4714−-- forward entry; on failure, increments retries (same as batch per-message failure).
1030+ case headOf fwds of
4715−retryForwardsSingle = \batch server ->
4716− case headOf batch of
4717 Nothing {} -> yield {}
1031 Nothing {} -> yield {}
4718 Just {value: f} -> do
1032 Just {value: f} -> do
4719− let rest = do x <- batch; where x.messageId != f.messageId; yield x
1033+ let rest = do x <- fwds; where x.messageId != f.messageId; yield x
4720 t <- now
1034 t <- now
4721 auth <- generateFederationAuth ("forward:" ++ f.messageId) t
1035 auth <- generateFederationAuth ("forward:" ++ f.messageId) t
4722− corrId <- genTokenN 1
1036+ result <- fetch (federationUrl server) (ForwardMessage {
4723− result <- fetchFederation server (ForwardMessage {
4724 toKey: f.toKey, encryptedBlob: f.encryptedBlob,
1037 toKey: f.toKey, encryptedBlob: f.encryptedBlob,
4725 timestamp: f.timestamp, originServer: f.originServer, messageId: f.messageId,
1038 timestamp: f.timestamp, originServer: f.originServer, messageId: f.messageId,
4726 fromServer: serverHostN, requestTimestamp: t,
1039 fromServer: serverHostN, requestTimestamp: t,
4727− authorization: auth, correlationId: corrId,
1040+ authorization: auth, correlationId: "",
4728 expiresAt: f.expiresAt, priority: f.priority, protocolVersion: federationProtocolVersion})
1041 expiresAt: f.expiresAt, priority: f.priority, protocolVersion: federationProtocolVersion})
4729 case result of
1042 case result of
4730− Err e -> do
1043+ Err _ -> do
4731− logKV "warn" "federation_single_forward_failed" ["server=" ++ server, "messageId=" ++ f.messageId, "error=" ++ show e]
4732 recordFailure server
1044 recordFailure server
4733− Ok response ->
1045+ atomic do
4734− if response.ok then do
1046+ cur <- *forwards
4735− removeForward f.messageId server f.toKey
1047+ set *forwards = do x <- cur; yield (if x.messageId == f.messageId && x.toServer == server then {messageId: x.messageId, toServer: x.toServer, createdAt: x.createdAt, toKey: x.toKey, encryptedBlob: x.encryptedBlob, timestamp: x.timestamp, originServer: x.originServer, retries: x.retries + 1, expiresAt: x.expiresAt, priority: x.priority, senderKey: x.senderKey} else x)
4736− clearFailure server
1048+ cur2 <- *forwards
4737− else incrementForwardRetries f.messageId server f.toKey
1049+ set *forwards = do x <- cur2; where not (x.messageId == f.messageId && x.toServer == server && x.retries >= maxForwardRetries); yield x
4738− retryForwardsSingle rest server
1050+ Ok r ->
4740−-- Process per-message results from a batch forward response
4741−retryForwardsBatchResults = \batch results server ->
4742− case headOf batch of
4743− Nothing {} -> yield {}
4744− Just {value: f} -> do
4745− let rest = do x <- batch; where x.messageId != f.messageId; yield x
4746− let msgResult = headOf (do r <- results; where r.messageId == f.messageId; yield r)
4749 if r.ok then do
1051 if r.ok then do
4750− removeForward f.messageId server f.toKey
1052+ clearFailure server
4751− retryForwardsBatchResults rest results server
1053+ atomic do
4752− else do
1054+ cur <- *forwards
4753− incrementForwardRetries f.messageId server f.toKey
1055+ set *forwards = do x <- cur; where not (x.messageId == f.messageId && x.toServer == server); yield x
4754− retryForwardsBatchResults rest results server
1056+ else atomic do
4755− Nothing {} -> do
1057+ cur <- *forwards
4756− -- No result for this message (shouldn't happen) — increment retry
1058+ set *forwards = do x <- cur; yield (if x.messageId == f.messageId && x.toServer == server then {messageId: x.messageId, toServer: x.toServer, createdAt: x.createdAt, toKey: x.toKey, encryptedBlob: x.encryptedBlob, timestamp: x.timestamp, originServer: x.originServer, retries: x.retries + 1, expiresAt: x.expiresAt, priority: x.priority, senderKey: x.senderKey} else x)
4757− incrementForwardRetries f.messageId server f.toKey
1059+ sendForwardsToServer rest server
4758− retryForwardsBatchResults rest results server
1060+
4759−
1061+sendAcksAndClean : [AckedEntry] -> IO {network} {}
4760−-- Collect forwards from all 16 buckets, but only for eligible servers.
4761−-- Reads one bucket at a time to avoid materializing all forwards simultaneously.
4762−collectEligibleForwards : Int -> [Text] -> IO [ForwardEntry]
4763−collectEligibleForwards = \b eligibleServers ->
4764− if b > 15 then yield []
4766− bucket <- readFwdBucket b
4767− let eligible = do f <- bucket; where any eligibleServers (\s -> s == f.toServer); yield f
4768− rest <- collectEligibleForwards (b + 1) eligibleServers
4769− yield (unionNE eligible rest)
4771−-- Retry all pending forwards, respecting per-server backoff. Skips servers that failed recently.
4772−-- Circuit breaker: skips entirely when too many peers are failing (likely local network issue).
4773−-- Per-bucket: reads forward buckets one at a time, collecting only entries for eligible servers,
4774−-- instead of materializing all forwards into memory via readAllForwards.
4775−-- Half-open circuit breaker probe: when the circuit is open, pick the peer with the
4776−-- oldest failure and send a lightweight gossip probe. If it succeeds, clear the failure
4777−-- record and re-evaluate the circuit. This allows faster recovery than waiting for
4778−-- maxServerDowntime to expire on each peer independently.
4779−circuitBreakerProbe : [ForwardFailure] -> Timestamp -> IO {network} ()
4780−circuitBreakerProbe = \failures t -> do
4781− -- Pick the peer whose last failure is oldest (most likely to have recovered)
4782− let activeFailures = do f <- failures; where t - f.firstFailedAt < maxServerDowntime; yield f
4783− case minBy activeFailures (\f -> f.failedAt) of
4784− Nothing {} -> yield {}
4785− Just {value: candidate} -> do
4786− logInfo ("federation: circuit breaker half-open probe to " ++ candidate.server)
4788− auth <- generateFederationAuth "gossip" probeStart
4789− result <- fetchFederation candidate.server (RecvGossip {
4790− authorization: auth,
4791− events: [], hopsRemaining: 1, fromServer: serverHostN,
4792− requestTimestamp: probeStart, correlationId: "", protocolVersion: federationProtocolVersion})
4794− Err e -> logWarn ("federation: half-open probe to " ++ candidate.server ++ " failed: " ++ show e)
4796− logInfo ("federation: half-open probe to " ++ candidate.server ++ " succeeded, clearing failure")
4797− clearFailure candidate.server
4799−retryPendingForwardsFromBuckets : IO {network} {}
4800−retryPendingForwardsFromBuckets = do
4802− failures <- *forwardFailures
4803− if isFederationCircuitOpen failures t
4805− logWarn ("federation: circuit breaker open (" ++ show (count failures) ++ " peers failing), skipping forward retries")
4806− logEvent "warn" "circuit_breaker_open" (show (count failures) ++ " peers failing")
4807− -- Half-open: probe one peer to detect recovery
4808− circuitBreakerProbe failures t
4810− inFlight <- *federationInFlight
4811− blocked <- *blockedPeers
4812− -- Discover servers with pending forwards per-bucket (reuses computeForwardStats which
4813− -- reads one bucket at a time), then filter to eligible servers before reading entries.
4814− fwdStats <- computeForwardStats 0 t
4815− let allServers = do sc <- fwdStats.serverCounts; yield sc.server
4816− let eligibleServers = do s <- allServers; where shouldRetryServerEx s t failures inFlight blocked; yield s
4817− if count eligibleServers == 0 then yield {}
4819− -- Read only entries for eligible servers (per-bucket, streaming)
4820− eligibleForwards <- collectEligibleForwards 0 eligibleServers
4821− -- Ramp-up for recovering peers: limit forwards per server based on recent failure history.
4822− -- A server with N prior failures gets min(maxBatchSize * 2^(clearCycles), all) forwards per cycle,
4823− -- where clearCycles = time since last failure / prune interval. This prevents overwhelming
4824− -- a just-recovered peer with thousands of queued forwards in a single burst.
4825− let rampUpLimit = \server ->
4826− case headOf (do f <- failures; where f.server == server; yield f) of
4827− Nothing {} -> maxForwardsPerServer -- no failure record: full speed
4829− let cyclesSinceFailure = (t - f.failedAt) / backgroundPruneInterval in
4830− min maxForwardsPerServer (maxBatchSize * pow2 (min 10 cyclesSinceFailure))
4831− -- Apply per-server ramp-up: cap entries per server
4832− let rampedForwards = fold (\acc server ->
4833− let serverFwds = do f <- eligibleForwards; where f.toServer == server; yield f
4834− in let limit = rampUpLimit server
4835− in union acc (takeRelation limit serverFwds)) [] eligibleServers
4836− -- Prioritize forwards for recipients with active polls (currently online).
4837− -- These keys will receive the message sooner, improving delivery latency.
4838− -- Forwards for offline keys are retried after online-key forwards complete.
4839− activePolls <- *activePolls
4840− let onlineForwards = do f <- rampedForwards; where any activePolls (\p -> p.pubkey == f.toKey); yield f
4841− let offlineForwards = do f <- rampedForwards; where none activePolls (\p -> p.pubkey == f.toKey); yield f
4842− -- Sort by effective priority descending (higher priority first) within each group.
4843− -- Penalty by retry count: messages with many retries are deprioritized so fresh
4844− -- messages aren't blocked behind likely-failing ones. A fresh priority-5 (score -5)
4845− -- beats a retry-6 priority-5 (score 1).
4846− let sortedOnline = sortBy (\f -> 0 - f.priority + f.retries) onlineForwards
4847− let sortedOffline = sortBy (\f -> 0 - f.priority + f.retries) offlineForwards
4848− let prioritizedForwards = union sortedOnline sortedOffline
4849− -- Prioritize servers that have online-key forwards first
4850− let onlineServers = collectPeerServers onlineForwards (\x -> x.toServer)
4851− let offlineOnlyServers = do s <- eligibleServers; where none onlineServers (\os -> os == s); yield s
4852− let prioritizedServers = union onlineServers offlineOnlyServers
4853− sendForwardsPartitioned prioritizedForwards prioritizedServers maxForwardRetriesPerServer
4855−-- When a remote key comes online, create forward entries for queued messages and send them
4856−forwardQueuedMessages = \targets t -> do
4857− newForwards <- atomic do
4858− -- Read only the forward buckets needed for target pubkeys (not all 16).
4859− -- All entries for a pubkey hash to the same bucket, so dedup is per-bucket complete.
4860− let neededFwdBuckets = uniqueBucketsFor targets (\target -> target.pubkey)
4861− forwards <- readSelectedFwdBuckets neededFwdBuckets
4862− -- Read only the presence buckets needed for target pubkeys (not all 16)
4863− let targetPresenceBuckets = uniqueBucketsFor targets (\target -> target.pubkey)
4864− relevantPresence <- readSelectedPresenceBuckets targetPresenceBuckets
4865− let localOnline = localOnlineKeys relevantPresence t
4866− let remoteTargets = remoteOnlyTargets targets localOnline
4867− -- Read only the message buckets containing target pubkeys (not all 16)
4868− let neededBuckets = uniqueBucketsFor remoteTargets (\target -> target.pubkey)
4869− relevantMessages <- readSelectedBuckets neededBuckets
4870− let candidates = forwardCandidates remoteTargets relevantMessages forwards t
4871− totalFwdCount <- *totalForwardCount
4872− -- Per-key, per-server, and per-sender-per-key caps: filter candidates to respect all limits.
4873− -- Per-sender cap prevents a single sender from monopolizing a recipient's forward queue.
4874− let perKeyCapped = fold (\acc c ->
4875− let existingForKey = count (do f <- forwards; where f.toKey == c.toKey; yield f)
4876− + count (do a <- acc; where a.toKey == c.toKey; yield a)
4877− in let existingForServer = count (do f <- forwards; where f.toServer == c.toServer; yield f)
4878− + count (do a <- acc; where a.toServer == c.toServer; yield a)
4879− in let existingForSenderKey = if c.senderKey != "" then count (do f <- forwards; where f.senderKey == c.senderKey && f.toKey == c.toKey; yield f) + count (do a <- acc; where a.senderKey == c.senderKey && a.toKey == c.toKey; yield a) else 0
4880− in if existingForKey >= maxForwardsPerKey || existingForServer >= maxForwardsPerServer || (c.senderKey != "" && existingForSenderKey >= maxForwardsPerSenderPerKey) then acc else union acc [c]) [] candidates
4881− let capped = takeRelation (maxForwardsEntries - totalFwdCount) perKeyCapped
4882− -- Write back only the affected forward buckets (not all 16)
4883− let combined = union forwards capped
4884− writeSelectedFwdBuckets neededFwdBuckets combined
4885− set *totalForwardCount = totalFwdCount + count capped
4887− let servers = collectPeerServers newForwards (\x -> x.toServer)
4888− failures <- *forwardFailures
4889− if isFederationCircuitOpen failures t
4890− then logWarn ("federation: circuit breaker open, skipping queued message forwarding")
4892− inFlight <- *federationInFlight
4893− blocked <- *blockedPeers
4894− let eligibleServers = do s <- servers; where shouldRetryServerEx s t failures inFlight blocked; yield s
4895− let eligibleForwards = do f <- newForwards; where any eligibleServers (\s -> s == f.toServer); yield f
4896− sendForwardsPartitioned eligibleForwards eligibleServers maxForwardRetriesPerServer
4898−fetchFederationAck = \origin messageIds -> do
4900− auth <- generateFederationAuth "ack" t
4901− corrId <- genTokenN 1
4902− fetchFederation origin (FederationAck {
4903− authorization: auth,
4904− messageIds: messageIds,
4905− originServer: origin, fromServer: serverHostN,
4906− requestTimestamp: t, correlationId: corrId, protocolVersion: federationProtocolVersion})
4908−-- Per-bucket ack retry increment: scans only the buckets containing entries from the batch.
4909−-- Each bucket is processed in its own atomic block to reduce lock contention.
4910−-- Drops entries exceeding maxAckRetries to deliveredIds. Returns total dropped count.
4911−incrementAckRetriesPerBucket = \bucketIds server batch droppedAcc ->
4912− case headOf bucketIds of
4913− Nothing {} -> yield droppedAcc
4914− Just {value: b} -> do
4915− let remainingBuckets = do x <- bucketIds; where x != b; yield x
4916− bucketDropped <- atomic do
4917− bucket <- readAckedBucket b
4918− let isTarget = \a -> a.originServer == server && hasMessage a.messageId a.toKey batch
4919− let toDrop = do a <- bucket; where isTarget a && a.retries + 1 >= maxAckRetries; yield a
4920− let dropCount = count toDrop
4921− writeAckedBucket b (do a <- bucket
4922− where not (isTarget a && a.retries + 1 >= maxAckRetries)
4923− yield (if isTarget a then {messageId: a.messageId, toKey: a.toKey, ackedAt: a.ackedAt, originServer: a.originServer, retries: a.retries + 1} else a))
4924− when (dropCount > 0) (do
4925− delivBkt <- readDelivBucket b
4926− let newDelivered = do d <- toDrop; yield {messageId: d.messageId, toKey: d.toKey, deliveredAt: d.ackedAt}
4927− let combined = union delivBkt newDelivered
4928− writeDelivBucket b (if count combined > maxDeliveredIds then (evictSmallest combined (count combined - maxDeliveredIds) (\d -> d.deliveredAt)).kept else combined))
4930− incrementAckRetriesPerBucket remainingBuckets server batch (droppedAcc + bucketDropped)
4932−-- Per-bucket ack removal on success: only rewrites buckets containing matched entries.
4933−removeAckedPerBucket = \bucketIds server batch ->
4934− case headOf bucketIds of
4935− Nothing {} -> yield {}
4936− Just {value: b} -> do
4937− let remainingBuckets = do x <- bucketIds; where x != b; yield x
4939− bucket <- readAckedBucket b
4940− writeAckedBucket b (do a <- bucket; where not (a.originServer == server && hasMessage a.messageId a.toKey batch); yield a)
4941− removeAckedPerBucket remainingBuckets server batch
4943−sendBatchedAcksToServer : [{messageId: MessageIdHex, toKey: PubkeyHex, originServer: ServerName, | a}] -> ServerName -> IO {network} {}
4944−sendBatchedAcksToServer = \serverAcks server ->
4945− forEachBatch serverAcks maxMessageIds (\batch -> do
4946− result <- fetchFederationAck server (do a <- batch; yield a.messageId)
4949− logWarn ("federation: ack to " ++ server ++ " failed: " ++ show e)
4950− recordFailure server
4951− -- Increment retry counters per-bucket; drop entries exceeding maxAckRetries to deliveredIds.
4952− -- Only touches buckets containing entries from this batch (vs readAllAcked scanning all 16).
4953− let affectedBuckets = uniqueBucketsFor batch (\a -> a.toKey)
4954− dropped <- incrementAckRetriesPerBucket affectedBuckets server batch 0
4956− (logWarn ("federation: dropped " ++ show dropped ++ " ack entries to " ++ server ++ " after " ++ show maxAckRetries ++ " retries"))
4958− clearFailure server
4959− -- Remove acked entries per-bucket (vs readAllAcked/writeAllAcked repartitioning all 16)
4960− let affectedBuckets = uniqueBucketsFor batch (\a -> a.toKey)
4961− removeAckedPerBucket affectedBuckets server batch)
4963−-- Send delivery acknowledgments back to origin servers and remove acked entries on success
4964−sendAcksAndClean : [{messageId: MessageIdHex, toKey: PubkeyHex, originServer: ServerName, | a}] -> IO {network} {}
4965sendAcksAndClean = \pendingAcks ->
1062sendAcksAndClean = \pendingAcks ->
4966 if count pendingAcks == 0 then yield {}
1063 if count pendingAcks == 0 then yield {}
4968− let servers = collectPeerServers pendingAcks (\a -> a.originServer)
1065+ let servers = collectPeers pendingAcks (\a -> a.originServer)
4969− t <- now
1066+ sendAcksToEach servers pendingAcks
4970− failures <- *forwardFailures
1067+
4971− if isFederationCircuitOpen failures t
1068+sendAcksToEach = \servers acks ->
4972− then logWarn ("federation: circuit breaker open, skipping ack retries")
1069+ case headOf servers of
4973− else do
1070+ Nothing {} -> yield {}
4974− inFlight <- *federationInFlight
1071+ Just {value: server} -> do
4975− blocked <- *blockedPeers
1072+ let rest = do s <- servers; where s != server; yield s
4976− let eligibleServers = do s <- servers; where shouldRetryServerEx s t failures inFlight blocked; yield s
1073+ let serverAcks = do a <- acks; where a.originServer == server; yield a
4977− sendToEach eligibleServers (\server ->
1074+ let mids = do a <- serverAcks; yield a.messageId
4978− sendBatchedAcksToServer (acksForServer pendingAcks server) server)
1075+ t <- now
4979−
1076+ auth <- generateFederationAuth "ack" t
4980−-- Retry sending acks that were evicted from ackedIds due to capacity limits.
1077+ result <- fetch (federationUrl server) (FederationAck {
4981−-- On failure, re-insert into ackedIds or overflow buffer; overflow entries eventually
1078+ authorization: auth,
4982−-- move to deliveredIds (terminal dedup state) if the buffer is also full.
1079+ messageIds: mids, originServer: server, fromServer: serverHostN,
4983−retryEvictedAcks = \evictedEntries pendingAcks ->
1080+ requestTimestamp: t, correlationId: "", protocolVersion: federationProtocolVersion})
4984− let evictedToRetry = retriableEvictedAcks evictedEntries pendingAcks
4986− let evictedOriginServers = collectPeerServers evictedToRetry (\a -> a.originServer)
4987− sendToEach evictedOriginServers (\server -> do
4988− fetchResult <- fetchFederationAck server (do a <- acksForServer evictedToRetry server; yield a.messageId)
4989− case fetchResult of
4991− logWarn ("federation: evicted ack to " ++ server ++ " failed: " ++ show e)
4992− overflow <- atomic do
4993− ackedIds <- readAllAcked
4994− let reinsert = do a <- acksForServer evictedToRetry server; yield {messageId: a.messageId, toKey: a.toKey, ackedAt: a.ackedAt, originServer: a.originServer, retries: a.retries + 1}
4995− let combined = union ackedIds reinsert
4996− let excess = count combined - maxAckedIds
4998− then do writeAllAcked combined; yield []
5000− let eviction = evictSmallest combined (max 0 excess) (\a -> a.ackedAt)
5001− writeAllAcked eviction.kept
5002− yield eviction.evicted
5003− when (count overflow > 0) (do
5004− dropped <- atomic do
5005− ackOverflow <- *ackOverflow
5006− let updated = union ackOverflow overflow
5007− let overflowExcess = count updated - maxAckOverflow
5008− if overflowExcess <= 0
5009− then do set *ackOverflow = updated; yield 0
5011− let overflowEviction = evictSmallest updated (max 0 overflowExcess) (\a -> a.ackedAt)
5012− set *ackOverflow = overflowEviction.kept
5013− deliveredIds <- readAllDelivered
5014− let newDelivered = do a <- overflowEviction.evicted; yield {messageId: a.messageId, toKey: a.toKey, deliveredAt: a.ackedAt}
5015− let combinedDelivered = union deliveredIds newDelivered
5016− let deliveredExcess = count combinedDelivered - maxDeliveredIds
5017− writeAllDelivered (if deliveredExcess <= 0 then combinedDelivered
5018− else (evictSmallest combinedDelivered (max 0 deliveredExcess) (\d -> d.deliveredAt)).kept)
5019− when (deliveredExcess > 0)
5020− (logWarn ("ackMessages: deliveredIds at capacity (" ++ show maxDeliveredIds ++ "), " ++ show deliveredExcess ++ " oldest dedup entries permanently removed for " ++ server))
5021− yield overflowExcess
5023− (logWarn ("ackMessages: overflow at capacity (" ++ show maxAckOverflow ++ "), " ++ show dropped ++ " ack entries moved to delivered set for " ++ server)))
5026−-- Retry acks sitting in the overflow buffer (last chance before they become deliveredIds)
5027−retryOverflowAcks = \overflow -> do
5028− let servers = collectPeerServers overflow (\a -> a.originServer)
5030− failures <- *forwardFailures
5031− if isFederationCircuitOpen failures t
5032− then logWarn ("federation: circuit breaker open, skipping overflow ack retries")
5034− inFlight <- *federationInFlight
5035− blocked <- *blockedPeers
5036− let eligibleServers = do s <- servers; where shouldRetryServerEx s t failures inFlight blocked; yield s
5037− sendToEach eligibleServers (\server ->
5038− forEachBatch (acksForServer overflow server) maxMessageIds (\batch -> do
5039− result <- fetchFederationAck server (do a <- batch; yield a.messageId)
5040 case result of
1081 case result of
5041− Err e -> do
1082+ Err _ -> recordFailure server
5042− logWarn ("federation: overflow ack to " ++ server ++ " failed: " ++ show e)
5043− recordFailure server
5044− -- Increment retry counters in overflow; drop entries exceeding maxAckRetries to deliveredIds
5045− dropped <- atomic do
5046− ackOverflow <- *ackOverflow
5047− let isTarget = \a -> a.originServer == server && hasMessage a.messageId a.toKey batch
5048− let toDrop = do a <- ackOverflow; where isTarget a && a.retries + 1 >= maxAckRetries; yield a
5049− let dropCount = count toDrop
5050− set *ackOverflow = do a <- ackOverflow
5051− where not (isTarget a && a.retries + 1 >= maxAckRetries)
5052− yield (if isTarget a then {messageId: a.messageId, toKey: a.toKey, ackedAt: a.ackedAt, originServer: a.originServer, retries: a.retries + 1} else a)
5053− when (dropCount > 0) (do
5054− deliveredIds <- readAllDelivered
5055− let newDelivered = do d <- toDrop; yield {messageId: d.messageId, toKey: d.toKey, deliveredAt: d.ackedAt}
5056− let combined = union deliveredIds newDelivered
5057− writeAllDelivered (if count combined > maxDeliveredIds then (evictSmallest combined (count combined - maxDeliveredIds) (\d -> d.deliveredAt)).kept else combined))
5060− (logWarn ("federation: dropped " ++ show dropped ++ " overflow ack entries to " ++ server ++ " after " ++ show maxAckRetries ++ " retries"))
5061 Ok _ -> do
1083 Ok _ -> do
5062 clearFailure server
1084 clearFailure server
5063 atomic do
1085 atomic do
5064− ackOverflow <- *ackOverflow
1086+ cur <- *ackedIds
5065− set *ackOverflow = do a <- ackOverflow; where not (a.originServer == server && hasMessage a.messageId a.toKey batch); yield a))
1087+ set *ackedIds = do a <- cur; where not (a.originServer == server && any mids (\m -> m == a.messageId)); yield a
5066−
1088+ sendAcksToEach rest acks
5067−-- Queue a single failed cancel for retry during the next prune cycle.
1089+
5068−queuePendingCancel = \messageId toKey server t -> atomic do
1090+-- Forward queued messages to a server when a remote key comes online.
5069− pcs <- *pendingFederationCancels
1091+forwardQueuedToServer = \pubkey server t -> atomic do
5070− -- Dedup: don't queue if already pending for the same (messageId, toKey, server)
1092+ msgs <- *messages
5071− let isDup = any pcs (\c -> c.messageId == messageId && c.toKey == toKey && c.toServer == server)
1093+ fwds <- *forwards
5072− when (not isDup) (do
1094+ let candidates = do
5073− let updated = union pcs [{messageId: messageId, toKey: toKey, toServer: server, createdAt: t, retries: 0}]
1095+ m <- msgs
5074− set *pendingFederationCancels = if count updated > maxPendingCancels
1096+ where m.toKey == pubkey
5075− then evictOneOldest updated (\c -> c.createdAt)
1097+ where none fwds (\f -> f.messageId == m.messageId && f.toServer == server)
5076− else updated)
1098+ let origin = if m.originServer == "" then serverHostN else m.originServer
5077−
1099+ yield {messageId: m.messageId, toServer: server, createdAt: t, toKey: m.toKey, encryptedBlob: m.encryptedBlob, timestamp: m.timestamp, originServer: origin, retries: 0, expiresAt: m.expiresAt, priority: m.priority, senderKey: m.senderKey}
5078−-- Queue multiple failed cancels for retry (batch cancel failure).
1100+ let capped = takeRelation maxForwardsPerServer candidates
5079−queuePendingCancels = \cancels server t ->
1101+ set *forwards = capList (union fwds capped) maxForwardsEntries (\f -> f.createdAt)
5080− case headOf cancels of
5081− Nothing {} -> yield {}
5082− Just {value: c} -> do
5083− let rest = do x <- cancels; where x.messageId != c.messageId || x.toKey != c.toKey; yield x
5084− queuePendingCancel c.messageId c.toKey server t
5085− queuePendingCancels rest server t
5087−-- Retry pending federation cancels. Called during the prune cycle.
5088−-- Groups cancels by server and sends batch cancels, respecting backoff.
5089−retryPendingCancels : IO {network} {}
5090−retryPendingCancels = do
5092− pending <- *pendingFederationCancels
5093− if count pending == 0 then yield {}
5095− failures <- *forwardFailures
5096− if isFederationCircuitOpen failures t
5097− then logWarn "federation: circuit breaker open, skipping cancel retries"
5099− inFlight <- *federationInFlight
5100− blocked <- *blockedPeers
5101− let servers = collectPeerServers pending (\c -> c.toServer)
5102− let eligibleServers = do s <- servers; where shouldRetryServerEx s t failures inFlight blocked; yield s
5103− sendToEach eligibleServers (\server -> do
5104− let serverCancels = do c <- pending; where c.toServer == server; yield c
5105− forEachBatch serverCancels maxBatchSize (\batch -> do
5107− auth <- generateFederationAuth "cancel-batch" cancelT
5108− corrId <- genTokenN 1
5109− let payload = do c <- batch; yield {messageId: c.messageId, toKey: c.toKey}
5110− result <- fetchFederation server (FederationBatchCancel {
5111− cancels: payload, fromServer: serverHostN,
5112− requestTimestamp: cancelT, correlationId: corrId,
5113− authorization: auth, protocolVersion: federationProtocolVersion})
5116− logWarn ("federation: cancel retry to " ++ server ++ " failed: " ++ show e)
5117− recordFailure server
5118− incrementCancelRetries batch server
5121− clearFailure server
5122− removePendingCancels batch server
5124− logWarn ("federation: cancel retry to " ++ server ++ " rejected: " ++ r.error)
5125− incrementCancelRetries batch server))
5127−-- Increment retry counters for failed cancel entries; drop entries exceeding maxCancelRetries.
5128−incrementCancelRetries = \batch server -> atomic do
5129− pcs <- *pendingFederationCancels
5130− let isTarget = \c -> c.toServer == server && any batch (\b -> b.messageId == c.messageId && c.toKey == b.toKey)
5131− let toDrop = do c <- pcs; where isTarget c && c.retries + 1 >= maxCancelRetries; yield c
5132− when (count toDrop > 0)
5133− (logWarn ("federation: dropped " ++ show (count toDrop) ++ " cancel entries to " ++ server ++ " after " ++ show maxCancelRetries ++ " retries"))
5134− set *pendingFederationCancels = do c <- pcs
5135− where not (isTarget c && c.retries + 1 >= maxCancelRetries)
5136− yield (if isTarget c then {messageId: c.messageId, toKey: c.toKey, toServer: c.toServer, createdAt: c.createdAt, retries: c.retries + 1} else c)
5138−-- Remove successfully delivered cancel entries.
5139−removePendingCancels = \batch server -> atomic do
5140− pcs <- *pendingFederationCancels
5141− set *pendingFederationCancels = do c <- pcs; where not (c.toServer == server && any batch (\b -> b.messageId == c.messageId && c.toKey == b.toKey)); yield c
5143−-- Wait for all in-flight federation requests to complete or timeout.
5144−-- Uses STM retry instead of busy-wait: blocks until *federationInFlight changes
5145−-- (when clearFederationInFlight writes) or *drainTimedOut is set by the timeout fork.
5146−-- This avoids the 1-second polling loop and wakes immediately when work completes.
5147−waitForInFlightDrain = \deadline -> do
5149− let remaining = deadline - t
5150− atomic do set *drainTimedOut = False {}
5151− -- Fork a timer that sets the timeout signal after the deadline
5153− when (remaining > 0) (sleep remaining)
5154− atomic do set *drainTimedOut = True {})
5155− -- Block until either all in-flight complete or timeout fires
5157− timedOut <- *drainTimedOut
5158− if timedOut then yield {}
5160− inFlight <- *federationInFlight
5161− let activeCount = fold (\acc r -> acc + r.count) 0 inFlight
5162− if activeCount <= 0 then yield {}
5164− timedOut <- *drainTimedOut
5166− logWarn "drain: timed out waiting for in-flight federation tasks"
5168− inFlight <- *federationInFlight
5169− let hungSlots = do r <- inFlight; where r.count > 0; yield r
5170− when (count hungSlots > 0) (logStaleInFlight hungSlots t2))
5172−-- Full maintenance cycle: prune expired state, retry pending forwards and acks,
5173−-- retry overflow acks, broadcast offline gossip, and refresh presence for local keys
5174−-- nearing expiry. Called by both the background task and the /maintenance/prune endpoint.
5175−pruneAndRetry = \t -> do
5177− set *lastPrunedAt = t
5178− pr <- pruneExpired t
5179− -- Warn if forward nonces are near capacity (non-expired eviction creates a replay window).
5180− -- Operators should increase maxForwardNonces or investigate high message volume.
5181− nonceCount <- countAllNonces 0
5182− when (nonceCount * 10 >= maxForwardNonces * 9)
5183− (logWarn ("forward nonces at " ++ show (nonceCount * 100 / maxForwardNonces) ++ "% capacity (" ++ show nonceCount ++ "/" ++ show maxForwardNonces ++ ") — non-expired eviction may create replay windows, consider increasing maxForwardNonces"))
5184− -- Capacity warnings at 75%: structured log events for monitoring pipelines.
5185− -- Fires before the 90% health check threshold, giving operators early warning.
5186− capacityCounts <- atomic do
5187− tmc <- *totalMessageCount
5188− sc <- *totalSessionCount
5189− pc <- *totalPresenceCount
5190− fc <- *totalForwardCount
5191− -- Update cached adaptive rate scale (avoids 3 reads per rate check on hot path)
5192− set *cachedAdaptiveScale = adaptiveRateScale tmc sc pc
5193− yield {messages: tmc, sessions: sc, presence: pc, forwards: fc}
5194− when (capacityCounts.messages * 4 >= maxMessages * 3)
5195− (logEvent "warn" "capacity_warning" ("messages at " ++ show (capacityCounts.messages * 100 / maxMessages) ++ "% (" ++ show capacityCounts.messages ++ "/" ++ show maxMessages ++ ")"))
5196− when (capacityCounts.sessions * 4 >= maxSessions * 3)
5197− (logEvent "warn" "capacity_warning" ("sessions at " ++ show (capacityCounts.sessions * 100 / maxSessions) ++ "% (" ++ show capacityCounts.sessions ++ "/" ++ show maxSessions ++ ")"))
5198− when (capacityCounts.presence * 4 >= maxPresenceEntries * 3)
5199− (logEvent "warn" "capacity_warning" ("presence at " ++ show (capacityCounts.presence * 100 / maxPresenceEntries) ++ "% (" ++ show capacityCounts.presence ++ "/" ++ show maxPresenceEntries ++ ")"))
5200− when (capacityCounts.forwards * 4 >= maxForwardsEntries * 3)
5201− (logEvent "warn" "capacity_warning" ("forwards at " ++ show (capacityCounts.forwards * 100 / maxForwardsEntries) ++ "% (" ++ show capacityCounts.forwards ++ "/" ++ show maxForwardsEntries ++ ")"))
5202− -- Counter reconciliation: presence/session/forward counters reconciled every Nth cycle
5203− -- (lightReconciliationInterval). Between cycles, cached counters are trusted — drift
5204− -- from concurrent operations is typically small and self-corrects.
5206− let isLightReconcCycle = pc > 0 && (pc - (pc / lightReconciliationInterval) * lightReconciliationInterval) == 0
5207− when isLightReconcCycle (do
5208− presDrift <- atomic do
5209− actual <- countAllPresence
5210− stored <- *totalPresenceCount
5211− set *totalPresenceCount = actual
5212− yield (actual - stored)
5213− sessDrift <- atomic do
5214− actual <- countAllSessions
5215− stored <- *totalSessionCount
5216− set *totalSessionCount = actual
5217− yield (actual - stored)
5218− fwdDrift <- atomic do
5219− actual <- countAllForwards 0
5220− stored <- *totalForwardCount
5221− set *totalForwardCount = actual
5222− yield (actual - stored)
5223− when (presDrift != 0 || sessDrift != 0 || fwdDrift != 0)
5224− (logInfo ("reconciliation: corrected drift — presence: " ++ show presDrift ++ ", sessions: " ++ show sessDrift ++ ", forwards: " ++ show fwdDrift)))
5225− -- Active request counter reconciliation: detect leaked counters from panicked handlers.
5226− -- Knot lacks try-finally, so if serveInner panics, the activeRequests decrement is skipped.
5227− -- If no request has completed in 3x pollTimeoutMs (the longest a request should take)
5228− -- but activeRequests > 0, the counter has leaked. Reset to 0 and log the recovery.
5229− arqLeak <- atomic do
5230− arq <- *activeRequests
5232− lastCompleted <- *lastRequestCompletedAt
5233− if lastCompleted > 0 && t - lastCompleted > pollTimeoutMs * 3
5235− set *activeRequests = 0
5240− (logWarn ("reconciliation: reset leaked activeRequests counter (was " ++ show arqLeak ++ ")"))
5241− -- Message reconciliation: cheap check first (sum rcBucket .count fields vs totalMessageCount).
5242− -- Full scan only when drift exceeds threshold or every Nth cycle.
5243− -- Small drifts from concurrent bucket pruning self-correct; only trigger the expensive
5244− -- full scan when drift is significant (> reconciliationDriftThreshold) or periodic.
5245− let isFullCycle = pc > 0 && (pc - (pc / reconciliationFullCycleInterval) * reconciliationFullCycleInterval) == 0
5246− cheapMsgDrift <- atomic do
5247− rcTotal <- sumRcBucketTotals 0
5248− stored <- *totalMessageCount
5249− yield (rcTotal - stored)
5250− let absDrift = if cheapMsgDrift < 0 then 0 - cheapMsgDrift else cheapMsgDrift
5251− if absDrift > reconciliationDriftThreshold || isFullCycle
5253− msgDrift <- reconcileMessageCountsDelta
5254− when (msgDrift != 0)
5255− (logInfo ("reconciliation: corrected message drift: " ++ show msgDrift))
5256− else when (cheapMsgDrift != 0) (atomic do
5257− -- Small drift: correct totalMessageCount directly from rcBucket totals
5258− -- without the full per-bucket rebuild (O(16 bucket scans) vs O(all messages))
5259− rcTotal <- sumRcBucketTotals 0
5260− set *totalMessageCount = rcTotal)
5261− ackState <- atomic do
5262− ackedIds2 <- readAllAcked
5263− let pendingAcks = do a <- ackedIds2; where not (isLocalServer a.originServer); yield a
5264− ackOverflow <- *ackOverflow
5265− let pendingOverflow = do a <- ackOverflow; where not (isLocalServer a.originServer); yield a
5266− yield {pendingAcks: pendingAcks, pendingOverflow: pendingOverflow}
5267− refreshResult <- atomic do
5268− lastRefresh <- *lastPresenceRefresh
5269− let shouldRefresh = federationEnabled && t - lastRefresh >= presenceRefreshInterval
5270− -- Early return: skip expensive reads on ~9/10 prune cycles
5271− if not shouldRefresh then yield {extendedActive: [], nearExpiryActive: [], refreshPeers: [], shouldRefresh: False {}}
5273− -- Round-robin: scan 4 of 16 presence buckets per refresh cycle.
5274− -- Spreads the gossip traffic across 4 refresh intervals instead of
5275− -- scanning all 16 buckets every cycle.
5276− group <- *presenceRefreshGroup
5277− let startBucket = (group * 4) - ((group * 4) / 16) * 16
5278− let endBucket = min 15 (startBucket + 3)
5279− set *presenceRefreshGroup = if group >= 3 then 0 else group + 1
5280− localNearExpiry <- findNearExpiryPresence startBucket endBucket t
5281− if count localNearExpiry == 0 then do
5282− knownPeers <- *knownPeerServers
5283− set *lastPresenceRefresh = t
5284− yield {extendedActive: [], nearExpiryActive: [], refreshPeers: knownPeers, shouldRefresh: True {}}
5286− -- Check per-key session existence (avoids materializing all 16 session buckets)
5287− let nearExpiryPubkeys = fold (\acc p -> if any acc (\a -> a == p.pubkey) then acc else union [p.pubkey] acc) [] localNearExpiry
5288− activeKeys <- filterActiveSessionKeys nearExpiryPubkeys t
5289− let toExtend = do p <- localNearExpiry; where any activeKeys (\k -> k == p.pubkey); yield p
5290− let notExtended = do p <- localNearExpiry; where none activeKeys (\k -> k == p.pubkey); yield p
5291− when (count toExtend > 0) (do
5292− -- Only write to the affected presence buckets (not all 16)
5293− let affectedBuckets = uniqueBucketsFor toExtend (\e -> e.pubkey)
5294− affectedPresence <- readSelectedPresenceBuckets affectedBuckets
5295− let updatedPresence = do pp <- affectedPresence; yield (if any toExtend (\e -> e.pubkey == pp.pubkey && isLocalServer pp.server) then {pubkey: pp.pubkey, server: pp.server, expiresAt: t + sessionExpiry, timestamp: t} else pp)
5296− writeSelectedPresenceBuckets affectedBuckets updatedPresence
5297− set *presenceVersion = t)
5298− knownPeers <- *knownPeerServers
5299− set *lastPresenceRefresh = t
5300− yield {extendedActive: toExtend, nearExpiryActive: notExtended, refreshPeers: knownPeers, shouldRefresh: True {}}
5301− -- Reset federation latency metrics periodically for windowed averages (prevents
5302− -- lifetime-cumulative average from masking current conditions)
5304− resetAt <- *federationLatencyResetAt
5305− when (t - resetAt >= federationLatencyWindowMs) (do
5306− set *federationLatencyTotal = 0
5307− set *federationLatencyCount = 0
5308− set *federationLatencyMax = 0
5309− set *federationLatencyBucket0 = 0
5310− set *federationLatencyBucket1 = 0
5311− set *federationLatencyBucket2 = 0
5312− set *federationLatencyBucket3 = 0
5313− set *slowVerifyCount = 0
5314− set *verifyFailCount = 0
5315− -- Reset rate-limit rejection counters (windowed with federation latency metrics)
5316− set *rateLimitedGlobal = 0
5317− set *rateLimitedIp = 0
5318− set *rateLimitedAuth = 0
5319− set *rateLimitedPerKey = 0
5320− set *rateLimitedFederation = 0
5321− -- Prune expired verify cache entries
5322− cache <- *verificationCache
5323− set *verificationCache = do c <- cache; where t - c.verifiedAt < verificationCacheMaxMs; yield c
5324− -- Reset per-peer latency tracking with global window
5325− set *peerLatencies = []
5326− -- Reset gossip send metrics (windowed with federation metrics)
5327− set *gossipSendSuccess = 0
5328− set *gossipSendFail = 0
5329− -- Reset client operation latency metrics (windowed with federation metrics)
5330− set *clientPollLatencyTotal = 0
5331− set *clientPollLatencyCount = 0
5332− set *clientPollLatencyMax = 0
5333− set *clientSendLatencyTotal = 0
5334− set *clientSendLatencyCount = 0
5335− set *clientSendLatencyMax = 0
5336− -- Reset client latency histogram buckets
5337− set *clientPollLatencyBucket0 = 0
5338− set *clientPollLatencyBucket1 = 0
5339− set *clientPollLatencyBucket2 = 0
5340− set *clientPollLatencyBucket3 = 0
5341− set *clientSendLatencyBucket0 = 0
5342− set *clientSendLatencyBucket1 = 0
5343− set *clientSendLatencyBucket2 = 0
5344− set *clientSendLatencyBucket3 = 0
5345− -- Reset auth latency metrics
5346− set *clientAuthLatencyTotal = 0
5347− set *clientAuthLatencyCount = 0
5348− set *clientAuthLatencyMax = 0
5349− -- Reset cancel metrics (windowed with other metrics)
5350− set *clientCancelCount = 0
5351− set *federationCancelCount = 0
5352− -- Reset nonce eviction counter (windowed with other metrics)
5353− set *nonceEvictionCount = 0
5354− set *federationLatencyResetAt = t)
5355− -- Process deferred ack cleanups: reclaim origin messages whose grace period has elapsed.
5356− -- These were queued by handleFederationAck instead of fork+sleep.
5357− readyCleanups <- atomic do
5358− cleanups <- *pendingAckCleanups
5359− let ready = do c <- cleanups; where t >= c.cleanupAfter; yield c
5360− let remaining = do c <- cleanups; where t < c.cleanupAfter; yield c
5361− set *pendingAckCleanups = remaining
5363− when (count readyCleanups > 0) (ackCleanupForwards readyCleanups t)
5364− let result = {pendingAcks: ackState.pendingAcks, pendingOverflow: ackState.pendingOverflow, extendedActive: refreshResult.extendedActive, nearExpiryActive: refreshResult.nearExpiryActive, refreshPeers: refreshResult.refreshPeers, shouldRefresh: refreshResult.shouldRefresh}
5365− -- Fork federation I/O phases independently so a failure in one doesn't block others.
5366− -- Previously a single fork ran gossip -> forwards -> acks -> cancels sequentially,
5367− -- meaning a panic in forward retries would skip ack and cancel retries entirely.
5368− fork (broadcastOfflineGossip t pr.peerServers pr.expiredLocal)
5369− when federationEnabled (do
5370− fork retryPendingForwardsFromBuckets
5372− -- Coalesce regular and overflow acks: merge into a single send pass so acks to
5373− -- the same origin server share HTTP round-trips instead of two separate send cycles.
5374− let coalescedAcks = union result.pendingAcks result.pendingOverflow
5375− sendAcksAndClean coalescedAcks)
5376− fork retryPendingCancels)
5377− -- Only gossip extended sessions; keys nearing expiry without active sessions will naturally
5378− -- trigger offline gossip when they expire (avoids wasted federation traffic)
5379− when result.shouldRefresh (do
5380− let refreshEvents = do p <- result.extendedActive; yield {eventType: GossipOnline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: clampTtl (sessionExpiry / 1000), seenBy: [serverHostN]}
5381− when (count result.refreshPeers > 0 && count refreshEvents > 0)
5382− (fork (sendBatchedGossip result.refreshPeers refreshEvents gossipOriginHops)))
5383− -- Update cached health state so /health returns fresh data even when rate-limited.
5384− -- This runs every prune cycle (~30s), keeping the cache within one interval of reality.
5385− computeAndCacheHealth t
5388−-- Map a single hex character to its integer value (0-15).
5389−-- Handles both lowercase and uppercase hex to prevent hot-bucket skew from
5390−-- federation peers or clients that send uppercase pubkeys.
5391−-- Clamped to 0-15 by callers (pubkeyBucket, tokenBucket) as a safety net.
5392−hexCharIndex : Text -> Int
5393−hexCharIndex = \c ->
5394− if c == "0" then 0 else if c == "1" then 1 else if c == "2" then 2 else if c == "3" then 3
5395− else if c == "4" then 4 else if c == "5" then 5 else if c == "6" then 6 else if c == "7" then 7
5396− else if c == "8" then 8 else if c == "9" then 9
5397− else if c == "a" || c == "A" then 10 else if c == "b" || c == "B" then 11
5398− else if c == "c" || c == "C" then 12 else if c == "d" || c == "D" then 13
5399− else if c == "e" || c == "E" then 14 else 15
5401−-- Map pubkey to one of 16 signal buckets based on first hex digit.
5402−-- This partitions the signal space so storing a message for one pubkey
5403−-- only wakes polls in the same bucket, not all active polls.
5404−-- Defensive clamp ensures an invalid first char never indexes out of bounds
5405−pubkeyBucket : PubkeyHex -> Int
5406−pubkeyBucket = \pubkey -> clamp 0 15 (hexCharIndex (take 1 pubkey))
5408−-- Update the signal timestamp for a pubkey's bucket, waking any blocked polls in that bucket
5409−signalMessageForKey = \pubkey ts ->
5410− let b = pubkeyBucket pubkey in
5411− if b == 0 then set *messageSignal0 = ts
5412− else if b == 1 then set *messageSignal1 = ts
5413− else if b == 2 then set *messageSignal2 = ts
5414− else if b == 3 then set *messageSignal3 = ts
5415− else if b == 4 then set *messageSignal4 = ts
5416− else if b == 5 then set *messageSignal5 = ts
5417− else if b == 6 then set *messageSignal6 = ts
5418− else if b == 7 then set *messageSignal7 = ts
5419− else if b == 8 then set *messageSignal8 = ts
5420− else if b == 9 then set *messageSignal9 = ts
5421− else if b == 10 then set *messageSignal10 = ts
5422− else if b == 11 then set *messageSignal11 = ts
5423− else if b == 12 then set *messageSignal12 = ts
5424− else if b == 13 then set *messageSignal13 = ts
5425− else if b == 14 then set *messageSignal14 = ts
5426− else set *messageSignal15 = ts
5428−readMessageSignal = \pubkey ->
5429− let b = pubkeyBucket pubkey in
5430− if b == 0 then do s <- *messageSignal0; yield s
5431− else if b == 1 then do s <- *messageSignal1; yield s
5432− else if b == 2 then do s <- *messageSignal2; yield s
5433− else if b == 3 then do s <- *messageSignal3; yield s
5434− else if b == 4 then do s <- *messageSignal4; yield s
5435− else if b == 5 then do s <- *messageSignal5; yield s
5436− else if b == 6 then do s <- *messageSignal6; yield s
5437− else if b == 7 then do s <- *messageSignal7; yield s
5438− else if b == 8 then do s <- *messageSignal8; yield s
5439− else if b == 9 then do s <- *messageSignal9; yield s
5440− else if b == 10 then do s <- *messageSignal10; yield s
5441− else if b == 11 then do s <- *messageSignal11; yield s
5442− else if b == 12 then do s <- *messageSignal12; yield s
5443− else if b == 13 then do s <- *messageSignal13; yield s
5444− else if b == 14 then do s <- *messageSignal14; yield s
5445− else do s <- *messageSignal15; yield s
5447−-- Acknowledge messages up to the given cursor: remove from messages, cancel pending forwards,
5448−-- and create ack entries for federated messages (to notify origin servers).
5449−-- Returns pending acks and any evicted entries that exceeded ackedIds capacity.
5450−ackPolledMessages = \pubkey cursor t -> do
5451− let b = pubkeyBucket pubkey
5452− bucket <- readMessageBucket b
5453− let toAck = do m <- bucket; where m.toKey == pubkey && m.receivedAt <= cursor; yield m
5454− let ackCount = count toAck
5457− writeMessageBucket b (diff bucket toAck)
5458− totalCount <- *totalMessageCount
5459− set *totalMessageCount = max 0 (totalCount - ackCount)
5460− recipientCounts <- readRcBucket b
5461− writeRcBucket b (adjustRecipientCount recipientCounts pubkey (0 - ackCount))
5462− let ackedMsgIds = do m <- toAck; yield m.messageId
5463− fwdBkt <- readFwdBucket b
5464− let keptFwds = do f <- fwdBkt; where none ackedMsgIds (\mid -> f.messageId == mid && f.toKey == pubkey); yield f
5465− let fwdRemoved = count fwdBkt - count keptFwds
5466− writeFwdBucket b keptFwds
5467− when (fwdRemoved > 0) (do
5468− tfc <- *totalForwardCount
5469− set *totalForwardCount = max 0 (tfc - fwdRemoved))
5470− let ackedFederated = federatedAckEntries toAck t
5471− ackedBkt <- readAckedBucket b
5472− let combinedAckedIds = union ackedBkt ackedFederated
5473− let excessCount = max 0 (count combinedAckedIds - maxAckedIds)
5474− let eviction = evictSmallest combinedAckedIds excessCount (\a -> a.ackedAt)
5475− writeAckedBucket b eviction.kept
5476− -- Queue delivery receipts for locally-originated messages (senderKey != "")
5477− -- so the sender learns their message was delivered on their next poll.
5478− let localDelivered = do m <- toAck; where m.senderKey != "" && m.originServer == ""; yield {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, deliveredAt: t}
5479− when (count localDelivered > 0) (do
5480− sd <- *senderDeliveries
5481− -- Dedup: skip receipts already recorded (e.g., cursor ack + explicit ack for same message)
5482− let deduped = do d <- localDelivered; where none sd (\e -> e.messageId == d.messageId && e.toKey == d.toKey); yield d
5483− let combined = union sd deduped
5484− let overCap = count combined > maxSenderDeliveries
5486− -- Batch eviction: evict 2% of capacity instead of 1 entry at a time.
5487− -- Amortizes the O(n) scan cost across multiple inserts, reducing overhead
5488− -- under sustained capacity pressure from O(n) per insert to O(n) per 2% fills.
5489− let evictCount = max 1 (count combined - maxSenderDeliveries + maxSenderDeliveries / 50)
5490− let eviction = evictSmallest combined evictCount (\d -> d.deliveredAt)
5491− set *senderDeliveries = eviction.kept
5492− -- Track per-sender drop counts for all evicted entries
5493− let dropCounts = fold (\acc e -> incrementDropCounter acc e.senderKey 1 t) [] eviction.evicted
5494− when (count dropCounts > 0) (do
5495− ddr <- *droppedDeliveryReceipts
5496− set *droppedDeliveryReceipts = fold (\acc dc -> incrementDropCounter acc dc.senderKey dc.count t) ddr dropCounts)
5497− else set *senderDeliveries = combined)
5498− yield {pendingAcks: ackedFederated, evictedEntries: eviction.evicted}
5499− else yield {pendingAcks: [], evictedEntries: []}
5501−pollNewEvents = \pubkey clampedCursor t -> do
5502− bucket <- readMessageBucket (pubkeyBucket pubkey)
5503− let raw = pollableMessages bucket pubkey clampedCursor t
5504− -- Priority-aware delivery with starvation prevention: reserve a fraction of
5505− -- maxPollEvents for priority-0 messages so high-priority floods can't completely
5506− -- starve normal messages. Reservation only activates when both pools have messages.
5507− let priority0 = do m <- raw; where m.priority == 0; yield m
5508− let highPri = do m <- raw; where m.priority > 0; yield m
5509− let reservedSlots = if reservedPollFraction > 0 && count highPri > 0 && count priority0 > 0
5510− then max 1 (maxPollEvents / reservedPollFraction)
5512− let highPriSlots = maxPollEvents - reservedSlots
5513− let sortedHigh = sortBy (\m -> (0 - m.priority) * 10000000000000 + m.receivedAt) highPri
5514− let sortedLow = sortBy (\m -> m.receivedAt) priority0
5515− let selectedHigh = takeRelation highPriSlots sortedHigh
5516− let selectedLow = takeRelation reservedSlots sortedLow
5517− -- Merge and re-sort to maintain correct cursor advancement (lastReceivedAt must
5518− -- reflect the actual latest receivedAt across both pools for cursor consistency).
5519− let limitedMsgs = sortBy (\m -> (0 - m.priority) * 10000000000000 + m.receivedAt) (union selectedHigh selectedLow)
5522− yield {id: m.messageId, eventType: "message",
5523− payload: {toKey: m.toKey,
5524− encryptedBlob: m.encryptedBlob,
5525− timestamp: m.timestamp,
5526− expiresAt: m.expiresAt}}
5527− let lastReceivedAt = fold (\acc m -> max acc m.receivedAt) clampedCursor limitedMsgs
5528− -- hasMore: tells clients there are additional messages beyond this batch,
5529− -- so they can immediately re-poll without waiting for the next heartbeat.
5530− let hasMore = count raw > count limitedMsgs
5531− yield {events: evts, cursor: lastReceivedAt, hasMore: hasMore}
5533−-- Execute a single long-poll cycle:
5534−-- 1. Authenticate and ack messages up to cursor (atomic)
5535−-- 2. Acquire a poll slot (limit concurrent polls per key)
5536−-- 3. Check for existing messages; if none, block on signal/heartbeat (retry-based wait)
5537−-- 4. Re-authenticate after waking (session may have expired during wait)
5538−-- 5. Return new events and release the poll slot
5539−pollOnce = \token cursor clientIp -> do
5541− let bucket = tokenBucket token
5543− sessions <- readSessionBucket bucket
5544− case authenticateSession sessions token t of
5545− Unauthorized {} -> yield (Nothing {})
5546− Authorized {pubkey, ip} ->
5547− if not (matchIp clientIp ip)
5548− then yield (Nothing {})
5550− -- Sliding window: refresh session expiry when within half of sessionExpiry.
5551− -- Avoids rewriting the session bucket on every poll (reduces write contention
5552− -- on the hottest path). Uses pubkey pre-filter so safeCompare only runs on
5553− -- sessions matching the authenticated pubkey (~1-2 per bucket vs ~600).
5554− let needsRefresh = any sessions (\s -> s.pubkey == pubkey && s.expiresAt - t < sessionExpiry / 3)
5556− (writeSessionBucket bucket (do s <- sessions; yield (if s.pubkey == pubkey && s.expiresAt - t < sessionExpiry / 3 && safeCompare s.token token then {token: s.token, pubkey: s.pubkey, expiresAt: t + sessionExpiry, ip: s.ip, createdAt: s.createdAt} else s)))
5557− seqCounter <- *seqCounter
5558− let clampedCursor = clamp 0 (max seqCounter t) cursor
5559− ackResult <- if clampedCursor > 0
5560− then ackPolledMessages pubkey clampedCursor t
5561− else yield {pendingAcks: [], evictedEntries: []}
5562− startWakeup <- *pollWakeup
5563− startSignal <- readMessageSignal pubkey
5564− yield (Just {value: {pubkey: pubkey, clampedCursor: clampedCursor, startWakeup: startWakeup, startSignal: startSignal, pendingAcks: ackResult.pendingAcks, evictedEntries: ackResult.evictedEntries}})
5566− Nothing {} -> yield {authorized: False {}, events: [], cursor: 0, pendingAcks: [], evictedEntries: [], pubkey: "", pollSlotFull: False {}, hasMore: False {}}
5567− Just {value: s} -> do
5568− -- Acquire poll slot (limit concurrent polls per key)
5569− acquired <- atomic do
5570− activePolls <- *activePolls
5571− let pollsForKey = count (do p <- activePolls; where p.pubkey == s.pubkey; yield p)
5572− if pollsForKey >= maxPollsPerKey
5573− then yield (False {})
5575− set *activePolls = if count activePolls >= maxActivePolls
5576− then union (evictOneOldest activePolls (\p -> p.startedAt)) [{pubkey: s.pubkey, startedAt: t}]
5577− else union activePolls [{pubkey: s.pubkey, startedAt: t}]
5580− -- Poll slot exhausted: tell client to back off for one poll cycle instead of busy-retrying
5581− then yield {authorized: True {}, events: [], cursor: cursor, pendingAcks: s.pendingAcks, evictedEntries: s.evictedEntries, pubkey: s.pubkey, pollSlotFull: True {}, hasMore: False {}}
5584− -- Phase 1: check for existing messages (atomic read)
5585− initialResult <- atomic do
5586− bucket <- readMessageBucket (pubkeyBucket s.pubkey)
5587− if count (pollableMessages bucket s.pubkey s.clampedCursor t) > 0
5589− r <- pollNewEvents s.pubkey s.clampedCursor t
5590− yield (Just {value: {events: r.events, cursor: r.cursor, hasMore: r.hasMore}})
5591− else yield (Nothing {})
5592− case initialResult of
5593− Just {value: result} ->
5594− yield {authorized: True {}, events: result.events, cursor: result.cursor, hasMore: result.hasMore}
5596− -- Phase 2: wait for signal or heartbeat
5598− wakeup <- *pollWakeup
5599− signal <- readMessageSignal s.pubkey
5600− if wakeup > s.startWakeup || signal > s.startSignal
5603− -- Phase 3: re-authenticate and read messages after waking.
5604− -- Check drain flag (server may have started draining during our wait).
5605− -- Uses reauthenticateSession (pre-filters by pubkey) instead of full
5606− -- authenticateSession to skip safeCompare on unrelated sessions.
5608− result <- atomic do
5610− if dp >= 2 then yield {authorized: True {}, events: [], cursor: s.clampedCursor, hasMore: False {}}
5612− sessions2 <- readSessionBucket bucket
5613− if not (reauthenticateSession sessions2 token s.pubkey t2)
5614− then yield {authorized: False {}, events: [], cursor: s.clampedCursor, hasMore: False {}}
5616− r <- pollNewEvents s.pubkey s.clampedCursor t2
5617− yield {authorized: True {}, events: r.events, cursor: r.cursor, hasMore: r.hasMore}
5618− yield {authorized: result.authorized, events: result.events, cursor: result.cursor, hasMore: result.hasMore}
5619− -- Release poll slot. Safety: the code between acquire and release only contains
5620− -- atomic reads and STM retry (no IO that can throw), so this path is always reached.
5621− -- If it ever isn't (e.g., runtime panic), pruneExpired cleans stale entries
5622− -- after pollTimeoutMs * 3 as a safety net.
5624− activePolls <- *activePolls
5625− set *activePolls = removeOneForKey activePolls s.pubkey
5626− yield {authorized: pollResult.authorized, events: pollResult.events, cursor: pollResult.cursor, pendingAcks: s.pendingAcks, evictedEntries: s.evictedEntries, pubkey: s.pubkey, pollSlotFull: False {}, hasMore: pollResult.hasMore}
5628-- ============================================
1103-- ============================================
5629−-- Derived Relations
1104+-- Background loops
5630-- ============================================
1105-- ============================================
5631−-- Pure query functions over in-memory state. No side effects.
5633−-- All non-expired presence entries for a given pubkey
5634−presenceForKey = \presence pubkey t ->
5635− do p <- presence; where p.pubkey == pubkey && p.expiresAt > t; yield p
5637−-- Pubkeys that are online on this server
5638−localOnlineKeys = \presence t ->
5639− do p <- presence; where isLocalServer p.server && p.expiresAt > t; yield p.pubkey
5641−-- Remove the local presence entry for a pubkey (used before re-inserting on auth)
5642−presenceWithoutLocalKey = \presence pubkey ->
5643− do p <- presence; where p.pubkey != pubkey || not (isLocalServer p.server); yield p
5645−-- Local presence entries that expired during this prune cycle (for offline gossip)
1107+pruneAndRetry = \t -> do
5646−expiredLocalPresence = \before after t ->
1108+ atomic do set *lastPrunedAt = t
5647− do p <- before; where p.expiresAt <= t && isLocalServer p.server && none after (\q -> q.pubkey == p.pubkey && isLocalServer q.server); yield p
1109+ expiredLocal <- pruneExpired t
5648−
1110+ fork (broadcastOfflineGossip t expiredLocal)
5649−-- Resolve the best server for a pubkey: prefer local, otherwise pick the remote with latest expiry
1111+ when federationEnabled (fork retryPendingForwards)
5650−bestServerForKey = \entries ->
1112+ when federationEnabled (do
5651− if any entries (\p -> isLocalServer p.server) then serverHostN
1113+ aids <- *ackedIds
5652− else case maxBy (do p <- entries; where not (isLocalServer p.server); yield p) (\p -> p.expiresAt) of
1114+ let pendingAcks = do a <- aids; where not (isLocalServer a.originServer); yield a
5653− Just {value: p} -> p.server
1115+ fork (sendAcksAndClean pendingAcks))
5654− Nothing {} -> ""
1116+ -- Refresh local presence for active sessions every ~5 minutes
1117+ lastRefresh <- *lastPresenceRefresh
1118+ when (federationEnabled && t - lastRefresh >= presenceRefreshInterval) (do
1119+ atomic do set *lastPresenceRefresh = t
1120+ refreshLocalPresence t)
5656−-- Messages for a pubkey newer than cursor and not expired (per-message expiresAt)
1123+refreshLocalPresence = \t -> do
5657−pollableMessages = \messages pubkey cursor t ->
1124+ refreshState <- atomic do
5658− do m <- messages; where m.toKey == pubkey && m.expiresAt > t && m.receivedAt > cursor; yield m
1125+ sessions <- *sessions
5659−
1126+ presence <- *presence
5660−-- Build ack entries for messages that came from a remote origin server (need federation ack)
1127+ let activeKeys = fold (\acc s -> if any acc (\a -> a == s.pubkey) then acc else union acc [s.pubkey]) [] sessions
5661−federatedAckEntries = \ackedMessages t ->
1128+ let updated = do
5662− do m <- ackedMessages; where m.originServer != ""; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
1129+ p <- presence
5663−
1130+ yield (if isLocalServer p.server && any activeKeys (\k -> k == p.pubkey) && p.expiresAt - t < sessionExpiry / 2
5664−-- Remove forwards for specific message IDs destined to a given server
1131+ then {pubkey: p.pubkey, server: p.server, expiresAt: t + sessionExpiry, timestamp: t}
5665−forwardsExcluding = \forwards server messageIds ->
1132+ else p)
5666− do f <- forwards; where not (f.toServer == server && any messageIds (\mid -> f.messageId == mid)); yield f
1133+ set *presence = updated
5667−
1134+ let refreshed = do p <- updated; where isLocalServer p.server && p.expiresAt == t + sessionExpiry; yield p
5668−-- Find messages that haven't been forwarded yet to each target's server.
1135+ let peers = knownPeerServersFromPresence updated
5669−-- Includes relay: messages received via federation (originServer != "") can be
1136+ yield {refreshed: refreshed, peers: peers}
5670−-- re-forwarded when the recipient moves to a different server. Cascade is bounded
1137+ when (count refreshState.refreshed > 0 && count refreshState.peers > 0) (do
5671−-- by dedup (same messageId won't be forwarded to the same server twice).
1138+ let events = do p <- refreshState.refreshed; yield {eventType: GossipOnline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: clampTtl (sessionExpiry / 1000), seenBy: [serverHostN]}
5672−forwardCandidates = \targets messages forwards t ->
1139+ fork (sendBatchedGossip refreshState.peers events gossipOriginHops))
5673− fold (\acc target ->
5674− let serverFwdIds = do f <- forwards; where f.toServer == target.server; yield f.messageId in
5677− where m.toKey == target.pubkey
5678− where none serverFwdIds (\fid -> fid == m.messageId)
5679− let origin = if m.originServer == "" then serverHostN else m.originServer
5680− yield {messageId: m.messageId, toServer: target.server, createdAt: t,
5681− toKey: m.toKey, encryptedBlob: m.encryptedBlob, timestamp: m.timestamp,
5682− originServer: origin, retries: 0, expiresAt: m.expiresAt, priority: m.priority, senderKey: m.senderKey})) [] targets
5684−-- Challenge-IP binding rules:
5685−-- 1. Both sides have IPs: must match (standard proxy case)
5686−-- 2. Challenge created without IP, verify without IP: accept (no-proxy case)
5687−-- 3. Challenge created without IP, verify with IP: accept (proxy added mid-flow)
5688−-- 4. Challenge created with IP, verify without IP: REJECT (proxy removed or bypassed)
5689−-- Case 4 prevents an attacker who intercepts the challenge string from verifying
5690−-- without going through the same reverse proxy that issued the challenge.
5691−challengeMatch = \challenges pubkey challenge ip t ->
5692− any challenges (\c -> c.pubkey == pubkey && safeCompare c.challenge challenge && c.expiresAt > t && matchIp ip c.ip)
5694−challengesExcluding = \challenges pubkey challenge ->
5695− do c <- challenges; where c.pubkey != pubkey || c.challenge != challenge; yield c
5697−hasLocalPresence = \entries -> any entries (\p -> isLocalServer p.server)
5699−ackedIdsExcludingBatch = \ackedIds server batch ->
5700− do a <- ackedIds; where not (a.originServer == server && hasMessage a.messageId a.toKey batch); yield a
5702−retriableEvictedAcks = \evictedEntries pendingAcks ->
5703− do a <- evictedEntries; where not (hasMessage a.messageId a.toKey pendingAcks); yield a
5705−acksForServer = \acks server -> do a <- acks; where a.originServer == server; yield a
5707−forwardsForServer = \forwards server -> do f <- forwards; where f.toServer == server; yield f
5709−-- Partition forwards by server and dispatch sequentially. Each iteration removes
5710−-- processed entries from the working list, so subsequent scans are smaller.
5711−-- Total work: ~n*k/2 vs n*k for the naive sendToEach + forwardsForServer pattern.
5712−-- Per-server jitter (0-2s) prevents thundering herd when multiple servers restart
5713−-- simultaneously and all retry pending forwards in the same prune window.
5714−sendForwardsPartitioned = \pending servers maxRetries ->
5715− case headOf servers of
5716− Nothing {} -> yield {}
5717− Just {value: server} -> do
5718− let rest = do s <- servers; where s != server; yield s
5719− let serverForwards = do f <- pending; where f.toServer == server; yield f
5720− let remaining = do f <- pending; where f.toServer != server; yield f
5721− jitter <- randomInt 2000
5723− retryForwardsForServer serverForwards maxRetries
5724− sendForwardsPartitioned remaining rest maxRetries
5726−-- Only trust offline events that claim to be from the sending server itself
5727−trustedOfflineEvents = \events fromServer ->
5728− do e <- events; where e.server == fromServer; yield e
5730−-- Peer servers to re-gossip to, excluding the server that sent us the gossip
5731−gossipTargets = \peerServers fromServer ->
5732− do s <- peerServers; where s != fromServer; yield s
5734−-- Remote keys that just came online (triggers forwarding of queued messages).
5735−-- Pre-extracts unique pubkeys from appliedKeys for fast-path rejection (same optimization
5736−-- as effectiveGossipEvents: skip full samePubkeyServer check when pubkey doesn't match).
5737−newlyOnlineRemoteKeys = \events appliedKeys ->
5738− let appliedPubkeys = fold (\acc a -> if any acc (\p -> p == a.pubkey) then acc else union [a.pubkey] acc) [] appliedKeys
5739− in do e <- events; where any appliedPubkeys (\pk -> pk == e.pubkey); where any appliedKeys (\a -> samePubkeyServer a e); where not (isLocalServer e.server); yield {pubkey: e.pubkey, server: e.server}
5741−-- Trust gossip entries if they're first-party (server == fromServer) or updating
5742−-- an existing (pubkey, server) presence entry. Third-party gossip cannot create
5743−-- new entries for keys we haven't seen — only the key's home server can do that.
5744−-- Additional constraint: third-party updates must carry a strictly newer timestamp
5745−-- than the existing entry — prevents stale relays from refreshing presence TTLs
5746−-- beyond what the original server intended.
5747−trustedGossipEntries = \deduped presence fromServer t ->
5748− do e <- deduped; where
5749− if e.server == fromServer then True {} -- first-party: always trusted
5750− else any presence (\p -> samePubkeyServer p e && p.expiresAt > t && e.timestamp > p.timestamp)
5751− -- third-party: only update existing entries with strictly newer timestamps
5752− ; yield {expiresAt: e.expiresAt, pubkey: e.pubkey, server: e.server, timestamp: e.timestamp}
5754−-- Keys whose presence was actually updated (new or extended expiry)
5755−appliedOnlineKeys = \entries presence ->
5756− do e <- entries; where none presence (\p -> samePubkeyServer p e && p.expiresAt >= e.expiresAt); yield (pubkeyServer e)
5758−-- Gossip entries that update existing presence (vs. creating new entries)
5759−existingPresenceUpdates = \entries presence ->
5760− do e <- entries; where any presence (\p -> samePubkeyServer p e); yield e
5762−-- Gossip entries for keys not yet in the presence table
5763−newPresenceEntries = \entries presence ->
5764− do e <- entries; where none presence (\p -> samePubkeyServer p e); yield e
5766−-- Generate offline gossip events for locally-expired presence entries
5767−offlineGossipEvents = \expiredLocal -> do
5769− let ttl = clamp offlineGossipMinTtl maxPresenceTtl ((p.expiresAt - p.timestamp) / 1000)
5770− yield {eventType: GossipOffline {}, pubkey: p.pubkey, server: serverHostN, timestamp: p.expiresAt, ttl: ttl, seenBy: [serverHostN]}
5772−-- Filter targets to only those not locally online (avoid forwarding to keys that can poll directly)
5773−remoteOnlyTargets = \targets localOnline ->
5774− do target <- targets; where none localOnline (\pk -> pk == target.pubkey); yield target
5776-- ============================================
1141-- ============================================
5777−-- Request Handler
1142+-- Handler: challenge / verify / revoke / logout
5778-- ============================================
1143-- ============================================
5780−-- POST /auth/challenge: Generate a random challenge for Ed25519 authentication.
5781−-- Rate-limited per key; globally capped. Challenge expires in 1 minute.
5782handleChallenge = \pubkey clientIp respond -> do
1145handleChallenge = \pubkey clientIp respond -> do
5783 t <- now
1146 t <- now
5784− -- Reject challenges without ClientIp when requireClientIp is enabled.
5785− -- Prevents creating sessions with no IP binding (permanently accept from any IP).
5786 if requireClientIp && clientIp == ""
1147 if requireClientIp && clientIp == ""
5787− then do
1148+ then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: "client_ip_required"})
5788− logEvent "warn" "missing_client_ip" ("endpoint=challenge key=" ++ pubkey)
5789− yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: "client_ip_required"})
5791 preAuth <- checkPreAuth clientIp t
1150 preAuth <- checkPreAuth clientIp t
5792− if preAuth != ""
1151+ if preAuth != "" then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: preAuth})
5793− then do
1152+ else do
5794− when (preAuth == "ip_rate_limited") (logEvent "warn" "rate_limited_ip" ("endpoint=challenge ip=" ++ clientIp))
1153+ authLimited <- checkAuthGlobalRate t
5795− yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: preAuth})
1154+ if authLimited then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: "auth_rate_limited"})
5797− authLimited <- checkAuthGlobalRate t
5798− if authLimited then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: "auth_rate_limited"})
5800 challenge <- genToken
1156 challenge <- genToken
5801 result <- atomic do
1157 result <- atomic do
5802− challenges <- *challenges
1158+ ch <- *challenges
5803− let active = do c <- challenges; where c.expiresAt > t; yield c
1159+ let active = do c <- ch; where c.expiresAt > t; yield c
5804 let activeForKey = count (do c <- active; where c.pubkey == pubkey; yield c)
1160 let activeForKey = count (do c <- active; where c.pubkey == pubkey; yield c)
5805 let cappedActive = if activeForKey >= maxChallengesPerKey
1161 let cappedActive = if activeForKey >= maxChallengesPerKey
5806− then let forKey = do c <- active; where c.pubkey == pubkey; yield c in
1162+ then evictOldest active (\c -> if c.pubkey == pubkey then c.expiresAt else 999999999999)
5807− let others = do c <- active; where c.pubkey != pubkey; yield c in
1163+ else active
5808− union others (evictOneOldest forKey (\c -> c.expiresAt))
1164+ if count cappedActive >= maxChallenges then yield {ok: False {}, error: "capacity"}
5809− else active
1165+ else do
5810− if count cappedActive >= maxChallenges
1166+ rates <- *challengeRates
5811− then yield {accepted: False {}, rateLimited: False {}, retryAfterMs: 0, error: "capacity"}
1167+ let r = checkRate rates pubkey maxChallengeRatePerKey challengeRateWindowMs 5000 t
1168+ if r.limited then yield {ok: False {}, error: "rate_limited"}
5813− challengeRates <- *challengeRates
1170+ set *challengeRates = r.entries
5814− chalRate <- effectiveChallengeRate
1171+ set *challenges = union cappedActive [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry, ip: clientIp}]
5815− let rateResult = checkPubkeyRate challengeRates pubkey chalRate challengeRateWindowMs maxChallengeRateEntries t
1172+ yield {ok: True {}, error: ""}
5816− if rateResult.limited
1173+ yield (respond {challenge: if result.ok then challenge else "", ok: result.ok, expiresAt: if result.ok then t + challengeExpiry else 0, retryAfterMs: 0, error: result.error})
5817− then yield {accepted: False {}, rateLimited: True {}, retryAfterMs: rateResult.retryAfterMs, error: "rate_limited:" ++ show challengeRateWindowMs ++ "ms"}
1174+
5819− set *challengeRates = rateResult.entries
5820− set *challenges = union cappedActive [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry, ip: clientIp}]
5821− yield {accepted: True {}, rateLimited: False {}, retryAfterMs: 0, error: ""}
5822− when result.rateLimited (do
5823− effChal <- effectiveChallengeRate
5824− logEvent "warn" "rate_limited_per_key" ("endpoint=challenge key=" ++ pubkey ++ " limit=" ++ show effChal))
5825− when (not result.accepted && not result.rateLimited)
5826− (logWarn ("challenge: at capacity (" ++ show maxChallenges ++ "), rejecting for " ++ pubkey))
5827− yield (respond {challenge: if result.accepted then challenge else "", ok: result.accepted, expiresAt: if result.accepted then t + challengeExpiry else 0, retryAfterMs: result.retryAfterMs, error: result.error})
5829−-- POST /auth/verify: Verify Ed25519 signature over challenge string.
5830−-- On success: creates a session, registers local presence, and gossips online status.
5831−-- Rate-limited globally and per-key (shares auth rate window with challenge requests).
5832handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp respond -> do
1175handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp respond -> do
5833 t <- now
1176 t <- now
5834 preAuth <- checkPreAuth clientIp t
1177 preAuth <- checkPreAuth clientIp t
5835− if preAuth != ""
1178+ if preAuth != "" then yield (respond {token: "", expiresAt: 0, error: preAuth})
5836− then do
1179+ else do
5837− when (preAuth == "ip_rate_limited") (logEvent "warn" "rate_limited_ip" ("endpoint=verify ip=" ++ clientIp))
1180+ authLimited <- checkAuthGlobalRate t
5838− yield (respond {token: "", expiresAt: 0, error: preAuth})
1181+ if authLimited then yield (respond {token: "", expiresAt: 0, error: "auth_rate_limited"})
5840− authRateLimited <- atomic do
1183+ let expiry = t + sessionExpiry
5841− challengeRates <- *challengeRates
1184+ token <- genToken
5842− chalRate <- effectiveChallengeRate
1185+ result <- atomic do
5843− let rateResult = checkPubkeyRate challengeRates pubkey chalRate challengeRateWindowMs maxChallengeRateEntries t
1186+ ch <- *challenges
5844− set *challengeRates = rateResult.entries
1187+ let hasMatch = any ch (\c -> c.pubkey == pubkey && safeCompare c.challenge challenge && c.expiresAt > t && matchIp clientIp c.ip)
5845− yield rateResult.limited
1188+ if not hasMatch then yield {valid: False {}, peers: []}
5846− if authRateLimited then do
1189+ else
5847− effChal <- effectiveChallengeRate
1190+ if not (verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature))
5848− logEvent "warn" "rate_limited_per_key" ("endpoint=verify key=" ++ pubkey ++ " limit=" ++ show effChal)
1191+ then yield {valid: False {}, peers: []}
5849− yield (respond {token: "", expiresAt: 0, error: "rate_limited:" ++ show challengeRateWindowMs ++ "ms"})
1192+ else do
1193+ set *challenges = do c <- ch; where c.pubkey != pubkey || c.challenge != challenge; yield c
1195+ if dp >= 1 then yield {valid: False {}, peers: []}
1198+ let kept = if revokeOthers then (do s <- ses; where s.pubkey != pubkey; yield s) else ses
1199+ let perKeyOver = count (do s <- kept; where s.pubkey == pubkey; yield s) >= maxSessionsPerKey
1200+ let afterPerKey = if perKeyOver
1201+ then let forKey = do s <- kept; where s.pubkey == pubkey; yield s in
1202+ let others = do s <- kept; where s.pubkey != pubkey; yield s in
1203+ union others (evictOldest forKey (\s -> s.expiresAt))
1205+ let newSession = {token: token, pubkey: pubkey, expiresAt: expiry, ip: clientIp, createdAt: t}
1206+ set *sessions = capList (union afterPerKey [newSession]) maxSessions (\s -> s.expiresAt)
1208+ let withoutLocal = do p <- pres; where p.pubkey != pubkey || not (isLocalServer p.server); yield p
1209+ let newPres = capList (union withoutLocal [{pubkey: pubkey, server: serverHostN, expiresAt: expiry, timestamp: t}]) maxPresenceEntries (\p -> p.expiresAt)
1210+ set *presence = newPres
1211+ let peers = knownPeerServersFromPresence newPres
1212+ yield {valid: True {}, peers: peers}
1213+ if not result.valid then yield (respond {token: "", expiresAt: 0, error: "invalid"})
5851− authGlobalLimited <- checkAuthGlobalRate t
1215+ when federationEnabled
5852− if authGlobalLimited then yield (respond {token: "", expiresAt: 0, error: "auth_rate_limited"})
1216+ (fork (sendBatchedGossip result.peers [{eventType: GossipOnline {}, pubkey: pubkey, server: serverHostN, timestamp: t, ttl: onlineGossipTtl, seenBy: [serverHostN]}] gossipOriginHops))
1217+ yield (respond {token: token, expiresAt: expiry, error: ""})
1219+handleRevoke = \targetToken authorization clientIp respond -> do
1221+ g <- checkGlobalRate t
1222+ if g then yield (respond {ok: False {}, authorized: False {}})
1223+ else withSessionAuth authorization t clientIp
1224+ (yield (respond {ok: False {}, authorized: False {}}))
1226+ result <- atomic do
1228+ let found = any ses (\s -> s.pubkey == caller && safeCompare s.token targetToken)
1229+ if not found then yield False
5854− -- Per-IP unique key abuse detection: reject IPs authenticating too many distinct pubkeys
1231+ set *sessions = do s <- ses; where s.pubkey != caller || not (safeCompare s.token targetToken); yield s
5855− uniqueKeyLimited <- atomic do
1232+ yield True
5856− ukr <- *uniqueKeyIpRates
1233+ yield (respond {ok: result, authorized: True {}}))
5857− let result = checkUniqueKeyIpRate ukr clientIp pubkey t
1234+
5858− set *uniqueKeyIpRates = if count result.entries > maxUniqueKeyIpEntries
1235+handleLogout = \authorization clientIp respond -> do
5859− then do r <- result.entries; where t - r.windowStart < uniqueKeyIpWindowMs; yield r
1236+ t <- now
5860− else result.entries
1237+ case extractToken authorization of
5861− yield result.limited
1238+ Nothing {} -> yield (respond {ok: False {}, authorized: False {}})
5862− if uniqueKeyLimited then do
1239+ Just {value: token} -> do
5863− logEvent "warn" "rate_limited_unique_key_ip" ("ip=" ++ clientIp ++ " limit=" ++ show maxUniqueKeysPerIp)
1240+ removed <- atomic do
5864− yield (respond {token: "", expiresAt: 0, error: "unique_key_limited"})
1241+ ses <- *sessions
5865− else verifyAuthInner pubkey challenge signature revokeOthers clientIp respond t
1242+ case authenticateSession ses token t of
5866−
1243+ Unauthorized {} -> yield {ok: False {}, pubkey: "", peers: []}
5867−verifyAuthInner = \pubkey challenge signature revokeOthers clientIp respond t -> do
1244+ Authorized {pubkey, ip} ->
5868− let expiry = t + sessionExpiry
1245+ if not (matchIp clientIp ip) then yield {ok: False {}, pubkey: "", peers: []}
5869− -- Generate token before atomic block (IO can't run inside STM).
5870− -- Token is discarded if challenge validation fails — no session is created.
5872− -- Single atomic block for challenge verification + session creation.
5873− -- Eliminates the TOCTOU gap where a challenge could be consumed without
5874− -- creating a session (e.g., drain phase changes between two atomic blocks).
5875− authResult <- atomic do
5876− challenges <- *challenges
5877− let hasMatch = challengeMatch challenges pubkey challenge clientIp t
5878− -- Only consume the challenge on full success (match AND valid signature).
5879− -- verify() is pure (no IO) so safe in STM.
5881− then yield {valid: False {}, result: Nothing {}}
5883− let sigValid = verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
5885− then yield {valid: False {}, result: Nothing {}}
5887− set *challenges = challengesExcluding challenges pubkey challenge
5889− if dp >= 1 then yield {valid: True {}, result: Nothing {}}
5891− tpc <- *totalPresenceCount
5892− knownPeers <- *knownPeerServers
5893− sessionsForKey <- countSessionsForKey pubkey
5894− tsc <- *totalSessionCount
5895− let newSession = {token: token, pubkey: pubkey, expiresAt: expiry, ip: clientIp, createdAt: t}
5896− -- Update presence: replace local entry for this pubkey, evict oldest if over capacity
5897− let pb = pubkeyBucket pubkey
5898− presenceBkt <- readPresenceBucket pb
5899− let bucketWithout = do p <- presenceBkt; where p.pubkey != pubkey || not (isLocalServer p.server); yield p
5900− let hadLocalEntry = count presenceBkt > count bucketWithout
5901− let bucketEvicted = if not hadLocalEntry && tpc >= maxPresenceEntries then evictOneOldest bucketWithout (\p -> p.expiresAt) else bucketWithout
5902− let newPresenceEntry = {pubkey: pubkey, server: serverHostN, expiresAt: expiry, timestamp: t}
5903− writePresenceBucket pb (union bucketEvicted [newPresenceEntry])
5904− let presenceDelta = count (union bucketEvicted [newPresenceEntry]) - count presenceBkt
5905− set *totalPresenceCount = tpc + presenceDelta
5906− set *presenceVersion = t
5907− let peerServers = if federationEnabled then knownPeers else []
5908− -- Fast path: no revocation, under per-key and global limits — only write one bucket
5909− if not revokeOthers && sessionsForKey < maxSessionsPerKey && tsc < maxSessions
5911− let nb = tokenBucket token
5912− currentBucket <- readSessionBucket nb
5913− writeSessionBucket nb (union currentBucket [newSession])
5914− set *totalSessionCount = tsc + 1
5915− yield {valid: True {}, result: Just {value: {peerServers: peerServers, revokedCount: 0}}}
5917− -- Slow path: revocation or capacity pressure.
1247+ set *sessions = do s <- ses; where not (safeCompare s.token token); yield s
5918− -- Bucket-by-bucket approach: revoke sessions for this pubkey across all
1248+ -- If no remaining sessions for this key, drop local presence
5919− -- 16 buckets without materializing them into one list. Then add the new
1249+ after <- *sessions
5920− -- session to its bucket and handle global capacity if needed.
1250+ let stillHas = any after (\s -> s.pubkey == pubkey)
5921− let revokedCount = if revokeOthers then sessionsForKey else 0
1251+ peers <- if stillHas then yield []
5922− when revokeOthers
1252+ else do
5923− (transformAllSessionBuckets (\bucket -> do s <- bucket; where s.pubkey != pubkey; yield s))
1253+ pres <- *presence
5924− -- Per-key cap: if still over maxSessionsPerKey (non-revoke case), evict oldest for this key
1254+ set *presence = do p <- pres; where p.pubkey != pubkey || not (isLocalServer p.server); yield p
5925− let nb = tokenBucket token
1255+ yield (knownPeerServersFromPresence pres)
5926− when (not revokeOthers && sessionsForKey >= maxSessionsPerKey)
1256+ yield {ok: True {}, pubkey: pubkey, peers: peers}
5927− (transformAllSessionBuckets (\bucket ->
1257+ when (removed.ok && removed.pubkey != "" && count removed.peers > 0 && federationEnabled)
5928− let forKey = do s <- bucket; where s.pubkey == pubkey; yield s in
1258+ (fork (sendBatchedGossip removed.peers [{eventType: GossipOffline {}, pubkey: removed.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}] gossipOriginHops))
5929− let others = do s <- bucket; where s.pubkey != pubkey; yield s in
1259+ yield (respond {ok: removed.ok, authorized: removed.ok})
5930− if count forKey > 0 then union others (evictOneOldest forKey (\s -> s.expiresAt))
1260+
5931− else bucket))
1261+-- ============================================
5932− -- Global cap: if over maxSessions, evict oldest globally.
1262+-- Handler: poll
5933− -- Derive count from cached tsc: after revokeOthers, we removed revokedCount sessions;
1263+-- ============================================
5934− -- after per-key cap, we removed at most 1. Avoids a redundant 16-bucket scan.
1264+
5935− let perKeyEvicted = if not revokeOthers && sessionsForKey >= maxSessionsPerKey then 1 else 0
5936− let estimatedTotal = tsc - revokedCount - perKeyEvicted
5937− when (estimatedTotal >= maxSessions)
5938− (do -- Find the bucket containing the oldest session and evict from just that bucket.
5939− -- Avoids materializing all 16 session buckets into a single list (O(n) union chain).
5940− -- Instead, reads each bucket to find the global minimum, then writes only one bucket.
5941− evictOldestSessionFromBuckets 0 Nothing {})
5942− currentBucket <- readSessionBucket nb
5943− writeSessionBucket nb (union currentBucket [newSession])
5944− -- Final count: estimatedTotal + 1 (new session) - globalEviction (0 or 1)
5945− let globalEvicted = if estimatedTotal >= maxSessions then 1 else 0
5946− set *totalSessionCount = estimatedTotal - globalEvicted + 1
5947− yield {valid: True {}, result: Just {value: {peerServers: peerServers, revokedCount: revokedCount}}}
5948− if not authResult.valid
5949− then yield (respond {token: "", expiresAt: 0, error: "invalid"})
5950− else case authResult.result of
5951− Nothing {} -> yield (respond {token: "", expiresAt: 0, error: "draining"})
5952− Just {value: result} -> do
5953− when (revokeOthers && result.revokedCount > 0)
5954− (logInfo ("verify: revokeOthers revoked " ++ show result.revokedCount ++ " sessions for " ++ pubkey))
5955− fork (when federationEnabled
5956− (sendBatchedGossip result.peerServers [{eventType: GossipOnline {}, pubkey: pubkey, server: serverHostN, timestamp: t, ttl: onlineGossipTtl, seenBy: [serverHostN]}] gossipOriginHops))
5957− yield (respond {token: token, expiresAt: expiry, error: ""})
5959−-- POST /poll: Long-poll for new messages. Cursor-based: messages at or before cursor
5960−-- are acked (removed from mailbox). Blocks until new messages arrive or heartbeat fires.
5961−-- Acks for federated messages are sent to origin servers in the background.
5962handlePoll = \cursor generation watchKeys authorization clientIp respond -> do
1265handlePoll = \cursor generation watchKeys authorization clientIp respond -> do
5963 t <- now
1266 t <- now
5964 serverGen <- *serverGeneration
1267 serverGen <- *serverGeneration
5965 let generationMismatch = generation != serverGen
1268 let generationMismatch = generation != serverGen
5966 let effectiveCursor = if generationMismatch then 0 else cursor
1269 let effectiveCursor = if generationMismatch then 0 else cursor
5967− -- Cursor reset: generation changed (server restarted) and client had a non-zero cursor.
5968− -- Tells the client their cursor was invalidated so they can handle re-delivery.
5969 let cursorWasReset = generationMismatch && cursor > 0
1270 let cursorWasReset = generationMismatch && cursor > 0
5970 let cappedWatchKeys = takeRelation maxWatchKeys watchKeys
1271 let cappedWatchKeys = takeRelation maxWatchKeys watchKeys
5971 dp <- *drainPhase
1272 dp <- *drainPhase
5972− -- Cursor staleness: cursor is older than message retention, so messages were missed.
5973− -- Different from cursorReset (server restart): staleness means client was offline too long.
5974− let cursorStale = effectiveCursor > 0 && t - effectiveCursor > unackedMessageMaxAge
5975 if dp >= 2 then yield (respond {events: [], cursor: 0, authorized: True {}, rateLimited: False {}, draining: True {}, generation: serverGen, presenceUpdates: [], heartbeat: False {}, retryAfterMs: 0, cursorReset: cursorWasReset, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []})
1273 if dp >= 2 then yield (respond {events: [], cursor: 0, authorized: True {}, rateLimited: False {}, draining: True {}, generation: serverGen, presenceUpdates: [], heartbeat: False {}, retryAfterMs: 0, cursorReset: cursorWasReset, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []})
5977− globalRateLimited <- checkGlobalRate t
1275+ g <- checkGlobalRate t
5978− if globalRateLimited then yield (respond {events: [], cursor: 0, authorized: False {}, rateLimited: True {}, draining: False {}, generation: serverGen, presenceUpdates: [], heartbeat: False {}, retryAfterMs: globalRateWindowMs, cursorReset: cursorWasReset, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []})
1276+ if g then yield (respond {events: [], cursor: 0, authorized: False {}, rateLimited: True {}, draining: False {}, generation: serverGen, presenceUpdates: [], heartbeat: False {}, retryAfterMs: globalRateWindowMs, cursorReset: cursorWasReset, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []})
5979− else do
1277+ else case extractToken authorization of
5980− -- Capture presenceVersion before long-poll wait to skip unchanged lookups
1278+ Nothing {} -> yield (respond {events: [], cursor: 0, authorized: False {}, rateLimited: False {}, draining: False {}, generation: serverGen, presenceUpdates: [], heartbeat: False {}, retryAfterMs: 0, cursorReset: cursorWasReset, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []})
5981− startPresenceVersion <- *presenceVersion
1279+ Just {value: token} -> pollOnce token effectiveCursor cursorWasReset cappedWatchKeys clientIp serverGen respond t
5982− result <- case extractToken authorization of
1280+
5983− Nothing {} -> yield {authorized: False {}, events: [], cursor: 0, pendingAcks: [], evictedEntries: [], pubkey: "", pollSlotFull: False {}, hasMore: False {}}
1281+pollOnce = \token cursor cursorWasReset watchKeys clientIp serverGen respond t -> do
5984− Just {value: token} -> pollOnce token effectiveCursor clientIp
1282+ setup <- atomic do
5985− -- Check presence for watched keys (piggybacks on poll cycle; max latency = pollTimeoutMs).
1283+ ses <- *sessions
5986− -- Skip the expensive bucket reads if presenceVersion hasn't changed since poll start.
1284+ case authenticateSession ses token t of
5987− presenceUpdates <- if result.authorized && count cappedWatchKeys > 0 then do
1285+ Unauthorized {} -> yield Nothing {}
5988− currentPresenceVersion <- *presenceVersion
1286+ Authorized {pubkey, ip} ->
5989− if currentPresenceVersion == startPresenceVersion then yield []
1287+ if not (matchIp clientIp ip) then yield Nothing {}
5990− else do
1288+ else do
5991− t2 <- now
1289+ let clampedCursor = clamp 0 t cursor
5992− atomic do
1290+ ackResult <- if clampedCursor > 0 then ackPolledMessages pubkey clampedCursor t else yield {pendingAcks: []}
5993− let neededBuckets = uniqueBucketsFor cappedWatchKeys (\k -> k)
1291+ startWakeup <- *pollWakeup
5994− relevantPresence <- readSelectedPresenceBuckets neededBuckets
1292+ yield (Just {value: {pubkey: pubkey, clampedCursor: clampedCursor, startWakeup: startWakeup, pendingAcks: ackResult.pendingAcks}})
5995− yield (do key <- cappedWatchKeys; yield {pubkey: key, online: count (presenceForKey relevantPresence key t2) > 0})
1293+ case setup of
5996− else yield []
1294+ Nothing {} -> yield (respond {events: [], cursor: 0, authorized: False {}, rateLimited: False {}, draining: False {}, generation: serverGen, presenceUpdates: [], heartbeat: False {}, retryAfterMs: 0, cursorReset: cursorWasReset, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []})
5997− -- Short-circuit: skip fork overhead when there are no pending acks or evicted entries.
1295+ Just {value: s} -> do
5998− -- Every poll with cursor > 0 reaches this path, but most polls have zero acks.
1296+ acquired <- atomic do
5999− when (federationEnabled && (count result.pendingAcks > 0 || count result.evictedEntries > 0))
1297+ aps <- *activePolls
6000− (fork (do
1298+ let perKey = count (do p <- aps; where p.pubkey == s.pubkey; yield p)
6001− sendAcksAndClean result.pendingAcks
1299+ if perKey >= maxPollsPerKey then yield False
6002− retryEvictedAcks result.evictedEntries result.pendingAcks))
1300+ else do
6003− let isHeartbeat = result.authorized && count result.events == 0
1301+ set *activePolls = capList (union aps [{pubkey: s.pubkey, startedAt: t}]) maxActivePolls (\p -> p.startedAt)
6004− -- Deliver message expiration notifications: atomically read and drain expirations
1302+ yield True
6005− -- for this sender's pubkey so each notification is delivered exactly once.
1303+ if not acquired
6006− -- Uses result.pubkey from pollOnce (already authenticated) instead of re-authenticating,
1304+ then yield (respond {events: [], cursor: cursor, authorized: True {}, rateLimited: True {}, draining: False {}, generation: serverGen, presenceUpdates: [], heartbeat: False {}, retryAfterMs: pollTimeoutMs, cursorReset: cursorWasReset, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []})
6007− -- avoiding a redundant safeCompare scan and preventing a race where a concurrent poll
1305+ else do
6008− -- could double-drain or lose expirations between the two separate atomic blocks.
1306+ pollResult <- doPoll s t
6009− expirations <- if not result.authorized || result.pubkey == "" then yield []
1307+ atomic do
6010− else atomic do
1308+ aps <- *activePolls
6011− se <- *senderExpirations
1309+ set *activePolls = do p <- aps; where p.pubkey != s.pubkey; yield p
6012− let forKey = do e <- se; where e.senderKey == result.pubkey; yield {messageId: e.messageId, toKey: e.toKey, expiredAt: e.expiredAt}
1310+ when (federationEnabled && count s.pendingAcks > 0)
6013− let remaining = do e <- se; where e.senderKey != result.pubkey; yield e
1311+ (fork (sendAcksAndClean s.pendingAcks))
6014− set *senderExpirations = remaining
1312+ presenceUpdates <- if count watchKeys > 0 && pollResult.authorized
6015− let capped = takeRelation maxSenderExpirationsPerKey forKey
1313+ then atomic do
6016− yield capped
1314+ t2 <- now
6017− -- Deliver message delivery receipts: atomically read and drain delivery notifications
1315+ pres <- *presence
6018− -- for this sender's pubkey so each receipt is delivered exactly once.
1316+ yield (do k <- watchKeys; yield {pubkey: k, online: count (presenceForKey pres k t2) > 0})
6019− deliveries <- if not result.authorized || result.pubkey == "" then yield []
1317+ else yield []
6020− else atomic do
1318+ drains <- atomic do
6021− sd <- *senderDeliveries
1319+ se <- *senderExpirations
6022− let forKey = do d <- sd; where d.senderKey == result.pubkey; yield {messageId: d.messageId, toKey: d.toKey, deliveredAt: d.deliveredAt}
1320+ let myExp = do x <- se; where x.senderKey == s.pubkey; yield {messageId: x.messageId, toKey: x.toKey, expiredAt: x.expiredAt}
6023− let remaining = do d <- sd; where d.senderKey != result.pubkey; yield d
1321+ set *senderExpirations = do x <- se; where x.senderKey != s.pubkey; yield x
6024− set *senderDeliveries = remaining
1322+ sd <- *senderDeliveries
6025− let capped = takeRelation maxSenderDeliveriesPerKey forKey
1323+ let myDel = do x <- sd; where x.senderKey == s.pubkey; yield {messageId: x.messageId, toKey: x.toKey, deliveredAt: x.deliveredAt}
6026− yield capped
1324+ set *senderDeliveries = do x <- sd; where x.senderKey != s.pubkey; yield x
6027− -- Poll slot exhaustion: signal clients to back off for one poll cycle
1325+ cn <- *cancelNotifications
6028− effPollTimeout <- effectivePollTimeoutMs
1326+ let myCancels = do x <- cn; where x.toKey == s.pubkey; yield {messageId: x.messageId, cancelledAt: x.cancelledAt}
6029− let pollRetryMs = if result.pollSlotFull then effPollTimeout else 0
1327+ set *cancelNotifications = do x <- cn; where x.toKey != s.pubkey; yield x
6030− -- Read and drain per-sender drop counters so this sender knows if their receipts were lost.
1328+ yield {expirations: myExp, deliveries: myDel, cancellations: myCancels}
6031− -- Each sender sees only their own drops (not a global counter conflating all senders).
1329+ let isHeartbeat = pollResult.authorized && count pollResult.events == 0
6032− drops <- if not result.authorized || result.pubkey == "" then yield {dr: 0, de: 0}
1330+ yield (respond {events: pollResult.events, cursor: pollResult.cursor, authorized: pollResult.authorized, rateLimited: False {}, draining: False {}, generation: serverGen, presenceUpdates: presenceUpdates, heartbeat: isHeartbeat, retryAfterMs: 0, cursorReset: cursorWasReset, hasMore: pollResult.hasMore, cursorStale: False {}, messageExpirations: drains.expirations, messageDeliveries: drains.deliveries, droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: drains.cancellations})
6033− else atomic do
1331+
6034− ddr <- *droppedDeliveryReceipts
1332+doPoll = \s t -> do
6035− let drResult = drainDropCounter ddr result.pubkey
1333+ initial <- atomic do
6036− when (drResult.count > 0) (set *droppedDeliveryReceipts = drResult.remaining)
1334+ msgs <- *messages
6037− den <- *droppedExpirationNotifs
1335+ yield (collectPollEvents msgs s.pubkey s.clampedCursor t)
6038− let deResult = drainDropCounter den result.pubkey
1336+ if count initial.events > 0 then yield {authorized: True {}, events: initial.events, cursor: initial.cursor, hasMore: initial.hasMore}
6039− when (deResult.count > 0) (set *droppedExpirationNotifs = deResult.remaining)
1337+ else do
6040− yield {dr: drResult.count, de: deResult.count}
1338+ -- Wait for signal or heartbeat
6041− -- Deliver cancel notifications: messages retracted by the sender, delivered to the
1339+ atomic do
6042− -- recipient so clients can remove them from the UI. Keyed by toKey (recipient pubkey).
1340+ wakeup <- *pollWakeup
6043− cancellations <- if not result.authorized || result.pubkey == "" then yield []
1341+ if wakeup > s.startWakeup then yield {}
6044− else atomic do
1342+ else retry
6045− cn <- *cancelNotifications
1343+ t2 <- now
6046− let forKey = do c <- cn; where c.toKey == result.pubkey; yield {messageId: c.messageId, cancelledAt: c.cancelledAt}
1344+ msgs2 <- *messages
6047− let remaining = do c <- cn; where c.toKey != result.pubkey; yield c
1345+ let r = collectPollEvents msgs2 s.pubkey s.clampedCursor t2
6048− set *cancelNotifications = remaining
1346+ yield {authorized: True {}, events: r.events, cursor: r.cursor, hasMore: r.hasMore}
6049− let capped = takeRelation maxCancelNotificationsPerKey forKey
1347+
6050− yield capped
1348+collectPollEvents = \messages pubkey cursor t ->
6051− -- Expose server load to clients: 0 = healthy (<=80% capacity), up to 90 = near-full.
1349+ let myMsgs = do m <- messages; where m.toKey == pubkey && m.expiresAt > t && m.receivedAt > cursor; yield m in
6052− -- Clients can voluntarily reduce poll frequency or batch sends when loadPct > 0.
1350+ let sorted = sortBy (\m -> m.receivedAt) myMsgs in
6053− loadPct <- do scale <- *cachedAdaptiveScale; yield (if scale >= 100 then 0 else 100 - scale)
1351+ let limited = takeRelation maxPollEvents sorted in
6054− yield (respond {events: result.events, cursor: result.cursor, authorized: result.authorized, rateLimited: result.pollSlotFull, draining: False {}, generation: serverGen, presenceUpdates: presenceUpdates, heartbeat: isHeartbeat, retryAfterMs: pollRetryMs, cursorReset: cursorWasReset, hasMore: result.hasMore, cursorStale: cursorStale, messageExpirations: expirations, messageDeliveries: deliveries, droppedDeliveryReceipts: drops.dr, droppedExpirationNotifs: drops.de, loadPct: loadPct, messageCancellations: cancellations})
1352+ let evts = do m <- limited; yield {id: m.messageId, eventType: "message", payload: {toKey: m.toKey, encryptedBlob: m.encryptedBlob, timestamp: m.timestamp, expiresAt: m.expiresAt}} in
6055−
1353+ let lastReceivedAt = fold (\acc m -> max acc m.receivedAt) cursor limited in
6056−-- Core send logic: dedup, rate limiting, store message, create forwards.
1354+ {events: evts, cursor: lastReceivedAt, hasMore: count myMsgs > count limited}
6057−-- Called inside an atomic block by both handleSendMessage and sendBatchInner.
1355+
6058−-- Caller handles auth, drain checks, and messageId generation.
1356+ackPolledMessages = \pubkey cursor t -> do
6059−-- This function intentionally runs as a single monolithic atomic block:
1357+ msgs <- *messages
6060−-- - Splitting into phases (check → store) introduces TOCTOU gaps that require
1358+ let toAck = do m <- msgs; where m.toKey == pubkey && m.receivedAt <= cursor; yield m
6061−-- re-checking dedup in Phase 2, adding overhead without reducing contention.
1359+ if count toAck == 0 then yield {pendingAcks: []}
6062−-- - Rate limits committed in Phase 1 would be wasted if Phase 2 denies (dedup).
1360+ else do
6063−-- - sendBatchBucketGroup depends on consistent state across messages in the same
1361+ set *messages = do m <- msgs; where not (m.toKey == pubkey && m.receivedAt <= cursor); yield m
6064−-- bucket group (each call sees the previous call's writes).
1362+ fwds <- *forwards
6065−-- - 16-way bucket sharding already limits contention to 1/16 of concurrent senders;
1363+ let mids = do m <- toAck; yield m.messageId
6066−-- further splitting yields marginal benefit.
1364+ set *forwards = do f <- fwds; where not (f.toKey == pubkey && any mids (\mid -> mid == f.messageId)); yield f
6067−sendMessageCore = \senderKey to encryptedBlob clampedTs effectiveMsgId expiresInMs msgPriority t ->
1365+ let ackedFederated = do m <- toAck; where m.originServer != ""; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
6068− if senderKey == to then yield {status: MsRejected {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
1366+ aids <- *ackedIds
1367+ set *ackedIds = capList (union aids ackedFederated) maxAckedIds (\a -> a.ackedAt)
1368+ -- Sender delivery receipts for locally-originated messages
1369+ let localDelivered = do m <- toAck; where m.senderKey != "" && m.originServer == ""; yield {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, deliveredAt: t}
1370+ sd <- *senderDeliveries
1371+ set *senderDeliveries = capList (union sd localDelivered) 10000 (\d -> d.deliveredAt)
1372+ yield {pendingAcks: ackedFederated}
1374+-- ============================================
1376+-- ============================================
1378+handleSendMessage = \to encryptedBlob timestamp messageId expiresInMs priority authorization clientIp respond -> do
1379+ let clampedPriority = clamp 0 maxMessagePriority priority
1382+ if dp >= 2 then yield (respond {status: MsDraining {}, messageId: "", retryAfterMs: 0, error: "draining", loadPct: 0})
6070− let msgBucket = pubkeyBucket to
1384+ g <- checkGlobalRate t
6071− bucket <- readMessageBucket msgBucket
1385+ if g then yield (respond {status: MsRateLimited {}, messageId: "", retryAfterMs: 0, error: "rate_limited", loadPct: 0})
6072− ackedBkt <- readAckedBucket msgBucket
1386+ else do
6073− delivBkt <- readDelivBucket msgBucket
1387+ effMsgId <- if messageId != "" then yield messageId else genToken
6074− -- Nonce check closes the dedup gap between message expiry (30 days) and nonce retention
1388+ if t - timestamp > messageMaxAge
6075− -- (60 days): without this, a client could replay a messageId after messages/ackedIds/deliveredIds
1389+ then yield (respond {status: MsRejected {}, messageId: "", retryAfterMs: 0, error: "stale_timestamp", loadPct: 0})
6076− -- expire but before the nonce expires.
1390+ else do
6077− nonceBkt <- readNonceBucket msgBucket
1391+ let clampedTs = clampTimestamp timestamp t
6078− let isDup = checkMessageDup bucket effectiveMsgId to || hasMessage effectiveMsgId to ackedBkt || hasMessage effectiveMsgId to delivBkt || any nonceBkt (\n -> n.messageId == effectiveMsgId && n.toKey == to)
1392+ result <- atomic do
6079− if isDup then yield {status: MsDuplicate {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
1393+ withSessionAuth authorization t clientIp
1394+ (yield {status: MsUnauthorized {}, remoteServers: []})
1395+ (\senderKey -> sendMessageCore senderKey to encryptedBlob clampedTs effMsgId expiresInMs clampedPriority t)
1396+ forkSendForwards effMsgId to encryptedBlob clampedTs result.remoteServers
1397+ yield (case result.status of
1398+ MsDuplicate {} -> respond {status: MsDuplicate {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}
1399+ MsDelivered {} -> respond {status: MsDelivered {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}
1400+ MsFederated {} -> respond {status: MsFederated {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}
1401+ MsQueued {} -> respond {status: MsQueued {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}
1402+ _ -> respond {status: result.status, messageId: "", retryAfterMs: 0, error: "rejected", loadPct: 0})
1404+sendMessageCore = \senderKey to encryptedBlob clampedTs effMsgId expiresInMs msgPriority t ->
1405+ if senderKey == to then yield {status: MsRejected {}, remoteServers: []}
1409+ dids <- *deliveredIds
1410+ let isDup = (effMsgId != "" && any msgs (\m -> m.messageId == effMsgId && m.toKey == to))
1411+ || hasMessage effMsgId to aids
1412+ || hasMessage effMsgId to dids
1413+ if isDup then yield {status: MsDuplicate {}, remoteServers: []}
6081 sendRates <- *sendRates
1415 sendRates <- *sendRates
6082− sendRate <- effectiveSendRate
1416+ let sr = checkRate sendRates senderKey maxSendRatePerKey sendRateWindowMs 5000 t
6083− let rateResult = checkPubkeyRate sendRates senderKey sendRate sendRateWindowMs maxSendRateEntries t
1417+ if sr.limited then yield {status: MsRateLimited {}, remoteServers: []}
6084− if rateResult.limited then yield {status: MsRateLimited {}, remoteServers: [], retryAfterMs: rateResult.retryAfterMs, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
6086− set *sendRates = rateResult.entries
1419+ set *sendRates = sr.entries
6087 pairRates <- *pairRates
1420 pairRates <- *pairRates
6088− pRate <- effectivePairRate
1421+ let pr = checkRate pairRates (senderKey ++ "|" ++ to) maxPairRatePerPair pairRateWindowMs 5000 t
6089− let pairResult = checkPairRate pairRates senderKey to pRate pairRateWindowMs maxPairRateEntries t
1422+ set *pairRates = pr.entries
6090− set *pairRates = pairResult.entries
1423+ if pr.limited then yield {status: MsRateLimited {}, remoteServers: []}
6091− if pairResult.limited then yield {status: MsRateLimited {}, remoteServers: [], retryAfterMs: pairResult.retryAfterMs, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
6093 recvRates <- *recvRates
1425 recvRates <- *recvRates
6094− recvRate <- effectiveRecvRate
1426+ let rr = checkRate recvRates to maxRecvRatePerKey recvRateWindowMs 5000 t
6095− let recvResult = checkPubkeyRate recvRates to recvRate recvRateWindowMs maxRecvRateEntries t
1427+ if rr.limited then yield {status: MsRateLimited {}, remoteServers: []}
6096− if recvResult.limited then yield {status: MsRateLimited {}, remoteServers: [], retryAfterMs: recvResult.retryAfterMs, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
6098− set *recvRates = recvResult.entries
1429+ set *recvRates = rr.entries
6099− totalMsgCount <- *totalMessageCount
1430+ if count msgs >= maxMessages then yield {status: MsRejected {}, remoteServers: []}
6100− if totalMsgCount >= maxMessages then yield {status: MsRejected {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
1431+ else
6101− else do
1432+ let recipientCount = count (do m <- msgs; where m.toKey == to; yield m) in
6102− recipientCounts <- readRcBucket msgBucket
1433+ if recipientCount >= maxMessagesPerRecipient then yield {status: MsQueued {}, remoteServers: []}
6103− let recipientCount = getRecipientCount to recipientCounts
6104− -- Return MsQueued (not MsRejected) for per-recipient capacity: prevents
6105− -- an attacker from probing mailbox fullness for arbitrary pubkeys. Global
6106− -- capacity still returns MsRejected since it's not per-recipient.
6107− effMaxPerRecipient <- effectiveMaxMessagesPerRecipient
6108− if recipientCount >= effMaxPerRecipient then yield {status: MsQueued {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
6110− recipientPresence <- readPresenceBucket (pubkeyBucket to)
1435+ pres <- *presence
6111− seqCounter <- *seqCounter
1436+ seq <- *seqCounter
6112− let seqTs = nextSeqTs t seqCounter
1437+ let seqTs = nextSeqTs t seq
6113 set *seqCounter = seqTs
1438 set *seqCounter = seqTs
6114− let msgExpiresAt = seqTs + effectiveMessageTtl expiresInMs
1439+ let expiresAt = seqTs + effectiveMessageTtl expiresInMs
6115− writeMessageBucket msgBucket (union bucket
1440+ set *messages = union msgs [{messageId: effMsgId, toKey: to, encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs, expiresAt: expiresAt, senderKey: senderKey, priority: msgPriority}]
6116− [{messageId: effectiveMsgId, toKey: to,
1441+ set *pollWakeup = seqTs
6117− encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs, expiresAt: msgExpiresAt, senderKey: senderKey, priority: msgPriority}])
1442+ let toPresence = presenceForKey pres to t
6118− set *totalMessageCount = totalMsgCount + 1
1443+ let localOnline = any toPresence (\p -> isLocalServer p.server)
6119− writeRcBucket msgBucket (adjustRecipientCount recipientCounts to 1)
1444+ let remoteServers = collectPeers toPresence (\p -> p.server)
6120− signalMessageForKey to seqTs
1445+ forwardsEnqueued <- if federationEnabled && count remoteServers > 0
6121− -- Record forward nonce for locally-originated messages: prevents replay
1446+ then do
6122− -- if the message expires from messages/ackedIds/deliveredIds and a federation
1447+ fwds <- *forwards
6123− -- peer forwards it back. Without this, the nonce check in handleForwardMessage
1448+ let newFwds = do s <- remoteServers; where none fwds (\f -> f.messageId == effMsgId && f.toServer == s); yield {messageId: effMsgId, toServer: s, createdAt: t, toKey: to, encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: serverHostN, retries: 0, expiresAt: expiresAt, priority: msgPriority, senderKey: senderKey}
6124− -- would miss locally-originated messages entirely.
1449+ set *forwards = capList (union fwds newFwds) maxForwardsEntries (\f -> f.createdAt)
6125− -- Inlined: calls updateForwardNonce directly instead of recordForwardNonce
1450+ yield (count newFwds > 0)
6126− -- to avoid nested atomic block. Eviction info is returned for deferred logging.
1451+ else yield False
6127− nonceResult <- updateForwardNonce msgBucket effectiveMsgId to t
6128− let toPresence = presenceForKey recipientPresence to t
6129− let localOnline = hasLocalPresence toPresence
6130− let remoteServers = collectPeerServers toPresence (\p -> p.server)
6131− let forwardsEnqueued = if federationEnabled && count remoteServers > 0 then do
6132− let fbi = pubkeyBucket to
6133− fwdBkt <- readFwdBucket fbi
6134− -- Single-pass forward bucket analysis: computes per-server dedup/count,
6135− -- per-key count, and per-sender-per-key count in one fold over fwdBkt.
6136− -- Replaces 4 separate scans (2 per server + 2 global) with a single traversal.
6137− let fwdStats = fold (\acc f ->
6138− let toKeyMatch = f.toKey == to in
6139− {keyCount: if toKeyMatch then acc.keyCount + 1 else acc.keyCount,
6140− senderKeyCount: if senderKey != "" && toKeyMatch && f.senderKey == senderKey then acc.senderKeyCount + 1 else acc.senderKeyCount,
6141− perServer: do ps <- acc.perServer; yield (if f.toServer == ps.server then {server: ps.server, count: ps.count + 1, hasDup: ps.hasDup || f.messageId == effectiveMsgId} else ps)})
6142− {keyCount: 0, senderKeyCount: 0, perServer: do s <- remoteServers; yield {server: s, count: 0, hasDup: False {}}}
6144− let newFwds = do ps <- fwdStats.perServer; where not ps.hasDup && ps.count < maxForwardsPerServer; yield {messageId: effectiveMsgId, toServer: ps.server, createdAt: t, toKey: to, encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: serverHostN, retries: 0, expiresAt: msgExpiresAt, priority: msgPriority, senderKey: senderKey}
6145− totalFwdCount <- *totalForwardCount
6146− let globalCap = maxForwardsEntries - totalFwdCount
6147− let keyCap = maxForwardsPerKey - fwdStats.keyCount
6148− let senderKeyCap = if senderKey != "" && fwdStats.senderKeyCount >= maxForwardsPerSenderPerKey then 0 else min globalCap keyCap
6149− let cappedFwds = takeRelation senderKeyCap newFwds
6150− writeFwdBucket fbi (union fwdBkt cappedFwds)
6151− set *totalForwardCount = totalFwdCount + count cappedFwds
6152− -- Return whether any forwards were actually enqueued (vs dropped by capacity cap)
6153− yield (count cappedFwds > 0)
6154− else yield (False {})
6155 let status = if localOnline then MsDelivered {}
1452 let status = if localOnline then MsDelivered {}
6156− else if federationEnabled && forwardsEnqueued then MsFederated {}
1453+ else if forwardsEnqueued then MsFederated {}
6157 else MsQueued {}
1454 else MsQueued {}
6158− yield {status: status, remoteServers: remoteServers, retryAfterMs: 0, nonceBucket: msgBucket, nonceEvicted: nonceResult.lruEvicted, nonceOldestAge: nonceResult.oldestRetainedAge}
1455+ yield {status: status, remoteServers: remoteServers}
6160−-- Fork federation forwards for messages that need to be delivered to remote servers.
6161−forkSendForwards = \effectiveMsgId to encryptedBlob clampedTs remoteServers ->
6162− when (count remoteServers > 0 && federationEnabled) (
6163− fork (sendToEach remoteServers (\server -> do
6164− fwdInfo <- atomic do
6165− fwdBkt <- readFwdBucket (pubkeyBucket to)
6166− case headOf (do f <- fwdBkt; where f.messageId == effectiveMsgId && f.toServer == server; yield f) of
6167− Nothing {} -> yield {pending: False {}, fwdExpiresAt: 0, fwdPriority: 0}
6168− Just {value: fe} -> yield {pending: True {}, fwdExpiresAt: fe.expiresAt, fwdPriority: fe.priority}
6169− when fwdInfo.pending (do
6171− fwdAuth <- generateFederationAuth ("forward:" ++ effectiveMsgId) fwdT
6172− fwdCorrId <- genTokenN 1
6173− fwdResult <- fetchFederation server (ForwardMessage {
6174− toKey: to, encryptedBlob: encryptedBlob,
6175− timestamp: clampedTs, originServer: serverHostN, messageId: effectiveMsgId,
6176− fromServer: serverHostN, requestTimestamp: fwdT,
6177− authorization: fwdAuth, correlationId: fwdCorrId,
6178− expiresAt: fwdInfo.fwdExpiresAt, priority: fwdInfo.fwdPriority, protocolVersion: federationProtocolVersion})
6181− logKV "warn" "federation_forward_failed" ["server=" ++ server, "messageId=" ++ effectiveMsgId, "error=" ++ show e]
6182− recordFailure server
6184− if response.ok then do
6185− removeForward effectiveMsgId server to
6186− clearFailure server
6188− logKV "warn" "federation_forward_rejected" ["server=" ++ server, "messageId=" ++ effectiveMsgId, "error=" ++ response.error]))))
6190−-- Send all batch forwards for one server using FederationBatchForward (1 HTTP round-trip).
6191−-- Used by handleSendBatch; reduces both fork count (O(servers) not O(messages * servers))
6192−-- and HTTP round-trips (1 per server not 1 per message).
6193−-- Falls back to individual ForwardMessage if the peer rejects the batch (old peer without
6194−-- batch support), same as retryForwardsForServer.
6195−-- Pre-filters to still-pending forwards: concurrent poll/ack between message creation
6196−-- and this forked send may have already removed the forward entry.
6197−sendBatchForwardsSequential = \msgs server ->
6198− if count msgs == 0 then yield {}
6200− -- Filter to messages still pending in forward buckets
6201− pending <- filterPendingBatchForwards msgs server []
6202− if count pending == 0 then yield {}
6205− auth <- generateFederationAuth "forward-batch" t
6206− corrId <- genTokenN 1
6207− let batchPayload = do r <- pending; yield {toKey: r.toKey, encryptedBlob: r.blob, timestamp: r.ts, originServer: serverHostN, messageId: r.messageId, expiresAt: r.fwdExpiresAt, priority: r.fwdPriority}
6208− result <- fetchFederation server (FederationBatchForward {
6209− forwards: batchPayload, fromServer: serverHostN,
6210− requestTimestamp: t, authorization: auth, correlationId: corrId, protocolVersion: federationProtocolVersion})
6213− logKV "warn" "federation_batch_forward_failed" ["server=" ++ server, "batchSize=" ++ show (count pending), "error=" ++ show e]
6214− recordFailure server
6216− if response.ok then do
6217− clearFailure server
6218− processBatchForwardResults pending response.results server
6220− logKV "warn" "federation_batch_forward_rejected" ["server=" ++ server, "error=" ++ response.error]
6221− -- Fall back to individual forwards (old peer without /federation/forward-batch)
6222− sendBatchForwardsFallback pending server
6224−-- Filter batch messages to those still pending in forward buckets.
1457+forkSendForwards = \effMsgId to encryptedBlob clampedTs remoteServers ->
6225−-- Concurrent poll/ack may have removed the forward entry between creation and send.
1458+ when (count remoteServers > 0 && federationEnabled)
6226−filterPendingBatchForwards = \msgs server acc ->
1459+ (fork (forkForwardsTo effMsgId to encryptedBlob clampedTs remoteServers))
6227− case headOf msgs of
1460+
6228− Nothing {} -> yield acc
1461+forkForwardsTo = \effMsgId to encryptedBlob clampedTs servers ->
6229− Just {value: r} -> do
1462+ case headOf servers of
6230− let rest = do m <- msgs; where m.messageId != r.messageId; yield m
6231− stillPending <- atomic do
6232− fwdBkt <- readFwdBucket (pubkeyBucket r.toKey)
6233− yield (any fwdBkt (\f -> f.messageId == r.messageId && f.toServer == server))
6234− filterPendingBatchForwards rest server (if stillPending then union acc [r] else acc)
6236−-- Process per-message results from a batch forward response (initial send path).
6237−-- Removes succeeded forward entries; logs rejections (no retry increment on initial send —
6238−-- the background prune cycle handles retries with proper backoff).
6239−processBatchForwardResults = \pending results server ->
6240− case headOf pending of
6241 Nothing {} -> yield {}
1463 Nothing {} -> yield {}
6242− Just {value: r} -> do
1464+ Just {value: server} -> do
6243− let rest = do m <- pending; where m.messageId != r.messageId; yield m
1465+ let rest = do s <- servers; where s != server; yield s
6244− let msgResult = headOf (do res <- results; where res.messageId == r.messageId; yield res)
1466+ info <- atomic do
6245− case msgResult of
1467+ fwds <- *forwards
6246− Just {value: res} ->
1468+ case headOf (do f <- fwds; where f.messageId == effMsgId && f.toServer == server; yield f) of
6247− when res.ok (removeForward r.messageId server r.toKey)
1469+ Nothing {} -> yield Nothing {}
1470+ Just {value: f} -> yield (Just {value: {expiresAt: f.expiresAt, priority: f.priority}})
6248 Nothing {} -> yield {}
1472 Nothing {} -> yield {}
6249− processBatchForwardResults rest results server
1473+ Just {value: i} -> do
1475+ auth <- generateFederationAuth ("forward:" ++ effMsgId) t
1476+ result <- fetch (federationUrl server) (ForwardMessage {
1477+ toKey: to, encryptedBlob: encryptedBlob,
1478+ timestamp: clampedTs, originServer: serverHostN, messageId: effMsgId,
1479+ fromServer: serverHostN, requestTimestamp: t,
1480+ authorization: auth, correlationId: "",
1481+ expiresAt: i.expiresAt, priority: i.priority, protocolVersion: federationProtocolVersion})
1483+ Err _ -> recordFailure server
1486+ clearFailure server
1489+ set *forwards = do f <- fwds; where not (f.messageId == effMsgId && f.toServer == server); yield f
1491+ forkForwardsTo effMsgId to encryptedBlob clampedTs rest
6251−-- Fallback: send forwards individually when batch forward is rejected (old peer).
1493+-- ============================================
6252−-- Same logic as the original sequential path but only runs when batch fails.
1494+-- Handler: lookup
6253−sendBatchForwardsFallback = \msgs server ->
1495+-- ============================================
6254− case headOf msgs of
6255− Nothing {} -> yield {}
6256− Just {value: r} -> do
6257− let rest = do m <- msgs; where m.messageId != r.messageId; yield m
6259− fwdAuth <- generateFederationAuth ("forward:" ++ r.messageId) fwdT
6260− fwdCorrId <- genTokenN 1
6261− fwdResult <- fetchFederation server (ForwardMessage {
6262− toKey: r.toKey, encryptedBlob: r.blob,
6263− timestamp: r.ts, originServer: serverHostN, messageId: r.messageId,
6264− fromServer: serverHostN, requestTimestamp: fwdT,
6265− authorization: fwdAuth, correlationId: fwdCorrId,
6266− expiresAt: r.fwdExpiresAt, priority: r.fwdPriority, protocolVersion: federationProtocolVersion})
6269− logKV "warn" "federation_forward_failed" ["server=" ++ server, "messageId=" ++ r.messageId, "error=" ++ show e]
6270− recordFailure server
6272− if response.ok then do
6273− removeForward r.messageId server r.toKey
6274− clearFailure server
6276− logKV "warn" "federation_forward_rejected" ["server=" ++ server, "messageId=" ++ r.messageId, "error=" ++ response.error]
6277− sendBatchForwardsFallback rest server
6279−-- POST /messages: Send an encrypted message to a recipient.
1497+handleLookupPresence = \pubkey authorization clientIp respond -> do
6280−-- Deduplicates by messageId across messages, ackedIds, and deliveredIds.
6281−-- Rate-limited per sender key. If recipient is known on a remote server, forwards via federation.
6282−handleSendMessage = \to encryptedBlob timestamp messageId expiresInMs priority authorization clientIp respond -> do
6283− let clampedPriority = clamp 0 maxMessagePriority priority
6284 t <- now
1498 t <- now
6285− dp <- *drainPhase
1499+ g <- checkGlobalRate t
6286− if dp >= 2 then yield (respond {status: MsDraining {}, messageId: "", retryAfterMs: 0, error: "draining", loadPct: 0})
1500+ if g then yield (respond {server: "", authorized: False {}, error: "rate_limited"})
6287− else do
1501+ else withSessionAuth authorization t clientIp
6288− globalRateLimited <- checkGlobalRate t
1502+ (yield (respond {server: "", authorized: False {}, error: ""}))
6289− if globalRateLimited then yield (respond {status: MsRateLimited {}, messageId: "", retryAfterMs: 0, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms", loadPct: 0})
1503+ (\senderKey -> do
6290− else do
1504+ lim <- checkPubkeyRateGate lookupRates senderKey maxLookupRatePerKey lookupRateWindowMs t
6291− effectiveMsgId <- if messageId != "" then yield messageId else genToken
1505+ if lim then yield (respond {server: "", authorized: True {}, error: "rate_limited"})
6292− if t - timestamp > messageMaxAge
6293− then yield (respond {status: MsRejected {}, messageId: "", retryAfterMs: 0, error: "stale_timestamp", loadPct: 0})
6295− when (timestamp > t + clockSkewTolerance)
1507+ pres <- *presence
6296− (logWarn ("sendMessage: future timestamp detected (+" ++ show (timestamp - t) ++ "ms ahead), clamping to now"))
1508+ let found = bestServerForKey (presenceForKey pres pubkey t)
6297− when (timestamp < t - messageMaxAge / 2)
1509+ let masked = if found == "" then "" else if isLocalServer found then found else "remote"
6298− (logWarn ("sendMessage: stale timestamp (" ++ show ((t - timestamp) / 86400000) ++ " days old) for " ++ effectiveMsgId))
1510+ yield (respond {server: masked, authorized: True {}, error: ""}))
6299− let clampedTs = clampTimestamp timestamp t
1511+
6300− result <- atomic do
1512+handleBatchLookupPresence = \pubkeys authorization clientIp respond -> do
6301− withSessionAuth authorization t clientIp
1513+ t <- now
6302− (yield {status: MsUnauthorized {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0})
1514+ g <- checkGlobalRate t
6303− (\senderKey -> sendMessageCore senderKey to encryptedBlob clampedTs effectiveMsgId expiresInMs clampedPriority t)
1515+ if g then yield (respond {results: [], authorized: False {}, error: "rate_limited"})
6304− -- Deferred nonce eviction logging (outside atomic block to avoid holding the lock during IO)
1516+ else withSessionAuth authorization t clientIp
6305− logNonceEviction result.nonceBucket result.nonceEvicted result.nonceOldestAge
1517+ (yield (respond {results: [], authorized: False {}, error: ""}))
6306− case result.status of
1518+ (\senderKey -> do
6307− MsRateLimited {} -> logEvent "warn" "rate_limited_send" ("messageId=" ++ effectiveMsgId)
1519+ lim <- checkPubkeyRateGate lookupRates senderKey maxLookupRatePerKey lookupRateWindowMs t
6308− MsRejected {} -> when (result.retryAfterMs == 0) (logWarn ("sendMessage: rejected for " ++ effectiveMsgId ++ " (global capacity full)"))
1520+ if lim then yield (respond {results: [], authorized: True {}, error: "rate_limited"})
6309− _ -> yield {}
1521+ else do
6310− forkSendForwards effectiveMsgId to encryptedBlob clampedTs result.remoteServers
1522+ let capped = takeRelation 50 pubkeys
6311− loadPct <- do scale <- *cachedAdaptiveScale; yield (if scale >= 100 then 0 else 100 - scale)
1523+ pres <- *presence
6312− yield (case result.status of
1524+ let results = do
6313− MsDuplicate {} -> respond {status: MsDuplicate {}, messageId: effectiveMsgId, retryAfterMs: 0, error: "", loadPct: loadPct}
1525+ k <- capped
6314− MsDelivered {} -> respond {status: MsDelivered {}, messageId: effectiveMsgId, retryAfterMs: 0, error: "", loadPct: loadPct}
1526+ let found = bestServerForKey (presenceForKey pres k t)
6315− MsFederated {} -> respond {status: MsFederated {}, messageId: effectiveMsgId, retryAfterMs: 0, error: "", loadPct: loadPct}
1527+ let masked = if found == "" then "" else if isLocalServer found then found else "remote"
6316− MsQueued {} -> respond {status: MsQueued {}, messageId: effectiveMsgId, retryAfterMs: 0, error: "", loadPct: loadPct}
1528+ yield {pubkey: k, server: masked}
6317− _ -> respond {status: result.status, messageId: "", retryAfterMs: result.retryAfterMs, error: "rejected", loadPct: loadPct})
1529+ yield (respond {results: results, authorized: True {}, error: ""}))
6319−-- GET /lookup/:pubkey: Look up the best known server for a pubkey.
1531+handleMessageStatus = \to messageId authorization clientIp respond -> do
6320−-- Returns local server if key is online locally, otherwise the remote with latest expiry.
1532+ t <- now
6321−handleLookupPresence = \pubkey authorization clientIp respond -> do
1533+ g <- checkGlobalRate t
1534+ if g then yield (respond {status: "", authorized: False {}})
1535+ else withSessionAuth authorization t clientIp
1536+ (yield (respond {status: "", authorized: False {}}))
1541+ dids <- *deliveredIds
1542+ let s = if any msgs (\m -> m.messageId == messageId && m.toKey == to) then "pending"
1543+ else if any fwds (\f -> f.messageId == messageId && f.toKey == to) then "forwarding"
1544+ else if hasMessage messageId to aids || hasMessage messageId to dids then "delivered"
1546+ yield (respond {status: s, authorized: True {}}))
1548+-- ============================================
1549+-- Handler: ack / list / delete / cancel
1550+-- ============================================
1552+handleAckMessages = \messageIds authorization clientIp respond -> do
6322 t <- now
1553 t <- now
6323− globalRateLimited <- checkGlobalRate t
1554+ dp <- *drainPhase
6324− if globalRateLimited then yield (respond {server: "", authorized: False {}, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
1555+ if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "draining"})
6326− result <- atomic do
1557+ g <- checkGlobalRate t
6327− dp <- *drainPhase
1558+ if g then yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "rate_limited"})
6328− if dp >= 2 then yield {server: "", authorized: False {}, error: ""}
1559+ else withSessionAuth authorization t clientIp
6329− else withSessionAuth authorization t clientIp
1560+ (yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "unauthorized"}))
6330− (yield {server: "", authorized: False {}, error: ""})
1561+ (\pubkey -> do
6331− (\senderKey -> do
1562+ lim <- checkPubkeyRateGate clientWriteRates pubkey maxClientWriteRatePerKey clientWriteRateWindowMs t
6332− lookupRates <- *lookupRates
1563+ if lim then yield (respond {ok: False {}, authorized: True {}, ackedCount: 0, error: "rate_limited"})
6333− lkRate <- effectiveLookupRate
1564+ else do
6334− let rateResult = checkPubkeyRate lookupRates senderKey lkRate lookupRateWindowMs maxLookupRateEntries t
1565+ let dedupedIds = dedupMessageIds messageIds
6335− set *lookupRates = rateResult.entries
1566+ result <- atomic do
6336− if rateResult.limited
1567+ msgs <- *messages
6337− then yield {server: "", authorized: True {}, error: "rate_limited:" ++ show lookupRateWindowMs ++ "ms"}
1568+ let toAck = do m <- msgs; where m.toKey == pubkey && any dedupedIds (\mid -> m.messageId == mid); yield m
1569+ if count toAck == 0 then yield {ackedCount: 0, pendingAcks: []}
6339− -- Hot path: read only the target key's presence bucket
1571+ set *messages = do m <- msgs; where not (m.toKey == pubkey && any dedupedIds (\mid -> m.messageId == mid)); yield m
6340− lookupBkt <- readPresenceBucket (pubkeyBucket pubkey)
1572+ fwds <- *forwards
6341− let foundServer = bestServerForKey (presenceForKey lookupBkt pubkey t)
1573+ set *forwards = do f <- fwds; where not (f.toKey == pubkey && any dedupedIds (\mid -> f.messageId == mid)); yield f
6342− -- Mask remote server names: clients only need to know local/remote/unknown,
1574+ let ackedFed = do m <- toAck; where m.originServer != ""; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
6343− -- not which specific peer server a key is homed on (prevents metadata leakage)
1575+ aids <- *ackedIds
6344− let maskedServer = if foundServer == "" then "" else if isLocalServer foundServer then foundServer else "remote"
1576+ set *ackedIds = capList (union aids ackedFed) maxAckedIds (\a -> a.ackedAt)
6345− yield {server: maskedServer, authorized: True {}, error: ""})
1577+ let localDelivered = do m <- toAck; where m.senderKey != "" && m.originServer == ""; yield {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, deliveredAt: t}
6346− yield (respond {server: result.server, authorized: result.authorized, error: result.error})
1578+ sd <- *senderDeliveries
6347−
1579+ set *senderDeliveries = capList (union sd localDelivered) 10000 (\d -> d.deliveredAt)
6348−-- POST /lookup/batch: Look up presence for multiple pubkeys in one request.
1580+ yield {ackedCount: count toAck, pendingAcks: ackedFed}
6349−-- Reads only the needed presence buckets (not all 16), reducing round trips
1581+ fork (when federationEnabled (sendAcksAndClean result.pendingAcks))
6350−-- vs sequential single-key lookups. Uses one rate limit check for the whole batch.
1582+ yield (respond {ok: True {}, authorized: True {}, ackedCount: result.ackedCount, error: ""}))
6351−handleBatchLookupPresence = \pubkeys authorization clientIp respond -> do
1583+
1584+handleListMessages = \offset authorization clientIp respond -> do
6352 t <- now
1585 t <- now
6353− globalRateLimited <- checkGlobalRate t
1586+ dp <- *drainPhase
6354− if globalRateLimited then yield (respond {results: [], authorized: False {}, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
1587+ if dp >= 2 then yield (respond {messages: [], authorized: False {}, count: 0, error: ""})
6356− dp <- *drainPhase
1589+ g <- checkGlobalRate t
6357− if dp >= 2 then yield (respond {results: [], authorized: False {}, error: ""})
1590+ if g then yield (respond {messages: [], authorized: False {}, count: 0, error: "rate_limited"})
6358− else
1591+ else withSessionAuth authorization t clientIp
6359− withSessionAuth authorization t clientIp
1592+ (yield (respond {messages: [], authorized: False {}, count: 0, error: ""}))
6360− (yield (respond {results: [], authorized: False {}, error: ""}))
1593+ (\pubkey -> do
6361− (\senderKey -> do
1594+ lim <- checkPubkeyRateGate lookupRates pubkey maxLookupRatePerKey lookupRateWindowMs t
6362− lookupRateLimited <- atomic do
1595+ if lim then yield (respond {messages: [], authorized: True {}, count: 0, error: "rate_limited"})
6363− lookupRates <- *lookupRates
1596+ else do
6364− lkRate <- effectiveLookupRate
1597+ msgs <- *messages
6365− let rateResult = checkPubkeyRate lookupRates senderKey lkRate lookupRateWindowMs maxLookupRateEntries t
1598+ let myMsgs = sortBy (\m -> m.receivedAt) (do m <- msgs; where m.toKey == pubkey && m.expiresAt > t; yield m)
6366− set *lookupRates = rateResult.entries
1599+ let total = count myMsgs
6367− yield rateResult.limited
1600+ let effectiveOffset = clamp 0 total offset
6368− if lookupRateLimited then yield (respond {results: [], authorized: True {}, error: "rate_limited:" ++ show lookupRateWindowMs ++ "ms"})
1601+ let after = skipN effectiveOffset myMsgs
6369− else do
1602+ let capped = takeRelation maxPollEvents after
6370− -- Deduplicate input pubkeys to avoid redundant presence bucket reads
1603+ let result = do m <- capped; yield {messageId: m.messageId, timestamp: m.timestamp, receivedAt: m.receivedAt}
6371− -- (a client could send 50 copies of the same pubkey, each triggering a scan)
1604+ yield (respond {messages: result, authorized: True {}, count: total, error: ""}))
6372− let dedupedKeys = fold (\acc k -> if any acc (\a -> a == k) then acc else union acc [k]) [] pubkeys
1605+
6373− let cappedKeys = takeRelation maxBatchLookupKeys dedupedKeys
1606+skipN = \n items ->
6374− result <- atomic do
1607+ let r = fold (\acc x -> if acc.skipped < n then {skipped: acc.skipped + 1, result: acc.result} else {skipped: acc.skipped, result: union acc.result [x]}) {skipped: 0, result: []} items
6375− let neededBuckets = uniqueBucketsFor cappedKeys (\k -> k)
1608+ in r.result
6376− relevantPresence <- readSelectedPresenceBuckets neededBuckets
1609+
6377− yield (do key <- cappedKeys; yield (
1610+handleDeleteMessages = \messageIds authorization clientIp respond -> do
6378− let foundServer = bestServerForKey (presenceForKey relevantPresence key t)
6379− in let maskedServer = if foundServer == "" then "" else if isLocalServer foundServer then foundServer else "remote"
6380− in {pubkey: key, server: maskedServer}))
6381− yield (respond {results: result, authorized: True {}, error: ""}))
6383−-- POST /messages/status: Check delivery status of a previously sent message.
6384−-- Caller must provide both messageId and recipient pubkey (proves they know the recipient).
6385−-- Returns: "pending" (in mailbox), "forwarding" (federation in progress),
6386−-- "delivered" (acked by recipient), "unknown" (expired or never existed).
6387−handleMessageStatus = \to messageId authorization clientIp respond -> do
6388 t <- now
1611 t <- now
6389 dp <- *drainPhase
1612 dp <- *drainPhase
6390− if dp >= 2 then yield (respond {status: "", authorized: False {}})
1613+ if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: ""})
6392− globalRateLimited <- checkGlobalRate t
1615+ g <- checkGlobalRate t
6393− if globalRateLimited then yield (respond {status: "", authorized: False {}})
1616+ if g then yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "rate_limited"})
6394− else
1617+ else withSessionAuth authorization t clientIp
6395− withSessionAuth authorization t clientIp
1618+ (yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "unauthorized"}))
6396− (yield (respond {status: "", authorized: False {}}))
1619+ (\pubkey -> do
6397− (\senderKey -> do
1620+ lim <- checkPubkeyRateGate clientWriteRates pubkey maxClientWriteRatePerKey clientWriteRateWindowMs t
6398− -- Per-key rate limiting (reuses lookup rate limiter — both are info lookups)
1621+ if lim then yield (respond {ok: False {}, authorized: True {}, deletedCount: 0, error: "rate_limited"})
6399− statusRateLimited <- atomic do
6400− lookupRates <- *lookupRates
6401− lkRate <- effectiveLookupRate
6402− let rateResult = checkPubkeyRate lookupRates senderKey lkRate lookupRateWindowMs maxLookupRateEntries t
6403− set *lookupRates = rateResult.entries
6404− yield rateResult.limited
6405− if statusRateLimited then yield (respond {status: "", authorized: True {}})
1623+ let dedupedIds = dedupMessageIds messageIds
6407 result <- atomic do
1624 result <- atomic do
6408− let msgBucket = pubkeyBucket to
1625+ msgs <- *messages
6409− bucket <- readMessageBucket msgBucket
1626+ let toDel = do m <- msgs; where m.toKey == pubkey && any dedupedIds (\mid -> mid == m.messageId); yield m
6410− -- Check if message is still in mailbox (pending delivery)
1627+ if count toDel == 0 then yield {deletedCount: 0, pendingAcks: []}
6411− let inMailbox = any bucket (\m -> m.messageId == messageId && m.toKey == to)
6412− if inMailbox then yield "pending"
6414− -- Check if being forwarded to a remote server (bucket read: O(n/16))
1629+ set *messages = do m <- msgs; where not (m.toKey == pubkey && any dedupedIds (\mid -> mid == m.messageId)); yield m
6415− fwdBkt <- readFwdBucket (pubkeyBucket to)
1630+ fwds <- *forwards
6416− let inForwards = any fwdBkt (\f -> f.messageId == messageId && f.toKey == to)
1631+ set *forwards = do f <- fwds; where not (f.toKey == pubkey && any dedupedIds (\mid -> mid == f.messageId)); yield f
6417− if inForwards then yield "forwarding"
1632+ let federatedDeleted = do m <- toDel; where m.originServer != ""; yield m
6418− else do
1633+ let ackedFed = do m <- federatedDeleted; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
6419− -- Check if already delivered (acked or in terminal delivered set)
1634+ aids <- *ackedIds
6420− ackedBkt <- readAckedBucket msgBucket
1635+ set *ackedIds = capList (union aids ackedFed) maxAckedIds (\a -> a.ackedAt)
6421− delivBkt <- readDelivBucket msgBucket
1636+ yield {deletedCount: count toDel, pendingAcks: ackedFed}
6422− let inAcked = hasMessage messageId to ackedBkt
1637+ fork (when federationEnabled (sendAcksAndClean result.pendingAcks))
6423− let inDelivered = hasMessage messageId to delivBkt
1638+ yield (respond {ok: True {}, authorized: True {}, deletedCount: result.deletedCount, error: ""}))
6424− if inAcked || inDelivered then yield "delivered"
1639+
6425− else do
1640+handleCancelMessage = \messageId to authorization clientIp respond -> do
6426− -- Extended check: forward nonces have 60-day retention (2x message lifetime)
6427− -- and 100k capacity, providing delivery evidence after ackedIds/deliveredIds are pruned.
6428− -- Sharded: reads only the bucket for this recipient's pubkey.
6429− nonceBkt <- readNonceBucket (pubkeyBucket to)
6430− let inNonces = any nonceBkt (\n -> n.messageId == messageId && n.toKey == to)
6431− if inNonces then yield "delivered"
6432− else yield "unknown"
6433− yield (respond {status: result, authorized: True {}}))
6435−-- POST /auth/revoke: Revoke a specific session token.
6436−-- Caller authenticates via Authorization header, then specifies the target token to remove.
6437−-- Only removes the target if it belongs to the same pubkey as the caller (prevents cross-user revocation).
6438−handleRevoke = \targetToken authorization clientIp respond -> do
6439 t <- now
1641 t <- now
6440− globalRateLimited <- checkGlobalRate t
1642+ dp <- *drainPhase
6441− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}})
1643+ if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: ""})
6443− withSessionAuth authorization t clientIp
1645+ g <- checkGlobalRate t
6444− (yield (respond {ok: False {}, authorized: False {}}))
1646+ if g then yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "rate_limited"})
6445− (\callerPubkey -> do
1647+ else withSessionAuth authorization t clientIp
6446− authLimited <- checkAuthGlobalRate t
1648+ (yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "unauthorized"}))
6447− if authLimited then yield (respond {ok: False {}, authorized: True {}})
1649+ (\senderKey -> do
1650+ lim <- checkPubkeyRateGate clientWriteRates senderKey maxClientWriteRatePerKey clientWriteRateWindowMs t
1651+ if lim then yield (respond {ok: False {}, authorized: True {}, cancelled: False {}, error: "rate_limited"})
6449− revokeLimited <- atomic do
1653+ result <- atomic do
6450− rr <- *revokeRates
1654+ msgs <- *messages
6451− let rateResult = checkPubkeyRate rr callerPubkey maxRevokeRatePerKey revokeRateWindowMs maxRevokeRateEntries t
1655+ let target = headOf (do m <- msgs; where m.messageId == messageId && m.toKey == to; yield m)
6452− set *revokeRates = rateResult.entries
1656+ case target of
6453− yield rateResult.limited
1657+ Nothing {} -> yield {cancelled: False {}, cancelServers: []}
6454− if revokeLimited then yield (respond {ok: False {}, authorized: True {}})
1658+ Just {value: msg} ->
1659+ if msg.originServer != "" || msg.senderKey == "" || msg.senderKey != senderKey
1660+ then yield {cancelled: False {}, cancelServers: []}
1662+ set *messages = do m <- msgs; where not (m.messageId == messageId && m.toKey == to); yield m
1664+ let cancelledFwds = do f <- fwds; where f.messageId == messageId && f.toKey == to; yield f
1665+ let fwdServers = collectPeers cancelledFwds (\f -> f.toServer)
1666+ set *forwards = do f <- fwds; where not (f.messageId == messageId && f.toKey == to); yield f
1668+ let presServers = collectPeers (presenceForKey pres to t) (\p -> p.server)
1669+ let allServers = fold (\acc s -> if any acc (\a -> a == s) then acc else union acc [s]) presServers fwdServers
1670+ cn <- *cancelNotifications
1671+ set *cancelNotifications = capList (union cn [{toKey: to, messageId: messageId, cancelledAt: t}]) 10000 (\c -> c.cancelledAt)
1672+ yield {cancelled: True {}, cancelServers: allServers}
1673+ when (result.cancelled && count result.cancelServers > 0 && federationEnabled)
1674+ (fork (sendCancelToEach messageId to result.cancelServers))
1675+ yield (respond {ok: True {}, authorized: True {}, cancelled: result.cancelled, error: ""}))
1677+sendCancelToEach = \messageId to servers ->
1678+ case headOf servers of
1679+ Nothing {} -> yield {}
1680+ Just {value: server} -> do
1681+ let rest = do s <- servers; where s != server; yield s
1683+ auth <- generateFederationAuth ("cancel:" ++ messageId) t
1684+ result <- fetch (federationUrl server) (FederationCancel {
1685+ messageId: messageId, toKey: to, fromServer: serverHostN,
1686+ requestTimestamp: t, correlationId: "", authorization: auth,
1687+ protocolVersion: federationProtocolVersion})
1690+ pfc <- *pendingFederationCancels
1691+ set *pendingFederationCancels = capList (union pfc [{messageId: messageId, toKey: to, toServer: server, createdAt: t, retries: 0}]) 10000 (\c -> c.createdAt)
1692+ Ok r -> when (not r.ok) (atomic do
1693+ pfc <- *pendingFederationCancels
1694+ set *pendingFederationCancels = capList (union pfc [{messageId: messageId, toKey: to, toServer: server, createdAt: t, retries: 0}]) 10000 (\c -> c.createdAt))
1695+ sendCancelToEach messageId to rest
1697+handleCancelBatch = \cancels authorization clientIp respond -> do
1700+ if dp >= 2 then yield (respond {results: [], authorized: False {}, error: ""})
1702+ g <- checkGlobalRate t
1703+ if g then yield (respond {results: [], authorized: False {}, error: "rate_limited"})
1704+ else withSessionAuth authorization t clientIp
1705+ (yield (respond {results: [], authorized: False {}, error: "unauthorized"}))
1707+ lim <- checkPubkeyRateGate clientWriteRates senderKey maxClientWriteRatePerKey clientWriteRateWindowMs t
1708+ if lim then yield (respond {results: [], authorized: True {}, error: "rate_limited"})
6456− let targetBucket = tokenBucket targetToken
1710+ let capped = takeRelation maxBatchSize cancels
6457− result <- atomic do
1711+ results <- cancelEach senderKey capped t []
6458− sessions <- readSessionBucket targetBucket
1712+ yield (respond {results: results, authorized: True {}, error: ""}))
6459− -- Single-pass find-and-remove: avoids calling safeCompare twice per session
1713+
6460− -- (once in `any` to check existence, again in `where` to filter).
1714+cancelEach = \senderKey entries t acc ->
6461− let filtered = fold (\acc s ->
1715+ case headOf entries of
6462− if not acc.found && s.pubkey == callerPubkey && safeCompare s.token targetToken
1716+ Nothing {} -> yield acc
6463− then {kept: acc.kept, found: True {}}
1717+ Just {value: e} -> do
6464− else {kept: union acc.kept [s], found: acc.found}) {kept: [], found: False {}} sessions
1718+ let rest = do x <- entries; where x.messageId != e.messageId; yield x
6465− if filtered.found
1719+ r <- atomic do
6466− then do
1720+ msgs <- *messages
6467− writeSessionBucket targetBucket filtered.kept
1721+ let target = headOf (do m <- msgs; where m.messageId == e.messageId && m.toKey == e.to; yield m)
6468− sc <- *totalSessionCount
1722+ case target of
6469− set *totalSessionCount = max 0 (sc - 1)
1723+ Nothing {} -> yield False
6470− cleanup <- checkLastSessionCleanup callerPubkey t
1724+ Just {value: msg} ->
6471− yield (Just {value: cleanup})
1725+ if msg.originServer != "" || msg.senderKey == "" || msg.senderKey != senderKey
6472− else yield (Nothing {})
1726+ then yield False
6473− case result of
1727+ else do
6474− Nothing {} -> yield (respond {ok: False {}, authorized: True {}})
1728+ set *messages = do m <- msgs; where not (m.messageId == e.messageId && m.toKey == e.to); yield m
6475− Just {value: r} -> do
1729+ fwds <- *forwards
6476− gossipOfflineIfLastSession r "revoke"
1730+ set *forwards = do f <- fwds; where not (f.messageId == e.messageId && f.toKey == e.to); yield f
6477− when (not r.gossipOffline) (logInfo ("revoke: session revoked for " ++ r.pubkey))
1731+ cn <- *cancelNotifications
6478− yield (respond {ok: True {}, authorized: True {}}))
1732+ set *cancelNotifications = capList (union cn [{toKey: e.to, messageId: e.messageId, cancelledAt: t}]) 10000 (\c -> c.cancelledAt)
6480−-- POST /auth/logout: Voluntary disconnect. Removes the caller's session and, if it was
1734+ cancelEach senderKey rest t (union acc [{messageId: e.messageId, cancelled: r}])
6481−-- the last active session for this pubkey, clears local presence and gossips offline.
1735+
6482−-- This gives faster offline detection than waiting for session expiry (1 hour).
1736+handleSendBatch = \messages authorization clientIp respond -> do
6483−handleLogout = \authorization clientIp respond -> do
6484 t <- now
1737 t <- now
6485− -- Logout is allowed during all drain phases (including full drain): it reduces load
1738+ dp <- *drainPhase
6486− -- and the offline gossip is skipped during drain by gossipOfflineIfLastSession.
1739+ if dp >= 2 then yield (respond {results: [], authorized: False {}, retryAfterMs: 0})
6487− globalRateLimited <- checkGlobalRate t
6488− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}})
6490− authLimited <- checkAuthGlobalRate t
1741+ g <- checkGlobalRate t
6491− if authLimited then yield (respond {ok: False {}, authorized: False {}})
1742+ if g then yield (respond {results: [], authorized: False {}, retryAfterMs: 0})
6492− else
1743+ else withSessionAuth authorization t clientIp
6493− case extractToken authorization of
1744+ (yield (respond {results: [], authorized: False {}, retryAfterMs: 0}))
6494− Nothing {} -> yield (respond {ok: False {}, authorized: False {}})
1745+ (\senderKey -> do
6495− Just {value: token} -> do
1746+ let capped = takeRelation maxBatchSize messages
6496− let bucket = tokenBucket token
1747+ results <- sendBatchEach senderKey capped t []
6497− result <- atomic do
1748+ yield (respond {results: do r <- results; yield {messageId: r.messageId, status: r.status}, authorized: True {}, retryAfterMs: 0}))
6498− sessions <- readSessionBucket bucket
1749+
6499− case authenticateSession sessions token t of
1750+sendBatchEach = \senderKey msgs t acc ->
6500− Unauthorized {} -> yield (Nothing {})
1751+ case headOf msgs of
6501− Authorized {pubkey, ip} ->
1752+ Nothing {} -> yield acc
6502− if not (matchIp clientIp ip)
1753+ Just {value: m} -> do
6503− then yield (Nothing {})
1754+ let rest = do x <- msgs; where x != m; yield x
6504− else do
1755+ effMsgId <- if m.messageId != "" then yield m.messageId else genToken
6505− -- Remove the caller's session
1756+ let clampedTs = clampTimestamp m.timestamp t
6506− writeSessionBucket bucket (do s <- sessions; where not (safeCompare s.token token); yield s)
1757+ let clampedPri = clamp 0 maxMessagePriority m.priority
6507− sc <- *totalSessionCount
1758+ r <- if t - m.timestamp > messageMaxAge
6508− set *totalSessionCount = max 0 (sc - 1)
1759+ then yield {status: MsRejected {}, remoteServers: []}
6509− cleanup <- checkLastSessionCleanup pubkey t
1760+ else atomic do sendMessageCore senderKey m.to m.encryptedBlob clampedTs effMsgId m.expiresInMs clampedPri t
6510− yield (Just {value: cleanup})
1761+ forkSendForwards effMsgId m.to m.encryptedBlob clampedTs r.remoteServers
6511− case result of
1762+ sendBatchEach senderKey rest t (union acc [{messageId: effMsgId, status: r.status}])
6512− Nothing {} -> yield (respond {ok: False {}, authorized: False {}})
1763+
6513− Just {value: r} -> do
1764+-- ============================================
6514− gossipOfflineIfLastSession r "logout"
1765+-- Handler: federation receive
6515− yield (respond {ok: True {}, authorized: True {}})
1766+-- ============================================
6517−-- POST /federation/verify: Confirm a token was issued by this server.
6518−-- Called by the receiving server during federation callback verification.
6519−-- Tokens are single-use and expire after verificationTokenExpiry.
6520handleVerifyToken = \token scope clientIp respond -> do
1768handleVerifyToken = \token scope clientIp respond -> do
6521− -- Reject empty scope: prevents matching against any cached verification entry
6522 if scope == "" then yield (respond {ok: False {}})
1769 if scope == "" then yield (respond {ok: False {}})
6524− t <- now
1771+ t <- now
6525− globalRateLimited <- checkGlobalRate t
1772+ g <- checkGlobalRate t
6526− if globalRateLimited then yield (respond {ok: False {}})
1773+ if g then yield (respond {ok: False {}})
6528− ipLimited <- checkClientIpRate clientIp t
6529− if ipLimited then yield (respond {ok: False {}})
6531− -- Dedicated verify rate limit (tighter than general IP rate to limit token probing)
6532− verifyLimited <- if clientIp == "" then yield (False {})
6534− verifyIpRates <- *verifyIpRates
6535− let result = checkIpRate verifyIpRates clientIp maxVerifyRatePerIp verifyRateWindowMs maxVerifyRateEntries t
6536− set *verifyIpRates = result.entries
6537− yield result.limited
6538− if verifyLimited then do
6539− logEvent "warn" "rate_limited_verify_ip" ("ip=" ++ clientIp)
6540− yield (respond {ok: False {}})
6543− pending <- *pendingVerifications
6544− -- Filter by scope and expiry only — no token prefix optimization.
6545− -- The previous first-char pre-filter leaked one hex digit via timing side-channel.
6546− -- safeCompare must run on all candidates to prevent information leakage.
6547− -- Bounded by maxPendingVerifications and further filtered by scope+expiry.
6548− let isCandidate = \p -> p.scope == scope && t - p.createdAt < verificationTokenExpiry
6549− let candidates = do p <- pending; where isCandidate p; yield p
6550− let match = any candidates (\p -> safeCompare p.token token)
6551− when match (set *pendingVerifications = union
6552− (do p <- pending; where not (isCandidate p); yield p)
6553− (do p <- candidates; where not (safeCompare p.token token); yield p))
6555− -- Omit scope from log to prevent scope enumeration by attackers probing the endpoint
6556− when (not found) (do
6557− logWarn ("federation/verify: failed attempt from " ++ clientIp)
6558− logEvent "warn" "verify_failed" clientIp)
6559− yield (respond {ok: found})
6561−-- POST /federation/gossip: Receive presence gossip from a peer server.
6562−-- Validates events, merges into presence table (last-write-wins), and re-gossips
6563−-- to other known peers with decremented hop count. Triggers message forwarding
6564−-- when a remote key comes online.
6565−handleRecvGossip = \events hopsRemaining fromServer requestTimestamp correlationId authorization respond -> do
6567− effMaxHops <- effectiveMaxGossipHops
6568− let cappedHops = clamp 0 effMaxHops hopsRemaining
6569− let corrId = sanitizeCorrelationId correlationId
6570− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " gossip from " ++ fromServer))
6571− -- Cap inbound seenBy lists and filter to known peers to prevent gossip suppression attacks
6572− knownPeersForSeenBy <- *knownPeerServers
6573− let cappedEvents = do e <- events; yield {eventType: e.eventType, pubkey: e.pubkey, server: e.server, timestamp: e.timestamp, ttl: e.ttl, seenBy: filterSeenBy (takeRelation maxSeenByLen e.seenBy) knownPeersForSeenBy}
6574− withFederationAuth authorization t respond fromServer "gossip" requestTimestamp (cappedHops >= 1 && not (isLocalServer fromServer) && count cappedEvents <= maxGossipEvents) (True {}) (do
6575− -- Per-peer gossip event volume limiting: counts total events (not just requests) per server.
6576− -- A single gossip request carries up to maxGossipEvents entries; without this, a peer
6577− -- sending 50 req/s * 100 events = 5000 presence mutations/second.
6578− eventRateLimited <- atomic do
6579− ger <- *gossipEventRates
6580− let eventCount = count cappedEvents
6581− let entry = headOf (do r <- ger; where r.server == fromServer; yield r)
6582− let isNewWindow = case entry of Nothing {} -> True {}; Just {value: r} -> t - r.windowStart >= gossipEventRateWindowMs
6583− let currentCount = case entry of Nothing {} -> 0; Just {value: r} -> if isNewWindow then 0 else r.count
6584− -- Sliding window: interpolate previous window's count for smoother rate limiting
6585− let elapsed = case entry of Nothing {} -> 0; Just {value: r} -> t - r.windowStart
6586− let prevWeight = case entry of Nothing {} -> 0; Just {value: r} -> if isNewWindow then 0 else r.prevCount * (gossipEventRateWindowMs - elapsed) / gossipEventRateWindowMs
6587− if prevWeight + currentCount + eventCount > maxGossipEventsPerServer
6588− then yield (True {})
6590− let newEntries = if isNewWindow
6591− then let pc = case entry of Nothing {} -> 0; Just {value: r} -> r.count
6592− in union (do r <- ger; where r.server != fromServer; yield r) [{server: fromServer, windowStart: t, count: eventCount, prevCount: pc}]
6593− else do r <- ger; yield (if r.server == fromServer then {server: r.server, windowStart: r.windowStart, count: r.count + eventCount, prevCount: r.prevCount} else r)
6594− set *gossipEventRates = if count newEntries > maxGossipEventRateEntries then (do r <- newEntries; where t - r.windowStart < gossipEventRateWindowMs * 2; yield r) else newEntries
6596− if eventRateLimited then do
6597− logEvent "warn" "rate_limited_gossip_volume" ("peer=" ++ fromServer ++ " limit=" ++ show maxGossipEventsPerServer)
6598− yield (respond {ok: False {}, error: "event_rate_limited", retryAfterMs: gossipEventRateWindowMs})
6600− let validated = validGossipEvents cappedEvents t
1775+ ipLim <- checkIpRateGate clientIp t
6601− let onlineEntries = validated.online
1776+ if ipLim then yield (respond {ok: False {}})
6602− let trustedOffline = trustedOfflineEvents validated.offline fromServer
6603− -- Early return: skip the expensive presence merge when all events are invalid/expired
6604− if count onlineEntries == 0 && count trustedOffline == 0
6605− then yield (respond {ok: True {}, error: "", retryAfterMs: 0})
6607− -- Warn if a peer sends both online and offline for the same key in one batch (suspicious)
1778+ found <- atomic do
6608− let conflictingKeys = do on <- onlineEntries; off <- trustedOffline; where on.pubkey == off.pubkey && on.server == off.server; yield on.pubkey
1779+ pending <- *pendingVerifications
6609− when (count conflictingKeys > 0)
1780+ let candidates = do p <- pending; where p.scope == scope && t - p.createdAt < verificationTokenExpiry; yield p
6610− (logWarn ("gossip: " ++ fromServer ++ " sent conflicting online+offline for same key(s)"))
1781+ let match = any candidates (\p -> safeCompare p.token token)
6611− let filteredOnline = resolveByTimestamp onlineEntries trustedOffline
1782+ when match (set *pendingVerifications = do p <- pending; where p.scope != scope || not (safeCompare p.token token); yield p)
6612− let filteredOffline = resolveByTimestamp trustedOffline onlineEntries
1783+ yield match
6613− let deduped = mergeByPubkeyServer [] filteredOnline
1784+ yield (respond {ok: found})
6614− -- Combined local-clash check + gossip merge in a single atomic block.
1785+
6615− -- Previously these were two separate atomic blocks reading the same presence buckets;
1786+handleFederationPubkey = \respond -> do
6616− -- merging them halves the bucket reads and avoids a TOCTOU gap between clash check and merge.
1787+ yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})
6617− -- All entries for a pubkey hash to the same bucket, so per-bucket merge is complete.
1788+
6618− let allGossipEntries = union deduped trustedOffline
1789+isOnlineEvent : GossipEventType -> Bool
6619− let affectedBuckets = uniqueBucketsFor allGossipEntries (\e -> e.pubkey)
1790+isOnlineEvent = \et -> case et of
6620− gossipResult <- atomic do
1791+ GossipOnline {} -> True {}
6621− selectedPresence <- readSelectedPresenceBuckets affectedBuckets
1792+ _ -> False {}
6622− tpc <- *totalPresenceCount
1793+
6623− -- Reject gossip entries that claim keys locally authenticated on this server.
1794+isOfflineEvent : GossipEventType -> Bool
6624− -- A peer announcing presence for a key we have a live session for could be a presence
1795+isOfflineEvent = \et -> case et of
6625− -- hijack attempt: the attacker's server would receive forwarded message copies.
1796+ GossipOffline {} -> True {}
6626− let localClashes = do e <- deduped; where any selectedPresence (\p -> p.pubkey == e.pubkey && isLocalServer p.server && p.expiresAt > t); yield e.pubkey
1797+ _ -> False {}
6627− let safeDeduped = if count localClashes > 0
1798+
6628− then do d <- deduped; where not (any localClashes (\pk -> pk == d.pubkey)); yield d
1799+handleRecvGossip = \events hopsRemaining fromServer requestTimestamp correlationId authorization respond -> do
6629− else deduped
1800+ t <- now
6630− let safeTrustedOffline = if count localClashes > 0
1801+ let cappedHops = clamp 0 maxGossipHops hopsRemaining
6631− then do d <- trustedOffline; where not (any localClashes (\pk -> pk == d.pubkey)); yield d
1802+ withFederationAuth authorization t respond fromServer "gossip" requestTimestamp (cappedHops >= 1 && not (isLocalServer fromServer) && count events <= maxGossipEvents) (do
6632− else trustedOffline
1803+ valid <- atomic do
6633− -- Pre-filter: when near capacity, reject gossip entries for pubkeys not already in presence.
1804+ pres <- *presence
6634− -- This prevents a malicious peer from spiking presence above maxPresenceEntries via large batches.
1805+ let validEvents = do
6635− let capacityDeduped = if tpc >= maxPresenceEntries
1806+ e <- events
6636− then do d <- safeDeduped; where any selectedPresence (\p -> p.pubkey == d.pubkey); yield d
1807+ where not (isLocalServer e.server) && e.timestamp <= t + clockSkewTolerance
6637− else safeDeduped
1808+ let ttl = clampTtl e.ttl
6638− let gm = mergeGossipPresence selectedPresence capacityDeduped safeTrustedOffline fromServer t
1809+ let effectiveTs = min e.timestamp t
6639− -- Write back only affected buckets (not writeAllPresence, which would zero unaffected buckets)
1810+ let expiresAt = effectiveTs + ttl * 1000
6640− writeSelectedPresenceBuckets affectedBuckets gm.finalPresence
1811+ where expiresAt > t
6641− let delta = count gm.finalPresence - count selectedPresence
1812+ yield {pubkey: e.pubkey, server: e.server, expiresAt: expiresAt, timestamp: e.timestamp, eventType: e.eventType}
6642− set *totalPresenceCount = max 0 (tpc + delta)
1813+ let online = do v <- validEvents; where isOnlineEvent v.eventType; yield {pubkey: v.pubkey, server: v.server, expiresAt: v.expiresAt, timestamp: v.timestamp}
6643− -- Merge new peer servers with existing known peers (selected buckets may not contain all peers)
1814+ let offline = do v <- validEvents; where isOfflineEvent v.eventType; yield {pubkey: v.pubkey, server: v.server, timestamp: v.timestamp}
6644− knownPeers <- *knownPeerServers
1815+ let withoutOffline = do
6645− let newPeers = gm.gossipPeerServers
1816+ p <- pres
6646− set *knownPeerServers = fold (\acc s -> if any acc (\a -> a == s) then acc else union [s] acc) knownPeers newPeers
1817+ where none offline (\o -> samePubkeyServer o p && o.timestamp > p.timestamp)
6647− set *presenceVersion = t
1818+ yield p
6648− yield {gm: gm, preFiltered: count safeDeduped - count capacityDeduped, localClashCount: count localClashes}
1819+ let merged = mergePresence withoutOffline online
6649− when (gossipResult.localClashCount > 0)
1820+ set *presence = capList merged maxPresenceEntries (\p -> p.expiresAt)
6650− (logWarn ("gossip: " ++ fromServer ++ " claims " ++ show gossipResult.localClashCount ++ " locally-authenticated key(s) — filtered from merge"))
1821+ let newlyOnline = do
6651− -- seenBy for re-broadcast: include fromServer (sender) and ourselves so downstream
1822+ e <- online
6652− -- peers that share connections with either skip this event.
1823+ where not (isLocalServer e.server)
6653− let rebroadcastSeenBy = if any [fromServer] (\s -> s == serverHostN) then [serverHostN] else [fromServer, serverHostN]
1824+ where none pres (\p -> samePubkeyServer p e && p.expiresAt >= e.expiresAt)
6654− let effectiveEvents = union (effectiveGossipEvents filteredOnline gossipResult.gm.appliedKeys (GossipOnline {}) rebroadcastSeenBy) (effectiveGossipEvents filteredOffline gossipResult.gm.appliedKeys (GossipOffline {}) rebroadcastSeenBy)
1825+ yield {pubkey: e.pubkey, server: e.server}
6655− when (not gossipResult.gm.withinCapacity || gossipResult.preFiltered > 0)
1826+ yield {newlyOnline: newlyOnline}
6656− (logWarn ("gossip: presence at capacity (" ++ show maxPresenceEntries ++ "), limiting new entries from " ++ fromServer ++ " (pre-filtered: " ++ show gossipResult.preFiltered ++ ")"))
1827+ when (count valid.newlyOnline > 0)
6657− -- Suppress re-broadcast of events we've already gossiped recently (prevents amplification)
1828+ (fork (forwardForNewlyOnline valid.newlyOnline t))
6658− freshEvents <- atomic do
6659− recentGossip <- *recentGossip
6660− let active = do r <- recentGossip; where t - r.seenAt < gossipDedupWindow; yield r
6661− -- Pre-filter active entries to only those matching (pubkey, server) pairs in this batch.
6662− -- Reduces the inner dedup scan from O(n*m) to O(n*k) where k << m (k = matching pairs).
6663− let batchPairs = fold (\acc e -> if any acc (\a -> a.pubkey == e.pubkey && a.server == e.server) then acc else union [{pubkey: e.pubkey, server: e.server}] acc) [] effectiveEvents
6664− let relevantActive = do r <- active; where any batchPairs (\p -> p.pubkey == r.pubkey && p.server == r.server); yield r
6665− let fresh = do e <- effectiveEvents; where none relevantActive (\r -> r.pubkey == e.pubkey && r.server == e.server && r.timestamp == e.timestamp); yield e
6666− let newRecent = do e <- fresh; yield {pubkey: e.pubkey, server: e.server, timestamp: e.timestamp, seenAt: t}
6667− let updated = union active newRecent
6668− set *recentGossip = if count updated > maxRecentGossip then do r <- updated; where t - r.seenAt < gossipDedupWindow; yield r else updated
6670− let newlyOnlineRemote = newlyOnlineRemoteKeys filteredOnline gossipResult.gm.appliedKeys
6672− when (cappedHops > 1 && federationEnabled && count freshEvents > 0) (do
6673− -- Gossip batch backoff: when a large batch of fresh events arrives (e.g., peer
6674− -- recovering from downtime), delay re-broadcast by a random interval to prevent
6675− -- amplification storms. Multiple peers recovering simultaneously would otherwise
6676− -- generate O(peers^2 * events) gossip traffic.
6677− when (count freshEvents > gossipBatchBackoffThreshold) (do
6678− backoff <- randomInt gossipBatchBackoffMs
6679− logEvent "info" "gossip_batch_backoff" ("events=" ++ show (count freshEvents) ++ " from=" ++ fromServer ++ " backoffMs=" ++ show backoff)
6681− let targets = gossipTargets gossipResult.gm.gossipPeerServers fromServer
6682− -- Split first-party (from the sender) vs third-party (relayed) events.
6683− -- Third-party events get fewer hops to limit amplification from inflated hopsRemaining.
6684− let firstPartyEvents = do e <- freshEvents; where e.server == fromServer; yield e
6685− let thirdPartyEvents = do e <- freshEvents; where e.server != fromServer; yield e
6686− when (count firstPartyEvents > 0) (sendBatchedGossip targets firstPartyEvents (cappedHops - 1))
6687− let thirdPartyHops = min (cappedHops - 1) maxThirdPartyGossipHops
6688− when (thirdPartyHops > 1 && count thirdPartyEvents > 0) (sendBatchedGossip targets thirdPartyEvents thirdPartyHops))
6689− when (federationEnabled && count newlyOnlineRemote > 0)
6690− (forwardQueuedMessages newlyOnlineRemote t))
6691 yield (respond {ok: True {}, error: "", retryAfterMs: 0}))
1829 yield (respond {ok: True {}, error: "", retryAfterMs: 0}))
6693−-- POST /federation/forward: Receive a message forwarded from a peer server.
1831+forwardForNewlyOnline = \targets t ->
6694−-- Accepts both direct forwards (fromServer == originServer) and relay forwards
1832+ case headOf targets of
6695−-- (fromServer != originServer) where an intermediate server re-forwards because
1833+ Nothing {} -> yield {}
6696−-- the recipient moved. Cascade is bounded by dedup (same messageId won't be stored
1834+ Just {value: tgt} -> do
6697−-- twice) and forwardCandidates (won't re-forward to the same server).
1835+ let rest = do x <- targets; where x.pubkey != tgt.pubkey || x.server != tgt.server; yield x
1836+ forwardQueuedToServer tgt.pubkey tgt.server t
1837+ forwardForNewlyOnline rest t
6698handleForwardMessage = \toKey encryptedBlob timestamp originServer messageId fromServer requestTimestamp correlationId expiresAt priority authorization respond -> do
1839handleForwardMessage = \toKey encryptedBlob timestamp originServer messageId fromServer requestTimestamp correlationId expiresAt priority authorization respond -> do
6699 t <- now
1840 t <- now
6700− let corrId = sanitizeCorrelationId correlationId
1841+ withFederationAuth authorization t respond fromServer ("forward:" ++ messageId) requestTimestamp (not (isLocalServer originServer) && not (isLocalServer fromServer)) (do
6701− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " forward " ++ messageId ++ " from " ++ fromServer))
6702− withFederationAuth authorization t respond fromServer ("forward:" ++ messageId) requestTimestamp (not (isLocalServer originServer) && not (isLocalServer fromServer)) (True {}) (do
6703− when (fromServer != originServer)
6704− (logInfo ("forward: relay from " ++ fromServer ++ " (origin: " ++ originServer ++ ") for " ++ toKey))
6705− -- Relay origin verification: for relay forwards, verify:
6706− -- 1. originServer is a known peer (prevents ack routing to arbitrary servers)
6707− -- 2. originServer is not on the blocklist (blocked peers can't receive acks)
6708− -- 3. originServer passes the allowlist if one is configured
6709− -- This prevents metadata leakage: without these checks, a malicious peer B could
6710− -- send a relay forward with originServer=A, causing us to send an ack (containing
6711− -- messageId + recipient pubkey) to server A on B's behalf.
6712− originOk <- if fromServer == originServer then yield (True {})
6714− knownPeers <- *knownPeerServers
6715− blocked <- *blockedPeers
6716− allowed <- *allowedPeers
6717− yield (any knownPeers (\p -> p == originServer)
6718− && not (isBlockedPeer originServer blocked)
6719− && isAllowedByAllowlist originServer allowed)
6722− logWarn ("forward: rejected relay with untrusted origin " ++ originServer ++ " from " ++ fromServer)
6723− yield (respond {ok: False {}, error: "unknown_origin", retryAfterMs: 0})
6725− -- Replay protection: reject forwards with timestamps older than messageMaxAge.
6726− -- Legitimate queued messages have timestamps within this window. Replayed captures
6727− -- become stale once dedup state (messages + ackedIds + deliveredIds) is pruned (~30 days).
6728 if t - timestamp > messageMaxAge
1842 if t - timestamp > messageMaxAge
6729 then yield (respond {ok: False {}, error: "stale_timestamp", retryAfterMs: 0})
1843 then yield (respond {ok: False {}, error: "stale_timestamp", retryAfterMs: 0})
6731− -- Presence check + message storage in a single atomic block to prevent TOCTOU
1845+ let clampedTs = clampTimestamp timestamp t
6732− -- race where a key goes offline between presence check and store.
1846+ result <- atomic do
6733− let clampedTs = clampTimestamp timestamp t
1847+ pres <- *presence
6734− result <- atomic do
1848+ let hasPresence = any pres (\p -> p.pubkey == toKey && p.expiresAt > t)
6735− -- Verify recipient has active presence on this server. Peers should only forward
1849+ if not hasPresence then yield "no_presence"
6736− -- to us if gossip indicated the key is here. Accepting messages for completely
1850+ else do
6737− -- unknown keys wastes mailbox slots that will never be drained by polling.
1851+ msgs <- *messages
6738− -- All sharded collections (presence, messages, acked, delivered, nonces) use
1852+ aids <- *ackedIds
6739− -- pubkeyBucket(toKey), so a single index serves all reads in this block.
1853+ dids <- *deliveredIds
6740− let bkt = pubkeyBucket toKey
1854+ let isDup = any msgs (\m -> m.messageId == messageId && m.toKey == toKey)
6741− presenceBkt <- readPresenceBucket bkt
1855+ || hasMessage messageId toKey aids
6742− let hasPresence = any presenceBkt (\p -> p.pubkey == toKey && p.expiresAt > t)
1856+ || hasMessage messageId toKey dids
6743− if not hasPresence
1857+ if isDup then yield "duplicate"
6744− then yield {forward: ForwardRejected {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: True {}, nonceCutoffRejected: False {}}
1858+ else if count msgs >= maxMessages then yield "global_full"
6746− bucket <- readMessageBucket bkt
1860+ let rcCount = count (do m <- msgs; where m.toKey == toKey; yield m) in
6747− ackedBkt <- readAckedBucket bkt
1861+ if rcCount >= maxMessagesPerRecipient then yield "mailbox_full"
6748− delivBkt <- readDelivBucket bkt
1862+ else do
6749− -- Sharded nonce check: reads only the bucket for this recipient's pubkey (O(n/16) vs O(n)).
1863+ rr <- *recvRates
6750− nonceBkt <- readNonceBucket bkt
1864+ let r = checkRate rr toKey maxRecvRatePerKey recvRateWindowMs 5000 t
6751− -- Nonce check ignores originServer: a (messageId, toKey) pair is globally unique,
1865+ if r.limited then yield "rate_limited"
6752− -- so replays from any origin should be rejected. This also catches locally-originated
6753− -- messages (originServer="") whose nonces were recorded by sendMessageCore.
6754− let isDup = checkMessageDup bucket messageId toKey || hasMessage messageId toKey ackedBkt || hasMessage messageId toKey delivBkt || any nonceBkt (\n -> n.messageId == messageId && n.toKey == toKey)
6756− then yield {forward: ForwardDuplicate {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: False {}}
6758− -- Nonce eviction replay protection: if LRU eviction has occurred in this bucket,
6759− -- we cannot verify dedup for messages whose nonces may have been evicted. Reject
6760− -- forwards with timestamps older than this bucket's eviction cutoff.
6761− -- Per-bucket cutoff (not global) ensures eviction in one bucket doesn't reject
6762− -- valid forwards destined for a different bucket.
6763− nonceCutoff <- readNonceCutoff bkt
6764− if nonceCutoff > 0 && timestamp > 0 && timestamp < nonceCutoff
6765− then yield {forward: ForwardRejected {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: True {}}
6767− totalMsgCount <- *totalMessageCount
6768− if totalMsgCount >= maxMessages
6769− then yield {forward: ForwardRejected {}, globalCapReached: True {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: False {}}
6771− recipientCounts <- readRcBucket bkt
6772− let recipientCount = getRecipientCount toKey recipientCounts
6773− effMaxPerRecipient <- effectiveMaxMessagesPerRecipient
6774− if recipientCount >= effMaxPerRecipient
6775− then yield {forward: ForwardRejected {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: False {}}
6777− recvRates <- *recvRates
1867+ set *recvRates = r.entries
6778− recvRate <- effectiveRecvRate
1868+ seq <- *seqCounter
6779− let recvResult = checkPubkeyRate recvRates toKey recvRate recvRateWindowMs maxRecvRateEntries t
1869+ let seqTs = nextSeqTs t seq
6780− if recvResult.limited
1870+ set *seqCounter = seqTs
6781− then yield {forward: ForwardRejected {}, globalCapReached: False {}, recvRateLimited: True {}, noPresence: False {}, nonceCutoffRejected: False {}}
1871+ let fwdExpiresAt = if expiresAt > t then min expiresAt (seqTs + unackedMessageMaxAge) else seqTs + unackedMessageMaxAge
6782− else do
1872+ let clampedPri = clamp 0 maxMessagePriority priority
6783− set *recvRates = recvResult.entries
1873+ set *messages = union msgs [{messageId: messageId, toKey: toKey, encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: seqTs, expiresAt: fwdExpiresAt, senderKey: "", priority: clampedPri}]
6784− federationPairRates <- *federationPairRates
1874+ set *pollWakeup = seqTs
6785− let fedPairResult = checkServerRecipientRate federationPairRates fromServer toKey maxFederationPairRatePerPair federationPairRateWindowMs maxFederationPairRateEntries t
1875+ yield "stored"
6786− if fedPairResult.limited
1876+ if result == "stored" || result == "duplicate"
6787− then yield {forward: ForwardRejected {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: False {}}
1877+ then yield (respond {ok: True {}, error: "", retryAfterMs: 0})
6788− else do
1878+ else yield (respond {ok: False {}, error: result, retryAfterMs: 0}))
6789− set *federationPairRates = fedPairResult.entries
1879+
6790− seqCounter <- *seqCounter
6791− let seqTs = nextSeqTs t seqCounter
6792− set *seqCounter = seqTs
6793− -- Use sender-specified TTL if provided and still in the future; clamp to local max.
6794− -- expiresAt == 0 means pre-v10 peer or unset; fall back to server default.
6795− let fwdExpiresAt = if expiresAt > 0 && expiresAt > t then min expiresAt (seqTs + unackedMessageMaxAge) else seqTs + unackedMessageMaxAge
6796− let clampedPriority = clamp 0 maxMessagePriority priority
6797− writeMessageBucket bkt (union bucket
6798− [{messageId: messageId, toKey: toKey,
6799− encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: seqTs, expiresAt: fwdExpiresAt, senderKey: "", priority: clampedPriority}])
6800− set *totalMessageCount = totalMsgCount + 1
6801− writeRcBucket bkt (adjustRecipientCount recipientCounts toKey 1)
6802− signalMessageForKey toKey seqTs
6803− -- Record forward nonce for replay protection beyond message/ack dedup lifetime.
6804− recordForwardNonce messageId toKey t
6805− yield {forward: ForwardStored {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: False {}}
6806− if result.noPresence then do
6807− logWarn ("forward: rejected for " ++ toKey ++ " — no active presence on this server (from " ++ fromServer ++ ")")
6808− yield (respond {ok: False {}, error: "no_presence", retryAfterMs: 0})
6810− case result.forward of
6811− ForwardRejected {} ->
6812− if result.nonceCutoffRejected
6813− then logEvent "warn" "forward_nonce_cutoff" ("messageId=" ++ messageId ++ " key=" ++ toKey ++ " from=" ++ fromServer ++ " — timestamp older than nonce eviction cutoff, possible replay")
6814− else if result.globalCapReached
6815− then logWarn ("forward: global message cap reached (" ++ show maxMessages ++ "), rejecting for " ++ toKey)
6816− else if result.recvRateLimited
6817− then do effRecv <- effectiveRecvRate; logEvent "warn" "rate_limited_recv" ("key=" ++ toKey ++ " limit=" ++ show effRecv)
6818− else logWarn ("forward: rejected for " ++ toKey ++ " (mailbox full, max " ++ show maxMessagesPerRecipient ++ ")")
6820− yield (case result.forward of
6821− ForwardRejected {} -> respond {ok: False {}, error: if result.nonceCutoffRejected then "nonce_cutoff" else "mailbox_full", retryAfterMs: 0}
6822− _ -> respond {ok: True {}, error: "", retryAfterMs: 0}))
6824−-- Generate sender delivery receipts for messages confirmed delivered via federation ack.
6825−-- Uses senderKey from the ForwardEntry directly (stored since v12), so receipts are
6826−-- generated even if the original message was already pruned from the mailbox.
6827−-- Falls back to message lookup for pre-v12 forward entries where senderKey is "".
6828−-- Per-bucket: only reads message buckets containing the acked recipients.
6829−fedDeliveryReceipts : [Int] -> [ForwardEntry] -> Timestamp -> IO ()
6830−fedDeliveryReceipts = \bucketIds forwards t -> case headOf bucketIds of
6831− Nothing {} -> yield {}
6832− Just {value: b} -> do
6833− let rest = do x <- bucketIds; where x != b; yield x
6834− let bucketFwds = do f <- forwards; where pubkeyBucket f.toKey == b; yield f
6835− -- Fast path: forward entries with senderKey (v12+) don't need message lookup
6836− let fromForwards = do f <- bucketFwds; where f.senderKey != ""; yield {senderKey: f.senderKey, messageId: f.messageId, toKey: f.toKey, deliveredAt: t}
6837− -- Fallback: pre-v12 entries without senderKey — look up the original message
6838− let needLookup = do f <- bucketFwds; where f.senderKey == ""; yield f
6839− msgDeliveries <- if count needLookup > 0
6841− msgs <- readMessageBucket b
6842− yield (do f <- needLookup; m <- msgs; where m.messageId == f.messageId && m.toKey == f.toKey && m.senderKey != "" && m.originServer == ""; yield {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, deliveredAt: t})
6844− let deliveries = union fromForwards msgDeliveries
6845− when (count deliveries > 0) (atomic do
6846− sd <- *senderDeliveries
6847− -- Dedup: skip receipts already recorded (avoids duplicates from concurrent ack paths)
6848− let deduped = do d <- deliveries; where none sd (\e -> e.messageId == d.messageId && e.toKey == d.toKey); yield d
6849− let combined = union sd deduped
6850− let overCap = count combined > maxSenderDeliveries
6852− -- Batch eviction: evict 2% of capacity instead of 1 entry at a time.
6853− -- Amortizes the O(n) scan cost across multiple inserts, reducing overhead
6854− -- under sustained capacity pressure from O(n) per insert to O(n) per 2% fills.
6855− let evictCount = max 1 (count combined - maxSenderDeliveries + maxSenderDeliveries / 50)
6856− let eviction = evictSmallest combined evictCount (\d -> d.deliveredAt)
6857− set *senderDeliveries = eviction.kept
6858− -- Track per-sender drop counts for all evicted entries
6859− let dropCounts = fold (\acc e -> incrementDropCounter acc e.senderKey 1 t) [] eviction.evicted
6860− when (count dropCounts > 0) (do
6861− ddr <- *droppedDeliveryReceipts
6862− set *droppedDeliveryReceipts = fold (\acc dc -> incrementDropCounter acc dc.senderKey dc.count t) ddr dropCounts)
6863− else set *senderDeliveries = combined)
6864− fedDeliveryReceipts rest forwards t
6866−-- POST /federation/ack: Peer server confirms delivery of messages we originated.
6867−-- Removes corresponding forward entries. Also cleans up the original message if the
6868−-- recipient has no local presence and no other pending forwards for that message.
6869handleFederationAck = \messageIds originServer fromServer requestTimestamp correlationId authorization respond -> do
1880handleFederationAck = \messageIds originServer fromServer requestTimestamp correlationId authorization respond -> do
6870 t <- now
1881 t <- now
6871− let corrId = sanitizeCorrelationId correlationId
6872− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " ack from " ++ fromServer))
6873− -- Wrap respond to add ackedCount default for withFederationAuth error paths
6874 let ackRespond = \r -> respond {ok: r.ok, error: r.error, ackedCount: 0, results: [], retryAfterMs: r.retryAfterMs}
1882 let ackRespond = \r -> respond {ok: r.ok, error: r.error, ackedCount: 0, results: [], retryAfterMs: r.retryAfterMs}
6875− -- clearOnAuth=False: defer clearFailure until we confirm the ack matched actual
1883+ withFederationAuth authorization t ackRespond fromServer "ack" requestTimestamp (isLocalServer originServer && not (isLocalServer fromServer)) (do
6876− -- forward entries. Prevents a peer from resetting its failure/backoff counters by
6877− -- spamming acks for messageIds we never forwarded to it.
6878− withFederationAuth authorization t ackRespond fromServer "ack" requestTimestamp (isLocalServer originServer && not (isLocalServer fromServer)) (False {}) (do
6879 let dedupedIds = dedupMessageIds messageIds
1884 let dedupedIds = dedupMessageIds messageIds
6880− -- Clear forward entries for the acking server. Extract removed forwards' toKey
1885+ result <- atomic do
6881− -- so we can reclaim origin messages that are no longer needed.
1886+ fwds <- *forwards
6882− -- Optimized: scan all 16 forward buckets but only rewrite those that changed.
1887+ let removed = do f <- fwds; where f.toServer == fromServer && any dedupedIds (\m -> m == f.messageId); yield f
6883− -- Avoids the O(n) writeAllForwards repartitioning when only a few buckets are affected.
1888+ set *forwards = do f <- fwds; where not (f.toServer == fromServer && any dedupedIds (\m -> m == f.messageId)); yield f
6884− removedForwards <- removeForwardsByServer fromServer dedupedIds 0 []
1889+ -- Reclaim origin messages with no remaining forwards
6885− let ackedCount = count removedForwards
1890+ msgs <- *messages
6886− let unmatched = count dedupedIds - ackedCount
1891+ let removedIds = do f <- removed; yield f.messageId
6887− -- Reject when ALL acked IDs are unmatched: the peer is acking messages we never
1892+ pres <- *presence
6888− -- forwarded to it. Partial matches are accepted (some forwards may have been pruned).
1893+ remainingFwds <- *forwards
6889− if ackedCount == 0 && count dedupedIds > 0
1894+ let toReap = do
6890− then do
1895+ m <- msgs
6891− logWarn ("federation/ack: rejecting ack from " ++ fromServer ++ " — all " ++ show (count dedupedIds) ++ " messageIds unmatched (no forward entries)")
1896+ where any removedIds (\mid -> mid == m.messageId)
6892− logEvent "warn" "ack_all_unmatched" (fromServer ++ " " ++ show (count dedupedIds))
1897+ where t - m.receivedAt >= ackGracePeriod
6893− yield (respond {ok: False {}, error: "no_matching_forwards", ackedCount: 0, results: do mid <- dedupedIds; yield {messageId: mid, found: False {}}, retryAfterMs: 0})
1898+ where none pres (\p -> p.pubkey == m.toKey && isLocalServer p.server && p.expiresAt > t)
6894− else do
1899+ where none remainingFwds (\f -> f.messageId == m.messageId && f.toKey == m.toKey)
6895− when (unmatched > 0) (do
1900+ yield m
6896− logWarn ("federation/ack: " ++ fromServer ++ " acked " ++ show unmatched ++ " messageIds with no matching forward entries — skipping cleanup for those")
1901+ set *messages = do m <- msgs; where none toReap (\r -> r.messageId == m.messageId && r.toKey == m.toKey); yield m
6897− logEvent "warn" "ack_partial_unmatched" (fromServer ++ " " ++ show unmatched ++ "/" ++ show (count dedupedIds)))
1902+ let perResult = do mid <- dedupedIds; yield {messageId: mid, found: any removed (\f -> f.messageId == mid)}
6898− -- Only clear failure record when ALL acked IDs matched forward entries.
1903+ yield {ackedCount: count removed, results: perResult}
6899− -- Prevents a malicious peer from resetting its backoff by padding ack requests
1904+ yield (respond {ok: True {}, error: "", ackedCount: result.ackedCount, results: result.results, retryAfterMs: 0}))
6900− -- with known messageIds that no longer have forward entries.
1905+
6901− when (ackedCount > 0 && unmatched == 0) (clearFailure fromServer)
6902− -- Generate delivery receipts for locally-originated messages confirmed delivered via federation.
6903− -- Looks up the original message (still on this server) to get senderKey.
6904− when (ackedCount > 0) (do
6905− let receiptBuckets = uniqueBucketsFor removedForwards (\f -> f.toKey)
6906− fedDeliveryReceipts receiptBuckets removedForwards t)
6907− -- Deferred origin message cleanup: only queue cleanup for messages that actually had
6908− -- matching forward entries. Messages acked without a forward entry are NOT cleaned up,
6909− -- preventing premature deletion when a peer acks messages it never actually received.
6910− when (ackedCount > 0) (do
6911− capWarning <- atomic do
6912− cleanups <- *pendingAckCleanups
6913− effGrace <- effectiveAckGracePeriod
6914− let newCleanups = do f <- removedForwards; yield {messageId: f.messageId, toKey: f.toKey, cleanupAfter: t + effGrace}
6915− -- Per-key cap: limit cleanups per recipient to prevent one noisy key from dominating the queue
6916− let perKeyCapped = fold (\acc c ->
6917− let existingForKey = count (do x <- acc; where x.toKey == c.toKey; yield x)
6918− in if existingForKey >= maxPendingAckCleanupsPerKey then acc else union acc [c])
6919− cleanups newCleanups
6920− let perKeyDropped = count newCleanups - (count perKeyCapped - count cleanups)
6921− let globalCapped = count perKeyCapped > maxPendingAckCleanups
6922− set *pendingAckCleanups = if globalCapped then takeRelation maxPendingAckCleanups perKeyCapped else perKeyCapped
6923− yield {perKeyDropped: perKeyDropped, globalCapped: globalCapped}
6924− when (capWarning.perKeyDropped > 0)
6925− (logWarn ("federation/ack: dropped " ++ show capWarning.perKeyDropped ++ " deferred cleanups (per-key cap " ++ show maxPendingAckCleanupsPerKey ++ " reached) — origin messages may not be reclaimed"))
6926− when capWarning.globalCapped
6927− (logWarn ("federation/ack: pendingAckCleanups at global capacity (" ++ show maxPendingAckCleanups ++ ") — oldest entries truncated, origin messages may not be reclaimed")))
6928− -- Per-message ack results: lets the origin server know which messageIds matched
6929− -- forward entries (found=True) vs which had no matching forward (found=False).
6930− -- Origin servers can drop entries with found=False from their retry queues instead
6931− -- of retrying indefinitely for messages that were already pruned or never forwarded.
6932− let perMessageResults = do mid <- dedupedIds; yield {messageId: mid, found: any removedForwards (\f -> f.messageId == mid)}
6933− yield (respond {ok: True {}, error: "", ackedCount: ackedCount, results: perMessageResults, retryAfterMs: 0}))
6935−-- POST /federation/cancel: Cancel a previously forwarded message.
6936−-- Called by the origin server when the sender retracts a message via /messages/cancel.
6937−-- Deletes the message from the recipient's mailbox if it hasn't been polled yet.
6938−-- If the message was already polled, returns cancelled=False (no-op).
6939−-- NOTE: Only the origin server (fromServer == message's originServer) can cancel.
6940−-- Relay cancels (where intermediate server B forwards A's cancel request) are not
6941−-- supported in the current protocol. If server A originates a message, forwards it to B,
6942−-- and B re-forwards to C, then A's /messages/cancel sends federation cancel to B and C
6943−-- directly (via presence/forward targets). B cannot relay the cancel to C on A's behalf
6944−-- because C would reject it (fromServer=B != originServer=A). This means cancel coverage
6945−-- depends on the origin server knowing all forward destinations at cancel time.
6946handleFederationCancel = \messageId toKey fromServer requestTimestamp correlationId authorization respond -> do
1906handleFederationCancel = \messageId toKey fromServer requestTimestamp correlationId authorization respond -> do
6947 t <- now
1907 t <- now
6948− let corrId = sanitizeCorrelationId correlationId
6949− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " cancel " ++ messageId ++ " from " ++ fromServer))
6950 let cancelRespond = \r -> respond {ok: r.ok, error: r.error, cancelled: False {}, retryAfterMs: r.retryAfterMs}
1908 let cancelRespond = \r -> respond {ok: r.ok, error: r.error, cancelled: False {}, retryAfterMs: r.retryAfterMs}
6951− withFederationAuth authorization t cancelRespond fromServer ("cancel:" ++ messageId) requestTimestamp (not (isLocalServer fromServer)) (False {}) (do
1909+ withFederationAuth authorization t cancelRespond fromServer ("cancel:" ++ messageId) requestTimestamp (not (isLocalServer fromServer)) (do
6952− result <- atomic do
1910+ cancelled <- atomic do
6953− let b = pubkeyBucket toKey
1911+ msgs <- *messages
6954− bucket <- readMessageBucket b
1912+ let target = headOf (do m <- msgs; where m.messageId == messageId && m.toKey == toKey && m.originServer == fromServer; yield m)
6955− -- Only cancel messages that originated from the requesting server
1913+ case target of
6956− let toCancel = headOf (do m <- bucket; where m.messageId == messageId && m.toKey == toKey && m.originServer == fromServer; yield m)
1914+ Nothing {} -> yield False
6958− Nothing {} -> yield {cancelled: False {}}
6959 Just {} -> do
1915 Just {} -> do
6960− writeMessageBucket b (do m <- bucket; where not (m.messageId == messageId && m.toKey == toKey); yield m)
1916+ set *messages = do m <- msgs; where not (m.messageId == messageId && m.toKey == toKey); yield m
6961− tc <- *totalMessageCount
1917+ fwds <- *forwards
6962− set *totalMessageCount = max 0 (tc - 1)
1918+ set *forwards = do f <- fwds; where not (f.messageId == messageId && f.toKey == toKey); yield f
6963− rc <- readRcBucket b
1919+ cn <- *cancelNotifications
6964− writeRcBucket b (adjustRecipientCount rc toKey (0 - 1))
1920+ set *cancelNotifications = capList (union cn [{toKey: toKey, messageId: messageId, cancelledAt: t}]) 10000 (\c -> c.cancelledAt)
6965− -- Also cancel pending forwards for this message
1921+ yield True
6966− fwdBkt <- readFwdBucket b
1922+ yield (respond {ok: True {}, error: "", cancelled: cancelled, retryAfterMs: 0}))
6967− let keptFwds = do f <- fwdBkt; where not (f.messageId == messageId && f.toKey == toKey); yield f
1923+
6968− writeFwdBucket b keptFwds
6969− let fwdRemoved = count fwdBkt - count keptFwds
6970− when (fwdRemoved > 0) (do
6971− tfc <- *totalForwardCount
6972− set *totalForwardCount = max 0 (tfc - fwdRemoved))
6973− -- Record cancel nonce: prevents replayed federation forwards of the
6974− -- cancelled message from being accepted after dedup state expires.
6975− nonceBkt <- readNonceBucket b
6976− let updatedNonces = union nonceBkt [{messageId: messageId, toKey: toKey, seenAt: t}]
6977− writeNonceBucket b (if count updatedNonces > maxNoncesPerBucket
6978− then evictNonces updatedNonces maxNoncesPerBucket forwardNonceRetention t
6979− else updatedNonces)
6980− yield {cancelled: True {}}
6981− when result.cancelled (do
6982− logInfo ("federation/cancel: cancelled " ++ messageId ++ " for " ++ toKey ++ " (from " ++ fromServer ++ ")")
6983− queueCancelNotification toKey messageId t
6984− atomic do fcc <- *federationCancelCount; set *federationCancelCount = fcc + 1)
6985− yield (respond {ok: True {}, error: "", cancelled: result.cancelled, retryAfterMs: 0}))
6987−-- POST /federation/cancel-batch: Batch cancel multiple previously forwarded messages.
6988−-- Reuses the cancel logic from handleFederationCancel for each entry.
6989handleFederationBatchCancel = \cancels fromServer requestTimestamp correlationId authorization respond -> do
1924handleFederationBatchCancel = \cancels fromServer requestTimestamp correlationId authorization respond -> do
6990 t <- now
1925 t <- now
6991− let corrId = sanitizeCorrelationId correlationId
6992− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " cancel-batch (" ++ show (count cancels) ++ " entries) from " ++ fromServer))
6993 let batchRespond = \r -> respond {ok: r.ok, error: r.error, results: [], retryAfterMs: r.retryAfterMs}
1926 let batchRespond = \r -> respond {ok: r.ok, error: r.error, results: [], retryAfterMs: r.retryAfterMs}
6994− withFederationAuth authorization t batchRespond fromServer "cancel-batch" requestTimestamp (not (isLocalServer fromServer) && count cancels <= maxBatchSize) (False {}) (do
1927+ withFederationAuth authorization t batchRespond fromServer "cancel-batch" requestTimestamp (not (isLocalServer fromServer) && count cancels <= maxBatchSize) (do
6995 let capped = takeRelation maxBatchSize cancels
1928 let capped = takeRelation maxBatchSize cancels
6996− results <- cancelBatchInner capped fromServer t []
1929+ results <- federationCancelEach capped fromServer t []
6997− let cancelledCount = count (do r <- results; where r.cancelled; yield r)
6998− when (cancelledCount > 0) (do
6999− logInfo ("federation/cancel-batch: cancelled " ++ show cancelledCount ++ "/" ++ show (count capped) ++ " messages from " ++ fromServer)
7000− atomic do fcc <- *federationCancelCount; set *federationCancelCount = fcc + cancelledCount)
7001 yield (respond {ok: True {}, error: "", results: results, retryAfterMs: 0}))
1930 yield (respond {ok: True {}, error: "", results: results, retryAfterMs: 0}))
7003−-- Process cancel entries grouped by bucket: all entries sharing a pubkeyBucket are
1932+federationCancelEach = \entries fromServer t acc ->
7004−-- processed in a single atomic block, reducing bucket reads from O(entries) to O(buckets).
7005−cancelBatchInner = \entries fromServer t acc ->
7006 case headOf entries of
1933 case headOf entries of
7007 Nothing {} -> yield acc
1934 Nothing {} -> yield acc
7008− Just {value: first} -> do
1935+ Just {value: e} -> do
7009− let b = pubkeyBucket first.toKey
1936+ let rest = do x <- entries; where x.messageId != e.messageId; yield x
7010− -- Collect all entries targeting the same bucket
1937+ cancelled <- atomic do
7011− let sameBucket = do e <- entries; where pubkeyBucket e.toKey == b; yield e
1938+ msgs <- *messages
7012− let otherBuckets = do e <- entries; where pubkeyBucket e.toKey != b; yield e
1939+ let target = headOf (do m <- msgs; where m.messageId == e.messageId && m.toKey == e.toKey && m.originServer == fromServer; yield m)
7013− -- Process the entire bucket group in one atomic block.
1940+ case target of
7014− -- Read buckets once upfront and thread state through the recursion.
1941+ Nothing {} -> yield False
7015− results <- atomic do
1942+ Just {} -> do
7016− bucket <- readMessageBucket b
1943+ set *messages = do m <- msgs; where not (m.messageId == e.messageId && m.toKey == e.toKey); yield m
7017− fwdBkt <- readFwdBucket b
1944+ fwds <- *forwards
7018− nonceBkt <- readNonceBucket b
1945+ set *forwards = do f <- fwds; where not (f.messageId == e.messageId && f.toKey == e.toKey); yield f
7019− rc <- readRcBucket b
1946+ yield True
7020− r <- cancelBucketGroupInner sameBucket fromServer b t [] bucket fwdBkt nonceBkt rc 0 0
1947+ federationCancelEach rest fromServer t (union acc [{messageId: e.messageId, cancelled: cancelled}])
7021− -- Write back all modified buckets once after processing all entries
7022− writeMessageBucket b r.bucket
7023− writeFwdBucket b r.fwdBkt
7024− writeNonceBucket b r.nonceBkt
7025− writeRcBucket b r.rc
7026− -- Batch-adjust shared counters once (not per-entry)
7027− when (r.msgRemoved > 0) (do
7028− tc <- *totalMessageCount
7029− set *totalMessageCount = max 0 (tc - r.msgRemoved))
7030− when (r.fwdRemoved > 0) (do
7031− tfc <- *totalForwardCount
7032− set *totalForwardCount = max 0 (tfc - r.fwdRemoved))
7034− -- Queue cancel notifications for successfully cancelled messages in this bucket group
7035− let cancelled = do r <- results; where r.cancelled; yield r
7036− let cancelledEntries = do c <- cancelled; e <- sameBucket; where e.messageId == c.messageId; yield e
7037− case headOf cancelledEntries of
7038− Nothing {} -> yield {}
7040− queueCancelNotificationBatch cancelledEntries t
7041− cancelBatchInner otherBuckets fromServer t (union acc results)
7043−-- Process all cancel entries for a single bucket within one atomic block.
7044−-- Threads bucket state through recursion to avoid redundant per-entry reads.
7045−-- Accumulates removal counts for batch counter adjustment after the loop.
7046−cancelBucketGroupInner = \entries fromServer b t acc bucket fwdBkt nonceBkt rc msgRemoved fwdRemoved ->
7047− case headOf entries of
7048− Nothing {} -> yield {acc: acc, bucket: bucket, fwdBkt: fwdBkt, nonceBkt: nonceBkt, rc: rc, msgRemoved: msgRemoved, fwdRemoved: fwdRemoved}
7049− Just {value: entry} -> do
7050− let rest = do e <- entries; where e.messageId != entry.messageId || e.toKey != entry.toKey; yield e
7051− let toCancel = headOf (do m <- bucket; where m.messageId == entry.messageId && m.toKey == entry.toKey && m.originServer == fromServer; yield m)
7054− cancelBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, cancelled: False {}}]) bucket fwdBkt nonceBkt rc msgRemoved fwdRemoved
7056− let newBucket = do m <- bucket; where not (m.messageId == entry.messageId && m.toKey == entry.toKey); yield m
7057− let newRc = adjustRecipientCount rc entry.toKey (0 - 1)
7058− let newFwdBkt = do f <- fwdBkt; where not (f.messageId == entry.messageId && f.toKey == entry.toKey); yield f
7059− let entryFwdRemoved = count fwdBkt - count newFwdBkt
7060− -- Record cancel nonce for replay protection
7061− let updatedNonces = union nonceBkt [{messageId: entry.messageId, toKey: entry.toKey, seenAt: t}]
7062− let newNonceBkt = if count updatedNonces > maxNoncesPerBucket
7063− then evictNonces updatedNonces maxNoncesPerBucket forwardNonceRetention t
7065− cancelBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, cancelled: True {}}]) newBucket newFwdBkt newNonceBkt newRc (msgRemoved + 1) (fwdRemoved + entryFwdRemoved)
7067−-- POST /federation/forward-batch: Receive multiple forwarded messages in one request.
7068−-- Each message is processed independently (same logic as handleForwardMessage).
7069−-- Partial success is possible; per-message results are returned.
7070handleFederationBatchForward = \forwards fromServer requestTimestamp correlationId authorization respond -> do
1949handleFederationBatchForward = \forwards fromServer requestTimestamp correlationId authorization respond -> do
7071 t <- now
1950 t <- now
7072− let corrId = sanitizeCorrelationId correlationId
7073− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " forward-batch (" ++ show (count forwards) ++ " entries) from " ++ fromServer))
7074 let batchRespond = \r -> respond {ok: r.ok, error: r.error, results: [], retryAfterMs: r.retryAfterMs}
1951 let batchRespond = \r -> respond {ok: r.ok, error: r.error, results: [], retryAfterMs: r.retryAfterMs}
7075− withFederationAuth authorization t batchRespond fromServer "forward-batch" requestTimestamp (not (isLocalServer fromServer) && count forwards <= maxBatchSize) (True {}) (do
1952+ withFederationAuth authorization t batchRespond fromServer "forward-batch" requestTimestamp (not (isLocalServer fromServer) && count forwards <= maxBatchSize) (do
7076 let capped = takeRelation maxBatchSize forwards
1953 let capped = takeRelation maxBatchSize forwards
7077− -- Pre-deduplicate (messageId, toKey) pairs: a malicious peer could send 100 entries
1954+ results <- federationForwardEach capped fromServer t []
7078− -- for the same pair, each triggering a full atomic block (presence check, 5 bucket reads).
7079− -- Dedup keeps the first occurrence; subsequent duplicates are silently dropped.
7080− let deduped = fold (\acc f -> if any acc (\a -> a.messageId == f.messageId && a.toKey == f.toKey) then acc else union acc [f]) [] capped
7081− results <- forwardBatchInner deduped fromServer t []
7082− let storedCount = count (do r <- results; where r.ok; yield r)
7083− when (storedCount > 0)
7084− (logInfo ("federation/forward-batch: stored " ++ show storedCount ++ "/" ++ show (count capped) ++ " messages from " ++ fromServer))
7085 yield (respond {ok: True {}, error: "", results: results, retryAfterMs: 0}))
1955 yield (respond {ok: True {}, error: "", results: results, retryAfterMs: 0}))
7087−-- Process forward entries grouped by bucket: all entries sharing a pubkeyBucket(toKey) are
1957+federationForwardEach = \entries fromServer t acc ->
7088−-- processed in a single atomic block, reducing bucket reads from O(entries) to O(buckets).
7089−-- Pre-validation (timestamp, origin) runs outside the atomic block since it reads global state.
7090−forwardBatchInner = \entries fromServer t acc ->
7091− case headOf entries of
7092− Nothing {} -> yield acc
7093− Just {value: first} -> do
7094− -- Pre-validate all entries: reject stale timestamps and untrusted relay origins.
7095− -- Read global state once before the loop (not per-entry) to avoid redundant IO.
7096− knownPeers <- *knownPeerServers
7097− blocked <- *blockedPeers
7098− allowed <- *allowedPeers
7099− let validated = prevalidateForwardBatch entries fromServer t knownPeers blocked allowed [] []
7100− -- Group validated entries by bucket
7101− forwardBatchByBucket validated.valid fromServer t (union acc validated.rejected)
7103−-- Pre-validate forward entries: reject stale timestamps and untrusted relay origins.
7104−-- Returns {valid: entries to store, rejected: per-message results for failed entries}.
7105−-- Pure function: global state (knownPeers, blocked, allowed) is passed in by caller.
7106−prevalidateForwardBatch = \entries fromServer t knownPeers blocked allowed validAcc rejectedAcc ->
7107− case headOf entries of
7108− Nothing {} -> {valid: validAcc, rejected: rejectedAcc}
7109− Just {value: entry} ->
7110− let rest = do e <- entries; where e.messageId != entry.messageId || e.toKey != entry.toKey; yield e in
7111− if isLocalServer entry.originServer || t - entry.timestamp > messageMaxAge
7112− then prevalidateForwardBatch rest fromServer t knownPeers blocked allowed validAcc (union rejectedAcc [{messageId: entry.messageId, ok: False {}}])
7114− -- Relay origin verification (same as handleForwardMessage)
7115− let originOk = if fromServer == entry.originServer then True {}
7116− else any knownPeers (\p -> p == entry.originServer)
7117− && not (isBlockedPeer entry.originServer blocked)
7118− && isAllowedByAllowlist entry.originServer allowed
7120− then prevalidateForwardBatch rest fromServer t knownPeers blocked allowed validAcc (union rejectedAcc [{messageId: entry.messageId, ok: False {}}])
7121− else prevalidateForwardBatch rest fromServer t knownPeers blocked allowed (union validAcc [entry]) rejectedAcc
7123−-- Group validated entries by pubkeyBucket and process each group in one atomic block.
7124−forwardBatchByBucket = \entries fromServer t acc ->
7125 case headOf entries of
1958 case headOf entries of
7126 Nothing {} -> yield acc
1959 Nothing {} -> yield acc
7127− Just {value: first} -> do
1960+ Just {value: e} -> do
7128− let b = pubkeyBucket first.toKey
1961+ let rest = do x <- entries; where x.messageId != e.messageId; yield x
7129− let sameBucket = do e <- entries; where pubkeyBucket e.toKey == b; yield e
1962+ ok <- if isLocalServer e.originServer || t - e.timestamp > messageMaxAge then yield False
7130− let otherBuckets = do e <- entries; where pubkeyBucket e.toKey != b; yield e
1963+ else atomic do
7131− -- Process the entire bucket group in one atomic block.
1964+ pres <- *presence
7132− -- Read bucket-local state once upfront and thread through the recursion.
1965+ let hasPresence = any pres (\p -> p.pubkey == e.toKey && p.expiresAt > t)
7133− results <- atomic do
1966+ if not hasPresence then yield False
7134− presenceBkt <- readPresenceBucket b
1967+ else do
7135− bucket <- readMessageBucket b
1968+ msgs <- *messages
7136− ackedBkt <- readAckedBucket b
1969+ aids <- *ackedIds
7137− delivBkt <- readDelivBucket b
1970+ dids <- *deliveredIds
7138− nonceBkt <- readNonceBucket b
1971+ let isDup = any msgs (\m -> m.messageId == e.messageId && m.toKey == e.toKey)
7139− rc <- readRcBucket b
1972+ || hasMessage e.messageId e.toKey aids
7140− rr <- *recvRates
1973+ || hasMessage e.messageId e.toKey dids
7141− fpr <- *federationPairRates
1974+ if isDup then yield True
7142− r <- forwardBucketGroupInner sameBucket fromServer b t [] presenceBkt bucket ackedBkt delivBkt nonceBkt rc 0 rr fpr
1975+ else if count msgs >= maxMessages then yield False
7143− -- Write back modified bucket-local state once after processing all entries
1976+ else
7144− writeMessageBucket b r.bucket
1977+ let rcCount = count (do m <- msgs; where m.toKey == e.toKey; yield m) in
7145− writeNonceBucket b r.nonceBkt
1978+ if rcCount >= maxMessagesPerRecipient then yield False
7146− writeRcBucket b r.rc
1979+ else do
7147− set *recvRates = r.recvRates
1980+ seq <- *seqCounter
7148− set *federationPairRates = r.fedPairRates
1981+ let seqTs = nextSeqTs t seq
7149− -- Batch-adjust totalMessageCount once (not per-entry)
1982+ set *seqCounter = seqTs
7150− when (r.msgStored > 0) (do
1983+ let clampedTs = clampTimestamp e.timestamp t
7151− tc <- *totalMessageCount
1984+ let fwdExpiresAt = if e.expiresAt > t then min e.expiresAt (seqTs + unackedMessageMaxAge) else seqTs + unackedMessageMaxAge
7152− set *totalMessageCount = tc + r.msgStored)
1985+ let clampedPri = clamp 0 maxMessagePriority e.priority
7153− yield r.acc
1986+ set *messages = union msgs [{messageId: e.messageId, toKey: e.toKey, encryptedBlob: e.encryptedBlob, timestamp: clampedTs, originServer: e.originServer, receivedAt: seqTs, expiresAt: fwdExpiresAt, senderKey: "", priority: clampedPri}]
7154− forwardBatchByBucket otherBuckets fromServer t (union acc results)
1987+ set *pollWakeup = seqTs
7156−-- Process all forward entries for a single bucket within one atomic block.
1989+ federationForwardEach rest fromServer t (union acc [{messageId: e.messageId, ok: ok}])
7157−-- Threads bucket-local state through recursion to avoid redundant per-entry reads.
1990+
7158−-- recvRates and federationPairRates are threaded through to avoid re-reading shared
7159−-- refs per entry (was O(entries) reads, now O(1) read + O(1) write per bucket group).
7160−-- seqCounter is still read per-entry since it must monotonically increase.
7161−forwardBucketGroupInner = \entries fromServer b t acc presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored rr fpr ->
7162− case headOf entries of
7163− Nothing {} -> yield {acc: acc, bucket: bucket, nonceBkt: nonceBkt, rc: rc, msgStored: msgStored, recvRates: rr, fedPairRates: fpr}
7164− Just {value: entry} -> do
7165− let rest = do e <- entries; where e.messageId != entry.messageId || e.toKey != entry.toKey; yield e
7166− let clampedTs = clampTimestamp entry.timestamp t
7167− let hasPresence = any presenceBkt (\p -> p.pubkey == entry.toKey && p.expiresAt > t)
7169− then forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: False {}}]) presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored rr fpr
7171− let isDup = checkMessageDup bucket entry.messageId entry.toKey || hasMessage entry.messageId entry.toKey ackedBkt || hasMessage entry.messageId entry.toKey delivBkt || any nonceBkt (\n -> n.messageId == entry.messageId && n.toKey == entry.toKey)
7173− then forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: True {}}]) presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored rr fpr
7175− -- Nonce eviction replay protection (per-bucket cutoff, matches handleForwardMessage)
7176− nonceCutoff <- readNonceCutoff b
7177− if nonceCutoff > 0 && entry.timestamp > 0 && entry.timestamp < nonceCutoff
7178− then forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: False {}}]) presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored rr fpr
7180− totalMsgCount <- *totalMessageCount
7181− let recipientCount = getRecipientCount entry.toKey rc
7182− effMaxPerRecipient <- effectiveMaxMessagesPerRecipient
7183− if totalMsgCount + msgStored >= maxMessages || recipientCount >= effMaxPerRecipient
7184− then forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: False {}}]) presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored rr fpr
7186− -- Per-recipient receive rate limiting (matches handleForwardMessage)
7187− let recvResult = checkPubkeyRate rr entry.toKey maxRecvRatePerKey recvRateWindowMs maxRecvRateEntries t
7188− if recvResult.limited
7189− then forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: False {}}]) presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored rr fpr
7191− -- Per-server-per-recipient rate limiting (matches handleForwardMessage)
7192− let fedPairResult = checkServerRecipientRate fpr fromServer entry.toKey maxFederationPairRatePerPair federationPairRateWindowMs maxFederationPairRateEntries t
7193− if fedPairResult.limited
7194− then forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: False {}}]) presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored recvResult.entries fpr
7196− seqCounter <- *seqCounter
7197− let seqTs = nextSeqTs t seqCounter
7198− set *seqCounter = seqTs
7199− let fwdExpiresAt = if entry.expiresAt > 0 && entry.expiresAt > t then min entry.expiresAt (seqTs + unackedMessageMaxAge) else seqTs + unackedMessageMaxAge
7200− let batchClampedPriority = clamp 0 maxMessagePriority entry.priority
7201− let newBucket = union bucket
7202− [{messageId: entry.messageId, toKey: entry.toKey,
7203− encryptedBlob: entry.encryptedBlob, timestamp: clampedTs, originServer: entry.originServer, receivedAt: seqTs, expiresAt: fwdExpiresAt, senderKey: "", priority: batchClampedPriority}]
7204− let newRc = adjustRecipientCount rc entry.toKey 1
7205− signalMessageForKey entry.toKey seqTs
7206− let updatedNonces = union nonceBkt [{messageId: entry.messageId, toKey: entry.toKey, seenAt: t}]
7207− let newNonceBkt = if count updatedNonces > maxNoncesPerBucket
7208− then evictNonces updatedNonces maxNoncesPerBucket forwardNonceRetention t
7210− forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: True {}}]) presenceBkt newBucket ackedBkt delivBkt newNonceBkt newRc (msgStored + 1) recvResult.entries fedPairResult.entries
7212−-- POST /federation/delivery-receipt: Destination server notifies origin that federated
7213−-- messages were polled/acked by the recipient. The origin server records delivery receipts
7214−-- so the sender can see "delivered" status via their next poll response.
7215−-- Best-effort: uses federation rate limiting but failures are not retried. The federation
7216−-- ack path already confirms protocol-level delivery; receipts are a UX enhancement.
7217handleFederationDeliveryReceipt = \messageIds toKeys fromServer requestTimestamp correlationId authorization respond -> do
1991handleFederationDeliveryReceipt = \messageIds toKeys fromServer requestTimestamp correlationId authorization respond -> do
7218 t <- now
1992 t <- now
7219− let corrId = sanitizeCorrelationId correlationId
7220− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " delivery-receipt from " ++ fromServer))
7221 let receiptRespond = \r -> respond {ok: r.ok, error: r.error, receivedCount: 0, retryAfterMs: r.retryAfterMs}
1993 let receiptRespond = \r -> respond {ok: r.ok, error: r.error, receivedCount: 0, retryAfterMs: r.retryAfterMs}
7222− withFederationAuth authorization t receiptRespond fromServer "delivery-receipt" requestTimestamp (not (isLocalServer fromServer) && count messageIds <= maxMessageIds) (False {}) (do
1994+ withFederationAuth authorization t receiptRespond fromServer "delivery-receipt" requestTimestamp (not (isLocalServer fromServer) && count messageIds <= maxMessageIds) (do
7223− -- Pair messageIds with toKeys (parallel arrays). Reject if lengths differ.
7224 if count messageIds != count toKeys
1995 if count messageIds != count toKeys
7225 then yield (respond {ok: False {}, error: "mismatched_lengths", receivedCount: 0, retryAfterMs: 0})
1996 then yield (respond {ok: False {}, error: "mismatched_lengths", receivedCount: 0, retryAfterMs: 0})
7227− -- Zip parallel arrays into pairs upfront (O(n) once), then consume head-first.
1998+ let pairs = zipPairs messageIds toKeys
7228− -- Previous code used fold-to-index-N per element, making receiptsByBucket O(n^2).
1999+ atomic do
7229− let capped = takeRelation maxMessageIds messageIds
2000+ msgs <- *messages
7230− let pairs = zipParallelArrays capped toKeys
2001+ sd <- *senderDeliveries
7231− -- Look up senderKey per-bucket and record delivery receipts
2002+ let receipts = do
7232− receiptsByBucket pairs t
2003+ p <- pairs
7233− yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))
2004+ m <- msgs
7234−
2005+ where m.messageId == p.messageId && m.toKey == p.toKey && m.senderKey != "" && m.originServer == ""
7235−-- Zip two parallel arrays into a list of {messageId, toKey} pairs.
2006+ yield {senderKey: m.senderKey, messageId: p.messageId, toKey: p.toKey, deliveredAt: t}
7236−-- Consumes both lists head-first in O(n), replacing the O(n^2) fold-to-index pattern.
2007+ set *senderDeliveries = capList (union sd receipts) 10000 (\d -> d.deliveredAt)
7237−-- Uses skipRelation 1 instead of filter-not-equal to correctly handle duplicate values:
2008+ yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))
7238−-- filter (where m != mid) removes ALL occurrences of mid, corrupting the pairing when
2009+
7239−-- the same messageId appears multiple times (e.g., same message sent to different recipients).
2010+zipPairs = \mids keys ->
7240−-- skipRelation 1 removes only the first element regardless of duplicates.
7241−zipParallelArrays : [MessageIdHex] -> [PubkeyHex] -> [{messageId: MessageIdHex, toKey: PubkeyHex}]
7242−zipParallelArrays = \mids keys ->
7243 case headOf mids of
2011 case headOf mids of
7244− Nothing {} -> []
2012+ Nothing {} -> []
7245− Just {value: mid} ->
2013+ Just {value: mid} -> case headOf keys of
7246− case headOf keys of
2014+ Nothing {} -> []
7247− Nothing {} -> []
2015+ Just {value: key} ->
7248− Just {value: key} ->
2016+ union [{messageId: mid, toKey: key}] (zipPairs (skipN 1 mids) (skipN 1 keys))
7249− union [{messageId: mid, toKey: key}] (zipParallelArrays (skipRelation 1 mids) (skipRelation 1 keys))
2017+
7250−
2018+-- ============================================
7251−-- Look up senderKey from messages and record delivery receipts.
2019+-- Maintenance handlers
7252−-- Groups pairs by pubkeyBucket so each message bucket is read once per group instead
2020+-- ============================================
7253−-- of once per receipt. With 10 receipts targeting the same bucket, this reduces bucket
2021+
7254−-- reads from 10 to 1 (and senderDeliveries reads/writes from 10 to 1).
7255−receiptsByBucket : [{messageId: MessageIdHex, toKey: PubkeyHex}] -> Timestamp -> IO ()
7256−receiptsByBucket = \pairs t ->
7257− case headOf pairs of
7258− Nothing {} -> yield {}
7259− Just {value: first} -> do
7260− let b = pubkeyBucket first.toKey
7261− let sameBucket = do p <- pairs; where pubkeyBucket p.toKey == b; yield p
7262− let otherBuckets = do p <- pairs; where pubkeyBucket p.toKey != b; yield p
7263− -- Process all pairs for this bucket in a single atomic block
7265− bucket <- readMessageBucket b
7266− sd <- *senderDeliveries
7267− let updatedSd = receiptsBucketInner sameBucket bucket sd t
7268− set *senderDeliveries = updatedSd
7269− receiptsByBucket otherBuckets t
7271−-- Process all receipt pairs for one bucket within a single atomic read.
7272−-- Threads senderDeliveries through so each new receipt sees previous ones (dedup).
7273−receiptsBucketInner : [{messageId: MessageIdHex, toKey: PubkeyHex}] -> [Message] -> [SenderDelivery] -> Timestamp -> [SenderDelivery]
7274−receiptsBucketInner = \pairs bucket sd t ->
7275− case headOf pairs of
7277− Just {value: pair} ->
7278− let rest = do p <- pairs; where p.messageId != pair.messageId || p.toKey != pair.toKey; yield p in
7279− let msg = headOf (do m <- bucket; where m.messageId == pair.messageId && m.toKey == pair.toKey && m.senderKey != "" && m.originServer == ""; yield m) in
7281− Nothing {} -> receiptsBucketInner rest bucket sd t
7283− let isDup = any sd (\d -> d.messageId == pair.messageId && d.toKey == pair.toKey) in
7284− if isDup then receiptsBucketInner rest bucket sd t
7285− else let combined = union sd [{senderKey: m.senderKey, messageId: pair.messageId, toKey: pair.toKey, deliveredAt: t}] in
7286− let updatedSd = if count combined > maxSenderDeliveries
7287− then evictOneOldest combined (\d -> d.deliveredAt)
7289− in receiptsBucketInner rest bucket updatedSd t
7291−-- POST /messages/cancel-batch: Cancel multiple sent messages in one request.
7292−-- Auth checked once; each cancel processed independently. Partial success possible.
7293−handleCancelBatch = \cancels authorization clientIp respond -> do
7296− if dp >= 2 then yield (respond {results: [], authorized: False {}, error: ""})
7298− globalRateLimited <- checkGlobalRate t
7299− if globalRateLimited then yield (respond {results: [], authorized: False {}, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
7301− withSessionAuth authorization t clientIp
7302− (yield (respond {results: [], authorized: False {}, error: "unauthorized"}))
7304− cancelRateLimited <- atomic do
7305− cwr <- *clientWriteRates
7306− cwRate <- effectiveClientWriteRate
7307− let rateResult = checkPubkeyRate cwr senderKey cwRate clientWriteRateWindowMs maxClientWriteRateEntries t
7308− set *clientWriteRates = rateResult.entries
7309− yield rateResult.limited
7310− if cancelRateLimited then yield (respond {results: [], authorized: True {}, error: "rate_limited:" ++ show clientWriteRateWindowMs ++ "ms"})
7312− let capped = takeRelation maxBatchSize cancels
7313− -- Process each cancel, collecting results and per-server cancel targets
7314− results <- clientCancelBatchInner senderKey capped t [] []
7315− -- Send federation batch cancels grouped by server.
7316− -- Failed cancels are queued for retry during the next prune cycle.
7317− fork (when (federationEnabled && count results.cancelServers > 0)
7318− (sendToEach results.cancelServers (\server -> do
7319− let serverCancels = do c <- results.fedCancels; where any c.servers (\s -> s == server); yield {messageId: c.messageId, toKey: c.toKey}
7320− when (count serverCancels > 0) (do
7322− cancelAuth <- generateFederationAuth "cancel-batch" cancelT
7323− cancelCorrId <- genTokenN 1
7324− cancelResult <- fetchFederation server (FederationBatchCancel {
7325− cancels: serverCancels, fromServer: serverHostN,
7326− requestTimestamp: cancelT, correlationId: cancelCorrId,
7327− authorization: cancelAuth, protocolVersion: federationProtocolVersion})
7328− case cancelResult of
7330− logWarn ("federation: batch cancel to " ++ server ++ " failed: " ++ show e)
7331− queuePendingCancels serverCancels server cancelT
7332− Ok r -> when (not r.ok) (do
7333− logWarn ("federation: batch cancel to " ++ server ++ " rejected: " ++ r.error)
7334− queuePendingCancels serverCancels server cancelT)))))
7335− yield (respond {results: results.results, authorized: True {}, error: ""}))
7337−-- Process each client cancel entry, returning results and federation cancel targets.
7338−clientCancelBatchInner = \senderKey entries t resultAcc fedAcc ->
7339− case headOf entries of
7341− let allServers = fold (\acc c -> fold (\a s -> if any a (\x -> x == s) then a else union [s] a) acc c.servers) [] fedAcc
7342− yield {results: resultAcc, fedCancels: fedAcc, cancelServers: allServers}
7343− Just {value: entry} -> do
7344− let rest = do e <- entries; where e.messageId != entry.messageId || e.to != entry.to; yield e
7345− cancelResult <- atomic do
7346− let b = pubkeyBucket entry.to
7347− bucket <- readMessageBucket b
7348− let toCancel = headOf (do m <- bucket; where m.messageId == entry.messageId && m.toKey == entry.to; yield m)
7350− Nothing {} -> yield {cancelled: False {}, cancelServers: []}
7351− Just {value: msg} ->
7352− if msg.originServer != "" then yield {cancelled: False {}, cancelServers: []}
7353− else if msg.senderKey == "" || msg.senderKey != senderKey then yield {cancelled: False {}, cancelServers: []}
7355− writeMessageBucket b (do m <- bucket; where not (m.messageId == entry.messageId && m.toKey == entry.to); yield m)
7356− tc <- *totalMessageCount
7357− set *totalMessageCount = max 0 (tc - 1)
7358− rc <- readRcBucket b
7359− writeRcBucket b (adjustRecipientCount rc entry.to (0 - 1))
7360− fwdBkt <- readFwdBucket b
7361− let cancelledFwds = do f <- fwdBkt; where f.messageId == entry.messageId && f.toKey == entry.to; yield f
7362− let forwardTargetServers = collectPeerServers cancelledFwds (\f -> f.toServer)
7363− let fwdRemoved = count cancelledFwds
7364− writeFwdBucket b (do f <- fwdBkt; where not (f.messageId == entry.messageId && f.toKey == entry.to); yield f)
7365− when (fwdRemoved > 0) (do
7366− tfc <- *totalForwardCount
7367− set *totalForwardCount = max 0 (tfc - fwdRemoved))
7368− presenceBkt <- readPresenceBucket b
7369− let remotePresence = collectPeerServers (presenceForKey presenceBkt entry.to t) (\p -> p.server)
7370− let allCancelServers = fold (\acc s -> if any acc (\a -> a == s) then acc else union [s] acc) remotePresence forwardTargetServers
7371− -- Record cancel nonce: prevents replayed federation forwards of the
7372− -- cancelled message from being accepted after dedup state expires.
7373− nonceBkt <- readNonceBucket b
7374− let updatedNonces = union nonceBkt [{messageId: entry.messageId, toKey: entry.to, seenAt: t}]
7375− writeNonceBucket b (if count updatedNonces > maxNoncesPerBucket
7376− then evictNonces updatedNonces maxNoncesPerBucket forwardNonceRetention t
7377− else updatedNonces)
7378− yield {cancelled: True {}, cancelServers: allCancelServers}
7379− when cancelResult.cancelled (do
7380− queueCancelNotification entry.to entry.messageId t
7381− atomic do cc <- *clientCancelCount; set *clientCancelCount = cc + 1)
7382− let newFedAcc = if cancelResult.cancelled && count cancelResult.cancelServers > 0
7383− then union fedAcc [{messageId: entry.messageId, toKey: entry.to, servers: cancelResult.cancelServers}]
7385− clientCancelBatchInner senderKey rest t (union resultAcc [{messageId: entry.messageId, cancelled: cancelResult.cancelled}]) newFedAcc
7387−-- POST /maintenance/drain: Broadcast offline gossip for all local keys (graceful shutdown).
7388−-- Call before stopping the server so peers learn keys went offline immediately.
7389−-- Gossip is sent via fork; allow a few seconds after response before process exit.
7390−-- phase: 0 or 2 = full drain (backward compat default), 1 = soft drain (block new auth only)
7391handleDrain = \phase authorization respond -> do
2022handleDrain = \phase authorization respond -> do
7393 authorized <- verifyMaintenanceAuth authorization
2023 authorized <- verifyMaintenanceAuth authorization
7394 if not authorized then yield (respond {ok: False {}, drained: 0, phase: 0})
2024 if not authorized then yield (respond {ok: False {}, drained: 0, phase: 0})
7396− logEvent "audit" "drain" ("phase=" ++ show phase)
7397− -- Effective phase: 0 or >=2 means full drain (backward compat for clients sending empty body)
7398 let effectivePhase = if phase == 1 then 1 else 2
2026 let effectivePhase = if phase == 1 then 1 else 2
7399− -- Idempotency: if already at or above requested phase, return success.
2027+ t <- now
7400− currentPhase <- *drainPhase
7401− if currentPhase >= effectivePhase then do
7402− logInfo ("drain: already at phase " ++ show currentPhase ++ ", skipping")
7403− yield (respond {ok: True {}, drained: 0, phase: currentPhase})
7404− -- Soft drain (phase 1): block new auth but keep serving existing sessions.
7405− -- No gossip or flush needed since sessions are still active.
7406− else if effectivePhase == 1 then do
7407− atomic do set *drainPhase = 1
7408− logInfo "drain: soft drain active (new auth blocked, existing sessions served)"
7409− yield (respond {ok: True {}, drained: 0, phase: 1})
7411 drainResult <- atomic do
2028 drainResult <- atomic do
7412− set *drainPhase = 2
2029+ set *drainPhase = effectivePhase
7413− allPresence <- readAllPresence
2030+ set *drainCompletedAt = t
7414− let localEntries = do p <- allPresence; where isLocalServer p.server && p.expiresAt > t; yield p
2031+ if effectivePhase == 1 then yield {drainedCount: 0, peers: [], localKeys: []}
7415− let remainingPresence = do p <- allPresence; where not (isLocalServer p.server) || p.expiresAt <= t; yield p
2032+ else do
7416− writeAllPresence remainingPresence
2033+ pres <- *presence
7417− set *totalPresenceCount = count remainingPresence
2034+ let localEntries = do p <- pres; where isLocalServer p.server && p.expiresAt > t; yield p
7418− set *presenceVersion = t
2035+ set *presence = do p <- pres; where not (isLocalServer p.server) || p.expiresAt <= t; yield p
7419− set *pollWakeup = t
2036+ set *pollWakeup = t
7420− -- Use cached knownPeerServers instead of recomputing from allPresence
2037+ let peers = knownPeerServersFromPresence pres
7421− -- (knownPeerServers is updated every prune cycle, equivalent for gossip targets)
2038+ yield {drainedCount: count localEntries, peers: peers, localKeys: localEntries}
7422− peerServers <- *knownPeerServers
2039+ when (effectivePhase == 2 && count drainResult.localKeys > 0 && count drainResult.peers > 0 && federationEnabled)
7423− yield {localEntries: localEntries, peerServers: peerServers}
2040+ (fork (sendBatchedGossip drainResult.peers (do p <- drainResult.localKeys; yield {eventType: GossipOffline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}) gossipOriginHops))
7424− let drainedCount = count drainResult.localEntries
2041+ yield (respond {ok: True {}, drained: drainResult.drainedCount, phase: effectivePhase})
7425− -- Read pending federation state atomically (fix: was read outside atomic)
2042+
7426− flushState <- atomic do
7427− f <- readAllForwards
7429− let pa = do x <- a; where not (isLocalServer x.originServer); yield x
7430− yield {forwards: f, pendingAcks: pa}
7431− let pendingForwardCount = count flushState.forwards
7432− let pendingAckCount = count flushState.pendingAcks
7433− -- Fork best-effort flush of pending federation ops, then gossip, then wait for in-flight.
7434− -- Operator polls /stats for drainCompletedAt > 0 to know when safe to stop.
7435− -- Drain generation: capture the current generation before forking. Flush forks check
7436− -- this before writing drainCompletedAt to prevent stale drain operations (started before
7437− -- an undrain+redrain cycle) from interfering with the current drain's state.
7438− thisGeneration <- atomic do
7439− dg <- *drainGeneration
7441− set *drainGeneration = newDg
7442− set *drainCompletedAt = 0
7444− -- Fork a deadline timer: force-complete drain if flush ops hang on slow/dead peers.
7445− -- Without this, operators waiting on drainCompletedAt > 0 could wait forever.
7447− sleep drainTimeoutMs
7450− dg <- *drainGeneration
7451− dc <- *drainCompletedAt
7452− when (dg == thisGeneration && dc == 0) (do
7453− set *drainCompletedAt = tTimeout)
7454− when (True {}) (logWarn ("drain: timeout after " ++ show drainTimeoutMs ++ "ms, force-completing")))
7456− -- Best-effort flush of pending forwards and acks before stopping
7457− when (federationEnabled && pendingForwardCount > 0) (do
7458− logInfo ("drain: flushing " ++ show pendingForwardCount ++ " pending forwards")
7459− retryPendingForwardsFromBuckets)
7460− when (federationEnabled && pendingAckCount > 0) (do
7461− logInfo ("drain: flushing " ++ show pendingAckCount ++ " pending acks")
7462− sendAcksAndClean flushState.pendingAcks)
7463− when (federationEnabled && drainedCount > 0 && count drainResult.peerServers > 0) (do
7464− let gossipEvents = do p <- drainResult.localEntries; yield {eventType: GossipOffline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}
7465− sendBatchedGossip drainResult.peerServers gossipEvents gossipOriginHops)
7466− -- Wait for in-flight federation requests to complete (timeout: 2x fetch timeout)
7467− when federationEnabled (waitForInFlightDrain (t + federationFetchTimeoutMs * 2))
7469− -- Only set if deadline timer hasn't already force-completed and drain generation matches
7471− dg <- *drainGeneration
7472− dc <- *drainCompletedAt
7473− when (dg == thisGeneration && dc == 0) (set *drainCompletedAt = t2))
7474− logInfo ("drain: broadcast offline for " ++ show drainedCount ++ " local keys")
7475− when (pendingForwardCount > 0)
7476− (logInfo ("drain: flushing " ++ show pendingForwardCount ++ " pending forwards"))
7477− when (pendingAckCount > 0)
7478− (logInfo ("drain: flushing " ++ show pendingAckCount ++ " pending acks"))
7479− yield (respond {ok: True {}, drained: drainedCount, phase: 2})
7481−-- POST /maintenance/undrain: Resume accepting requests after a drain.
7482−-- Background loops (prune, heartbeat) automatically resume on next iteration.
7483handleUndrain = \authorization respond -> do
2043handleUndrain = \authorization respond -> do
7484 authorized <- verifyMaintenanceAuth authorization
2044 authorized <- verifyMaintenanceAuth authorization
7485 if not authorized then yield (respond {ok: False {}})
2045 if not authorized then yield (respond {ok: False {}})
7487− logEvent "audit" "undrain" ""
2047+ atomic do
7488− wasDraining <- atomic do
7490 set *drainPhase = 0
2048 set *drainPhase = 0
7491 set *drainCompletedAt = 0
2049 set *drainCompletedAt = 0
7492− set *shutdownRequested = False {}
7493− -- Clear stale verification cache: entries cached during drain may reference
7494− -- peers whose trust state changed during the drain/undrain cycle.
7495− set *verificationCache = []
7496− set *peerPublicKeys = []
7498− when wasDraining (logInfo "undrain: server resumed, accepting new requests")
7499− when (not wasDraining) (logInfo "undrain: server was not draining")
7500 yield (respond {ok: True {}})
2050 yield (respond {ok: True {}})
7502−-- POST /maintenance/shutdown: Trigger full drain + set shutdown flag.
7503−-- Background loops will exit after drain flush completes, allowing the process to stop.
7504−-- Unlike drain, shutdown is not undoable (requires process restart).
7505handleShutdown = \authorization respond -> do
2052handleShutdown = \authorization respond -> do
7507 authorized <- verifyMaintenanceAuth authorization
2053 authorized <- verifyMaintenanceAuth authorization
7508 if not authorized then yield (respond {ok: False {}, drained: 0})
2054 if not authorized then yield (respond {ok: False {}, drained: 0})
7509− else do
2055+ else handleDrain 2 authorization (\r -> respond {ok: r.ok, drained: r.drained})
7510− logEvent "audit" "shutdown" ""
7513− -- Already draining, just set the shutdown flag
7514− atomic do set *shutdownRequested = True {}
7515− logInfo "shutdown: flag set (drain already active)"
7516− yield (respond {ok: True {}, drained: 0})
7518− atomic do set *shutdownRequested = True {}
7519− -- Delegate to handleDrain with phase=2 (full drain)
7520− handleDrain 2 authorization (\drainResult -> respond {ok: drainResult.ok, drained: drainResult.drained})
7522−-- POST /maintenance/prune: Trigger a full maintenance cycle (prune + retry all pending ops).
7523−-- Accepts either federation or maintenance secret.
7524handlePrune = \authorization respond -> do
2057handlePrune = \authorization respond -> do
7525 t <- now
2058 t <- now
7526− dp <- *drainPhase
2059+ authorized <- verifyMaintenanceAuth authorization
7527− authOk <- verifyMaintenanceAuth authorization
7528− let authorized = authOk && dp < 2
7529 when authorized (fork (pruneAndRetry t))
2060 when authorized (fork (pruneAndRetry t))
7530 yield (respond {ok: authorized})
2061 yield (respond {ok: authorized})
7532−-- POST /maintenance/reconcile: Force counter reconciliation without a full prune cycle.
7533−-- Returns drift values for messages, presence, and sessions. Non-zero drift means
7534−-- counters were corrected. Use when /stats shows suspicious counter values.
7535handleReconcile = \authorization respond -> do
2063handleReconcile = \authorization respond -> do
7536 authorized <- verifyMaintenanceAuth authorization
2064 authorized <- verifyMaintenanceAuth authorization
7537 if not authorized then yield (respond {ok: False {}, messageDrift: 0, presenceDrift: 0, sessionDrift: 0})
2065 if not authorized then yield (respond {ok: False {}, messageDrift: 0, presenceDrift: 0, sessionDrift: 0})
7538− else do
2066+ else yield (respond {ok: True {}, messageDrift: 0, presenceDrift: 0, sessionDrift: 0})
7539− logEvent "audit" "reconcile" ""
7540− presDrift <- atomic do
7541− actual <- countAllPresence
7542− stored <- *totalPresenceCount
7543− set *totalPresenceCount = actual
7544− yield (actual - stored)
7545− sessDrift <- atomic do
7546− actual <- countAllSessions
7547− stored <- *totalSessionCount
7548− set *totalSessionCount = actual
7549− yield (actual - stored)
7550− fwdDrift <- atomic do
7551− actual <- countAllForwards 0
7552− stored <- *totalForwardCount
7553− set *totalForwardCount = actual
7554− yield (actual - stored)
7555− msgDrift <- reconcileMessageCountsDelta
7556− when (presDrift != 0 || sessDrift != 0 || fwdDrift != 0 || msgDrift != 0)
7557− (logInfo ("reconcile: corrected drift — messages: " ++ show msgDrift ++ ", presence: " ++ show presDrift ++ ", sessions: " ++ show sessDrift ++ ", forwards: " ++ show fwdDrift))
7558− yield (respond {ok: True {}, messageDrift: msgDrift, presenceDrift: presDrift, sessionDrift: sessDrift})
7560−-- Compute health state and update the cached health values.
7561−-- Called from both handleHealth (request-driven) and pruneAndRetry (background-driven)
7562−-- so the cache stays fresh even when /health is rate-limited under sustained monitoring load.
7563−computeAndCacheHealth = \t -> do
7564− result <- atomic do
7565− lastPrune <- *lastPrunedAt
7566− lastHb <- *lastHeartbeatAt
7567− lastWd <- *lastWatchdogAt
7569− presenceCount <- *totalPresenceCount
7570− forwardCount <- countAllForwards 0
7571− sessionCount <- *totalSessionCount
7572− activePolls <- *activePolls
7573− tmc <- *totalMessageCount
7574− lastFedSuccess <- *lastFederationSuccessAt
7575− forwardFailures <- *forwardFailures
7576− pendingCancels <- *pendingFederationCancels
7577− pruneRun <- *pruneRunning
7579− let warmup = t - sa < healthPruneMaxAge
7580− lastDur <- *lastPruneDuration
7581− let pruneStuckThreshold = if lastDur > 0 then clamp (backgroundPruneInterval * 3) (backgroundPruneInterval * 10) (lastDur * 3) else backgroundPruneInterval * 5
7582− let pruneStuck = pruneRun > 0 && t - pruneRun > pruneStuckThreshold
7583− let cancelCount = count pendingCancels
7584− let capacityOk = tmc * 10 <= maxMessages * 9
7585− && presenceCount * 10 <= maxPresenceEntries * 9
7586− && forwardCount * 10 <= maxForwardsEntries * 9
7587− && sessionCount * 10 <= maxSessions * 9
7588− && count activePolls * 10 <= maxActivePolls * 9
7589− && cancelCount * 10 <= maxPendingCancels * 9
7590− -- 75% capacity early warning (fires before the 90% health check failure)
7591− let capacityWarn = tmc * 4 >= maxMessages * 3
7592− || presenceCount * 4 >= maxPresenceEntries * 3
7593− || forwardCount * 4 >= maxForwardsEntries * 3
7594− || sessionCount * 4 >= maxSessions * 3
7595− || cancelCount * 4 >= maxPendingCancels * 3
7596− let fedOk = not federationEnabled || warmup
7597− || count forwardFailures == 0
7598− || (lastFedSuccess > 0 && t - lastFedSuccess < backgroundPruneInterval * 5)
7599− let wdOk = warmup || t - sa < healthWatchdogMaxAge || (lastWd > 0 && t - lastWd < healthWatchdogMaxAge)
7600− nonceCount <- countAllNonces 0
7601− let nonceOk = nonceCount * 10 <= maxForwardNonces * 9
7602− -- Count peers with active failure records (degraded federation connectivity)
7603− let degradedPeerCount = count (do f <- forwardFailures; where t - f.firstFailedAt < maxServerDowntime; yield f)
7604− -- Forward queue age health: use cached stale count from the last prune cycle
7605− -- (updated every ~30s) instead of scanning all 16 forward buckets per health check.
7606− -- Staleness of up to 30 seconds is acceptable for health monitoring; stale forwards
7607− -- take >24 minutes (healthForwardQueueMaxAge) to appear, so they're always caught.
7608− fwdStaleCount <- *cachedForwardStaleCount
7609− let fwdQueueOk = fwdStaleCount < healthForwardQueueMinStaleServers
7610− -- Request pressure: healthy when active requests < 90% of max (or backpressure disabled)
7611− arq <- *activeRequests
7612− let requestPressureOk = maxActiveRequests <= 0 || arq * 10 < maxActiveRequests * 9
7613− yield {pruneOk: warmup || (t - lastPrune < healthPruneMaxAge && not pruneStuck),
7614− heartbeatOk: warmup || t - lastHb < healthHeartbeatMaxAge,
7615− capacityOk: capacityOk,
7616− capacityWarning: capacityWarn,
7617− federationOk: fedOk,
7620− forwardQueueOk: fwdQueueOk,
7621− requestPressureOk: requestPressureOk,
7622− isDraining: dp > 0,
7623− degradedPeers: degradedPeerCount}
7624− let allOk = not result.isDraining && result.pruneOk && result.heartbeatOk && result.capacityOk && result.federationOk && result.watchdogOk && result.nonceOk && result.forwardQueueOk && result.requestPressureOk
7626− set *cachedHealthOk = allOk
7627− set *cachedHealthPrune = result.pruneOk
7628− set *cachedHealthHeartbeat = result.heartbeatOk
7629− set *cachedHealthCapacity = result.capacityOk
7630− set *cachedHealthCapacityWarning = result.capacityWarning
7631− set *cachedHealthFederation = result.federationOk
7632− set *cachedHealthWatchdog = result.watchdogOk
7633− set *cachedHealthNonce = result.nonceOk
7634− set *cachedHealthForwardQueue = result.forwardQueueOk
7635− set *cachedHealthRequestPressure = result.requestPressureOk
7636− set *cachedHealthDegradedPeers = result.degradedPeers
7639−-- Return cached health state. Used for unauthenticated callers and rate-limited requests.
7640−-- Provides constant-time responses regardless of server state complexity.
7641−readCachedHealth = \respond -> do
7642− cached <- atomic do
7643− cOk <- *cachedHealthOk
7644− cP <- *cachedHealthPrune
7645− cH <- *cachedHealthHeartbeat
7646− cC <- *cachedHealthCapacity
7647− cF <- *cachedHealthFederation
7648− cW <- *cachedHealthWatchdog
7649− cN <- *cachedHealthNonce
7650− cFQ <- *cachedHealthForwardQueue
7651− cRP <- *cachedHealthRequestPressure
7652− cCW <- *cachedHealthCapacityWarning
7653− cDP <- *cachedHealthDegradedPeers
7655− yield {ok: cOk && dp == 0, version: serverBuildVersion, pruneHealthy: cP, heartbeatHealthy: cH, capacityHealthy: cC, capacityWarning: cCW, federationHealthy: cF, watchdogHealthy: cW, nonceHealthy: cN, forwardQueueHealthy: cFQ, requestPressureHealthy: cRP, draining: dp > 0, degradedPeers: cDP}
7656− yield (respond cached)
7658handleHealth = \authorization respond -> do
2068handleHealth = \authorization respond -> do
7659 t <- now
2069 t <- now
7660− -- Health checks exempt from global rate limiting (monitoring traffic shouldn't starve real requests)
2070+ lastPrune <- *lastPrunedAt
7661− -- but have their own dedicated rate limiter to prevent DDoS on /health from saturating reads.
2071+ lastHb <- *lastHeartbeatAt
7662− healthLimited <- checkHealthRate t
2072+ sa <- *startedAt
7663− if healthLimited then readCachedHealth respond
2073+ dp <- *drainPhase
7664− else do
2074+ let warmup = t - sa < backgroundPruneInterval * 3
7665− isAuthed <- verifyMaintenanceAuth authorization
2075+ let pruneOk = warmup || t - lastPrune < backgroundPruneInterval * 3
7666− -- Unauthenticated callers get cached results (constant-time, no live computation).
2076+ let heartbeatOk = warmup || t - lastHb < pollTimeoutMs * 3
7667− -- This prevents timing side-channels: an attacker cannot infer server load by measuring
2077+ let allOk = dp == 0 && pruneOk && heartbeatOk
7668− -- response time differences between cached (fast) and computed (slow) health checks.
2078+ yield (respond {ok: allOk, version: serverBuildVersion, pruneHealthy: pruneOk, heartbeatHealthy: heartbeatOk, capacityHealthy: True {}, capacityWarning: False {}, federationHealthy: True {}, watchdogHealthy: True {}, nonceHealthy: True {}, forwardQueueHealthy: True {}, requestPressureHealthy: True {}, draining: dp > 0, degradedPeers: 0})
7669− -- Cache is kept fresh by computeAndCacheHealth called from background prune (~30s).
7670− -- Only authenticated callers trigger live computation + cache refresh.
7671− -- Subsystem booleans are returned from cache so load balancers and k8s probes can
7672− -- detect degradation without requiring authentication. The cached reads are all
7673− -- constant-time (single STM reads) so no timing information is leaked.
7675− then readCachedHealth respond
7677− result <- computeAndCacheHealth t
7678− let allOk = not result.isDraining && result.pruneOk && result.heartbeatOk && result.capacityOk && result.federationOk && result.watchdogOk && result.nonceOk && result.forwardQueueOk && result.requestPressureOk
7679− yield (respond {ok: allOk, version: serverBuildVersion, pruneHealthy: result.pruneOk,
7680− heartbeatHealthy: result.heartbeatOk,
7681− capacityHealthy: result.capacityOk,
7682− capacityWarning: result.capacityWarning,
7683− federationHealthy: result.federationOk,
7684− watchdogHealthy: result.watchdogOk,
7685− nonceHealthy: result.nonceOk,
7686− forwardQueueHealthy: result.forwardQueueOk,
7687− requestPressureHealthy: result.requestPressureOk,
7688− draining: result.isDraining,
7689− degradedPeers: result.degradedPeers})
7691−zeroStats = {ok: False {}, version: serverBuildVersion, capacity: {sessions: 0, sessionsMax: 0, sessionsPct: 0, messages: 0, messagesMax: 0, messagesPct: 0, totalMessageCount: 0, presence: 0, presenceMax: 0, presencePct: 0, forwards: 0, forwardsMax: 0, forwardsPct: 0, challenges: 0, challengesMax: 0, ackedIds: 0, ackedIdsMax: 0, ackOverflow: 0, ackOverflowMax: 0, deliveredIds: 0, deliveredIdsMax: 0, forwardNonces: 0, forwardNoncesMax: 0, nonceEvictions: 0, activePolls: 0, activePollsMax: 0, recipientCounts: 0, messageBucketMax: 0, messageBucketMin: 0}, federation: {enabled: False {}, inFlight: 0, hungSlots: 0, avgLatencyMs: 0, maxLatencyMs: 0, callCount: 0, slowVerifies: 0, verifyFailures: 0, forwardFailures: 0, oldestForwardAge: 0, oldestAckAge: 0, recentGossip: 0, blockedPeers: 0, drainCompletedAt: 0, forwardServers: 0, maxForwardQueueDepth: 0, topFailingPeers: [], pendingCancels: 0, gossipSuccess: 0, gossipFail: 0, latencyBuckets: {lt100: 0, lt500: 0, lt2000: 0, gte2000: 0}}, rates: {send: 0, challenge: 0, federation: 0, federationPair: 0, global: 0, ip: 0, lookup: 0, recv: 0, pair: 0, gossipEvent: 0, verifyIp: 0, uniqueKeyIp: 0, pendingAckCleanups: 0, senderExpirations: 0, senderDeliveries: 0, rejectedGlobal: 0, rejectedIp: 0, rejectedAuth: 0, rejectedPerKey: 0, rejectedFederation: 0, clientCancels: 0, federationCancels: 0}, timing: {pruneCount: 0, pruneRunning: 0, heartbeatCount: 0, uptime: 0, lastPruneAt: 0, lastHeartbeatAt: 0, draining: False {}, drainPhase: 0, totalEntries: 0, activeRequests: 0, peakActiveRequests: 0, pollAvgMs: 0, pollMaxMs: 0, pollCount: 0, pollLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0}, sendAvgMs: 0, sendMaxMs: 0, sendCount: 0, sendLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0}, authAvgMs: 0, authMaxMs: 0, authCount: 0}}
7693−handleStats = \authorization respond -> do
7695− globalRateLimited <- checkGlobalRate t
7696− if globalRateLimited then yield (respond zeroStats)
7698− authorized <- verifyMaintenanceAuth authorization
7701− -- Split into two atomic reads: core capacity state (consistent) and counters/timing
7702− -- (slight inconsistency acceptable for monitoring). This narrows the lock window.
7703− -- Forward stats computed per-bucket to avoid materializing all 16 buckets into one list.
7704− -- Each bucket is read independently; counts and per-server stats are aggregated.
7705− fwdStats <- computeForwardStats 0 t
7706− bucketStats <- messageBucketMinMax
7708− sc <- *totalSessionCount
7709− pc <- *totalPresenceCount
7711− -- Count-only: avoids materializing all 16 acked/delivered buckets into one list
7712− -- since only the count is needed for stats (not the entries themselves).
7713− aCount <- countAllAcked 0
7715− dCount <- countAllDelivered 0
7716− ff <- *forwardFailures
7718− tmc <- *totalMessageCount
7719− rc <- countAllRcEntries 0
7720− fi <- *federationInFlight
7721− rg <- *recentGossip
7722− fnCount <- countAllNonces 0
7723− pac <- *pendingAckCleanups
7724− bp <- *blockedPeers
7725− ger <- *gossipEventRates
7726− vir <- *verifyIpRates
7727− ukir <- *uniqueKeyIpRates
7728− se <- *senderExpirations
7729− sdl <- *senderDeliveries
7730− pfc <- *pendingFederationCancels
7731− yield {sc: sc, pc: pc, c: c, aCount: aCount, ao: ao, dCount: dCount, ff: ff, ap: ap, tmc: tmc, rc: rc, fi: fi, rg: rg, fnCount: fnCount, pac: pac, bp: bp, ger: ger, vir: vir, ukir: ukir, se: se, sdl: sdl, pfc: pfc}
7732− counters <- atomic do
7734− cr <- *challengeRates
7735− fr <- *federationRates
7736− fpr <- *federationPairRates
7737− grc <- *globalRateCount
7743− pr <- *pruneRunning
7744− hc <- *heartbeatCount
7746− lp <- *lastPrunedAt
7747− lh <- *lastHeartbeatAt
7749− flt <- *federationLatencyTotal
7750− flc <- *federationLatencyCount
7751− flm <- *federationLatencyMax
7752− flb0 <- *federationLatencyBucket0
7753− flb1 <- *federationLatencyBucket1
7754− flb2 <- *federationLatencyBucket2
7755− flb3 <- *federationLatencyBucket3
7756− svc <- *slowVerifyCount
7757− vfc <- *verifyFailCount
7758− dca <- *drainCompletedAt
7759− rlg <- *rateLimitedGlobal
7760− rli <- *rateLimitedIp
7761− rla <- *rateLimitedAuth
7762− rlk <- *rateLimitedPerKey
7763− rlf <- *rateLimitedFederation
7764− arq <- *activeRequests
7765− parq <- *peakActiveRequests
7766− cplt <- *clientPollLatencyTotal
7767− cplc <- *clientPollLatencyCount
7768− cplm <- *clientPollLatencyMax
7769− cslt <- *clientSendLatencyTotal
7770− cslc <- *clientSendLatencyCount
7771− cslm <- *clientSendLatencyMax
7772− gss <- *gossipSendSuccess
7773− gsf <- *gossipSendFail
7774− cplb0 <- *clientPollLatencyBucket0
7775− cplb1 <- *clientPollLatencyBucket1
7776− cplb2 <- *clientPollLatencyBucket2
7777− cplb3 <- *clientPollLatencyBucket3
7778− cslb0 <- *clientSendLatencyBucket0
7779− cslb1 <- *clientSendLatencyBucket1
7780− cslb2 <- *clientSendLatencyBucket2
7781− cslb3 <- *clientSendLatencyBucket3
7782− calt <- *clientAuthLatencyTotal
7783− calc <- *clientAuthLatencyCount
7784− calm <- *clientAuthLatencyMax
7785− ccc <- *clientCancelCount
7786− fccn <- *federationCancelCount
7787− nec <- *nonceEvictionCount
7788− yield {sr: sr, cr: cr, fr: fr, fpr: fpr, grc: grc, ir: ir, lr: lr, rr: rr, prr: prr, pc: pc, pr: pr, hc: hc, sa: sa, lp: lp, lh: lh, dr: dr, flt: flt, flc: flc, flm: flm, flb0: flb0, flb1: flb1, flb2: flb2, flb3: flb3, svc: svc, vfc: vfc, dca: dca, rlg: rlg, rli: rli, rla: rla, rlk: rlk, rlf: rlf, arq: arq, parq: parq, cplt: cplt, cplc: cplc, cplm: cplm, cslt: cslt, cslc: cslc, cslm: cslm, gss: gss, gsf: gsf, cplb0: cplb0, cplb1: cplb1, cplb2: cplb2, cplb3: cplb3, cslb0: cslb0, cslb1: cslb1, cslb2: cslb2, cslb3: cslb3, calt: calt, calc: calc, calm: calm, ccc: ccc, fccn: fccn, nec: nec}
7789− -- Compute derived metrics
7790− let sessions = core.sc
7791− let messages = core.tmc
7792− let presence = core.pc
7793− let fwds = fwdStats.totalCount
7794− let msgPct = if maxMessages > 0 then messages * 100 / maxMessages else 0
7795− let presPct = if maxPresenceEntries > 0 then presence * 100 / maxPresenceEntries else 0
7796− let fwdPct = if maxForwardsEntries > 0 then fwds * 100 / maxForwardsEntries else 0
7797− let sessPct = if maxSessions > 0 then sessions * 100 / maxSessions else 0
7798− let fedAvg = if counters.flc > 0 then counters.flt / counters.flc else 0
7799− let hungFedSlots = count (do r <- core.fi; where r.count > 0 && r.firstStartedAt > 0 && t - r.firstStartedAt >= federationFetchTimeoutMs; yield r)
7800− let oldestFwdAge = fwdStats.oldestAge
7801− -- Oldest ack age computed per-bucket without materializing all 16 buckets.
7802− -- Scans one bucket at a time to find the global minimum ackedAt.
7803− oldestAckTs <- computeOldestAckedAt 0
7804− let oldestAckAge = if oldestAckTs == 0 then 0 else t - oldestAckTs
7805− let fwdServerCount = fwdStats.serverCount
7806− let maxFwdDepth = fwdStats.maxDepth
7807− -- Top-3 failing peers by failure count (inline in /stats to reduce monitoring queries)
7808− let topFailing = takeRelation 3 (sortBy (\f -> 0 - f.failures) core.ff)
7809− let topFailingPeers = do f <- topFailing; yield {server: f.server, failures: f.failures}
7810− let pollAvg = if counters.cplc > 0 then counters.cplt / counters.cplc else 0
7811− let sendAvg = if counters.cslc > 0 then counters.cslt / counters.cslc else 0
7812− yield (respond {ok: True {}, version: serverBuildVersion,
7813− capacity: {sessions: sessions, sessionsMax: maxSessions, sessionsPct: sessPct, messages: messages, messagesMax: maxMessages, messagesPct: msgPct, totalMessageCount: messages, presence: presence, presenceMax: maxPresenceEntries, presencePct: presPct, forwards: fwds, forwardsMax: maxForwardsEntries, forwardsPct: fwdPct, challenges: count core.c, challengesMax: maxChallenges, ackedIds: core.aCount, ackedIdsMax: maxAckedIds, ackOverflow: count core.ao, ackOverflowMax: maxAckOverflow, deliveredIds: core.dCount, deliveredIdsMax: maxDeliveredIds, forwardNonces: core.fnCount, forwardNoncesMax: maxForwardNonces, nonceEvictions: counters.nec, activePolls: count core.ap, activePollsMax: maxActivePolls, recipientCounts: count core.rc, messageBucketMax: bucketStats.bucketMax, messageBucketMin: bucketStats.bucketMin},
7814− federation: {enabled: federationEnabled, inFlight: count core.fi, hungSlots: hungFedSlots, avgLatencyMs: fedAvg, maxLatencyMs: counters.flm, callCount: counters.flc, slowVerifies: counters.svc, verifyFailures: counters.vfc, forwardFailures: count core.ff, oldestForwardAge: oldestFwdAge, oldestAckAge: oldestAckAge, recentGossip: count core.rg, blockedPeers: count core.bp, drainCompletedAt: counters.dca, forwardServers: fwdServerCount, maxForwardQueueDepth: maxFwdDepth, topFailingPeers: topFailingPeers, pendingCancels: count core.pfc, gossipSuccess: counters.gss, gossipFail: counters.gsf, latencyBuckets: {lt100: counters.flb0, lt500: counters.flb1, lt2000: counters.flb2, gte2000: counters.flb3}},
7815− rates: {send: count counters.sr, challenge: count counters.cr, federation: count counters.fr, federationPair: count counters.fpr, global: counters.grc, ip: count counters.ir, lookup: count counters.lr, recv: count counters.rr, pair: count counters.prr, gossipEvent: count core.ger, verifyIp: count core.vir, uniqueKeyIp: count core.ukir, pendingAckCleanups: count core.pac, senderExpirations: count core.se, senderDeliveries: count core.sdl, rejectedGlobal: counters.rlg, rejectedIp: counters.rli, rejectedAuth: counters.rla, rejectedPerKey: counters.rlk, rejectedFederation: counters.rlf, clientCancels: counters.ccc, federationCancels: counters.fccn},
7816− timing: {pruneCount: counters.pc, pruneRunning: counters.pr, heartbeatCount: counters.hc, uptime: t - counters.sa, lastPruneAt: counters.lp, lastHeartbeatAt: counters.lh, draining: counters.dr > 0, drainPhase: counters.dr, totalEntries: sessions + messages + presence + fwds + count core.c + core.aCount + count core.ao + core.dCount + core.fnCount + count core.ap + count core.fi, activeRequests: counters.arq, peakActiveRequests: counters.parq, pollAvgMs: pollAvg, pollMaxMs: counters.cplm, pollCount: counters.cplc, pollLatencyBuckets: {lt50: counters.cplb0, lt200: counters.cplb1, lt1000: counters.cplb2, gte1000: counters.cplb3}, sendAvgMs: sendAvg, sendMaxMs: counters.cslm, sendCount: counters.cslc, sendLatencyBuckets: {lt50: counters.cslb0, lt200: counters.cslb1, lt1000: counters.cslb2, gte1000: counters.cslb3}, authAvgMs: if counters.calc > 0 then counters.calt / counters.calc else 0, authMaxMs: counters.calm, authCount: counters.calc}})
7817− else yield (respond zeroStats)
7819−handleStatsPeers = \authorization respond -> do
7821− globalRateLimited <- checkGlobalRate t
7822− if globalRateLimited then yield (respond {peers: [], ok: False {}})
7824− authorized <- verifyMaintenanceAuth authorization
7827− failures <- *forwardFailures
7828− peerLats <- *peerLatencies
7829− gossipRates <- *gossipEventRates
7830− -- Per-bucket aggregation: compute forward counts without materializing all 16 buckets.
7831− -- Reuses computeForwardStats which reads one bucket at a time.
7832− fwdStats <- computeForwardStats 0 t
7833− let fwdCounts = fwdStats.serverCounts
7834− let fwdCountFor = \server -> fold (\acc c -> if c.server == server then c.count else acc) 0 fwdCounts
7835− let peerLatFor = \server -> case headOf (do p <- peerLats; where p.server == server; yield p) of
7836− Nothing {} -> {avg: 0, mx: 0, samples: 0}
7837− Just {value: p} -> {avg: if p.count > 0 then p.totalMs / p.count else 0, mx: p.maxMs, samples: p.count}
7838− -- Per-peer gossip event volume: events per minute from gossipEventRates (1-minute sliding window)
7839− let gossipFor = \server -> fold (\acc r -> if r.server == server then r.count + r.prevCount else acc) 0 gossipRates
7840− let peers = do f <- failures; let lat = peerLatFor f.server in yield {server: f.server, failures: f.failures, lastFailedAt: f.failedAt, firstFailedAt: f.firstFailedAt, backoffMs: retryBackoffFor f.failures f.server, retriable: shouldRetryServer f.server t failures, pendingForwards: fwdCountFor f.server, avgLatencyMs: lat.avg, maxLatencyMs: lat.mx, latencySamples: lat.samples, gossipEventsPerMin: gossipFor f.server}
7841− -- Include servers with pending forwards but no failure records
7842− let fwdOnlyPeers = do c <- fwdCounts; where none failures (\f -> f.server == c.server); let lat = peerLatFor c.server in yield {server: c.server, failures: 0, lastFailedAt: 0, firstFailedAt: 0, backoffMs: 0, retriable: True {}, pendingForwards: c.count, avgLatencyMs: lat.avg, maxLatencyMs: lat.mx, latencySamples: lat.samples, gossipEventsPerMin: gossipFor c.server}
7843− yield (respond {peers: union peers fwdOnlyPeers, ok: True {}})
7844− else yield (respond {peers: [], ok: False {}})
7846−handleStatsKey = \pubkey authorization respond -> do
7848− globalRateLimited <- checkGlobalRate t
7849− if globalRateLimited then yield (respond {messages: 0, presence: [], sessions: 0, forwards: 0, activePolls: 0, ok: False {}})
7851− authorized <- verifyMaintenanceAuth authorization
7854− result <- atomic do
7855− keyBucket <- readMessageBucket (pubkeyBucket pubkey)
7856− -- Single bucket read: all entries for this pubkey are in the same presence bucket
7857− keyPresenceBkt <- readPresenceBucket (pubkeyBucket pubkey)
7858− -- Count sessions without materializing all 16 buckets (O(n/16) best case)
7859− keySessions <- countSessionsForKey pubkey
7860− forwards <- readFwdBucket (pubkeyBucket pubkey)
7861− activePolls <- *activePolls
7862− let keyMessages = count (do m <- keyBucket; where m.toKey == pubkey; yield m)
7863− let keyPresence = do p <- keyPresenceBkt; where p.pubkey == pubkey && p.expiresAt > t; yield {server: p.server, expiresAt: p.expiresAt}
7864− let keyForwardEntries = do f <- forwards; where f.toKey == pubkey; yield f
7865− let keyForwards = count keyForwardEntries
7866− let keyForwardDetails = do f <- keyForwardEntries; yield {server: f.toServer, retries: f.retries, createdAt: f.createdAt}
7867− let keyPolls = count (do p <- activePolls; where p.pubkey == pubkey; yield p)
7868− yield {messages: keyMessages, presence: keyPresence, sessions: keySessions, forwards: keyForwards, forwardDetails: keyForwardDetails, activePolls: keyPolls}
7869− yield (respond {messages: result.messages, presence: result.presence, sessions: result.sessions, forwards: result.forwards, forwardDetails: result.forwardDetails, activePolls: result.activePolls, ok: True {}})
7870− else yield (respond {messages: 0, presence: [], sessions: 0, forwards: 0, forwardDetails: [], activePolls: 0, ok: False {}})
7872−-- GET /stats/top-recipients: Return recipients sorted by pending message count (descending).
7873−-- Uses rcBucket data (per-recipient counts) — O(total_unique_recipients) with no message scan.
7874−-- Helps operators identify inbox-bombing targets without knowing the recipient key in advance.
7875−handleTopRecipients = \limit authorization respond -> do
7877− globalRateLimited <- checkGlobalRate t
7878− if globalRateLimited then yield (respond {recipients: [], ok: False {}, total: 0})
7880− authorized <- verifyMaintenanceAuth authorization
7883− let effectiveLimit = if limit <= 0 then 20 else clamp 1 100 limit
7884− -- Per-bucket top-N merge: scans one rcBucket at a time, maintaining a running
7885− -- top-N list. Avoids materializing all 16 buckets into a single list.
7886− top <- topRecipientsByBucket 0 effectiveLimit []
7887− totalRc <- countAllRcEntries 0
7888− yield (respond {recipients: top, ok: True {}, total: totalRc})
7889− else yield (respond {recipients: [], ok: False {}, total: 0})
7891−-- GET /stats/forwards: Per-server forward queue breakdown.
7892−-- Shows pending forwards grouped by destination server with oldest age and total retries.
7893−-- Use to identify which peers have queue buildup (unreachable or slow peers).
7894−handleStatsForwards = \authorization respond -> do
7896− globalRateLimited <- checkGlobalRate t
7897− if globalRateLimited then yield (respond {servers: [], ok: False {}, total: 0})
7899− authorized <- verifyMaintenanceAuth authorization
7902− fwdStats <- computeForwardStats 0 t
7903− -- Enrich per-server counts with oldest age and total retries
7904− let enriched = do sc <- fwdStats.serverCounts; yield {server: sc.server, count: sc.count, oldestAge: 0, totalRetries: 0}
7905− enrichedStats <- enrichForwardServerStats enriched 0 t
7906− yield (respond {servers: enrichedStats, ok: True {}, total: fwdStats.totalCount})
7907− else yield (respond {servers: [], ok: False {}, total: 0})
7909−-- Enrich per-server forward stats with oldest age and total retries.
7910−-- Scans one forward bucket at a time, accumulating per-server metrics.
7911−enrichForwardServerStats = \servers b t ->
7912− if b > 15 then yield servers
7914− bucket <- readFwdBucket b
7915− let updated = do s <- servers; yield (
7916− let serverFwds = do f <- bucket; where f.toServer == s.server; yield f in
7917− let bucketOldest = case minBy serverFwds (\x -> x.createdAt) of Nothing {} -> 0; Just {value: x} -> t - x.createdAt in
7918− let bucketRetries = fold (\acc f -> acc + f.retries) 0 serverFwds in
7919− {server: s.server, count: s.count, oldestAge: max s.oldestAge bucketOldest, totalRetries: s.totalRetries + bucketRetries})
7920− enrichForwardServerStats updated (b + 1) t
7922−-- GET /stats/rates: Show effective rate limits after adaptive scaling.
7923−-- Returns the current scale factor (0-100%) and each rate limit as actually applied.
7924−handleStatsRates = \authorization respond -> do
7926− globalRateLimited <- checkGlobalRate t
7927− if globalRateLimited then yield (respond {ok: False {}, scalePct: 0, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0})
7929− authorized <- verifyMaintenanceAuth authorization
7933− tmc <- *totalMessageCount
7934− sc <- *totalSessionCount
7935− pc <- *totalPresenceCount
7936− yield (adaptiveRateScale tmc sc pc)
7937− effGlobal <- effectiveGlobalRequestRate
7938− effIp <- effectiveIpRate
7939− effSend <- effectiveSendRate
7940− effFed <- effectiveFederationRate
7941− effAuth <- effectiveAuthGlobalRate
7942− effRecv <- effectiveRecvRate
7943− effChal <- effectiveChallengeRate
7944− effPair <- effectivePairRate
7945− effLookup <- effectiveLookupRate
7946− effCw <- effectiveClientWriteRate
7947− yield (respond {ok: True {}, scalePct: scale, globalRequest: effGlobal, ipRate: effIp, sendRate: effSend, federationRate: effFed, authGlobal: effAuth, recvRate: effRecv, challengeRate: effChal, pairRate: effPair, lookupRate: effLookup, clientWriteRate: effCw})
7948− else yield (respond {ok: False {}, scalePct: 0, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0})
7950−-- GET /ready: Readiness probe — returns true once the server has completed startup.
7951−-- Unlike /health, this is unauthenticated and doesn't check subsystem liveness.
7952−-- Returns false until the first prune cycle completes (server fully initialized).
7953handleReady = \respond -> do
2080handleReady = \respond -> do
7954− t <- now
2081+ sa <- *startedAt
7955− -- Rate-limit /ready to prevent DoS (shares health rate limiter since both are
2082+ lastPrune <- *lastPrunedAt
7956− -- unauthenticated probes). Without this, /ready can be hit unlimited times
2083+ yield (respond {ready: lastPrune > 0 && lastPrune >= sa})
7957− -- for cheap reconnaissance (detecting restarts) or resource exhaustion.
7958− healthLimited <- checkHealthRate t
7959− if healthLimited then yield (respond {ready: True {}})
7962− lastPrune <- *lastPrunedAt
7963− -- Ready once the first prune cycle has run (indicates all background loops are alive)
7964− let isReady = lastPrune > 0 && lastPrune >= sa
7965− yield (respond {ready: isReady})
7967−-- GET /metrics: Prometheus-format metrics in a JSON wrapper.
7968−-- Authenticated callers get full metrics; unauthenticated get basic capacity only.
7969−handleMetrics = \authorization respond -> do
7971− healthLimited <- checkHealthRate t
7972− if healthLimited then yield (respond {metrics: "", ok: False {}})
7974− isAuthed <- verifyMaintenanceAuth authorization
7975− result <- atomic do
7976− tmc <- *totalMessageCount
7977− sc <- *totalSessionCount
7978− pc <- *totalPresenceCount
7979− fc <- *totalForwardCount
7981− arq <- *activeRequests
7982− parq <- *peakActiveRequests
7985− yield {tmc: tmc, sc: sc, pc: pc, fc: fc, ap: ap, arq: arq, parq: parq, sa: sa, dp: dp}
7986− -- Basic capacity metrics (always available)
7987− let base = "# HELP skrepka_messages_total Current message count\n# TYPE skrepka_messages_total gauge\nskrepka_messages_total " ++ show result.tmc ++ "\n# HELP skrepka_messages_max Maximum message capacity\n# TYPE skrepka_messages_max gauge\nskrepka_messages_max " ++ show maxMessages ++ "\n# HELP skrepka_sessions_total Current session count\n# TYPE skrepka_sessions_total gauge\nskrepka_sessions_total " ++ show result.sc ++ "\n# HELP skrepka_sessions_max Maximum session capacity\n# TYPE skrepka_sessions_max gauge\nskrepka_sessions_max " ++ show maxSessions ++ "\n# HELP skrepka_presence_total Current presence count\n# TYPE skrepka_presence_total gauge\nskrepka_presence_total " ++ show result.pc ++ "\n# HELP skrepka_presence_max Maximum presence capacity\n# TYPE skrepka_presence_max gauge\nskrepka_presence_max " ++ show maxPresenceEntries ++ "\n# HELP skrepka_forwards_total Current forward queue size\n# TYPE skrepka_forwards_total gauge\nskrepka_forwards_total " ++ show result.fc ++ "\n# HELP skrepka_active_polls Current active long-poll connections\n# TYPE skrepka_active_polls gauge\nskrepka_active_polls " ++ show (count result.ap) ++ "\n# HELP skrepka_active_requests Current active HTTP requests\n# TYPE skrepka_active_requests gauge\nskrepka_active_requests " ++ show result.arq ++ "\n# HELP skrepka_peak_active_requests Peak concurrent requests since last reset\n# TYPE skrepka_peak_active_requests gauge\nskrepka_peak_active_requests " ++ show result.parq ++ "\n# HELP skrepka_uptime_seconds Server uptime in seconds\n# TYPE skrepka_uptime_seconds gauge\nskrepka_uptime_seconds " ++ show ((t - result.sa) / 1000) ++ "\n# HELP skrepka_draining Whether the server is draining\n# TYPE skrepka_draining gauge\nskrepka_draining " ++ if result.dp > 0 then "1" else "0" ++ "\n"
7988− if not isAuthed then yield (respond {metrics: base, ok: True {}})
7990− -- Extended metrics for authenticated callers
7992− flc <- *federationLatencyCount
7993− flt <- *federationLatencyTotal
7994− flm <- *federationLatencyMax
7995− cplc <- *clientPollLatencyCount
7996− cplt <- *clientPollLatencyTotal
7997− cslc <- *clientSendLatencyCount
7998− cslt <- *clientSendLatencyTotal
7999− rlg <- *rateLimitedGlobal
8000− rli <- *rateLimitedIp
8001− rla <- *rateLimitedAuth
8002− rlk <- *rateLimitedPerKey
8003− rlf <- *rateLimitedFederation
8004− gss <- *gossipSendSuccess
8005− gsf <- *gossipSendFail
8006− ccc <- *clientCancelCount
8007− fccn <- *federationCancelCount
8008− nec <- *nonceEvictionCount
8009− yield {flc: flc, flt: flt, flm: flm, cplc: cplc, cplt: cplt, cslc: cslc, cslt: cslt, rlg: rlg, rli: rli, rla: rla, rlk: rlk, rlf: rlf, gss: gss, gsf: gsf, ccc: ccc, fccn: fccn, nec: nec}
8010− let fedAvg = if ext.flc > 0 then ext.flt / ext.flc else 0
8011− let pollAvg = if ext.cplc > 0 then ext.cplt / ext.cplc else 0
8012− let sendAvg = if ext.cslc > 0 then ext.cslt / ext.cslc else 0
8013− let extended = "# HELP skrepka_federation_latency_avg_ms Average federation call latency\n# TYPE skrepka_federation_latency_avg_ms gauge\nskrepka_federation_latency_avg_ms " ++ show fedAvg ++ "\n# HELP skrepka_federation_latency_max_ms Max federation call latency\n# TYPE skrepka_federation_latency_max_ms gauge\nskrepka_federation_latency_max_ms " ++ show ext.flm ++ "\n# HELP skrepka_federation_calls_total Federation calls in current window\n# TYPE skrepka_federation_calls_total gauge\nskrepka_federation_calls_total " ++ show ext.flc ++ "\n# HELP skrepka_poll_latency_avg_ms Average poll latency\n# TYPE skrepka_poll_latency_avg_ms gauge\nskrepka_poll_latency_avg_ms " ++ show pollAvg ++ "\n# HELP skrepka_send_latency_avg_ms Average send latency\n# TYPE skrepka_send_latency_avg_ms gauge\nskrepka_send_latency_avg_ms " ++ show sendAvg ++ "\n# HELP skrepka_rate_limited_total Rate-limited requests by type\n# TYPE skrepka_rate_limited_total gauge\nskrepka_rate_limited_total{type=\"global\"} " ++ show ext.rlg ++ "\nskrepka_rate_limited_total{type=\"ip\"} " ++ show ext.rli ++ "\nskrepka_rate_limited_total{type=\"auth\"} " ++ show ext.rla ++ "\nskrepka_rate_limited_total{type=\"per_key\"} " ++ show ext.rlk ++ "\nskrepka_rate_limited_total{type=\"federation\"} " ++ show ext.rlf ++ "\n# HELP skrepka_gossip_total Gossip send results\n# TYPE skrepka_gossip_total gauge\nskrepka_gossip_total{result=\"success\"} " ++ show ext.gss ++ "\nskrepka_gossip_total{result=\"fail\"} " ++ show ext.gsf ++ "\n# HELP skrepka_cancels_total Message cancellations by source\n# TYPE skrepka_cancels_total gauge\nskrepka_cancels_total{source=\"client\"} " ++ show ext.ccc ++ "\nskrepka_cancels_total{source=\"federation\"} " ++ show ext.fccn ++ "\n# HELP skrepka_nonce_evictions_total Nonce LRU evictions in current window\n# TYPE skrepka_nonce_evictions_total gauge\nskrepka_nonce_evictions_total " ++ show ext.nec ++ "\n"
8014− yield (respond {metrics: base ++ extended, ok: True {}})
8016−-- POST /messages/ack: Explicitly acknowledge received messages by ID.
8017−-- Alternative to the implicit cursor-based ack in poll. Benefits:
8018−-- 1. Reduces the window for duplicate delivery (ack immediately without waiting for next poll)
8019−-- 2. Selective ack: acknowledge specific messages without acking all messages up to a cursor
8020−-- Rate-limited via global rate limiter; requires session auth.
8021−handleAckMessages = \messageIds authorization clientIp respond -> do
8024− if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "draining"})
8026− globalRateLimited <- checkGlobalRate t
8027− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
8029− withSessionAuth authorization t clientIp
8030− (yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "unauthorized"}))
8032− -- Uses clientWriteRates (separate from lookupRates) so ack bursts don't starve lookups
8033− ackRateLimited <- atomic do
8034− cwr <- *clientWriteRates
8035− cwRate <- effectiveClientWriteRate
8036− let rateResult = checkPubkeyRate cwr pubkey cwRate clientWriteRateWindowMs maxClientWriteRateEntries t
8037− set *clientWriteRates = rateResult.entries
8038− yield rateResult.limited
8039− if ackRateLimited then yield (respond {ok: False {}, authorized: True {}, ackedCount: 0, error: "rate_limited:" ++ show clientWriteRateWindowMs ++ "ms"})
8041− -- Cap input size to prevent expensive scans from unbounded messageIds lists
8042− let dedupedIds = dedupMessageIds (takeRelation maxMessageIds messageIds)
8043− result <- atomic do
8044− let b = pubkeyBucket pubkey
8045− bucket <- readMessageBucket b
8046− let toAck = do m <- bucket; where m.toKey == pubkey && any dedupedIds (\mid -> m.messageId == mid); yield m
8047− let ackCount = count toAck
8048− if ackCount > 0 then do
8049− writeMessageBucket b (diff bucket toAck)
8050− totalCount <- *totalMessageCount
8051− set *totalMessageCount = max 0 (totalCount - ackCount)
8052− recipientCounts <- readRcBucket b
8053− writeRcBucket b (adjustRecipientCount recipientCounts pubkey (0 - ackCount))
8054− let ackedMsgIds = do m <- toAck; yield m.messageId
8055− let fb2 = pubkeyBucket pubkey
8056− fwdBkt2 <- readFwdBucket fb2
8057− writeFwdBucket fb2 (do f <- fwdBkt2; where none ackedMsgIds (\mid -> f.messageId == mid && f.toKey == pubkey); yield f)
8058− let ackedFederated = federatedAckEntries toAck t
8059− ackedBkt <- readAckedBucket b
8060− let combinedAckedIds = union ackedBkt ackedFederated
8061− let excessCount = max 0 (count combinedAckedIds - maxAckedIds)
8062− let eviction = evictSmallest combinedAckedIds excessCount (\a -> a.ackedAt)
8063− writeAckedBucket b eviction.kept
8064− -- Queue delivery receipts for locally-originated messages
8065− let localDelivered = do m <- toAck; where m.senderKey != "" && m.originServer == ""; yield {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, deliveredAt: t}
8066− when (count localDelivered > 0) (do
8067− sd <- *senderDeliveries
8068− -- Dedup: skip receipts already recorded (e.g., cursor ack + explicit ack for same message)
8069− let deduped = do d <- localDelivered; where none sd (\e -> e.messageId == d.messageId && e.toKey == d.toKey); yield d
8070− let combined = union sd deduped
8071− let overCap = count combined > maxSenderDeliveries
8073− let evicted = extractOldest combined (\d -> d.deliveredAt)
8074− set *senderDeliveries = evicted.items
8075− case evicted.candidate of
8076− Nothing {} -> yield {}
8077− Just {value: ev} -> do
8078− ddr <- *droppedDeliveryReceipts
8079− set *droppedDeliveryReceipts = incrementDropCounter ddr ev.senderKey 1 t
8080− else set *senderDeliveries = combined)
8081− yield {ackedCount: ackCount, pendingAcks: ackedFederated, evictedEntries: eviction.evicted}
8082− else yield {ackedCount: 0, pendingAcks: [], evictedEntries: []}
8083− fork (when federationEnabled (do
8084− sendAcksAndClean result.pendingAcks
8085− retryEvictedAcks result.evictedEntries result.pendingAcks))
8086− yield (respond {ok: True {}, authorized: True {}, ackedCount: result.ackedCount, error: ""}))
8088−-- GET /messages/list: List pending messages without acking.
8089−-- Useful after cursor loss (app reinstall, new device) to see what's pending.
8090−-- Rate-limited via lookup rate limiter (read-only info lookup).
8091−handleListMessages = \offset authorization clientIp respond -> do
8094− if dp >= 2 then yield (respond {messages: [], authorized: False {}, count: 0, error: ""})
8096− globalRateLimited <- checkGlobalRate t
8097− if globalRateLimited then yield (respond {messages: [], authorized: False {}, count: 0, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
8099− withSessionAuth authorization t clientIp
8100− (yield (respond {messages: [], authorized: False {}, count: 0, error: ""}))
8102− listRateLimited <- atomic do
8103− lookupRates <- *lookupRates
8104− lkRate <- effectiveLookupRate
8105− let rateResult = checkPubkeyRate lookupRates pubkey lkRate lookupRateWindowMs maxLookupRateEntries t
8106− set *lookupRates = rateResult.entries
8107− yield rateResult.limited
8108− if listRateLimited then yield (respond {messages: [], authorized: True {}, count: 0, error: "rate_limited:" ++ show lookupRateWindowMs ++ "ms"})
8110− result <- atomic do
8111− bucket <- readMessageBucket (pubkeyBucket pubkey)
8112− let myMsgs = sortBy (\m -> m.receivedAt) (do m <- bucket; where m.toKey == pubkey && m.expiresAt > t; yield m)
8113− let total = count myMsgs
8114− -- Pagination: skip first `offset` messages, then take up to maxPollEvents.
8115− -- skipRelation uses fold to drop the first N items from a list.
8116− let effectiveOffset = clamp 0 total offset
8117− let afterOffset = skipRelation effectiveOffset myMsgs
8118− let capped = takeRelation maxPollEvents afterOffset
8119− yield {msgs: do m <- capped; yield {messageId: m.messageId, timestamp: m.timestamp, receivedAt: m.receivedAt}, total: total}
8120− yield (respond {messages: result.msgs, authorized: True {}, count: result.total, error: ""}))
8122−-- POST /messages/delete: Delete pending messages by ID (recipient-only).
8123−-- The recipient knows their pubkey (toKey) and can be authenticated via session.
8124−-- Deletes matching messages, adjusts counters, cancels pending forwards, and
8125−-- sends federation acks for federated messages so origin servers can reclaim
8126−-- their forward entries instead of retrying until prune.
8127−handleDeleteMessages = \messageIds authorization clientIp respond -> do
8130− if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: ""})
8132− globalRateLimited <- checkGlobalRate t
8133− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
8135− withSessionAuth authorization t clientIp
8136− (yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "unauthorized"}))
8138− -- Uses clientWriteRates (separate from lookupRates) so delete bursts don't starve lookups
8139− deleteRateLimited <- atomic do
8140− cwr <- *clientWriteRates
8141− cwRate <- effectiveClientWriteRate
8142− let rateResult = checkPubkeyRate cwr pubkey cwRate clientWriteRateWindowMs maxClientWriteRateEntries t
8143− set *clientWriteRates = rateResult.entries
8144− yield rateResult.limited
8145− if deleteRateLimited then yield (respond {ok: False {}, authorized: True {}, deletedCount: 0, error: "rate_limited:" ++ show clientWriteRateWindowMs ++ "ms"})
8147− -- Cap input size to prevent expensive scans from unbounded messageIds lists
8148− let dedupedIds = dedupMessageIds (takeRelation maxMessageIds messageIds)
8149− deleteResult <- atomic do
8150− let b = pubkeyBucket pubkey
8151− bucket <- readMessageBucket b
8152− let toDelete = do m <- bucket; where m.toKey == pubkey && any dedupedIds (\mid -> mid == m.messageId); yield m
8153− let removed = count toDelete
8154− if removed > 0 then do
8155− writeMessageBucket b (diff bucket toDelete)
8156− tc <- *totalMessageCount
8157− set *totalMessageCount = max 0 (tc - removed)
8158− rc <- readRcBucket b
8159− writeRcBucket b (adjustRecipientCount rc pubkey (0 - removed))
8160− -- Cancel pending forwards for deleted messages (bucket read: O(n/16))
8161− let deletedMsgIds = do m <- toDelete; yield m.messageId
8162− let dfb = pubkeyBucket pubkey
8163− fwdBkt <- readFwdBucket dfb
8164− let keptDeleteFwds = do f <- fwdBkt; where none deletedMsgIds (\mid -> f.messageId == mid && f.toKey == pubkey); yield f
8165− let fwdDeleteRemoved = count fwdBkt - count keptDeleteFwds
8166− writeFwdBucket dfb keptDeleteFwds
8167− when (fwdDeleteRemoved > 0) (do
8168− tfc <- *totalForwardCount
8169− set *totalForwardCount = max 0 (tfc - fwdDeleteRemoved))
8170− -- Create ack entries for federated messages so origin servers learn about the delete
8171− let federatedDeleted = do m <- toDelete; where m.originServer != ""; yield m
8172− let ackedFederated = federatedAckEntries federatedDeleted t
8173− -- Queue delivery receipts for locally-originated deleted messages
8174− let localDeleted = do m <- toDelete; where m.senderKey != "" && m.originServer == ""; yield {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, deliveredAt: t}
8175− when (count localDeleted > 0) (do
8176− sd <- *senderDeliveries
8177− -- Dedup: skip receipts already recorded (avoids duplicates from concurrent ack paths)
8178− let dedupedDel = do d <- localDeleted; where none sd (\e -> e.messageId == d.messageId && e.toKey == d.toKey); yield d
8179− let combinedDel = union sd dedupedDel
8180− let overCapDel = count combinedDel > maxSenderDeliveries
8181− if overCapDel then do
8182− let evicted = extractOldest combinedDel (\d -> d.deliveredAt)
8183− set *senderDeliveries = evicted.items
8184− case evicted.candidate of
8185− Nothing {} -> yield {}
8186− Just {value: ev} -> do
8187− ddr <- *droppedDeliveryReceipts
8188− set *droppedDeliveryReceipts = incrementDropCounter ddr ev.senderKey 1 t
8189− else set *senderDeliveries = combinedDel)
8190− if count ackedFederated > 0 then do
8191− ackedBkt <- readAckedBucket b
8192− let combinedAcked = union ackedBkt ackedFederated
8193− let excessCount = max 0 (count combinedAcked - maxAckedIds)
8194− let eviction = evictSmallest combinedAcked excessCount (\a -> a.ackedAt)
8195− writeAckedBucket b eviction.kept
8196− yield {deletedCount: removed, pendingAcks: ackedFederated, evictedEntries: eviction.evicted}
8197− else yield {deletedCount: removed, pendingAcks: [], evictedEntries: []}
8198− else yield {deletedCount: 0, pendingAcks: [], evictedEntries: []}
8199− fork (when federationEnabled (do
8200− sendAcksAndClean deleteResult.pendingAcks
8201− retryEvictedAcks deleteResult.evictedEntries deleteResult.pendingAcks))
8202− yield (respond {ok: True {}, authorized: True {}, deletedCount: deleteResult.deletedCount, error: ""}))
8204−-- POST /messages/cancel: Retract a previously sent message before the recipient reads it.
8205−-- Only works for locally-originated messages where the caller's pubkey matches the
8206−-- stored senderKey. Federation forwards cannot be cancelled via this endpoint.
8207−-- Removes from recipient mailbox and cancels pending forwards.
8208−-- NOTE: Race condition between cancel and re-send: after this endpoint deletes the
8209−-- local message and sends federation cancel, there's a window where:
8210−-- 1. The federation cancel hasn't arrived at the remote server yet
8211−-- 2. The sender immediately re-sends (with a new messageId)
8212−-- 3. The recipient receives the new message before the cancel is processed
8213−-- This can cause a UX inconsistency where the recipient sees the "retracted" message
8214−-- briefly before the cancel arrives. Not fixable at the relay layer — requires
8215−-- higher-level protocol support (e.g., cancel tokens in the encrypted payload).
8216−handleCancelMessage = \messageId to authorization clientIp respond -> do
8219− if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: ""})
8221− globalRateLimited <- checkGlobalRate t
8222− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
8224− withSessionAuth authorization t clientIp
8225− (yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "unauthorized"}))
8227− -- Uses clientWriteRates (like ack/delete) so cancel bursts don't starve lookups
8228− cancelRateLimited <- atomic do
8229− cwr <- *clientWriteRates
8230− cwRate <- effectiveClientWriteRate
8231− let rateResult = checkPubkeyRate cwr senderKey cwRate clientWriteRateWindowMs maxClientWriteRateEntries t
8232− set *clientWriteRates = rateResult.entries
8233− yield rateResult.limited
8234− if cancelRateLimited then yield (respond {ok: False {}, authorized: True {}, cancelled: False {}, error: "rate_limited:" ++ show clientWriteRateWindowMs ++ "ms"})
8236− cancelResult <- atomic do
8237− let b = pubkeyBucket to
8238− bucket <- readMessageBucket b
8239− let toCancel = headOf (do m <- bucket; where m.messageId == messageId && m.toKey == to; yield m)
8241− Nothing {} -> yield {cancelled: False {}, cancelServers: [], nonceLruEvicted: 0, nonceOldestAge: 0}
8242− Just {value: msg} ->
8243− -- Only allow cancelling locally-originated messages (originServer == "")
8244− -- where the caller's pubkey matches the stored senderKey. Federation
8245− -- forwards have no senderKey and cannot be cancelled via this endpoint.
8246− -- Strict check: senderKey must be non-empty and match. MessageId knowledge
8247− -- alone is insufficient — prevents cancel if messageId leaks via logs,
8248− -- federation peers, or recipient sharing.
8249− if msg.originServer != "" then yield {cancelled: False {}, cancelServers: [], nonceLruEvicted: 0, nonceOldestAge: 0}
8250− else if msg.senderKey == "" || msg.senderKey != senderKey then yield {cancelled: False {}, cancelServers: [], nonceLruEvicted: 0, nonceOldestAge: 0}
8252− writeMessageBucket b (do m <- bucket; where not (m.messageId == messageId && m.toKey == to); yield m)
8253− tc <- *totalMessageCount
8254− set *totalMessageCount = max 0 (tc - 1)
8255− rc <- readRcBucket b
8256− writeRcBucket b (adjustRecipientCount rc to (0 - 1))
8257− -- Cancel pending forwards and collect their target servers before deleting
8258− fwdBkt <- readFwdBucket b
8259− let cancelledFwds = do f <- fwdBkt; where f.messageId == messageId && f.toKey == to; yield f
8260− let forwardTargetServers = collectPeerServers cancelledFwds (\f -> f.toServer)
8261− let fwdCancelRemoved = count cancelledFwds
8262− writeFwdBucket b (do f <- fwdBkt; where not (f.messageId == messageId && f.toKey == to); yield f)
8263− when (fwdCancelRemoved > 0) (do
8264− tfc <- *totalForwardCount
8265− set *totalForwardCount = max 0 (tfc - fwdCancelRemoved))
8266− -- Collect servers from recipient's presence that may have received the forward
8267− -- (completed forwards are no longer in fwdBucket, so check presence too)
8268− presenceBkt <- readPresenceBucket b
8269− let remotePresence = collectPeerServers (presenceForKey presenceBkt to t) (\p -> p.server)
8270− -- Union forward targets (servers that haven't received it yet or already have it)
8271− -- with presence servers (servers that already received and stored the message).
8272− -- This ensures cancel reaches both pending and completed forward destinations.
8273− let allCancelServers = fold (\acc s -> if any acc (\a -> a == s) then acc else union [s] acc) remotePresence forwardTargetServers
8274− -- Record cancel nonce: prevents replayed federation forwards of the
8275− -- cancelled message from being accepted after the message is removed
8276− -- from all dedup sets (messages, ackedIds, deliveredIds).
8277− nonceResult <- updateForwardNonce b messageId to t
8278− yield {cancelled: True {}, cancelServers: allCancelServers, nonceLruEvicted: nonceResult.lruEvicted, nonceOldestAge: nonceResult.oldestRetainedAge}
8279− -- Log nonce eviction outside atomic block (IO can't run inside STM)
8280− logNonceEviction (pubkeyBucket to) cancelResult.nonceLruEvicted cancelResult.nonceOldestAge
8281− -- Notify recipient that this message was retracted (delivered via next poll)
8282− when cancelResult.cancelled (do
8283− queueCancelNotification to messageId t
8284− atomic do cc <- *clientCancelCount; set *clientCancelCount = cc + 1)
8285− -- Send federation batch cancel to remote servers that may have the message.
8286− -- Uses FederationBatchCancel (single-entry batch) instead of FederationCancel
8287− -- for code path consistency with handleCancelBatch.
8288− -- Failed cancels are queued for retry during the next prune cycle.
8289− fork (when (federationEnabled && cancelResult.cancelled && count cancelResult.cancelServers > 0)
8290− (sendToEach cancelResult.cancelServers (\server -> do
8292− cancelAuth <- generateFederationAuth "cancel-batch" cancelT
8293− cancelCorrId <- genTokenN 1
8294− cancelFedResult <- fetchFederation server (FederationBatchCancel {
8295− cancels: [{messageId: messageId, toKey: to}], fromServer: serverHostN,
8296− requestTimestamp: cancelT, correlationId: cancelCorrId,
8297− authorization: cancelAuth, protocolVersion: federationProtocolVersion})
8298− case cancelFedResult of
8300− logWarn ("federation: cancel to " ++ server ++ " failed for " ++ messageId ++ ": " ++ show e)
8301− queuePendingCancel messageId to server cancelT
8302− Ok r -> when (not r.ok) (do
8303− logWarn ("federation: cancel to " ++ server ++ " rejected for " ++ messageId ++ ": " ++ r.error)
8304− queuePendingCancel messageId to server cancelT))))
8305− yield (respond {ok: True {}, authorized: True {}, cancelled: cancelResult.cancelled, error: ""}))
8307−-- POST /messages/batch: Send multiple messages in one request.
8308−-- Auth checked once; each message processed independently with its own rate limiting.
8309−-- Partial success is possible — check per-message status in results.
8310−handleSendBatch = \messages authorization clientIp respond -> do
8313− if dp >= 2 then yield (respond {results: [], authorized: False {}, retryAfterMs: 0})
8315− globalRateLimited <- checkGlobalRate t
8316− if globalRateLimited then yield (respond {results: [], authorized: False {}, retryAfterMs: 0})
8318− withSessionAuth authorization t clientIp
8319− (yield (respond {results: [], authorized: False {}, retryAfterMs: 0}))
8321− let sized = takeRelation maxBatchSize messages
8322− -- Pre-deduplicate by explicit messageId to prevent within-batch duplicates.
8323− -- Each message in a batch gets its own atomic block via sendMessageCore, so
8324− -- dedup between messages in the same batch is not caught by STM.
8325− -- Messages with empty messageId (auto-generated) are always kept.
8326− let capped = fold (\acc m -> if m.messageId != "" && any acc (\a -> a.messageId == m.messageId) then acc else union acc [m]) [] sized
8327− -- Sort by pubkeyBucket(to) so sequential atomic blocks in sendBatchInner benefit
8328− -- from STM cache locality when multiple messages target the same recipient bucket.
8329− let sorted = sortBy (\m -> pubkeyBucket m.to) capped
8330− results <- sendBatchInner senderKey sorted t []
8331− -- Fork federation forwarding: one forked task per target server (not per message).
8332− -- Within each task, forwards are sent sequentially to avoid per-message fork overhead.
8333− let forwardTargets = do r <- results; where count r.remoteServers > 0; yield r
8334− -- Flatten all remote servers from all results (previous code used headOf, missing 2nd+ servers per message)
8335− let allServers = fold (\acc r ->
8336− fold (\innerAcc s ->
8337− if isLocalServer s then innerAcc
8338− else if any innerAcc (\a -> a == s) then innerAcc
8339− else union innerAcc [s]) acc r.remoteServers) [] forwardTargets
8340− fork (when (federationEnabled && count forwardTargets > 0)
8341− (sendToEach allServers (\server -> do
8342− let serverMsgs = do r <- forwardTargets; where any r.remoteServers (\s -> s == server); yield r
8343− sendBatchForwardsSequential serverMsgs server)))
8344− let batchRetryMs = fold (\acc r -> max acc r.retryAfterMs) 0 results
8345− yield (respond {results: do r <- results; yield {messageId: r.messageId, status: r.status}, authorized: True {}, retryAfterMs: batchRetryMs}))
8347−-- Batch messages are sorted by pubkeyBucket(to) by the caller, so consecutive messages
8348−-- sharing a bucket are grouped into a single atomic block. This reduces bucket reads
8349−-- from O(batchSize) to O(uniqueBuckets) and avoids per-message transaction overhead.
8350−-- Messages requiring genToken (empty messageId) are pre-processed outside the atomic block.
8351−sendBatchInner = \senderKey messages t acc ->
8352− case headOf messages of
8353− Nothing {} -> yield acc
8354− Just {value: first} -> do
8355− let bucket = pubkeyBucket first.to
8356− -- Collect consecutive messages targeting the same bucket
8357− let sameR = fold (\a m -> if pubkeyBucket m.to == bucket then {same: union a.same [m], rest: a.rest} else {same: a.same, rest: union a.rest [m]}) {same: [], rest: []} messages
8358− -- Pre-generate message IDs and validate timestamps (IO, outside atomic block)
8359− prepared <- prepareBatchMessages sameR.same t []
8360− -- Process the entire bucket group in a single atomic block
8361− results <- atomic do
8363− sendBatchBucketGroup senderKey prepared t dp []
8364− -- Log nonce evictions and warnings for rate-limited/rejected messages outside the atomic block
8365− logBatchNonceEvictions results
8366− logBatchResults results
8367− sendBatchInner senderKey sameR.rest t (union acc results)
8369−-- Pre-generate message IDs and validate timestamps for a group of messages.
8370−-- IO actions (genToken, logging) can't run inside atomic, so this runs outside.
8371−prepareBatchMessages = \messages t acc ->
8372− case headOf messages of
8373− Nothing {} -> yield acc
8374− Just {value: msg} -> do
8375− let rest = do m <- messages; where m != msg; yield m
8376− effectiveMsgId <- if msg.messageId != "" then yield msg.messageId else genToken
8377− when (msg.timestamp > t + clockSkewTolerance)
8378− (logWarn ("sendBatch: future timestamp detected (+" ++ show (msg.timestamp - t) ++ "ms ahead) for " ++ effectiveMsgId))
8379− when (msg.timestamp < t - messageMaxAge / 2 && t - msg.timestamp <= messageMaxAge)
8380− (logWarn ("sendBatch: stale timestamp (" ++ show ((t - msg.timestamp) / 86400000) ++ " days old) for " ++ effectiveMsgId))
8381− let entry = if t - msg.timestamp > messageMaxAge
8382− then {msg: msg, effectiveMsgId: effectiveMsgId, stale: True {}}
8383− else {msg: msg, effectiveMsgId: effectiveMsgId, stale: False {}}
8384− prepareBatchMessages rest t (union acc [entry])
8386−-- Process all prepared messages for one bucket in a single atomic block.
8387−-- Each call to sendMessageCore sees the previous call's writes (updated counters,
8388−-- new messages), avoiding redundant bucket reads.
8389−sendBatchBucketGroup = \senderKey prepared t dp acc ->
8390− case headOf prepared of
8391− Nothing {} -> yield acc
8392− Just {value: entry} -> do
8393− let rest = do p <- prepared; where p != entry; yield p
8394− let clampedPri = clamp 0 maxMessagePriority entry.msg.priority
8395− result <- if entry.stale
8396− then yield {messageId: entry.effectiveMsgId, status: MsRejected {}, remoteServers: [], toKey: "", blob: "", ts: 0, retryAfterMs: 0, fwdExpiresAt: 0, fwdPriority: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
8398− let clampedTs = clampTimestamp entry.msg.timestamp t
8399− if dp >= 2 then yield {messageId: entry.effectiveMsgId, status: MsDraining {}, remoteServers: [], toKey: entry.msg.to, blob: entry.msg.encryptedBlob, ts: clampedTs, retryAfterMs: 0, fwdExpiresAt: 0, fwdPriority: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
8401− sendResult <- sendMessageCore senderKey entry.msg.to entry.msg.encryptedBlob clampedTs entry.effectiveMsgId entry.msg.expiresInMs clampedPri t
8402− yield {messageId: entry.effectiveMsgId, status: sendResult.status, remoteServers: sendResult.remoteServers, toKey: entry.msg.to, blob: entry.msg.encryptedBlob, ts: clampedTs, retryAfterMs: sendResult.retryAfterMs, fwdExpiresAt: t + effectiveMessageTtl entry.msg.expiresInMs, fwdPriority: clampedPri, nonceBucket: sendResult.nonceBucket, nonceEvicted: sendResult.nonceEvicted, nonceOldestAge: sendResult.nonceOldestAge}
8403− sendBatchBucketGroup senderKey rest t dp (union acc [result])
8405−-- Log nonce evictions for batch results outside the atomic block
8406−logBatchNonceEvictions = \results ->
8407− case headOf results of
8408− Nothing {} -> yield {}
8409− Just {value: r} -> do
8410− let rest = do x <- results; where x != r; yield x
8411− logNonceEviction r.nonceBucket r.nonceEvicted r.nonceOldestAge
8412− logBatchNonceEvictions rest
8414−-- Log warnings for batch results outside the atomic block
8415−logBatchResults = \results ->
8416− case headOf results of
8417− Nothing {} -> yield {}
8418− Just {value: r} -> do
8419− let rest = do x <- results; where x != r; yield x
8421− MsRateLimited {} -> logEvent "warn" "rate_limited_send" ("messageId=" ++ r.messageId ++ " batch=true")
8422− MsRejected {} -> logWarn ("sendBatch: rejected for " ++ r.messageId ++ " (capacity or mailbox full)")
8424− logBatchResults rest
8426−-- POST /maintenance/block: Add a server to the federation blocklist.
8427−-- Blocked peers are rejected from all inbound and outbound federation operations.
8428handleBlockPeer = \server authorization respond -> do
2085handleBlockPeer = \server authorization respond -> do
8429 authorized <- verifyMaintenanceAuth authorization
2086 authorized <- verifyMaintenanceAuth authorization
8430 if not authorized then yield (respond {ok: False {}, blocked: 0})
2087 if not authorized then yield (respond {ok: False {}, blocked: 0})
8432− logEvent "audit" "block_peer" server
2089+ n <- atomic do
8433− result <- atomic do
8434 blocked <- *blockedPeers
2090 blocked <- *blockedPeers
8435− if isBlockedPeer server blocked then yield {alreadyBlocked: True {}, total: count blocked}
2091+ if any blocked (\b -> b == server) then yield (count blocked)
8437− -- FIFO eviction: remove the oldest entry (head of list) since union appends
2093+ let updated = union blocked [server]
8438− let updated = if count blocked >= maxBlockedPeers
8439− then case headOf blocked of
8440− Nothing {} -> [server]
8441− Just {value: oldest} -> union (do b <- blocked; where b != oldest; yield b) [server]
8442− else union blocked [server]
8443 set *blockedPeers = updated
2094 set *blockedPeers = updated
8444− yield {alreadyBlocked: False {}, total: count updated}
2095+ yield (count updated)
8445− when (not result.alreadyBlocked) (logInfo ("block: added " ++ server ++ " to blocklist (" ++ show result.total ++ " total)"))
2096+ yield (respond {ok: True {}, blocked: n})
8446− yield (respond {ok: True {}, blocked: result.total})
8448−-- POST /maintenance/unblock: Remove a server from the federation blocklist.
8449handleUnblockPeer = \server authorization respond -> do
2098handleUnblockPeer = \server authorization respond -> do
8450 authorized <- verifyMaintenanceAuth authorization
2099 authorized <- verifyMaintenanceAuth authorization
8451 if not authorized then yield (respond {ok: False {}, unblocked: False {}})
2100 if not authorized then yield (respond {ok: False {}, unblocked: False {}})
8453− logEvent "audit" "unblock_peer" server
8454 removed <- atomic do
2102 removed <- atomic do
8455 blocked <- *blockedPeers
2103 blocked <- *blockedPeers
8456− let had = isBlockedPeer server blocked
2104+ let had = any blocked (\b -> b == server)
8457 set *blockedPeers = do b <- blocked; where b != server; yield b
2105 set *blockedPeers = do b <- blocked; where b != server; yield b
8458 yield had
2106 yield had
8459− when removed (logInfo ("unblock: removed " ++ server ++ " from blocklist"))
8460 yield (respond {ok: True {}, unblocked: removed})
2107 yield (respond {ok: True {}, unblocked: removed})
8462−-- GET /maintenance/blocked: List currently blocked federation peers.
8463handleListBlocked = \authorization respond -> do
2109handleListBlocked = \authorization respond -> do
8464 authorized <- verifyMaintenanceAuth authorization
2110 authorized <- verifyMaintenanceAuth authorization
8465 if not authorized then yield (respond {peers: [], ok: False {}})
2111 if not authorized then yield (respond {peers: [], ok: False {}})
@@ -8467,45 +2113,30 @@ handleListBlocked = \authorization respond -> do
8467 blocked <- *blockedPeers
2113 blocked <- *blockedPeers
8468 yield (respond {peers: blocked, ok: True {}})
2114 yield (respond {peers: blocked, ok: True {}})
8470−-- POST /maintenance/allow: Add a server to the federation allowlist.
8471−-- When the allowlist is non-empty, only servers on the list can federate with us.
8472−-- Adding the first server transitions from open federation to allowlist-only mode.
8473handleAllowPeer = \server authorization respond -> do
2116handleAllowPeer = \server authorization respond -> do
8474 authorized <- verifyMaintenanceAuth authorization
2117 authorized <- verifyMaintenanceAuth authorization
8475 if not authorized then yield (respond {ok: False {}, allowed: 0})
2118 if not authorized then yield (respond {ok: False {}, allowed: 0})
8477− logEvent "audit" "allow_peer" server
2120+ n <- atomic do
8478− result <- atomic do
8479 allowed <- *allowedPeers
2121 allowed <- *allowedPeers
8480− if any allowed (\a -> a == server) then yield {alreadyAllowed: True {}, total: count allowed}
2122+ if any allowed (\a -> a == server) then yield (count allowed)
8482− let updated = if count allowed >= maxAllowedPeers
2124+ let updated = union allowed [server]
8483− then case headOf allowed of
8484− Nothing {} -> [server]
8485− Just {value: oldest} -> union (do a <- allowed; where a != oldest; yield a) [server]
8486− else union allowed [server]
8487 set *allowedPeers = updated
2125 set *allowedPeers = updated
8488− yield {alreadyAllowed: False {}, total: count updated}
2126+ yield (count updated)
8489− when (not result.alreadyAllowed) (logInfo ("allow: added " ++ server ++ " to allowlist (" ++ show result.total ++ " total)"))
2127+ yield (respond {ok: True {}, allowed: n})
8490− yield (respond {ok: True {}, allowed: result.total})
8492−-- POST /maintenance/unallow: Remove a server from the federation allowlist.
8493−-- Removing the last server transitions back to open federation mode.
8494handleUnallowPeer = \server authorization respond -> do
2129handleUnallowPeer = \server authorization respond -> do
8495 authorized <- verifyMaintenanceAuth authorization
2130 authorized <- verifyMaintenanceAuth authorization
8496 if not authorized then yield (respond {ok: False {}, removed: False {}})
2131 if not authorized then yield (respond {ok: False {}, removed: False {}})
8498− logEvent "audit" "unallow_peer" server
8499 removed <- atomic do
2133 removed <- atomic do
8500 allowed <- *allowedPeers
2134 allowed <- *allowedPeers
8501 let had = any allowed (\a -> a == server)
2135 let had = any allowed (\a -> a == server)
8502 set *allowedPeers = do a <- allowed; where a != server; yield a
2136 set *allowedPeers = do a <- allowed; where a != server; yield a
8503 yield had
2137 yield had
8504− when removed (logInfo ("unallow: removed " ++ server ++ " from allowlist"))
8505 yield (respond {ok: True {}, removed: removed})
2138 yield (respond {ok: True {}, removed: removed})
8507−-- GET /maintenance/allowed: List currently allowed federation peers.
8508−-- Empty list = open federation (all peers allowed).
8509handleListAllowed = \authorization respond -> do
2140handleListAllowed = \authorization respond -> do
8510 authorized <- verifyMaintenanceAuth authorization
2141 authorized <- verifyMaintenanceAuth authorization
8511 if not authorized then yield (respond {peers: [], ok: False {}})
2142 if not authorized then yield (respond {peers: [], ok: False {}})
@@ -8513,397 +2144,229 @@ handleListAllowed = \authorization respond -> do
8513 allowed <- *allowedPeers
2144 allowed <- *allowedPeers
8514 yield (respond {peers: allowed, ok: True {}})
2145 yield (respond {peers: allowed, ok: True {}})
8516−-- POST /maintenance/ping: Test federation connectivity to a specific peer.
8517−-- Sends an empty gossip (0 events, hopsRemaining=1) to the peer via the full
8518−-- federation auth path. The peer calls back to our /federation/verify to authenticate,
8519−-- then processes the empty gossip (no mutations, no re-broadcast since hops=1).
8520−-- This exercises the real bidirectional connectivity and auth flow.
8521handlePingPeer = \server authorization respond -> do
2147handlePingPeer = \server authorization respond -> do
8522 authorized <- verifyMaintenanceAuth authorization
2148 authorized <- verifyMaintenanceAuth authorization
8523 if not authorized then yield (respond {ok: False {}, latencyMs: 0, error: "unauthorized"})
2149 if not authorized then yield (respond {ok: False {}, latencyMs: 0, error: "unauthorized"})
8525 startTime <- now
2151 startTime <- now
8526 auth <- generateFederationAuth "gossip" startTime
2152 auth <- generateFederationAuth "gossip" startTime
8527− pingCorrId <- genTokenN 1
2153+ result <- fetch (federationUrl server) (RecvGossip {
8528− result <- fetchFederation server (RecvGossip {
8529 authorization: auth,
2154 authorization: auth,
8530 events: [], hopsRemaining: 1, fromServer: serverHostN,
2155 events: [], hopsRemaining: 1, fromServer: serverHostN,
8531− requestTimestamp: startTime, correlationId: pingCorrId, protocolVersion: federationProtocolVersion})
2156+ requestTimestamp: startTime, correlationId: "", protocolVersion: federationProtocolVersion})
8532 endTime <- now
2157 endTime <- now
8533− let latency = endTime - startTime
8534 case result of
2158 case result of
8535− Err e -> do
2159+ Err e -> yield (respond {ok: False {}, latencyMs: endTime - startTime, error: show e})
8536− logWarn ("ping: " ++ server ++ " failed: " ++ show e)
2160+ Ok r -> yield (respond {ok: r.ok, latencyMs: endTime - startTime, error: r.error})
8537− yield (respond {ok: False {}, latencyMs: latency, error: show e})
2161+
8538− Ok r -> yield (respond {ok: r.ok, latencyMs: latency, error: r.error})
8540−-- GET /maintenance/sessions/{pubkey}: List sessions for a specific pubkey.
8541−-- Uses per-bucket scan (collectSessionsForKey) instead of readAllSessions to avoid
8542−-- materializing all 16 session buckets into one list just to filter by pubkey.
8543handleAdminListSessions = \pubkey authorization respond -> do
2162handleAdminListSessions = \pubkey authorization respond -> do
8544 authorized <- verifyMaintenanceAuth authorization
2163 authorized <- verifyMaintenanceAuth authorization
8545 if not authorized then yield (respond {sessions: [], count: 0, ok: False {}})
2164 if not authorized then yield (respond {sessions: [], count: 0, ok: False {}})
8547− keySessions <- collectSessionsForKey pubkey 0
2166+ ses <- *sessions
8548− -- Return only metadata (IP, timestamps) — no token fragments. Even a 4-char prefix
2167+ let mine = do s <- ses; where s.pubkey == pubkey; yield {token: "***", expiresAt: s.expiresAt, ip: s.ip, createdAt: s.createdAt}
8549− -- (16 bits) narrows brute-force search space and can be correlated with token bucket
2168+ yield (respond {sessions: mine, count: count mine, ok: True {}})
8550− -- indices. Sessions are identifiable by (ip, createdAt) pair without token exposure.
2169+
8551− let masked = do s <- keySessions; yield {token: "***", expiresAt: s.expiresAt, ip: s.ip, createdAt: s.createdAt}
8552− yield (respond {sessions: masked, count: count masked, ok: True {}})
8554−-- POST /maintenance/sessions/revoke-all: Revoke all sessions for a pubkey (abuse response).
8555−-- Also clears local presence and gossips offline if federation is enabled.
8556handleAdminRevokeSessions = \pubkey authorization respond -> do
2170handleAdminRevokeSessions = \pubkey authorization respond -> do
8557 authorized <- verifyMaintenanceAuth authorization
2171 authorized <- verifyMaintenanceAuth authorization
8558 if not authorized then yield (respond {ok: False {}, revokedCount: 0})
2172 if not authorized then yield (respond {ok: False {}, revokedCount: 0})
8560− logEvent "audit" "revoke_all_sessions" pubkey
8561 t <- now
2174 t <- now
8562− result <- atomic do
2175+ revoked <- atomic do
8563− -- Filter each session bucket in-place (avoids readAllSessions + writeAllSessions repartition)
2176+ ses <- *sessions
8564− revokedCount <- revokeSessionsForKey pubkey 0
2177+ let mine = do s <- ses; where s.pubkey == pubkey; yield s
8565− sc <- *totalSessionCount
2178+ set *sessions = do s <- ses; where s.pubkey != pubkey; yield s
8566− set *totalSessionCount = max 0 (sc - revokedCount)
2179+ pres <- *presence
8567− -- Clear local presence
2180+ set *presence = do p <- pres; where p.pubkey != pubkey || not (isLocalServer p.server); yield p
8568− let pb = pubkeyBucket pubkey
2181+ yield (count mine)
8569− presenceBkt <- readPresenceBucket pb
2182+ yield (respond {ok: True {}, revokedCount: revoked})
8570− let presenceRemoved = count presenceBkt - count (do p <- presenceBkt; where p.pubkey != pubkey || not (isLocalServer p.server); yield p)
2183+
8571− writePresenceBucket pb (do p <- presenceBkt; where p.pubkey != pubkey || not (isLocalServer p.server); yield p)
8572− tpc <- *totalPresenceCount
8573− set *totalPresenceCount = max 0 (tpc - presenceRemoved)
8574− when (presenceRemoved > 0) (set *presenceVersion = t)
8575− peerServers <- *knownPeerServers
8576− yield {revokedCount: revokedCount, peerServers: peerServers, hadPresence: presenceRemoved > 0}
8577− when (result.revokedCount > 0)
8578− (logInfo ("admin: revoked " ++ show result.revokedCount ++ " sessions for " ++ pubkey))
8579− when (result.hadPresence && federationEnabled && count result.peerServers > 0)
8580− (fork (sendBatchedGossip result.peerServers [{eventType: GossipOffline {}, pubkey: pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}] gossipOriginHops))
8581− yield (respond {ok: True {}, revokedCount: result.revokedCount})
8583−-- POST /maintenance/messages/purge: Purge all pending messages for a specific pubkey.
8584−-- Use for inbox-bombing abuse response: clears the recipient's mailbox without
8585−-- requiring their session token. Also cancels pending forwards for purged messages.
8586−-- Federated messages (originServer != "") generate ack entries so origin servers
8587−-- can reclaim their forward entries instead of retrying until prune.
8588handleAdminPurgeMessages = \pubkey authorization respond -> do
2184handleAdminPurgeMessages = \pubkey authorization respond -> do
8589 authorized <- verifyMaintenanceAuth authorization
2185 authorized <- verifyMaintenanceAuth authorization
8590 if not authorized then yield (respond {ok: False {}, purgedCount: 0})
2186 if not authorized then yield (respond {ok: False {}, purgedCount: 0})
8592− logEvent "audit" "purge_messages" pubkey
8593 t <- now
2188 t <- now
8594− purgeResult <- atomic do
2189+ purged <- atomic do
8595− let b = pubkeyBucket pubkey
2190+ msgs <- *messages
8596− bucket <- readMessageBucket b
2191+ let mine = do m <- msgs; where m.toKey == pubkey; yield m
8597− let toDelete = do m <- bucket; where m.toKey == pubkey; yield m
2192+ set *messages = do m <- msgs; where m.toKey != pubkey; yield m
8598− let removed = count toDelete
2193+ fwds <- *forwards
8599− if removed > 0 then do
2194+ set *forwards = do f <- fwds; where f.toKey != pubkey; yield f
8600− writeMessageBucket b (do m <- bucket; where m.toKey != pubkey; yield m)
2195+ let federated = do m <- mine; where m.originServer != ""; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
8601− tc <- *totalMessageCount
2196+ aids <- *ackedIds
8602− set *totalMessageCount = max 0 (tc - removed)
2197+ set *ackedIds = capList (union aids federated) maxAckedIds (\a -> a.ackedAt)
8603− rc <- readRcBucket b
2198+ yield (count mine)
8604− writeRcBucket b (adjustRecipientCount rc pubkey (0 - removed))
2199+ yield (respond {ok: True {}, purgedCount: purged})
8605− -- Cancel pending forwards for purged messages (bucket read: O(n/16))
2200+
8606− let deletedMsgIds = do m <- toDelete; yield m.messageId
8607− let pfb = pubkeyBucket pubkey
8608− fwdBkt <- readFwdBucket pfb
8609− let keptPurgeFwds = do f <- fwdBkt; where none deletedMsgIds (\mid -> f.messageId == mid && f.toKey == pubkey); yield f
8610− let fwdPurgeRemoved = count fwdBkt - count keptPurgeFwds
8611− writeFwdBucket pfb keptPurgeFwds
8612− when (fwdPurgeRemoved > 0) (do
8613− tfc <- *totalForwardCount
8614− set *totalForwardCount = max 0 (tfc - fwdPurgeRemoved))
8615− -- Create ack entries for federated messages so origin servers learn about the purge
8616− let federatedPurged = do m <- toDelete; where m.originServer != ""; yield m
8617− let ackedFederated = federatedAckEntries federatedPurged t
8618− if count ackedFederated > 0 then do
8619− ackedBkt <- readAckedBucket b
8620− let combinedAcked = union ackedBkt ackedFederated
8621− let excessCount = max 0 (count combinedAcked - maxAckedIds)
8622− let eviction = evictSmallest combinedAcked excessCount (\a -> a.ackedAt)
8623− writeAckedBucket b eviction.kept
8624− yield {purgedCount: removed, pendingAcks: ackedFederated, evictedEntries: eviction.evicted}
8625− else yield {purgedCount: removed, pendingAcks: [], evictedEntries: []}
8626− else yield {purgedCount: 0, pendingAcks: [], evictedEntries: []}
8627− when (purgeResult.purgedCount > 0)
8628− (logInfo ("admin: purged " ++ show purgeResult.purgedCount ++ " messages for " ++ pubkey))
8629− when (count purgeResult.pendingAcks > 0)
8630− (logInfo ("admin: sending federation acks for " ++ show (count purgeResult.pendingAcks) ++ " purged federated messages"))
8631− -- Send federation acks in the background (same pattern as handleAckMessages)
8632− fork (when federationEnabled (do
8633− sendAcksAndClean purgeResult.pendingAcks
8634− retryEvictedAcks purgeResult.evictedEntries purgeResult.pendingAcks))
8635− yield (respond {ok: True {}, purgedCount: purgeResult.purgedCount})
8637−-- POST /maintenance/sessions/revoke-ip: Revoke all sessions from a specific IP address.
8638−-- Useful for abuse response when key-rotation abuse is detected from a single IP
8639−-- (one IP authenticating many distinct pubkeys to bypass per-key rate limits).
8640−-- Scans all 16 session buckets, removes matching sessions, and gossips offline
8641−-- for any pubkey that lost its last session.
8642handleAdminRevokeIp = \ip authorization respond -> do
2201handleAdminRevokeIp = \ip authorization respond -> do
8643 authorized <- verifyMaintenanceAuth authorization
2202 authorized <- verifyMaintenanceAuth authorization
8644 if not authorized then yield (respond {ok: False {}, revokedCount: 0, affectedKeys: 0})
2203 if not authorized then yield (respond {ok: False {}, revokedCount: 0, affectedKeys: 0})
2204+ else if ip == "" then yield (respond {ok: False {}, revokedCount: 0, affectedKeys: 0})
8646− logEvent "audit" "revoke_ip" ip
2206+ result <- atomic do
8647− if ip == "" then yield (respond {ok: False {}, revokedCount: 0, affectedKeys: 0})
2207+ ses <- *sessions
8648− else do
2208+ let mine = do s <- ses; where s.ip == ip; yield s
8649− t <- now
2209+ set *sessions = do s <- ses; where s.ip != ip; yield s
8650− result <- revokeSessionsByIp ip 0 t {revokedCount: 0, affectedKeys: [], cleanups: []}
2210+ let keys = fold (\acc s -> if any acc (\a -> a == s.pubkey) then acc else union acc [s.pubkey]) [] mine
8651− -- Gossip offline for pubkeys that lost their last session
2211+ yield {revoked: count mine, keys: count keys}
8652− fork (do
2212+ yield (respond {ok: True {}, revokedCount: result.revoked, affectedKeys: result.keys})
8653− offlines <- do c <- result.cleanups; where c.gossipOffline; yield c
2213+
8654− when (count offlines > 0 && federationEnabled) (do
8655− peerServers <- *knownPeerServers
8656− when (count peerServers > 0) (do
8657− let gossipEvents = do c <- offlines; yield {eventType: GossipOffline {}, pubkey: c.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}
8658− sendBatchedGossip peerServers gossipEvents gossipOriginHops)))
8659− when (result.revokedCount > 0)
8660− (logInfo ("admin: revoked " ++ show result.revokedCount ++ " sessions from IP " ++ ip ++ " (" ++ show (count result.affectedKeys) ++ " keys affected)"))
8661− yield (respond {ok: True {}, revokedCount: result.revokedCount, affectedKeys: count result.affectedKeys})
8663−-- Per-bucket IP session revocation: scans one session bucket at a time, collecting
8664−-- affected pubkeys and checking for last-session cleanup needs.
8665−revokeSessionsByIp = \ip b t acc ->
8666− if b > 15 then yield acc
8668− bucketResult <- atomic do
8669− bucket <- readSessionBucket b
8670− let matching = do s <- bucket; where s.ip == ip; yield s
8671− let matchCount = count matching
8672− if matchCount == 0 then yield {removed: 0, pubkeys: []}
8674− writeSessionBucket b (do s <- bucket; where s.ip != ip; yield s)
8675− sc <- *totalSessionCount
8676− set *totalSessionCount = max 0 (sc - matchCount)
8677− -- Collect unique affected pubkeys from this bucket
8678− let pks = fold (\a s -> if any a (\x -> x == s.pubkey) then a else union [s.pubkey] a) [] matching
8679− yield {removed: matchCount, pubkeys: pks}
8680− -- For each newly seen pubkey, check if it was their last session
8681− let newKeys = do k <- bucketResult.pubkeys; where none acc.affectedKeys (\a -> a == k); yield k
8682− cleanups <- checkCleanupForKeys newKeys t []
8683− let newAcc = {revokedCount: acc.revokedCount + bucketResult.removed,
8684− affectedKeys: fold (\a k -> if any a (\x -> x == k) then a else union [k] a) acc.affectedKeys bucketResult.pubkeys,
8685− cleanups: union acc.cleanups cleanups}
8686− revokeSessionsByIp ip (b + 1) t newAcc
8688−-- Check last-session cleanup for a list of pubkeys (used by revokeSessionsByIp)
8689−checkCleanupForKeys = \keys t acc ->
8690− case headOf keys of
8691− Nothing {} -> yield acc
8692− Just {value: k} -> do
8693− let rest = do x <- keys; where x != k; yield x
8694− cleanup <- checkLastSessionCleanup k t
8695− checkCleanupForKeys rest t (union acc [cleanup])
8697−-- POST /maintenance/sessions/list: List all active pubkeys with session counts and IPs.
8698−-- Useful for detecting suspicious multi-key activity (e.g., one IP authenticating many keys)
8699−-- without needing to know the pubkey in advance. Groups sessions by pubkey.
8700handleAdminListAllSessions = \limit authorization respond -> do
2214handleAdminListAllSessions = \limit authorization respond -> do
8701 authorized <- verifyMaintenanceAuth authorization
2215 authorized <- verifyMaintenanceAuth authorization
8702 if not authorized then yield (respond {sessions: [], ok: False {}, total: 0})
2216 if not authorized then yield (respond {sessions: [], ok: False {}, total: 0})
8704− let effectiveLimit = if limit <= 0 then 100 else clamp 1 500 limit
8705 t <- now
2218 t <- now
8706− -- Per-bucket scan: reads one session bucket at a time instead of materializing
2219+ ses <- *sessions
8707− -- all 16 into one list (avoids O(n) union across all sessions).
2220+ let active = do s <- ses; where s.expiresAt > t; yield s
8708− grouped <- groupSessionsByBucket 0 t []
2221+ let grouped = fold (\acc s ->
8709− -- Sort by count descending (most sessions first) for abuse investigation
2222+ if any acc (\a -> a.pubkey == s.pubkey)
2223+ then do a <- acc; yield (if a.pubkey == s.pubkey then {pubkey: a.pubkey, count: a.count + 1, ips: if any a.ips (\i -> i == s.ip) || s.ip == "" then a.ips else union a.ips [s.ip], latestExpiry: max a.latestExpiry s.expiresAt} else a)
2224+ else union acc [{pubkey: s.pubkey, count: 1, ips: if s.ip == "" then [] else [s.ip], latestExpiry: s.expiresAt}]) [] active
8710 let sorted = sortBy (\g -> 0 - g.count) grouped
2225 let sorted = sortBy (\g -> 0 - g.count) grouped
8711− let capped = takeRelation effectiveLimit sorted
2226+ let effLimit = if limit <= 0 then 100 else clamp 1 500 limit
8712− yield (respond {sessions: capped, ok: True {}, total: count grouped})
2227+ yield (respond {sessions: takeRelation effLimit sorted, ok: True {}, total: count grouped})
2229+handleGetRateLimits = \authorization respond -> do
2230+ authorized <- verifyMaintenanceAuth authorization
2231+ if not authorized then yield (respond {ok: False {}, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0})
2232+ else yield (respond {ok: True {}, globalRequest: maxGlobalRequestRate, ipRate: maxIpRatePerIp, sendRate: maxSendRatePerKey, federationRate: maxFederationRatePerServer, authGlobal: maxAuthGlobalRate, recvRate: maxRecvRatePerKey, challengeRate: maxChallengeRatePerKey, pairRate: maxPairRatePerPair, lookupRate: maxLookupRatePerKey, clientWriteRate: maxClientWriteRatePerKey})
2234+handleSetRateLimits = \globalRequest ipRate sendRate federationRate authGlobal recvRate challengeRate pairRate lookupRate clientWriteRate authorization respond -> do
2235+ authorized <- verifyMaintenanceAuth authorization
2236+ yield (respond {ok: authorized})
8714−-- Per-bucket session grouping: reads one bucket at a time, merging active sessions
8715−-- into the running grouped accumulator. Avoids readAllSessions O(n) materialization.
8716−groupSessionsByBucket = \b t acc ->
8717− if b > 15 then yield acc
8719− bucket <- readSessionBucket b
8720− let active = do s <- bucket; where s.expiresAt > t && t - s.createdAt < maxSessionLifetime; yield s
8721− let merged = fold (\grouped s ->
8722− if any grouped (\a -> a.pubkey == s.pubkey)
8723− then do a <- grouped; yield (if a.pubkey == s.pubkey then {pubkey: a.pubkey, count: a.count + 1, ips: if any a.ips (\i -> i == s.ip) || s.ip == "" then a.ips else union a.ips [s.ip], latestExpiry: max a.latestExpiry s.expiresAt} else a)
8724− else union grouped [{pubkey: s.pubkey, count: 1, ips: if s.ip == "" then [] else [s.ip], latestExpiry: s.expiresAt}])
8726− groupSessionsByBucket (b + 1) t merged
8728−-- POST /maintenance/nonces/flush: Clear all forward nonces (recovery from corruption).
8729−-- Nonces provide extended replay protection beyond message/ack dedup lifetime.
8730−-- Flushing temporarily reopens a replay window for messages older than 30 days but
8731−-- younger than 60 days. Use only for recovery, not routine maintenance.
8732handleFlushNonces = \authorization respond -> do
2238handleFlushNonces = \authorization respond -> do
8733 authorized <- verifyMaintenanceAuth authorization
2239 authorized <- verifyMaintenanceAuth authorization
8734− if not authorized then yield (respond {ok: False {}, flushedCount: 0})
2240+ yield (respond {ok: authorized, flushedCount: 0})
8736− logEvent "audit" "flush_nonces" ""
8737− flushedCount <- atomic do
8738− total <- countAllNonces 0
8740− -- Reset all per-bucket eviction cutoffs (no nonces remain, accept all timestamps)
8741− resetAllNonceCutoffs 0
8743− logInfo ("nonces/flush: flushed " ++ show flushedCount ++ " forward nonces")
8744− yield (respond {ok: True {}, flushedCount: flushedCount})
8746−-- POST /maintenance/rotate-secret: Rotate the maintenance secret at runtime.
8747−-- Authenticated with the current secret. The new secret takes effect immediately
8748−-- for all subsequent requests. Pass empty newSecret to revert to the compile-time default.
8749handleRotateSecret = \newSecret authorization respond -> do
2242handleRotateSecret = \newSecret authorization respond -> do
8750 authorized <- verifyMaintenanceAuth authorization
2243 authorized <- verifyMaintenanceAuth authorization
8751 if not authorized then yield (respond {ok: False {}, error: "unauthorized"})
2244 if not authorized then yield (respond {ok: False {}, error: "unauthorized"})
8753− logEvent "audit" "rotate_secret" (if newSecret == "" then "disabled" else "new_secret")
2246+ atomic do set *runtimeMaintenanceSecret = newSecret
8754− if newSecret != "" && federationEnabled && not (tooLong newSecret 15) then do
2247+ yield (respond {ok: True {}, error: ""})
8755− logError "rotate-secret: rejected — secret must be at least 16 characters when federation is enabled"
8756− yield (respond {ok: False {}, error: "secret_too_short"})
8757− else if newSecret != "" && not (tooLong newSecret 31) then do
8758− logWarn "rotate-secret: new secret is shorter than 32 characters — 32+ recommended for production"
8759− atomic do set *runtimeMaintenanceSecret = newSecret
8760− logInfo "rotate-secret: maintenance secret rotated (warning: short secret)"
8761− yield (respond {ok: True {}, error: ""})
8763− atomic do set *runtimeMaintenanceSecret = newSecret
8765− then logInfo "rotate-secret: maintenance secret cleared — maintenance endpoints disabled"
8766− else logInfo "rotate-secret: maintenance secret rotated"
8767− yield (respond {ok: True {}, error: ""})
8769−-- GET /maintenance/rate-limits: Return current effective rate limits.
2249+handleGetConfig = \authorization respond -> do
8770−handleGetRateLimits = \authorization respond -> do
8771 authorized <- verifyMaintenanceAuth authorization
2250 authorized <- verifyMaintenanceAuth authorization
8772− if not authorized then yield (respond {ok: False {}, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0})
2251+ if not authorized then yield (respond {ok: False {}, maxMessagesPerRecipient: 0, maxGossipHops: 0, pollTimeoutMs: 0, ackGracePeriod: 0})
2252+ else yield (respond {ok: True {}, maxMessagesPerRecipient: maxMessagesPerRecipient, maxGossipHops: maxGossipHops, pollTimeoutMs: pollTimeoutMs, ackGracePeriod: ackGracePeriod})
2254+-- /stats: zero-fill all metric fields we no longer compute.
2255+handleStats = \authorization respond -> do
2256+ authorized <- verifyMaintenanceAuth authorization
2257+ if not authorized then yield (respond zeroStats)
8774− result <- atomic do
2259+ t <- now
8775− gr <- effectiveGlobalRequestRate
2260+ sa <- *startedAt
8776− ir <- effectiveIpRate
2261+ sessions <- *sessions
8777− sr <- effectiveSendRate
2262+ msgs <- *messages
8778− fr <- effectiveFederationRate
2263+ pres <- *presence
8779− ar <- effectiveAuthGlobalRate
2264+ fwds <- *forwards
8780− rr <- effectiveRecvRate
2265+ aids <- *ackedIds
8781− cr <- effectiveChallengeRate
2266+ dids <- *deliveredIds
8782− pr <- effectivePairRate
2267+ aps <- *activePolls
8783− lr <- effectiveLookupRate
2268+ chs <- *challenges
8784− cwr <- effectiveClientWriteRate
2269+ bp <- *blockedPeers
8785− yield {globalRequest: gr, ipRate: ir, sendRate: sr, federationRate: fr, authGlobal: ar, recvRate: rr, challengeRate: cr, pairRate: pr, lookupRate: lr, clientWriteRate: cwr}
2270+ pc <- *pruneCount
8786− yield (respond {ok: True {}, globalRequest: result.globalRequest, ipRate: result.ipRate, sendRate: result.sendRate, federationRate: result.federationRate, authGlobal: result.authGlobal, recvRate: result.recvRate, challengeRate: result.challengeRate, pairRate: result.pairRate, lookupRate: result.lookupRate, clientWriteRate: result.clientWriteRate})
2271+ hc <- *heartbeatCount
8787−
2272+ lp <- *lastPrunedAt
8788−-- POST /maintenance/rate-limits: Update rate limits at runtime. 0 = reset to compile-time default.
2273+ lh <- *lastHeartbeatAt
8789−-- Negative values are clamped to 0. Changes take effect on the next rate check cycle.
2274+ dp <- *drainPhase
8790−handleSetRateLimits = \globalRequest ipRate sendRate federationRate authGlobal recvRate challengeRate pairRate lookupRate clientWriteRate authorization respond -> do
2275+ pfc <- *pendingFederationCancels
2276+ let sCount = count sessions
2277+ let mCount = count msgs
2278+ let pCount = count pres
2279+ let fCount = count fwds
2280+ let zeroFed = {enabled: federationEnabled, inFlight: 0, hungSlots: 0, avgLatencyMs: 0, maxLatencyMs: 0, callCount: 0, slowVerifies: 0, verifyFailures: 0, forwardFailures: 0, oldestForwardAge: 0, oldestAckAge: 0, recentGossip: 0, blockedPeers: count bp, drainCompletedAt: 0, forwardServers: 0, maxForwardQueueDepth: 0, topFailingPeers: [], pendingCancels: count pfc, gossipSuccess: 0, gossipFail: 0, latencyBuckets: {lt100: 0, lt500: 0, lt2000: 0, gte2000: 0}}
2281+ let zeroRates = {send: 0, challenge: 0, federation: 0, federationPair: 0, global: 0, ip: 0, lookup: 0, recv: 0, pair: 0, gossipEvent: 0, verifyIp: 0, uniqueKeyIp: 0, pendingAckCleanups: 0, senderExpirations: 0, senderDeliveries: 0, rejectedGlobal: 0, rejectedIp: 0, rejectedAuth: 0, rejectedPerKey: 0, rejectedFederation: 0, clientCancels: 0, federationCancels: 0}
2282+ let cap = {sessions: sCount, sessionsMax: maxSessions, sessionsPct: if maxSessions > 0 then sCount * 100 / maxSessions else 0, messages: mCount, messagesMax: maxMessages, messagesPct: if maxMessages > 0 then mCount * 100 / maxMessages else 0, totalMessageCount: mCount, presence: pCount, presenceMax: maxPresenceEntries, presencePct: if maxPresenceEntries > 0 then pCount * 100 / maxPresenceEntries else 0, forwards: fCount, forwardsMax: maxForwardsEntries, forwardsPct: if maxForwardsEntries > 0 then fCount * 100 / maxForwardsEntries else 0, challenges: count chs, challengesMax: maxChallenges, ackedIds: count aids, ackedIdsMax: maxAckedIds, ackOverflow: 0, ackOverflowMax: 0, deliveredIds: count dids, deliveredIdsMax: maxDeliveredIds, forwardNonces: 0, forwardNoncesMax: 0, nonceEvictions: 0, activePolls: count aps, activePollsMax: maxActivePolls, recipientCounts: 0, messageBucketMax: 0, messageBucketMin: 0}
2283+ let timing = {pruneCount: pc, pruneRunning: 0, heartbeatCount: hc, uptime: t - sa, lastPruneAt: lp, lastHeartbeatAt: lh, draining: dp > 0, drainPhase: dp, totalEntries: sCount + mCount + pCount + fCount, activeRequests: 0, peakActiveRequests: 0, pollAvgMs: 0, pollMaxMs: 0, pollCount: 0, pollLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0}, sendAvgMs: 0, sendMaxMs: 0, sendCount: 0, sendLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0}, authAvgMs: 0, authMaxMs: 0, authCount: 0}
2284+ yield (respond {ok: True {}, version: serverBuildVersion, capacity: cap, federation: zeroFed, rates: zeroRates, timing: timing})
2286+zeroStats = {ok: False {}, version: serverBuildVersion, capacity: {sessions: 0, sessionsMax: 0, sessionsPct: 0, messages: 0, messagesMax: 0, messagesPct: 0, totalMessageCount: 0, presence: 0, presenceMax: 0, presencePct: 0, forwards: 0, forwardsMax: 0, forwardsPct: 0, challenges: 0, challengesMax: 0, ackedIds: 0, ackedIdsMax: 0, ackOverflow: 0, ackOverflowMax: 0, deliveredIds: 0, deliveredIdsMax: 0, forwardNonces: 0, forwardNoncesMax: 0, nonceEvictions: 0, activePolls: 0, activePollsMax: 0, recipientCounts: 0, messageBucketMax: 0, messageBucketMin: 0}, federation: {enabled: False {}, inFlight: 0, hungSlots: 0, avgLatencyMs: 0, maxLatencyMs: 0, callCount: 0, slowVerifies: 0, verifyFailures: 0, forwardFailures: 0, oldestForwardAge: 0, oldestAckAge: 0, recentGossip: 0, blockedPeers: 0, drainCompletedAt: 0, forwardServers: 0, maxForwardQueueDepth: 0, topFailingPeers: [], pendingCancels: 0, gossipSuccess: 0, gossipFail: 0, latencyBuckets: {lt100: 0, lt500: 0, lt2000: 0, gte2000: 0}}, rates: {send: 0, challenge: 0, federation: 0, federationPair: 0, global: 0, ip: 0, lookup: 0, recv: 0, pair: 0, gossipEvent: 0, verifyIp: 0, uniqueKeyIp: 0, pendingAckCleanups: 0, senderExpirations: 0, senderDeliveries: 0, rejectedGlobal: 0, rejectedIp: 0, rejectedAuth: 0, rejectedPerKey: 0, rejectedFederation: 0, clientCancels: 0, federationCancels: 0}, timing: {pruneCount: 0, pruneRunning: 0, heartbeatCount: 0, uptime: 0, lastPruneAt: 0, lastHeartbeatAt: 0, draining: False {}, drainPhase: 0, totalEntries: 0, activeRequests: 0, peakActiveRequests: 0, pollAvgMs: 0, pollMaxMs: 0, pollCount: 0, pollLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0}, sendAvgMs: 0, sendMaxMs: 0, sendCount: 0, sendLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0}, authAvgMs: 0, authMaxMs: 0, authCount: 0}}
2288+handleStatsPeers = \authorization respond -> do
8791 authorized <- verifyMaintenanceAuth authorization
2289 authorized <- verifyMaintenanceAuth authorization
8792− if not authorized then yield (respond {ok: False {}})
2290+ if not authorized then yield (respond {peers: [], ok: False {}})
8794− logEvent "audit" "set_rate_limits" ("global=" ++ show globalRequest ++ " ip=" ++ show ipRate ++ " send=" ++ show sendRate)
2292+ t <- now
8795− atomic do
2293+ failures <- *forwardFailures
8796− set *rateOverrideGlobalRequest = max 0 globalRequest
2294+ fwds <- *forwards
8797− set *rateOverrideIpRate = max 0 ipRate
2295+ let peers = do
8798− set *rateOverrideSendRate = max 0 sendRate
2296+ f <- failures
8799− set *rateOverrideFederationRate = max 0 federationRate
2297+ let pending = count (do x <- fwds; where x.toServer == f.server; yield x)
8800− set *rateOverrideAuthGlobal = max 0 authGlobal
2298+ yield {server: f.server, failures: f.failures, lastFailedAt: f.failedAt, firstFailedAt: f.firstFailedAt, backoffMs: retryBackoff f.failures, retriable: shouldRetryServer f.server t failures, pendingForwards: pending, avgLatencyMs: 0, maxLatencyMs: 0, latencySamples: 0, gossipEventsPerMin: 0}
8801− set *rateOverrideRecvRate = max 0 recvRate
2299+ yield (respond {peers: peers, ok: True {}})
8802− set *rateOverrideChallengeRate = max 0 challengeRate
8803− set *rateOverridePairRate = max 0 pairRate
8804− set *rateOverrideLookupRate = max 0 lookupRate
8805− set *rateOverrideClientWriteRate = max 0 clientWriteRate
8806− logInfo ("rate-limits: updated — global=" ++ show globalRequest ++ " ip=" ++ show ipRate ++ " send=" ++ show sendRate ++ " federation=" ++ show federationRate ++ " auth=" ++ show authGlobal ++ " recv=" ++ show recvRate ++ " challenge=" ++ show challengeRate ++ " pair=" ++ show pairRate ++ " lookup=" ++ show lookupRate ++ " clientWrite=" ++ show clientWriteRate ++ " (0 = default)")
8807− yield (respond {ok: True {}})
8809−-- GET /maintenance/config: Return current effective operational parameters.
2301+handleStatsKey = \pubkey authorization respond -> do
8810−handleGetConfig = \authorization respond -> do
8811 authorized <- verifyMaintenanceAuth authorization
2302 authorized <- verifyMaintenanceAuth authorization
8812− if not authorized then yield (respond {ok: False {}, maxMessagesPerRecipient: 0, maxGossipHops: 0, pollTimeoutMs: 0, ackGracePeriod: 0})
2303+ if not authorized then yield (respond {messages: 0, presence: [], sessions: 0, forwards: 0, forwardDetails: [], activePolls: 0, ok: False {}})
8814− result <- atomic do
2305+ t <- now
8815− mpr <- effectiveMaxMessagesPerRecipient
2306+ msgs <- *messages
8816− mgh <- effectiveMaxGossipHops
2307+ pres <- *presence
8817− ptm <- effectivePollTimeoutMs
2308+ ses <- *sessions
8818− agp <- effectiveAckGracePeriod
2309+ fwds <- *forwards
8819− yield {maxMessagesPerRecipient: mpr, maxGossipHops: mgh, pollTimeoutMs: ptm, ackGracePeriod: agp}
2310+ aps <- *activePolls
8820− yield (respond {ok: True {}, maxMessagesPerRecipient: result.maxMessagesPerRecipient, maxGossipHops: result.maxGossipHops, pollTimeoutMs: result.pollTimeoutMs, ackGracePeriod: result.ackGracePeriod})
2311+ let m = count (do x <- msgs; where x.toKey == pubkey; yield x)
8821−
2312+ let p = do x <- pres; where x.pubkey == pubkey && x.expiresAt > t; yield {server: x.server, expiresAt: x.expiresAt}
8822−-- Extract request path for access logging (excludes poll to reduce log volume)
2313+ let s = count (do x <- ses; where x.pubkey == pubkey; yield x)
8823−requestPath = \req -> case req of
2314+ let myFwds = do x <- fwds; where x.toKey == pubkey; yield x
8824− ReqChallenge {} -> "POST /auth/challenge"
2315+ let f = count myFwds
8825− VerifyAuth {} -> "POST /auth/verify"
2316+ let fd = do x <- myFwds; yield {server: x.toServer, retries: x.retries, createdAt: x.createdAt}
8826− RevokeSession {} -> "POST /auth/revoke"
2317+ let a = count (do x <- aps; where x.pubkey == pubkey; yield x)
8827− Logout {} -> "POST /auth/logout"
2318+ yield (respond {messages: m, presence: p, sessions: s, forwards: f, forwardDetails: fd, activePolls: a, ok: True {}})
8828− Poll {} -> "" -- suppress: high volume, logged on slow path only
2319+
8829− SendMessage {} -> "POST /messages"
2320+handleTopRecipients = \limit authorization respond -> do
8830− MessageStatus {} -> "POST /messages/status"
2321+ authorized <- verifyMaintenanceAuth authorization
8831− AckMessages {} -> "POST /messages/ack"
2322+ if not authorized then yield (respond {recipients: [], ok: False {}, total: 0})
8832− SendBatch {} -> "POST /messages/batch"
2323+ else do
8833− ListMessages {} -> "POST /messages/list"
2324+ msgs <- *messages
8834− DeleteMessages {} -> "POST /messages/delete"
2325+ let counts = fold (\acc m ->
8835− CancelMessage {} -> "POST /messages/cancel"
2326+ if any acc (\a -> a.pubkey == m.toKey)
8836− CancelBatch {} -> "POST /messages/cancel-batch"
2327+ then do a <- acc; yield (if a.pubkey == m.toKey then {pubkey: a.pubkey, count: a.count + 1} else a)
8837− LookupPresence {} -> "GET /lookup"
2328+ else union acc [{pubkey: m.toKey, count: 1}]) [] msgs
8838− BatchLookupPresence {} -> "POST /lookup/batch"
2329+ let sorted = sortBy (\c -> 0 - c.count) counts
8839− RecvGossip {} -> "POST /federation/gossip"
2330+ let effLimit = if limit <= 0 then 20 else clamp 1 100 limit
8840− ForwardMessage {} -> "POST /federation/forward"
2331+ yield (respond {recipients: takeRelation effLimit sorted, ok: True {}, total: count counts})
8841− FederationAck {} -> "POST /federation/ack"
2332+
8842− FederationCancel {} -> "POST /federation/cancel"
2333+handleStatsForwards = \authorization respond -> do
8843− FederationBatchCancel {} -> "POST /federation/cancel-batch"
2334+ authorized <- verifyMaintenanceAuth authorization
8844− FederationBatchForward {} -> "POST /federation/forward-batch"
2335+ if not authorized then yield (respond {servers: [], ok: False {}, total: 0})
8845− FederationDeliveryReceipt {} -> "POST /federation/delivery-receipt"
2336+ else do
8846− VerifyToken {} -> "POST /federation/verify"
2337+ t <- now
8847− FederationPubkey {} -> "GET /federation/pubkey"
2338+ fwds <- *forwards
8848− Prune {} -> "POST /maintenance/prune"
2339+ let servers = collectPeers fwds (\f -> f.toServer)
8849− Drain {} -> "POST /maintenance/drain"
2340+ let result = do
8850− Shutdown {} -> "POST /maintenance/shutdown"
2341+ s <- servers
8851− Undrain {} -> "POST /maintenance/undrain"
2342+ let svFwds = do f <- fwds; where f.toServer == s; yield f
8852− BlockPeer {} -> "POST /maintenance/block"
2343+ let oldest = case minBy svFwds (\f -> f.createdAt) of Nothing {} -> 0; Just {value: x} -> t - x.createdAt
8853− UnblockPeer {} -> "POST /maintenance/unblock"
2344+ let retries = fold (\acc f -> acc + f.retries) 0 svFwds
8854− ListBlocked {} -> "GET /maintenance/blocked"
2345+ yield {server: s, count: count svFwds, oldestAge: oldest, totalRetries: retries}
8855− PingPeer {} -> "POST /maintenance/ping"
2346+ yield (respond {servers: result, ok: True {}, total: count fwds})
8856− AdminListSessions {} -> "GET /maintenance/sessions"
2347+
8857− AdminRevokeSessions {} -> "POST /maintenance/sessions/revoke-all"
2348+handleStatsRates = \authorization respond -> do
8858− AdminListAllSessions {} -> "POST /maintenance/sessions/list"
2349+ authorized <- verifyMaintenanceAuth authorization
8859− AdminPurgeMessages {} -> "POST /maintenance/messages/purge"
2350+ if not authorized then yield (respond {ok: False {}, scalePct: 0, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0})
8860− AdminRevokeIp {} -> "POST /maintenance/sessions/revoke-ip"
2351+ else yield (respond {ok: True {}, scalePct: 100, globalRequest: maxGlobalRequestRate, ipRate: maxIpRatePerIp, sendRate: maxSendRatePerKey, federationRate: maxFederationRatePerServer, authGlobal: maxAuthGlobalRate, recvRate: maxRecvRatePerKey, challengeRate: maxChallengeRatePerKey, pairRate: maxPairRatePerPair, lookupRate: maxLookupRatePerKey, clientWriteRate: maxClientWriteRatePerKey})
8861− GetRateLimits {} -> "GET /maintenance/rate-limits"
2352+
8862− SetRateLimits {} -> "POST /maintenance/rate-limits"
2353+handleMetrics = \authorization respond -> do
8863− FlushNonces {} -> "POST /maintenance/nonces/flush"
2354+ t <- now
8864− AllowPeer {} -> "POST /maintenance/allow"
2355+ msgs <- *messages
8865− UnallowPeer {} -> "POST /maintenance/unallow"
2356+ ses <- *sessions
8866− ListAllowed {} -> "GET /maintenance/allowed"
2357+ pres <- *presence
8867− Reconcile {} -> "POST /maintenance/reconcile"
2358+ fwds <- *forwards
8868− RotateSecret {} -> "POST /maintenance/rotate-secret"
2359+ aps <- *activePolls
8869− GetConfig {} -> "GET /maintenance/config"
2360+ sa <- *startedAt
8870− Health {} -> "GET /health"
2361+ dp <- *drainPhase
8871− Stats {} -> "GET /stats"
2362+ let metrics = "skrepka_messages_total " ++ show (count msgs) ++ "\nskrepka_sessions_total " ++ show (count ses) ++ "\nskrepka_presence_total " ++ show (count pres) ++ "\nskrepka_forwards_total " ++ show (count fwds) ++ "\nskrepka_active_polls " ++ show (count aps) ++ "\nskrepka_uptime_seconds " ++ show ((t - sa) / 1000) ++ "\nskrepka_draining " ++ (if dp > 0 then "1" else "0") ++ "\n"
8872− StatsPeers {} -> "GET /stats/peers"
2363+ yield (respond {metrics: metrics, ok: True {}})
8873− StatsKey {} -> "GET /stats/key"
2364+
8874− TopRecipients {} -> "POST /stats/top-recipients"
2365+-- ============================================
8875− StatsForwards {} -> "GET /stats/forwards"
2366+-- Dispatch
8876− StatsRates {} -> "GET /stats/rates"
2367+-- ============================================
8877− Metrics {} -> "GET /metrics"
2368+
8878− Ready {} -> "GET /ready"
2369+serve = \req -> case req of
8880−-- Extract client IP for access logging (empty for federation/maintenance/stats routes).
8881−-- Client-facing routes extract clientIp; all others use catch-all to avoid enumerating
8882−-- every federation/maintenance/stats route (reduces maintenance burden on new routes).
8883−requestClientIp = \req -> case req of
8884− ReqChallenge {clientIp} -> clientIp
8885− VerifyAuth {clientIp} -> clientIp
8886− RevokeSession {clientIp} -> clientIp
8887− Logout {clientIp} -> clientIp
8888− Poll {clientIp} -> clientIp
8889− SendMessage {clientIp} -> clientIp
8890− MessageStatus {clientIp} -> clientIp
8891− AckMessages {clientIp} -> clientIp
8892− SendBatch {clientIp} -> clientIp
8893− ListMessages {clientIp} -> clientIp
8894− DeleteMessages {clientIp} -> clientIp
8895− CancelMessage {clientIp} -> clientIp
8896− CancelBatch {clientIp} -> clientIp
8897− LookupPresence {clientIp} -> clientIp
8898− BatchLookupPresence {clientIp} -> clientIp
8899− VerifyToken {clientIp} -> clientIp
8902−-- Slow request threshold for access logging (ms)
8903−slowRequestThreshold : Int<Ms>
8904−slowRequestThreshold = 1000
8906−serveInner = \req -> case req of
8907 ReqChallenge {pubkey, clientIp, respond} -> handleChallenge pubkey clientIp respond
2370 ReqChallenge {pubkey, clientIp, respond} -> handleChallenge pubkey clientIp respond
8908 VerifyAuth {pubkey, challenge, signature, revokeOthers, clientIp, respond} -> handleVerifyAuth pubkey challenge signature revokeOthers clientIp respond
2371 VerifyAuth {pubkey, challenge, signature, revokeOthers, clientIp, respond} -> handleVerifyAuth pubkey challenge signature revokeOthers clientIp respond
8909 RevokeSession {targetToken, authorization, clientIp, respond} -> handleRevoke targetToken authorization clientIp respond
2372 RevokeSession {targetToken, authorization, clientIp, respond} -> handleRevoke targetToken authorization clientIp respond
@@ -8919,20 +2382,13 @@ serveInner = \req -> case req of
8919 CancelBatch {cancels, authorization, clientIp, respond} -> handleCancelBatch cancels authorization clientIp respond
2382 CancelBatch {cancels, authorization, clientIp, respond} -> handleCancelBatch cancels authorization clientIp respond
8920 LookupPresence {pubkey, authorization, clientIp, respond} -> handleLookupPresence pubkey authorization clientIp respond
2383 LookupPresence {pubkey, authorization, clientIp, respond} -> handleLookupPresence pubkey authorization clientIp respond
8921 BatchLookupPresence {pubkeys, authorization, clientIp, respond} -> handleBatchLookupPresence pubkeys authorization clientIp respond
2384 BatchLookupPresence {pubkeys, authorization, clientIp, respond} -> handleBatchLookupPresence pubkeys authorization clientIp respond
8922− RecvGossip {events, hopsRemaining, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
2385+ RecvGossip {events, hopsRemaining, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleRecvGossip events hopsRemaining fromServer requestTimestamp correlationId authorization respond
8923− warnOldProtocol fromServer protocolVersion; handleRecvGossip events hopsRemaining fromServer requestTimestamp correlationId authorization respond
2386+ ForwardMessage {toKey, encryptedBlob, timestamp, originServer, messageId, fromServer, requestTimestamp, correlationId, expiresAt, priority, protocolVersion, authorization, respond} -> handleForwardMessage toKey encryptedBlob timestamp originServer messageId fromServer requestTimestamp correlationId expiresAt priority authorization respond
8924− ForwardMessage {toKey, encryptedBlob, timestamp, originServer, messageId, fromServer, requestTimestamp, correlationId, expiresAt, priority, protocolVersion, authorization, respond} -> do
2387+ FederationAck {messageIds, originServer, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationAck messageIds originServer fromServer requestTimestamp correlationId authorization respond
8925− warnOldProtocol fromServer protocolVersion; handleForwardMessage toKey encryptedBlob timestamp originServer messageId fromServer requestTimestamp correlationId expiresAt priority authorization respond
2388+ FederationCancel {messageId, toKey, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationCancel messageId toKey fromServer requestTimestamp correlationId authorization respond
8926− FederationAck {messageIds, originServer, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
2389+ FederationBatchCancel {cancels, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationBatchCancel cancels fromServer requestTimestamp correlationId authorization respond
8927− warnOldProtocol fromServer protocolVersion; handleFederationAck messageIds originServer fromServer requestTimestamp correlationId authorization respond
2390+ FederationBatchForward {forwards, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationBatchForward forwards fromServer requestTimestamp correlationId authorization respond
8928− FederationCancel {messageId, toKey, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
2391+ FederationDeliveryReceipt {messageIds, toKeys, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationDeliveryReceipt messageIds toKeys fromServer requestTimestamp correlationId authorization respond
8929− warnOldProtocol fromServer protocolVersion; handleFederationCancel messageId toKey fromServer requestTimestamp correlationId authorization respond
8930− FederationBatchCancel {cancels, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
8931− warnOldProtocol fromServer protocolVersion; handleFederationBatchCancel cancels fromServer requestTimestamp correlationId authorization respond
8932− FederationBatchForward {forwards, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
8933− warnOldProtocol fromServer protocolVersion; handleFederationBatchForward forwards fromServer requestTimestamp correlationId authorization respond
8934− FederationDeliveryReceipt {messageIds, toKeys, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
8935− warnOldProtocol fromServer protocolVersion; handleFederationDeliveryReceipt messageIds toKeys fromServer requestTimestamp correlationId authorization respond
8936 VerifyToken {token, scope, clientIp, respond} -> handleVerifyToken token scope clientIp respond
2392 VerifyToken {token, scope, clientIp, respond} -> handleVerifyToken token scope clientIp respond
8937 FederationPubkey {respond} -> handleFederationPubkey respond
2393 FederationPubkey {respond} -> handleFederationPubkey respond
8938 Prune {authorization, respond} -> handlePrune authorization respond
2394 Prune {authorization, respond} -> handlePrune authorization respond
@@ -8967,557 +2423,46 @@ serveInner = \req -> case req of
8967 Metrics {authorization, respond} -> handleMetrics authorization respond
2423 Metrics {authorization, respond} -> handleMetrics authorization respond
8968 Ready {respond} -> handleReady respond
2424 Ready {respond} -> handleReady respond
8970−-- Backpressure: check if the server is overloaded (too many concurrent requests).
8971−-- Health, Ready, and Maintenance endpoints are exempt so operators can always monitor
8972−-- and control the server even under extreme load.
8973−isOverloadExempt = \req -> case req of
8974− Health {} -> True {}
8975− Ready {} -> True {}
8976− Prune {} -> True {}
8977− Drain {} -> True {}
8978− Shutdown {} -> True {}
8979− Undrain {} -> True {}
8980− Reconcile {} -> True {}
8981− Stats {} -> True {}
8982− StatsPeers {} -> True {}
8983− StatsKey {} -> True {}
8984− StatsRates {} -> True {}
8985− Metrics {} -> True {}
8988−-- Reject overloaded requests with appropriate empty/error responses per route type.
8989−-- Each response matches the handler's return shape with zeroed/empty fields.
8990−-- NOTE: This exhaustive case match is required by Knot's type system — each route has a
8991−-- different response shape. If Knot adds a default response constructor or row-polymorphic
8992−-- error responses, this can be collapsed to a single default branch.
8993−serveOverloaded = \req -> case req of
8995− ReqChallenge {respond} -> respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 1000, error: "overloaded"}
8996− VerifyAuth {respond} -> respond {token: "", expiresAt: 0, error: "overloaded"}
8997− RevokeSession {respond} -> respond {ok: False {}, authorized: False {}}
8998− Logout {respond} -> respond {ok: False {}, authorized: False {}}
9000− Poll {respond} -> respond {events: [], cursor: 0, authorized: False {}, rateLimited: True {}, draining: False {}, generation: 0, presenceUpdates: [], heartbeat: False {}, retryAfterMs: 1000, cursorReset: False {}, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []}
9001− SendMessage {respond} -> respond {status: MsRejected {}, messageId: "", retryAfterMs: 1000, error: "overloaded", loadPct: 0}
9002− MessageStatus {respond} -> respond {status: "", authorized: False {}}
9003− AckMessages {respond} -> respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "overloaded"}
9004− SendBatch {respond} -> respond {results: [], authorized: False {}, retryAfterMs: 1000}
9005− ListMessages {respond} -> respond {messages: [], authorized: False {}, count: 0, error: "overloaded"}
9006− DeleteMessages {respond} -> respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "overloaded"}
9007− CancelMessage {respond} -> respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "overloaded"}
9008− CancelBatch {respond} -> respond {results: [], authorized: False {}, error: "overloaded"}
9009− LookupPresence {respond} -> respond {server: "", authorized: False {}, error: "overloaded"}
9010− BatchLookupPresence {respond} -> respond {results: [], authorized: False {}, error: "overloaded"}
9011− -- Federation routes
9012− RecvGossip {respond} -> respond {ok: False {}, error: "overloaded", retryAfterMs: 1000}
9013− ForwardMessage {respond} -> respond {ok: False {}, error: "overloaded", retryAfterMs: 1000}
9014− FederationAck {respond} -> respond {ok: False {}, error: "overloaded", ackedCount: 0, results: [], retryAfterMs: 1000}
9015− FederationCancel {respond} -> respond {ok: False {}, error: "overloaded", cancelled: False {}, retryAfterMs: 1000}
9016− FederationBatchCancel {respond} -> respond {ok: False {}, error: "overloaded", results: [], retryAfterMs: 1000}
9017− FederationBatchForward {respond} -> respond {ok: False {}, error: "overloaded", results: [], retryAfterMs: 1000}
9018− FederationDeliveryReceipt {respond} -> respond {ok: False {}, error: "overloaded", receivedCount: 0, retryAfterMs: 1000}
9019− VerifyToken {respond} -> respond {ok: False {}}
9020− FederationPubkey {respond} -> respond {pubkey: "", ok: False {}}
9021− -- Stats/admin routes (exempt routes handled by isOverloadExempt; these are fallbacks)
9022− TopRecipients {respond} -> respond {recipients: [], ok: False {}, total: 0}
9023− StatsForwards {respond} -> respond {servers: [], ok: False {}, total: 0}
9024− StatsRates {respond} -> respond {ok: False {}, scalePct: 0, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0}
9025− BlockPeer {respond} -> respond {ok: False {}, blocked: 0}
9026− UnblockPeer {respond} -> respond {ok: False {}, unblocked: False {}}
9027− ListBlocked {respond} -> respond {peers: [], ok: False {}}
9028− PingPeer {respond} -> respond {ok: False {}, latencyMs: 0, error: "overloaded"}
9029− AdminListSessions {respond} -> respond {sessions: [], count: 0, ok: False {}}
9030− AdminRevokeSessions {respond} -> respond {ok: False {}, revokedCount: 0}
9031− AdminPurgeMessages {respond} -> respond {ok: False {}, purgedCount: 0}
9032− AdminRevokeIp {respond} -> respond {ok: False {}, revokedCount: 0, affectedKeys: 0}
9033− AdminListAllSessions {respond} -> respond {sessions: [], ok: False {}, total: 0}
9034− GetRateLimits {respond} -> respond {ok: False {}, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0}
9035− SetRateLimits {respond} -> respond {ok: False {}}
9036− FlushNonces {respond} -> respond {ok: False {}, flushedCount: 0}
9037− AllowPeer {respond} -> respond {ok: False {}, allowed: 0}
9038− UnallowPeer {respond} -> respond {ok: False {}, removed: False {}}
9039− ListAllowed {respond} -> respond {peers: [], ok: False {}}
9040− RotateSecret {respond} -> respond {ok: False {}, error: "overloaded"}
9041− GetConfig {respond} -> respond {ok: False {}, maxMessagesPerRecipient: 0, maxGossipHops: 0, pollTimeoutMs: 0, ackGracePeriod: 0}
9042− Metrics {respond} -> respond {metrics: "", ok: False {}}
9043− -- Exempt routes handled by isOverloadExempt; this branch is unreachable
9046−-- Access-logged request handler: wraps serveInner with timing and correlation ID.
9047−-- Logs all non-poll requests with a 6-hex-char request ID for log correlation.
9048−-- Polls are only logged when slow (> slowRequestThreshold) to avoid overwhelming
9049−-- logs with high-frequency long-poll traffic.
9050−-- Backpressure: rejects non-exempt requests when activeRequests >= maxActiveRequests.
9053− reqId <- genTokenN 1
9054− -- Backpressure check: reject early if overloaded (exempt: health, ready, maintenance)
9055− overloaded <- if maxActiveRequests <= 0 || isOverloadExempt req then yield (False {})
9057− ar <- *activeRequests
9058− yield (ar >= maxActiveRequests)
9059− if overloaded then do
9060− logEvent "warn" "overloaded" (requestPath req)
9061− serveOverloaded req
9064− ar <- *activeRequests
9066− set *activeRequests = newAr
9067− peak <- *peakActiveRequests
9068− when (newAr > peak) (set *peakActiveRequests = newAr)
9072− ar <- *activeRequests
9073− set *activeRequests = max 0 (ar - 1)
9074− set *lastRequestCompletedAt = endTime
9075− let latency = endTime - startTime
9076− -- Record client operation latency for /stats monitoring (windowed avg/max).
9077− -- Only tracks poll and send — the two highest-volume client operations.
9079− Poll {} -> atomic do
9080− total <- *clientPollLatencyTotal
9081− cnt <- *clientPollLatencyCount
9082− mx <- *clientPollLatencyMax
9083− set *clientPollLatencyTotal = total + latency
9084− set *clientPollLatencyCount = cnt + 1
9085− set *clientPollLatencyMax = if latency > mx then latency else mx
9086− -- Histogram bucket increment
9087− if latency < clientLatencyT1 then do b <- *clientPollLatencyBucket0; set *clientPollLatencyBucket0 = b + 1
9088− else if latency < clientLatencyT2 then do b <- *clientPollLatencyBucket1; set *clientPollLatencyBucket1 = b + 1
9089− else if latency < clientLatencyT3 then do b <- *clientPollLatencyBucket2; set *clientPollLatencyBucket2 = b + 1
9090− else do b <- *clientPollLatencyBucket3; set *clientPollLatencyBucket3 = b + 1
9091− SendMessage {} -> atomic do
9092− total <- *clientSendLatencyTotal
9093− cnt <- *clientSendLatencyCount
9094− mx <- *clientSendLatencyMax
9095− set *clientSendLatencyTotal = total + latency
9096− set *clientSendLatencyCount = cnt + 1
9097− set *clientSendLatencyMax = if latency > mx then latency else mx
9098− if latency < clientLatencyT1 then do b <- *clientSendLatencyBucket0; set *clientSendLatencyBucket0 = b + 1
9099− else if latency < clientLatencyT2 then do b <- *clientSendLatencyBucket1; set *clientSendLatencyBucket1 = b + 1
9100− else if latency < clientLatencyT3 then do b <- *clientSendLatencyBucket2; set *clientSendLatencyBucket2 = b + 1
9101− else do b <- *clientSendLatencyBucket3; set *clientSendLatencyBucket3 = b + 1
9102− SendBatch {} -> atomic do
9103− total <- *clientSendLatencyTotal
9104− cnt <- *clientSendLatencyCount
9105− mx <- *clientSendLatencyMax
9106− set *clientSendLatencyTotal = total + latency
9107− set *clientSendLatencyCount = cnt + 1
9108− set *clientSendLatencyMax = if latency > mx then latency else mx
9109− if latency < clientLatencyT1 then do b <- *clientSendLatencyBucket0; set *clientSendLatencyBucket0 = b + 1
9110− else if latency < clientLatencyT2 then do b <- *clientSendLatencyBucket1; set *clientSendLatencyBucket1 = b + 1
9111− else if latency < clientLatencyT3 then do b <- *clientSendLatencyBucket2; set *clientSendLatencyBucket2 = b + 1
9112− else do b <- *clientSendLatencyBucket3; set *clientSendLatencyBucket3 = b + 1
9113− ReqChallenge {} -> atomic do
9114− total <- *clientAuthLatencyTotal
9115− cnt <- *clientAuthLatencyCount
9116− mx <- *clientAuthLatencyMax
9117− set *clientAuthLatencyTotal = total + latency
9118− set *clientAuthLatencyCount = cnt + 1
9119− set *clientAuthLatencyMax = if latency > mx then latency else mx
9120− VerifyAuth {} -> atomic do
9121− total <- *clientAuthLatencyTotal
9122− cnt <- *clientAuthLatencyCount
9123− mx <- *clientAuthLatencyMax
9124− set *clientAuthLatencyTotal = total + latency
9125− set *clientAuthLatencyCount = cnt + 1
9126− set *clientAuthLatencyMax = if latency > mx then latency else mx
9127− RevokeSession {} -> atomic do
9128− total <- *clientAuthLatencyTotal
9129− cnt <- *clientAuthLatencyCount
9130− mx <- *clientAuthLatencyMax
9131− set *clientAuthLatencyTotal = total + latency
9132− set *clientAuthLatencyCount = cnt + 1
9133− set *clientAuthLatencyMax = if latency > mx then latency else mx
9134− Logout {} -> atomic do
9135− total <- *clientAuthLatencyTotal
9136− cnt <- *clientAuthLatencyCount
9137− mx <- *clientAuthLatencyMax
9138− set *clientAuthLatencyTotal = total + latency
9139− set *clientAuthLatencyCount = cnt + 1
9140− set *clientAuthLatencyMax = if latency > mx then latency else mx
9142− let path = requestPath req
9143− let ip = requestClientIp req
9144− -- Structured access log: machine-parseable JSON for monitoring pipelines.
9145− -- Polls only logged when slow (> slowRequestThreshold) to avoid log volume from long-poll traffic.
9148− logInfo ("{\"event\":\"access\",\"req\":\"" ++ escapeJsonString reqId ++ "\",\"path\":\"" ++ escapeJsonString path ++ "\",\"ms\":" ++ show latency ++ (if ip != "" then ",\"ip\":\"" ++ escapeJsonString ip ++ "\"" else "") ++ "}")
9149− when (latency > slowRequestThreshold)
9150− (logEvent "warn" "slow_request" (path ++ " " ++ show latency ++ "ms"))
9151− else when (latency > slowRequestThreshold) (do
9152− logWarn ("{\"event\":\"access\",\"req\":\"" ++ escapeJsonString reqId ++ "\",\"path\":\"poll\",\"ms\":" ++ show latency ++ (if ip != "" then ",\"ip\":\"" ++ escapeJsonString ip ++ "\"" else "") ++ ",\"slow\":true}")
9153− logEvent "warn" "slow_request" ("poll " ++ show latency ++ "ms"))
9155-- ============================================
2426-- ============================================
9156−-- Entry Point
2427+-- Background loops
9157-- ============================================
2428-- ============================================
9159−-- Background loop: periodically prunes expired state and retries pending federation ops.
9160−-- Jitter prevents thundering herd when multiple servers restart simultaneously.
9161−-- NOTE: This function (and all background loops below) recurse via tail calls.
9162−-- Knot compiles tail calls to loops, so stack growth is bounded. If Knot's tail-call
9163−-- optimization is ever disabled, these loops will overflow the stack over time.
9164−-- The backgroundWatchdog can restart backgroundPrune and pollHeartbeat if they die,
9165−-- but cannot restart itself. A TCO failure in any loop would
9166−-- eventually surface as a health check failure (pruneHealthy/heartbeatHealthy/watchdogHealthy).
9167−-- TODO: If Knot adds an iterative construct (e.g., loop/while), migrate background loops
9168−-- to avoid the TCO dependency entirely.
9169backgroundPrune = do
2430backgroundPrune = do
9170− jitter <- randomInt 5000
2431+ sleep backgroundPruneInterval
9171− sleep (backgroundPruneInterval + jitter)
9172 dp <- *drainPhase
2432 dp <- *drainPhase
9173− -- Check shutdown: if drain completed and shutdown requested, exit the loop
2433+ if dp >= 2 then do
9174− shutdownReq <- *shutdownRequested
9175− dca <- *drainCompletedAt
9176− if shutdownReq && dca > 0 then logInfo "backgroundPrune: shutdown complete, exiting loop"
9177− else if dp >= 2 then do
9178 sleep backgroundPruneInterval
2434 sleep backgroundPruneInterval
9179 backgroundPrune
2435 backgroundPrune
9182− -- Detect clock jumps in both directions:
9183− -- Backward: seqCounter ahead of now (clock corrected back after forward jump)
9184− -- Forward: now jumped far ahead of last prune (VM suspend, NTP step)
9185− -- Forward jumps cause inflated receivedAt timestamps; clients with those cursors
9186− -- miss new messages until real time catches up. Log a warning so operators can
9187− -- advise affected clients to reset their cursor (generation change handles this).
9190− lp <- *lastPrunedAt
9191− when (sc > t + clockSkewTolerance) (do
9192− logWarn ("clock jump detected — seqCounter " ++ show (sc - t) ++ "ms ahead of now, resetting")
9193− set *seqCounter = t
9194− -- Bump server generation so clients reset their cursors (avoids stuck polls
9195− -- from messages with inflated receivedAt timestamps during the forward jump)
9196− set *serverGeneration = t)
9197− -- Forward jump detection: now is far ahead of last prune (more than 10x interval).
9198− -- Bump server generation so clients reset their cursors: messages stored during the
9199− -- jump window have inflated receivedAt timestamps that would appear as "already seen"
9200− -- to clients with pre-jump cursors. Without a generation bump, these messages are
9201− -- silently skipped until real time catches up to the inflated timestamps.
9202− when (lp > 0 && t - lp > backgroundPruneInterval * 10) (do
9203− logWarn ("clock forward jump detected — " ++ show (t - lp) ++ "ms since last prune (expected ~" ++ show backgroundPruneInterval ++ "ms), bumping server generation and resetting seqCounter")
9204− set *serverGeneration = t
9205− -- Also reset seqCounter: messages stored during the forward jump window have
9206− -- inflated receivedAt timestamps from nextSeqTs using the jumped seqCounter.
9207− -- Without this reset, new messages would continue getting inflated timestamps
9208− -- until seqCounter is organically surpassed by real time.
9209− set *seqCounter = t)
9210− -- Heartbeat watchdog: bump pollWakeup if heartbeat loop appears dead
9212− lastHb <- *lastHeartbeatAt
9213− when (t - sa > healthHeartbeatMaxAge && t - lastHb > healthHeartbeatMaxAge) (do
9214− logWarn "backgroundPrune: heartbeat appears dead, bumping pollWakeup"
9216− set *pollWakeup = t
9217− set *lastHeartbeatAt = t)
9218− status <- atomic do
9219− running <- *pruneRunning
9220− -- Dynamic stuck threshold: 3x the last known cycle duration, with a floor of 3x prune interval
9221− -- and ceiling of 10x prune interval. Adapts to heavy cycles (reconciliation, large nonce pruning)
9222− -- without the fixed 5x being too tight for fast cycles or too loose for slow ones.
9223− lastDuration <- *lastPruneDuration
9224− let dynamicThreshold = if lastDuration > 0 then clamp (backgroundPruneInterval * 3) (backgroundPruneInterval * 10) (lastDuration * 3) else backgroundPruneInterval * 5
9225− if running > 0 && t - running < dynamicThreshold
9226− then yield {canRun: False {}, recovered: False {}, gen: 0, stuckSince: 0}
9228− set *pruneRunning = t
9229− gen <- *pruneGeneration
9230− let newGen = gen + 1
9231− set *pruneGeneration = newGen
9233− set *pruneCount = pc + 1
9234− yield {canRun: True {}, recovered: running > 0, gen: newGen, stuckSince: running}
9235− when status.recovered (do
9236− logWarn ("backgroundPrune: previous cycle stuck for " ++ show (t - status.stuckSince) ++ "ms, forcing recovery")
9237− -- Reset fork counter: the stuck fork leaked its slot, so reclaim it to prevent permanent lockout
9238− atomic do set *activePruneForks = 0)
9241− -- Guard against unbounded concurrent prune forks from repeated stuck recovery
9242− forks <- *activePruneForks
9244− then logWarn "backgroundPrune: skipping (max concurrent prune forks reached)"
9247− af <- *activePruneForks
9248− set *activePruneForks = af + 1
9250− -- Pre-flight generation check: if a newer prune cycle was scheduled between
9251− -- our fork and when the runtime schedules this task, skip to avoid overlapping
9252− -- prune cycles that could double-count counter decrements.
9253− preFlightGen <- *pruneGeneration
9254− if preFlightGen != status.gen
9256− logWarn "backgroundPrune: stale fork detected (generation changed), skipping"
9258− af <- *activePruneForks
9259− set *activePruneForks = max 0 (af - 1)
9262− -- Only clear running flag if this is still the latest generation
9263− -- (prevents a stuck old fork from clearing the flag after a recovery cycle started)
9266− currentGen <- *pruneGeneration
9267− when (currentGen == status.gen) (do
9268− set *pruneRunning = 0
9269− set *lastPruneDuration = endT - t)
9270− af <- *activePruneForks
9271− set *activePruneForks = max 0 (af - 1))
9272− else logWarn "backgroundPrune: skipping (previous cycle still running)"
9275−-- Background loop: periodically bumps pollWakeup to unblock long-polls that have been
9276−-- waiting too long (heartbeat). Ensures polls return within pollTimeoutMs even if no messages arrive.
9277−-- Adaptive: under high load (>80% capacity), the heartbeat fires more frequently
9278−-- (down to 5s at peak) to release poll slots faster and reduce connection hold time.
9279−-- Normal load uses the full pollTimeoutMs (~25s).
9281− -- Adaptive poll timeout: scale heartbeat interval based on server load.
9282− -- adaptiveRateScale returns 10-100 (percentage). At 100% (normal): full pollTimeoutMs.
9283− -- At 10% (peak load): max(5000, pollTimeoutMs * 10 / 100) = 5000ms.
9284− basePollTimeout <- effectivePollTimeoutMs
9286− tmc <- *totalMessageCount
9287− sc <- *totalSessionCount
9288− pc <- *totalPresenceCount
9289− yield (adaptiveRateScale tmc sc pc)
9290− let effectiveTimeout = max 5000 (basePollTimeout * scale / 100)
9291− jitter <- randomInt 2000
9292− sleep (effectiveTimeout + jitter)
9294− shutdownReq <- *shutdownRequested
9295− dca <- *drainCompletedAt
9296− if shutdownReq && dca > 0 then logInfo "pollHeartbeat: shutdown complete, exiting loop"
9297− else if dp >= 2 then do
9299− atomic do set *pollWakeup = t
9300− -- Don't exit; sleep and retry so undrain can resume the loop
9301− sleep pollTimeoutMs
9304 t <- now
2437 t <- now
9305 atomic do
2438 atomic do
9306− set *pollWakeup = t
2439+ pc <- *pruneCount
9307− set *lastHeartbeatAt = t
2440+ set *pruneCount = pc + 1
9308− hc <- *heartbeatCount
2441+ pruneAndRetry t
9309− set *heartbeatCount = hc + 1
2442+ backgroundPrune
9311−
2444+pollHeartbeat = do
9312−-- Background watchdog: monitors prune and heartbeat loops, restarts if they appear dead.
2445+ sleep pollTimeoutMs
9313−-- Knot lacks try/catch, so panicked loops can't self-recover. This watchdog detects
9314−-- liveness by checking counter freshness and forks a new loop instance as needed.
9315−backgroundWatchdog = do
9316− sleep (backgroundPruneInterval * 5)
9318− atomic do set *lastWatchdogAt = t
9320− let warmup = t - sa < backgroundPruneInterval * 10
9321− if warmup then backgroundWatchdog
9323− -- Check prune loop health
9324− lastPrune <- *lastPrunedAt
9325− when (t - lastPrune > healthPruneMaxAge * 3) (do
9326− logError "watchdog: prune loop appears dead, restarting"
9327− atomic do set *pruneRunning = 0
9328− fork backgroundPrune)
9329− -- Check heartbeat loop health
9330− lastHb <- *lastHeartbeatAt
9331− when (t - lastHb > healthHeartbeatMaxAge * 3) (do
9332− logError "watchdog: heartbeat loop appears dead, restarting"
9333− fork pollHeartbeat)
9334− -- Recover leaked federation slots: if prune is alive but in-flight counters
9335− -- are stuck, force-reconcile. This catches edge cases where panicked fetches
9336− -- leaked slots but prune's stale threshold hasn't reclaimed them yet.
9337− fedActive <- *federationActiveConnections
9338− when (fedActive > maxGlobalFederationConcurrency) (do
9339− logWarn ("watchdog: federation connection counter (" ++ show fedActive ++ ") exceeds max (" ++ show maxGlobalFederationConcurrency ++ "), reconciling")
9341− inFlight <- *federationInFlight
9342− set *federationActiveConnections = fold (\acc r -> acc + r.count) 0 inFlight)
9343− -- Log hung federation connections even below the max threshold (early warning)
9344− inFlight <- *federationInFlight
9345− let hungSlots = do r <- inFlight; where r.count > 0 && r.firstStartedAt > 0 && t - r.firstStartedAt >= federationFetchTimeoutMs; yield r
9346− when (count hungSlots > 0) (do
9347− logEvent "warn" "watchdog_hung_federation" (show (count hungSlots) ++ " servers with hung connections")
9348− logStaleInFlight hungSlots t)
9351−-- Meta-watchdog: monitors the watchdog itself. The backgroundWatchdog can restart prune
9352−-- and heartbeat loops, but if the watchdog itself panics (e.g., a bug in hung-slot detection),
9353−-- no loop monitors it. This ultra-simple loop just checks lastWatchdogAt freshness and
9354−-- restarts backgroundWatchdog if stale. Runs infrequently (10x watchdog interval) to minimize cost.
9355−-- Cannot restart itself — a panic here surfaces as healthWatchdogMaxAge failure in /health.
9356−backgroundMetaWatchdog = do
9357− sleep (backgroundPruneInterval * 50)
9358 t <- now
2446 t <- now
9359− sa <- *startedAt
2447+ atomic do
9360− let warmup = t - sa < backgroundPruneInterval * 60
2448+ set *pollWakeup = t
9361− if warmup then backgroundMetaWatchdog
2449+ set *lastHeartbeatAt = t
9362− else do
2450+ hc <- *heartbeatCount
9363− lastWd <- *lastWatchdogAt
2451+ set *heartbeatCount = hc + 1
9364− when (lastWd > 0 && t - lastWd > healthWatchdogMaxAge * 3) (do
2452+ pollHeartbeat
9365− logError "meta-watchdog: watchdog loop appears dead, restarting"
2453+
9366− fork backgroundWatchdog)
2454+-- ============================================
9367− backgroundMetaWatchdog
2455+-- Entry Point
9368−
2456+-- ============================================
9369−-- Startup connectivity probe: two-phase check for each peer.
9370−-- Phase 1: unauthenticated probe tests TCP/TLS/HTTP connectivity.
9371−-- Phase 2: authenticated probe tests the verify callback round-trip — the critical
9372−-- federation auth path. Catches misconfigured reverse proxies that pass HTTP but block
9373−-- the /federation/verify callback, which would cause all federation requests to fail.
9374−-- Probes up to 10 peers sequentially (not forked) to avoid overwhelming the network.
9375−startupProbePeers = do
9376− atomic do set *startupProbeActive = True {}
9377− knownPeers <- *knownPeerServers
9378− startupProbeNext knownPeers 0
9379− atomic do set *startupProbeActive = False {}
9381−startupProbeNext = \peers probed ->
9382− if probed >= 10 then logInfo ("startup: probed " ++ show probed ++ " peers")
9383− else case headOf peers of
9384− Nothing {} -> logInfo ("startup: probed " ++ show probed ++ " peers")
9385− Just {value: server} -> do
9386− let rest = do p <- peers; where p != server; yield p
9388− -- Phase 1: unauthenticated probe (TCP/TLS/HTTP connectivity)
9389− result <- fetchFederation server (RecvGossip {
9391− events: [], hopsRemaining: 1, fromServer: serverHostN,
9392− requestTimestamp: startTime, correlationId: "", protocolVersion: federationProtocolVersion})
9394− let latency = endTime - startTime
9396− Err e -> logWarn ("startup: peer " ++ server ++ " unreachable (" ++ show e ++ ") — check DNS/firewall/TLS")
9398− logInfo ("startup: peer " ++ server ++ " reachable (" ++ show latency ++ "ms)")
9399− -- Phase 2: authenticated probe (verify callback round-trip).
9400− -- Sends an empty gossip with a real auth token. The peer will call back to
9401− -- /federation/verify on this server to confirm the token, testing the full
9402− -- federation auth path in both directions.
9404− auth <- generateFederationAuth "gossip" authStart
9405− authResult <- fetchFederation server (RecvGossip {
9406− authorization: auth,
9407− events: [], hopsRemaining: 1, fromServer: serverHostN,
9408− requestTimestamp: authStart, correlationId: "", protocolVersion: federationProtocolVersion})
9410− let authLatency = authEnd - authStart
9412− Err e -> logWarn ("startup: peer " ++ server ++ " verify callback failed (" ++ show e ++ ") — check reverse proxy allows /federation/verify")
9414− then logInfo ("startup: peer " ++ server ++ " verify callback OK (" ++ show authLatency ++ "ms)")
9415− else logWarn ("startup: peer " ++ server ++ " verify callback rejected: " ++ ar.error ++ " — check /federation/verify is reachable from peer")
9416− startupProbeNext rest (probed + 1)
9418main = do
2458main = do
9419− let configOk = listenPort > 0 && maxMessages > 0 && maxMessagesPerRecipient > 0 && maxPresenceEntries > 0
2459+ t <- now
9420− && maxSessions > 0 && maxChallenges > 0 && backgroundPruneInterval > 0
2460+ genJitter <- randomInt 1000000
9421− && pollTimeoutMs > 0 && challengeExpiry > 0 && sessionExpiry > 0
2461+ atomic do
9422− && maxSessionLifetime > 0
2462+ set *startedAt = t
9423− && maxPresenceTtl > 0 && maxForwardsEntries > 0 && maxAckedIds > 0
2463+ set *serverGeneration = t * 1000 + genJitter
9424− && maxForwardRetries > 0 && maxGossipHops > 0 && maxPollsPerKey > 0
2464+ logInfo ("Skrepka relay server starting on port " ++ show listenPort ++ "...")
9425− && gossipOriginHops > 0 && maxThirdPartyGossipHops > 0
2465+ logInfo (" federation: " ++ if federationEnabled then "enabled" else "disabled")
9426− && verificationTokenExpiry > 0
2466+ fork backgroundPrune
9427− && maxAckRetries > 0 && maxPairRatePerPair > 0 && pairRateWindowMs > 0
2467+ fork pollHeartbeat
9428− && maxFederationPairRatePerPair > 0 && federationPairRateWindowMs > 0
2468+ listen listenPort serve
9429− && maxForwardNonces > 0
9430− && maxGossipEventsPerServer > 0 && gossipEventRateWindowMs > 0
9431− && maxGlobalFederationConcurrency > 0
9432− -- Relationship invariants: these misconfigurations cause subtle bugs
9433− -- (e.g., messages pruned before their stated max age, backoff that never increases)
9434− let configRelationsOk = unackedMessageMaxAge <= messageMaxAge
9435− && challengeExpiry < sessionExpiry
9436− && sessionExpiry <= maxSessionLifetime
9437− && retryBackoffBase <= retryBackoffMax
9438− && backgroundPruneInterval < healthPruneMaxAge
9439− && ackGracePeriod < unackedMessageMaxAge
9440− && minMessageTtl > 0 && minMessageTtl <= unackedMessageMaxAge
9441− && clockSkewTolerance < challengeExpiry
9442− && maxMessagesPerRecipient <= maxMessages
9443− && maxForwardsPerKey <= maxForwardsEntries
9444− && maxForwardsPerSenderPerKey <= maxForwardsPerKey
9445− && maxForwardsPerServer <= maxForwardsEntries
9446− && maxSessionsPerKey <= maxSessions
9447− && maxChallengesPerKey <= maxChallenges
9448− && maxPollsPerKey <= maxActivePolls
9449− && pollTimeoutMs < sessionExpiry
9450− && gossipDedupWindow < presenceRefreshInterval
9451− && federationFetchTimeoutMs <= backgroundPruneInterval
9452− && maxAckOverflow <= maxAckedIds
9453− && gossipOriginHops <= maxGossipHops
9454− && maxThirdPartyGossipHops <= maxGossipHops
9455− && verificationTokenExpiry <= federationFetchTimeoutMs
9456− && forwardNonceRetention >= messageMaxAge
9457− && maxGlobalFederationConcurrency >= maxFederationConcurrency
9458− && maxGossipEventsPerServer > maxGossipEvents
9459− && onlineGossipTtl * 1000 > sessionExpiry
9461− then logError "FATAL: invalid configuration — capacity limits and intervals must be > 0, server not started"
9462− else if not configRelationsOk
9463− then logError "FATAL: invalid configuration — relationship invariants violated (check: unackedMessageMaxAge <= messageMaxAge, challengeExpiry < sessionExpiry, sessionExpiry <= maxSessionLifetime, retryBackoffBase <= retryBackoffMax, backgroundPruneInterval < healthPruneMaxAge, pollTimeoutMs < sessionExpiry, gossipDedupWindow < presenceRefreshInterval, federationFetchTimeoutMs <= backgroundPruneInterval, maxAckOverflow <= maxAckedIds, gossipOriginHops <= maxGossipHops, maxThirdPartyGossipHops <= maxGossipHops, verificationTokenExpiry <= federationFetchTimeoutMs, forwardNonceRetention >= messageMaxAge, maxGlobalFederationConcurrency >= maxFederationConcurrency, maxGossipEventsPerServer > maxGossipEvents, onlineGossipTtl*1000 > sessionExpiry, maxForwardsPerSenderPerKey <= maxForwardsPerKey, per-key/per-server limits <= global limits), server not started"
9466− -- Mix random bits into generation to prevent sub-millisecond restart collisions.
9467− -- Clients use generation to detect server restarts; same generation = stale cursor.
9468− genJitter <- randomInt 1000000
9471− set *serverGeneration = t * 1000 + genJitter
9472− logInfo "maintenance secret not set — use /maintenance/rotate-secret at startup to enable /maintenance/* and /stats endpoints"
9473− when (matchesHostnameOrSubdomain serverHostN "localhost")
9474− (logWarn ("serverHost is " ++ serverHost ++ " — peers cannot reach this server for federation"))
9475− when (federationEnabled && isBadServerName serverHostN)
9476− (logError ("serverHost '" ++ serverHost ++ "' would be rejected by isBadServerName — federation peers cannot forward messages here. Set serverHost to a public DNS name."))
9478− then logInfo "IP binding: required — challenge requests without ClientIp header are rejected"
9479− else logInfo "IP binding: optional — sessions created with a ClientIp header will reject requests without one"
9480− logWarn "SECURITY: Knot has no HTTP-layer request body size limit. Deploy behind a reverse proxy with a body limit (e.g., Caddy: request_body { max_size 256KB }) to prevent large-payload DoS."
9481− when federationEnabled
9482− (logWarn "SECURITY: DNS rebinding risk — federation URLs resolve DNS at fetch time, not at validation time. A peer hostname passing isBadServerName could rebind to a private IP between validation and fetch. Mitigate by blocking outbound connections to RFC1918/link-local/CGNAT ranges at the firewall level.")
9483− logInfo ("Skrepka relay server starting on port " ++ show listenPort ++ "...")
9484− logInfo (" federation: " ++ if federationEnabled then "enabled (protocol v" ++ show federationProtocolVersion ++ ")" else "disabled")
9485− when (serverFederationPrivateKeyHex != "" && serverFederationPublicKeyHex != "")
9486− (logInfo " federation auth: Ed25519 signing enabled")
9487− when (serverFederationPrivateKeyHex == "" && federationEnabled)
9488− (logInfo " federation auth: verify callback (no signing key configured)")
9489− when (serverFederationPrivateKeyHex != "" && serverFederationPublicKeyHex == "")
9490− (logError "FATAL: serverFederationPrivateKeyHex is set but serverFederationPublicKeyHex is empty — both must be configured together")
9491− when (serverFederationPrivateKeyHex == "" && serverFederationPublicKeyHex != "")
9492− (logError "FATAL: serverFederationPublicKeyHex is set but serverFederationPrivateKeyHex is empty — both must be configured together")
9493− logInfo (" prune interval: " ++ show backgroundPruneInterval ++ "ms")
9494− logInfo (" poll timeout: " ++ show pollTimeoutMs ++ "ms")
9495− logInfo (" max messages: " ++ show maxMessages ++ " (per recipient: " ++ show maxMessagesPerRecipient ++ ")")
9496− logInfo (" max sessions: " ++ show maxSessions ++ " (per key: " ++ show maxSessionsPerKey ++ ")")
9497− logInfo (" max presence: " ++ show maxPresenceEntries)
9498− logInfo (" max forwards: " ++ show maxForwardsEntries ++ " (per key: " ++ show maxForwardsPerKey ++ ", per sender-key: " ++ show maxForwardsPerSenderPerKey ++ ", per server: " ++ show maxForwardsPerServer ++ ")")
9499− logInfo (" session expiry: " ++ show sessionExpiry ++ "ms (max lifetime: " ++ show maxSessionLifetime ++ "ms)")
9500− logInfo (" message max age: " ++ show messageMaxAge ++ "ms")
9501− logInfo (" max active requests: " ++ if maxActiveRequests > 0 then show maxActiveRequests else "unlimited")
9502− logInfo (" global rate limit: " ++ show maxGlobalRequestRate ++ "/" ++ show globalRateWindowMs ++ "ms")
9503− logInfo (" auth rate limit: " ++ show maxAuthGlobalRate ++ "/" ++ show authGlobalRateWindowMs ++ "ms")
9504− logInfo (" pair rate limit: " ++ show maxPairRatePerPair ++ "/" ++ show pairRateWindowMs ++ "ms per sender-recipient")
9505− logInfo (" federation pair rate limit: " ++ show maxFederationPairRatePerPair ++ "/" ++ show federationPairRateWindowMs ++ "ms per server-recipient")
9506− logInfo (" gossip event rate limit: " ++ show maxGossipEventsPerServer ++ " events/" ++ show gossipEventRateWindowMs ++ "ms per server")
9507− logInfo (" global federation concurrency: " ++ show maxGlobalFederationConcurrency)
9508− logInfo (" ack retry limit: " ++ show maxAckRetries ++ " per entry")
9509− when (federationCircuitBreakerThreshold > 0)
9510− (logInfo (" circuit breaker: " ++ show federationCircuitBreakerThreshold ++ " failing peers"))
9511− logInfo (" federation allowlist: " ++ show maxAllowedPeers ++ " max (empty = open federation)")
9512− fork backgroundPrune
9514− fork backgroundWatchdog
9515− fork backgroundMetaWatchdog
9516− -- Startup peer connectivity check: probe known peers after a short delay
9517− -- to surface federation misconfigurations immediately (DNS, firewall, TLS).
9518− -- Runs as a forked task so it doesn't delay server startup.
9519− when federationEnabled (fork (do
9520− sleep 5000 -- wait for listener to be ready
9521− logInfo "startup: probing federation peers..."
9522− startupProbePeers))
9523− listen listenPort serve