@@ -1,79 +1,42 @@
1−-- Skrepka Relay Server
2−-- Single-server implementation of the Skrepka protocol (v0.1)
3−-- Binary data (keys, signatures, blobs) uses hex encoding (bytesToHex/bytesFromHex)
4−--
5−-- Architecture:
6−-- Clients authenticate via Ed25519 challenge-response, then poll for messages via long-polling.
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.
1+-- Skrepka Relay Server (simplified)
2+-- Single-server implementation of the Skrepka protocol (v0.1).
3+-- This is a deliberately simplified rewrite: every collection is a single flat list,
4+-- rate limiters use a plain count-per-window, no caches, no histograms, no TCO accumulator
5+-- helpers. Performance under load is significantly worse than the sharded original;
6+-- correctness and clarity are the only goals here.
117
128-- ============================================
139-- Configuration
1410-- ============================================
1511
16−-- Server identity and federation credentials
1712serverHost = "localhost"
1813listenPort = 8080
19−federationScheme = "https://" -- scheme for federation HTTP calls
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.
14+federationScheme = "https://"
2515serverFederationPrivateKeyHex = ""
2616serverFederationPublicKeyHex = ""
27−-- NOTE: listenHost is not configurable — Knot's listen primitive only accepts a port.
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.
17+
4818messageMaxAge : Int<Ms>
49−messageMaxAge = 2592000000 -- 30 days
19+messageMaxAge = 2592000000
5020maxPresenceTtl : Int<S>
51−maxPresenceTtl = 3600 -- max presence TTL from gossip
21+maxPresenceTtl = 3600
5222maxPubkeyLen = 256
5323maxBlobLen = 65536
5424maxSignatureLen = 256
55−maxIpLen = 45 -- max length of an IP address string (IPv6 = 45 chars); used in matchIp instead of maxServerNameLen
25+maxIpLen = 45
5626maxMessageIds = 100
57−maxBatchSize = 100 -- max messages per batch request (bounds recursion depth in sendBatchInner)
58−maxMessagePriority = 10 -- max priority value (clamped on ingress)
27+maxBatchSize = 100
28+maxMessagePriority = 10
5929maxGossipEvents = 100
6030maxPollEvents = 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
6731maxPresenceEntries = 10000
6832maxMessagesPerRecipient = 500
69−maxMessages = 100000 -- global cap on total stored messages across all recipients
70−-- Global capacity limits for in-memory collections
33+maxMessages = 100000
7134clockSkewTolerance : Int<Ms>
72−clockSkewTolerance = 5000 -- 5 seconds tolerance for clock skew between federated servers
35+clockSkewTolerance = 5000
7336maxForwardsEntries = 10000
74−maxForwardsPerKey = 50 -- max pending forwards per recipient pubkey (prevents one key from starving others)
75−maxForwardsPerSenderPerKey = 10 -- max pending forwards per sender-recipient pair (prevents one sender from monopolizing a recipient's queue)
76−maxForwardsPerServer = 2000 -- max pending forwards per destination server (prevents one unreachable peer from starving others)
37+maxForwardsPerKey = 50
38+maxForwardsPerSenderPerKey = 10
39+maxForwardsPerServer = 2000
7740maxServerNameLen = 128
7841maxMessageIdLen = 128
7942maxCorrelationIdLen = 128
@@ -81,301 +44,95 @@ maxTokenLen = 256
8144maxChallenges = 10000
8245maxSessions = 10000
8346maxAckedIds = 10000
84−maxAckOverflow = 200 -- overflow buffer for acks that couldn't be sent yet
8547maxDeliveredIds = 10000
86−-- Per-key limits and rate limiting
8748maxChallengesPerKey = 5
8849maxSessionsPerKey = 10
8950challengeExpiry : Int<Ms>
90−challengeExpiry = 60000 -- 1 minute
91−maxChallengeRatePerKey = 5 -- max challenge requests per key per window
92−maxChallengeRateEntries = 1000
51+challengeExpiry = 60000
52+maxChallengeRatePerKey = 5
9353challengeRateWindowMs : Int<Ms>
9454challengeRateWindowMs = 1000
95−maxSendRatePerKey = 20 -- max messages sent per key per window
55+maxSendRatePerKey = 20
9656sendRateWindowMs : Int<Ms>
9757sendRateWindowMs = 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
10659recvRateWindowMs : Int<Ms>
10760recvRateWindowMs = 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
11162pairRateWindowMs : Int<Ms>
112−pairRateWindowMs = 60000 -- 1 minute
113−maxPairRateEntries = 5000
114−-- Federation rate limiting (per-server)
115−maxFederationRatePerServer = 50 -- max federation requests per server per window
63+pairRateWindowMs = 60000
64+maxFederationRatePerServer = 50
11665federationRateWindowMs : Int<Ms>
11766federationRateWindowMs = 1000
118−maxFederationRateEntries = 100
119−-- Per-server-per-recipient rate limiting for federation forwards
120−maxFederationPairRatePerPair = 10 -- max forwards per fromServer-recipient pair per window
121−federationPairRateWindowMs : Int<Ms>
122−federationPairRateWindowMs = 60000 -- 1 minute
123−maxFederationPairRateEntries = 5000
124−-- Global request rate limiting
125−maxActiveRequests = 500 -- max concurrent requests before rejecting with overloaded (0 = disable)
126−maxGlobalRequestRate = 1000 -- max total requests per window
67+maxLookupRatePerKey = 5
68+lookupRateWindowMs : Int<Ms>
69+lookupRateWindowMs = 1000
70+maxClientWriteRatePerKey = 10
71+clientWriteRateWindowMs : Int<Ms>
72+clientWriteRateWindowMs = 1000
73+maxIpRatePerIp = 10
74+ipRateWindowMs : Int<Ms>
75+ipRateWindowMs = 1000
76+maxGlobalRequestRate = 1000
12777globalRateWindowMs : Int<Ms>
12878globalRateWindowMs = 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
13180authGlobalRateWindowMs : Int<Ms>
13281authGlobalRateWindowMs = 1000
133−-- Session and gossip timing
82+
13483sessionExpiry : Int<Ms>
135−sessionExpiry = 3600000 -- 1 hour
136−maxSessionLifetime : Int<Ms>
137−maxSessionLifetime = 86400000 -- 24 hours; absolute session lifetime (forces re-auth even if sliding window keeps refreshing)
84+sessionExpiry = 3600000
13885onlineGossipTtl : Int<S>
139−onlineGossipTtl = 5400 -- 1.5 hours; 1.5x sessionExpiry to prevent presence expiring before session refresh gossips
86+onlineGossipTtl = 5400
14087offlineGossipMinTtl : Int<S>
141−offlineGossipMinTtl = 60 -- minimum TTL for offline gossip events
142−maxFederationConcurrency = 10 -- max concurrent outbound federation requests per cycle
143−maxForwardRetriesPerServer = 100
144−maxForwardRetries = 10 -- max retries per individual forward entry before dropping
145−maxAckRetries = 10 -- max retries per ack entry before dropping to deliveredIds
146−maxGossipHops = 5 -- max hops a gossip event can propagate across servers
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
149−gossipDedupWindow : Int<Ms>
150−gossipDedupWindow = 60000 -- suppress re-broadcast of identical gossip events within this window
151−maxRecentGossip = 1000
152−-- Exponential backoff for failed federation forwards
88+offlineGossipMinTtl = 60
89+maxForwardRetries = 10
90+maxAckRetries = 10
91+maxGossipHops = 5
92+gossipOriginHops = 2
93+
15394retryBackoffBase : Int<Ms>
154−retryBackoffBase = 30000 -- 30 seconds
95+retryBackoffBase = 30000
15596retryBackoffMax : Int<Ms>
156−retryBackoffMax = 480000 -- 8 minutes
157−maxForwardFailures = 1000 -- max tracked server failure records
158−maxServerDowntime : Int<Ms>
159−maxServerDowntime = 86400000 -- 24 hours; stop retrying a server after this duration of consecutive failures
160−-- Federation in-flight tracking: skip servers with outstanding requests older than this threshold
97+retryBackoffMax = 480000
98+
99+verificationTokenExpiry : Int<Ms>
100+verificationTokenExpiry = 30000
101+maxPendingVerifications = 10000
102+
161103federationFetchTimeoutMs : Int<Ms>
162−federationFetchTimeoutMs = 30000 -- 30 seconds; consider server unresponsive if fetch hasn't returned
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
192−
193−-- Federation latency metric window
194−federationLatencyWindowMs : Int<Ms>
195−federationLatencyWindowMs = 300000 -- 5 minutes; reset latency metrics after this interval
196−
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)
205−
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"
209−
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
104+federationFetchTimeoutMs = 30000
215105
216−-- Max seenBy list length in gossip events (bounds memory and bandwidth per event)
217−maxSeenByLen = 20
218−
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
236−
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
241106backgroundPruneInterval : Int<Ms>
242−backgroundPruneInterval = 30000 -- 30 seconds; also retries failed forwards/acks
107+backgroundPruneInterval = 30000
243108pollTimeoutMs : Int<Ms>
244−pollTimeoutMs = 25000 -- long-poll heartbeat interval (how long a poll blocks before returning empty)
245−maxPollsPerKey = 3 -- max concurrent long-poll connections per pubkey
109+pollTimeoutMs = 25000
110+maxPollsPerKey = 3
246111maxActivePolls = 5000
247112maxWatchKeys = 50
248113presenceRefreshInterval : Int<Ms>
249−presenceRefreshInterval = 300000 -- 5 minutes
250−-- Refresh entries expiring within 1.5 refresh intervals. At 2x, entries with 8-10 min
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)
114+presenceRefreshInterval = 300000
115+
305116unackedMessageMaxAge : Int<Ms>
306−unackedMessageMaxAge = 604800000 -- 7 days
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.
117+unackedMessageMaxAge = 604800000
309118minMessageTtl : Int<Ms>
310−minMessageTtl = 60000 -- 1 minute
311−-- Grace period before federation ack can delete the original message (allows local client to poll)
119+minMessageTtl = 60000
312120ackGracePeriod : Int<Ms>
313−ackGracePeriod = 120000 -- 2 minutes; allows clients on slow connections or backgrounded apps
314−-- to poll before federation ack reclaims the origin message
315−-- Deferred ack cleanup capacity
316−maxPendingAckCleanups = 10000
317−-- Per-key deferred ack cleanup cap (prevents one noisy key from dominating the queue)
318−maxPendingAckCleanupsPerKey = 100
319−
320−-- Message expiration notifications: track expired locally-originated messages so senders
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
340−
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
121+ackGracePeriod = 120000
122+
123+federationProtocolVersion = 15
124+serverBuildVersion = "2026-04-27-simple"
125+
126+federationEnabled = True {}
127+federationUrl = \server -> federationScheme ++ server
128+requireClientIp = True {}
370129
371130-- ============================================
372131-- Types
373132-- ============================================
374133
375−-- Event delivered to a polling client: an encrypted message blob
376134type PollEvent = {id: MessageIdHex, eventType: Text, payload: {encryptedBlob: BlobHex, timestamp: Timestamp, toKey: PubkeyHex, expiresAt: Timestamp}}
377135
378−-- Gossip events propagate presence changes between federated servers
379136data GossipEventType = GossipOnline {} | GossipOffline {} | GossipUnknown {}
380137
381138impl ToJSON GossipEventType where
@@ -391,18 +148,8 @@ impl FromJSON GossipEventType where
391148 else if s == "offline" then GossipOffline {}
392149 else GossipUnknown {}
393150
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).
398151type GossipEvent = {eventType: GossipEventType, pubkey: PubkeyHex, server: ServerName, timestamp: Timestamp, ttl: Int<S>, seenBy: [Text]}
399152
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>}
402−
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
406153data MessageStatus = MsDelivered {} | MsFederated {} | MsQueued {} | MsUnauthorized {} | MsRejected {} | MsRateLimited {} | MsDuplicate {} | MsDraining {}
407154
408155impl ToJSON MessageStatus where
@@ -416,7 +163,6 @@ impl ToJSON MessageStatus where
416163 MsDuplicate {} -> "duplicate"
417164 MsDraining {} -> "draining")
418165
419−-- Validated hex-encoded types with maximum length constraints
420166isValidBoundedHex : Int -> Text -> Bool
421167isValidBoundedHex = \maxLen s -> not (tooLong s maxLen) && isValidHex s && s == normalizeHex s
422168type PubkeyHex = Text where isValidBoundedHex maxPubkeyLen
@@ -426,8 +172,6 @@ isValidMessageId : Text -> Bool
426172isValidMessageId = isValidBoundedHex maxMessageIdLen
427173type MessageIdHex = Text where isValidMessageId
428174type 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)
431175isValidServerName : Text -> Bool
432176isValidServerName = \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s)
433177type ServerName = Text where isValidServerName
@@ -435,642 +179,87 @@ type AnyServerName = Text where \s -> not (tooLong s maxServerNameLen) && s == n
435179
436180type Timestamp = Int<Ms>
437181
438−-- Pending challenge for Ed25519 challenge-response auth
439182type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp, ip: Text}
440−-- Authenticated session; token is a random hex string
441183type 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.
448184type 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
450185type 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.
454186type 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
456187type 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)
458188type DeliveredEntry = {messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}
459−-- Tracks consecutive failures per federation peer for exponential backoff
460189type ForwardFailure = {server: Text, failedAt: Timestamp, failures: Int, firstFailedAt: Timestamp}
461−-- Sliding-window rate limit state per pubkey.
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
190+type RateEntry = {key: Text, windowStart: Timestamp, count: Int}
472191type ActivePoll = {pubkey: PubkeyHex, startedAt: Timestamp}
473192data AuthResult = Authorized {pubkey: PubkeyHex, ip: Text} | Unauthorized {}
474−data ForwardResult = ForwardDuplicate {} | ForwardRejected {} | ForwardStored {}
475−
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}
489193
490−-- Forward nonce for extended replay protection
491−type ForwardNonce = {messageId: MessageIdHex, toKey: PubkeyHex, seenAt: Timestamp}
194+type SenderExpiration = {senderKey: Text, messageId: MessageIdHex, toKey: PubkeyHex, expiredAt: 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}
492198
493−-- Batch send types
494199type BatchMessage = {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int}
495200type BatchResult = {messageId: OptionalMessageId, status: MessageStatus}
496201
497−-- Batch cancel types
498202type BatchCancelEntry = {messageId: MessageIdHex, to: PubkeyHex}
499203type BatchCancelResult = {messageId: MessageIdHex, cancelled: Bool}
500204
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}
504−
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}
508−
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}
513−
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}
518−
519205-- ============================================
520−-- Persisted State
206+-- Persisted State (all flat lists, no sharding)
521207-- ============================================
522−-- All state is in-memory (no disk persistence). Prefixed with * (mutable refs).
523−-- Atomic blocks provide transactional consistency for reads + writes.
524208
525209*challenges : [Challenge]
526−
527−-- Sessions sharded into 16 buckets by first hex char of token.
528−-- Hot-path auth scans only one bucket (~1/16 of sessions).
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]
553−
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]
572−
573−*totalMessageCount : Int
574−
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]
593−
594−*totalPresenceCount : Int
595−
596−-- Cached set of known peer server names (updated on prune and gossip, avoids full presence scans)
597−*knownPeerServers : [Text]
598−
599−-- Monotonic counter ensuring unique receivedAt ordering even within the same millisecond
600−*seqCounter : Timestamp
601−
602−-- Forwards sharded into 16 buckets by pubkeyBucket(toKey).
603−-- Hot-path operations (sendMessageCore dedup, ackPolledMessages) scan one bucket.
604−*fwdBucket0 : [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]
620−
621−*totalForwardCount : Int
622−
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]
626−*ackedBucket1 : [AckedEntry]
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]
641−
642−*lastPrunedAt : Timestamp
643−
210+*sessions : [Session]
211+*messages : [Message]
212+*presence : [PresenceEntry]
213+*forwards : [ForwardEntry]
214+*ackedIds : [AckedEntry]
215+*deliveredIds : [DeliveredEntry]
644216*forwardFailures : [ForwardFailure]
645−
646−*sendRates : [SendRateEntry]
647−
648−*lastPresenceRefresh : Timestamp
649−
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
656−
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
661−
662−*challengeRates : [ChallengeRateEntry]
663−
664−-- Separate revoke rate limiter (prevents challenge floods from exhausting revoke budget)
665−*revokeRates : [ChallengeRateEntry]
666−
667−-- Heartbeat signal: incremented periodically to wake all blocking long-polls
668−*pollWakeup : Timestamp
669−
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
689−
690217*activePolls : [ActivePoll]
691218
692−-- Overflow buffer: acks evicted from ackedIds before they could be sent to origin
693−*ackOverflow : [AckedEntry]
694−
695−-- Final dedup set: messages confirmed delivered (ack sent or overflow drained).
696−-- Sharded into 16 buckets by pubkeyBucket(toKey) for O(n/16) dedup in sendMessageCore.
697−*delivBucket0 : [DeliveredEntry]
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]
713−
714−*federationRates : [FederationRateEntry]
715−
716−*federationPairRates : [FederationPairRateEntry]
219+*sendRates : [RateEntry]
220+*recvRates : [RateEntry]
221+*pairRates : [RateEntry]
222+*challengeRates : [RateEntry]
223+*lookupRates : [RateEntry]
224+*clientWriteRates : [RateEntry]
225+*federationRates : [RateEntry]
226+*ipRates : [RateEntry]
717227
718228*globalRateCount : Int
719−*globalRatePrevCount : Int
720−
721229*globalRateWindowStart : Timestamp
230+*authGlobalRateCount : Int
231+*authGlobalRateWindowStart : Timestamp
722232
723−-- Health endpoint rate limiting state (separate from global rate to avoid starving real requests)
724−*healthRateCount : Int
725−*healthRateWindowStart : Timestamp
726−*healthRatePrevCount : Int
727−
728−-- Background task cycle counters (exposed via /stats for health monitoring)
729−*pruneCount : Int
730−
731−*heartbeatCount : Int
732−
733−*startedAt : Timestamp
734−
233+*seqCounter : Timestamp
234+*pollWakeup : Timestamp
235+*lastPrunedAt : Timestamp
735236*lastHeartbeatAt : Timestamp
736−
737−-- Drain phase: 0=normal (accepting), 1=soft drain (block new auth, serve existing sessions),
738−-- 2=full drain (reject all client requests). Allows staged shutdown:
739−-- phase 1 lets active clients finish while preventing new connections.
740−*drainPhase : Int
741−
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
746−
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
750−
751−*pruneRunning : Timestamp
752−
753−*pruneGeneration : Int
754−
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>
758−
759−*ipRates : [IpRateEntry]
760−
761−*lookupRates : [LookupRateEntry]
762−
763−-- Separate rate limiter for client write operations (ack, delete) — prevents ack bursts from starving lookups
764−*clientWriteRates : [LookupRateEntry]
765−
766−*recvRates : [RecvRateEntry]
767−
768−*pairRates : [PairRateEntry]
769−
770−*recentGossip : [RecentGossipEntry]
771−
772−*lastFederationSuccessAt : Timestamp
773−
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]
792−
793−-- Tracks outstanding federation fetches per server (detects hung connections)
794−*federationInFlight : [FederationInFlightEntry]
795−
796−-- Federation latency tracking (for /stats)
797−*federationLatencyTotal : Int<Ms>
798−*federationLatencyCount : Int
799−*federationLatencyMax : Int<Ms>
800−
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
807−
808−-- Federation verify callback metrics (exposed in /stats, reset with latency window)
809−*slowVerifyCount : Int
810−*verifyFailCount : Int
811−
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
816−
817−-- Server instance generation (epoch timestamp, for cursor staleness detection)
237+*lastPresenceRefresh : Timestamp
238+*startedAt : Timestamp
818239*serverGeneration : Int
819240
820−-- Timestamp when drain federation ops completed (0 if in progress or not draining)
241+*drainPhase : Int
821242*drainCompletedAt : Timestamp
822243
823−-- Last time federation latency metrics were reset (for windowed averages)
824−*federationLatencyResetAt : Timestamp
825−
826−-- Suppresses latency metric recording during startup probe phase (prevents
827−-- unauthenticated probe results from skewing initial /stats readings)
828−*startupProbeActive : Bool
829−
830−-- Total session count across all buckets (avoids O(16) recount on monitoring paths)
831−*totalSessionCount : Int
832−
833−-- Auth-tier global rate limiting state
834−*authGlobalRateCount : Int
835−*authGlobalRatePrevCount : Int
836−*authGlobalRateWindowStart : Timestamp
837−
838−-- Max concurrent background prune forks (prevents resource exhaustion from stuck recovery)
839−*activePruneForks : Int
840−
841−-- Signal for drain timeout (set by forked timer, watched by STM retry in waitForInFlightDrain)
842−*drainTimedOut : Bool
843−
844−-- Recent federation requests for replay detection (dedup by server+timestamp)
845−*recentFederationRequests : [RecentFederationRequest]
846−
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
849244*pendingVerifications : [{token: Text, createdAt: Timestamp, scope: Text}]
850245
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]
869−
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
893−
894−-- Federation verify per-IP rate limiting (tighter than general IP rate)
895−*verifyIpRates : [IpRateEntry]
896−
897−-- Per-peer gossip event volume rate limiting
898−*gossipEventRates : [GossipEventRateEntry]
899−
900−-- Global federation connection counter (tracks total concurrent outbound connections)
901−*federationActiveConnections : Int
902−
903−-- Blocked federation peers (managed at runtime via /maintenance/block and /maintenance/unblock)
904−*blockedPeers : [Text]
905−
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]
909−
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}]
913−
914−-- Cached successful verify callbacks per-server (short-lived, reduces outbound HTTP calls)
915−*verificationCache : [{server: Text, scope: Text, verifiedAt: Timestamp}]
916−
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}]
921−
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]
925−
926−-- Sender expiration notifications: messages that expired unread, queued for the sender's next poll.
927−-- Populated during prune for locally-originated messages (senderKey != "").
928246*senderExpirations : [SenderExpiration]
929−
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.
932247*senderDeliveries : [SenderDelivery]
933−
934−-- Cancel notifications: messages retracted by the sender, queued for the recipient's next poll.
935−-- Populated during handleCancelMessage, handleFederationCancel, handleFederationBatchCancel.
936248*cancelNotifications : [CancelNotification]
937−
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.
940249*pendingFederationCancels : [PendingFederationCancel]
941250
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}]
947−
948−-- Maintenance secret: set via /maintenance/rotate-secret at startup.
949−-- When empty, maintenance and stats endpoints are disabled.
950251*runtimeMaintenanceSecret : Text
951252
952−-- Runtime-configurable rate limit overrides (0 = use compile-time default).
953−-- Adjusted via /maintenance/rate-limits POST endpoint without recompile+restart.
954−*rateOverrideGlobalRequest : Int
955−*rateOverrideIpRate : Int
956−*rateOverrideSendRate : Int
957−*rateOverrideFederationRate : Int
958−*rateOverrideAuthGlobal : Int
959−*rateOverrideRecvRate : Int
960−*rateOverrideChallengeRate : Int
961−*rateOverridePairRate : Int
962−*rateOverrideLookupRate : Int
963−*rateOverrideClientWriteRate : Int
964−
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
971−
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
976−*rateLimitedIp : Int
977−*rateLimitedAuth : Int
978−*rateLimitedPerKey : Int
979−*rateLimitedFederation : Int
980−
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
985−
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
989−
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
998−
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>
1006−
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
1017−
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
1025−
1026−-- Auth (challenge + verify) latency tracking (for /stats, reset with latency window)
1027−*clientAuthLatencyTotal : Int<Ms>
1028−*clientAuthLatencyCount : Int
1029−*clientAuthLatencyMax : Int<Ms>
1030−
1031−-- Last time the background watchdog loop ran (for health check liveness detection)
1032−*lastWatchdogAt : Timestamp
1033−
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
1052−
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
1056−
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
1061−
1062−-- Gossip send metrics (windowed, reset with federation latency metrics)
1063−*gossipSendSuccess : Int
1064−*gossipSendFail : Int
253+*blockedPeers : [Text]
254+*allowedPeers : [Text]
255+
256+*pruneCount : Int
257+*heartbeatCount : Int
1065258
1066259-- ============================================
1067−-- Routes
260+-- Routes (response shapes preserved; removed metric fields are zero-filled)
1068261-- ============================================
1069262
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
1074263route AuthApi where
1075264 /auth
1076265 POST {pubkey: PubkeyHex} /challenge headers {clientIp: Text}
@@ -1082,241 +271,151 @@ route AuthApi where
1082271 POST {targetToken: Text} /revoke headers {authorization: Text, clientIp: Text}
1083272 -> {ok: Bool, authorized: Bool}
1084273 = RevokeSession
1085− -- Voluntary disconnect: removes session and gossips offline if last session for this key
1086274 POST {} /logout headers {authorization: Text, clientIp: Text}
1087275 -> {ok: Bool, authorized: Bool}
1088276 = Logout
1089277
1090−-- Client-facing API (requires session token in Authorization header)
1091278route ClientApi where
1092− -- Long-poll for new messages; cursor tracks last-seen receivedAt timestamp
1093279 POST {cursor: Timestamp, generation: Int, watchKeys: [PubkeyHex]} /poll headers {authorization: Text, clientIp: Text}
1094280 -> {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}]}
1095281 = Poll
1096282 /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.
1102283 POST {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int} / headers {authorization: Text, clientIp: Text}
1103284 -> {status: MessageStatus, messageId: OptionalMessageId, retryAfterMs: Int, error: Text, loadPct: Int}
1104285 = SendMessage
1105− -- Check delivery status of a sent message (caller must know recipient to prove ownership)
1106286 POST {to: PubkeyHex, messageId: MessageIdHex} /status headers {authorization: Text, clientIp: Text}
1107287 -> {status: Text, authorized: Bool}
1108288 = MessageStatus
1109− -- Explicitly acknowledge received messages by ID (alternative to cursor-based ack in poll)
1110289 POST {messageIds: [MessageIdHex]} /ack headers {authorization: Text, clientIp: Text}
1111290 -> {ok: Bool, authorized: Bool, ackedCount: Int, error: Text}
1112291 = AckMessages
1113− -- Send multiple messages in one request (auth checked once; each message rate-limited independently)
1114292 POST {messages: [BatchMessage]} /batch headers {authorization: Text, clientIp: Text}
1115293 -> {results: [BatchResult], authorized: Bool, retryAfterMs: Int}
1116294 = 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).
1119295 POST {offset: Int} /list headers {authorization: Text, clientIp: Text}
1120296 -> {messages: [{messageId: MessageIdHex, timestamp: Timestamp, receivedAt: Timestamp}], authorized: Bool, count: Int, error: Text}
1121297 = ListMessages
1122− -- Delete pending messages by ID (recipient-only; messages don't store sender pubkey)
1123298 POST {messageIds: [MessageIdHex]} /delete headers {authorization: Text, clientIp: Text}
1124299 -> {ok: Bool, authorized: Bool, deletedCount: Int, error: Text}
1125300 = 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.
1130301 POST {messageId: MessageIdHex, to: PubkeyHex} /cancel headers {authorization: Text, clientIp: Text}
1131302 -> {ok: Bool, authorized: Bool, cancelled: Bool, error: Text}
1132303 = CancelMessage
1133− -- Cancel (retract) multiple sent messages in one request.
1134− -- Each cancel is processed independently; partial success is possible.
1135304 POST {cancels: [BatchCancelEntry]} /cancel-batch headers {authorization: Text, clientIp: Text}
1136305 -> {results: [BatchCancelResult], authorized: Bool, error: Text}
1137306 = CancelBatch
1138− -- Look up which server a pubkey is present on (for federation routing)
1139307 GET /lookup/{pubkey: PubkeyHex} headers {authorization: Text, clientIp: Text}
1140308 -> {server: AnyServerName, authorized: Bool, error: Text}
1141309 = LookupPresence
1142− -- Batch lookup: look up presence for multiple pubkeys in one request
1143310 POST {pubkeys: [PubkeyHex]} /lookup/batch headers {authorization: Text, clientIp: Text}
1144311 -> {results: [{pubkey: PubkeyHex, server: AnyServerName}], authorized: Bool, error: Text}
1145312 = BatchLookupPresence
1146313
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.
1152314route FederationApi where
1153315 /federation
1154− -- Receive presence gossip events from a peer server
1155316 POST {events: [GossipEvent], hopsRemaining: Int, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /gossip headers {authorization: Text}
1156317 -> {ok: Bool, error: Text, retryAfterMs: Int}
1157318 = 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.
1164319 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}
1165320 -> {ok: Bool, error: Text, retryAfterMs: Int}
1166321 = ForwardMessage
1167− -- Acknowledge delivery of messages back to the origin server
1168322 POST {messageIds: [MessageIdHex], originServer: ServerName, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /ack headers {authorization: Text}
1169323 -> {ok: Bool, error: Text, ackedCount: Int, results: [{messageId: MessageIdHex, found: Bool}], retryAfterMs: Int}
1170324 = 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.
1179325 POST {messageId: MessageIdHex, toKey: PubkeyHex, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /cancel headers {authorization: Text}
1180326 -> {ok: Bool, error: Text, cancelled: Bool, retryAfterMs: Int}
1181327 = FederationCancel
1182− -- Batch cancel: cancel multiple previously forwarded messages in one request.
1183328 POST {cancels: [{messageId: MessageIdHex, toKey: PubkeyHex}], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /cancel-batch headers {authorization: Text}
1184329 -> {ok: Bool, error: Text, results: [BatchCancelResult], retryAfterMs: Int}
1185330 = 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.
1189331 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}
1190332 -> {ok: Bool, error: Text, results: [{messageId: MessageIdHex, ok: Bool}], retryAfterMs: Int}
1191333 = 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).
1196334 POST {messageIds: [MessageIdHex], toKeys: [PubkeyHex], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /delivery-receipt headers {authorization: Text}
1197335 -> {ok: Bool, error: Text, receivedCount: Int, retryAfterMs: Int}
1198336 = FederationDeliveryReceipt
1199337
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.
1209338route FederationVerifyApi where
1210339 POST {token: Text, scope: Text} /federation/verify headers {clientIp: Text} -> {ok: Bool} = VerifyToken
1211340
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.
1214341route FederationPubkeyApi where
1215342 GET /federation/pubkey -> {pubkey: Text, ok: Bool} = FederationPubkey
1216343
1217−-- Triggers pruning of expired state and retry of pending federation ops
1218344route MaintenanceApi where
1219345 POST {} /maintenance/prune headers {authorization: Text}
1220346 -> {ok: Bool}
1221347 = Prune
1222− -- phase: 0 or 2 = full drain (backward compat), 1 = soft drain (auth-only block)
1223348 POST {phase: Int} /maintenance/drain headers {authorization: Text}
1224349 -> {ok: Bool, drained: Int, phase: Int}
1225350 = Drain
1226351 POST {} /maintenance/undrain headers {authorization: Text}
1227352 -> {ok: Bool}
1228353 = 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.
1231354 POST {} /maintenance/shutdown headers {authorization: Text}
1232355 -> {ok: Bool, drained: Int}
1233356 = Shutdown
1234− -- Block a federation peer (rejects all inbound/outbound federation with this server)
1235357 POST {server: ServerName} /maintenance/block headers {authorization: Text}
1236358 -> {ok: Bool, blocked: Int}
1237359 = BlockPeer
1238− -- Unblock a previously blocked peer
1239360 POST {server: ServerName} /maintenance/unblock headers {authorization: Text}
1240361 -> {ok: Bool, unblocked: Bool}
1241362 = UnblockPeer
1242− -- List currently blocked peers
1243363 GET /maintenance/blocked headers {authorization: Text}
1244364 -> {peers: [Text], ok: Bool}
1245365 = ListBlocked
1246− -- Test federation connectivity to a specific peer via verify callback round-trip
1247366 POST {server: ServerName} /maintenance/ping headers {authorization: Text}
1248367 -> {ok: Bool, latencyMs: Int, error: Text}
1249368 = PingPeer
1250− -- List sessions for a specific pubkey (admin debugging)
1251369 GET /maintenance/sessions/{pubkey: PubkeyHex} headers {authorization: Text}
1252370 -> {sessions: [{token: Text, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}], count: Int, ok: Bool}
1253371 = AdminListSessions
1254− -- Revoke all sessions for a specific pubkey (abuse response)
1255372 POST {pubkey: PubkeyHex} /maintenance/sessions/revoke-all headers {authorization: Text}
1256373 -> {ok: Bool, revokedCount: Int}
1257374 = AdminRevokeSessions
1258− -- Purge all pending messages for a specific pubkey (inbox bombing response)
1259375 POST {pubkey: PubkeyHex} /maintenance/messages/purge headers {authorization: Text}
1260376 -> {ok: Bool, purgedCount: Int}
1261377 = AdminPurgeMessages
1262− -- Revoke all sessions from a specific IP address (key-rotation abuse response)
1263378 POST {ip: Text} /maintenance/sessions/revoke-ip headers {authorization: Text}
1264379 -> {ok: Bool, revokedCount: Int, affectedKeys: Int}
1265380 = 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.
1269381 POST {limit: Int} /maintenance/sessions/list headers {authorization: Text}
1270382 -> {sessions: [{pubkey: PubkeyHex, count: Int, ips: [Text], latestExpiry: Timestamp}], ok: Bool, total: Int}
1271383 = AdminListAllSessions
1272− -- Read current effective rate limits (compile-time defaults + runtime overrides)
1273384 GET /maintenance/rate-limits headers {authorization: Text}
1274385 -> {ok: Bool, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int}
1275386 = GetRateLimits
1276− -- Update rate limits at runtime (0 = reset to compile-time default)
1277387 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}
1278388 -> {ok: Bool}
1279389 = SetRateLimits
1280− -- Flush forward nonces (recovery from corruption or capacity issues)
1281390 POST {} /maintenance/nonces/flush headers {authorization: Text}
1282391 -> {ok: Bool, flushedCount: Int}
1283392 = FlushNonces
1284− -- Allow a federation peer (when allowlist is non-empty, only allowed peers can federate)
1285393 POST {server: ServerName} /maintenance/allow headers {authorization: Text}
1286394 -> {ok: Bool, allowed: Int}
1287395 = AllowPeer
1288− -- Remove a server from the federation allowlist
1289396 POST {server: ServerName} /maintenance/unallow headers {authorization: Text}
1290397 -> {ok: Bool, removed: Bool}
1291398 = UnallowPeer
1292− -- List currently allowed federation peers (empty = open federation)
1293399 GET /maintenance/allowed headers {authorization: Text}
1294400 -> {peers: [Text], ok: Bool}
1295401 = ListAllowed
1296− -- Force counter reconciliation (message counts, presence, sessions).
1297− -- Returns drift values; non-zero means counters were corrected.
1298402 POST {} /maintenance/reconcile headers {authorization: Text}
1299403 -> {ok: Bool, messageDrift: Int, presenceDrift: Int, sessionDrift: Int}
1300404 = 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.
1304405 POST {newSecret: Text} /maintenance/rotate-secret headers {authorization: Text}
1305406 -> {ok: Bool, error: Text}
1306407 = RotateSecret
1307− -- Read current effective operational config (compile-time defaults + runtime overrides)
1308408 GET /maintenance/config headers {authorization: Text}
1309409 -> {ok: Bool, maxMessagesPerRecipient: Int, maxGossipHops: Int, pollTimeoutMs: Int, ackGracePeriod: Int}
1310410 = GetConfig
411+
1311412route HealthApi where
1312413 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
1313414
1314−-- Returns counts of in-memory collections (requires maintenance secret)
1315−-- TODO: If Knot adds raw text response support, add a /metrics endpoint
1316−-- returning Prometheus exposition format for direct integration with standard
1317−-- monitoring stacks. Currently /stats returns JSON which requires a custom scraper.
1318−-- Stats response grouped into nested objects for monitoring dashboard ergonomics.
1319−-- BREAKING CHANGE from flat format — existing scrapers must update field paths.
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}
416+type KeyPresenceEntry = {server: Text, expiresAt: Timestamp}
417+type RecipientCount = {pubkey: PubkeyHex, count: Int}
418+
1320419route StatsApi where
1321420 GET /stats headers {authorization: Text}
1322421 -> {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
1327426 GET /stats/key/{pubkey: PubkeyHex} headers {authorization: Text}
1328427 -> {messages: Int, presence: [KeyPresenceEntry], sessions: Int, forwards: Int, forwardDetails: [{server: Text, retries: Int, createdAt: Timestamp}], activePolls: Int, ok: Bool}
1329428 = 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.
1332429 POST {limit: Int} /stats/top-recipients headers {authorization: Text}
1333430 -> {recipients: [RecipientCount], ok: Bool, total: Int}
1334431 = 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).
1337432 GET /stats/forwards headers {authorization: Text}
1338433 -> {servers: [{server: Text, count: Int, oldestAge: Int, totalRetries: Int}], ok: Bool, total: Int}
1339434 = 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.
1343435 GET /stats/rates headers {authorization: Text}
1344436 -> {ok: Bool, scalePct: Int, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int}
1345437 = StatsRates
1346438
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).
1352439route MetricsApi where
1353440 GET /metrics headers {authorization: Text} -> {metrics: Text, ok: Bool} = Metrics
1354441
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.
1359442route ReadyApi where
1360443 GET /ready -> {ready: Bool} = Ready
1361444
1362445route Api = AuthApi | ClientApi | FederationApi | FederationVerifyApi | FederationPubkeyApi | MaintenanceApi | HealthApi | StatsApi | MetricsApi | ReadyApi
1363446
1364447-- ============================================
1365−-- Helpers
448+-- Generic helpers
1366449-- ============================================
1367450
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
1380−
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)
1386−
1387−joinKVPairs = \kvs -> fold (\acc kv -> if acc == "" then kv else acc ++ " " ++ kv) "" kvs
1388−
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 ++ ")"))
1395−
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
1404−
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
1409−isJsonSafe = \s ->
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)
1414− else False {}
1415−
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 ->
1426− if s == "" then ""
1427− else if isJsonSafe s then s
1428− else escapeJsonStringAcc s ""
1429−
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
1441−
1442451any : [a] -> (a -> Bool) -> Bool
1443452any = \xs pred -> fold (\acc x -> if acc then acc else pred x) (False {}) xs
1444453none : [a] -> (a -> Bool) -> Bool
1445454none = \xs pred -> not (any xs pred)
1446455when = \cond action -> if cond then action else yield {}
1447−whenOk = \result action -> case result of
1448− Ok _ -> action
1449− Err _ -> yield {}
1450456clamp = \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
1454457min = \a b -> if a < b then a else b
1455458max = \a b -> if a > b then a else b
1456459
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}]
1467−
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}
1472−
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 {}
1481− else do
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)
1485− else updated
1486−
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
1495−
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.
1501460headOf = \items -> fold (\acc x -> case acc of
1502461 Nothing {} -> Just {value: x}
1503462 _ -> acc) Nothing {} items
1504463
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
467+
1505468maxBy = \items getKey -> fold (\acc x -> case acc of
1506469 Nothing {} -> Just {value: x}
1507470 Just {value: v} -> if getKey x > getKey v then Just {value: x} else acc) Nothing {} items
1508471
1509−minBy = \items getKey -> fold (\acc x -> case acc of
1510− Nothing {} -> Just {value: x}
1511− Just {value: v} -> if getKey x < getKey v then Just {value: x} else acc) Nothing {} items
472+-- Drop the single oldest entry by key (LRU-style eviction)
473+evictOldest = \items getKey ->
474+ case minBy items getKey of
475+ Nothing {} -> items
476+ Just {value: oldest} ->
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
481+ in r.items
482+
483+capList = \items maxN getKey ->
484+ if count items > maxN then evictOldest items getKey else items
1512485
1513−-- Hex encoding utilities for token generation
486+-- Hex tokens
1514487hexDigit : Int -> Text
1515488hexDigit = \n -> take 1 (drop (clamp 0 15 n) "0123456789abcdef")
1516489
1517490byteToHex : Int -> Text
1518491byteToHex = \n -> hexDigit (n / 16) ++ hexDigit (n - (n / 16) * 16)
1519492
1520−-- Encode a 24-bit integer as 6 hex characters (3 bytes)
1521493intTo3Hex : Int -> Text
1522494intTo3Hex = \n ->
1523495 let b0 = n / 65536 in
@@ -1526,57 +498,53 @@ intTo3Hex = \n ->
1526498 let b2 = r0 - b1 * 256 in
1527499 byteToHex b0 ++ byteToHex b1 ++ byteToHex b2
1528500
1529−-- Generate a random hex token (n chunks of 3 bytes each = 6n hex chars)
1530501genTokenN = \n -> if n <= 0 then yield "" else do
1531502 chunk <- randomInt 16777216
1532503 rest <- genTokenN (n - 1)
1533504 yield (intTo3Hex chunk ++ rest)
1534505
1535−-- Token generation parameters (linked to safeCompareLen for consistency)
1536−tokenChunks = 8
1537−tokenHexLen = 6 * tokenChunks -- 48; each chunk produces 6 hex chars (3 bytes)
1538−
1539−-- Default token: tokenChunks chunks = tokenHexLen hex chars = 24 bytes of randomness
1540−genToken = genTokenN tokenChunks
506+genToken = genTokenN 8
1541507
1542508tooLong : Text -> Int -> Bool
1543509tooLong = \s maxLen -> drop maxLen s != ""
1544510
1545−-- Sanitize correlationId: truncate to maxCorrelationIdLen and strip non-printable characters
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)
1552−
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).
511+-- Printable ASCII allowlist
1555512printableAscii : Text
1556513printableAscii = " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
1557514
1558−-- Strip all non-printable characters from a string (allowlist approach).
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 ++.
515+-- Strip non-printable characters via simple recursion (no accumulator)
1562516stripNonPrintable : Text -> Text
1563−stripNonPrintable = \s -> stripNonPrintableAcc s ""
517+stripNonPrintable = \s ->
518+ if s == "" then ""
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)
1564522
1565−stripNonPrintableAcc : Text -> Text -> Text
1566−stripNonPrintableAcc = \s acc ->
1567− if s == "" then acc
523+sanitizeCorrelationId : Text -> Text
524+sanitizeCorrelationId = \cid -> stripNonPrintable (take maxCorrelationIdLen cid)
525+
526+-- Escape JSON string via simple recursion
527+escapeJsonString : Text -> Text
528+escapeJsonString = \s ->
529+ if s == "" then ""
1568530 else let c = take 1 s in
1569− if contains c printableAscii then stripNonPrintableAcc (drop 1 s) (acc ++ c)
1570− else stripNonPrintableAcc (drop 1 s) acc
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)
536+ else if contains c printableAscii then c ++ escapeJsonString (drop 1 s)
537+ else escapeJsonString (drop 1 s)
538+
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
1571544
1572545isHexChar : Text -> Bool
1573546isHexChar = \c -> contains c "0123456789abcdef"
1574547
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.
1580548isValidHexPairs : Text -> Bool
1581549isValidHexPairs = \s ->
1582550 if s == "" then True {}
@@ -1599,75 +567,13 @@ isAllowedServerChar = \c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"
1599567containsBadUrlChar : Text -> Bool
1600568containsBadUrlChar = \s -> any (chars s) (\c -> not (isAllowedServerChar c))
1601569
1602−-- Carrier-grade NAT range: 100.64.0.0/10 (RFC 6598)
1603−isCgnatRange : Text -> Bool
1604−isCgnatRange = \s ->
1605− take 4 s == "100."
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))
1616−
1617−containsMultipleColons : Text -> Bool
1618−containsMultipleColons = \s -> count (do c <- chars s; where c == ":"; yield c) > 1
1619−
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)
1625−
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
1630−
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)
1638−
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)
1647−
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
1652−
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)
1658− else False {}
1659−
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)
1665− else False {}
570+isAllDots : Text -> Bool
571+isAllDots = \s -> if s == "" then True {} else if take 1 s == "." then isAllDots (drop 1 s) else False {}
1666572
1667573stripTrailingDot : Text -> Text
1668574stripTrailingDot = \s ->
1669575 if s == "" then ""
1670− else if take 1 s == "." && isTrailingDots (drop 1 s) then stripTrailingDot (drop 1 s)
576+ else if isAllDots s then ""
1671577 else take 1 s ++ stripTrailingDot (drop 1 s)
1672578
1673579normalizeServerName : Text -> Text
@@ -1678,197 +584,116 @@ serverHostN = normalizeServerName serverHost
1678584isLocalServer : Text -> Bool
1679585isLocalServer = \s -> s == serverHostN
1680586
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)
1686−
1687587containsSuffix : Text -> Text -> Bool
1688−containsSuffix = \suffix s -> containsSuffixN suffix (count (chars suffix)) s
1689−
1690−is172Private : Text -> Bool
1691−is172Private = \sn ->
1692− take 4 sn == "172."
1693− && let d1 = take 1 (drop 4 sn) in
1694− let d2 = take 1 (drop 5 sn) in
1695− take 1 (drop 6 sn) == "."
1696− && isDigitChar (take 1 (drop 7 sn))
1697− && ((d1 == "1" && contains d2 "6789")
1698− || (d1 == "2" && isDigitChar d2)
1699− || (d1 == "3" && contains d2 "01"))
1700−
1701−isHighOctetPrefix : Text -> Bool
1702−isHighOctetPrefix = \sn ->
1703− take 1 sn == "2"
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"))
1711−
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) == ":")
1716−
1717−matchesHostnameOrSubdomain : Text -> Text -> Bool
1718−matchesHostnameOrSubdomain = \sn name ->
1719− matchesHostname sn name || containsSuffix ("." ++ name) sn
1720−
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)
1727−
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.
588+containsSuffix = \suffix s ->
589+ let suffixLen = count (chars suffix) in
590+ let sLen = count (chars s) in
591+ sLen >= suffixLen && drop (sLen - suffixLen) s == suffix
592+
593+-- Block private/reserved/internal hostnames (SSRF defense). Simplified vs original:
594+-- still rejects the high-value cases (loopback, RFC1918, link-local, metadata services)
595+-- but skips obscure encoding tricks (octal, hex, percent-encoding).
1731596isBadServerName : Text -> Bool
1732597isBadServerName = \sn ->
1733598 let fc = take 1 sn in
1734− fc == ""
1735− || fc == "."
1736− || fc == ":"
599+ fc == "" || fc == "." || fc == ":"
1737600 || containsBadUrlChar sn
1738− || not (hasDotBeforePort sn)
1739− || matchesHostnameOrSubdomain sn "localhost"
1740− || matchesHostname sn "localhost.localdomain"
1741− || matchesHostnameOrSubdomain sn "local"
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 == "["
1749− || is172Private sn
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 == "::"
1757− || isCgnatRange sn
1758− || containsMultipleColons sn
1759− || hasOctalOctet sn
1760− || hasHexPrefix sn
1761− || (isDigitChar fc && isAllDigitsOrDotsUntilColonOrEnd sn)
1762− || isHighOctetPrefix sn
601+ || sn == "localhost"
602+ || containsSuffix ".localhost" sn
603+ || containsSuffix ".local" sn
604+ || containsSuffix ".internal" sn
1763605 || containsSuffix ".arpa" sn
1764606 || containsSuffix ".onion" sn
1765− || containsSuffix ".i2p" sn
1766− || containsSuffix ".corp" sn
1767− || containsSuffix ".home" sn
1768− || containsSuffix ".lan" sn
1769− || containsSuffix ".intranet" sn
1770− || containsSuffix ".test" sn
1771− || containsSuffix ".example" sn
1772− || containsSuffix ".invalid" sn
1773− || containsPercentEncoding sn
1774− || containsDoubleEncoding sn
1775− -- Kubernetes / service mesh internal DNS
1776− || containsSuffix ".svc" sn
1777− || containsSuffix ".cluster.local" sn
1778− -- HashiCorp Consul service discovery
1779− || containsSuffix ".consul" sn
1780− || containsSuffix ".node.consul" sn
1781− || containsSuffix ".service.consul" sn
1782− -- Cloud provider internal DNS (SSRF targets for metadata/internal services)
1783− || containsSuffix ".compute.internal" sn -- GCP internal DNS
1784− || containsSuffix ".ec2.internal" sn -- AWS EC2 internal DNS
1785− || containsSuffix ".amazonaws.com" sn -- AWS service endpoints (S3, SQS, etc.)
1786− || matchesHostname sn "metadata.google.internal" -- GCP metadata server
1787− || containsSuffix ".internal.cloudapp.net" sn -- Azure VM internal DNS
1788− || matchesHostname sn "metadata.azure.com" -- Azure Instance Metadata Service (IMDS v2)
1789− -- NOTE: Unicode/IDN defense is provided by containsBadUrlChar above, which rejects
1790− -- any character not in [0-9a-z-.:] via isAllowedServerChar. This blocks homoglyph
1791− -- attacks (e.g., Greek omicron in "lοcalhost") assuming Knot's Text type preserves
1792− -- Unicode codepoints in take/contains operations. If Knot ever normalizes Unicode
1793− -- (NFKC/NFC) before comparison, add an explicit ASCII-range byte check here.
1794−
1795−-- Look up a non-expired session matching the given token (constant-time comparison).
1796−-- Caller passes the appropriate session bucket (sharded by token prefix).
1797−authenticateSession : [Session] -> Text -> Timestamp -> AuthResult
1798−authenticateSession = \sessions token t ->
1799− case headOf (do s <- sessions; where s.expiresAt > t && t - s.createdAt < maxSessionLifetime && safeCompare s.token token; yield s) of
1800− Nothing {} -> Unauthorized {}
1801− Just {value: s} -> Authorized {pubkey: s.pubkey, ip: s.ip}
607+ || take 4 sn == "127."
608+ || take 3 sn == "10."
609+ || take 8 sn == "192.168."
610+ || take 8 sn == "169.254."
611+ || take 2 sn == "0."
612+ || take 2 sn == "::"
613+ || fc == "["
614+
615+-- ============================================
616+-- Auth helpers
617+-- ============================================
618+
619+safeCompareLen = maxTokenLen + 16
620+
621+-- Simple non-TCO constant-time comparison: compares character-by-character.
622+-- Returns True iff strings are non-empty and equal up to safeCompareLen.
623+safeCompareLoop : Text -> Text -> Int -> Int
624+safeCompareLoop = \s1 s2 n ->
625+ if n <= 0 then 0
626+ else
627+ let c1 = take 1 s1 in
628+ let c2 = take 1 s2 in
629+ let d = if c1 == c2 then 0 else 1 in
630+ let endMismatch = if c1 == "" then (if c2 == "" then 0 else 1) else (if c2 == "" then 1 else 0) in
631+ d + endMismatch + safeCompareLoop (drop 1 s1) (drop 1 s2) (n - 1)
632+
633+safeCompare : Text -> Text -> Bool
634+safeCompare = \a b ->
635+ if take 1 a == "" || take 1 b == "" then False {}
636+ else safeCompareLoop a b safeCompareLen == 0
637+
638+matchIp : Text -> Text -> Bool
639+matchIp = \clientIp sessionIp ->
640+ if sessionIp == "" then True {}
641+ else if clientIp == "" then False {}
642+ else safeCompare clientIp sessionIp
1802643
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)
1814−
1815−-- Extract bearer token from "Authorization: Bearer <token>" header.
1816−-- Rejects empty tokens early to avoid unnecessary session bucket scans.
1817644extractToken = \authHeader ->
1818645 let token = drop 7 authHeader in
1819646 if toLower (take 7 authHeader) == "bearer " && token != "" && not (tooLong token maxTokenLen)
1820647 then Just {value: token}
1821648 else Nothing {}
1822649
1823−-- Constant-time secret comparison (prevents timing attacks on maintenance secret)
1824650verifySecret : Text -> Text -> Bool
1825−verifySecret = \token secret ->
1826− secret != "" && safeCompare token secret
651+verifySecret = \token secret -> secret != "" && safeCompare token secret
1827652
1828−verifyAuthWith : (Text -> Bool) -> Text -> Bool
1829−verifyAuthWith = \check authorization ->
1830− case extractToken authorization of
1831− Nothing {} -> False {}
1832− Just {value: token} -> check token
1833−
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).
1836653verifyMaintenanceAuth : Text -> IO Bool
1837654verifyMaintenanceAuth = \authorization -> do
1838655 secret <- *runtimeMaintenanceSecret
1839656 if secret == "" then yield False
1840− else yield (verifyAuthWith (\token -> verifySecret token secret) authorization)
657+ else case extractToken authorization of
658+ Nothing {} -> yield False
659+ Just {value: token} -> yield (verifySecret token secret)
660+
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}
666+
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
676+ else onAuth pubkey
1841677
1842−-- Check if a server is on the blocklist
1843678isBlockedPeer : Text -> [Text] -> Bool
1844679isBlockedPeer = \server blocked -> any blocked (\b -> b == server)
1845680
1846−-- Check if a server passes the allowlist (empty allowlist = all allowed)
1847681isAllowedByAllowlist : Text -> [Text] -> Bool
1848682isAllowedByAllowlist = \server allowed -> count allowed == 0 || any allowed (\a -> a == server)
1849683
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.
1852684splitOnColon : Text -> {before: Text, after: Text}
1853−splitOnColon = \s -> splitOnColonInner s 0
1854−
1855−splitOnColonInner : Text -> Int -> {before: Text, after: Text}
1856−splitOnColonInner = \s pos ->
1857− if drop pos s == "" then {before: s, after: ""}
1858− else if take 1 (drop pos s) == ":" then {before: take pos s, after: drop (pos + 1) s}
1859− else splitOnColonInner s (pos + 1)
1860−
1861−-- Generate a single-use token for outbound federation auth.
1862−-- scope binds the token to a request type ("gossip", "forward", "ack") so a token
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).
685+splitOnColon = \s ->
686+ if s == "" then {before: "", after: ""}
687+ else if take 1 s == ":" then {before: "", after: drop 1 s}
688+ else
689+ let r = splitOnColon (drop 1 s) in
690+ {before: take 1 s ++ r.before, after: r.after}
691+
1867692generateFederationAuth : Text -> Timestamp -> IO {network} Text
1868693generateFederationAuth = \scope requestTimestamp ->
1869694 if serverFederationPrivateKeyHex != ""
1870695 then do
1871− nonce <- genTokenN tokenChunks
696+ nonce <- genTokenN 8
1872697 let message = textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ serverHostN ++ "|" ++ nonce)
1873698 let sig = sign (bytesFromHex serverFederationPrivateKeyHex) message
1874699 yield ("Signed " ++ bytesToHex sig ++ ":" ++ nonce)
@@ -1878,1567 +703,176 @@ generateFederationAuth = \scope requestTimestamp ->
1878703 atomic do
1879704 pending <- *pendingVerifications
1880705 let updated = union pending [{token: token, createdAt: t, scope: scope}]
1881− set *pendingVerifications = if count updated > maxPendingVerifications
1882− then evictOneOldest updated (\p -> p.createdAt)
1883− else updated
706+ set *pendingVerifications = capList updated maxPendingVerifications (\p -> p.createdAt)
1884707 yield ("Bearer " ++ token)
1885708
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
1902− Just {value: p} ->
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
1906−
1907709verifyFederationCallback : Text -> Text -> Text -> IO {network} Bool
1908710verifyFederationCallback = \fromServer authorization scope ->
1909− case extractToken authorization of
1910− Nothing {} -> yield (False {})
1911− Just {value: token} -> do
1912− -- Check verify cache: skip the outbound HTTP call if we recently verified this server+scope
1913− t <- now
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 {})
1920− else do
1921− startTime <- now
1922− result <- fetchFederation fromServer (VerifyToken {token: token, scope: scope})
1923− endTime <- now
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)")
1927− atomic do
1928− svc <- *slowVerifyCount
1929− set *slowVerifyCount = svc + 1)
1930− case result of
1931− Err e -> do
1932− logWarn ("federation: verify callback to " ++ fromServer ++ " failed: " ++ show e)
1933− atomic do
1934− vfc <- *verifyFailCount
1935− set *verifyFailCount = vfc + 1
1936− yield (False {})
1937− Ok r -> do
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)
1946− else updated)
1947− yield r.ok
711+ case extractToken authorization of
712+ Nothing {} -> yield False
713+ Just {value: token} -> do
714+ result <- fetch (federationUrl fromServer) (VerifyToken {token: token, scope: scope})
715+ case result of
716+ Err _ -> yield False
717+ Ok r -> yield r.ok
1948718
1949−-- ============================================
1950−-- Session Bucket Helpers
1951−-- ============================================
1952−-- Sessions are sharded into 16 buckets by the first hex char of the token.
1953−-- This reduces auth scan from O(n) to O(n/16) on the hot path.
1954−
1955−tokenBucket : Text -> Int
1956−tokenBucket = \token -> clamp 0 15 (hexCharIndex (take 1 token))
1957−
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
1976−
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
1995−
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)))))))))))))))
2019−
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)
2040−
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 {})
2047− else do
2048− bucket <- readSessionBucket b
2049− if any bucket (\s -> s.pubkey == pubkey) then yield (True {})
2050− else hasSessionForKey pubkey (b + 1)
2051−
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 {})
2057− else do
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)
2061−
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
2076−
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 []
2083− else do
2084− bucket <- readSessionBucket b
2085− let matching = do s <- bucket; where s.pubkey == pubkey; yield s
2086− rest <- collectSessionsForKey pubkey (b + 1)
2087− yield (union matching rest)
2088−
2089−-- Count sessions for a specific pubkey across all buckets (avoids materializing full session list).
2090−-- Used in verify fast path to skip readAllSessions.
2091−countSessionsForKey : PubkeyHex -> IO Int
2092−countSessionsForKey = \pubkey -> countSessionsInBucket pubkey 0
2093−
2094−countSessionsInBucket : PubkeyHex -> Int -> IO Int
2095−countSessionsInBucket = \pubkey b ->
2096− if b > 15 then yield 0
2097− else do
2098− bucket <- readSessionBucket b
2099− let n = count (do s <- bucket; where s.pubkey == pubkey; yield s)
2100− rest <- countSessionsInBucket pubkey (b + 1)
2101− yield (n + rest)
2102−
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
2108− else do
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)
2115−
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
2120−
2121−pruneAndCountSessionBucket : ([Session] -> [Session]) -> Int -> IO Int
2122−pruneAndCountSessionBucket = \f b ->
2123− if b > 15 then yield 0
2124− else do
2125− bucket <- readSessionBucket b
2126− let pruned = f bucket
2127− writeSessionBucket b pruned
2128− rest <- pruneAndCountSessionBucket f (b + 1)
2129− yield (count pruned + rest)
2130−
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
2150−
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
2190−
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 ->
2196− if b > 15
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))
719+-- Verify Ed25519 signed federation request, with optional nonce.
720+verifyFederationSignature : Text -> Text -> Text -> Text -> Timestamp -> IO {network} Bool
721+verifyFederationSignature = \fromServer signatureHex nonce scope requestTimestamp -> do
722+ result <- fetch (federationUrl fromServer) (FederationPubkey {})
723+ case result of
724+ Err _ -> yield False
725+ Ok r ->
726+ if not r.ok || r.pubkey == "" then yield False
727+ else
728+ let msg = if nonce == ""
729+ then scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer
730+ else scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer ++ "|" ++ nonce
731+ in yield (verify (bytesFromHex r.pubkey) (textToBytes msg) (bytesFromHex signatureHex))
732+
733+withFederationAuth = \authorization t respond fromServer scope requestTimestamp precondition action -> do
734+ blocked <- *blockedPeers
735+ if isBlockedPeer fromServer blocked
736+ then yield (respond {ok: False {}, error: "blocked", retryAfterMs: 0})
2202737 else do
2203− bucket <- readSessionBucket b
2204− let bucketMin = minBy bucket (\s -> s.expiresAt)
2205− let newCandidate = case bucketMin of
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
2211−
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).
2217−
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
2236−
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
2255−
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)))))))))))))))
2275−
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)
2295−
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)
2306−
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
2318−
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
2361−
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
2380−
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 []
2388− else do
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)
2393−
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.
2399−
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
2418−
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
2437−
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)))))))))))))))
2459−
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
2479−
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)
2490−
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
2501−
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 ->
2505− fold (\acc x ->
2506− let b = pubkeyBucket (getKey x) in
2507− if any acc (\i -> i == b) then acc else union [b] acc) [] items
2508−
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
2538− if overCap then do
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
2548− else do
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))
2554− else yield {}
2555−
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
2562−
2563−pruneMessageBucketsConcurrent = \b t ->
2564− if b > 15 then do
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.
2567− atomic do
2568− pending <- *pendingBucketPrunes
2569− if pending > 0 then retry else yield {}
2570− else do
2571− bucket <- readMessageBucket b
2572− if count bucket == 0 then pruneMessageBucketsConcurrent (b + 1) t
738+ allowed <- *allowedPeers
739+ if not (isAllowedByAllowlist fromServer allowed)
740+ then yield (respond {ok: False {}, error: "not_allowed", retryAfterMs: 0})
2573741 else do
2574− atomic do
2575− p <- *pendingBucketPrunes
2576− set *pendingBucketPrunes = p + 1
2577− fork (do
2578− pruneMessageBucket b t
2579− atomic do
2580− p <- *pendingBucketPrunes
2581− set *pendingBucketPrunes = max 0 (p - 1))
2582− pruneMessageBucketsConcurrent (b + 1) t
2583−
2584−-- Per-bucket message reconciliation: reads one bucket per atomic block instead of all 16
2585−-- at once, reducing lock contention during reconciliation. Each pubkey maps to exactly one
2586−-- bucket, so per-bucket recipient counts are disjoint — each bucket's counts are written
2587−-- to the corresponding rcBucket without overlap.
2588−-- Delta-based counter adjustment: snapshots totalMessageCount before scanning, computes the
2589−-- drift (actual - snapshot), then applies the drift atomically to the live counter. This is
2590−-- commutative with concurrent sendMessageCore: if sendMessageCore increments by N between our
2591−-- snapshot and final adjustment, the live counter becomes (snapshot + N + drift) = (actual + N),
2592−-- which is correct. The old approach overwrote with the absolute recount, losing concurrent N.
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
2601−
2602−reconcileMessageCountsPerBucket = \b totalDrift ->
2603− if b > 15 then yield totalDrift
2604− else do
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
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))
2622− yield drift
2623− reconcileMessageCountsPerBucket (b + 1) (totalDrift + bucketDrift)
742+ verified <- if take 7 authorization == "Signed "
743+ then
744+ let payload = drop 7 authorization in
745+ if payload == "" || tooLong payload (maxSignatureLen + 25)
746+ then yield False
747+ else
748+ let parts = splitOnColon payload in
749+ verifyFederationSignature fromServer parts.before parts.after scope requestTimestamp
750+ else verifyFederationCallback fromServer authorization scope
751+ if not verified
752+ then yield (respond {ok: False {}, error: "unauthorized", retryAfterMs: 0})
753+ else if requestTimestamp > 0 && (requestTimestamp > t + clockSkewTolerance || requestTimestamp < t - clockSkewTolerance)
754+ then yield (respond {ok: False {}, error: "clock_skew", retryAfterMs: 0})
755+ else if not precondition
756+ then yield (respond {ok: False {}, error: "invalid_request", retryAfterMs: 0})
757+ else do
758+ limited <- checkServerRateGate fromServer t
759+ if limited
760+ then yield (respond {ok: False {}, error: "rate_limited", retryAfterMs: federationRateWindowMs})
761+ else action
2624762
2625763-- ============================================
2626−-- Recipient Count Helpers
764+-- Rate limiting (plain count-per-window, no sliding interpolation)
2627765-- ============================================
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.
2634−
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
2642−
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}]
2656− else counts
2657−
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
2665−
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
2680−
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
2690−
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
2710−
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
2729−
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
2734− else do
2735− bucket <- readRcBucket b
2736− rest <- countAllRcEntries (b + 1)
2737− yield (count bucket + rest)
2738−
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
2748−
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
2755− else do
2756− bucket <- readRcBucket b
2757− let merged = mergeTopN acc bucket limit
2758− topRecipientsByBucket (b + 1) limit merged
2759−
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
2764− else do
2765− bucket <- readRcBucket b
2766− let bucketTotal = fold (\acc c -> acc + c.count) 0 bucket
2767− rest <- sumRcBucketTotals (b + 1)
2768− yield (bucketTotal + rest)
2769766
2770−-- Check message dedup only (without counting — count comes from rcBuckets)
2771−checkMessageDup : [Message] -> Text -> PubkeyHex -> Bool
2772−checkMessageDup = \messages messageId toKey ->
2773− messageId != "" && any messages (\m -> m.messageId == messageId && m.toKey == toKey)
2774−
2775−-- ============================================
2776−-- Forward Nonce Bucket Helpers
2777−-- ============================================
2778−-- Forward nonces sharded into 16 buckets by pubkeyBucket(toKey).
2779−-- Hot-path (handleForwardMessage, sendMessageCore) scans one bucket (~1/16 of nonces).
2780−
2781−readNonceBucket : Int -> IO [ForwardNonce]
2782−readNonceBucket = \b ->
2783− if b == 0 then do s <- *nonceBucket0; yield s
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
2799−
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
2818−
2819−readAllNonces : IO [ForwardNonce]
2820−readAllNonces = do
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)))))))))))))))
2838−
2839−countAllNonces : Int -> IO Int
2840−countAllNonces = \b ->
2841− if b > 15 then yield 0
2842− else do
2843− bucket <- readNonceBucket b
2844− rest <- countAllNonces (b + 1)
2845− yield (count bucket + rest)
2846−
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
2885−
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 {}
2890− else do
2891− bucket <- readNonceBucket b
2892− writeNonceBucket b (do n <- bucket; where t - n.seenAt < forwardNonceRetention; yield n)
2893− pruneAllNonceBuckets (b + 1) t
2894−
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
2904−
2905−pruneNonceBucketRange : Int -> Int -> Timestamp -> IO ()
2906−pruneNonceBucketRange = \b endB t ->
2907− if b > endB || b > 15 then yield {}
2908− else do
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
2913−
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
2933−
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
2952−
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 {}
2958− else do
2959− writeNonceCutoff b 0
2960− resetAllNonceCutoffs (b + 1)
2961−
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
2971− else updatedNonces
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
2975− else 0
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}
2987−
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])
2994−
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
767+-- Returns {limited, entries}. Increments count when the key fits within the window.
768+checkRate = \entries key maxRate windowMs maxEntries t ->
769+ let entry = headOf (do r <- entries; where r.key == key; yield r) in
770+ case entry of
771+ Nothing {} ->
772+ if 1 >= maxRate
773+ then {limited: True {}, entries: entries}
774+ else {limited: False {}, entries: capList (union entries [{key: key, windowStart: t, count: 1}]) maxEntries (\r -> r.windowStart)}
775+ Just {value: r} ->
776+ if t - r.windowStart >= windowMs
777+ then {limited: False {}, entries: do x <- entries; yield (if x.key == key then {key: x.key, windowStart: t, count: 1} else x)}
778+ else if r.count >= maxRate
779+ then {limited: True {}, entries: entries}
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)}
3006781
3007−-- ============================================
3008−-- Forward Bucket Helpers
3009−-- ============================================
3010−-- Forwards sharded into 16 buckets by pubkeyBucket(toKey).
3011−
3012−readFwdBucket : Int -> IO [ForwardEntry]
3013−readFwdBucket = \b ->
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
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
3030−
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
3049−
3050−readAllForwards : IO [ForwardEntry]
3051−readAllForwards = do
3052− f0 <- *fwdBucket0
3053− f1 <- *fwdBucket1
3054− f2 <- *fwdBucket2
3055− f3 <- *fwdBucket3
3056− f4 <- *fwdBucket4
3057− f5 <- *fwdBucket5
3058− f6 <- *fwdBucket6
3059− f7 <- *fwdBucket7
3060− f8 <- *fwdBucket8
3061− f9 <- *fwdBucket9
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)))))))))))))))
3069−
3070−countAllForwards : Int -> IO Int
3071−countAllForwards = \b ->
3072− if b > 15 then yield 0
3073− else do
3074− bucket <- readFwdBucket b
3075− rest <- countAllForwards (b + 1)
3076− yield (count bucket + rest)
3077−
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
3082−
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}
782+checkGlobalRate = \t -> atomic do
783+ ws <- *globalRateWindowStart
784+ c <- *globalRateCount
785+ if t - ws >= globalRateWindowMs then do
786+ set *globalRateWindowStart = t
787+ set *globalRateCount = 1
788+ yield False
789+ else if c >= maxGlobalRequestRate then yield True
3086790 else do
3087− bucket <- readMessageBucket b
3088− let c = count bucket
3089− messageBucketMinMaxInner (b + 1) (min currentMin c) (max currentMax c)
791+ set *globalRateCount = c + 1
792+ yield False
3090793
3091−-- Compute forward stats per-bucket without materializing all forwards into one list.
3092−-- Returns total count, oldest age, unique server count, and max per-server queue depth.
3093−computeForwardStats : Int -> Timestamp -> IO {totalCount: Int, oldestAge: Int, serverCount: Int, maxDepth: Int, serverCounts: [{server: Text, count: Int}]}
3094−computeForwardStats = \b t -> computeForwardStatsInner b t {totalCount: 0, oldestAge: 0, serverCount: 0, maxDepth: 0, serverCounts: []}
794+checkAuthGlobalRate = \t -> atomic do
795+ ws <- *authGlobalRateWindowStart
796+ c <- *authGlobalRateCount
797+ if t - ws >= authGlobalRateWindowMs then do
798+ set *authGlobalRateWindowStart = t
799+ set *authGlobalRateCount = 1
800+ yield False
801+ else if c >= maxAuthGlobalRate then yield True
802+ else do
803+ set *authGlobalRateCount = c + 1
804+ yield False
805+
806+checkIpRateGate = \ip t ->
807+ if ip == "" then yield False
808+ else atomic do
809+ rates <- *ipRates
810+ let r = checkRate rates ip maxIpRatePerIp ipRateWindowMs 5000 t
811+ set *ipRates = r.entries
812+ yield r.limited
813+
814+checkPubkeyRateGate = \rateRef pubkey maxRate windowMs t -> atomic do
815+ rates <- *rateRef
816+ let r = checkRate rates pubkey maxRate windowMs 5000 t
817+ set *rateRef = r.entries
818+ yield r.limited
819+
820+checkPairRateGate = \sender recipient t -> atomic do
821+ rates <- *pairRates
822+ let r = checkRate rates (sender ++ "|" ++ recipient) maxPairRatePerPair pairRateWindowMs 5000 t
823+ set *pairRates = r.entries
824+ yield r.limited
825+
826+checkServerRateGate = \server t -> atomic do
827+ rates <- *federationRates
828+ let r = checkRate rates server maxFederationRatePerServer federationRateWindowMs 5000 t
829+ set *federationRates = r.entries
830+ yield r.limited
3095831
3096−computeForwardStatsInner = \b t acc ->
3097− if b > 15 then yield acc
3098− else do
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}
3109−
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
832+checkPreAuth = \clientIp t -> do
833+ dp <- *drainPhase
834+ if dp >= 1 then yield "draining"
3115835 else do
3116− bucket <- readFwdBucket b
3117− let bucketOldest = case minBy bucket (\x -> x.createdAt) of Nothing {} -> 0; Just {value: x} -> t - x.createdAt
3118− oldestForwardAgeAcrossBuckets (b + 1) t (max acc bucketOldest)
3119−
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 ->
3125− if b > 15
3126− then yield (count seen)
836+ g <- checkGlobalRate t
837+ if g then yield "global_rate_limited"
3127838 else do
3128− bucket <- readFwdBucket b
3129− -- Find servers in this bucket with entries older than the threshold
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)
3136−
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 ->
3143− if b > 15 then do
3144− let totalRemoved = count acc
3145− when (totalRemoved > 0) (atomic do
3146− tfc <- *totalForwardCount
3147− set *totalForwardCount = max 0 (tfc - totalRemoved))
3148− yield acc
3149− else do
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))
3155− yield matched
3156− removeForwardsByServer server messageIds (b + 1) (if count removed > 0 then union acc removed else acc)
3157−
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 []
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)
3168−
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
3180−
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
839+ i <- checkIpRateGate clientIp t
840+ if i then yield "ip_rate_limited"
841+ else yield ""
3218842
3219843-- ============================================
3220−-- AckedIds Bucket Helpers
844+-- Federation failure tracking (simple, no circuit breaker)
3221845-- ============================================
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
3232−
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
3243−
3244−readAllAcked : IO [AckedEntry]
3245−readAllAcked = do
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)))))))))))))))
3251−
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
3268−
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)
3272−
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 {}
3278− else do
3279− atomic do
3280− bucket <- readAckedBucket b
3281− writeAckedBucket b (do a <- bucket; where a.ackedAt > retainCutoff; yield a)
3282− pruneAllAckedBuckets (b + 1) retainCutoff
3283−
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
3290− else do
3291− kept <- atomic do
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)
3298−
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)
3307846
3308−-- ============================================
3309−-- DeliveredIds Bucket Helpers
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
3321−
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
3332−
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)))))))))))))))
3340−
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
3357−
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)
3361−
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 {}
3366− else do
3367− atomic do
3368− bucket <- readDelivBucket b
3369− writeDelivBucket b (do d <- bucket; where d.deliveredAt > retainCutoff; yield d)
3370− pruneAllDeliveredBuckets (b + 1) retainCutoff
847+pow2 : Int -> Int
848+pow2 = \n -> if n <= 0 then 1 else 2 * pow2 (n - 1)
3371849
3372−-- ============================================
3373−-- Federation In-Flight Tracking
3374−-- ============================================
3375−-- Tracks outstanding federation fetches per server. Servers with hung requests
3376−-- (older than federationFetchTimeoutMs) are skipped to prevent slot exhaustion.
850+retryBackoff : Int -> Int<Ms>
851+retryBackoff = \failures ->
852+ min retryBackoffMax (retryBackoffBase * pow2 (max 0 (failures - 1)))
3377853
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
859+
860+recordFailure = \server -> do
3379861 t <- now
3380862 atomic do
3381− inFlight <- *federationInFlight
3382− let existing = headOf (do r <- inFlight; where r.server == server; yield r)
863+ failures <- *forwardFailures
864+ let existing = headOf (do f <- failures; where f.server == server; yield f)
3383865 case existing of
3384− Nothing {} -> set *federationInFlight =
3385− let updated = union inFlight [{server: server, count: 1, firstStartedAt: t}] in
3386− if count updated > maxFederationInFlight then evictOneOldest updated (\r -> r.firstStartedAt) else updated
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)
3388−
3389−clearFederationInFlight = \server -> atomic do
3390− inFlight <- *federationInFlight
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)
3392−
3393−hasHungFederationRequest : Text -> Timestamp -> [FederationInFlightEntry] -> Bool
3394−hasHungFederationRequest = \server t inFlight ->
3395− any inFlight (\r -> r.server == server && r.count > 0 && r.firstStartedAt > 0 && t - r.firstStartedAt >= federationFetchTimeoutMs)
3396−
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
3404− atomic do
3405− ac <- *federationActiveConnections
3406− set *federationActiveConnections = ac + 1
3407− markFederationInFlight server
3408− startTime <- now
3409− result <- fetch (federationUrl server) request
3410− clearFederationInFlight server
3411− -- Release global federation connection slot
3412− atomic do
3413− ac <- *federationActiveConnections
3414− set *federationActiveConnections = max 0 (ac - 1)
3415− endTime <- now
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)
3441− yield result
866+ Nothing {} -> set *forwardFailures = union failures [{server: server, failedAt: t, failures: 1, firstFailedAt: t}]
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)
868+
869+clearFailure = \server -> atomic do
870+ failures <- *forwardFailures
871+ set *forwardFailures = do f <- failures; where f.server != server; yield f
872+
873+-- ============================================
874+-- Common utility queries
875+-- ============================================
3442876
3443877clampTtl : Int<S> -> Int<S>
3444878clampTtl = clamp 1 maxPresenceTtl
@@ -3446,5020 +880,1232 @@ clampTtl = clamp 1 maxPresenceTtl
3446880clampTimestamp : Timestamp -> Timestamp -> Timestamp
3447881clampTimestamp = \timestamp t -> clamp (t - messageMaxAge) t timestamp
3448882
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.
3452883effectiveMessageTtl : Int<Ms> -> Int<Ms>
3453884effectiveMessageTtl = \expiresInMs ->
3454885 if expiresInMs <= 0 then unackedMessageMaxAge
3455886 else clamp minMessageTtl unackedMessageMaxAge expiresInMs
3456887
3457−-- Ensure strictly monotonic timestamps for message ordering
3458888nextSeqTs : Timestamp -> Timestamp -> Timestamp
3459889nextSeqTs = \t seqCounter -> if t > seqCounter then t else seqCounter + 1
3460890
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).
3464891dedupMessageIds : [MessageIdHex] -> [MessageIdHex]
3465−dedupMessageIds = \messageIds ->
3466− let capped = takeRelation maxMessageIds messageIds in
3467− fold (\acc mid ->
3468− if any acc (\a -> a == mid) then acc
3469− else union [mid] acc) [] capped
3470−
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
892+dedupMessageIds = \ids ->
893+ let capped = takeRelation maxMessageIds ids in
894+ fold (\acc mid -> if any acc (\a -> a == mid) then acc else union acc [mid]) [] capped
3476895
3477−-- Constant-time string comparison to prevent timing side-channels.
3478−-- Always iterates safeCompareLen characters regardless of input length;
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 ->
3484− if n <= 0
3485− then diff + lenDiff
3486− else
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)
896+presenceForKey = \presence pubkey t ->
897+ do p <- presence; where p.pubkey == pubkey && p.expiresAt > t; yield p
3492898
3493−safeCompare : Text -> Text -> Bool
3494−safeCompare = \a b ->
3495− if take 1 a == "" || take 1 b == "" then False {}
3496− else safeCompareLoop a b safeCompareLen 0 0 == 0
899+bestServerForKey = \entries ->
900+ if any entries (\p -> isLocalServer p.server) then serverHostN
901+ else case maxBy (do p <- entries; where not (isLocalServer p.server); yield p) (\p -> p.expiresAt) of
902+ Just {value: p} -> p.server
903+ Nothing {} -> ""
3497904
3498−-- Constant-time IP binding check: returns True if IPs match or no binding is configured.
3499−-- When a session was created with an IP (behind a proxy), requests without an IP header
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
3508−
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}
3527− else
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}
3533−
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
3543−
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
3551−
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
3559−
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
3567−
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}
3573− else
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
3576− if isNewWindow
3577− then {limited: False {}, entries: union (do r <- entries; where r.ip != ip; yield r) [{ip: ip, keys: [pubkey], windowStart: t}]}
3578− else case entry of
3579− Nothing {} -> {limited: False {}, entries: entries}
3580− Just {value: r} ->
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)}
3586−
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
3594−
3595−-- Extract the item with the smallest key and return both the item and remaining list
3596−extractOldest = \items getKey ->
3597− fold (\acc x ->
3598− case acc.candidate of
3599− Nothing {} -> {candidate: Just {value: x}, items: acc.items}
3600− Just {value: c} ->
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
3605−
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
3620− in r.items
905+hasMessage : MessageIdHex -> PubkeyHex -> [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> Bool
906+hasMessage = \mid toKey items -> any items (\x -> x.messageId == mid && x.toKey == toKey)
3621907
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
3628− in r.items
3629−
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}
3636− else
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
3641− else
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}
3648−
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
3653−
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
3667−
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)
3676− else active
3677−
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
3682− else items
3683−
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
3687−
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))
3692−
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]
3700−collectPeerServers = \items getServer ->
908+collectPeers : [a] -> (a -> Text) -> [Text]
909+collectPeers = \items getServer ->
3701910 fold (\acc item ->
3702911 let s = getServer item in
3703− if isLocalServer s then acc
3704− else if any acc (\a -> a == s) then acc
3705− else union [s] acc) [] items
912+ if isLocalServer s || any acc (\a -> a == s) then acc
913+ else union acc [s]) [] items
914+
915+knownPeerServersFromPresence : [PresenceEntry] -> [Text]
916+knownPeerServersFromPresence = \presence -> collectPeers presence (\p -> p.server)
3706917
3707918samePubkeyServer = \a b -> a.pubkey == b.pubkey && a.server == b.server
3708−pubkeyServer = \e -> {pubkey: e.pubkey, server: e.server}
3709919
3710−-- Upsert items by key, keeping the fresher entry on conflict (last-write-wins by freshness).
3711−-- union [e] filtered prepends (O(1)) vs union filtered [e] which copies filtered (O(|acc|)).
3712−mergeByKey = \sameKey getFreshness initial items ->
920+-- Last-write-wins merge by (pubkey, server), keeping the entry with the larger expiresAt.
921+mergePresence = \existing incoming ->
3713922 fold (\acc e ->
3714− if any acc (\a -> sameKey a e && getFreshness a >= getFreshness e)
3715− then acc
3716− else union [e]
3717− (do a <- acc; where not (sameKey a e); yield a)) initial items
3718−
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 ->
3725− fold (\acc e ->
3726− if any acc (\a -> samePubkeyServer a e && (a.expiresAt > e.expiresAt || (a.expiresAt == e.expiresAt && a.server <= e.server)))
3727− then acc
3728− else union [e]
3729− (do a <- acc; where not (samePubkeyServer a e); yield a)) initial items
3730−
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
3736−
3737−-- Remove presence entries that have a corresponding offline event with a newer timestamp
3738−removeOffline = \presenceSet trustedOffline t ->
3739− diff presenceSet (do
3740− p <- presenceSet
3741− o <- trustedOffline
3742− where samePubkeyServer p o && min o.timestamp t > p.timestamp
3743− yield p)
3744−
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 {}}
3750− else
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 {}}
923+ if any acc (\a -> samePubkeyServer a e && a.expiresAt >= e.expiresAt) then acc
924+ else union (do x <- acc; where not (samePubkeyServer x e); yield x) [e]) existing incoming
3762925
3763−hasMessage : MessageIdHex -> PubkeyHex -> [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> Bool
3764−hasMessage = \mid toKey items -> any items (\x -> x.messageId == mid && x.toKey == toKey)
926+-- ============================================
927+-- Pruning
928+-- ============================================
3765929
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
3779−
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
3787− if expiresAt > t
3788− then [{pubkey: e.pubkey, server: e.server, expiresAt: expiresAt, timestamp: e.timestamp, ttl: ttl}]
3789− else []
3790− else []
3791− in fold (\acc e ->
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
3796−
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
3801−
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
3811− then do
3812− fork (action server)
3813− sendToEachN rest action (effectiveRemaining - 1)
3814− else do
3815− action server
3816− sendToEachN rest action 0
3817−
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}
3830−
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}
3836− else do
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}
3843−
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.
3846930pruneExpired = \t -> do
3847− -- Prune presence per-bucket (16 smaller atomic blocks instead of one large one).
3848− -- Each bucket is independent: all entries for a pubkey hash to the same bucket,
3849− -- so per-bucket before/after comparison is equivalent to the global check.
3850− presenceResults <- prunePresenceBuckets 0 t
3851− -- Dedup peer servers once after collecting from all 16 buckets (O(n) total
3852− -- vs O(n*k) if deduped per-bucket during aggregation).
3853− let dedupServers = \servers -> fold (\acc s -> if any acc (\x -> x == s) then acc else union [s] acc) [] servers
3854− let keptPeers = dedupServers presenceResults.keptPeerServers
3855− let allPeers = dedupServers presenceResults.allPeerServers
3856− atomic do
3857− tpc <- *totalPresenceCount
3858− set *totalPresenceCount = max 0 (tpc - presenceResults.totalRemoved)
3859− set *knownPeerServers = keptPeers
3860− when (presenceResults.totalRemoved > 0) (set *presenceVersion = t)
3861− let presenceResult = {expiredLocal: presenceResults.expiredLocal, peerServers: allPeers}
3862− -- Prune auth state (challenges in their own block; sessions counted during transform)
3863− atomic do
3864− challenges <- *challenges
3865− set *challenges = do x <- challenges; where x.expiresAt > t; yield x
3866− -- Prune sessions and count in a single pass (avoids redundant 16-bucket traversal).
3867− -- pruneAndCountAllSessions applies the filter to each bucket and sums the survivors.
3868− sessionCount <- pruneAndCountAllSessions (\bucket -> do x <- bucket; where x.expiresAt > t && t - x.createdAt < maxSessionLifetime; yield x)
3869− atomic do
3870− set *totalSessionCount = sessionCount
3871− -- Prune messages across all 16 buckets concurrently. Each bucket prune is atomic
3872− -- and touches only its own message bucket + rcBucket. The only shared write is
3873− -- *totalMessageCount (a single Int), so STM contention is minimal.
3874− -- Fork first 15 buckets; run the last one in the foreground to bound concurrency.
3875− -- Uses per-message expiresAt instead of a global cutoff, so sender-specified TTLs
3876− -- are respected during pruning.
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.
3900− atomic do
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.
3913− atomic do
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)
3934− atomic do
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
3949− atomic do
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
3979− set *pendingVerifications = do p <- pending; 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)
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
3998− set *senderExpirations = do e <- senderExp; where t - e.expiredAt < unackedMessageMaxAge; yield e
3999− -- Prune old sender delivery receipts (same retention as expirations)
4000− senderDel <- *senderDeliveries
4001− set *senderDeliveries = do d <- senderDel; where t - d.deliveredAt < unackedMessageMaxAge; yield d
4002− -- Prune old cancel notifications (same retention as delivery receipts)
4003− cancelNotifs <- *cancelNotifications
4004− set *cancelNotifications = do c <- cancelNotifs; where t - c.cancelledAt < unackedMessageMaxAge; yield c
4005− -- Prune stale per-sender drop counters. Without this, drop counters for senders who
4006− -- disconnect permanently persist until capacity eviction pushes them out. Same retention
4007− -- as delivery receipts since drop counters track lost receipts/expirations.
4008− ddr <- *droppedDeliveryReceipts
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
4017−
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
4025− in r.result
931+ expiredLocalKeys <- atomic do
932+ -- challenges
933+ ch <- *challenges
934+ set *challenges = do x <- ch; where x.expiresAt > t; yield x
935+ -- sessions
936+ ses <- *sessions
937+ set *sessions = do x <- ses; where x.expiresAt > t; yield x
938+ -- messages
939+ msgs <- *messages
940+ set *messages = do m <- msgs; where m.expiresAt > t; yield m
941+ -- forwards
942+ fwds <- *forwards
943+ set *forwards = do f <- fwds; where f.expiresAt > t; yield f
944+ -- ackedIds, deliveredIds
945+ aids <- *ackedIds
946+ set *ackedIds = do a <- aids; where t - a.ackedAt < messageMaxAge; yield a
947+ dids <- *deliveredIds
948+ set *deliveredIds = do d <- dids; where t - d.deliveredAt < messageMaxAge; yield d
949+ -- presence: remember locally-expired keys for offline gossip
950+ pres <- *presence
951+ let keptPres = do p <- pres; where p.expiresAt > t; yield p
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
953+ set *presence = keptPres
954+ -- forwardFailures
955+ ff <- *forwardFailures
956+ set *forwardFailures = do f <- ff; where t - f.failedAt < 86400000; yield f
957+ -- activePolls (clean up stale entries beyond 3x poll timeout)
958+ aps <- *activePolls
959+ set *activePolls = do p <- aps; where t - p.startedAt < pollTimeoutMs * 3; yield p
960+ -- pendingVerifications
961+ pv <- *pendingVerifications
962+ set *pendingVerifications = do p <- pv; where t - p.createdAt < verificationTokenExpiry; yield p
963+ -- sender notifications
964+ se <- *senderExpirations
965+ set *senderExpirations = do x <- se; where t - x.expiredAt < unackedMessageMaxAge; yield x
966+ sd <- *senderDeliveries
967+ set *senderDeliveries = do x <- sd; where t - x.deliveredAt < unackedMessageMaxAge; yield x
968+ cn <- *cancelNotifications
969+ set *cancelNotifications = do x <- cn; where t - x.cancelledAt < unackedMessageMaxAge; yield x
970+ pfc <- *pendingFederationCancels
971+ set *pendingFederationCancels = do x <- pfc; where t - x.createdAt < messageMaxAge; yield x
972+ yield expiredLocal
973+ yield expiredLocalKeys
4026974
4027−splitAtN = \items n ->
4028− fold (\acc e ->
4029− if acc.n < n then {n: acc.n + 1, batch: union acc.batch [e], rest: acc.rest}
4030− else {n: acc.n, batch: acc.batch, rest: union acc.rest [e]})
4031− {n: 0, batch: [], rest: []} items
975+-- ============================================
976+-- Federation gossip
977+-- ============================================
4032978
4033−forEachBatch = \items batchSize process ->
4034− if count items == 0 then yield {}
4035− else do
4036− let split = splitAtN items batchSize
4037− process split.batch
4038− forEachBatch split.rest batchSize process
4039−
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.
4044− t0 <- now
4045− failures <- *forwardFailures
4046− inFlight <- *federationInFlight
4047− blocked <- *blockedPeers
4048− if not (shouldRetryServerEx server t0 failures inFlight blocked) then yield {}
4049− else do
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
4057− t <- now
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})
4064− case result of
4065− Err e -> do
4066− logWarn ("federation: gossip to " ++ server ++ " failed: " ++ show e)
4067− recordFailure server
4068− atomic do gs <- *gossipSendFail; set *gossipSendFail = gs + 1
4069− Ok _ -> do
4070− clearFailure server
4071− atomic do gs <- *gossipSendSuccess; set *gossipSendSuccess = gs + 1)
4072−
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.
4078979sendBatchedGossip : [ServerName] -> [GossipEvent] -> Int -> IO {network} {}
4079−sendBatchedGossip = \peerServers allEvents hops ->
4080− sendToEach peerServers (\server -> sendBatchedGossipToServer server allEvents hops)
4081−
4082−broadcastOfflineGossip = \t peerServers expiredLocal ->
4083− when (federationEnabled && count peerServers > 0 && count expiredLocal > 0) (do
4084− failures <- *forwardFailures
4085− if isFederationCircuitOpen failures t
4086− then logWarn ("federation: circuit breaker open, skipping offline gossip broadcast")
4087− else do
4088− let cappedExpired = takeRelation maxPresenceEntries expiredLocal
4089− when (count expiredLocal > maxPresenceEntries)
4090− (logWarn ("gossip: capped offline broadcast to " ++ show maxPresenceEntries ++ " entries (had " ++ show (count expiredLocal) ++ ")"))
4091− let gossipEvents = mergeByKey (\a b -> a.pubkey == b.pubkey) (\x -> x.timestamp) [] (offlineGossipEvents cappedExpired)
4092− sendBatchedGossip peerServers gossipEvents gossipOriginHops)
4093−
4094−-- Build re-broadcast gossip events from validated entries. The seenBy list includes
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
4102− in do
4103− e <- entries
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}
4107−
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}
4119−
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)
4133−
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))
4144−
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)
4150−
4151−effectiveIpRate = do
4152− o <- *rateOverrideIpRate
4153− adaptiveRate (if o > 0 then o else maxIpRatePerIp)
4154−
4155−effectiveSendRate = do
4156− o <- *rateOverrideSendRate
4157− adaptiveRate (if o > 0 then o else maxSendRatePerKey)
4158−
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)
4164−
4165−effectiveAuthGlobalRate = do
4166− o <- *rateOverrideAuthGlobal
4167− adaptiveRate (if o > 0 then o else maxAuthGlobalRate)
4168−
4169−effectiveRecvRate = do
4170− o <- *rateOverrideRecvRate
4171− adaptiveRate (if o > 0 then o else maxRecvRatePerKey)
4172−
4173−effectiveChallengeRate = do
4174− o <- *rateOverrideChallengeRate
4175− adaptiveRate (if o > 0 then o else maxChallengeRatePerKey)
4176−
4177−effectivePairRate = do
4178− o <- *rateOverridePairRate
4179− adaptiveRate (if o > 0 then o else maxPairRatePerPair)
4180−
4181−effectiveLookupRate = do
4182− o <- *rateOverrideLookupRate
4183− adaptiveRate (if o > 0 then o else maxLookupRatePerKey)
4184−
4185−effectiveClientWriteRate = do
4186− o <- *rateOverrideClientWriteRate
4187− adaptiveRate (if o > 0 then o else maxClientWriteRatePerKey)
4188−
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)
4194−
4195−effectiveMaxGossipHops = do
4196− o <- *configOverrideMaxGossipHops
4197− yield (if o > 0 then o else maxGossipHops)
4198−
4199−effectivePollTimeoutMs = do
4200− o <- *configOverridePollTimeoutMs
4201− yield (if o > 0 then o else pollTimeoutMs)
4202−
4203−effectiveAckGracePeriod : IO Int<Ms>
4204−effectiveAckGracePeriod = do
4205− o <- *configOverrideAckGracePeriod
4206− yield (if o > 0 then o else ackGracePeriod)
4207−
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
4217−
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
4225− then do
4226− set *globalRateWindowStart = t
4227− set *globalRatePrevCount = rateCount
4228− set *globalRateCount = 1
4229− yield (False {})
4230− else do
4231− -- Sliding window: interpolate previous window's count
4232− let prevWeight = prevCount * (globalRateWindowMs - elapsed) / globalRateWindowMs
4233− if prevWeight + rateCount >= effectiveRate
4234− then do
4235− rlg <- *rateLimitedGlobal
4236− set *rateLimitedGlobal = rlg + 1
4237− yield (True {})
4238− else do
4239− set *globalRateCount = rateCount + 1
4240− yield (False {})
980+sendBatchedGossip = \peers events hops ->
981+ case headOf peers of
982+ Nothing {} -> yield {}
983+ Just {value: server} -> do
984+ let rest = do s <- peers; where s != server; yield s
985+ t <- now
986+ failures <- *forwardFailures
987+ when (shouldRetryServer server t failures) (do
988+ auth <- generateFederationAuth "gossip" t
989+ result <- fetch (federationUrl server) (RecvGossip {
990+ authorization: auth,
991+ events: events, hopsRemaining: hops, fromServer: serverHostN,
992+ requestTimestamp: t, correlationId: "", protocolVersion: federationProtocolVersion})
993+ case result of
994+ Err _ -> recordFailure server
995+ Ok _ -> clearFailure server)
996+ sendBatchedGossip rest events hops
4241997
4242−-- Auth-tier global rate limiting (shared budget for challenge + verify + revoke)
4243−checkAuthGlobalRate = \t -> atomic do
4244− windowStart <- *authGlobalRateWindowStart
4245− rateCount <- *authGlobalRateCount
4246− prevCount <- *authGlobalRatePrevCount
4247− authRate <- effectiveAuthGlobalRate
4248− let elapsed = t - windowStart
4249− if elapsed >= authGlobalRateWindowMs
4250− then do
4251− set *authGlobalRateWindowStart = t
4252− set *authGlobalRatePrevCount = rateCount
4253− set *authGlobalRateCount = 1
4254− yield (False {})
4255− else do
4256− let prevWeight = prevCount * (authGlobalRateWindowMs - elapsed) / authGlobalRateWindowMs
4257− if prevWeight + rateCount >= authRate
4258− then do
4259− rla <- *rateLimitedAuth
4260− set *rateLimitedAuth = rla + 1
4261− yield (True {})
4262− else do
4263− set *authGlobalRateCount = rateCount + 1
4264− yield (False {})
4265−
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
4273− then do
4274− set *healthRateWindowStart = t
4275− set *healthRatePrevCount = rateCount
4276− set *healthRateCount = 1
4277− yield (False {})
4278− else do
4279− let prevWeight = prevCount * (healthRateWindowMs - elapsed) / healthRateWindowMs
4280− if prevWeight + rateCount >= maxHealthRate
4281− then yield (True {})
4282− else do
4283− set *healthRateCount = rateCount + 1
4284− yield (False {})
4285−
4286−-- IP-based rate limiting; skips if clientIp header is empty (no reverse proxy)
4287−checkClientIpRate = \ip t ->
4288− if ip == "" then yield (False {})
4289− else atomic do
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
4298−
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
4302− dp <- *drainPhase
4303− if dp >= 1 then yield "draining"
4304− else do
4305− globalLimited <- checkGlobalRate t
4306− if globalLimited then yield "global_rate_limited"
4307− else do
4308− ipLimited <- checkClientIpRate clientIp t
4309− if ipLimited then yield "ip_rate_limited"
4310− else yield ""
998+broadcastOfflineGossip = \t expiredLocal -> do
999+ presence <- *presence
1000+ let peers = knownPeerServersFromPresence presence
1001+ when (federationEnabled && count peers > 0 && count expiredLocal > 0) (do
1002+ let events = do p <- expiredLocal; yield {eventType: GossipOffline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}
1003+ sendBatchedGossip peers events gossipOriginHops)
43111004
43121005-- ============================================
4313−-- Ed25519 Federation Signing
1006+-- Forward retries and acks
43141007-- ============================================
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.
4319−
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
4323− t <- now
4324− healthLimited <- checkHealthRate t
4325− if healthLimited then yield (respond {pubkey: "", ok: False {}})
4326− else yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})
4327−
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))
4337− case cached of
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
4342− then yield ""
4343− else fetchAndCachePeerKey server t
4344− Nothing {} -> fetchAndCachePeerKey server t
4345−
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 {})
4351− case result of
4352− Err e -> do
4353− logWarn ("federation: pubkey fetch from " ++ server ++ " failed: " ++ show e)
4354− atomic do
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
4358− yield ""
4359− Ok r ->
4360− if r.ok && r.pubkey != "" then do
4361− atomic 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
4365− yield r.pubkey
4366− else do
4367− atomic do
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
4371− yield ""
4372−
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
4379− t <- now
4380− pubkeyHex <- fetchPeerPublicKey fromServer t
4381− if pubkeyHex == "" then yield (False {})
4382− else do
4383− let message = textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer)
4384− yield (verify (bytesFromHex pubkeyHex) message (bytesFromHex signatureHex))
43851008
4386−-- Verify signature with nonce (new format: prevents replay of same-millisecond requests).
4387−verifyFederationSignatureWithNonce : Text -> Text -> Text -> Text -> Timestamp -> IO {network} Bool
4388−verifyFederationSignatureWithNonce = \fromServer signatureHex nonce scope requestTimestamp -> do
1009+retryPendingForwards : IO {network} {}
1010+retryPendingForwards = do
43891011 t <- now
4390− pubkeyHex <- fetchPeerPublicKey fromServer t
4391− if pubkeyHex == "" then yield (False {})
4392− else do
4393− let message = textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer ++ "|" ++ nonce)
4394− yield (verify (bytesFromHex pubkeyHex) message (bytesFromHex signatureHex))
4395−
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
1012+ fwds <- *forwards
1013+ failures <- *forwardFailures
44051014 blocked <- *blockedPeers
4406− if isBlockedPeer fromServer blocked
4407− then do
4408− logWarn ("federation: blocked peer " ++ fromServer ++ " rejected")
4409− yield (respond {ok: False {}, error: "blocked", retryAfterMs: 0})
4410− else do
4411− allowed <- *allowedPeers
4412− if not (isAllowedByAllowlist fromServer allowed)
4413− then do
4414− logWarn ("federation: peer " ++ fromServer ++ " not in allowlist, rejected")
4415− yield (respond {ok: False {}, error: "not_allowed", retryAfterMs: 0})
4416− else do
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 "
4421− then do
4422− let payload = drop 7 authorization
4423− if payload == "" || tooLong payload (maxSignatureLen + 25)
4424− then yield (False {})
4425− else
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
4431− if not verified
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)
4436− then do
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})
4441− else do
4442− -- Replay detection: reject duplicate (server, timestamp) pairs within the skew window
4443− replayDetected <- if requestTimestamp > 0
4444− then atomic do
4445− recent <- *recentFederationRequests
4446− let isDup = any recent (\r -> r.server == fromServer && r.timestamp == requestTimestamp)
4447− if isDup then yield (True {})
4448− else do
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
4452− yield (False {})
4453− else yield (False {})
4454− if replayDetected
4455− then do
4456− logWarn ("federation: replay detected from " ++ fromServer ++ " (timestamp: " ++ show requestTimestamp ++ ")")
4457− yield (respond {ok: False {}, error: "replay_detected", retryAfterMs: 0})
4458− else do
4459− globalLimited <- checkGlobalRate t
4460− if globalLimited
4461− then do
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})
4467− else do
4468− rateLimited <- checkFederationRate fromServer t
4469− if rateLimited
4470− then do
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})
4474− else do
4475− when clearOnAuth (clearFailure fromServer)
4476− action
4477−
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)
4488− then onUnauth
4489− else do
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)
4497− when needsRefresh
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)))
4502− onAuth pubkey
4503−
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
4511− then do
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: []}
4523−
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
4529− t <- now
4530− dp <- *drainPhase
4531− if dp >= 2
4532− then logInfo (label ++ ": last session for " ++ r.pubkey ++ " (drain active, skipping redundant offline gossip)")
4533− else do
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)))
4537−
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))
4547−
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
4554−
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
4563− atomic do
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))
4574− yield rf
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
4586−
4587−pow2 : Int -> Int
4588−pow2 = \n -> if n <= 0 then 1 else 2 * pow2 (n - 1)
4589−
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)))
4594−
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)
4603−
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
4609−
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)
4614−
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
1015+ -- Group by server
1016+ let servers = collectPeers fwds (\f -> f.toServer)
1017+ let eligibleServers = do s <- servers; where shouldRetryServer s t failures && not (isBlockedPeer s blocked); yield s
1018+ retryServerForwards eligibleServers fwds
46221019
4623−recordFailure = \server -> do
4624− t <- now
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)
4631− atomic do
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
4638−
4639−clearFailure = \server -> do
4640− t <- now
4641− atomic do
4642− failures <- *forwardFailures
4643− set *forwardFailures = do f <- failures; where f.server != server; yield f
4644− set *lastFederationSuccessAt = t
4645−
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)
4651− if shouldDrop
4652− then do
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))
4658−
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 {}
4664− else do
4665− t <- now
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 {}
4672− else do
4673− let server = case headOf liveEntries of Just {value: f} -> f.toServer; Nothing {} -> ""
4674− forEachBatch liveEntries maxBatchSize (\batch -> do
4675− t <- now
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})
4682− case result of
4683− Err e -> do
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).
4690− yield {}
4691− Ok response -> do
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
4696− else do
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)
4702−
4703−-- Increment retry counts for all entries in a failed batch
4704−retryForwardsBatchIncrement = \batch server ->
4705− case headOf batch of
1020+retryServerForwards = \servers fwds ->
1021+ case headOf servers of
47061022 Nothing {} -> yield {}
4707− Just {value: f} -> do
4708− let rest = do x <- batch; where x.messageId != f.messageId; yield x
4709− incrementForwardRetries f.messageId server f.toKey
4710− retryForwardsBatchIncrement rest server
4711−
4712−-- Fallback: send forwards individually when batch forward is rejected (old peer).
4713−-- Each message gets its own auth token and HTTP round-trip. On success, removes the
4714−-- forward entry; on failure, increments retries (same as batch per-message failure).
4715−retryForwardsSingle = \batch server ->
4716− case headOf batch of
1023+ Just {value: server} -> do
1024+ let rest = do s <- servers; where s != server; yield s
1025+ let serverFwds = takeRelation maxBatchSize (do f <- fwds; where f.toServer == server; yield f)
1026+ sendForwardsToServer serverFwds server
1027+ retryServerForwards rest fwds
1028+
1029+sendForwardsToServer = \fwds server ->
1030+ case headOf fwds of
47171031 Nothing {} -> yield {}
47181032 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
47201034 t <- now
47211035 auth <- generateFederationAuth ("forward:" ++ f.messageId) t
4722− corrId <- genTokenN 1
4723− result <- fetchFederation server (ForwardMessage {
1036+ result <- fetch (federationUrl server) (ForwardMessage {
47241037 toKey: f.toKey, encryptedBlob: f.encryptedBlob,
47251038 timestamp: f.timestamp, originServer: f.originServer, messageId: f.messageId,
47261039 fromServer: serverHostN, requestTimestamp: t,
4727− authorization: auth, correlationId: corrId,
1040+ authorization: auth, correlationId: "",
47281041 expiresAt: f.expiresAt, priority: f.priority, protocolVersion: federationProtocolVersion})
47291042 case result of
4730− Err e -> do
4731− logKV "warn" "federation_single_forward_failed" ["server=" ++ server, "messageId=" ++ f.messageId, "error=" ++ show e]
1043+ Err _ -> do
47321044 recordFailure server
4733− Ok response ->
4734− if response.ok then do
4735− removeForward f.messageId server f.toKey
4736− clearFailure server
4737− else incrementForwardRetries f.messageId server f.toKey
4738− retryForwardsSingle rest server
4739−
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)
4747− case msgResult of
4748− Just {value: r} ->
1045+ atomic do
1046+ cur <- *forwards
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)
1048+ cur2 <- *forwards
1049+ set *forwards = do x <- cur2; where not (x.messageId == f.messageId && x.toServer == server && x.retries >= maxForwardRetries); yield x
1050+ Ok r ->
47491051 if r.ok then do
4750− removeForward f.messageId server f.toKey
4751− retryForwardsBatchResults rest results server
4752− else do
4753− incrementForwardRetries f.messageId server f.toKey
4754− retryForwardsBatchResults rest results server
4755− Nothing {} -> do
4756− -- No result for this message (shouldn't happen) — increment retry
4757− incrementForwardRetries f.messageId server f.toKey
4758− retryForwardsBatchResults rest results server
4759−
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 []
4765− else do
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)
4770−
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)
4787− probeStart <- now
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})
4793− case result of
4794− Err e -> logWarn ("federation: half-open probe to " ++ candidate.server ++ " failed: " ++ show e)
4795− Ok _ -> do
4796− logInfo ("federation: half-open probe to " ++ candidate.server ++ " succeeded, clearing failure")
4797− clearFailure candidate.server
4798−
4799−retryPendingForwardsFromBuckets : IO {network} {}
4800−retryPendingForwardsFromBuckets = do
4801− t <- now
4802− failures <- *forwardFailures
4803− if isFederationCircuitOpen failures t
4804− then do
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
4809− else do
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 {}
4818− else do
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
4828− Just {value: f} ->
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
4854−
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
4886− yield 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")
4891− else do
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
4897−
4898−fetchFederationAck = \origin messageIds -> do
4899− t <- now
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})
4907−
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))
4929− yield dropCount
4930− incrementAckRetriesPerBucket remainingBuckets server batch (droppedAcc + bucketDropped)
4931−
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
4938− atomic do
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
4942−
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)
4947− case result of
4948− Err e -> do
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
4955− when (dropped > 0)
4956− (logWarn ("federation: dropped " ++ show dropped ++ " ack entries to " ++ server ++ " after " ++ show maxAckRetries ++ " retries"))
4957− Ok _ -> do
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)
4962−
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} {}
1052+ clearFailure server
1053+ atomic do
1054+ cur <- *forwards
1055+ set *forwards = do x <- cur; where not (x.messageId == f.messageId && x.toServer == server); yield x
1056+ else atomic do
1057+ cur <- *forwards
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)
1059+ sendForwardsToServer rest server
1060+
1061+sendAcksAndClean : [AckedEntry] -> IO {network} {}
49651062sendAcksAndClean = \pendingAcks ->
49661063 if count pendingAcks == 0 then yield {}
49671064 else do
4968− let servers = collectPeerServers pendingAcks (\a -> a.originServer)
4969− t <- now
4970− failures <- *forwardFailures
4971− if isFederationCircuitOpen failures t
4972− then logWarn ("federation: circuit breaker open, skipping ack retries")
4973− else do
4974− inFlight <- *federationInFlight
4975− blocked <- *blockedPeers
4976− let eligibleServers = do s <- servers; where shouldRetryServerEx s t failures inFlight blocked; yield s
4977− sendToEach eligibleServers (\server ->
4978− sendBatchedAcksToServer (acksForServer pendingAcks server) server)
4979−
4980−-- Retry sending acks that were evicted from ackedIds due to capacity limits.
4981−-- On failure, re-insert into ackedIds or overflow buffer; overflow entries eventually
4982−-- move to deliveredIds (terminal dedup state) if the buffer is also full.
4983−retryEvictedAcks = \evictedEntries pendingAcks ->
4984− let evictedToRetry = retriableEvictedAcks evictedEntries pendingAcks
4985− in do
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
4990− Err e -> do
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
4997− if excess <= 0
4998− then do writeAllAcked combined; yield []
4999− else do
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
5010− else do
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
5022− when (dropped > 0)
5023− (logWarn ("ackMessages: overflow at capacity (" ++ show maxAckOverflow ++ "), " ++ show dropped ++ " ack entries moved to delivered set for " ++ server)))
5024− Ok _ -> yield {})
5025−
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)
5029− t <- now
5030− failures <- *forwardFailures
5031− if isFederationCircuitOpen failures t
5032− then logWarn ("federation: circuit breaker open, skipping overflow ack retries")
5033− else do
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)
1065+ let servers = collectPeers pendingAcks (\a -> a.originServer)
1066+ sendAcksToEach servers pendingAcks
1067+
1068+sendAcksToEach = \servers acks ->
1069+ case headOf servers of
1070+ Nothing {} -> yield {}
1071+ Just {value: server} -> do
1072+ let rest = do s <- servers; where s != server; yield s
1073+ let serverAcks = do a <- acks; where a.originServer == server; yield a
1074+ let mids = do a <- serverAcks; yield a.messageId
1075+ t <- now
1076+ auth <- generateFederationAuth "ack" t
1077+ result <- fetch (federationUrl server) (FederationAck {
1078+ authorization: auth,
1079+ messageIds: mids, originServer: server, fromServer: serverHostN,
1080+ requestTimestamp: t, correlationId: "", protocolVersion: federationProtocolVersion})
50401081 case result of
5041− Err e -> do
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))
5058− yield dropCount
5059− when (dropped > 0)
5060− (logWarn ("federation: dropped " ++ show dropped ++ " overflow ack entries to " ++ server ++ " after " ++ show maxAckRetries ++ " retries"))
1082+ Err _ -> recordFailure server
50611083 Ok _ -> do
50621084 clearFailure server
50631085 atomic do
5064− ackOverflow <- *ackOverflow
5065− set *ackOverflow = do a <- ackOverflow; where not (a.originServer == server && hasMessage a.messageId a.toKey batch); yield a))
5066−
5067−-- Queue a single failed cancel for retry during the next prune cycle.
5068−queuePendingCancel = \messageId toKey server t -> atomic do
5069− pcs <- *pendingFederationCancels
5070− -- Dedup: don't queue if already pending for the same (messageId, toKey, server)
5071− let isDup = any pcs (\c -> c.messageId == messageId && c.toKey == toKey && c.toServer == server)
5072− when (not isDup) (do
5073− let updated = union pcs [{messageId: messageId, toKey: toKey, toServer: server, createdAt: t, retries: 0}]
5074− set *pendingFederationCancels = if count updated > maxPendingCancels
5075− then evictOneOldest updated (\c -> c.createdAt)
5076− else updated)
5077−
5078−-- Queue multiple failed cancels for retry (batch cancel failure).
5079−queuePendingCancels = \cancels server t ->
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
5086−
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
5091− t <- now
5092− pending <- *pendingFederationCancels
5093− if count pending == 0 then yield {}
5094− else do
5095− failures <- *forwardFailures
5096− if isFederationCircuitOpen failures t
5097− then logWarn "federation: circuit breaker open, skipping cancel retries"
5098− else do
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
5106− cancelT <- now
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})
5114− case result of
5115− Err e -> do
5116− logWarn ("federation: cancel retry to " ++ server ++ " failed: " ++ show e)
5117− recordFailure server
5118− incrementCancelRetries batch server
5119− Ok r ->
5120− if r.ok then do
5121− clearFailure server
5122− removePendingCancels batch server
5123− else do
5124− logWarn ("federation: cancel retry to " ++ server ++ " rejected: " ++ r.error)
5125− incrementCancelRetries batch server))
5126−
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)
5137−
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
5142−
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
5148− t <- now
5149− let remaining = deadline - t
5150− atomic do set *drainTimedOut = False {}
5151− -- Fork a timer that sets the timeout signal after the deadline
5152− fork (do
5153− when (remaining > 0) (sleep remaining)
5154− atomic do set *drainTimedOut = True {})
5155− -- Block until either all in-flight complete or timeout fires
5156− atomic do
5157− timedOut <- *drainTimedOut
5158− if timedOut then yield {}
5159− else do
5160− inFlight <- *federationInFlight
5161− let activeCount = fold (\acc r -> acc + r.count) 0 inFlight
5162− if activeCount <= 0 then yield {}
5163− else retry
5164− timedOut <- *drainTimedOut
5165− when timedOut (do
5166− logWarn "drain: timed out waiting for in-flight federation tasks"
5167− t2 <- now
5168− inFlight <- *federationInFlight
5169− let hungSlots = do r <- inFlight; where r.count > 0; yield r
5170− when (count hungSlots > 0) (logStaleInFlight hungSlots t2))
5171−
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
5176− atomic 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.
5205− pc <- *pruneCount
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
5231− if arq > 0 then do
5232− lastCompleted <- *lastRequestCompletedAt
5233− if lastCompleted > 0 && t - lastCompleted > pollTimeoutMs * 3
5234− then do
5235− set *activeRequests = 0
5236− yield arq
5237− else yield 0
5238− else yield 0
5239− when (arqLeak > 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
5252− then do
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 {}}
5272− else do
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 {}}
5285− else do
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)
5303− atomic do
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
5362− yield ready
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
5371− fork (do
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
5386− yield {}
5387−
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
5400−
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))
5407−
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
5427−
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
5446−
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
5455− if ackCount > 0
5456− then do
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
5485− if overCap then do
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: []}
5500−
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)
5511− else 0
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)
5520− let evts = do
5521− m <- limitedMsgs
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}
5532−
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
5540− t <- now
5541− let bucket = tokenBucket token
5542− setup <- atomic do
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 {})
5549− else do
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)
5555− when needsRefresh
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}})
5565− case setup of
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 {})
5574− else do
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}]
5578− yield (True {})
5579− if not acquired
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 {}}
5582− else do
5583− pollResult <- do
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
5588− then do
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}
5595− Nothing {} -> do
5596− -- Phase 2: wait for signal or heartbeat
5597− atomic do
5598− wakeup <- *pollWakeup
5599− signal <- readMessageSignal s.pubkey
5600− if wakeup > s.startWakeup || signal > s.startSignal
5601− then yield {}
5602− else retry
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.
5607− t2 <- now
5608− result <- atomic do
5609− dp <- *drainPhase
5610− if dp >= 2 then yield {authorized: True {}, events: [], cursor: s.clampedCursor, hasMore: False {}}
5611− else do
5612− sessions2 <- readSessionBucket bucket
5613− if not (reauthenticateSession sessions2 token s.pubkey t2)
5614− then yield {authorized: False {}, events: [], cursor: s.clampedCursor, hasMore: False {}}
5615− else do
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.
5623− atomic do
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}
1086+ cur <- *ackedIds
1087+ set *ackedIds = do a <- cur; where not (a.originServer == server && any mids (\m -> m == a.messageId)); yield a
1088+ sendAcksToEach rest acks
1089+
1090+-- Forward queued messages to a server when a remote key comes online.
1091+forwardQueuedToServer = \pubkey server t -> atomic do
1092+ msgs <- *messages
1093+ fwds <- *forwards
1094+ let candidates = do
1095+ m <- msgs
1096+ where m.toKey == pubkey
1097+ where none fwds (\f -> f.messageId == m.messageId && f.toServer == server)
1098+ let origin = if m.originServer == "" then serverHostN else m.originServer
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}
1100+ let capped = takeRelation maxForwardsPerServer candidates
1101+ set *forwards = capList (union fwds capped) maxForwardsEntries (\f -> f.createdAt)
56271102
56281103-- ============================================
5629−-- Derived Relations
1104+-- Background loops
56301105-- ============================================
5631−-- Pure query functions over in-memory state. No side effects.
5632−
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
5636−
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
5640−
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
56441106
5645−-- Local presence entries that expired during this prune cycle (for offline gossip)
5646−expiredLocalPresence = \before after t ->
5647− do p <- before; where p.expiresAt <= t && isLocalServer p.server && none after (\q -> q.pubkey == p.pubkey && isLocalServer q.server); yield p
5648−
5649−-- Resolve the best server for a pubkey: prefer local, otherwise pick the remote with latest expiry
5650−bestServerForKey = \entries ->
5651− if any entries (\p -> isLocalServer p.server) then serverHostN
5652− else case maxBy (do p <- entries; where not (isLocalServer p.server); yield p) (\p -> p.expiresAt) of
5653− Just {value: p} -> p.server
5654− Nothing {} -> ""
1107+pruneAndRetry = \t -> do
1108+ atomic do set *lastPrunedAt = t
1109+ expiredLocal <- pruneExpired t
1110+ fork (broadcastOfflineGossip t expiredLocal)
1111+ when federationEnabled (fork retryPendingForwards)
1112+ when federationEnabled (do
1113+ aids <- *ackedIds
1114+ let pendingAcks = do a <- aids; where not (isLocalServer a.originServer); yield a
1115+ fork (sendAcksAndClean pendingAcks))
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)
1121+ yield {}
56551122
5656−-- Messages for a pubkey newer than cursor and not expired (per-message expiresAt)
5657−pollableMessages = \messages pubkey cursor t ->
5658− do m <- messages; where m.toKey == pubkey && m.expiresAt > t && m.receivedAt > cursor; yield m
5659−
5660−-- Build ack entries for messages that came from a remote origin server (need federation ack)
5661−federatedAckEntries = \ackedMessages t ->
5662− do m <- ackedMessages; where m.originServer != ""; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
5663−
5664−-- Remove forwards for specific message IDs destined to a given server
5665−forwardsExcluding = \forwards server messageIds ->
5666− do f <- forwards; where not (f.toServer == server && any messageIds (\mid -> f.messageId == mid)); yield f
5667−
5668−-- Find messages that haven't been forwarded yet to each target's server.
5669−-- Includes relay: messages received via federation (originServer != "") can be
5670−-- re-forwarded when the recipient moves to a different server. Cascade is bounded
5671−-- by dedup (same messageId won't be forwarded to the same server twice).
5672−forwardCandidates = \targets messages forwards t ->
5673− fold (\acc target ->
5674− let serverFwdIds = do f <- forwards; where f.toServer == target.server; yield f.messageId in
5675− union acc (do
5676− m <- messages
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
5683−
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)
5693−
5694−challengesExcluding = \challenges pubkey challenge ->
5695− do c <- challenges; where c.pubkey != pubkey || c.challenge != challenge; yield c
5696−
5697−hasLocalPresence = \entries -> any entries (\p -> isLocalServer p.server)
5698−
5699−ackedIdsExcludingBatch = \ackedIds server batch ->
5700− do a <- ackedIds; where not (a.originServer == server && hasMessage a.messageId a.toKey batch); yield a
5701−
5702−retriableEvictedAcks = \evictedEntries pendingAcks ->
5703− do a <- evictedEntries; where not (hasMessage a.messageId a.toKey pendingAcks); yield a
5704−
5705−acksForServer = \acks server -> do a <- acks; where a.originServer == server; yield a
5706−
5707−forwardsForServer = \forwards server -> do f <- forwards; where f.toServer == server; yield f
5708−
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
5722− sleep jitter
5723− retryForwardsForServer serverForwards maxRetries
5724− sendForwardsPartitioned remaining rest maxRetries
5725−
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
5729−
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
5733−
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}
5740−
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}
5753−
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)
5757−
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
5761−
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
5765−
5766−-- Generate offline gossip events for locally-expired presence entries
5767−offlineGossipEvents = \expiredLocal -> do
5768− p <- expiredLocal
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]}
5771−
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
1123+refreshLocalPresence = \t -> do
1124+ refreshState <- atomic do
1125+ sessions <- *sessions
1126+ presence <- *presence
1127+ let activeKeys = fold (\acc s -> if any acc (\a -> a == s.pubkey) then acc else union acc [s.pubkey]) [] sessions
1128+ let updated = do
1129+ p <- presence
1130+ yield (if isLocalServer p.server && any activeKeys (\k -> k == p.pubkey) && p.expiresAt - t < sessionExpiry / 2
1131+ then {pubkey: p.pubkey, server: p.server, expiresAt: t + sessionExpiry, timestamp: t}
1132+ else p)
1133+ set *presence = updated
1134+ let refreshed = do p <- updated; where isLocalServer p.server && p.expiresAt == t + sessionExpiry; yield p
1135+ let peers = knownPeerServersFromPresence updated
1136+ yield {refreshed: refreshed, peers: peers}
1137+ when (count refreshState.refreshed > 0 && count refreshState.peers > 0) (do
1138+ let events = do p <- refreshState.refreshed; yield {eventType: GossipOnline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: clampTtl (sessionExpiry / 1000), seenBy: [serverHostN]}
1139+ fork (sendBatchedGossip refreshState.peers events gossipOriginHops))
57751140
57761141-- ============================================
5777−-- Request Handler
1142+-- Handler: challenge / verify / revoke / logout
57781143-- ============================================
57791144
5780−-- POST /auth/challenge: Generate a random challenge for Ed25519 authentication.
5781−-- Rate-limited per key; globally capped. Challenge expires in 1 minute.
57821145handleChallenge = \pubkey clientIp respond -> do
57831146 t <- now
5784− -- Reject challenges without ClientIp when requireClientIp is enabled.
5785− -- Prevents creating sessions with no IP binding (permanently accept from any IP).
57861147 if requireClientIp && clientIp == ""
5787− then do
5788− logEvent "warn" "missing_client_ip" ("endpoint=challenge key=" ++ pubkey)
5789− yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: "client_ip_required"})
1148+ then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: "client_ip_required"})
57901149 else do
57911150 preAuth <- checkPreAuth clientIp t
5792− if preAuth != ""
5793− then do
5794− when (preAuth == "ip_rate_limited") (logEvent "warn" "rate_limited_ip" ("endpoint=challenge ip=" ++ clientIp))
5795− yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: preAuth})
1151+ if preAuth != "" then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: preAuth})
1152+ else do
1153+ authLimited <- checkAuthGlobalRate t
1154+ if authLimited then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: "auth_rate_limited"})
57961155 else do
5797− authLimited <- checkAuthGlobalRate t
5798− if authLimited then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: "auth_rate_limited"})
5799− else do
58001156 challenge <- genToken
58011157 result <- atomic do
5802− challenges <- *challenges
5803− let active = do c <- challenges; where c.expiresAt > t; yield c
1158+ ch <- *challenges
1159+ let active = do c <- ch; where c.expiresAt > t; yield c
58041160 let activeForKey = count (do c <- active; where c.pubkey == pubkey; yield c)
58051161 let cappedActive = if activeForKey >= maxChallengesPerKey
5806− then let forKey = do c <- active; where c.pubkey == pubkey; yield c in
5807− let others = do c <- active; where c.pubkey != pubkey; yield c in
5808− union others (evictOneOldest forKey (\c -> c.expiresAt))
5809− else active
5810− if count cappedActive >= maxChallenges
5811− then yield {accepted: False {}, rateLimited: False {}, retryAfterMs: 0, error: "capacity"}
1162+ then evictOldest active (\c -> if c.pubkey == pubkey then c.expiresAt else 999999999999)
1163+ else active
1164+ if count cappedActive >= maxChallenges then yield {ok: False {}, error: "capacity"}
1165+ else do
1166+ rates <- *challengeRates
1167+ let r = checkRate rates pubkey maxChallengeRatePerKey challengeRateWindowMs 5000 t
1168+ if r.limited then yield {ok: False {}, error: "rate_limited"}
58121169 else do
5813− challengeRates <- *challengeRates
5814− chalRate <- effectiveChallengeRate
5815− let rateResult = checkPubkeyRate challengeRates pubkey chalRate challengeRateWindowMs maxChallengeRateEntries t
5816− if rateResult.limited
5817− then yield {accepted: False {}, rateLimited: True {}, retryAfterMs: rateResult.retryAfterMs, error: "rate_limited:" ++ show challengeRateWindowMs ++ "ms"}
5818− else do
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})
5828−
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).
1170+ set *challengeRates = r.entries
1171+ set *challenges = union cappedActive [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry, ip: clientIp}]
1172+ yield {ok: True {}, error: ""}
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})
1174+
58321175handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp respond -> do
58331176 t <- now
58341177 preAuth <- checkPreAuth clientIp t
5835− if preAuth != ""
5836− then do
5837− when (preAuth == "ip_rate_limited") (logEvent "warn" "rate_limited_ip" ("endpoint=verify ip=" ++ clientIp))
5838− yield (respond {token: "", expiresAt: 0, error: preAuth})
1178+ if preAuth != "" then yield (respond {token: "", expiresAt: 0, error: preAuth})
1179+ else do
1180+ authLimited <- checkAuthGlobalRate t
1181+ if authLimited then yield (respond {token: "", expiresAt: 0, error: "auth_rate_limited"})
58391182 else do
5840− authRateLimited <- atomic do
5841− challengeRates <- *challengeRates
5842− chalRate <- effectiveChallengeRate
5843− let rateResult = checkPubkeyRate challengeRates pubkey chalRate challengeRateWindowMs maxChallengeRateEntries t
5844− set *challengeRates = rateResult.entries
5845− yield rateResult.limited
5846− if authRateLimited then do
5847− effChal <- effectiveChallengeRate
5848− logEvent "warn" "rate_limited_per_key" ("endpoint=verify key=" ++ pubkey ++ " limit=" ++ show effChal)
5849− yield (respond {token: "", expiresAt: 0, error: "rate_limited:" ++ show challengeRateWindowMs ++ "ms"})
1183+ let expiry = t + sessionExpiry
1184+ token <- genToken
1185+ result <- atomic do
1186+ ch <- *challenges
1187+ let hasMatch = any ch (\c -> c.pubkey == pubkey && safeCompare c.challenge challenge && c.expiresAt > t && matchIp clientIp c.ip)
1188+ if not hasMatch then yield {valid: False {}, peers: []}
1189+ else
1190+ if not (verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature))
1191+ then yield {valid: False {}, peers: []}
1192+ else do
1193+ set *challenges = do c <- ch; where c.pubkey != pubkey || c.challenge != challenge; yield c
1194+ dp <- *drainPhase
1195+ if dp >= 1 then yield {valid: False {}, peers: []}
1196+ else do
1197+ ses <- *sessions
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))
1204+ else kept
1205+ let newSession = {token: token, pubkey: pubkey, expiresAt: expiry, ip: clientIp, createdAt: t}
1206+ set *sessions = capList (union afterPerKey [newSession]) maxSessions (\s -> s.expiresAt)
1207+ pres <- *presence
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"})
58501214 else do
5851− authGlobalLimited <- checkAuthGlobalRate t
5852− if authGlobalLimited then yield (respond {token: "", expiresAt: 0, error: "auth_rate_limited"})
1215+ when federationEnabled
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: ""})
1218+
1219+handleRevoke = \targetToken authorization clientIp respond -> do
1220+ t <- now
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 {}}))
1225+ (\caller -> do
1226+ result <- atomic do
1227+ ses <- *sessions
1228+ let found = any ses (\s -> s.pubkey == caller && safeCompare s.token targetToken)
1229+ if not found then yield False
58531230 else do
5854− -- Per-IP unique key abuse detection: reject IPs authenticating too many distinct pubkeys
5855− uniqueKeyLimited <- atomic do
5856− ukr <- *uniqueKeyIpRates
5857− let result = checkUniqueKeyIpRate ukr clientIp pubkey t
5858− set *uniqueKeyIpRates = if count result.entries > maxUniqueKeyIpEntries
5859− then do r <- result.entries; where t - r.windowStart < uniqueKeyIpWindowMs; yield r
5860− else result.entries
5861− yield result.limited
5862− if uniqueKeyLimited then do
5863− logEvent "warn" "rate_limited_unique_key_ip" ("ip=" ++ clientIp ++ " limit=" ++ show maxUniqueKeysPerIp)
5864− yield (respond {token: "", expiresAt: 0, error: "unique_key_limited"})
5865− else verifyAuthInner pubkey challenge signature revokeOthers clientIp respond t
5866−
5867−verifyAuthInner = \pubkey challenge signature revokeOthers clientIp respond t -> do
5868− let expiry = t + sessionExpiry
5869− -- Generate token before atomic block (IO can't run inside STM).
5870− -- Token is discarded if challenge validation fails — no session is created.
5871− token <- genToken
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.
5880− if not hasMatch
5881− then yield {valid: False {}, result: Nothing {}}
5882− else do
5883− let sigValid = verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
5884− if not sigValid
5885− then yield {valid: False {}, result: Nothing {}}
5886− else do
5887− set *challenges = challengesExcluding challenges pubkey challenge
5888− dp <- *drainPhase
5889− if dp >= 1 then yield {valid: True {}, result: Nothing {}}
5890− else do
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
5910− then do
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}}}
1231+ set *sessions = do s <- ses; where s.pubkey != caller || not (safeCompare s.token targetToken); yield s
1232+ yield True
1233+ yield (respond {ok: result, authorized: True {}}))
1234+
1235+handleLogout = \authorization clientIp respond -> do
1236+ t <- now
1237+ case extractToken authorization of
1238+ Nothing {} -> yield (respond {ok: False {}, authorized: False {}})
1239+ Just {value: token} -> do
1240+ removed <- atomic do
1241+ ses <- *sessions
1242+ case authenticateSession ses token t of
1243+ Unauthorized {} -> yield {ok: False {}, pubkey: "", peers: []}
1244+ Authorized {pubkey, ip} ->
1245+ if not (matchIp clientIp ip) then yield {ok: False {}, pubkey: "", peers: []}
59161246 else do
5917− -- Slow path: revocation or capacity pressure.
5918− -- Bucket-by-bucket approach: revoke sessions for this pubkey across all
5919− -- 16 buckets without materializing them into one list. Then add the new
5920− -- session to its bucket and handle global capacity if needed.
5921− let revokedCount = if revokeOthers then sessionsForKey else 0
5922− when revokeOthers
5923− (transformAllSessionBuckets (\bucket -> do s <- bucket; where s.pubkey != pubkey; yield s))
5924− -- Per-key cap: if still over maxSessionsPerKey (non-revoke case), evict oldest for this key
5925− let nb = tokenBucket token
5926− when (not revokeOthers && sessionsForKey >= maxSessionsPerKey)
5927− (transformAllSessionBuckets (\bucket ->
5928− let forKey = do s <- bucket; where s.pubkey == pubkey; yield s in
5929− let others = do s <- bucket; where s.pubkey != pubkey; yield s in
5930− if count forKey > 0 then union others (evictOneOldest forKey (\s -> s.expiresAt))
5931− else bucket))
5932− -- Global cap: if over maxSessions, evict oldest globally.
5933− -- Derive count from cached tsc: after revokeOthers, we removed revokedCount sessions;
5934− -- after per-key cap, we removed at most 1. Avoids a redundant 16-bucket scan.
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: ""})
5958−
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.
1247+ set *sessions = do s <- ses; where not (safeCompare s.token token); yield s
1248+ -- If no remaining sessions for this key, drop local presence
1249+ after <- *sessions
1250+ let stillHas = any after (\s -> s.pubkey == pubkey)
1251+ peers <- if stillHas then yield []
1252+ else do
1253+ pres <- *presence
1254+ set *presence = do p <- pres; where p.pubkey != pubkey || not (isLocalServer p.server); yield p
1255+ yield (knownPeerServersFromPresence pres)
1256+ yield {ok: True {}, pubkey: pubkey, peers: peers}
1257+ when (removed.ok && removed.pubkey != "" && count removed.peers > 0 && federationEnabled)
1258+ (fork (sendBatchedGossip removed.peers [{eventType: GossipOffline {}, pubkey: removed.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}] gossipOriginHops))
1259+ yield (respond {ok: removed.ok, authorized: removed.ok})
1260+
1261+-- ============================================
1262+-- Handler: poll
1263+-- ============================================
1264+
59621265handlePoll = \cursor generation watchKeys authorization clientIp respond -> do
59631266 t <- now
59641267 serverGen <- *serverGeneration
59651268 let generationMismatch = generation != serverGen
59661269 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.
59691270 let cursorWasReset = generationMismatch && cursor > 0
59701271 let cappedWatchKeys = takeRelation maxWatchKeys watchKeys
59711272 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
59751273 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: []})
59761274 else do
5977− globalRateLimited <- 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: []})
5979− else do
5980− -- Capture presenceVersion before long-poll wait to skip unchanged lookups
5981− startPresenceVersion <- *presenceVersion
5982− result <- case extractToken authorization of
5983− Nothing {} -> yield {authorized: False {}, events: [], cursor: 0, pendingAcks: [], evictedEntries: [], pubkey: "", pollSlotFull: False {}, hasMore: False {}}
5984− Just {value: token} -> pollOnce token effectiveCursor clientIp
5985− -- Check presence for watched keys (piggybacks on poll cycle; max latency = pollTimeoutMs).
5986− -- Skip the expensive bucket reads if presenceVersion hasn't changed since poll start.
5987− presenceUpdates <- if result.authorized && count cappedWatchKeys > 0 then do
5988− currentPresenceVersion <- *presenceVersion
5989− if currentPresenceVersion == startPresenceVersion then yield []
5990− else do
5991− t2 <- now
5992− atomic do
5993− let neededBuckets = uniqueBucketsFor cappedWatchKeys (\k -> k)
5994− relevantPresence <- readSelectedPresenceBuckets neededBuckets
5995− yield (do key <- cappedWatchKeys; yield {pubkey: key, online: count (presenceForKey relevantPresence key t2) > 0})
5996− else yield []
5997− -- Short-circuit: skip fork overhead when there are no pending acks or evicted entries.
5998− -- Every poll with cursor > 0 reaches this path, but most polls have zero acks.
5999− when (federationEnabled && (count result.pendingAcks > 0 || count result.evictedEntries > 0))
6000− (fork (do
6001− sendAcksAndClean result.pendingAcks
6002− retryEvictedAcks result.evictedEntries result.pendingAcks))
6003− let isHeartbeat = result.authorized && count result.events == 0
6004− -- Deliver message expiration notifications: atomically read and drain expirations
6005− -- for this sender's pubkey so each notification is delivered exactly once.
6006− -- Uses result.pubkey from pollOnce (already authenticated) instead of re-authenticating,
6007− -- avoiding a redundant safeCompare scan and preventing a race where a concurrent poll
6008− -- could double-drain or lose expirations between the two separate atomic blocks.
6009− expirations <- if not result.authorized || result.pubkey == "" then yield []
6010− else atomic do
6011− se <- *senderExpirations
6012− let forKey = do e <- se; where e.senderKey == result.pubkey; yield {messageId: e.messageId, toKey: e.toKey, expiredAt: e.expiredAt}
6013− let remaining = do e <- se; where e.senderKey != result.pubkey; yield e
6014− set *senderExpirations = remaining
6015− let capped = takeRelation maxSenderExpirationsPerKey forKey
6016− yield capped
6017− -- Deliver message delivery receipts: atomically read and drain delivery notifications
6018− -- for this sender's pubkey so each receipt is delivered exactly once.
6019− deliveries <- if not result.authorized || result.pubkey == "" then yield []
6020− else atomic do
6021− sd <- *senderDeliveries
6022− let forKey = do d <- sd; where d.senderKey == result.pubkey; yield {messageId: d.messageId, toKey: d.toKey, deliveredAt: d.deliveredAt}
6023− let remaining = do d <- sd; where d.senderKey != result.pubkey; yield d
6024− set *senderDeliveries = remaining
6025− let capped = takeRelation maxSenderDeliveriesPerKey forKey
6026− yield capped
6027− -- Poll slot exhaustion: signal clients to back off for one poll cycle
6028− effPollTimeout <- effectivePollTimeoutMs
6029− let pollRetryMs = if result.pollSlotFull then effPollTimeout else 0
6030− -- Read and drain per-sender drop counters so this sender knows if their receipts were lost.
6031− -- Each sender sees only their own drops (not a global counter conflating all senders).
6032− drops <- if not result.authorized || result.pubkey == "" then yield {dr: 0, de: 0}
6033− else atomic do
6034− ddr <- *droppedDeliveryReceipts
6035− let drResult = drainDropCounter ddr result.pubkey
6036− when (drResult.count > 0) (set *droppedDeliveryReceipts = drResult.remaining)
6037− den <- *droppedExpirationNotifs
6038− let deResult = drainDropCounter den result.pubkey
6039− when (deResult.count > 0) (set *droppedExpirationNotifs = deResult.remaining)
6040− yield {dr: drResult.count, de: deResult.count}
6041− -- Deliver cancel notifications: messages retracted by the sender, delivered to the
6042− -- recipient so clients can remove them from the UI. Keyed by toKey (recipient pubkey).
6043− cancellations <- if not result.authorized || result.pubkey == "" then yield []
6044− else atomic do
6045− cn <- *cancelNotifications
6046− let forKey = do c <- cn; where c.toKey == result.pubkey; yield {messageId: c.messageId, cancelledAt: c.cancelledAt}
6047− let remaining = do c <- cn; where c.toKey != result.pubkey; yield c
6048− set *cancelNotifications = remaining
6049− let capped = takeRelation maxCancelNotificationsPerKey forKey
6050− yield capped
6051− -- Expose server load to clients: 0 = healthy (<=80% capacity), up to 90 = near-full.
6052− -- Clients can voluntarily reduce poll frequency or batch sends when loadPct > 0.
6053− loadPct <- do scale <- *cachedAdaptiveScale; yield (if scale >= 100 then 0 else 100 - scale)
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})
6055−
6056−-- Core send logic: dedup, rate limiting, store message, create forwards.
6057−-- Called inside an atomic block by both handleSendMessage and sendBatchInner.
6058−-- Caller handles auth, drain checks, and messageId generation.
6059−-- This function intentionally runs as a single monolithic atomic block:
6060−-- - Splitting into phases (check → store) introduces TOCTOU gaps that require
6061−-- re-checking dedup in Phase 2, adding overhead without reducing contention.
6062−-- - Rate limits committed in Phase 1 would be wasted if Phase 2 denies (dedup).
6063−-- - sendBatchBucketGroup depends on consistent state across messages in the same
6064−-- bucket group (each call sees the previous call's writes).
6065−-- - 16-way bucket sharding already limits contention to 1/16 of concurrent senders;
6066−-- further splitting yields marginal benefit.
6067−sendMessageCore = \senderKey to encryptedBlob clampedTs effectiveMsgId expiresInMs msgPriority t ->
6068− if senderKey == to then yield {status: MsRejected {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
1275+ g <- checkGlobalRate t
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: []})
1277+ else case extractToken authorization of
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: []})
1279+ Just {value: token} -> pollOnce token effectiveCursor cursorWasReset cappedWatchKeys clientIp serverGen respond t
1280+
1281+pollOnce = \token cursor cursorWasReset watchKeys clientIp serverGen respond t -> do
1282+ setup <- atomic do
1283+ ses <- *sessions
1284+ case authenticateSession ses token t of
1285+ Unauthorized {} -> yield Nothing {}
1286+ Authorized {pubkey, ip} ->
1287+ if not (matchIp clientIp ip) then yield Nothing {}
1288+ else do
1289+ let clampedCursor = clamp 0 t cursor
1290+ ackResult <- if clampedCursor > 0 then ackPolledMessages pubkey clampedCursor t else yield {pendingAcks: []}
1291+ startWakeup <- *pollWakeup
1292+ yield (Just {value: {pubkey: pubkey, clampedCursor: clampedCursor, startWakeup: startWakeup, pendingAcks: ackResult.pendingAcks}})
1293+ case setup of
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: []})
1295+ Just {value: s} -> do
1296+ acquired <- atomic do
1297+ aps <- *activePolls
1298+ let perKey = count (do p <- aps; where p.pubkey == s.pubkey; yield p)
1299+ if perKey >= maxPollsPerKey then yield False
1300+ else do
1301+ set *activePolls = capList (union aps [{pubkey: s.pubkey, startedAt: t}]) maxActivePolls (\p -> p.startedAt)
1302+ yield True
1303+ if not acquired
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: []})
1305+ else do
1306+ pollResult <- doPoll s t
1307+ atomic do
1308+ aps <- *activePolls
1309+ set *activePolls = do p <- aps; where p.pubkey != s.pubkey; yield p
1310+ when (federationEnabled && count s.pendingAcks > 0)
1311+ (fork (sendAcksAndClean s.pendingAcks))
1312+ presenceUpdates <- if count watchKeys > 0 && pollResult.authorized
1313+ then atomic do
1314+ t2 <- now
1315+ pres <- *presence
1316+ yield (do k <- watchKeys; yield {pubkey: k, online: count (presenceForKey pres k t2) > 0})
1317+ else yield []
1318+ drains <- atomic do
1319+ se <- *senderExpirations
1320+ let myExp = do x <- se; where x.senderKey == s.pubkey; yield {messageId: x.messageId, toKey: x.toKey, expiredAt: x.expiredAt}
1321+ set *senderExpirations = do x <- se; where x.senderKey != s.pubkey; yield x
1322+ sd <- *senderDeliveries
1323+ let myDel = do x <- sd; where x.senderKey == s.pubkey; yield {messageId: x.messageId, toKey: x.toKey, deliveredAt: x.deliveredAt}
1324+ set *senderDeliveries = do x <- sd; where x.senderKey != s.pubkey; yield x
1325+ cn <- *cancelNotifications
1326+ let myCancels = do x <- cn; where x.toKey == s.pubkey; yield {messageId: x.messageId, cancelledAt: x.cancelledAt}
1327+ set *cancelNotifications = do x <- cn; where x.toKey != s.pubkey; yield x
1328+ yield {expirations: myExp, deliveries: myDel, cancellations: myCancels}
1329+ let isHeartbeat = pollResult.authorized && count pollResult.events == 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})
1331+
1332+doPoll = \s t -> do
1333+ initial <- atomic do
1334+ msgs <- *messages
1335+ yield (collectPollEvents msgs s.pubkey s.clampedCursor t)
1336+ if count initial.events > 0 then yield {authorized: True {}, events: initial.events, cursor: initial.cursor, hasMore: initial.hasMore}
1337+ else do
1338+ -- Wait for signal or heartbeat
1339+ atomic do
1340+ wakeup <- *pollWakeup
1341+ if wakeup > s.startWakeup then yield {}
1342+ else retry
1343+ t2 <- now
1344+ msgs2 <- *messages
1345+ let r = collectPollEvents msgs2 s.pubkey s.clampedCursor t2
1346+ yield {authorized: True {}, events: r.events, cursor: r.cursor, hasMore: r.hasMore}
1347+
1348+collectPollEvents = \messages pubkey cursor t ->
1349+ let myMsgs = do m <- messages; where m.toKey == pubkey && m.expiresAt > t && m.receivedAt > cursor; yield m in
1350+ let sorted = sortBy (\m -> m.receivedAt) myMsgs in
1351+ let limited = takeRelation maxPollEvents sorted in
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
1353+ let lastReceivedAt = fold (\acc m -> max acc m.receivedAt) cursor limited in
1354+ {events: evts, cursor: lastReceivedAt, hasMore: count myMsgs > count limited}
1355+
1356+ackPolledMessages = \pubkey cursor t -> do
1357+ msgs <- *messages
1358+ let toAck = do m <- msgs; where m.toKey == pubkey && m.receivedAt <= cursor; yield m
1359+ if count toAck == 0 then yield {pendingAcks: []}
1360+ else do
1361+ set *messages = do m <- msgs; where not (m.toKey == pubkey && m.receivedAt <= cursor); yield m
1362+ fwds <- *forwards
1363+ let mids = do m <- toAck; yield m.messageId
1364+ set *forwards = do f <- fwds; where not (f.toKey == pubkey && any mids (\mid -> mid == f.messageId)); yield f
1365+ let ackedFederated = do m <- toAck; where m.originServer != ""; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 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}
1373+
1374+-- ============================================
1375+-- Handler: send
1376+-- ============================================
1377+
1378+handleSendMessage = \to encryptedBlob timestamp messageId expiresInMs priority authorization clientIp respond -> do
1379+ let clampedPriority = clamp 0 maxMessagePriority priority
1380+ t <- now
1381+ dp <- *drainPhase
1382+ if dp >= 2 then yield (respond {status: MsDraining {}, messageId: "", retryAfterMs: 0, error: "draining", loadPct: 0})
60691383 else do
6070− let msgBucket = pubkeyBucket to
6071− bucket <- readMessageBucket msgBucket
6072− ackedBkt <- readAckedBucket msgBucket
6073− delivBkt <- readDelivBucket msgBucket
6074− -- Nonce check closes the dedup gap between message expiry (30 days) and nonce retention
6075− -- (60 days): without this, a client could replay a messageId after messages/ackedIds/deliveredIds
6076− -- expire but before the nonce expires.
6077− nonceBkt <- readNonceBucket msgBucket
6078− let isDup = checkMessageDup bucket effectiveMsgId to || hasMessage effectiveMsgId to ackedBkt || hasMessage effectiveMsgId to delivBkt || any nonceBkt (\n -> n.messageId == effectiveMsgId && n.toKey == to)
6079− if isDup then yield {status: MsDuplicate {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
1384+ g <- checkGlobalRate t
1385+ if g then yield (respond {status: MsRateLimited {}, messageId: "", retryAfterMs: 0, error: "rate_limited", loadPct: 0})
1386+ else do
1387+ effMsgId <- if messageId != "" then yield messageId else genToken
1388+ if t - timestamp > messageMaxAge
1389+ then yield (respond {status: MsRejected {}, messageId: "", retryAfterMs: 0, error: "stale_timestamp", loadPct: 0})
1390+ else do
1391+ let clampedTs = clampTimestamp timestamp t
1392+ result <- atomic do
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})
1403+
1404+sendMessageCore = \senderKey to encryptedBlob clampedTs effMsgId expiresInMs msgPriority t ->
1405+ if senderKey == to then yield {status: MsRejected {}, remoteServers: []}
1406+ else do
1407+ msgs <- *messages
1408+ aids <- *ackedIds
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: []}
60801414 else do
60811415 sendRates <- *sendRates
6082− sendRate <- effectiveSendRate
6083− let rateResult = checkPubkeyRate sendRates senderKey sendRate sendRateWindowMs maxSendRateEntries t
6084− if rateResult.limited then yield {status: MsRateLimited {}, remoteServers: [], retryAfterMs: rateResult.retryAfterMs, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
1416+ let sr = checkRate sendRates senderKey maxSendRatePerKey sendRateWindowMs 5000 t
1417+ if sr.limited then yield {status: MsRateLimited {}, remoteServers: []}
60851418 else do
6086− set *sendRates = rateResult.entries
1419+ set *sendRates = sr.entries
60871420 pairRates <- *pairRates
6088− pRate <- effectivePairRate
6089− let pairResult = checkPairRate pairRates senderKey to pRate pairRateWindowMs maxPairRateEntries t
6090− set *pairRates = pairResult.entries
6091− if pairResult.limited then yield {status: MsRateLimited {}, remoteServers: [], retryAfterMs: pairResult.retryAfterMs, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
1421+ let pr = checkRate pairRates (senderKey ++ "|" ++ to) maxPairRatePerPair pairRateWindowMs 5000 t
1422+ set *pairRates = pr.entries
1423+ if pr.limited then yield {status: MsRateLimited {}, remoteServers: []}
60921424 else do
60931425 recvRates <- *recvRates
6094− recvRate <- effectiveRecvRate
6095− let recvResult = checkPubkeyRate recvRates to recvRate recvRateWindowMs maxRecvRateEntries t
6096− if recvResult.limited then yield {status: MsRateLimited {}, remoteServers: [], retryAfterMs: recvResult.retryAfterMs, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
1426+ let rr = checkRate recvRates to maxRecvRatePerKey recvRateWindowMs 5000 t
1427+ if rr.limited then yield {status: MsRateLimited {}, remoteServers: []}
60971428 else do
6098− set *recvRates = recvResult.entries
6099− totalMsgCount <- *totalMessageCount
6100− if totalMsgCount >= maxMessages then yield {status: MsRejected {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0}
6101− else do
6102− recipientCounts <- readRcBucket msgBucket
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}
1429+ set *recvRates = rr.entries
1430+ if count msgs >= maxMessages then yield {status: MsRejected {}, remoteServers: []}
1431+ else
1432+ let recipientCount = count (do m <- msgs; where m.toKey == to; yield m) in
1433+ if recipientCount >= maxMessagesPerRecipient then yield {status: MsQueued {}, remoteServers: []}
61091434 else do
6110− recipientPresence <- readPresenceBucket (pubkeyBucket to)
6111− seqCounter <- *seqCounter
6112− let seqTs = nextSeqTs t seqCounter
1435+ pres <- *presence
1436+ seq <- *seqCounter
1437+ let seqTs = nextSeqTs t seq
61131438 set *seqCounter = seqTs
6114− let msgExpiresAt = seqTs + effectiveMessageTtl expiresInMs
6115− writeMessageBucket msgBucket (union bucket
6116− [{messageId: effectiveMsgId, toKey: to,
6117− encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs, expiresAt: msgExpiresAt, senderKey: senderKey, priority: msgPriority}])
6118− set *totalMessageCount = totalMsgCount + 1
6119− writeRcBucket msgBucket (adjustRecipientCount recipientCounts to 1)
6120− signalMessageForKey to seqTs
6121− -- Record forward nonce for locally-originated messages: prevents replay
6122− -- if the message expires from messages/ackedIds/deliveredIds and a federation
6123− -- peer forwards it back. Without this, the nonce check in handleForwardMessage
6124− -- would miss locally-originated messages entirely.
6125− -- Inlined: calls updateForwardNonce directly instead of recordForwardNonce
6126− -- to avoid nested atomic block. Eviction info is returned for deferred logging.
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 {}}}
6143− fwdBkt
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 {})
1439+ let expiresAt = seqTs + effectiveMessageTtl expiresInMs
1440+ set *messages = union msgs [{messageId: effMsgId, toKey: to, encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs, expiresAt: expiresAt, senderKey: senderKey, priority: msgPriority}]
1441+ set *pollWakeup = seqTs
1442+ let toPresence = presenceForKey pres to t
1443+ let localOnline = any toPresence (\p -> isLocalServer p.server)
1444+ let remoteServers = collectPeers toPresence (\p -> p.server)
1445+ forwardsEnqueued <- if federationEnabled && count remoteServers > 0
1446+ then do
1447+ fwds <- *forwards
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}
1449+ set *forwards = capList (union fwds newFwds) maxForwardsEntries (\f -> f.createdAt)
1450+ yield (count newFwds > 0)
1451+ else yield False
61551452 let status = if localOnline then MsDelivered {}
6156− else if federationEnabled && forwardsEnqueued then MsFederated {}
1453+ else if forwardsEnqueued then MsFederated {}
61571454 else MsQueued {}
6158− yield {status: status, remoteServers: remoteServers, retryAfterMs: 0, nonceBucket: msgBucket, nonceEvicted: nonceResult.lruEvicted, nonceOldestAge: nonceResult.oldestRetainedAge}
6159−
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
6170− fwdT <- now
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})
6179− case fwdResult of
6180− Err e -> do
6181− logKV "warn" "federation_forward_failed" ["server=" ++ server, "messageId=" ++ effectiveMsgId, "error=" ++ show e]
6182− recordFailure server
6183− Ok response ->
6184− if response.ok then do
6185− removeForward effectiveMsgId server to
6186− clearFailure server
6187− else
6188− logKV "warn" "federation_forward_rejected" ["server=" ++ server, "messageId=" ++ effectiveMsgId, "error=" ++ response.error]))))
6189−
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 {}
6199− else do
6200− -- Filter to messages still pending in forward buckets
6201− pending <- filterPendingBatchForwards msgs server []
6202− if count pending == 0 then yield {}
6203− else do
6204− t <- now
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})
6211− case result of
6212− Err e -> do
6213− logKV "warn" "federation_batch_forward_failed" ["server=" ++ server, "batchSize=" ++ show (count pending), "error=" ++ show e]
6214− recordFailure server
6215− Ok response ->
6216− if response.ok then do
6217− clearFailure server
6218− processBatchForwardResults pending response.results server
6219− else do
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
1455+ yield {status: status, remoteServers: remoteServers}
62231456
6224−-- Filter batch messages to those still pending in forward buckets.
6225−-- Concurrent poll/ack may have removed the forward entry between creation and send.
6226−filterPendingBatchForwards = \msgs server acc ->
6227− case headOf msgs of
6228− Nothing {} -> yield acc
6229− Just {value: r} -> do
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)
6235−
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
1457+forkSendForwards = \effMsgId to encryptedBlob clampedTs remoteServers ->
1458+ when (count remoteServers > 0 && federationEnabled)
1459+ (fork (forkForwardsTo effMsgId to encryptedBlob clampedTs remoteServers))
1460+
1461+forkForwardsTo = \effMsgId to encryptedBlob clampedTs servers ->
1462+ case headOf servers of
62411463 Nothing {} -> yield {}
6242− Just {value: r} -> do
6243− let rest = do m <- pending; where m.messageId != r.messageId; yield m
6244− let msgResult = headOf (do res <- results; where res.messageId == r.messageId; yield res)
6245− case msgResult of
6246− Just {value: res} ->
6247− when res.ok (removeForward r.messageId server r.toKey)
1464+ Just {value: server} -> do
1465+ let rest = do s <- servers; where s != server; yield s
1466+ info <- atomic do
1467+ fwds <- *forwards
1468+ case headOf (do f <- fwds; where f.messageId == effMsgId && f.toServer == server; yield f) of
1469+ Nothing {} -> yield Nothing {}
1470+ Just {value: f} -> yield (Just {value: {expiresAt: f.expiresAt, priority: f.priority}})
1471+ case info of
62481472 Nothing {} -> yield {}
6249− processBatchForwardResults rest results server
1473+ Just {value: i} -> do
1474+ t <- now
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})
1482+ case result of
1483+ Err _ -> recordFailure server
1484+ Ok r ->
1485+ if r.ok then do
1486+ clearFailure server
1487+ atomic do
1488+ fwds <- *forwards
1489+ set *forwards = do f <- fwds; where not (f.messageId == effMsgId && f.toServer == server); yield f
1490+ else yield {}
1491+ forkForwardsTo effMsgId to encryptedBlob clampedTs rest
62501492
6251−-- Fallback: send forwards individually when batch forward is rejected (old peer).
6252−-- Same logic as the original sequential path but only runs when batch fails.
6253−sendBatchForwardsFallback = \msgs server ->
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
6258− fwdT <- now
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})
6267− case fwdResult of
6268− Err e -> do
6269− logKV "warn" "federation_forward_failed" ["server=" ++ server, "messageId=" ++ r.messageId, "error=" ++ show e]
6270− recordFailure server
6271− Ok response ->
6272− if response.ok then do
6273− removeForward r.messageId server r.toKey
6274− clearFailure server
6275− else
6276− logKV "warn" "federation_forward_rejected" ["server=" ++ server, "messageId=" ++ r.messageId, "error=" ++ response.error]
6277− sendBatchForwardsFallback rest server
1493+-- ============================================
1494+-- Handler: lookup
1495+-- ============================================
62781496
6279−-- POST /messages: Send an encrypted message to a recipient.
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
1497+handleLookupPresence = \pubkey authorization clientIp respond -> do
62841498 t <- now
6285− dp <- *drainPhase
6286− if dp >= 2 then yield (respond {status: MsDraining {}, messageId: "", retryAfterMs: 0, error: "draining", loadPct: 0})
6287− else do
6288− globalRateLimited <- checkGlobalRate t
6289− if globalRateLimited then yield (respond {status: MsRateLimited {}, messageId: "", retryAfterMs: 0, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms", loadPct: 0})
6290− else do
6291− effectiveMsgId <- if messageId != "" then yield messageId else genToken
6292− if t - timestamp > messageMaxAge
6293− then yield (respond {status: MsRejected {}, messageId: "", retryAfterMs: 0, error: "stale_timestamp", loadPct: 0})
1499+ g <- checkGlobalRate t
1500+ if g then yield (respond {server: "", authorized: False {}, error: "rate_limited"})
1501+ else withSessionAuth authorization t clientIp
1502+ (yield (respond {server: "", authorized: False {}, error: ""}))
1503+ (\senderKey -> do
1504+ lim <- checkPubkeyRateGate lookupRates senderKey maxLookupRatePerKey lookupRateWindowMs t
1505+ if lim then yield (respond {server: "", authorized: True {}, error: "rate_limited"})
62941506 else do
6295− when (timestamp > t + clockSkewTolerance)
6296− (logWarn ("sendMessage: future timestamp detected (+" ++ show (timestamp - t) ++ "ms ahead), clamping to now"))
6297− when (timestamp < t - messageMaxAge / 2)
6298− (logWarn ("sendMessage: stale timestamp (" ++ show ((t - timestamp) / 86400000) ++ " days old) for " ++ effectiveMsgId))
6299− let clampedTs = clampTimestamp timestamp t
6300− result <- atomic do
6301− withSessionAuth authorization t clientIp
6302− (yield {status: MsUnauthorized {}, remoteServers: [], retryAfterMs: 0, nonceBucket: 0, nonceEvicted: 0, nonceOldestAge: 0})
6303− (\senderKey -> sendMessageCore senderKey to encryptedBlob clampedTs effectiveMsgId expiresInMs clampedPriority t)
6304− -- Deferred nonce eviction logging (outside atomic block to avoid holding the lock during IO)
6305− logNonceEviction result.nonceBucket result.nonceEvicted result.nonceOldestAge
6306− case result.status of
6307− MsRateLimited {} -> logEvent "warn" "rate_limited_send" ("messageId=" ++ effectiveMsgId)
6308− MsRejected {} -> when (result.retryAfterMs == 0) (logWarn ("sendMessage: rejected for " ++ effectiveMsgId ++ " (global capacity full)"))
6309− _ -> yield {}
6310− forkSendForwards effectiveMsgId to encryptedBlob clampedTs result.remoteServers
6311− loadPct <- do scale <- *cachedAdaptiveScale; yield (if scale >= 100 then 0 else 100 - scale)
6312− yield (case result.status of
6313− MsDuplicate {} -> respond {status: MsDuplicate {}, messageId: effectiveMsgId, retryAfterMs: 0, error: "", loadPct: loadPct}
6314− MsDelivered {} -> respond {status: MsDelivered {}, messageId: effectiveMsgId, retryAfterMs: 0, error: "", loadPct: loadPct}
6315− MsFederated {} -> respond {status: MsFederated {}, messageId: effectiveMsgId, retryAfterMs: 0, error: "", loadPct: loadPct}
6316− MsQueued {} -> respond {status: MsQueued {}, messageId: effectiveMsgId, retryAfterMs: 0, error: "", loadPct: loadPct}
6317− _ -> respond {status: result.status, messageId: "", retryAfterMs: result.retryAfterMs, error: "rejected", loadPct: loadPct})
6318−
6319−-- GET /lookup/:pubkey: Look up the best known server for a pubkey.
6320−-- Returns local server if key is online locally, otherwise the remote with latest expiry.
6321−handleLookupPresence = \pubkey authorization clientIp respond -> do
1507+ pres <- *presence
1508+ let found = bestServerForKey (presenceForKey pres pubkey t)
1509+ let masked = if found == "" then "" else if isLocalServer found then found else "remote"
1510+ yield (respond {server: masked, authorized: True {}, error: ""}))
1511+
1512+handleBatchLookupPresence = \pubkeys authorization clientIp respond -> do
1513+ t <- now
1514+ g <- checkGlobalRate t
1515+ if g then yield (respond {results: [], authorized: False {}, error: "rate_limited"})
1516+ else withSessionAuth authorization t clientIp
1517+ (yield (respond {results: [], authorized: False {}, error: ""}))
1518+ (\senderKey -> do
1519+ lim <- checkPubkeyRateGate lookupRates senderKey maxLookupRatePerKey lookupRateWindowMs t
1520+ if lim then yield (respond {results: [], authorized: True {}, error: "rate_limited"})
1521+ else do
1522+ let capped = takeRelation 50 pubkeys
1523+ pres <- *presence
1524+ let results = do
1525+ k <- capped
1526+ let found = bestServerForKey (presenceForKey pres k t)
1527+ let masked = if found == "" then "" else if isLocalServer found then found else "remote"
1528+ yield {pubkey: k, server: masked}
1529+ yield (respond {results: results, authorized: True {}, error: ""}))
1530+
1531+handleMessageStatus = \to messageId authorization clientIp respond -> do
1532+ t <- now
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 {}}))
1537+ (\_ -> do
1538+ msgs <- *messages
1539+ fwds <- *forwards
1540+ aids <- *ackedIds
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"
1545+ else "unknown"
1546+ yield (respond {status: s, authorized: True {}}))
1547+
1548+-- ============================================
1549+-- Handler: ack / list / delete / cancel
1550+-- ============================================
1551+
1552+handleAckMessages = \messageIds authorization clientIp respond -> do
63221553 t <- now
6323− globalRateLimited <- checkGlobalRate t
6324− if globalRateLimited then yield (respond {server: "", authorized: False {}, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
1554+ dp <- *drainPhase
1555+ if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "draining"})
63251556 else do
6326− result <- atomic do
6327− dp <- *drainPhase
6328− if dp >= 2 then yield {server: "", authorized: False {}, error: ""}
6329− else withSessionAuth authorization t clientIp
6330− (yield {server: "", authorized: False {}, error: ""})
6331− (\senderKey -> do
6332− lookupRates <- *lookupRates
6333− lkRate <- effectiveLookupRate
6334− let rateResult = checkPubkeyRate lookupRates senderKey lkRate lookupRateWindowMs maxLookupRateEntries t
6335− set *lookupRates = rateResult.entries
6336− if rateResult.limited
6337− then yield {server: "", authorized: True {}, error: "rate_limited:" ++ show lookupRateWindowMs ++ "ms"}
1557+ g <- checkGlobalRate t
1558+ if g then yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "rate_limited"})
1559+ else withSessionAuth authorization t clientIp
1560+ (yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "unauthorized"}))
1561+ (\pubkey -> do
1562+ lim <- checkPubkeyRateGate clientWriteRates pubkey maxClientWriteRatePerKey clientWriteRateWindowMs t
1563+ if lim then yield (respond {ok: False {}, authorized: True {}, ackedCount: 0, error: "rate_limited"})
1564+ else do
1565+ let dedupedIds = dedupMessageIds messageIds
1566+ result <- atomic do
1567+ msgs <- *messages
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: []}
63381570 else do
6339− -- Hot path: read only the target key's presence bucket
6340− lookupBkt <- readPresenceBucket (pubkeyBucket pubkey)
6341− let foundServer = bestServerForKey (presenceForKey lookupBkt pubkey t)
6342− -- Mask remote server names: clients only need to know local/remote/unknown,
6343− -- not which specific peer server a key is homed on (prevents metadata leakage)
6344− let maskedServer = if foundServer == "" then "" else if isLocalServer foundServer then foundServer else "remote"
6345− yield {server: maskedServer, authorized: True {}, error: ""})
6346− yield (respond {server: result.server, authorized: result.authorized, error: result.error})
6347−
6348−-- POST /lookup/batch: Look up presence for multiple pubkeys in one request.
6349−-- Reads only the needed presence buckets (not all 16), reducing round trips
6350−-- vs sequential single-key lookups. Uses one rate limit check for the whole batch.
6351−handleBatchLookupPresence = \pubkeys authorization clientIp respond -> do
1571+ set *messages = do m <- msgs; where not (m.toKey == pubkey && any dedupedIds (\mid -> m.messageId == mid)); yield m
1572+ fwds <- *forwards
1573+ set *forwards = do f <- fwds; where not (f.toKey == pubkey && any dedupedIds (\mid -> f.messageId == mid)); yield f
1574+ let ackedFed = do m <- toAck; where m.originServer != ""; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
1575+ aids <- *ackedIds
1576+ set *ackedIds = capList (union aids ackedFed) maxAckedIds (\a -> a.ackedAt)
1577+ let localDelivered = do m <- toAck; where m.senderKey != "" && m.originServer == ""; yield {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, deliveredAt: t}
1578+ sd <- *senderDeliveries
1579+ set *senderDeliveries = capList (union sd localDelivered) 10000 (\d -> d.deliveredAt)
1580+ yield {ackedCount: count toAck, pendingAcks: ackedFed}
1581+ fork (when federationEnabled (sendAcksAndClean result.pendingAcks))
1582+ yield (respond {ok: True {}, authorized: True {}, ackedCount: result.ackedCount, error: ""}))
1583+
1584+handleListMessages = \offset authorization clientIp respond -> do
63521585 t <- now
6353− globalRateLimited <- checkGlobalRate t
6354− if globalRateLimited then yield (respond {results: [], authorized: False {}, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
1586+ dp <- *drainPhase
1587+ if dp >= 2 then yield (respond {messages: [], authorized: False {}, count: 0, error: ""})
63551588 else do
6356− dp <- *drainPhase
6357− if dp >= 2 then yield (respond {results: [], authorized: False {}, error: ""})
6358− else
6359− withSessionAuth authorization t clientIp
6360− (yield (respond {results: [], authorized: False {}, error: ""}))
6361− (\senderKey -> do
6362− lookupRateLimited <- atomic do
6363− lookupRates <- *lookupRates
6364− lkRate <- effectiveLookupRate
6365− let rateResult = checkPubkeyRate lookupRates senderKey lkRate lookupRateWindowMs maxLookupRateEntries t
6366− set *lookupRates = rateResult.entries
6367− yield rateResult.limited
6368− if lookupRateLimited then yield (respond {results: [], authorized: True {}, error: "rate_limited:" ++ show lookupRateWindowMs ++ "ms"})
6369− else do
6370− -- Deduplicate input pubkeys to avoid redundant presence bucket reads
6371− -- (a client could send 50 copies of the same pubkey, each triggering a scan)
6372− let dedupedKeys = fold (\acc k -> if any acc (\a -> a == k) then acc else union acc [k]) [] pubkeys
6373− let cappedKeys = takeRelation maxBatchLookupKeys dedupedKeys
6374− result <- atomic do
6375− let neededBuckets = uniqueBucketsFor cappedKeys (\k -> k)
6376− relevantPresence <- readSelectedPresenceBuckets neededBuckets
6377− yield (do key <- cappedKeys; yield (
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: ""}))
6382−
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
1589+ g <- checkGlobalRate t
1590+ if g then yield (respond {messages: [], authorized: False {}, count: 0, error: "rate_limited"})
1591+ else withSessionAuth authorization t clientIp
1592+ (yield (respond {messages: [], authorized: False {}, count: 0, error: ""}))
1593+ (\pubkey -> do
1594+ lim <- checkPubkeyRateGate lookupRates pubkey maxLookupRatePerKey lookupRateWindowMs t
1595+ if lim then yield (respond {messages: [], authorized: True {}, count: 0, error: "rate_limited"})
1596+ else do
1597+ msgs <- *messages
1598+ let myMsgs = sortBy (\m -> m.receivedAt) (do m <- msgs; where m.toKey == pubkey && m.expiresAt > t; yield m)
1599+ let total = count myMsgs
1600+ let effectiveOffset = clamp 0 total offset
1601+ let after = skipN effectiveOffset myMsgs
1602+ let capped = takeRelation maxPollEvents after
1603+ let result = do m <- capped; yield {messageId: m.messageId, timestamp: m.timestamp, receivedAt: m.receivedAt}
1604+ yield (respond {messages: result, authorized: True {}, count: total, error: ""}))
1605+
1606+skipN = \n items ->
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
1608+ in r.result
1609+
1610+handleDeleteMessages = \messageIds authorization clientIp respond -> do
63881611 t <- now
63891612 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: ""})
63911614 else do
6392− globalRateLimited <- checkGlobalRate t
6393− if globalRateLimited then yield (respond {status: "", authorized: False {}})
6394− else
6395− withSessionAuth authorization t clientIp
6396− (yield (respond {status: "", authorized: False {}}))
6397− (\senderKey -> do
6398− -- Per-key rate limiting (reuses lookup rate limiter — both are info lookups)
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 {}})
1615+ g <- checkGlobalRate t
1616+ if g then yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "rate_limited"})
1617+ else withSessionAuth authorization t clientIp
1618+ (yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "unauthorized"}))
1619+ (\pubkey -> do
1620+ lim <- checkPubkeyRateGate clientWriteRates pubkey maxClientWriteRatePerKey clientWriteRateWindowMs t
1621+ if lim then yield (respond {ok: False {}, authorized: True {}, deletedCount: 0, error: "rate_limited"})
64061622 else do
1623+ let dedupedIds = dedupMessageIds messageIds
64071624 result <- atomic do
6408− let msgBucket = pubkeyBucket to
6409− bucket <- readMessageBucket msgBucket
6410− -- Check if message is still in mailbox (pending delivery)
6411− let inMailbox = any bucket (\m -> m.messageId == messageId && m.toKey == to)
6412− if inMailbox then yield "pending"
1625+ msgs <- *messages
1626+ let toDel = do m <- msgs; where m.toKey == pubkey && any dedupedIds (\mid -> mid == m.messageId); yield m
1627+ if count toDel == 0 then yield {deletedCount: 0, pendingAcks: []}
64131628 else do
6414− -- Check if being forwarded to a remote server (bucket read: O(n/16))
6415− fwdBkt <- readFwdBucket (pubkeyBucket to)
6416− let inForwards = any fwdBkt (\f -> f.messageId == messageId && f.toKey == to)
6417− if inForwards then yield "forwarding"
6418− else do
6419− -- Check if already delivered (acked or in terminal delivered set)
6420− ackedBkt <- readAckedBucket msgBucket
6421− delivBkt <- readDelivBucket msgBucket
6422− let inAcked = hasMessage messageId to ackedBkt
6423− let inDelivered = hasMessage messageId to delivBkt
6424− if inAcked || inDelivered then yield "delivered"
6425− else 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 {}}))
6434−
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
1629+ set *messages = do m <- msgs; where not (m.toKey == pubkey && any dedupedIds (\mid -> mid == m.messageId)); yield m
1630+ fwds <- *forwards
1631+ set *forwards = do f <- fwds; where not (f.toKey == pubkey && any dedupedIds (\mid -> mid == f.messageId)); yield f
1632+ let federatedDeleted = do m <- toDel; where m.originServer != ""; yield m
1633+ let ackedFed = do m <- federatedDeleted; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
1634+ aids <- *ackedIds
1635+ set *ackedIds = capList (union aids ackedFed) maxAckedIds (\a -> a.ackedAt)
1636+ yield {deletedCount: count toDel, pendingAcks: ackedFed}
1637+ fork (when federationEnabled (sendAcksAndClean result.pendingAcks))
1638+ yield (respond {ok: True {}, authorized: True {}, deletedCount: result.deletedCount, error: ""}))
1639+
1640+handleCancelMessage = \messageId to authorization clientIp respond -> do
64391641 t <- now
6440− globalRateLimited <- checkGlobalRate t
6441− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}})
6442− else
6443− withSessionAuth authorization t clientIp
6444− (yield (respond {ok: False {}, authorized: False {}}))
6445− (\callerPubkey -> do
6446− authLimited <- checkAuthGlobalRate t
6447− if authLimited then yield (respond {ok: False {}, authorized: True {}})
1642+ dp <- *drainPhase
1643+ if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: ""})
1644+ else do
1645+ g <- checkGlobalRate t
1646+ if g then yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "rate_limited"})
1647+ else withSessionAuth authorization t clientIp
1648+ (yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "unauthorized"}))
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"})
64481652 else do
6449− revokeLimited <- atomic do
6450− rr <- *revokeRates
6451− let rateResult = checkPubkeyRate rr callerPubkey maxRevokeRatePerKey revokeRateWindowMs maxRevokeRateEntries t
6452− set *revokeRates = rateResult.entries
6453− yield rateResult.limited
6454− if revokeLimited then yield (respond {ok: False {}, authorized: True {}})
1653+ result <- atomic do
1654+ msgs <- *messages
1655+ let target = headOf (do m <- msgs; where m.messageId == messageId && m.toKey == to; yield m)
1656+ case target of
1657+ Nothing {} -> yield {cancelled: False {}, cancelServers: []}
1658+ Just {value: msg} ->
1659+ if msg.originServer != "" || msg.senderKey == "" || msg.senderKey != senderKey
1660+ then yield {cancelled: False {}, cancelServers: []}
1661+ else do
1662+ set *messages = do m <- msgs; where not (m.messageId == messageId && m.toKey == to); yield m
1663+ fwds <- *forwards
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
1667+ pres <- *presence
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: ""}))
1676+
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
1682+ t <- now
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})
1688+ case result of
1689+ Err _ -> atomic do
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
1696+
1697+handleCancelBatch = \cancels authorization clientIp respond -> do
1698+ t <- now
1699+ dp <- *drainPhase
1700+ if dp >= 2 then yield (respond {results: [], authorized: False {}, error: ""})
1701+ else do
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"}))
1706+ (\senderKey -> do
1707+ lim <- checkPubkeyRateGate clientWriteRates senderKey maxClientWriteRatePerKey clientWriteRateWindowMs t
1708+ if lim then yield (respond {results: [], authorized: True {}, error: "rate_limited"})
64551709 else do
6456− let targetBucket = tokenBucket targetToken
6457− result <- atomic do
6458− sessions <- readSessionBucket targetBucket
6459− -- Single-pass find-and-remove: avoids calling safeCompare twice per session
6460− -- (once in `any` to check existence, again in `where` to filter).
6461− let filtered = fold (\acc s ->
6462− if not acc.found && s.pubkey == callerPubkey && safeCompare s.token targetToken
6463− then {kept: acc.kept, found: True {}}
6464− else {kept: union acc.kept [s], found: acc.found}) {kept: [], found: False {}} sessions
6465− if filtered.found
6466− then do
6467− writeSessionBucket targetBucket filtered.kept
6468− sc <- *totalSessionCount
6469− set *totalSessionCount = max 0 (sc - 1)
6470− cleanup <- checkLastSessionCleanup callerPubkey t
6471− yield (Just {value: cleanup})
6472− else yield (Nothing {})
6473− case result of
6474− Nothing {} -> yield (respond {ok: False {}, authorized: True {}})
6475− Just {value: r} -> do
6476− gossipOfflineIfLastSession r "revoke"
6477− when (not r.gossipOffline) (logInfo ("revoke: session revoked for " ++ r.pubkey))
6478− yield (respond {ok: True {}, authorized: True {}}))
6479−
6480−-- POST /auth/logout: Voluntary disconnect. Removes the caller's session and, if it was
6481−-- the last active session for this pubkey, clears local presence and gossips offline.
6482−-- This gives faster offline detection than waiting for session expiry (1 hour).
6483−handleLogout = \authorization clientIp respond -> do
1710+ let capped = takeRelation maxBatchSize cancels
1711+ results <- cancelEach senderKey capped t []
1712+ yield (respond {results: results, authorized: True {}, error: ""}))
1713+
1714+cancelEach = \senderKey entries t acc ->
1715+ case headOf entries of
1716+ Nothing {} -> yield acc
1717+ Just {value: e} -> do
1718+ let rest = do x <- entries; where x.messageId != e.messageId; yield x
1719+ r <- atomic do
1720+ msgs <- *messages
1721+ let target = headOf (do m <- msgs; where m.messageId == e.messageId && m.toKey == e.to; yield m)
1722+ case target of
1723+ Nothing {} -> yield False
1724+ Just {value: msg} ->
1725+ if msg.originServer != "" || msg.senderKey == "" || msg.senderKey != senderKey
1726+ then yield False
1727+ else do
1728+ set *messages = do m <- msgs; where not (m.messageId == e.messageId && m.toKey == e.to); yield m
1729+ fwds <- *forwards
1730+ set *forwards = do f <- fwds; where not (f.messageId == e.messageId && f.toKey == e.to); yield f
1731+ cn <- *cancelNotifications
1732+ set *cancelNotifications = capList (union cn [{toKey: e.to, messageId: e.messageId, cancelledAt: t}]) 10000 (\c -> c.cancelledAt)
1733+ yield True
1734+ cancelEach senderKey rest t (union acc [{messageId: e.messageId, cancelled: r}])
1735+
1736+handleSendBatch = \messages authorization clientIp respond -> do
64841737 t <- now
6485− -- Logout is allowed during all drain phases (including full drain): it reduces load
6486− -- and the offline gossip is skipped during drain by gossipOfflineIfLastSession.
6487− globalRateLimited <- checkGlobalRate t
6488− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}})
1738+ dp <- *drainPhase
1739+ if dp >= 2 then yield (respond {results: [], authorized: False {}, retryAfterMs: 0})
64891740 else do
6490− authLimited <- checkAuthGlobalRate t
6491− if authLimited then yield (respond {ok: False {}, authorized: False {}})
6492− else
6493− case extractToken authorization of
6494− Nothing {} -> yield (respond {ok: False {}, authorized: False {}})
6495− Just {value: token} -> do
6496− let bucket = tokenBucket token
6497− result <- atomic do
6498− sessions <- readSessionBucket bucket
6499− case authenticateSession sessions token t of
6500− Unauthorized {} -> yield (Nothing {})
6501− Authorized {pubkey, ip} ->
6502− if not (matchIp clientIp ip)
6503− then yield (Nothing {})
6504− else do
6505− -- Remove the caller's session
6506− writeSessionBucket bucket (do s <- sessions; where not (safeCompare s.token token); yield s)
6507− sc <- *totalSessionCount
6508− set *totalSessionCount = max 0 (sc - 1)
6509− cleanup <- checkLastSessionCleanup pubkey t
6510− yield (Just {value: cleanup})
6511− case result of
6512− Nothing {} -> yield (respond {ok: False {}, authorized: False {}})
6513− Just {value: r} -> do
6514− gossipOfflineIfLastSession r "logout"
6515− yield (respond {ok: True {}, authorized: True {}})
6516−
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.
1741+ g <- checkGlobalRate t
1742+ if g then yield (respond {results: [], authorized: False {}, retryAfterMs: 0})
1743+ else withSessionAuth authorization t clientIp
1744+ (yield (respond {results: [], authorized: False {}, retryAfterMs: 0}))
1745+ (\senderKey -> do
1746+ let capped = takeRelation maxBatchSize messages
1747+ results <- sendBatchEach senderKey capped t []
1748+ yield (respond {results: do r <- results; yield {messageId: r.messageId, status: r.status}, authorized: True {}, retryAfterMs: 0}))
1749+
1750+sendBatchEach = \senderKey msgs t acc ->
1751+ case headOf msgs of
1752+ Nothing {} -> yield acc
1753+ Just {value: m} -> do
1754+ let rest = do x <- msgs; where x != m; yield x
1755+ effMsgId <- if m.messageId != "" then yield m.messageId else genToken
1756+ let clampedTs = clampTimestamp m.timestamp t
1757+ let clampedPri = clamp 0 maxMessagePriority m.priority
1758+ r <- if t - m.timestamp > messageMaxAge
1759+ then yield {status: MsRejected {}, remoteServers: []}
1760+ else atomic do sendMessageCore senderKey m.to m.encryptedBlob clampedTs effMsgId m.expiresInMs clampedPri t
1761+ forkSendForwards effMsgId m.to m.encryptedBlob clampedTs r.remoteServers
1762+ sendBatchEach senderKey rest t (union acc [{messageId: effMsgId, status: r.status}])
1763+
1764+-- ============================================
1765+-- Handler: federation receive
1766+-- ============================================
1767+
65201768handleVerifyToken = \token scope clientIp respond -> do
6521− -- Reject empty scope: prevents matching against any cached verification entry
65221769 if scope == "" then yield (respond {ok: False {}})
65231770 else do
6524− t <- now
6525− globalRateLimited <- checkGlobalRate t
6526− if globalRateLimited then yield (respond {ok: False {}})
6527− else do
6528− ipLimited <- checkClientIpRate clientIp t
6529− if ipLimited then yield (respond {ok: False {}})
6530− else do
6531− -- Dedicated verify rate limit (tighter than general IP rate to limit token probing)
6532− verifyLimited <- if clientIp == "" then yield (False {})
6533− else atomic do
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 {}})
6541− else do
6542− found <- atomic do
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))
6554− yield match
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})
6560−
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
6566− t <- now
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 {})
6589− else do
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
6595− yield (False {})
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})
1771+ t <- now
1772+ g <- checkGlobalRate t
1773+ if g then yield (respond {ok: False {}})
65991774 else do
6600− let validated = validGossipEvents cappedEvents t
6601− let onlineEntries = validated.online
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})
1775+ ipLim <- checkIpRateGate clientIp t
1776+ if ipLim then yield (respond {ok: False {}})
66061777 else do
6607− -- Warn if a peer sends both online and offline for the same key in one batch (suspicious)
6608− let conflictingKeys = do on <- onlineEntries; off <- trustedOffline; where on.pubkey == off.pubkey && on.server == off.server; yield on.pubkey
6609− when (count conflictingKeys > 0)
6610− (logWarn ("gossip: " ++ fromServer ++ " sent conflicting online+offline for same key(s)"))
6611− let filteredOnline = resolveByTimestamp onlineEntries trustedOffline
6612− let filteredOffline = resolveByTimestamp trustedOffline onlineEntries
6613− let deduped = mergeByPubkeyServer [] filteredOnline
6614− -- Combined local-clash check + gossip merge in a single atomic block.
6615− -- Previously these were two separate atomic blocks reading the same presence buckets;
6616− -- merging them halves the bucket reads and avoids a TOCTOU gap between clash check and merge.
6617− -- All entries for a pubkey hash to the same bucket, so per-bucket merge is complete.
6618− let allGossipEntries = union deduped trustedOffline
6619− let affectedBuckets = uniqueBucketsFor allGossipEntries (\e -> e.pubkey)
6620− gossipResult <- atomic do
6621− selectedPresence <- readSelectedPresenceBuckets affectedBuckets
6622− tpc <- *totalPresenceCount
6623− -- Reject gossip entries that claim keys locally authenticated on this server.
6624− -- A peer announcing presence for a key we have a live session for could be a presence
6625− -- hijack attempt: the attacker's server would receive forwarded message copies.
6626− let localClashes = do e <- deduped; where any selectedPresence (\p -> p.pubkey == e.pubkey && isLocalServer p.server && p.expiresAt > t); yield e.pubkey
6627− let safeDeduped = if count localClashes > 0
6628− then do d <- deduped; where not (any localClashes (\pk -> pk == d.pubkey)); yield d
6629− else deduped
6630− let safeTrustedOffline = if count localClashes > 0
6631− then do d <- trustedOffline; where not (any localClashes (\pk -> pk == d.pubkey)); yield d
6632− else trustedOffline
6633− -- Pre-filter: when near capacity, reject gossip entries for pubkeys not already in presence.
6634− -- This prevents a malicious peer from spiking presence above maxPresenceEntries via large batches.
6635− let capacityDeduped = if tpc >= maxPresenceEntries
6636− then do d <- safeDeduped; where any selectedPresence (\p -> p.pubkey == d.pubkey); yield d
6637− else safeDeduped
6638− let gm = mergeGossipPresence selectedPresence capacityDeduped safeTrustedOffline fromServer t
6639− -- Write back only affected buckets (not writeAllPresence, which would zero unaffected buckets)
6640− writeSelectedPresenceBuckets affectedBuckets gm.finalPresence
6641− let delta = count gm.finalPresence - count selectedPresence
6642− set *totalPresenceCount = max 0 (tpc + delta)
6643− -- Merge new peer servers with existing known peers (selected buckets may not contain all peers)
6644− knownPeers <- *knownPeerServers
6645− let newPeers = gm.gossipPeerServers
6646− set *knownPeerServers = fold (\acc s -> if any acc (\a -> a == s) then acc else union [s] acc) knownPeers newPeers
6647− set *presenceVersion = t
6648− yield {gm: gm, preFiltered: count safeDeduped - count capacityDeduped, localClashCount: count localClashes}
6649− when (gossipResult.localClashCount > 0)
6650− (logWarn ("gossip: " ++ fromServer ++ " claims " ++ show gossipResult.localClashCount ++ " locally-authenticated key(s) — filtered from merge"))
6651− -- seenBy for re-broadcast: include fromServer (sender) and ourselves so downstream
6652− -- peers that share connections with either skip this event.
6653− let rebroadcastSeenBy = if any [fromServer] (\s -> s == serverHostN) then [serverHostN] else [fromServer, serverHostN]
6654− let effectiveEvents = union (effectiveGossipEvents filteredOnline gossipResult.gm.appliedKeys (GossipOnline {}) rebroadcastSeenBy) (effectiveGossipEvents filteredOffline gossipResult.gm.appliedKeys (GossipOffline {}) rebroadcastSeenBy)
6655− when (not gossipResult.gm.withinCapacity || gossipResult.preFiltered > 0)
6656− (logWarn ("gossip: presence at capacity (" ++ show maxPresenceEntries ++ "), limiting new entries from " ++ fromServer ++ " (pre-filtered: " ++ show gossipResult.preFiltered ++ ")"))
6657− -- Suppress re-broadcast of events we've already gossiped recently (prevents amplification)
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
6669− yield fresh
6670− let newlyOnlineRemote = newlyOnlineRemoteKeys filteredOnline gossipResult.gm.appliedKeys
6671− fork (do
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)
6680− sleep 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))
1778+ found <- atomic do
1779+ pending <- *pendingVerifications
1780+ let candidates = do p <- pending; where p.scope == scope && t - p.createdAt < verificationTokenExpiry; yield p
1781+ let match = any candidates (\p -> safeCompare p.token token)
1782+ when match (set *pendingVerifications = do p <- pending; where p.scope != scope || not (safeCompare p.token token); yield p)
1783+ yield match
1784+ yield (respond {ok: found})
1785+
1786+handleFederationPubkey = \respond -> do
1787+ yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})
1788+
1789+isOnlineEvent : GossipEventType -> Bool
1790+isOnlineEvent = \et -> case et of
1791+ GossipOnline {} -> True {}
1792+ _ -> False {}
1793+
1794+isOfflineEvent : GossipEventType -> Bool
1795+isOfflineEvent = \et -> case et of
1796+ GossipOffline {} -> True {}
1797+ _ -> False {}
1798+
1799+handleRecvGossip = \events hopsRemaining fromServer requestTimestamp correlationId authorization respond -> do
1800+ t <- now
1801+ let cappedHops = clamp 0 maxGossipHops hopsRemaining
1802+ withFederationAuth authorization t respond fromServer "gossip" requestTimestamp (cappedHops >= 1 && not (isLocalServer fromServer) && count events <= maxGossipEvents) (do
1803+ valid <- atomic do
1804+ pres <- *presence
1805+ let validEvents = do
1806+ e <- events
1807+ where not (isLocalServer e.server) && e.timestamp <= t + clockSkewTolerance
1808+ let ttl = clampTtl e.ttl
1809+ let effectiveTs = min e.timestamp t
1810+ let expiresAt = effectiveTs + ttl * 1000
1811+ where expiresAt > t
1812+ yield {pubkey: e.pubkey, server: e.server, expiresAt: expiresAt, timestamp: e.timestamp, eventType: e.eventType}
1813+ let online = do v <- validEvents; where isOnlineEvent v.eventType; yield {pubkey: v.pubkey, server: v.server, expiresAt: v.expiresAt, timestamp: v.timestamp}
1814+ let offline = do v <- validEvents; where isOfflineEvent v.eventType; yield {pubkey: v.pubkey, server: v.server, timestamp: v.timestamp}
1815+ let withoutOffline = do
1816+ p <- pres
1817+ where none offline (\o -> samePubkeyServer o p && o.timestamp > p.timestamp)
1818+ yield p
1819+ let merged = mergePresence withoutOffline online
1820+ set *presence = capList merged maxPresenceEntries (\p -> p.expiresAt)
1821+ let newlyOnline = do
1822+ e <- online
1823+ where not (isLocalServer e.server)
1824+ where none pres (\p -> samePubkeyServer p e && p.expiresAt >= e.expiresAt)
1825+ yield {pubkey: e.pubkey, server: e.server}
1826+ yield {newlyOnline: newlyOnline}
1827+ when (count valid.newlyOnline > 0)
1828+ (fork (forwardForNewlyOnline valid.newlyOnline t))
66911829 yield (respond {ok: True {}, error: "", retryAfterMs: 0}))
66921830
6693−-- POST /federation/forward: Receive a message forwarded from a peer server.
6694−-- Accepts both direct forwards (fromServer == originServer) and relay forwards
6695−-- (fromServer != originServer) where an intermediate server re-forwards because
6696−-- the recipient moved. Cascade is bounded by dedup (same messageId won't be stored
6697−-- twice) and forwardCandidates (won't re-forward to the same server).
1831+forwardForNewlyOnline = \targets t ->
1832+ case headOf targets of
1833+ Nothing {} -> yield {}
1834+ Just {value: tgt} -> do
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
1838+
66981839handleForwardMessage = \toKey encryptedBlob timestamp originServer messageId fromServer requestTimestamp correlationId expiresAt priority authorization respond -> do
66991840 t <- now
6700− let corrId = sanitizeCorrelationId correlationId
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 {})
6713− else do
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)
6720− if not originOk
6721− then do
6722− logWarn ("forward: rejected relay with untrusted origin " ++ originServer ++ " from " ++ fromServer)
6723− yield (respond {ok: False {}, error: "unknown_origin", retryAfterMs: 0})
6724− else do
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).
1841+ withFederationAuth authorization t respond fromServer ("forward:" ++ messageId) requestTimestamp (not (isLocalServer originServer) && not (isLocalServer fromServer)) (do
67281842 if t - timestamp > messageMaxAge
67291843 then yield (respond {ok: False {}, error: "stale_timestamp", retryAfterMs: 0})
67301844 else do
6731− -- Presence check + message storage in a single atomic block to prevent TOCTOU
6732− -- race where a key goes offline between presence check and store.
6733− let clampedTs = clampTimestamp timestamp t
6734− result <- atomic do
6735− -- Verify recipient has active presence on this server. Peers should only forward
6736− -- to us if gossip indicated the key is here. Accepting messages for completely
6737− -- unknown keys wastes mailbox slots that will never be drained by polling.
6738− -- All sharded collections (presence, messages, acked, delivered, nonces) use
6739− -- pubkeyBucket(toKey), so a single index serves all reads in this block.
6740− let bkt = pubkeyBucket toKey
6741− presenceBkt <- readPresenceBucket bkt
6742− let hasPresence = any presenceBkt (\p -> p.pubkey == toKey && p.expiresAt > t)
6743− if not hasPresence
6744− then yield {forward: ForwardRejected {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: True {}, nonceCutoffRejected: False {}}
6745− else do
6746− bucket <- readMessageBucket bkt
6747− ackedBkt <- readAckedBucket bkt
6748− delivBkt <- readDelivBucket bkt
6749− -- Sharded nonce check: reads only the bucket for this recipient's pubkey (O(n/16) vs O(n)).
6750− nonceBkt <- readNonceBucket bkt
6751− -- Nonce check ignores originServer: a (messageId, toKey) pair is globally unique,
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)
6755− if isDup
6756− then yield {forward: ForwardDuplicate {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: False {}}
6757− else do
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 {}}
6766− else do
6767− totalMsgCount <- *totalMessageCount
6768− if totalMsgCount >= maxMessages
6769− then yield {forward: ForwardRejected {}, globalCapReached: True {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: False {}}
6770− else do
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 {}}
1845+ let clampedTs = clampTimestamp timestamp t
1846+ result <- atomic do
1847+ pres <- *presence
1848+ let hasPresence = any pres (\p -> p.pubkey == toKey && p.expiresAt > t)
1849+ if not hasPresence then yield "no_presence"
1850+ else do
1851+ msgs <- *messages
1852+ aids <- *ackedIds
1853+ dids <- *deliveredIds
1854+ let isDup = any msgs (\m -> m.messageId == messageId && m.toKey == toKey)
1855+ || hasMessage messageId toKey aids
1856+ || hasMessage messageId toKey dids
1857+ if isDup then yield "duplicate"
1858+ else if count msgs >= maxMessages then yield "global_full"
1859+ else
1860+ let rcCount = count (do m <- msgs; where m.toKey == toKey; yield m) in
1861+ if rcCount >= maxMessagesPerRecipient then yield "mailbox_full"
1862+ else do
1863+ rr <- *recvRates
1864+ let r = checkRate rr toKey maxRecvRatePerKey recvRateWindowMs 5000 t
1865+ if r.limited then yield "rate_limited"
67761866 else do
6777− recvRates <- *recvRates
6778− recvRate <- effectiveRecvRate
6779− let recvResult = checkPubkeyRate recvRates toKey recvRate recvRateWindowMs maxRecvRateEntries t
6780− if recvResult.limited
6781− then yield {forward: ForwardRejected {}, globalCapReached: False {}, recvRateLimited: True {}, noPresence: False {}, nonceCutoffRejected: False {}}
6782− else do
6783− set *recvRates = recvResult.entries
6784− federationPairRates <- *federationPairRates
6785− let fedPairResult = checkServerRecipientRate federationPairRates fromServer toKey maxFederationPairRatePerPair federationPairRateWindowMs maxFederationPairRateEntries t
6786− if fedPairResult.limited
6787− then yield {forward: ForwardRejected {}, globalCapReached: False {}, recvRateLimited: False {}, noPresence: False {}, nonceCutoffRejected: False {}}
6788− else do
6789− set *federationPairRates = fedPairResult.entries
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})
6809− else do
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 ++ ")")
6819− _ -> yield {}
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}))
6823−
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
6840− then atomic do
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})
6843− else yield []
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
6851− if overCap then do
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
6865−
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.
1867+ set *recvRates = r.entries
1868+ seq <- *seqCounter
1869+ let seqTs = nextSeqTs t seq
1870+ set *seqCounter = seqTs
1871+ let fwdExpiresAt = if expiresAt > t then min expiresAt (seqTs + unackedMessageMaxAge) else seqTs + unackedMessageMaxAge
1872+ let clampedPri = clamp 0 maxMessagePriority priority
1873+ set *messages = union msgs [{messageId: messageId, toKey: toKey, encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: seqTs, expiresAt: fwdExpiresAt, senderKey: "", priority: clampedPri}]
1874+ set *pollWakeup = seqTs
1875+ yield "stored"
1876+ if result == "stored" || result == "duplicate"
1877+ then yield (respond {ok: True {}, error: "", retryAfterMs: 0})
1878+ else yield (respond {ok: False {}, error: result, retryAfterMs: 0}))
1879+
68691880handleFederationAck = \messageIds originServer fromServer requestTimestamp correlationId authorization respond -> do
68701881 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
68741882 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
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
1883+ withFederationAuth authorization t ackRespond fromServer "ack" requestTimestamp (isLocalServer originServer && not (isLocalServer fromServer)) (do
68791884 let dedupedIds = dedupMessageIds messageIds
6880− -- Clear forward entries for the acking server. Extract removed forwards' toKey
6881− -- so we can reclaim origin messages that are no longer needed.
6882− -- Optimized: scan all 16 forward buckets but only rewrite those that changed.
6883− -- Avoids the O(n) writeAllForwards repartitioning when only a few buckets are affected.
6884− removedForwards <- removeForwardsByServer fromServer dedupedIds 0 []
6885− let ackedCount = count removedForwards
6886− let unmatched = count dedupedIds - ackedCount
6887− -- Reject when ALL acked IDs are unmatched: the peer is acking messages we never
6888− -- forwarded to it. Partial matches are accepted (some forwards may have been pruned).
6889− if ackedCount == 0 && count dedupedIds > 0
6890− then do
6891− logWarn ("federation/ack: rejecting ack from " ++ fromServer ++ " — all " ++ show (count dedupedIds) ++ " messageIds unmatched (no forward entries)")
6892− logEvent "warn" "ack_all_unmatched" (fromServer ++ " " ++ show (count dedupedIds))
6893− yield (respond {ok: False {}, error: "no_matching_forwards", ackedCount: 0, results: do mid <- dedupedIds; yield {messageId: mid, found: False {}}, retryAfterMs: 0})
6894− else do
6895− when (unmatched > 0) (do
6896− logWarn ("federation/ack: " ++ fromServer ++ " acked " ++ show unmatched ++ " messageIds with no matching forward entries — skipping cleanup for those")
6897− logEvent "warn" "ack_partial_unmatched" (fromServer ++ " " ++ show unmatched ++ "/" ++ show (count dedupedIds)))
6898− -- Only clear failure record when ALL acked IDs matched forward entries.
6899− -- Prevents a malicious peer from resetting its backoff by padding ack requests
6900− -- with known messageIds that no longer have forward entries.
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}))
6934−
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.
1885+ result <- atomic do
1886+ fwds <- *forwards
1887+ let removed = do f <- fwds; where f.toServer == fromServer && any dedupedIds (\m -> m == f.messageId); yield f
1888+ set *forwards = do f <- fwds; where not (f.toServer == fromServer && any dedupedIds (\m -> m == f.messageId)); yield f
1889+ -- Reclaim origin messages with no remaining forwards
1890+ msgs <- *messages
1891+ let removedIds = do f <- removed; yield f.messageId
1892+ pres <- *presence
1893+ remainingFwds <- *forwards
1894+ let toReap = do
1895+ m <- msgs
1896+ where any removedIds (\mid -> mid == m.messageId)
1897+ where t - m.receivedAt >= ackGracePeriod
1898+ where none pres (\p -> p.pubkey == m.toKey && isLocalServer p.server && p.expiresAt > t)
1899+ where none remainingFwds (\f -> f.messageId == m.messageId && f.toKey == m.toKey)
1900+ yield m
1901+ set *messages = do m <- msgs; where none toReap (\r -> r.messageId == m.messageId && r.toKey == m.toKey); yield m
1902+ let perResult = do mid <- dedupedIds; yield {messageId: mid, found: any removed (\f -> f.messageId == mid)}
1903+ yield {ackedCount: count removed, results: perResult}
1904+ yield (respond {ok: True {}, error: "", ackedCount: result.ackedCount, results: result.results, retryAfterMs: 0}))
1905+
69461906handleFederationCancel = \messageId toKey fromServer requestTimestamp correlationId authorization respond -> do
69471907 t <- now
6948− let corrId = sanitizeCorrelationId correlationId
6949− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " cancel " ++ messageId ++ " from " ++ fromServer))
69501908 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
6952− result <- atomic do
6953− let b = pubkeyBucket toKey
6954− bucket <- readMessageBucket b
6955− -- Only cancel messages that originated from the requesting server
6956− let toCancel = headOf (do m <- bucket; where m.messageId == messageId && m.toKey == toKey && m.originServer == fromServer; yield m)
6957− case toCancel of
6958− Nothing {} -> yield {cancelled: False {}}
1909+ withFederationAuth authorization t cancelRespond fromServer ("cancel:" ++ messageId) requestTimestamp (not (isLocalServer fromServer)) (do
1910+ cancelled <- atomic do
1911+ msgs <- *messages
1912+ let target = headOf (do m <- msgs; where m.messageId == messageId && m.toKey == toKey && m.originServer == fromServer; yield m)
1913+ case target of
1914+ Nothing {} -> yield False
69591915 Just {} -> do
6960− writeMessageBucket b (do m <- bucket; where not (m.messageId == messageId && m.toKey == toKey); yield m)
6961− tc <- *totalMessageCount
6962− set *totalMessageCount = max 0 (tc - 1)
6963− rc <- readRcBucket b
6964− writeRcBucket b (adjustRecipientCount rc toKey (0 - 1))
6965− -- Also cancel pending forwards for this message
6966− fwdBkt <- readFwdBucket b
6967− let keptFwds = do f <- fwdBkt; where not (f.messageId == messageId && f.toKey == toKey); yield f
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}))
6986−
6987−-- POST /federation/cancel-batch: Batch cancel multiple previously forwarded messages.
6988−-- Reuses the cancel logic from handleFederationCancel for each entry.
1916+ set *messages = do m <- msgs; where not (m.messageId == messageId && m.toKey == toKey); yield m
1917+ fwds <- *forwards
1918+ set *forwards = do f <- fwds; where not (f.messageId == messageId && f.toKey == toKey); yield f
1919+ cn <- *cancelNotifications
1920+ set *cancelNotifications = capList (union cn [{toKey: toKey, messageId: messageId, cancelledAt: t}]) 10000 (\c -> c.cancelledAt)
1921+ yield True
1922+ yield (respond {ok: True {}, error: "", cancelled: cancelled, retryAfterMs: 0}))
1923+
69891924handleFederationBatchCancel = \cancels fromServer requestTimestamp correlationId authorization respond -> do
69901925 t <- now
6991− let corrId = sanitizeCorrelationId correlationId
6992− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " cancel-batch (" ++ show (count cancels) ++ " entries) from " ++ fromServer))
69931926 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
69951928 let capped = takeRelation maxBatchSize cancels
6996− results <- cancelBatchInner 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)
1929+ results <- federationCancelEach capped fromServer t []
70011930 yield (respond {ok: True {}, error: "", results: results, retryAfterMs: 0}))
70021931
7003−-- Process cancel entries grouped by bucket: all entries sharing a pubkeyBucket are
7004−-- processed in a single atomic block, reducing bucket reads from O(entries) to O(buckets).
7005−cancelBatchInner = \entries fromServer t acc ->
1932+federationCancelEach = \entries fromServer t acc ->
70061933 case headOf entries of
70071934 Nothing {} -> yield acc
7008− Just {value: first} -> do
7009− let b = pubkeyBucket first.toKey
7010− -- Collect all entries targeting the same bucket
7011− let sameBucket = do e <- entries; where pubkeyBucket e.toKey == b; yield e
7012− let otherBuckets = do e <- entries; where pubkeyBucket e.toKey != b; yield e
7013− -- Process the entire bucket group in one atomic block.
7014− -- Read buckets once upfront and thread state through the recursion.
7015− results <- atomic do
7016− bucket <- readMessageBucket b
7017− fwdBkt <- readFwdBucket b
7018− nonceBkt <- readNonceBucket b
7019− rc <- readRcBucket b
7020− r <- cancelBucketGroupInner sameBucket fromServer b t [] bucket fwdBkt nonceBkt rc 0 0
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))
7033− yield r.acc
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 {}
7039− Just {} -> do
7040− queueCancelNotificationBatch cancelledEntries t
7041− cancelBatchInner otherBuckets fromServer t (union acc results)
1935+ Just {value: e} -> do
1936+ let rest = do x <- entries; where x.messageId != e.messageId; yield x
1937+ cancelled <- atomic do
1938+ msgs <- *messages
1939+ let target = headOf (do m <- msgs; where m.messageId == e.messageId && m.toKey == e.toKey && m.originServer == fromServer; yield m)
1940+ case target of
1941+ Nothing {} -> yield False
1942+ Just {} -> do
1943+ set *messages = do m <- msgs; where not (m.messageId == e.messageId && m.toKey == e.toKey); yield m
1944+ fwds <- *forwards
1945+ set *forwards = do f <- fwds; where not (f.messageId == e.messageId && f.toKey == e.toKey); yield f
1946+ yield True
1947+ federationCancelEach rest fromServer t (union acc [{messageId: e.messageId, cancelled: cancelled}])
70421948
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)
7052− case toCancel of
7053− Nothing {} ->
7054− cancelBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, cancelled: False {}}]) bucket fwdBkt nonceBkt rc msgRemoved fwdRemoved
7055− Just {} -> do
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
7064− else updatedNonces
7065− cancelBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, cancelled: True {}}]) newBucket newFwdBkt newNonceBkt newRc (msgRemoved + 1) (fwdRemoved + entryFwdRemoved)
7066−
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.
70701949handleFederationBatchForward = \forwards fromServer requestTimestamp correlationId authorization respond -> do
70711950 t <- now
7072− let corrId = sanitizeCorrelationId correlationId
7073− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " forward-batch (" ++ show (count forwards) ++ " entries) from " ++ fromServer))
70741951 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
70761953 let capped = takeRelation maxBatchSize forwards
7077− -- Pre-deduplicate (messageId, toKey) pairs: a malicious peer could send 100 entries
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))
1954+ results <- federationForwardEach capped fromServer t []
70851955 yield (respond {ok: True {}, error: "", results: results, retryAfterMs: 0}))
70861956
7087−-- Process forward entries grouped by bucket: all entries sharing a pubkeyBucket(toKey) are
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)
7102−
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 {}}])
7113− else
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
7119− in if not originOk
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
7122−
7123−-- Group validated entries by pubkeyBucket and process each group in one atomic block.
7124−forwardBatchByBucket = \entries fromServer t acc ->
1957+federationForwardEach = \entries fromServer t acc ->
71251958 case headOf entries of
71261959 Nothing {} -> yield acc
7127− Just {value: first} -> do
7128− let b = pubkeyBucket first.toKey
7129− let sameBucket = do e <- entries; where pubkeyBucket e.toKey == b; yield e
7130− let otherBuckets = do e <- entries; where pubkeyBucket e.toKey != b; yield e
7131− -- Process the entire bucket group in one atomic block.
7132− -- Read bucket-local state once upfront and thread through the recursion.
7133− results <- atomic do
7134− presenceBkt <- readPresenceBucket b
7135− bucket <- readMessageBucket b
7136− ackedBkt <- readAckedBucket b
7137− delivBkt <- readDelivBucket b
7138− nonceBkt <- readNonceBucket b
7139− rc <- readRcBucket b
7140− rr <- *recvRates
7141− fpr <- *federationPairRates
7142− r <- forwardBucketGroupInner sameBucket fromServer b t [] presenceBkt bucket ackedBkt delivBkt nonceBkt rc 0 rr fpr
7143− -- Write back modified bucket-local state once after processing all entries
7144− writeMessageBucket b r.bucket
7145− writeNonceBucket b r.nonceBkt
7146− writeRcBucket b r.rc
7147− set *recvRates = r.recvRates
7148− set *federationPairRates = r.fedPairRates
7149− -- Batch-adjust totalMessageCount once (not per-entry)
7150− when (r.msgStored > 0) (do
7151− tc <- *totalMessageCount
7152− set *totalMessageCount = tc + r.msgStored)
7153− yield r.acc
7154− forwardBatchByBucket otherBuckets fromServer t (union acc results)
7155−
7156−-- Process all forward entries for a single bucket within one atomic block.
7157−-- Threads bucket-local state through recursion to avoid redundant per-entry reads.
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)
7168− if not hasPresence
7169− then forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: False {}}]) presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored rr fpr
7170− else do
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)
7172− if isDup
7173− then forwardBucketGroupInner rest fromServer b t (union acc [{messageId: entry.messageId, ok: True {}}]) presenceBkt bucket ackedBkt delivBkt nonceBkt rc msgStored rr fpr
7174− else do
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
7179− else do
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
7185− else do
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
7190− else do
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
7195− else do
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
7209− else updatedNonces
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
7211−
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.
1960+ Just {value: e} -> do
1961+ let rest = do x <- entries; where x.messageId != e.messageId; yield x
1962+ ok <- if isLocalServer e.originServer || t - e.timestamp > messageMaxAge then yield False
1963+ else atomic do
1964+ pres <- *presence
1965+ let hasPresence = any pres (\p -> p.pubkey == e.toKey && p.expiresAt > t)
1966+ if not hasPresence then yield False
1967+ else do
1968+ msgs <- *messages
1969+ aids <- *ackedIds
1970+ dids <- *deliveredIds
1971+ let isDup = any msgs (\m -> m.messageId == e.messageId && m.toKey == e.toKey)
1972+ || hasMessage e.messageId e.toKey aids
1973+ || hasMessage e.messageId e.toKey dids
1974+ if isDup then yield True
1975+ else if count msgs >= maxMessages then yield False
1976+ else
1977+ let rcCount = count (do m <- msgs; where m.toKey == e.toKey; yield m) in
1978+ if rcCount >= maxMessagesPerRecipient then yield False
1979+ else do
1980+ seq <- *seqCounter
1981+ let seqTs = nextSeqTs t seq
1982+ set *seqCounter = seqTs
1983+ let clampedTs = clampTimestamp e.timestamp t
1984+ let fwdExpiresAt = if e.expiresAt > t then min e.expiresAt (seqTs + unackedMessageMaxAge) else seqTs + unackedMessageMaxAge
1985+ let clampedPri = clamp 0 maxMessagePriority e.priority
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}]
1987+ set *pollWakeup = seqTs
1988+ yield True
1989+ federationForwardEach rest fromServer t (union acc [{messageId: e.messageId, ok: ok}])
1990+
72171991handleFederationDeliveryReceipt = \messageIds toKeys fromServer requestTimestamp correlationId authorization respond -> do
72181992 t <- now
7219− let corrId = sanitizeCorrelationId correlationId
7220− when (corrId != "") (logInfo ("[CORR] " ++ corrId ++ " delivery-receipt from " ++ fromServer))
72211993 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
7223− -- Pair messageIds with toKeys (parallel arrays). Reject if lengths differ.
1994+ withFederationAuth authorization t receiptRespond fromServer "delivery-receipt" requestTimestamp (not (isLocalServer fromServer) && count messageIds <= maxMessageIds) (do
72241995 if count messageIds != count toKeys
72251996 then yield (respond {ok: False {}, error: "mismatched_lengths", receivedCount: 0, retryAfterMs: 0})
72261997 else do
7227− -- Zip parallel arrays into pairs upfront (O(n) once), then consume head-first.
7228− -- Previous code used fold-to-index-N per element, making receiptsByBucket O(n^2).
7229− let capped = takeRelation maxMessageIds messageIds
7230− let pairs = zipParallelArrays capped toKeys
7231− -- Look up senderKey per-bucket and record delivery receipts
7232− receiptsByBucket pairs t
7233− yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))
7234−
7235−-- Zip two parallel arrays into a list of {messageId, toKey} pairs.
7236−-- Consumes both lists head-first in O(n), replacing the O(n^2) fold-to-index pattern.
7237−-- Uses skipRelation 1 instead of filter-not-equal to correctly handle duplicate values:
7238−-- filter (where m != mid) removes ALL occurrences of mid, corrupting the pairing when
7239−-- the same messageId appears multiple times (e.g., same message sent to different recipients).
7240−-- skipRelation 1 removes only the first element regardless of duplicates.
7241−zipParallelArrays : [MessageIdHex] -> [PubkeyHex] -> [{messageId: MessageIdHex, toKey: PubkeyHex}]
7242−zipParallelArrays = \mids keys ->
1998+ let pairs = zipPairs messageIds toKeys
1999+ atomic do
2000+ msgs <- *messages
2001+ sd <- *senderDeliveries
2002+ let receipts = do
2003+ p <- pairs
2004+ m <- msgs
2005+ where m.messageId == p.messageId && m.toKey == p.toKey && m.senderKey != "" && m.originServer == ""
2006+ yield {senderKey: m.senderKey, messageId: p.messageId, toKey: p.toKey, deliveredAt: t}
2007+ set *senderDeliveries = capList (union sd receipts) 10000 (\d -> d.deliveredAt)
2008+ yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))
2009+
2010+zipPairs = \mids keys ->
72432011 case headOf mids of
7244− Nothing {} -> []
7245− Just {value: mid} ->
7246− case headOf keys of
7247− Nothing {} -> []
7248− Just {value: key} ->
7249− union [{messageId: mid, toKey: key}] (zipParallelArrays (skipRelation 1 mids) (skipRelation 1 keys))
7250−
7251−-- Look up senderKey from messages and record delivery receipts.
7252−-- Groups pairs by pubkeyBucket so each message bucket is read once per group instead
7253−-- of once per receipt. With 10 receipts targeting the same bucket, this reduces bucket
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
7264− atomic do
7265− bucket <- readMessageBucket b
7266− sd <- *senderDeliveries
7267− let updatedSd = receiptsBucketInner sameBucket bucket sd t
7268− set *senderDeliveries = updatedSd
7269− receiptsByBucket otherBuckets t
7270−
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
7276− Nothing {} -> sd
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
7280− case msg of
7281− Nothing {} -> receiptsBucketInner rest bucket sd t
7282− Just {value: m} ->
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)
7288− else combined
7289− in receiptsBucketInner rest bucket updatedSd t
7290−
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
7294− t <- now
7295− dp <- *drainPhase
7296− if dp >= 2 then yield (respond {results: [], authorized: False {}, error: ""})
7297− else do
7298− globalRateLimited <- checkGlobalRate t
7299− if globalRateLimited then yield (respond {results: [], authorized: False {}, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
7300− else
7301− withSessionAuth authorization t clientIp
7302− (yield (respond {results: [], authorized: False {}, error: "unauthorized"}))
7303− (\senderKey -> do
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"})
7311− else do
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
7321− cancelT <- now
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
7329− Err e -> do
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: ""}))
7336−
7337−-- Process each client cancel entry, returning results and federation cancel targets.
7338−clientCancelBatchInner = \senderKey entries t resultAcc fedAcc ->
7339− case headOf entries of
7340− Nothing {} -> do
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)
7349− case toCancel of
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: []}
7354− else do
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}]
7384− else fedAcc
7385− clientCancelBatchInner senderKey rest t (union resultAcc [{messageId: entry.messageId, cancelled: cancelResult.cancelled}]) newFedAcc
7386−
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)
2012+ Nothing {} -> []
2013+ Just {value: mid} -> case headOf keys of
2014+ Nothing {} -> []
2015+ Just {value: key} ->
2016+ union [{messageId: mid, toKey: key}] (zipPairs (skipN 1 mids) (skipN 1 keys))
2017+
2018+-- ============================================
2019+-- Maintenance handlers
2020+-- ============================================
2021+
73912022handleDrain = \phase authorization respond -> do
7392− t <- now
73932023 authorized <- verifyMaintenanceAuth authorization
73942024 if not authorized then yield (respond {ok: False {}, drained: 0, phase: 0})
73952025 else do
7396− logEvent "audit" "drain" ("phase=" ++ show phase)
7397− -- Effective phase: 0 or >=2 means full drain (backward compat for clients sending empty body)
73982026 let effectivePhase = if phase == 1 then 1 else 2
7399− -- Idempotency: if already at or above requested phase, return success.
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})
7410− else do
2027+ t <- now
74112028 drainResult <- atomic do
7412− set *drainPhase = 2
7413− allPresence <- readAllPresence
7414− let localEntries = do p <- allPresence; where isLocalServer p.server && p.expiresAt > t; yield p
7415− let remainingPresence = do p <- allPresence; where not (isLocalServer p.server) || p.expiresAt <= t; yield p
7416− writeAllPresence remainingPresence
7417− set *totalPresenceCount = count remainingPresence
7418− set *presenceVersion = t
7419− set *pollWakeup = t
7420− -- Use cached knownPeerServers instead of recomputing from allPresence
7421− -- (knownPeerServers is updated every prune cycle, equivalent for gossip targets)
7422− peerServers <- *knownPeerServers
7423− yield {localEntries: localEntries, peerServers: peerServers}
7424− let drainedCount = count drainResult.localEntries
7425− -- Read pending federation state atomically (fix: was read outside atomic)
7426− flushState <- atomic do
7427− f <- readAllForwards
7428− a <- readAllAcked
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
7440− let newDg = dg + 1
7441− set *drainGeneration = newDg
7442− set *drainCompletedAt = 0
7443− yield newDg
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.
7446− fork (do
7447− sleep drainTimeoutMs
7448− tTimeout <- now
7449− atomic do
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")))
7455− fork (do
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))
7468− t2 <- now
7469− -- Only set if deadline timer hasn't already force-completed and drain generation matches
7470− atomic do
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})
7480−
7481−-- POST /maintenance/undrain: Resume accepting requests after a drain.
7482−-- Background loops (prune, heartbeat) automatically resume on next iteration.
2029+ set *drainPhase = effectivePhase
2030+ set *drainCompletedAt = t
2031+ if effectivePhase == 1 then yield {drainedCount: 0, peers: [], localKeys: []}
2032+ else do
2033+ pres <- *presence
2034+ let localEntries = do p <- pres; where isLocalServer p.server && p.expiresAt > t; yield p
2035+ set *presence = do p <- pres; where not (isLocalServer p.server) || p.expiresAt <= t; yield p
2036+ set *pollWakeup = t
2037+ let peers = knownPeerServersFromPresence pres
2038+ yield {drainedCount: count localEntries, peers: peers, localKeys: localEntries}
2039+ when (effectivePhase == 2 && count drainResult.localKeys > 0 && count drainResult.peers > 0 && federationEnabled)
2040+ (fork (sendBatchedGossip drainResult.peers (do p <- drainResult.localKeys; yield {eventType: GossipOffline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl, seenBy: [serverHostN]}) gossipOriginHops))
2041+ yield (respond {ok: True {}, drained: drainResult.drainedCount, phase: effectivePhase})
2042+
74832043handleUndrain = \authorization respond -> do
74842044 authorized <- verifyMaintenanceAuth authorization
74852045 if not authorized then yield (respond {ok: False {}})
74862046 else do
7487− logEvent "audit" "undrain" ""
7488− wasDraining <- atomic do
7489− d <- *drainPhase
2047+ atomic do
74902048 set *drainPhase = 0
74912049 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 = []
7497− yield (d > 0)
7498− when wasDraining (logInfo "undrain: server resumed, accepting new requests")
7499− when (not wasDraining) (logInfo "undrain: server was not draining")
75002050 yield (respond {ok: True {}})
75012051
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).
75052052handleShutdown = \authorization respond -> do
7506− t <- now
75072053 authorized <- verifyMaintenanceAuth authorization
75082054 if not authorized then yield (respond {ok: False {}, drained: 0})
7509− else do
7510− logEvent "audit" "shutdown" ""
7511− dp <- *drainPhase
7512− if dp >= 2 then do
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})
7517− else do
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})
2055+ else handleDrain 2 authorization (\r -> respond {ok: r.ok, drained: r.drained})
75212056
7522−-- POST /maintenance/prune: Trigger a full maintenance cycle (prune + retry all pending ops).
7523−-- Accepts either federation or maintenance secret.
75242057handlePrune = \authorization respond -> do
75252058 t <- now
7526− dp <- *drainPhase
7527− authOk <- verifyMaintenanceAuth authorization
7528− let authorized = authOk && dp < 2
2059+ authorized <- verifyMaintenanceAuth authorization
75292060 when authorized (fork (pruneAndRetry t))
75302061 yield (respond {ok: authorized})
75312062
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.
75352063handleReconcile = \authorization respond -> do
75362064 authorized <- verifyMaintenanceAuth authorization
75372065 if not authorized then yield (respond {ok: False {}, messageDrift: 0, presenceDrift: 0, sessionDrift: 0})
7538− else do
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})
7559−
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
7568− sa <- *startedAt
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
7578− dp <- *drainPhase
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,
7618− watchdogOk: wdOk,
7619− nonceOk: nonceOk,
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
7625− atomic do
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
7637− yield result
7638−
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
7654− dp <- *drainPhase
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)
2066+ else yield (respond {ok: True {}, messageDrift: 0, presenceDrift: 0, sessionDrift: 0})
76572067
76582068handleHealth = \authorization respond -> do
76592069 t <- now
7660− -- Health checks exempt from global rate limiting (monitoring traffic shouldn't starve real requests)
7661− -- but have their own dedicated rate limiter to prevent DDoS on /health from saturating reads.
7662− healthLimited <- checkHealthRate t
7663− if healthLimited then readCachedHealth respond
7664− else do
7665− isAuthed <- verifyMaintenanceAuth authorization
7666− -- Unauthenticated callers get cached results (constant-time, no live computation).
7667− -- This prevents timing side-channels: an attacker cannot infer server load by measuring
7668− -- response time differences between cached (fast) and computed (slow) health checks.
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.
7674− if not isAuthed
7675− then readCachedHealth respond
7676− else do
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})
7690−
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}}
7692−
7693−handleStats = \authorization respond -> do
7694− t <- now
7695− globalRateLimited <- checkGlobalRate t
7696− if globalRateLimited then yield (respond zeroStats)
7697− else do
7698− authorized <- verifyMaintenanceAuth authorization
7699− if authorized
7700− then do
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
7707− core <- atomic do
7708− sc <- *totalSessionCount
7709− pc <- *totalPresenceCount
7710− c <- *challenges
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
7714− ao <- *ackOverflow
7715− dCount <- countAllDelivered 0
7716− ff <- *forwardFailures
7717− ap <- *activePolls
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
7733− sr <- *sendRates
7734− cr <- *challengeRates
7735− fr <- *federationRates
7736− fpr <- *federationPairRates
7737− grc <- *globalRateCount
7738− ir <- *ipRates
7739− lr <- *lookupRates
7740− rr <- *recvRates
7741− prr <- *pairRates
7742− pc <- *pruneCount
7743− pr <- *pruneRunning
7744− hc <- *heartbeatCount
7745− sa <- *startedAt
7746− lp <- *lastPrunedAt
7747− lh <- *lastHeartbeatAt
7748− dr <- *drainPhase
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)
7818−
7819−handleStatsPeers = \authorization respond -> do
7820− t <- now
7821− globalRateLimited <- checkGlobalRate t
7822− if globalRateLimited then yield (respond {peers: [], ok: False {}})
7823− else do
7824− authorized <- verifyMaintenanceAuth authorization
7825− if authorized
7826− then do
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 {}})
2070+ lastPrune <- *lastPrunedAt
2071+ lastHb <- *lastHeartbeatAt
2072+ sa <- *startedAt
2073+ dp <- *drainPhase
2074+ let warmup = t - sa < backgroundPruneInterval * 3
2075+ let pruneOk = warmup || t - lastPrune < backgroundPruneInterval * 3
2076+ let heartbeatOk = warmup || t - lastHb < pollTimeoutMs * 3
2077+ let allOk = dp == 0 && pruneOk && heartbeatOk
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})
78452079
7846−handleStatsKey = \pubkey authorization respond -> do
7847− t <- now
7848− globalRateLimited <- checkGlobalRate t
7849− if globalRateLimited then yield (respond {messages: 0, presence: [], sessions: 0, forwards: 0, activePolls: 0, ok: False {}})
7850− else do
7851− authorized <- verifyMaintenanceAuth authorization
7852− if authorized
7853− then do
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 {}})
7871−
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
7876− t <- now
7877− globalRateLimited <- checkGlobalRate t
7878− if globalRateLimited then yield (respond {recipients: [], ok: False {}, total: 0})
7879− else do
7880− authorized <- verifyMaintenanceAuth authorization
7881− if authorized
7882− then do
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})
7890−
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
7895− t <- now
7896− globalRateLimited <- checkGlobalRate t
7897− if globalRateLimited then yield (respond {servers: [], ok: False {}, total: 0})
7898− else do
7899− authorized <- verifyMaintenanceAuth authorization
7900− if authorized
7901− then do
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})
7908−
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
7913− else do
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
7921−
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
7925− t <- now
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})
7928− else do
7929− authorized <- verifyMaintenanceAuth authorization
7930− if authorized
7931− then do
7932− scale <- atomic do
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})
7949−
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).
79532080handleReady = \respond -> do
7954− t <- now
7955− -- Rate-limit /ready to prevent DoS (shares health rate limiter since both are
7956− -- unauthenticated probes). Without this, /ready can be hit unlimited times
7957− -- for cheap reconnaissance (detecting restarts) or resource exhaustion.
7958− healthLimited <- checkHealthRate t
7959− if healthLimited then yield (respond {ready: True {}})
7960− else do
7961− sa <- *startedAt
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})
7966−
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
7970− t <- now
7971− healthLimited <- checkHealthRate t
7972− if healthLimited then yield (respond {metrics: "", ok: False {}})
7973− else do
7974− isAuthed <- verifyMaintenanceAuth authorization
7975− result <- atomic do
7976− tmc <- *totalMessageCount
7977− sc <- *totalSessionCount
7978− pc <- *totalPresenceCount
7979− fc <- *totalForwardCount
7980− ap <- *activePolls
7981− arq <- *activeRequests
7982− parq <- *peakActiveRequests
7983− sa <- *startedAt
7984− dp <- *drainPhase
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 {}})
7989− else do
7990− -- Extended metrics for authenticated callers
7991− ext <- atomic do
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 {}})
8015−
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
8022− t <- now
8023− dp <- *drainPhase
8024− if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "draining"})
8025− else do
8026− globalRateLimited <- checkGlobalRate t
8027− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
8028− else
8029− withSessionAuth authorization t clientIp
8030− (yield (respond {ok: False {}, authorized: False {}, ackedCount: 0, error: "unauthorized"}))
8031− (\pubkey -> do
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"})
8040− else do
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
8072− if overCap then do
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: ""}))
8087−
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
8092− t <- now
8093− dp <- *drainPhase
8094− if dp >= 2 then yield (respond {messages: [], authorized: False {}, count: 0, error: ""})
8095− else do
8096− globalRateLimited <- checkGlobalRate t
8097− if globalRateLimited then yield (respond {messages: [], authorized: False {}, count: 0, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
8098− else
8099− withSessionAuth authorization t clientIp
8100− (yield (respond {messages: [], authorized: False {}, count: 0, error: ""}))
8101− (\pubkey -> do
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"})
8109− else do
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: ""}))
8121−
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
8128− t <- now
8129− dp <- *drainPhase
8130− if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: ""})
8131− else do
8132− globalRateLimited <- checkGlobalRate t
8133− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
8134− else
8135− withSessionAuth authorization t clientIp
8136− (yield (respond {ok: False {}, authorized: False {}, deletedCount: 0, error: "unauthorized"}))
8137− (\pubkey -> do
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"})
8146− else do
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: ""}))
8203−
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
8217− t <- now
8218− dp <- *drainPhase
8219− if dp >= 2 then yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: ""})
8220− else do
8221− globalRateLimited <- checkGlobalRate t
8222− if globalRateLimited then yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "rate_limited:" ++ show globalRateWindowMs ++ "ms"})
8223− else
8224− withSessionAuth authorization t clientIp
8225− (yield (respond {ok: False {}, authorized: False {}, cancelled: False {}, error: "unauthorized"}))
8226− (\senderKey -> do
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"})
8235− else do
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)
8240− case toCancel of
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}
8251− else do
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
8291− cancelT <- now
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
8299− Err e -> do
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: ""}))
8306−
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
8311− t <- now
8312− dp <- *drainPhase
8313− if dp >= 2 then yield (respond {results: [], authorized: False {}, retryAfterMs: 0})
8314− else do
8315− globalRateLimited <- checkGlobalRate t
8316− if globalRateLimited then yield (respond {results: [], authorized: False {}, retryAfterMs: 0})
8317− else
8318− withSessionAuth authorization t clientIp
8319− (yield (respond {results: [], authorized: False {}, retryAfterMs: 0}))
8320− (\senderKey -> do
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}))
8346−
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
8362− dp <- *drainPhase
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)
8368−
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])
8385−
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}
8397− else do
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}
8400− else do
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])
2081+ sa <- *startedAt
2082+ lastPrune <- *lastPrunedAt
2083+ yield (respond {ready: lastPrune > 0 && lastPrune >= sa})
84042084
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
8413−
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
8420− case r.status of
8421− MsRateLimited {} -> logEvent "warn" "rate_limited_send" ("messageId=" ++ r.messageId ++ " batch=true")
8422− MsRejected {} -> logWarn ("sendBatch: rejected for " ++ r.messageId ++ " (capacity or mailbox full)")
8423− _ -> yield {}
8424− logBatchResults rest
8425−
8426−-- POST /maintenance/block: Add a server to the federation blocklist.
8427−-- Blocked peers are rejected from all inbound and outbound federation operations.
84282085handleBlockPeer = \server authorization respond -> do
84292086 authorized <- verifyMaintenanceAuth authorization
84302087 if not authorized then yield (respond {ok: False {}, blocked: 0})
84312088 else do
8432− logEvent "audit" "block_peer" server
8433− result <- atomic do
2089+ n <- atomic do
84342090 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)
84362092 else do
8437− -- FIFO eviction: remove the oldest entry (head of list) since union appends
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]
2093+ let updated = union blocked [server]
84432094 set *blockedPeers = updated
8444− yield {alreadyBlocked: False {}, total: count updated}
8445− when (not result.alreadyBlocked) (logInfo ("block: added " ++ server ++ " to blocklist (" ++ show result.total ++ " total)"))
8446− yield (respond {ok: True {}, blocked: result.total})
2095+ yield (count updated)
2096+ yield (respond {ok: True {}, blocked: n})
84472097
8448−-- POST /maintenance/unblock: Remove a server from the federation blocklist.
84492098handleUnblockPeer = \server authorization respond -> do
84502099 authorized <- verifyMaintenanceAuth authorization
84512100 if not authorized then yield (respond {ok: False {}, unblocked: False {}})
84522101 else do
8453− logEvent "audit" "unblock_peer" server
84542102 removed <- atomic do
84552103 blocked <- *blockedPeers
8456− let had = isBlockedPeer server blocked
2104+ let had = any blocked (\b -> b == server)
84572105 set *blockedPeers = do b <- blocked; where b != server; yield b
84582106 yield had
8459− when removed (logInfo ("unblock: removed " ++ server ++ " from blocklist"))
84602107 yield (respond {ok: True {}, unblocked: removed})
84612108
8462−-- GET /maintenance/blocked: List currently blocked federation peers.
84632109handleListBlocked = \authorization respond -> do
84642110 authorized <- verifyMaintenanceAuth authorization
84652111 if not authorized then yield (respond {peers: [], ok: False {}})
@@ -8467,45 +2113,30 @@ handleListBlocked = \authorization respond -> do
84672113 blocked <- *blockedPeers
84682114 yield (respond {peers: blocked, ok: True {}})
84692115
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.
84732116handleAllowPeer = \server authorization respond -> do
84742117 authorized <- verifyMaintenanceAuth authorization
84752118 if not authorized then yield (respond {ok: False {}, allowed: 0})
84762119 else do
8477− logEvent "audit" "allow_peer" server
8478− result <- atomic do
2120+ n <- atomic do
84792121 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)
84812123 else do
8482− let updated = if count allowed >= maxAllowedPeers
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]
2124+ let updated = union allowed [server]
84872125 set *allowedPeers = updated
8488− yield {alreadyAllowed: False {}, total: count updated}
8489− when (not result.alreadyAllowed) (logInfo ("allow: added " ++ server ++ " to allowlist (" ++ show result.total ++ " total)"))
8490− yield (respond {ok: True {}, allowed: result.total})
2126+ yield (count updated)
2127+ yield (respond {ok: True {}, allowed: n})
84912128
8492−-- POST /maintenance/unallow: Remove a server from the federation allowlist.
8493−-- Removing the last server transitions back to open federation mode.
84942129handleUnallowPeer = \server authorization respond -> do
84952130 authorized <- verifyMaintenanceAuth authorization
84962131 if not authorized then yield (respond {ok: False {}, removed: False {}})
84972132 else do
8498− logEvent "audit" "unallow_peer" server
84992133 removed <- atomic do
85002134 allowed <- *allowedPeers
85012135 let had = any allowed (\a -> a == server)
85022136 set *allowedPeers = do a <- allowed; where a != server; yield a
85032137 yield had
8504− when removed (logInfo ("unallow: removed " ++ server ++ " from allowlist"))
85052138 yield (respond {ok: True {}, removed: removed})
85062139
8507−-- GET /maintenance/allowed: List currently allowed federation peers.
8508−-- Empty list = open federation (all peers allowed).
85092140handleListAllowed = \authorization respond -> do
85102141 authorized <- verifyMaintenanceAuth authorization
85112142 if not authorized then yield (respond {peers: [], ok: False {}})
@@ -8513,397 +2144,229 @@ handleListAllowed = \authorization respond -> do
85132144 allowed <- *allowedPeers
85142145 yield (respond {peers: allowed, ok: True {}})
85152146
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.
85212147handlePingPeer = \server authorization respond -> do
85222148 authorized <- verifyMaintenanceAuth authorization
85232149 if not authorized then yield (respond {ok: False {}, latencyMs: 0, error: "unauthorized"})
85242150 else do
85252151 startTime <- now
85262152 auth <- generateFederationAuth "gossip" startTime
8527− pingCorrId <- genTokenN 1
8528− result <- fetchFederation server (RecvGossip {
2153+ result <- fetch (federationUrl server) (RecvGossip {
85292154 authorization: auth,
85302155 events: [], hopsRemaining: 1, fromServer: serverHostN,
8531− requestTimestamp: startTime, correlationId: pingCorrId, protocolVersion: federationProtocolVersion})
2156+ requestTimestamp: startTime, correlationId: "", protocolVersion: federationProtocolVersion})
85322157 endTime <- now
8533− let latency = endTime - startTime
85342158 case result of
8535− Err e -> do
8536− logWarn ("ping: " ++ server ++ " failed: " ++ show e)
8537− yield (respond {ok: False {}, latencyMs: latency, error: show e})
8538− Ok r -> yield (respond {ok: r.ok, latencyMs: latency, error: r.error})
8539−
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.
2159+ Err e -> yield (respond {ok: False {}, latencyMs: endTime - startTime, error: show e})
2160+ Ok r -> yield (respond {ok: r.ok, latencyMs: endTime - startTime, error: r.error})
2161+
85432162handleAdminListSessions = \pubkey authorization respond -> do
85442163 authorized <- verifyMaintenanceAuth authorization
85452164 if not authorized then yield (respond {sessions: [], count: 0, ok: False {}})
85462165 else do
8547− keySessions <- collectSessionsForKey pubkey 0
8548− -- Return only metadata (IP, timestamps) — no token fragments. Even a 4-char prefix
8549− -- (16 bits) narrows brute-force search space and can be correlated with token bucket
8550− -- indices. Sessions are identifiable by (ip, createdAt) pair without token exposure.
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 {}})
8553−
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.
2166+ ses <- *sessions
2167+ let mine = do s <- ses; where s.pubkey == pubkey; yield {token: "***", expiresAt: s.expiresAt, ip: s.ip, createdAt: s.createdAt}
2168+ yield (respond {sessions: mine, count: count mine, ok: True {}})
2169+
85562170handleAdminRevokeSessions = \pubkey authorization respond -> do
85572171 authorized <- verifyMaintenanceAuth authorization
85582172 if not authorized then yield (respond {ok: False {}, revokedCount: 0})
85592173 else do
8560− logEvent "audit" "revoke_all_sessions" pubkey
85612174 t <- now
8562− result <- atomic do
8563− -- Filter each session bucket in-place (avoids readAllSessions + writeAllSessions repartition)
8564− revokedCount <- revokeSessionsForKey pubkey 0
8565− sc <- *totalSessionCount
8566− set *totalSessionCount = max 0 (sc - revokedCount)
8567− -- Clear local presence
8568− let pb = pubkeyBucket pubkey
8569− presenceBkt <- readPresenceBucket pb
8570− let presenceRemoved = count presenceBkt - count (do p <- presenceBkt; where p.pubkey != pubkey || not (isLocalServer p.server); yield p)
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})
8582−
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.
2175+ revoked <- atomic do
2176+ ses <- *sessions
2177+ let mine = do s <- ses; where s.pubkey == pubkey; yield s
2178+ set *sessions = do s <- ses; where s.pubkey != pubkey; yield s
2179+ pres <- *presence
2180+ set *presence = do p <- pres; where p.pubkey != pubkey || not (isLocalServer p.server); yield p
2181+ yield (count mine)
2182+ yield (respond {ok: True {}, revokedCount: revoked})
2183+
85882184handleAdminPurgeMessages = \pubkey authorization respond -> do
85892185 authorized <- verifyMaintenanceAuth authorization
85902186 if not authorized then yield (respond {ok: False {}, purgedCount: 0})
85912187 else do
8592− logEvent "audit" "purge_messages" pubkey
85932188 t <- now
8594− purgeResult <- atomic do
8595− let b = pubkeyBucket pubkey
8596− bucket <- readMessageBucket b
8597− let toDelete = do m <- bucket; where m.toKey == pubkey; yield m
8598− let removed = count toDelete
8599− if removed > 0 then do
8600− writeMessageBucket b (do m <- bucket; where m.toKey != pubkey; yield m)
8601− tc <- *totalMessageCount
8602− set *totalMessageCount = max 0 (tc - removed)
8603− rc <- readRcBucket b
8604− writeRcBucket b (adjustRecipientCount rc pubkey (0 - removed))
8605− -- Cancel pending forwards for purged messages (bucket read: O(n/16))
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})
8636−
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.
2189+ purged <- atomic do
2190+ msgs <- *messages
2191+ let mine = do m <- msgs; where m.toKey == pubkey; yield m
2192+ set *messages = do m <- msgs; where m.toKey != pubkey; yield m
2193+ fwds <- *forwards
2194+ set *forwards = do f <- fwds; where f.toKey != pubkey; yield f
2195+ let federated = do m <- mine; where m.originServer != ""; yield {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
2196+ aids <- *ackedIds
2197+ set *ackedIds = capList (union aids federated) maxAckedIds (\a -> a.ackedAt)
2198+ yield (count mine)
2199+ yield (respond {ok: True {}, purgedCount: purged})
2200+
86422201handleAdminRevokeIp = \ip authorization respond -> do
86432202 authorized <- verifyMaintenanceAuth authorization
86442203 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})
86452205 else do
8646− logEvent "audit" "revoke_ip" ip
8647− if ip == "" then yield (respond {ok: False {}, revokedCount: 0, affectedKeys: 0})
8648− else do
8649− t <- now
8650− result <- revokeSessionsByIp ip 0 t {revokedCount: 0, affectedKeys: [], cleanups: []}
8651− -- Gossip offline for pubkeys that lost their last session
8652− fork (do
8653− offlines <- do c <- result.cleanups; where c.gossipOffline; yield c
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})
8662−
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
8667− else do
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: []}
8673− else do
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
8687−
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])
8696−
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.
2206+ result <- atomic do
2207+ ses <- *sessions
2208+ let mine = do s <- ses; where s.ip == ip; yield s
2209+ set *sessions = do s <- ses; where s.ip != ip; yield s
2210+ let keys = fold (\acc s -> if any acc (\a -> a == s.pubkey) then acc else union acc [s.pubkey]) [] mine
2211+ yield {revoked: count mine, keys: count keys}
2212+ yield (respond {ok: True {}, revokedCount: result.revoked, affectedKeys: result.keys})
2213+
87002214handleAdminListAllSessions = \limit authorization respond -> do
87012215 authorized <- verifyMaintenanceAuth authorization
87022216 if not authorized then yield (respond {sessions: [], ok: False {}, total: 0})
87032217 else do
8704− let effectiveLimit = if limit <= 0 then 100 else clamp 1 500 limit
87052218 t <- now
8706− -- Per-bucket scan: reads one session bucket at a time instead of materializing
8707− -- all 16 into one list (avoids O(n) union across all sessions).
8708− grouped <- groupSessionsByBucket 0 t []
8709− -- Sort by count descending (most sessions first) for abuse investigation
2219+ ses <- *sessions
2220+ let active = do s <- ses; where s.expiresAt > t; yield s
2221+ let grouped = fold (\acc s ->
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
87102225 let sorted = sortBy (\g -> 0 - g.count) grouped
8711− let capped = takeRelation effectiveLimit sorted
8712− yield (respond {sessions: capped, ok: True {}, total: count grouped})
2226+ let effLimit = if limit <= 0 then 100 else clamp 1 500 limit
2227+ yield (respond {sessions: takeRelation effLimit sorted, ok: True {}, total: count grouped})
2228+
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})
2233+
2234+handleSetRateLimits = \globalRequest ipRate sendRate federationRate authGlobal recvRate challengeRate pairRate lookupRate clientWriteRate authorization respond -> do
2235+ authorized <- verifyMaintenanceAuth authorization
2236+ yield (respond {ok: authorized})
87132237
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
8718− else do
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}])
8725− acc active
8726− groupSessionsByBucket (b + 1) t merged
8727−
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.
87322238handleFlushNonces = \authorization respond -> do
87332239 authorized <- verifyMaintenanceAuth authorization
8734− if not authorized then yield (respond {ok: False {}, flushedCount: 0})
8735− else do
8736− logEvent "audit" "flush_nonces" ""
8737− flushedCount <- atomic do
8738− total <- countAllNonces 0
8739− writeAllNonces []
8740− -- Reset all per-bucket eviction cutoffs (no nonces remain, accept all timestamps)
8741− resetAllNonceCutoffs 0
8742− yield total
8743− logInfo ("nonces/flush: flushed " ++ show flushedCount ++ " forward nonces")
8744− yield (respond {ok: True {}, flushedCount: flushedCount})
8745−
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.
2240+ yield (respond {ok: authorized, flushedCount: 0})
2241+
87492242handleRotateSecret = \newSecret authorization respond -> do
87502243 authorized <- verifyMaintenanceAuth authorization
87512244 if not authorized then yield (respond {ok: False {}, error: "unauthorized"})
87522245 else do
8753− logEvent "audit" "rotate_secret" (if newSecret == "" then "disabled" else "new_secret")
8754− if newSecret != "" && federationEnabled && not (tooLong newSecret 15) then do
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: ""})
8762− else do
8763− atomic do set *runtimeMaintenanceSecret = newSecret
8764− if 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: ""})
2246+ atomic do set *runtimeMaintenanceSecret = newSecret
2247+ yield (respond {ok: True {}, error: ""})
87682248
8769−-- GET /maintenance/rate-limits: Return current effective rate limits.
8770−handleGetRateLimits = \authorization respond -> do
2249+handleGetConfig = \authorization respond -> do
87712250 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})
2253+
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)
87732258 else do
8774− result <- atomic do
8775− gr <- effectiveGlobalRequestRate
8776− ir <- effectiveIpRate
8777− sr <- effectiveSendRate
8778− fr <- effectiveFederationRate
8779− ar <- effectiveAuthGlobalRate
8780− rr <- effectiveRecvRate
8781− cr <- effectiveChallengeRate
8782− pr <- effectivePairRate
8783− lr <- effectiveLookupRate
8784− cwr <- effectiveClientWriteRate
8785− yield {globalRequest: gr, ipRate: ir, sendRate: sr, federationRate: fr, authGlobal: ar, recvRate: rr, challengeRate: cr, pairRate: pr, lookupRate: lr, clientWriteRate: cwr}
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})
8787−
8788−-- POST /maintenance/rate-limits: Update rate limits at runtime. 0 = reset to compile-time default.
8789−-- Negative values are clamped to 0. Changes take effect on the next rate check cycle.
8790−handleSetRateLimits = \globalRequest ipRate sendRate federationRate authGlobal recvRate challengeRate pairRate lookupRate clientWriteRate authorization respond -> do
2259+ t <- now
2260+ sa <- *startedAt
2261+ sessions <- *sessions
2262+ msgs <- *messages
2263+ pres <- *presence
2264+ fwds <- *forwards
2265+ aids <- *ackedIds
2266+ dids <- *deliveredIds
2267+ aps <- *activePolls
2268+ chs <- *challenges
2269+ bp <- *blockedPeers
2270+ pc <- *pruneCount
2271+ hc <- *heartbeatCount
2272+ lp <- *lastPrunedAt
2273+ lh <- *lastHeartbeatAt
2274+ dp <- *drainPhase
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})
2285+
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}}
2287+
2288+handleStatsPeers = \authorization respond -> do
87912289 authorized <- verifyMaintenanceAuth authorization
8792− if not authorized then yield (respond {ok: False {}})
2290+ if not authorized then yield (respond {peers: [], ok: False {}})
87932291 else do
8794− logEvent "audit" "set_rate_limits" ("global=" ++ show globalRequest ++ " ip=" ++ show ipRate ++ " send=" ++ show sendRate)
8795− atomic do
8796− set *rateOverrideGlobalRequest = max 0 globalRequest
8797− set *rateOverrideIpRate = max 0 ipRate
8798− set *rateOverrideSendRate = max 0 sendRate
8799− set *rateOverrideFederationRate = max 0 federationRate
8800− set *rateOverrideAuthGlobal = max 0 authGlobal
8801− set *rateOverrideRecvRate = max 0 recvRate
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 {}})
2292+ t <- now
2293+ failures <- *forwardFailures
2294+ fwds <- *forwards
2295+ let peers = do
2296+ f <- failures
2297+ let pending = count (do x <- fwds; where x.toServer == f.server; yield x)
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}
2299+ yield (respond {peers: peers, ok: True {}})
88082300
8809−-- GET /maintenance/config: Return current effective operational parameters.
8810−handleGetConfig = \authorization respond -> do
2301+handleStatsKey = \pubkey authorization respond -> do
88112302 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 {}})
88132304 else do
8814− result <- atomic do
8815− mpr <- effectiveMaxMessagesPerRecipient
8816− mgh <- effectiveMaxGossipHops
8817− ptm <- effectivePollTimeoutMs
8818− agp <- effectiveAckGracePeriod
8819− yield {maxMessagesPerRecipient: mpr, maxGossipHops: mgh, pollTimeoutMs: ptm, ackGracePeriod: agp}
8820− yield (respond {ok: True {}, maxMessagesPerRecipient: result.maxMessagesPerRecipient, maxGossipHops: result.maxGossipHops, pollTimeoutMs: result.pollTimeoutMs, ackGracePeriod: result.ackGracePeriod})
8821−
8822−-- Extract request path for access logging (excludes poll to reduce log volume)
8823−requestPath = \req -> case req of
8824− ReqChallenge {} -> "POST /auth/challenge"
8825− VerifyAuth {} -> "POST /auth/verify"
8826− RevokeSession {} -> "POST /auth/revoke"
8827− Logout {} -> "POST /auth/logout"
8828− Poll {} -> "" -- suppress: high volume, logged on slow path only
8829− SendMessage {} -> "POST /messages"
8830− MessageStatus {} -> "POST /messages/status"
8831− AckMessages {} -> "POST /messages/ack"
8832− SendBatch {} -> "POST /messages/batch"
8833− ListMessages {} -> "POST /messages/list"
8834− DeleteMessages {} -> "POST /messages/delete"
8835− CancelMessage {} -> "POST /messages/cancel"
8836− CancelBatch {} -> "POST /messages/cancel-batch"
8837− LookupPresence {} -> "GET /lookup"
8838− BatchLookupPresence {} -> "POST /lookup/batch"
8839− RecvGossip {} -> "POST /federation/gossip"
8840− ForwardMessage {} -> "POST /federation/forward"
8841− FederationAck {} -> "POST /federation/ack"
8842− FederationCancel {} -> "POST /federation/cancel"
8843− FederationBatchCancel {} -> "POST /federation/cancel-batch"
8844− FederationBatchForward {} -> "POST /federation/forward-batch"
8845− FederationDeliveryReceipt {} -> "POST /federation/delivery-receipt"
8846− VerifyToken {} -> "POST /federation/verify"
8847− FederationPubkey {} -> "GET /federation/pubkey"
8848− Prune {} -> "POST /maintenance/prune"
8849− Drain {} -> "POST /maintenance/drain"
8850− Shutdown {} -> "POST /maintenance/shutdown"
8851− Undrain {} -> "POST /maintenance/undrain"
8852− BlockPeer {} -> "POST /maintenance/block"
8853− UnblockPeer {} -> "POST /maintenance/unblock"
8854− ListBlocked {} -> "GET /maintenance/blocked"
8855− PingPeer {} -> "POST /maintenance/ping"
8856− AdminListSessions {} -> "GET /maintenance/sessions"
8857− AdminRevokeSessions {} -> "POST /maintenance/sessions/revoke-all"
8858− AdminListAllSessions {} -> "POST /maintenance/sessions/list"
8859− AdminPurgeMessages {} -> "POST /maintenance/messages/purge"
8860− AdminRevokeIp {} -> "POST /maintenance/sessions/revoke-ip"
8861− GetRateLimits {} -> "GET /maintenance/rate-limits"
8862− SetRateLimits {} -> "POST /maintenance/rate-limits"
8863− FlushNonces {} -> "POST /maintenance/nonces/flush"
8864− AllowPeer {} -> "POST /maintenance/allow"
8865− UnallowPeer {} -> "POST /maintenance/unallow"
8866− ListAllowed {} -> "GET /maintenance/allowed"
8867− Reconcile {} -> "POST /maintenance/reconcile"
8868− RotateSecret {} -> "POST /maintenance/rotate-secret"
8869− GetConfig {} -> "GET /maintenance/config"
8870− Health {} -> "GET /health"
8871− Stats {} -> "GET /stats"
8872− StatsPeers {} -> "GET /stats/peers"
8873− StatsKey {} -> "GET /stats/key"
8874− TopRecipients {} -> "POST /stats/top-recipients"
8875− StatsForwards {} -> "GET /stats/forwards"
8876− StatsRates {} -> "GET /stats/rates"
8877− Metrics {} -> "GET /metrics"
8878− Ready {} -> "GET /ready"
8879−
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
8900− _ -> ""
8901−
8902−-- Slow request threshold for access logging (ms)
8903−slowRequestThreshold : Int<Ms>
8904−slowRequestThreshold = 1000
8905−
8906−serveInner = \req -> case req of
2305+ t <- now
2306+ msgs <- *messages
2307+ pres <- *presence
2308+ ses <- *sessions
2309+ fwds <- *forwards
2310+ aps <- *activePolls
2311+ let m = count (do x <- msgs; where x.toKey == pubkey; yield x)
2312+ let p = do x <- pres; where x.pubkey == pubkey && x.expiresAt > t; yield {server: x.server, expiresAt: x.expiresAt}
2313+ let s = count (do x <- ses; where x.pubkey == pubkey; yield x)
2314+ let myFwds = do x <- fwds; where x.toKey == pubkey; yield x
2315+ let f = count myFwds
2316+ let fd = do x <- myFwds; yield {server: x.toServer, retries: x.retries, createdAt: x.createdAt}
2317+ let a = count (do x <- aps; where x.pubkey == pubkey; yield x)
2318+ yield (respond {messages: m, presence: p, sessions: s, forwards: f, forwardDetails: fd, activePolls: a, ok: True {}})
2319+
2320+handleTopRecipients = \limit authorization respond -> do
2321+ authorized <- verifyMaintenanceAuth authorization
2322+ if not authorized then yield (respond {recipients: [], ok: False {}, total: 0})
2323+ else do
2324+ msgs <- *messages
2325+ let counts = fold (\acc m ->
2326+ if any acc (\a -> a.pubkey == m.toKey)
2327+ then do a <- acc; yield (if a.pubkey == m.toKey then {pubkey: a.pubkey, count: a.count + 1} else a)
2328+ else union acc [{pubkey: m.toKey, count: 1}]) [] msgs
2329+ let sorted = sortBy (\c -> 0 - c.count) counts
2330+ let effLimit = if limit <= 0 then 20 else clamp 1 100 limit
2331+ yield (respond {recipients: takeRelation effLimit sorted, ok: True {}, total: count counts})
2332+
2333+handleStatsForwards = \authorization respond -> do
2334+ authorized <- verifyMaintenanceAuth authorization
2335+ if not authorized then yield (respond {servers: [], ok: False {}, total: 0})
2336+ else do
2337+ t <- now
2338+ fwds <- *forwards
2339+ let servers = collectPeers fwds (\f -> f.toServer)
2340+ let result = do
2341+ s <- servers
2342+ let svFwds = do f <- fwds; where f.toServer == s; yield f
2343+ let oldest = case minBy svFwds (\f -> f.createdAt) of Nothing {} -> 0; Just {value: x} -> t - x.createdAt
2344+ let retries = fold (\acc f -> acc + f.retries) 0 svFwds
2345+ yield {server: s, count: count svFwds, oldestAge: oldest, totalRetries: retries}
2346+ yield (respond {servers: result, ok: True {}, total: count fwds})
2347+
2348+handleStatsRates = \authorization respond -> do
2349+ authorized <- verifyMaintenanceAuth authorization
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})
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})
2352+
2353+handleMetrics = \authorization respond -> do
2354+ t <- now
2355+ msgs <- *messages
2356+ ses <- *sessions
2357+ pres <- *presence
2358+ fwds <- *forwards
2359+ aps <- *activePolls
2360+ sa <- *startedAt
2361+ dp <- *drainPhase
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"
2363+ yield (respond {metrics: metrics, ok: True {}})
2364+
2365+-- ============================================
2366+-- Dispatch
2367+-- ============================================
2368+
2369+serve = \req -> case req of
89072370 ReqChallenge {pubkey, clientIp, respond} -> handleChallenge pubkey clientIp respond
89082371 VerifyAuth {pubkey, challenge, signature, revokeOthers, clientIp, respond} -> handleVerifyAuth pubkey challenge signature revokeOthers clientIp respond
89092372 RevokeSession {targetToken, authorization, clientIp, respond} -> handleRevoke targetToken authorization clientIp respond
@@ -8919,20 +2382,13 @@ serveInner = \req -> case req of
89192382 CancelBatch {cancels, authorization, clientIp, respond} -> handleCancelBatch cancels authorization clientIp respond
89202383 LookupPresence {pubkey, authorization, clientIp, respond} -> handleLookupPresence pubkey authorization clientIp respond
89212384 BatchLookupPresence {pubkeys, authorization, clientIp, respond} -> handleBatchLookupPresence pubkeys authorization clientIp respond
8922− RecvGossip {events, hopsRemaining, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
8923− warnOldProtocol fromServer protocolVersion; handleRecvGossip events hopsRemaining fromServer requestTimestamp correlationId authorization respond
8924− ForwardMessage {toKey, encryptedBlob, timestamp, originServer, messageId, fromServer, requestTimestamp, correlationId, expiresAt, priority, protocolVersion, authorization, respond} -> do
8925− warnOldProtocol fromServer protocolVersion; handleForwardMessage toKey encryptedBlob timestamp originServer messageId fromServer requestTimestamp correlationId expiresAt priority authorization respond
8926− FederationAck {messageIds, originServer, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
8927− warnOldProtocol fromServer protocolVersion; handleFederationAck messageIds originServer fromServer requestTimestamp correlationId authorization respond
8928− FederationCancel {messageId, toKey, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> do
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
2385+ RecvGossip {events, hopsRemaining, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> 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
2387+ FederationAck {messageIds, originServer, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationAck messageIds originServer fromServer requestTimestamp correlationId authorization respond
2388+ FederationCancel {messageId, toKey, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationCancel messageId toKey fromServer requestTimestamp correlationId authorization respond
2389+ FederationBatchCancel {cancels, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationBatchCancel cancels fromServer requestTimestamp correlationId authorization respond
2390+ FederationBatchForward {forwards, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationBatchForward forwards fromServer requestTimestamp correlationId authorization respond
2391+ FederationDeliveryReceipt {messageIds, toKeys, fromServer, requestTimestamp, correlationId, protocolVersion, authorization, respond} -> handleFederationDeliveryReceipt messageIds toKeys fromServer requestTimestamp correlationId authorization respond
89362392 VerifyToken {token, scope, clientIp, respond} -> handleVerifyToken token scope clientIp respond
89372393 FederationPubkey {respond} -> handleFederationPubkey respond
89382394 Prune {authorization, respond} -> handlePrune authorization respond
@@ -8967,557 +2423,46 @@ serveInner = \req -> case req of
89672423 Metrics {authorization, respond} -> handleMetrics authorization respond
89682424 Ready {respond} -> handleReady respond
89692425
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 {}
8986− _ -> False {}
8987−
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
8994− -- Auth routes
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 {}}
8999− -- Client routes
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
9044− _ -> yield {}
9045−
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.
9051−serve = \req -> do
9052− startTime <- now
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 {})
9056− else do
9057− ar <- *activeRequests
9058− yield (ar >= maxActiveRequests)
9059− if overloaded then do
9060− logEvent "warn" "overloaded" (requestPath req)
9061− serveOverloaded req
9062− else do
9063− atomic do
9064− ar <- *activeRequests
9065− let newAr = ar + 1
9066− set *activeRequests = newAr
9067− peak <- *peakActiveRequests
9068− when (newAr > peak) (set *peakActiveRequests = newAr)
9069− serveInner req
9070− endTime <- now
9071− atomic do
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.
9078− case req of
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
9141− _ -> yield {}
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.
9146− if path != ""
9147− then do
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"))
9154−
91552426-- ============================================
9156−-- Entry Point
2427+-- Background loops
91572428-- ============================================
91582429
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.
91692430backgroundPrune = do
9170− jitter <- randomInt 5000
9171− sleep (backgroundPruneInterval + jitter)
2431+ sleep backgroundPruneInterval
91722432 dp <- *drainPhase
9173− -- Check shutdown: if drain completed and shutdown requested, exit the loop
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
2433+ if dp >= 2 then do
91782434 sleep backgroundPruneInterval
91792435 backgroundPrune
9180− else do
9181− t <- now
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).
9188− atomic do
9189− sc <- *seqCounter
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
9211− sa <- *startedAt
9212− lastHb <- *lastHeartbeatAt
9213− when (t - sa > healthHeartbeatMaxAge && t - lastHb > healthHeartbeatMaxAge) (do
9214− logWarn "backgroundPrune: heartbeat appears dead, bumping pollWakeup"
9215− atomic do
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}
9227− else do
9228− set *pruneRunning = t
9229− gen <- *pruneGeneration
9230− let newGen = gen + 1
9231− set *pruneGeneration = newGen
9232− pc <- *pruneCount
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)
9239− if status.canRun
9240− then do
9241− -- Guard against unbounded concurrent prune forks from repeated stuck recovery
9242− forks <- *activePruneForks
9243− if forks >= 2
9244− then logWarn "backgroundPrune: skipping (max concurrent prune forks reached)"
9245− else do
9246− atomic do
9247− af <- *activePruneForks
9248− set *activePruneForks = af + 1
9249− fork (do
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
9255− then do
9256− logWarn "backgroundPrune: stale fork detected (generation changed), skipping"
9257− atomic do
9258− af <- *activePruneForks
9259− set *activePruneForks = max 0 (af - 1)
9260− else do
9261− pruneAndRetry t
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)
9264− endT <- now
9265− atomic do
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)"
9273− backgroundPrune
9274−
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).
9280−pollHeartbeat = do
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
9285− scale <- atomic do
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)
9293− dp <- *drainPhase
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
9298− t <- now
9299− atomic do set *pollWakeup = t
9300− -- Don't exit; sleep and retry so undrain can resume the loop
9301− sleep pollTimeoutMs
9302− pollHeartbeat
93032436 else do
93042437 t <- now
93052438 atomic do
9306− set *pollWakeup = t
9307− set *lastHeartbeatAt = t
9308− hc <- *heartbeatCount
9309− set *heartbeatCount = hc + 1
9310− pollHeartbeat
9311−
9312−-- Background watchdog: monitors prune and heartbeat loops, restarts if they appear dead.
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)
9317− t <- now
9318− atomic do set *lastWatchdogAt = t
9319− sa <- *startedAt
9320− let warmup = t - sa < backgroundPruneInterval * 10
9321− if warmup then backgroundWatchdog
9322− else do
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")
9340− atomic do
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)
9349− backgroundWatchdog
9350−
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)
2439+ pc <- *pruneCount
2440+ set *pruneCount = pc + 1
2441+ pruneAndRetry t
2442+ backgroundPrune
2443+
2444+pollHeartbeat = do
2445+ sleep pollTimeoutMs
93582446 t <- now
9359− sa <- *startedAt
9360− let warmup = t - sa < backgroundPruneInterval * 60
9361− if warmup then backgroundMetaWatchdog
9362− else do
9363− lastWd <- *lastWatchdogAt
9364− when (lastWd > 0 && t - lastWd > healthWatchdogMaxAge * 3) (do
9365− logError "meta-watchdog: watchdog loop appears dead, restarting"
9366− fork backgroundWatchdog)
9367− backgroundMetaWatchdog
9368−
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 {}
9380−
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
9387− startTime <- now
9388− -- Phase 1: unauthenticated probe (TCP/TLS/HTTP connectivity)
9389− result <- fetchFederation server (RecvGossip {
9390− authorization: "",
9391− events: [], hopsRemaining: 1, fromServer: serverHostN,
9392− requestTimestamp: startTime, correlationId: "", protocolVersion: federationProtocolVersion})
9393− endTime <- now
9394− let latency = endTime - startTime
9395− case result of
9396− Err e -> logWarn ("startup: peer " ++ server ++ " unreachable (" ++ show e ++ ") — check DNS/firewall/TLS")
9397− Ok r -> do
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.
9403− authStart <- now
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})
9409− authEnd <- now
9410− let authLatency = authEnd - authStart
9411− case authResult of
9412− Err e -> logWarn ("startup: peer " ++ server ++ " verify callback failed (" ++ show e ++ ") — check reverse proxy allows /federation/verify")
9413− Ok ar -> if ar.ok
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)
2447+ atomic do
2448+ set *pollWakeup = t
2449+ set *lastHeartbeatAt = t
2450+ hc <- *heartbeatCount
2451+ set *heartbeatCount = hc + 1
2452+ pollHeartbeat
2453+
2454+-- ============================================
2455+-- Entry Point
2456+-- ============================================
94172457
94182458main = do
9419− let configOk = listenPort > 0 && maxMessages > 0 && maxMessagesPerRecipient > 0 && maxPresenceEntries > 0
9420− && maxSessions > 0 && maxChallenges > 0 && backgroundPruneInterval > 0
9421− && pollTimeoutMs > 0 && challengeExpiry > 0 && sessionExpiry > 0
9422− && maxSessionLifetime > 0
9423− && maxPresenceTtl > 0 && maxForwardsEntries > 0 && maxAckedIds > 0
9424− && maxForwardRetries > 0 && maxGossipHops > 0 && maxPollsPerKey > 0
9425− && gossipOriginHops > 0 && maxThirdPartyGossipHops > 0
9426− && verificationTokenExpiry > 0
9427− && maxAckRetries > 0 && maxPairRatePerPair > 0 && pairRateWindowMs > 0
9428− && maxFederationPairRatePerPair > 0 && federationPairRateWindowMs > 0
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
9460− if not configOk
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"
9464− else do
9465− t <- now
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
9469− atomic do
9470− set *startedAt = t
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."))
9477− if requireClientIp
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
9513− fork pollHeartbeat
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
2459+ t <- now
2460+ genJitter <- randomInt 1000000
2461+ atomic do
2462+ set *startedAt = t
2463+ set *serverGeneration = t * 1000 + genJitter
2464+ logInfo ("Skrepka relay server starting on port " ++ show listenPort ++ "...")
2465+ logInfo (" federation: " ++ if federationEnabled then "enabled" else "disabled")
2466+ fork backgroundPrune
2467+ fork pollHeartbeat
2468+ listen listenPort serve