@@ -184,7 +184,11 @@ sToMs = \s -> stripUnit s * 1000
184184-- and stripped of trailing dots, with a deny-list filter (`isBadServerName`)
185185-- applied where SSRF is a concern.
186186
187−type PollEvent = {id: MessageIdHex, eventType: Text, payload: {encryptedBlob: BlobHex, timestamp: Timestamp, toKey: PubkeyHex, expiresAt: Timestamp}}
187+type PollEvent = {
188+ id: MessageIdHex,
189+ eventType: Text,
190+ payload: {encryptedBlob: BlobHex, timestamp: Timestamp, toKey: PubkeyHex, expiresAt: Timestamp}
191+}
188192
189193data GossipEventType = GossipOnline {} | GossipOffline {} | GossipUnknown {}
190194
@@ -195,15 +199,26 @@ impl ToJSON GossipEventType where
195199 GossipUnknown {} -> "unknown")
196200
197201impl FromJSON GossipEventType where
198− parseJson t =
199− let s : Text = parseJson t in
200− if s == "online" then GossipOnline {}
201− else if s == "offline" then GossipOffline {}
202− else GossipUnknown {}
203−
204−type GossipEvent = {eventType: GossipEventType, pubkey: PubkeyHex, server: ServerName, timestamp: Timestamp, ttl: Int<Ms>, seenBy: [Text]}
205−
206−data MessageStatus = MsDelivered {} | MsFederated {} | MsQueued {} | MsUnauthorized {} | MsRejected {} | MsRateLimited {} | MsDuplicate {} | MsDraining {}
202+ parseJson t = (\s -> if s == "online" then GossipOnline {} else if s == "offline" then GossipOffline {} else GossipUnknown {}) (parseJson t : Text)
203+
204+type GossipEvent = {
205+ eventType: GossipEventType,
206+ pubkey: PubkeyHex,
207+ server: ServerName,
208+ timestamp: Timestamp,
209+ ttl: Int<Ms>,
210+ seenBy: [Text]
211+}
212+
213+data MessageStatus
214+ = MsDelivered {}
215+ | MsFederated {}
216+ | MsQueued {}
217+ | MsUnauthorized {}
218+ | MsRejected {}
219+ | MsRateLimited {}
220+ | MsDuplicate {}
221+ | MsDraining {}
207222
208223impl ToJSON MessageStatus where
209224 toJson ms = toJson (case ms of
@@ -217,7 +232,7 @@ impl ToJSON MessageStatus where
217232 MsDraining {} -> "draining")
218233
219234isValidBoundedHex : Int -> Text -> Bool
220−isValidBoundedHex = \maxLen s -> not (tooLong s maxLen) && isValidHex s
235+isValidBoundedHex = \maxLen s -> not tooLong s maxLen && isValidHex s
221236type PubkeyHex = Text where isValidBoundedHex maxPubkeyLen
222237type BlobHex = Text where isValidBoundedHex maxBlobLen
223238type SignatureHex = Text where isValidBoundedHex maxSignatureLen
@@ -226,31 +241,93 @@ isValidMessageId = isValidBoundedHex maxMessageIdLen
226241type MessageIdHex = Text where isValidMessageId
227242type OptionalMessageId = Text where \s -> s == "" || isValidMessageId s
228243isAnyServerName : Text -> Bool
229−isAnyServerName = \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s
244+isAnyServerName = \s -> not tooLong s maxServerNameLen && s == normalizeServerName s
230245isValidServerName : Text -> Bool
231−isValidServerName = \s -> isAnyServerName s && not (isBadServerName s)
246+isValidServerName = \s -> isAnyServerName s && not isBadServerName s
232247type ServerName = Text where isValidServerName
233248type AnyServerName = Text where isAnyServerName
234249
235250type Timestamp = Int<Ms>
236251
237252type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp, ip: Text}
238−type Session = {token: Text, pubkey: PubkeyHex, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}
239−type Message = {messageId: MessageIdHex, toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: Text, receivedAt: Timestamp, expiresAt: Timestamp, senderKey: Text, priority: Int}
240−type PresenceEntry = {pubkey: PubkeyHex, server: AnyServerName, expiresAt: Timestamp, timestamp: Timestamp}
241−type ForwardEntry = {messageId: MessageIdHex, toServer: ServerName, createdAt: Timestamp, toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: Text, retries: Int, expiresAt: Timestamp, priority: Int, senderKey: Text}
242−type AckedEntry = {messageId: MessageIdHex, toKey: PubkeyHex, ackedAt: Timestamp, originServer: ServerName, retries: Int}
253+type Session = {
254+ token: Text,
255+ pubkey: PubkeyHex,
256+ expiresAt: Timestamp,
257+ ip: Text,
258+ createdAt: Timestamp
259+}
260+type Message = {
261+ messageId: MessageIdHex,
262+ toKey: PubkeyHex,
263+ encryptedBlob: BlobHex,
264+ timestamp: Timestamp,
265+ originServer: Text,
266+ receivedAt: Timestamp,
267+ expiresAt: Timestamp,
268+ senderKey: Text,
269+ priority: Int
270+}
271+type PresenceEntry = {
272+ pubkey: PubkeyHex,
273+ server: AnyServerName,
274+ expiresAt: Timestamp,
275+ timestamp: Timestamp
276+}
277+type ForwardEntry = {
278+ messageId: MessageIdHex,
279+ toServer: ServerName,
280+ createdAt: Timestamp,
281+ toKey: PubkeyHex,
282+ encryptedBlob: BlobHex,
283+ timestamp: Timestamp,
284+ originServer: Text,
285+ retries: Int,
286+ expiresAt: Timestamp,
287+ priority: Int,
288+ senderKey: Text
289+}
290+type AckedEntry = {
291+ messageId: MessageIdHex,
292+ toKey: PubkeyHex,
293+ ackedAt: Timestamp,
294+ originServer: ServerName,
295+ retries: Int
296+}
243297type DeliveredEntry = {messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}
244298type ForwardFailure = {server: Text, failedAt: Timestamp, failures: Int, firstFailedAt: Timestamp}
245299type RateEntry = {key: Text, windowStart: Timestamp, count: Int}
246300type ActivePoll = {pubkey: PubkeyHex, startedAt: Timestamp}
247301
248−type SenderExpiration = {senderKey: Text, messageId: MessageIdHex, toKey: PubkeyHex, expiredAt: Timestamp}
249−type SenderDelivery = {senderKey: Text, messageId: MessageIdHex, toKey: PubkeyHex, deliveredAt: Timestamp}
302+type SenderExpiration = {
303+ senderKey: Text,
304+ messageId: MessageIdHex,
305+ toKey: PubkeyHex,
306+ expiredAt: Timestamp
307+}
308+type SenderDelivery = {
309+ senderKey: Text,
310+ messageId: MessageIdHex,
311+ toKey: PubkeyHex,
312+ deliveredAt: Timestamp
313+}
250314type CancelNotification = {toKey: PubkeyHex, messageId: MessageIdHex, cancelledAt: Timestamp}
251−type PendingFederationCancel = {messageId: MessageIdHex, toKey: PubkeyHex, toServer: ServerName, createdAt: Timestamp, retries: Int}
252−
253−type BatchMessage = {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int}
315+type PendingFederationCancel = {
316+ messageId: MessageIdHex,
317+ toKey: PubkeyHex,
318+ toServer: ServerName,
319+ createdAt: Timestamp,
320+ retries: Int
321+}
322+
323+type BatchMessage = {
324+ to: PubkeyHex,
325+ encryptedBlob: BlobHex,
326+ timestamp: Timestamp,
327+ messageId: OptionalMessageId,
328+ expiresInMs: Int,
329+ priority: Int
330+}
254331type BatchResult = {messageId: OptionalMessageId, status: MessageStatus}
255332
256333type BatchCancelEntry = {messageId: MessageIdHex, to: PubkeyHex}
@@ -329,79 +406,32 @@ type BatchCancelResult = {messageId: MessageIdHex, cancelled: Bool}
329406-- the underlying value is no longer computed (zero-filled).
330407
331408route AuthApi where
332− /auth
333− POST {pubkey: PubkeyHex} /challenge headers {clientIp: Text}
334− -> {challenge: Text, ok: Bool, expiresAt: Timestamp, retryAfterMs: Int, error: Text}
335− = ReqChallenge
336− POST {pubkey: PubkeyHex, challenge: Text, signature: SignatureHex, revokeOthers: Bool} /verify headers {clientIp: Text}
337− -> {token: Text, expiresAt: Timestamp, error: Text}
338− = VerifyAuth
339− POST {targetToken: Text} /revoke headers {authorization: Text, clientIp: Text}
340− -> {ok: Bool, authorized: Bool}
341− = RevokeSession
342− POST {} /logout headers {authorization: Text, clientIp: Text}
343− -> {ok: Bool, authorized: Bool}
344− = Logout
409+ POST {pubkey: PubkeyHex} /auth/challenge headers {clientIp: Text} -> {challenge: Text, ok: Bool, expiresAt: Timestamp, retryAfterMs: Int, error: Text} = ReqChallenge
410+ POST {pubkey: PubkeyHex, challenge: Text, signature: SignatureHex, revokeOthers: Bool} /auth/verify headers {clientIp: Text} -> {token: Text, expiresAt: Timestamp, error: Text} = VerifyAuth
411+ POST {targetToken: Text} /auth/revoke headers {authorization: Text, clientIp: Text} -> {ok: Bool, authorized: Bool} = RevokeSession
412+ POST /auth/logout headers {authorization: Text, clientIp: Text} -> {ok: Bool, authorized: Bool} = Logout
345413
346414route ClientApi where
347− POST {cursor: Timestamp, generation: Int, watchKeys: [PubkeyHex]} /poll headers {authorization: Text, clientIp: Text}
348− -> {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}]}
349− = Poll
350− /messages
351− POST {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int} / headers {authorization: Text, clientIp: Text}
352− -> {status: MessageStatus, messageId: OptionalMessageId, retryAfterMs: Int, error: Text, loadPct: Int}
353− = SendMessage
354− POST {to: PubkeyHex, messageId: MessageIdHex} /status headers {authorization: Text, clientIp: Text}
355− -> {status: Text, authorized: Bool}
356− = MessageStatus
357− POST {messageIds: [MessageIdHex]} /ack headers {authorization: Text, clientIp: Text}
358− -> {ok: Bool, authorized: Bool, ackedCount: Int, error: Text}
359− = AckMessages
360− POST {messages: [BatchMessage]} /batch headers {authorization: Text, clientIp: Text}
361− -> {results: [BatchResult], authorized: Bool, retryAfterMs: Int}
362− = SendBatch
363− POST {offset: Int} /list headers {authorization: Text, clientIp: Text}
364− -> {messages: [{messageId: MessageIdHex, timestamp: Timestamp, receivedAt: Timestamp}], authorized: Bool, count: Int, error: Text}
365− = ListMessages
366− POST {messageIds: [MessageIdHex]} /delete headers {authorization: Text, clientIp: Text}
367− -> {ok: Bool, authorized: Bool, deletedCount: Int, error: Text}
368− = DeleteMessages
369− POST {messageId: MessageIdHex, to: PubkeyHex} /cancel headers {authorization: Text, clientIp: Text}
370− -> {ok: Bool, authorized: Bool, cancelled: Bool, error: Text}
371− = CancelMessage
372− POST {cancels: [BatchCancelEntry]} /cancel-batch headers {authorization: Text, clientIp: Text}
373− -> {results: [BatchCancelResult], authorized: Bool, error: Text}
374− = CancelBatch
375− GET /lookup/{pubkey: PubkeyHex} headers {authorization: Text, clientIp: Text}
376− -> {server: AnyServerName, authorized: Bool, error: Text}
377− = LookupPresence
378− POST {pubkeys: [PubkeyHex]} /lookup/batch headers {authorization: Text, clientIp: Text}
379− -> {results: [{pubkey: PubkeyHex, server: AnyServerName}], authorized: Bool, error: Text}
380− = BatchLookupPresence
415+ POST {cursor: Timestamp, generation: Int, watchKeys: [PubkeyHex]} /poll headers {authorization: Text, clientIp: Text} -> {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}]} = Poll
416+ POST {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, messageId: OptionalMessageId, expiresInMs: Int, priority: Int} /messages headers {authorization: Text, clientIp: Text} -> {status: MessageStatus, messageId: OptionalMessageId, retryAfterMs: Int, error: Text, loadPct: Int} = SendMessage
417+ POST {to: PubkeyHex, messageId: MessageIdHex} /messages/status headers {authorization: Text, clientIp: Text} -> {status: Text, authorized: Bool} = MessageStatus
418+ POST {messageIds: [MessageIdHex]} /messages/ack headers {authorization: Text, clientIp: Text} -> {ok: Bool, authorized: Bool, ackedCount: Int, error: Text} = AckMessages
419+ POST {messages: [BatchMessage]} /messages/batch headers {authorization: Text, clientIp: Text} -> {results: [BatchResult], authorized: Bool, retryAfterMs: Int} = SendBatch
420+ POST {offset: Int} /messages/list headers {authorization: Text, clientIp: Text} -> {messages: [{messageId: MessageIdHex, timestamp: Timestamp, receivedAt: Timestamp}], authorized: Bool, count: Int, error: Text} = ListMessages
421+ POST {messageIds: [MessageIdHex]} /messages/delete headers {authorization: Text, clientIp: Text} -> {ok: Bool, authorized: Bool, deletedCount: Int, error: Text} = DeleteMessages
422+ POST {messageId: MessageIdHex, to: PubkeyHex} /messages/cancel headers {authorization: Text, clientIp: Text} -> {ok: Bool, authorized: Bool, cancelled: Bool, error: Text} = CancelMessage
423+ POST {cancels: [BatchCancelEntry]} /messages/cancel-batch headers {authorization: Text, clientIp: Text} -> {results: [BatchCancelResult], authorized: Bool, error: Text} = CancelBatch
424+ GET /lookup/{pubkey: PubkeyHex} headers {authorization: Text, clientIp: Text} -> {server: AnyServerName, authorized: Bool, error: Text} = LookupPresence
425+ POST {pubkeys: [PubkeyHex]} /lookup/batch headers {authorization: Text, clientIp: Text} -> {results: [{pubkey: PubkeyHex, server: AnyServerName}], authorized: Bool, error: Text} = BatchLookupPresence
381426
382427route FederationApi where
383− /federation
384− POST {events: [GossipEvent], hopsRemaining: Int, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /gossip headers {authorization: Text}
385− -> {ok: Bool, error: Text, retryAfterMs: Int}
386− = RecvGossip
387− 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}
388− -> {ok: Bool, error: Text, retryAfterMs: Int}
389− = ForwardMessage
390− POST {messageIds: [MessageIdHex], originServer: ServerName, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /ack headers {authorization: Text}
391− -> {ok: Bool, error: Text, ackedCount: Int, results: [{messageId: MessageIdHex, found: Bool}], retryAfterMs: Int}
392− = FederationAck
393− POST {messageId: MessageIdHex, toKey: PubkeyHex, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /cancel headers {authorization: Text}
394− -> {ok: Bool, error: Text, cancelled: Bool, retryAfterMs: Int}
395− = FederationCancel
396− POST {cancels: [{messageId: MessageIdHex, toKey: PubkeyHex}], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /cancel-batch headers {authorization: Text}
397− -> {ok: Bool, error: Text, results: [BatchCancelResult], retryAfterMs: Int}
398− = FederationBatchCancel
399− 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}
400− -> {ok: Bool, error: Text, results: [{messageId: MessageIdHex, ok: Bool}], retryAfterMs: Int}
401− = FederationBatchForward
402− POST {messageIds: [MessageIdHex], toKeys: [PubkeyHex], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /delivery-receipt headers {authorization: Text}
403− -> {ok: Bool, error: Text, receivedCount: Int, retryAfterMs: Int}
404− = FederationDeliveryReceipt
428+ POST {events: [GossipEvent], hopsRemaining: Int, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /federation/gossip headers {authorization: Text} -> {ok: Bool, error: Text, retryAfterMs: Int} = RecvGossip
429+ POST {toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: ServerName, messageId: MessageIdHex, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, expiresAt: Timestamp, priority: Int, protocolVersion: Int} /federation/forward headers {authorization: Text} -> {ok: Bool, error: Text, retryAfterMs: Int} = ForwardMessage
430+ POST {messageIds: [MessageIdHex], originServer: ServerName, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /federation/ack headers {authorization: Text} -> {ok: Bool, error: Text, ackedCount: Int, results: [{messageId: MessageIdHex, found: Bool}], retryAfterMs: Int} = FederationAck
431+ POST {messageId: MessageIdHex, toKey: PubkeyHex, fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /federation/cancel headers {authorization: Text} -> {ok: Bool, error: Text, cancelled: Bool, retryAfterMs: Int} = FederationCancel
432+ POST {cancels: [{messageId: MessageIdHex, toKey: PubkeyHex}], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /federation/cancel-batch headers {authorization: Text} -> {ok: Bool, error: Text, results: [BatchCancelResult], retryAfterMs: Int} = FederationBatchCancel
433+ POST {forwards: [{toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: ServerName, messageId: MessageIdHex, expiresAt: Timestamp, priority: Int}], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /federation/forward-batch headers {authorization: Text} -> {ok: Bool, error: Text, results: [{messageId: MessageIdHex, ok: Bool}], retryAfterMs: Int} = FederationBatchForward
434+ POST {messageIds: [MessageIdHex], toKeys: [PubkeyHex], fromServer: ServerName, requestTimestamp: Timestamp, correlationId: Text, protocolVersion: Int} /federation/delivery-receipt headers {authorization: Text} -> {ok: Bool, error: Text, receivedCount: Int, retryAfterMs: Int} = FederationDeliveryReceipt
405435
406436route FederationVerifyApi where
407437 POST {token: Text, scope: Text} /federation/verify headers {clientIp: Text} -> {ok: Bool} = VerifyToken
@@ -410,99 +440,55 @@ route FederationPubkeyApi where
410440 GET /federation/pubkey -> {pubkey: Text, ok: Bool} = FederationPubkey
411441
412442route MaintenanceApi where
413− POST {} /maintenance/prune headers {authorization: Text}
414− -> {ok: Bool}
415− = Prune
416− POST {phase: Int} /maintenance/drain headers {authorization: Text}
417− -> {ok: Bool, drained: Int, phase: Int}
418− = Drain
419− POST {} /maintenance/undrain headers {authorization: Text}
420− -> {ok: Bool}
421− = Undrain
422− POST {} /maintenance/shutdown headers {authorization: Text}
423− -> {ok: Bool, drained: Int}
424− = Shutdown
425− POST {server: ServerName} /maintenance/block headers {authorization: Text}
426− -> {ok: Bool, blocked: Int}
427− = BlockPeer
428− POST {server: ServerName} /maintenance/unblock headers {authorization: Text}
429− -> {ok: Bool, unblocked: Bool}
430− = UnblockPeer
431− GET /maintenance/blocked headers {authorization: Text}
432− -> {peers: [Text], ok: Bool}
433− = ListBlocked
434− POST {server: ServerName} /maintenance/ping headers {authorization: Text}
435− -> {ok: Bool, latencyMs: Int, error: Text}
436− = PingPeer
437− GET /maintenance/sessions/{pubkey: PubkeyHex} headers {authorization: Text}
438− -> {sessions: [{token: Text, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}], count: Int, ok: Bool}
439− = AdminListSessions
440− POST {pubkey: PubkeyHex} /maintenance/sessions/revoke-all headers {authorization: Text}
441− -> {ok: Bool, revokedCount: Int}
442− = AdminRevokeSessions
443− POST {pubkey: PubkeyHex} /maintenance/messages/purge headers {authorization: Text}
444− -> {ok: Bool, purgedCount: Int}
445− = AdminPurgeMessages
446− POST {ip: Text} /maintenance/sessions/revoke-ip headers {authorization: Text}
447− -> {ok: Bool, revokedCount: Int, affectedKeys: Int}
448− = AdminRevokeIp
449− POST {limit: Int} /maintenance/sessions/list headers {authorization: Text}
450− -> {sessions: [{pubkey: PubkeyHex, count: Int, ips: [Text], latestExpiry: Timestamp}], ok: Bool, total: Int}
451− = AdminListAllSessions
452− GET /maintenance/rate-limits headers {authorization: Text}
453− -> {ok: Bool, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int}
454− = GetRateLimits
455− 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}
456− -> {ok: Bool}
457− = SetRateLimits
458− POST {} /maintenance/nonces/flush headers {authorization: Text}
459− -> {ok: Bool, flushedCount: Int}
460− = FlushNonces
461− POST {server: ServerName} /maintenance/allow headers {authorization: Text}
462− -> {ok: Bool, allowed: Int}
463− = AllowPeer
464− POST {server: ServerName} /maintenance/unallow headers {authorization: Text}
465− -> {ok: Bool, removed: Bool}
466− = UnallowPeer
467− GET /maintenance/allowed headers {authorization: Text}
468− -> {peers: [Text], ok: Bool}
469− = ListAllowed
470− POST {} /maintenance/reconcile headers {authorization: Text}
471− -> {ok: Bool, messageDrift: Int, presenceDrift: Int, sessionDrift: Int}
472− = Reconcile
473− POST {newSecret: Text} /maintenance/rotate-secret headers {authorization: Text}
474− -> {ok: Bool, error: Text}
475− = RotateSecret
476− GET /maintenance/config headers {authorization: Text}
477− -> {ok: Bool, maxMessagesPerRecipient: Int, maxGossipHops: Int, pollTimeoutMs: Int, ackGracePeriod: Int}
478− = GetConfig
443+ POST /maintenance/prune headers {authorization: Text} -> {ok: Bool} = Prune
444+ POST {phase: Int} /maintenance/drain headers {authorization: Text} -> {ok: Bool, drained: Int, phase: Int} = Drain
445+ POST /maintenance/undrain headers {authorization: Text} -> {ok: Bool} = Undrain
446+ POST /maintenance/shutdown headers {authorization: Text} -> {ok: Bool, drained: Int} = Shutdown
447+ POST {server: ServerName} /maintenance/block headers {authorization: Text} -> {ok: Bool, blocked: Int} = BlockPeer
448+ POST {server: ServerName} /maintenance/unblock headers {authorization: Text} -> {ok: Bool, unblocked: Bool} = UnblockPeer
449+ GET /maintenance/blocked headers {authorization: Text} -> {peers: [Text], ok: Bool} = ListBlocked
450+ POST {server: ServerName} /maintenance/ping headers {authorization: Text} -> {ok: Bool, latencyMs: Int, error: Text} = PingPeer
451+ GET /maintenance/sessions/{pubkey: PubkeyHex} headers {authorization: Text} -> {sessions: [{token: Text, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}], count: Int, ok: Bool} = AdminListSessions
452+ POST {pubkey: PubkeyHex} /maintenance/sessions/revoke-all headers {authorization: Text} -> {ok: Bool, revokedCount: Int} = AdminRevokeSessions
453+ POST {pubkey: PubkeyHex} /maintenance/messages/purge headers {authorization: Text} -> {ok: Bool, purgedCount: Int} = AdminPurgeMessages
454+ POST {ip: Text} /maintenance/sessions/revoke-ip headers {authorization: Text} -> {ok: Bool, revokedCount: Int, affectedKeys: Int} = AdminRevokeIp
455+ POST {limit: Int} /maintenance/sessions/list headers {authorization: Text} -> {sessions: [{pubkey: PubkeyHex, count: Int, ips: [Text], latestExpiry: Timestamp}], ok: Bool, total: Int} = AdminListAllSessions
456+ GET /maintenance/rate-limits headers {authorization: Text} -> {ok: Bool, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int} = GetRateLimits
457+ 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} -> {ok: Bool} = SetRateLimits
458+ POST /maintenance/nonces/flush headers {authorization: Text} -> {ok: Bool, flushedCount: Int} = FlushNonces
459+ POST {server: ServerName} /maintenance/allow headers {authorization: Text} -> {ok: Bool, allowed: Int} = AllowPeer
460+ POST {server: ServerName} /maintenance/unallow headers {authorization: Text} -> {ok: Bool, removed: Bool} = UnallowPeer
461+ GET /maintenance/allowed headers {authorization: Text} -> {peers: [Text], ok: Bool} = ListAllowed
462+ POST /maintenance/reconcile headers {authorization: Text} -> {ok: Bool, messageDrift: Int, presenceDrift: Int, sessionDrift: Int} = Reconcile
463+ POST {newSecret: Text} /maintenance/rotate-secret headers {authorization: Text} -> {ok: Bool, error: Text} = RotateSecret
464+ GET /maintenance/config headers {authorization: Text} -> {ok: Bool, maxMessagesPerRecipient: Int, maxGossipHops: Int, pollTimeoutMs: Int, ackGracePeriod: Int} = GetConfig
479465
480466route HealthApi where
481467 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
482468
483−type PeerStatus = {server: Text, failures: Int, lastFailedAt: Timestamp, firstFailedAt: Timestamp, backoffMs: Int, retriable: Bool, pendingForwards: Int, avgLatencyMs: Int, maxLatencyMs: Int, latencySamples: Int, gossipEventsPerMin: Int}
469+type PeerStatus = {
470+ server: Text,
471+ failures: Int,
472+ lastFailedAt: Timestamp,
473+ firstFailedAt: Timestamp,
474+ backoffMs: Int,
475+ retriable: Bool,
476+ pendingForwards: Int,
477+ avgLatencyMs: Int,
478+ maxLatencyMs: Int,
479+ latencySamples: Int,
480+ gossipEventsPerMin: Int
481+}
484482type KeyPresenceEntry = {server: Text, expiresAt: Timestamp}
485483type RecipientCount = {pubkey: PubkeyHex, count: Int}
486484
487485route StatsApi where
488− GET /stats headers {authorization: Text}
489− -> {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}}
490− = Stats
491− GET /stats/peers headers {authorization: Text}
492− -> {peers: [PeerStatus], ok: Bool}
493− = StatsPeers
494− GET /stats/key/{pubkey: PubkeyHex} headers {authorization: Text}
495− -> {messages: Int, presence: [KeyPresenceEntry], sessions: Int, forwards: Int, forwardDetails: [{server: Text, retries: Int, createdAt: Timestamp}], activePolls: Int, ok: Bool}
496− = StatsKey
497− POST {limit: Int} /stats/top-recipients headers {authorization: Text}
498− -> {recipients: [RecipientCount], ok: Bool, total: Int}
499− = TopRecipients
500− GET /stats/forwards headers {authorization: Text}
501− -> {servers: [{server: Text, count: Int, oldestAge: Int, totalRetries: Int}], ok: Bool, total: Int}
502− = StatsForwards
503− GET /stats/rates headers {authorization: Text}
504− -> {ok: Bool, scalePct: Int, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int}
505− = StatsRates
486+ GET /stats headers {authorization: Text} -> {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}} = Stats
487+ GET /stats/peers headers {authorization: Text} -> {peers: [PeerStatus], ok: Bool} = StatsPeers
488+ GET /stats/key/{pubkey: PubkeyHex} headers {authorization: Text} -> {messages: Int, presence: [KeyPresenceEntry], sessions: Int, forwards: Int, forwardDetails: [{server: Text, retries: Int, createdAt: Timestamp}], activePolls: Int, ok: Bool} = StatsKey
489+ POST {limit: Int} /stats/top-recipients headers {authorization: Text} -> {recipients: [RecipientCount], ok: Bool, total: Int} = TopRecipients
490+ GET /stats/forwards headers {authorization: Text} -> {servers: [{server: Text, count: Int, oldestAge: Int, totalRetries: Int}], ok: Bool, total: Int} = StatsForwards
491+ GET /stats/rates headers {authorization: Text} -> {ok: Bool, scalePct: Int, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int} = StatsRates
506492
507493route MetricsApi where
508494 GET /metrics headers {authorization: Text} -> {metrics: Text, ok: Bool} = Metrics
@@ -520,22 +506,27 @@ route Api = AuthApi | ClientApi | FederationApi | FederationVerifyApi | Federati
520506-- Everything is intentionally O(n) over flat lists; performance is sacrificed
521507-- for clarity per the file header.
522508
523−filter : (a b) -> (b -> Bool) -> (a b)
524−filter = \xs pred -> do x <- xs; where pred x; yield x
525−removeWhere : (a b) -> (b -> Bool) -> (a b)
526−removeWhere = \xs pred -> filter xs (\x -> not (pred x))
527−pluck : (a b) -> (b -> c) -> (a c)
528−pluck = \xs f -> do x <- xs; yield (f x)
529−mapWhere : (a b) -> (b -> Bool) -> (b -> c) -> (a c)
509+filter : a b -> (b -> Bool) -> a b
510+filter = \xs pred -> do
511+ x <- xs
512+ where pred x
513+ yield x
514+removeWhere : a b -> (b -> Bool) -> a b
515+removeWhere = \xs pred -> filter xs (\x -> not pred x)
516+pluck : a b -> (b -> c) -> a c
517+pluck = \xs f -> do
518+ x <- xs
519+ yield (f x)
520+mapWhere : a b -> (b -> Bool) -> (b -> c) -> a c
530521mapWhere = \xs pred -> pluck (filter xs pred)
531−countWhere : (a b) -> (b -> Bool) -> Int
522+countWhere : a b -> (b -> Bool) -> Int
532523countWhere = \xs pred -> count (filter xs pred)
533524any : [a] -> (a -> Bool) -> Bool
534525any = \xs pred -> countWhere xs pred > 0
535526none : [a] -> (a -> Bool) -> Bool
536−none = \xs pred -> not (any xs pred)
527+none = \xs pred -> not any xs pred
537528all : [a] -> (a -> Bool) -> Bool
538−all = \xs pred -> none xs (\x -> not (pred x))
529+all = \xs pred -> none xs (\x -> not pred x)
539530elem : [a] -> a -> Bool
540531elem = \xs x -> any xs (\y -> y == x)
541532findFirst : [a] -> (a -> Bool) -> Maybe a
@@ -560,7 +551,7 @@ withIndex : [a] -> [{i: Int, v: a}]
560551withIndex = fold (\acc x -> union acc [{i: count acc, v: x}]) []
561552
562553headOf : [a] -> Maybe a
563−headOf = \items -> fold (\_ x -> Just {value: x}) Nothing {} (takeRelation 1 items)
554+headOf = \items -> fold (\_ x -> Just {value: x}) (Nothing {}) (takeRelation 1 items)
564555
565556-- Cap to maxN by dropping the smallest-key entries (LRU-style). Always sorts.
566557capList : [a] -> Int -> (a -> b) -> [a]
@@ -571,27 +562,44 @@ pct : Int -> Int -> Int
571562pct = \cur maxN -> if maxN > 0 then cur * 100 / maxN else 0
572563
573564-- Common ack/delete tail: pull matching messages, drop them and their forwards.
574−removeForKey : (forall a. {toKey: PubkeyHex, messageId: MessageIdHex | a} -> Bool) -> IO {} [Message]
565+removeForKey : (forall a. {toKey: PubkeyHex, messageId: MessageIdHex | a} -> Bool) -> IO {reads *forwards, reads *messages, writes *forwards, writes *messages} [Message]
575566removeForKey = \pred -> do
576567 msgs <- *messages
577568 fwds <- *forwards
578− set *messages = removeWhere msgs pred
579− set *forwards = removeWhere fwds pred
569+ *messages = removeWhere msgs pred
570+ *forwards = removeWhere fwds pred
580571 yield (filter msgs pred)
581572
582573-- Cap pred-matching entries to maxN-1 (caller adds one more).
583574capPerKey : [a] -> (a -> Bool) -> Int -> (a -> b) -> [a]
584−capPerKey = \items pred maxN getKey ->
585− union (removeWhere items pred) (capList (filter items pred) (maxN - 1) getKey)
575+capPerKey = \items pred maxN getKey -> union (removeWhere items pred) (capList (filter items pred) (maxN - 1) getKey)
586576
587577-- Shared empty/error shape for /poll. Only a few fields ever vary.
588578emptyPollResp : Timestamp -> Bool -> Bool -> Bool -> Int -> Int -> Bool -> {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}]}
589−emptyPollResp = \cursor authorized rateLimited draining gen retryAfterMs cursorWasReset ->
590− {events: [], cursor: cursor, authorized: authorized, rateLimited: rateLimited, draining: draining, generation: gen, presenceUpdates: [], heartbeat: False {}, retryAfterMs: retryAfterMs, cursorReset: cursorWasReset, hasMore: False {}, cursorStale: False {}, messageExpirations: [], messageDeliveries: [], droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: []}
579+emptyPollResp = \cursor authorized rateLimited draining gen retryAfterMs cursorWasReset -> {
580+ events: [],
581+ cursor,
582+ authorized,
583+ rateLimited,
584+ draining,
585+ generation: gen,
586+ presenceUpdates: [],
587+ heartbeat: False {},
588+ retryAfterMs,
589+ cursorReset: cursorWasReset,
590+ hasMore: False {},
591+ cursorStale: False {},
592+ messageExpirations: [],
593+ messageDeliveries: [],
594+ droppedDeliveryReceipts: 0,
595+ droppedExpirationNotifs: 0,
596+ loadPct: 0,
597+ messageCancellations: []
598+}
591599
592600-- Shared error shape for /messages send.
593601sendErrResp : MessageStatus -> Text -> {status: MessageStatus, messageId: OptionalMessageId, retryAfterMs: Int, error: Text, loadPct: Int}
594−sendErrResp = \status err -> {status: status, messageId: "", retryAfterMs: 0, error: err, loadPct: 0}
602+sendErrResp = \status err -> {status, messageId: "", retryAfterMs: 0, error: err, loadPct: 0}
595603
596604-- True when a send produced (or matched) a deliverable message.
597605isSendSuccess : MessageStatus -> Bool
@@ -606,7 +614,9 @@ isSendSuccess = \s -> case s of
606614forEach : [a] -> (a -> IO {} {}) -> IO {} {}
607615forEach = \items action -> case single (takeRelation 1 items) of
608616 Nothing {} -> yield {}
609− Just {value: x} -> do action x; forEach (dropRelation 1 items) action
617+ Just {value: x} -> do
618+ action x
619+ forEach (dropRelation 1 items) action
610620
611621-- Like forEach, but collects each action's result into a list.
612622mapEach : [a] -> (a -> IO {} b) -> IO {} [b]
@@ -618,30 +628,31 @@ mapEach = \items action -> case headOf items of
618628 yield (union [r] rest)
619629
620630-- Hex tokens: one random hex char per recursive call.
621−genTokenN : Int -> IO {} Text
622−genTokenN = \n -> if n <= 0 then yield "" else do
631+genTokenN : Int -> IO {random} Text
632+genTokenN = \n -> if n <= 0
633+then yield ""
634+else do
623635 d <- randomInt 16
624636 rest <- genTokenN (n - 1)
625637 yield (take 1 (drop d "0123456789abcdef") ++ rest)
626638
627−genToken : IO {} Text
639+genToken : IO {random} Text
628640genToken = genTokenN 48
629641
630642-- Use the supplied message id when non-empty, otherwise generate a fresh one.
631−resolveMessageId : OptionalMessageId -> IO {} OptionalMessageId
643+resolveMessageId : OptionalMessageId -> IO {random} OptionalMessageId
632644resolveMessageId = \mid -> if mid != "" then yield mid else genToken
633645
634646tooLong : Text -> Int -> Bool
635647tooLong = \s maxLen -> count (chars s) > maxLen
636648
637649isValidHex : Text -> Bool
638−isValidHex = \s ->
639− let cs = chars s in
640− let n = count cs in
641− n > 0 && n / 2 * 2 == n && all cs (\c -> contains c "0123456789abcdef")
650+isValidHex = \s -> (\cs -> (\n -> n > 0 && n / 2 * 2 == n && all cs (\c -> contains c "0123456789abcdef")) (count cs)) (chars s)
642651
643652stripTrailingDot : Text -> Text
644−stripTrailingDot = \s -> if containsSuffix "." s then stripTrailingDot (take (count (chars s) - 1) s) else s
653+stripTrailingDot = \s -> if containsSuffix "." s
654+then stripTrailingDot (take (count (chars s) - 1) s)
655+else s
645656
646657normalizeServerName : Text -> Text
647658normalizeServerName = \s -> toLower (stripTrailingDot s)
@@ -651,7 +662,7 @@ serverHostN = normalizeServerName serverHost
651662isLocalServer : Text -> Bool
652663isLocalServer = \s -> s == serverHostN
653664isRemote : Text -> Bool
654−isRemote = \s -> not (isLocalServer s)
665+isRemote = \s -> not isLocalServer s
655666
656667hasPrefix : Text -> Text -> Bool
657668hasPrefix = \pre s -> take (count (chars pre)) s == pre
@@ -662,11 +673,17 @@ containsSuffix = \suffix s -> drop (max 0 (count (chars s) - count (chars suffix
662673-- Block private/reserved/internal hostnames (SSRF defense). Skips obscure encoding
663674-- tricks (octal, hex, percent-encoding) but covers the high-value cases.
664675isBadServerName : Text -> Bool
665−isBadServerName = \sn ->
666− sn == "" || sn == "localhost"
667− || not (all (chars sn) (\c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"))
668− || any [".", ":", "[", "127.", "10.", "192.168.", "169.254.", "0.", "::"] (\p -> hasPrefix p sn)
669− || any [".localhost", ".local", ".internal", ".arpa", ".onion"] (\s -> containsSuffix s sn)
676+isBadServerName = \sn -> sn == "" || sn == "localhost" || not all (chars sn) (\c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:") || any [
677+ ".",
678+ ":",
679+ "[",
680+ "127.",
681+ "10.",
682+ "192.168.",
683+ "169.254.",
684+ "0.",
685+ "::"
686+] (\p -> hasPrefix p sn) || any [".localhost", ".local", ".internal", ".arpa", ".onion"] (\s -> containsSuffix s sn)
670687
671688-- ============================================
672689-- Auth helpers
@@ -682,73 +699,78 @@ matchIp : Text -> Text -> Bool
682699matchIp = \clientIp sessionIp -> sessionIp == "" || clientIp == sessionIp
683700
684701extractToken : Text -> Maybe Text
685−extractToken = \h ->
686− if hasPrefix "Bearer " h && drop 7 h != "" then Just {value: drop 7 h} else Nothing {}
702+extractToken = \h -> if hasPrefix "Bearer " h && drop 7 h != ""
703+then Just {value: drop 7 h}
704+else Nothing {}
687705
688−verifyMaintenanceAuth : Text -> IO {} Bool
706+verifyMaintenanceAuth : Text -> IO {reads *runtimeMaintenanceSecret} Bool
689707verifyMaintenanceAuth = \authorization -> do
690708 secret <- *runtimeMaintenanceSecret
691709 yield (secret != "" && extractToken authorization == Just {value: secret})
692710
693−withMaintAuth : Text -> IO {} a -> IO {} a -> IO {} a
711+withMaintAuth : Text -> IO {| effs} a -> IO {| effs} a -> IO {reads *runtimeMaintenanceSecret | effs} a
694712withMaintAuth = \authorization onUnauth onAuth -> do
695713 authorized <- verifyMaintenanceAuth authorization
696714 if authorized then onAuth else onUnauth
697715
698716-- Common gate for handlers: optional drain check, global rate, session auth.
699717-- mkErr is called with one of: "draining", "rate_limited", "unauthorized".
700−gateAuth : Bool -> Text -> Text -> Timestamp -> (resp -> ret) -> (Text -> resp) -> (PubkeyHex -> IO {} ret) -> IO {} ret
718+gateAuth : Bool -> Text -> Text -> Timestamp -> (resp -> ret) -> (Text -> resp) -> (PubkeyHex -> IO {} ret) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart} ret
701719gateAuth = \checkDrain auth ip t respond mkErr onAuth -> do
702720 dp <- *drainPhase
703721 g <- checkGlobalRate t
704722 let err = \e -> yield (respond (mkErr e))
705− if checkDrain && dp >= 2 then err "draining"
706− else if g then err "rate_limited"
707− else withSessionAuth auth t ip (err "unauthorized") onAuth
723+ if checkDrain && dp >= 2
724+ then err "draining"
725+ else if g then err "rate_limited" else withSessionAuth auth t ip (err "unauthorized") onAuth
708726
709727-- gateAuth + per-key rate gate. `rateResp` is the response value when the per-key gate trips.
710−gateClientWrite : Text -> Text -> Timestamp -> (resp -> ret) -> (Text -> resp) -> resp -> (PubkeyHex -> IO {} ret) -> IO {} ret
728+gateClientWrite : Text -> Text -> Int<Ms> -> (a -> b) -> (Text -> a) -> a -> (Text -> IO {} b) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart} b
711729gateClientWrite = \auth ip t respond mkErr rateResp onAuth ->
712730 gateAuth (True {}) auth ip t respond mkErr (\pk -> do
713731 lim <- atomic do
714732 rates <- *clientWriteRates
715733 let r = checkRate rates pk maxClientWriteRatePerKey clientWriteRateWindowMs t
716− set *clientWriteRates = r.entries
734+ -- TODO: make this no be a `replace`
735+ replace *clientWriteRates = r.entries
717736 yield r.limited
718737 if lim then yield (respond rateResp) else onAuth pk)
719738
720−gateLookup : Text -> Text -> Timestamp -> (resp -> ret) -> (Text -> resp) -> resp -> (PubkeyHex -> IO {} ret) -> IO {} ret
739+gateLookup : Text -> Text -> Int<Ms> -> (a -> b) -> (Text -> a) -> a -> (Text -> IO {} b) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart} b
721740gateLookup = \auth ip t respond mkErr rateResp onAuth ->
722741 gateAuth (False {}) auth ip t respond mkErr (\pk -> do
723742 lim <- atomic do
724743 rates <- *lookupRates
725744 let r = checkRate rates pk maxLookupRatePerKey lookupRateWindowMs t
726− set *lookupRates = r.entries
745+ -- TODO: make this no be a `replace`
746+ replace *lookupRates = r.entries
727747 yield r.limited
728748 if lim then yield (respond rateResp) else onAuth pk)
729749
730−withSessionAuth : Text -> Int<Ms> -> Text -> a -> (PubkeyHex -> a) -> a
731−withSessionAuth = \authorization t clientIp onUnauth onAuth ->
750+withSessionAuth : Text -> Int<Ms> -> Text -> IO {| e} a -> (PubkeyHex -> IO {| e} a) -> IO {reads *sessions | e} a
751+withSessionAuth = \authorization t clientIp onUnauth onAuth -> do
752+ ses <- *sessions
732753 case extractToken authorization of
733754 Nothing {} -> onUnauth
734− Just {value: token} -> do
735− ses <- *sessions
736− case findFirst ses (\s -> s.expiresAt > t && s.token == token && matchIp clientIp s.ip) of
737− Just {value: s} -> onAuth s.pubkey
738− _ -> onUnauth
739−
740−generateFederationAuth : Text -> Timestamp -> IO {network} Text
741−generateFederationAuth = \scope requestTimestamp ->
742− if serverFederationPrivateKeyHex != ""
743− then do
755+ Just {value: token} -> case findFirst ses (\s -> s.expiresAt > t && s.token == token && matchIp clientIp s.ip) of
756+ Just {value: s} -> onAuth s.pubkey
757+ _ -> onUnauth
758+
759+generateFederationAuth : Text -> a -> IO {reads *pendingVerifications, writes *pendingVerifications, clock, random} Text
760+generateFederationAuth = \scope requestTimestamp -> do
761+ let privKey = if serverFederationPrivateKeyHex == ""
762+ then Nothing {}
763+ else bytesFromHex serverFederationPrivateKeyHex
764+ case privKey of
765+ Just {value: pk} -> do
744766 nonce <- genTokenN 48
745− yield ("Signed " ++ bytesToHex (sign (bytesFromHex serverFederationPrivateKeyHex) (textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ serverHostN ++ "|" ++ nonce))) ++ ":" ++ nonce)
746− else do
767+ yield ("Signed " ++ bytesToHex (sign pk (textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ serverHostN ++ "|" ++ nonce))) ++ ":" ++ nonce)
768+ _ -> do
747769 token <- genToken
748770 t <- now
749− atomic do
771+ atomic (do
750772 cur <- *pendingVerifications
751− set *pendingVerifications = capList (union cur [{token: token, createdAt: t, scope: scope}]) maxPendingVerifications (\p -> p.createdAt)
773+ *pendingVerifications = capList (union cur [{token, createdAt: t, scope}]) maxPendingVerifications (\p -> p.createdAt))
752774 yield ("Bearer " ++ token)
753775
754776-- Verify a federation request: signed (Ed25519 over scope|ts|fromServer|nonce) or callback Bearer token.
@@ -767,7 +789,11 @@ verifyFederationAuth = \authorization fromServer scope requestTimestamp -> do
767789 let nonce = drop (sepIdx + 1) payload
768790 result <- fetch (federationUrl fromServer) (FederationPubkey {})
769791 case result of
770− Ok {value: r} -> yield (r.ok && r.pubkey != "" && verify (bytesFromHex r.pubkey) (textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer ++ (if nonce == "" then "" else "|" ++ nonce))) (bytesFromHex sig))
792+ Ok {value: r} -> case bytesFromHex r.pubkey of
793+ Just {value: pk} -> case bytesFromHex sig of
794+ Just {value: sigBytes} -> yield (r.ok && r.pubkey != "" && verify pk (textToBytes (scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer ++ (if nonce == "" then "" else "|" ++ nonce))) sigBytes)
795+ _ -> yield False {}
796+ _ -> yield False {}
771797 _ -> yield False {}
772798 else case extractToken authorization of
773799 Just {value: token} -> do
@@ -775,25 +801,28 @@ verifyFederationAuth = \authorization fromServer scope requestTimestamp -> do
775801 case result of Ok {value: r} -> yield r.ok; _ -> yield False {}
776802 _ -> yield False {}
777803
778−withFederationAuth : Text -> Timestamp -> ({ok: Bool, error: Text, retryAfterMs: Int} -> ret) -> Text -> Text -> Timestamp -> Bool -> IO {network} ret -> IO {network} ret
779804withFederationAuth = \authorization t respond fromServer scope requestTimestamp precondition action -> do
780805 blocked <- *blockedPeers
781806 allowed <- *allowedPeers
782807 let err = \e r -> yield (respond {ok: False {}, error: e, retryAfterMs: r})
783− let preErr =
784− if elem blocked fromServer then "blocked"
785− else if count allowed > 0 && not (elem allowed fromServer) then "not_allowed"
786− else if not precondition then "invalid_request"
787− else if requestTimestamp > 0 && abs (requestTimestamp - t) > clockSkewTolerance then "clock_skew"
788− else ""
789− if preErr != "" then err preErr 0
808+ let preErr = if elem blocked fromServer
809+ then "blocked"
810+ else if count allowed > 0 && not elem allowed fromServer
811+ then "not_allowed"
812+ else if not precondition
813+ then "invalid_request"
814+ else if requestTimestamp > 0 && abs (requestTimestamp - t) > clockSkewTolerance
815+ then "clock_skew"
816+ else ""
817+ if preErr != ""
818+ then err preErr 0
790819 else do
791820 verified <- verifyFederationAuth authorization fromServer scope requestTimestamp
792− if not verified then err "unauthorized" 0
821+ if not verified
822+ then err "unauthorized" 0
793823 else do
794824 limited <- checkServerRateGate fromServer t
795− if limited then err "rate_limited" federationRateWindowMs
796− else action
825+ if limited then err "rate_limited" federationRateWindowMs else action
797826
798827-- ============================================
799828-- Rate limiting (plain count-per-window, no sliding interpolation)
@@ -808,68 +837,67 @@ withFederationAuth = \authorization t respond fromServer scope requestTimestamp
808837
809838-- Returns {limited, entries}. Increments count when the key fits within the window.
810839checkRate : [RateEntry] -> Text -> Int -> Int<Ms> -> Timestamp -> {limited: Bool, entries: [RateEntry]}
811−checkRate = \entries key maxRate windowMs t ->
812− let cur = case findFirst entries (\r -> r.key == key && t - r.windowStart < windowMs) of
813− Just {value: r} -> {windowStart: r.windowStart, count: r.count + 1}
814− _ -> {windowStart: t, count: 1} in
815− if cur.count > maxRate
816− then {limited: True {}, entries: entries}
817− else {limited: False {}, entries: capList (union (removeWhere entries (\x -> x.key == key)) [{key: key, windowStart: cur.windowStart, count: cur.count}]) 5000 (\r -> r.windowStart)}
818−
819−checkGlobalRate : Int<Ms> -> IO {} Bool
820−checkGlobalRate = \t -> atomic do
840+checkRate = \entries key maxRate windowMs t -> (\cur -> if cur.count > maxRate then {limited: True {}, entries} else {limited: False {}, entries: capList (union (removeWhere entries (\x -> x.key == key)) [{key, cur.windowStart, cur.count}]) 5000 (\r -> r.windowStart)}) (case findFirst entries (\r -> r.key == key && t - r.windowStart < windowMs) of
841+ Just {value: r} -> {r.windowStart, count: r.count + 1}
842+ _ -> {windowStart: t, count: 1})
843+
844+checkGlobalRate : Timestamp -> IO {reads *globalRateCount, reads *globalRateWindowStart, writes *globalRateCount, writes *globalRateWindowStart} Bool
845+checkGlobalRate = \t -> atomic (do
821846 ws <- *globalRateWindowStart
822847 c <- *globalRateCount
823− if t - ws >= globalRateWindowMs then do
824− set *globalRateWindowStart = t
825− set *globalRateCount = 1
826− yield False {}
827− else if c >= maxGlobalRequestRate then yield True {}
848+ if t - ws >= globalRateWindowMs
849+ then do
850+ *globalRateWindowStart = t
851+ *globalRateCount = 1
852+ yield (False {})
853+ else if c >= maxGlobalRequestRate
854+ then yield (True {})
828855 else do
829− set *globalRateCount = c + 1
830− yield False {}
856+ *globalRateCount = c + 1
857+ yield (False {}))
831858
832−checkAuthGlobalRate : Int<Ms> -> IO {} Bool
833−checkAuthGlobalRate = \t -> atomic do
859+checkAuthGlobalRate = \t -> atomic (do
834860 ws <- *authGlobalRateWindowStart
835861 c <- *authGlobalRateCount
836− if t - ws >= authGlobalRateWindowMs then do
837− set *authGlobalRateWindowStart = t
838− set *authGlobalRateCount = 1
839− yield False {}
840− else if c >= maxAuthGlobalRate then yield True {}
862+ if t - ws >= authGlobalRateWindowMs
863+ then do
864+ *authGlobalRateWindowStart = t
865+ *authGlobalRateCount = 1
866+ yield (False {})
867+ else if c >= maxAuthGlobalRate
868+ then yield (True {})
841869 else do
842− set *authGlobalRateCount = c + 1
843− yield False {}
844−
845−checkIpRateGate : Text -> Timestamp -> IO {} Bool
846−checkIpRateGate = \ip t ->
847− if ip == "" then yield False {}
848− else atomic do
849− rates <- *ipRates
850− let r = checkRate rates ip maxIpRatePerIp ipRateWindowMs t
851− set *ipRates = r.entries
852− yield r.limited
853−
854−checkServerRateGate : Text -> Int -> IO {} Bool
855−checkServerRateGate = \server t -> atomic do
870+ *authGlobalRateCount = c + 1
871+ yield (False {}))
872+
873+checkIpRateGate : Text -> Int<Ms> -> IO {reads *ipRates, writes *ipRates} Bool
874+checkIpRateGate = \ip t -> if ip == ""
875+then yield (False {})
876+else atomic (do
877+ rates <- *ipRates
878+ let r = checkRate rates ip maxIpRatePerIp ipRateWindowMs t
879+ replace *ipRates = r.entries
880+ yield r.limited)
881+
882+checkServerRateGate : Text -> Int -> IO {reads *federationRates, writes *federationRates} Bool
883+checkServerRateGate = \server t -> atomic (do
856884 rates <- *federationRates
857885 let r = checkRate rates server maxFederationRatePerServer federationRateWindowMs t
858− set *federationRates = r.entries
859− yield r.limited
886+ replace *federationRates = r.entries
887+ yield r.limited)
860888
861889-- Pre-auth gate: drain + global + ip + auth-global. Returns "" when ok, else an error code.
862−authPreCheck : Text -> Timestamp -> IO {} Text
890+authPreCheck : Text -> Int<Ms> -> IO {reads *authGlobalRateCount, reads *authGlobalRateWindowStart, reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *ipRates, writes *authGlobalRateCount, writes *authGlobalRateWindowStart, writes *globalRateCount, writes *globalRateWindowStart, writes *ipRates} Text
863891authPreCheck = \clientIp t -> do
864892 dp <- *drainPhase
865893 g <- checkGlobalRate t
866894 i <- checkIpRateGate clientIp t
867895 a <- checkAuthGlobalRate t
868− yield (if dp >= 1 then "draining"
869− else if g then "global_rate_limited"
870− else if i then "ip_rate_limited"
871− else if a then "auth_rate_limited"
872− else "")
896+ yield (if dp >= 1
897+ then "draining"
898+ else if g
899+ then "global_rate_limited"
900+ else if i then "ip_rate_limited" else if a then "auth_rate_limited" else "")
873901
874902-- ============================================
875903-- Federation failure tracking (simple, no circuit breaker)
@@ -883,25 +911,25 @@ retryBackoff : Int -> Int<Ms>
883911retryBackoff = \failures -> min retryBackoffMax (retryBackoffBase * max 1 failures)
884912
885913shouldRetryServer : Text -> Timestamp -> [ForwardFailure] -> Bool
886−shouldRetryServer = \server t failures ->
887− none failures (\f -> f.server == server && t - f.failedAt < retryBackoff f.failures)
914+shouldRetryServer = \server t failures -> none failures (\f -> f.server == server && t - f.failedAt < retryBackoff f.failures)
888915
889−recordFailure : Text -> IO {} {}
916+recordFailure : Text -> IO {reads *forwardFailures, writes *forwardFailures, clock} {}
890917recordFailure = \server -> do
891918 t <- now
892− atomic do
919+ atomic (do
893920 failures <- *forwardFailures
894921 let same = \f -> f.server == server
895922 let prev = case findFirst failures same of
896− Just {value: f} -> {failures: f.failures + 1, firstFailedAt: f.firstFailedAt}
897− _ -> {failures: 1, firstFailedAt: t}
898− set *forwardFailures = union (removeWhere failures same)
899− [{server: server, failedAt: t, failures: prev.failures, firstFailedAt: prev.firstFailedAt}]
900−
901−clearFailure : Text -> IO {} {}
902−clearFailure = \server -> atomic do
923+ Just {value: f} -> {failures: f.failures + 1, f.firstFailedAt}
924+ _ -> {failures: 1, firstFailedAt: t}
925+ *forwardFailures = union (removeWhere failures same) [
926+ {server, failedAt: t, prev.failures, prev.firstFailedAt}
927+ ])
928+
929+clearFailure : Text -> IO {reads *forwardFailures, writes *forwardFailures} {}
930+clearFailure = \server -> atomic (do
903931 forwardFailures <- *forwardFailures
904− set *forwardFailures = filter forwardFailures (\f -> f.server != server)
932+ *forwardFailures = filter forwardFailures (\f -> f.server != server))
905933
906934-- ============================================
907935-- Common utility queries
@@ -917,7 +945,9 @@ clampTimestamp : Timestamp -> Timestamp -> Timestamp
917945clampTimestamp = \timestamp t -> clamp (t - messageMaxAge) t timestamp
918946
919947effectiveMessageTtl : Int<Ms> -> Int<Ms>
920−effectiveMessageTtl = \e -> if e <= 0 then unackedMessageMaxAge else clamp minMessageTtl unackedMessageMaxAge e
948+effectiveMessageTtl = \e -> if e <= 0
949+then unackedMessageMaxAge
950+else clamp minMessageTtl unackedMessageMaxAge e
921951
922952nextSeqTs : Timestamp -> Timestamp -> Timestamp
923953nextSeqTs = \t seqCounter -> max t (seqCounter + 1)
@@ -926,38 +956,27 @@ dedupMessageIds : [MessageIdHex] -> [MessageIdHex]
926956dedupMessageIds = \ids -> takeRelation maxMessageIds (unique ids)
927957
928958presenceForKey : [PresenceEntry] -> PubkeyHex -> Timestamp -> [PresenceEntry]
929−presenceForKey = \presence pubkey t ->
930− filter presence (\p -> p.pubkey == pubkey && p.expiresAt > t)
959+presenceForKey = \presence pubkey t -> filter presence (\p -> p.pubkey == pubkey && p.expiresAt > t)
931960
932961-- Resolve a key's server for client lookup, masking remote identities behind "remote".
933962maskedServer : [PresenceEntry] -> PubkeyHex -> Timestamp -> Text
934−maskedServer = \pres pubkey t ->
935− let here = presenceForKey pres pubkey t in
936− if any here (\p -> isLocalServer p.server) then serverHostN
937− else if count here > 0 then "remote"
938− else ""
963+maskedServer = \pres pubkey t -> (\here -> if any here (\p -> isLocalServer p.server) then serverHostN else if count here > 0 then "remote" else "") (presenceForKey pres pubkey t)
939964
940965hasMessage : MessageIdHex -> PubkeyHex -> [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> Bool
941966hasMessage = \mid toKey items -> any items (\x -> x.messageId == mid && x.toKey == toKey)
942967
943968isDuplicateMessage : MessageIdHex -> PubkeyHex -> [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> [{messageId: MessageIdHex, toKey: PubkeyHex | b}] -> [{messageId: MessageIdHex, toKey: PubkeyHex | c}] -> Bool
944−isDuplicateMessage = \mid toKey msgs aids dids ->
945− hasMessage mid toKey msgs || hasMessage mid toKey aids || hasMessage mid toKey dids
969+isDuplicateMessage = \mid toKey msgs aids dids -> hasMessage mid toKey msgs || hasMessage mid toKey aids || hasMessage mid toKey dids
946970
947971collectPeers : [a] -> (a -> Text) -> [Text]
948−collectPeers = \items getServer ->
949− unique (filter (pluck items getServer) isRemote)
972+collectPeers = \items getServer -> unique (filter (pluck items getServer) isRemote)
950973
951974knownPeerServersFromPresence : [PresenceEntry] -> [Text]
952975knownPeerServersFromPresence = \presence -> collectPeers presence (\p -> p.server)
953976
954977-- Last-write-wins merge by (pubkey, server), keeping the entry with the larger expiresAt.
955978mergePresence : [PresenceEntry] -> [PresenceEntry] -> [PresenceEntry]
956−mergePresence = \existing incoming ->
957− fold (\acc e ->
958− let same = \x -> x.pubkey == e.pubkey && x.server == e.server in
959− if any acc (\x -> same x && x.expiresAt >= e.expiresAt) then acc
960− else union (removeWhere acc same) [e]) existing incoming
979+mergePresence = \existing incoming -> fold (\acc e -> (\same -> if any acc (\x -> same x && x.expiresAt >= e.expiresAt) then acc else union (removeWhere acc same) [e]) (\x -> x.pubkey == e.pubkey && x.server == e.server)) existing incoming
961980
962981-- ============================================
963982-- Pruning
@@ -966,37 +985,37 @@ mergePresence = \existing incoming ->
966985-- block. Returns the locally-expired presence rows whose pubkey has no other
967986-- live local session, so the caller can broadcast offline gossip for them.
968987
969−pruneExpired : Timestamp -> IO {} [PresenceEntry]
988+pruneExpired : Int<Ms> -> IO {reads *ackedIds, reads *activePolls, reads *cancelNotifications, reads *challenges, reads *deliveredIds, reads *forwardFailures, reads *forwards, reads *messages, reads *pendingFederationCancels, reads *pendingVerifications, reads *presence, reads *senderDeliveries, reads *senderExpirations, reads *sessions, writes *ackedIds, writes *activePolls, writes *cancelNotifications, writes *challenges, writes *deliveredIds, writes *forwardFailures, writes *forwards, writes *messages, writes *pendingFederationCancels, writes *pendingVerifications, writes *presence, writes *senderDeliveries, writes *senderExpirations, writes *sessions} [{expiresAt: Timestamp, pubkey: PubkeyHex, server: AnyServerName, timestamp: Timestamp}]
970989pruneExpired = \t -> atomic do
971990 ch <- *challenges
972− set *challenges = filter ch (\x -> x.expiresAt > t)
991+ *challenges = filter ch (\x -> x.expiresAt > t)
973992 ses <- *sessions
974− set *sessions = filter ses (\x -> x.expiresAt > t)
993+ *sessions = filter ses (\x -> x.expiresAt > t)
975994 msgs <- *messages
976− set *messages = filter msgs (\m -> m.expiresAt > t)
995+ *messages = filter msgs (\m -> m.expiresAt > t)
977996 fwds <- *forwards
978− set *forwards = filter fwds (\f -> f.expiresAt > t)
997+ *forwards = filter fwds (\f -> f.expiresAt > t)
979998 aids <- *ackedIds
980− set *ackedIds = filter aids (\a -> t - a.ackedAt < messageMaxAge)
999+ *ackedIds = filter aids (\a -> t - a.ackedAt < messageMaxAge)
9811000 dids <- *deliveredIds
982− set *deliveredIds = filter dids (\d -> t - d.deliveredAt < messageMaxAge)
1001+ *deliveredIds = filter dids (\d -> t - d.deliveredAt < messageMaxAge)
9831002 ff <- *forwardFailures
984− set *forwardFailures = filter ff (\f -> t - f.failedAt < 86400000)
1003+ *forwardFailures = filter ff (\f -> t - f.failedAt < 86400000)
9851004 aps <- *activePolls
986− set *activePolls = filter aps (\p -> t - p.startedAt < pollTimeoutMs * 3)
1005+ *activePolls = filter aps (\p -> t - p.startedAt < pollTimeoutMs * 3)
9871006 pv <- *pendingVerifications
988− set *pendingVerifications = filter pv (\p -> t - p.createdAt < verificationTokenExpiry)
1007+ *pendingVerifications = filter pv (\p -> t - p.createdAt < verificationTokenExpiry)
9891008 se <- *senderExpirations
990− set *senderExpirations = filter se (\x -> t - x.expiredAt < unackedMessageMaxAge)
1009+ *senderExpirations = filter se (\x -> t - x.expiredAt < unackedMessageMaxAge)
9911010 sd <- *senderDeliveries
992− set *senderDeliveries = filter sd (\x -> t - x.deliveredAt < unackedMessageMaxAge)
1011+ *senderDeliveries = filter sd (\x -> t - x.deliveredAt < unackedMessageMaxAge)
9931012 cn <- *cancelNotifications
994− set *cancelNotifications = filter cn (\x -> t - x.cancelledAt < unackedMessageMaxAge)
1013+ *cancelNotifications = filter cn (\x -> t - x.cancelledAt < unackedMessageMaxAge)
9951014 pfc <- *pendingFederationCancels
996− set *pendingFederationCancels = filter pfc (\x -> t - x.createdAt < messageMaxAge)
1015+ *pendingFederationCancels = filter pfc (\x -> t - x.createdAt < messageMaxAge)
9971016 -- presence: remember locally-expired keys for offline gossip
9981017 pres <- *presence
999− set *presence = filter pres (\p -> p.expiresAt > t)
1018+ *presence = filter pres (\p -> p.expiresAt > t)
10001019 let stillLive = \pk -> any pres (\k -> isLocalServer k.server && k.pubkey == pk && k.expiresAt > t)
10011020 yield (filter pres (\p -> p.expiresAt <= t && isLocalServer p.server && not (stillLive p.pubkey)))
10021021
@@ -1010,47 +1029,60 @@ pruneExpired = \t -> atomic do
10101029
10111030-- Build a gossip event with this server's identity.
10121031mkGossip : GossipEventType -> PubkeyHex -> Timestamp -> Int<Ms> -> GossipEvent
1013−mkGossip = \etype pk t ttl ->
1014− {eventType: etype, pubkey: pk, server: serverHostN, timestamp: t, ttl: ttl, seenBy: [serverHostN]}
1032+mkGossip = \etype pk t ttl -> {
1033+ eventType: etype,
1034+ pubkey: pk,
1035+ server: serverHostN,
1036+ timestamp: t,
1037+ ttl,
1038+ seenBy: [serverHostN]
1039+}
10151040
10161041-- Build an acked entry for a federated message.
10171042mkAckedEntry : {messageId: MessageIdHex, toKey: PubkeyHex, originServer: Text | a} -> Timestamp -> AckedEntry
1018−mkAckedEntry = \m t -> {messageId: m.messageId, toKey: m.toKey, ackedAt: t, originServer: m.originServer, retries: 0}
1043+mkAckedEntry = \m t -> {m.messageId, m.toKey, ackedAt: t, m.originServer, retries: 0}
10191044
10201045-- Record federation acks and sender deliveries for a batch of just-removed messages.
10211046-- Returns the federated-ack entries (the caller flushes them remotely later).
1022−recordAcksAndDeliveries : [Message] -> Timestamp -> IO {} [AckedEntry]
1047+recordAcksAndDeliveries : [{messageId: MessageIdHex, originServer: Text, senderKey: Text, toKey: PubkeyHex | a}] -> Int<Ms> -> IO {reads *ackedIds, reads *senderDeliveries, writes *ackedIds, writes *senderDeliveries} [{ackedAt: Timestamp, messageId: MessageIdHex, originServer: ServerName, retries: Int, toKey: PubkeyHex}]
10231048recordAcksAndDeliveries = \toAck t -> do
10241049 let ackedFed = mapWhere toAck (\m -> m.originServer != "") (\m -> mkAckedEntry m t)
1025− let myDel = mapWhere toAck (\m -> m.senderKey != "" && m.originServer == "")
1026− (\m -> {senderKey: m.senderKey, messageId: m.messageId, toKey: m.toKey, deliveredAt: t})
1050+ let myDel = mapWhere toAck (\m -> m.senderKey != "" && m.originServer == "") (\m -> {
1051+ m.senderKey,
1052+ m.messageId,
1053+ m.toKey,
1054+ deliveredAt: t
1055+ })
10271056 aids <- *ackedIds
1028− set *ackedIds = capList (union aids ackedFed) maxAckedIds (\a -> a.ackedAt)
1057+ *ackedIds = capList (union aids ackedFed) maxAckedIds (\a -> a.ackedAt)
10291058 sds <- *senderDeliveries
1030− set *senderDeliveries = capList (union sds myDel) 10000 (\d -> d.deliveredAt)
1059+ *senderDeliveries = capList (union sds myDel) 10000 (\d -> d.deliveredAt)
10311060 yield ackedFed
10321061
10331062-- Common cancel block: drop matching messages + forwards, record cancel notification.
10341063-- Returns the federated forward servers that had the message (for caller follow-up).
1035−applyCancel : [a] -> (forall r. {messageId: MessageIdHex, toKey: Text | r} -> Bool) -> Text -> MessageIdHex -> Timestamp -> IO {} [Text]
1036−applyCancel = \msgs matches to mid t -> do
1037− set *messages = removeWhere msgs matches
1064+applyCancel : (forall r. {messageId: MessageIdHex, toKey: PubkeyHex | r} -> Bool) -> PubkeyHex -> MessageIdHex -> Int<Ms> -> IO {reads *cancelNotifications, reads *forwards, reads *messages, writes *cancelNotifications, writes *forwards, writes *messages} [Text]
1065+applyCancel = \matches to mid t -> do
1066+ mssgs <- *messages
1067+ *messages = removeWhere mssgs matches
10381068 fwds <- *forwards
1039− set *forwards = removeWhere fwds matches
1069+ *forwards = removeWhere fwds matches
10401070 cn <- *cancelNotifications
1041− set *cancelNotifications = capList (union cn [{toKey: to, messageId: mid, cancelledAt: t}]) 10000 (\c -> c.cancelledAt)
1071+ *cancelNotifications = capList (union cn [{toKey: to, messageId: mid, cancelledAt: t}]) 10000 (\c -> c.cancelledAt)
10421072 yield (collectPeers (filter fwds matches) (\f -> f.toServer))
10431073
10441074-- Cancel one message if `ownerPred` holds for it; returns whether a cancel happened.
1045−cancelOne : MessageIdHex -> PubkeyHex -> (Message -> Bool) -> Timestamp -> IO {} Bool
1046−cancelOne = \mid to ownerPred t -> atomic do
1075+cancelOne : MessageIdHex -> PubkeyHex -> ({| r} -> Bool) -> Int<Ms> -> IO {reads *messages, reads *cancelNotifications, reads *forwards, writes *cancelNotifications, writes *forwards, writes *messages} Bool
1076+cancelOne = \mid to ownerPred t -> atomic (do
10471077 msgs <- *messages
10481078 let matches = \x -> x.messageId == mid && x.toKey == to
10491079 let owns = any msgs (\m -> matches m && ownerPred m)
1050− when owns (do applyCancel msgs matches to mid t; yield {})
1051− yield owns
1080+ when owns (do
1081+ applyCancel matches to mid t
1082+ yield {})
1083+ yield owns)
10521084
1053−sendBatchedGossip : [Text] -> [GossipEvent] -> IO {network} {}
1085+sendBatchedGossip : [Text] -> [GossipEvent] -> IO {} {}
10541086sendBatchedGossip = \peers events -> forEach peers (\server -> do
10551087 t <- now
10561088 failures <- *forwardFailures
@@ -1058,17 +1090,21 @@ sendBatchedGossip = \peers events -> forEach peers (\server -> do
10581090 auth <- generateFederationAuth "gossip" t
10591091 result <- fetch (federationUrl server) (RecvGossip {
10601092 authorization: auth,
1061− events: events, hopsRemaining: gossipOriginHops, fromServer: serverHostN,
1062− requestTimestamp: t, correlationId: "", protocolVersion: federationProtocolVersion})
1093+ events,
1094+ hopsRemaining: gossipOriginHops,
1095+ fromServer: serverHostN,
1096+ requestTimestamp: t,
1097+ correlationId: "",
1098+ protocolVersion: federationProtocolVersion
1099+ })
10631100 case result of
10641101 Err _ -> recordFailure server
10651102 Ok _ -> clearFailure server))
10661103
1067−broadcastOfflineGossip : Timestamp -> [PresenceEntry] -> IO {network} {}
1104+broadcastOfflineGossip : Int<Ms> -> [{pubkey: PubkeyHex | a}] -> IO {reads *presence} {}
10681105broadcastOfflineGossip = \t expiredLocal -> do
10691106 presence <- *presence
1070− when (federationEnabled && count expiredLocal > 0)
1071− (sendBatchedGossip (knownPeerServersFromPresence presence) (pluck expiredLocal (\p -> mkGossip (GossipOffline {}) p.pubkey t offlineGossipMinTtl)))
1107+ when (federationEnabled && count expiredLocal > 0) (sendBatchedGossip (knownPeerServersFromPresence presence) (pluck expiredLocal (\p -> mkGossip (GossipOffline {}) p.pubkey t offlineGossipMinTtl)))
10721108
10731109-- ============================================
10741110-- Forward retries and acks
@@ -1081,61 +1117,98 @@ broadcastOfflineGossip = \t expiredLocal -> do
10811117-- comes online: any messages already buffered for that pubkey are enqueued
10821118-- as forwards to the newly-known server.
10831119
1084−retryPendingForwards : IO {network} {}
1120+retryPendingForwards : IO {reads *blockedPeers, reads *forwardFailures, reads *forwards, clock} {}
10851121retryPendingForwards = do
10861122 t <- now
10871123 fwds <- *forwards
10881124 failures <- *forwardFailures
10891125 blocked <- *blockedPeers
1090− forEach (filter (collectPeers fwds (\f -> f.toServer)) (\s -> shouldRetryServer s t failures && not (elem blocked s))) (\server ->
1091− forEach (takeRelation maxBatchSize (filter fwds (\f -> f.toServer == server))) (\f -> do
1092− t2 <- now
1093− auth <- generateFederationAuth ("forward:" ++ f.messageId) t2
1094− result <- fetch (federationUrl server) (ForwardMessage {
1095− toKey: f.toKey, encryptedBlob: f.encryptedBlob,
1096− timestamp: f.timestamp, originServer: f.originServer, messageId: f.messageId,
1097− fromServer: serverHostN, requestTimestamp: t2,
1098− authorization: auth, correlationId: "",
1099− expiresAt: f.expiresAt, priority: f.priority, protocolVersion: federationProtocolVersion})
1100− success <- case result of
1101− Err _ -> do recordFailure server; yield False {}
1102− Ok {value: r} -> do when r.ok (clearFailure server); yield r.ok
1103− let isMatch = \x -> x.messageId == f.messageId && x.toServer == server
1104− let isDone = \x -> isMatch x && (success || x.retries + 1 >= maxForwardRetries)
1105− atomic do
1106− cur <- *forwards
1107− set *forwards = pluck (removeWhere cur isDone) (\x ->
1108− if isMatch x
1109− 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}
1110− else x)))
1111−
1112−sendAcksAndClean : [AckedEntry] -> IO {network} {}
1113−sendAcksAndClean = \pendingAcks ->
1114− forEach (collectPeers pendingAcks (\a -> a.originServer)) (\server -> do
1115− let mids = mapWhere pendingAcks (\a -> a.originServer == server) (\a -> a.messageId)
1116− t <- now
1117− auth <- generateFederationAuth "ack" t
1118− result <- fetch (federationUrl server) (FederationAck {
1126+ forEach (filter (collectPeers fwds (\f -> f.toServer)) (\s -> shouldRetryServer s t failures && not elem blocked s)) (\server -> forEach (takeRelation maxBatchSize (filter fwds (\f -> f.toServer == server))) (\f -> do
1127+ t2 <- now
1128+ auth <- generateFederationAuth ("forward:" ++ f.messageId) t2
1129+ result <- fetch (federationUrl server) (ForwardMessage {
1130+ f.toKey,
1131+ f.encryptedBlob,
1132+ f.timestamp,
1133+ f.originServer,
1134+ f.messageId,
1135+ fromServer: serverHostN,
1136+ requestTimestamp: t2,
11191137 authorization: auth,
1120− messageIds: mids, originServer: server, fromServer: serverHostN,
1121− requestTimestamp: t, correlationId: "", protocolVersion: federationProtocolVersion})
1122− case result of
1123− Err _ -> recordFailure server
1124− Ok _ -> do
1125− clearFailure server
1126− atomic do
1127− aids <- *ackedIds
1128− set *ackedIds = filter aids (\a -> not (a.originServer == server && elem mids a.messageId)))
1138+ correlationId: "",
1139+ f.expiresAt,
1140+ f.priority,
1141+ protocolVersion: federationProtocolVersion
1142+ })
1143+ success <- case result of
1144+ Err _ -> do
1145+ recordFailure server
1146+ yield (False {})
1147+ Ok {value: r} -> do
1148+ when r.ok (clearFailure server)
1149+ yield r.ok
1150+ let isMatch = \x -> x.messageId == f.messageId && x.toServer == server
1151+ let isDone = \x -> isMatch x && (success || x.retries + 1 >= maxForwardRetries)
1152+ atomic (do
1153+ cur <- *forwards
1154+ *forwards = pluck (removeWhere cur isDone) (\x -> if isMatch x
1155+ then {
1156+ x.messageId,
1157+ x.toServer,
1158+ x.createdAt,
1159+ x.toKey,
1160+ x.encryptedBlob,
1161+ x.timestamp,
1162+ x.originServer,
1163+ retries: x.retries + 1,
1164+ x.expiresAt,
1165+ x.priority,
1166+ x.senderKey
1167+ }
1168+ else x))))
1169+
1170+sendAcksAndClean : [{messageId: MessageIdHex, originServer: Text | a}] -> IO {} {}
1171+sendAcksAndClean = \pendingAcks -> forEach (collectPeers pendingAcks (\a -> a.originServer)) (\server -> do
1172+ let mids = mapWhere pendingAcks (\a -> a.originServer == server) (\a -> a.messageId)
1173+ t <- now
1174+ auth <- generateFederationAuth "ack" t
1175+ result <- fetch (federationUrl server) (FederationAck {
1176+ authorization: auth,
1177+ messageIds: mids,
1178+ originServer: server,
1179+ fromServer: serverHostN,
1180+ requestTimestamp: t,
1181+ correlationId: "",
1182+ protocolVersion: federationProtocolVersion
1183+ })
1184+ case result of
1185+ Err _ -> recordFailure server
1186+ Ok _ -> do
1187+ clearFailure server
1188+ atomic (do
1189+ aids <- *ackedIds
1190+ *ackedIds = filter aids (\a -> not (a.originServer == server && elem mids a.messageId))))
11291191
11301192-- Forward queued messages to a server when a remote key comes online.
1131−forwardQueuedToServer : PubkeyHex -> Text -> Timestamp -> IO {} {}
1132−forwardQueuedToServer = \pubkey server t -> atomic do
1193+forwardQueuedToServer : PubkeyHex -> ServerName -> Int<Ms> -> IO {reads *forwards, reads *messages, writes *forwards} {}
1194+forwardQueuedToServer = \pubkey server t -> atomic (do
11331195 msgs <- *messages
11341196 fwds <- *forwards
11351197 let candidates = filter msgs (\m -> m.toKey == pubkey && none fwds (\f -> f.messageId == m.messageId && f.toServer == server))
1136− let newFwds = pluck (takeRelation maxForwardsPerServer candidates) (\m ->
1137− {messageId: m.messageId, toServer: server, createdAt: t, toKey: m.toKey, encryptedBlob: m.encryptedBlob, timestamp: m.timestamp, originServer: (if m.originServer == "" then serverHostN else m.originServer), retries: 0, expiresAt: m.expiresAt, priority: m.priority, senderKey: m.senderKey})
1138− set *forwards = capList (union fwds newFwds) maxForwardsEntries (\f -> f.createdAt)
1198+ let newFwds = pluck (takeRelation maxForwardsPerServer candidates) (\m -> {
1199+ m.messageId,
1200+ toServer: server,
1201+ createdAt: t,
1202+ m.toKey,
1203+ m.encryptedBlob,
1204+ m.timestamp,
1205+ originServer: if m.originServer == "" then serverHostN else m.originServer,
1206+ retries: 0,
1207+ m.expiresAt,
1208+ m.priority,
1209+ m.senderKey
1210+ })
1211+ *forwards = capList (union fwds newFwds) maxForwardsEntries (\f -> f.createdAt))
11391212
11401213-- ============================================
11411214-- Background loops
@@ -1144,9 +1217,9 @@ forwardQueuedToServer = \pubkey server t -> atomic do
11441217-- expire stale rows, then opportunistically retry pending forwards and refresh
11451218-- local presence so peers don't see us go offline mid-session.
11461219
1147−pruneAndRetry : Timestamp -> IO {network} {}
1220+pruneAndRetry : Int<Ms> -> IO {reads *ackedIds, reads *activePolls, reads *cancelNotifications, reads *challenges, reads *deliveredIds, reads *forwardFailures, reads *forwards, reads *lastPrunedAt, reads *messages, reads *pendingFederationCancels, reads *pendingVerifications, reads *presence, reads *senderDeliveries, reads *senderExpirations, reads *sessions, writes *ackedIds, writes *activePolls, writes *cancelNotifications, writes *challenges, writes *deliveredIds, writes *forwardFailures, writes *forwards, writes *lastPrunedAt, writes *messages, writes *pendingFederationCancels, writes *pendingVerifications, writes *presence, writes *senderDeliveries, writes *senderExpirations, writes *sessions, reads *blockedPeers, reads *lastPresenceRefresh, writes *lastPresenceRefresh, clock} {}
11481221pruneAndRetry = \t -> do
1149− atomic do set *lastPrunedAt = t
1222+ *lastPrunedAt = t
11501223 expiredLocal <- pruneExpired t
11511224 fork (broadcastOfflineGossip t expiredLocal)
11521225 when federationEnabled (do
@@ -1155,22 +1228,26 @@ pruneAndRetry = \t -> do
11551228 fork (sendAcksAndClean (filter aids (\a -> isRemote a.originServer)))
11561229 lastRefresh <- *lastPresenceRefresh
11571230 when (t - lastRefresh >= presenceRefreshInterval) (do
1158− atomic do set *lastPresenceRefresh = t
1231+ *lastPresenceRefresh = t
11591232 refreshLocalPresence t))
11601233
1161−refreshLocalPresence : Timestamp -> IO {network} {}
1234+refreshLocalPresence : Int<Ms> -> IO {reads *presence, reads *sessions, writes *presence} {}
11621235refreshLocalPresence = \t -> do
1163− refreshState <- atomic do
1236+ refreshState <- atomic (do
11641237 sessions <- *sessions
11651238 presence <- *presence
11661239 let sessionKeys = pluck sessions (\s -> s.pubkey)
11671240 let needsRefresh = \p -> isLocalServer p.server && elem sessionKeys p.pubkey && p.expiresAt - t < sessionExpiry / 2
1168− let refreshed = mapWhere presence needsRefresh (\p -> {pubkey: p.pubkey, server: p.server, expiresAt: t + sessionExpiry, timestamp: t})
1241+ let refreshed = mapWhere presence needsRefresh (\p -> {
1242+ p.pubkey,
1243+ p.server,
1244+ expiresAt: t + sessionExpiry,
1245+ timestamp: t
1246+ })
11691247 let updated = union (removeWhere presence needsRefresh) refreshed
1170− set *presence = updated
1171− yield {refreshed: refreshed, peers: knownPeerServersFromPresence updated}
1172− when (count refreshState.refreshed > 0)
1173− (fork (sendBatchedGossip refreshState.peers (pluck refreshState.refreshed (\p -> mkGossip (GossipOnline {}) p.pubkey t (clampTtl (sessionExpiry / 1000))))))
1248+ replace *presence = updated
1249+ yield {refreshed, peers: knownPeerServersFromPresence updated})
1250+ when (count refreshState.refreshed > 0) (fork (sendBatchedGossip refreshState.peers (pluck refreshState.refreshed (\p -> mkGossip (GossipOnline {}) p.pubkey t (clampTtl (sessionExpiry / 1000))))))
11741251
11751252-- ============================================
11761253-- Handler: challenge / verify / revoke / logout
@@ -1189,99 +1266,129 @@ refreshLocalPresence = \t -> do
11891266-- POST /auth/challenge: issue a fresh signed-nonce challenge for `pubkey`.
11901267-- Capped per-key (maxChallengesPerKey) and rate-limited; the IP is recorded
11911268-- so /auth/verify can require the same client.
1192−handleChallenge : PubkeyHex -> Text -> ({challenge: Text, ok: Bool, expiresAt: Timestamp, retryAfterMs: Int, error: Text} -> ret) -> IO {} ret
1269+handleChallenge : PubkeyHex -> Text -> ({challenge: Text, error: Text, expiresAt: Int, ok: Bool, retryAfterMs: Int} -> a) -> IO {reads *authGlobalRateCount, reads *authGlobalRateWindowStart, reads *challengeRates, reads *challenges, reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *ipRates, writes *authGlobalRateCount, writes *authGlobalRateWindowStart, writes *challengeRates, writes *challenges, writes *globalRateCount, writes *globalRateWindowStart, writes *ipRates, clock, random} a
11931270handleChallenge = \pubkey clientIp respond -> do
11941271 t <- now
1195− preErr <- if requireClientIp && clientIp == "" then yield "client_ip_required" else authPreCheck clientIp t
1196− if preErr != "" then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: preErr})
1272+ preErr <- if requireClientIp && clientIp == ""
1273+ then yield "client_ip_required"
1274+ else authPreCheck clientIp t
1275+ if preErr != ""
1276+ then yield (respond {challenge: "", ok: False {}, expiresAt: 0, retryAfterMs: 0, error: preErr})
11971277 else do
11981278 challenge <- genToken
1199− result <- atomic do
1279+ result <- atomic (do
12001280 ch <- *challenges
12011281 let cappedActive = capPerKey (filter ch (\c -> c.expiresAt > t)) (\c -> c.pubkey == pubkey) maxChallengesPerKey (\c -> c.expiresAt)
1202− if count cappedActive >= maxChallenges then yield {ok: False {}, error: "capacity"}
1282+ if count cappedActive >= maxChallenges
1283+ then yield {ok: False {}, error: "capacity"}
12031284 else do
12041285 chRates <- *challengeRates
12051286 let chR = checkRate chRates pubkey maxChallengeRatePerKey challengeRateWindowMs t
1206− set *challengeRates = chR.entries
1207− if chR.limited then yield {ok: False {}, error: "rate_limited"}
1287+ replace *challengeRates = chR.entries
1288+ if chR.limited
1289+ then yield {ok: False {}, error: "rate_limited"}
12081290 else do
1209− set *challenges = union cappedActive [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry, ip: clientIp}]
1210− yield {ok: True {}, error: ""}
1211− 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})
1291+ replace *challenges = union cappedActive [
1292+ {pubkey, challenge, expiresAt: t + challengeExpiry, ip: clientIp}
1293+ ]
1294+ yield {ok: True {}, error: ""})
1295+ yield (respond {
1296+ challenge: if result.ok then challenge else "",
1297+ result.ok,
1298+ expiresAt: if result.ok then t + challengeExpiry else 0,
1299+ retryAfterMs: 0,
1300+ result.error
1301+ })
12121302
12131303-- POST /auth/verify: validate `signature` over `challenge` for `pubkey`.
12141304-- On success, mints a session token, records local presence (`pubkey` is now
12151305-- live on this server), and gossips an `online` event to known peers. If
12161306-- `revokeOthers` is set, all other sessions for the same pubkey are dropped.
1217−handleVerifyAuth : PubkeyHex -> Text -> SignatureHex -> Bool -> Text -> ({token: Text, expiresAt: Timestamp, error: Text} -> ret) -> IO {network} ret
1307+handleVerifyAuth : PubkeyHex -> Text -> Text -> Bool -> Text -> ({error: Text, expiresAt: Int, token: Text} -> a) -> IO {reads *authGlobalRateCount, reads *authGlobalRateWindowStart, reads *challenges, reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *ipRates, reads *presence, reads *sessions, writes *authGlobalRateCount, writes *authGlobalRateWindowStart, writes *challenges, writes *globalRateCount, writes *globalRateWindowStart, writes *ipRates, writes *presence, writes *sessions, clock, random} a
12181308handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp respond -> do
12191309 t <- now
12201310 preErr <- authPreCheck clientIp t
1221− if preErr != "" then yield (respond {token: "", expiresAt: 0, error: preErr})
1311+ if preErr != ""
1312+ then yield (respond {token: "", expiresAt: 0, error: preErr})
12221313 else do
12231314 let expiry = t + sessionExpiry
12241315 token <- genToken
1225− result <- atomic do
1316+ result <- atomic (do
12261317 ch <- *challenges
12271318 dp <- *drainPhase
12281319 let same = \c -> c.pubkey == pubkey && c.challenge == challenge
1229− let valid = dp < 1
1230− && any ch (\c -> same c && c.expiresAt > t && matchIp clientIp c.ip)
1231− && verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
1232− if not valid then yield {valid: False {}, peers: []}
1320+ let sigValid = case bytesFromHex pubkey of
1321+ Just {value: pk} -> case bytesFromHex signature of
1322+ Just {value: sigBytes} -> verify pk (textToBytes challenge) sigBytes
1323+ _ -> False {}
1324+ _ -> False {}
1325+ let valid = dp < 1 && any ch (\c -> same c && c.expiresAt > t && matchIp clientIp c.ip) && sigValid
1326+ if not valid
1327+ then yield {valid: False {}, peers: []}
12331328 else do
1234− set *challenges = removeWhere ch same
1329+ *challenges = removeWhere ch same
12351330 ses <- *sessions
12361331 let mine = \s -> s.pubkey == pubkey
1237− let pruned = if revokeOthers then removeWhere ses mine else capPerKey ses mine maxSessionsPerKey (\s -> s.expiresAt)
1238− let newSession = {token: token, pubkey: pubkey, expiresAt: expiry, ip: clientIp, createdAt: t}
1239− set *sessions = capList (union pruned [newSession]) maxSessions (\s -> s.expiresAt)
1332+ let pruned = if revokeOthers
1333+ then removeWhere ses mine
1334+ else capPerKey ses mine maxSessionsPerKey (\s -> s.expiresAt)
1335+ let newSession = {token, pubkey, expiresAt: expiry, ip: clientIp, createdAt: t}
1336+ replace *sessions = capList (union pruned [newSession]) maxSessions (\s -> s.expiresAt)
12401337 pres <- *presence
12411338 let prunedPres = removeWhere pres (\p -> p.pubkey == pubkey && isLocalServer p.server)
1242− let newPres = capList (union prunedPres [{pubkey: pubkey, server: serverHostN, expiresAt: expiry, timestamp: t}]) maxPresenceEntries (\p -> p.expiresAt)
1243− set *presence = newPres
1244− yield {valid: True {}, peers: knownPeerServersFromPresence newPres}
1245− if not result.valid then yield (respond {token: "", expiresAt: 0, error: "invalid"})
1339+ let newPres = capList (union prunedPres [
1340+ {pubkey, server: serverHostN, expiresAt: expiry, timestamp: t}
1341+ ]) maxPresenceEntries (\p -> p.expiresAt)
1342+ replace *presence = newPres
1343+ yield {valid: True {}, peers: knownPeerServersFromPresence newPres})
1344+ if not result.valid
1345+ then yield (respond {token: "", expiresAt: 0, error: "invalid"})
12461346 else do
1247− when federationEnabled
1248− (fork (sendBatchedGossip result.peers [mkGossip (GossipOnline {}) pubkey t onlineGossipTtl]))
1249− yield (respond {token: token, expiresAt: expiry, error: ""})
1347+ when federationEnabled (fork (sendBatchedGossip result.peers [
1348+ mkGossip (GossipOnline {}) pubkey t onlineGossipTtl
1349+ ]))
1350+ yield (respond {token, expiresAt: expiry, error: ""})
12501351
12511352-- POST /auth/revoke: caller (any session for the pubkey) revokes a sibling
12521353-- session by token. Returns ok=False if no such sibling existed.
1253−handleRevoke : Text -> Text -> Text -> ({ok: Bool, authorized: Bool} -> ret) -> IO {} ret
1354+handleRevoke : Text -> Text -> Text -> ({authorized: Bool, ok: Bool} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} a
12541355handleRevoke = \targetToken authorization clientIp respond -> do
12551356 t <- now
12561357 gateAuth (False {}) authorization clientIp t respond (\_ -> {ok: False {}, authorized: False {}}) (\caller -> do
1257− result <- atomic do
1358+ result <- atomic (do
12581359 ses <- *sessions
12591360 let pred = \s -> s.pubkey == caller && s.token == targetToken
1260− set *sessions = removeWhere ses pred
1261− yield (any ses pred)
1361+ *sessions = removeWhere ses pred
1362+ yield (any ses pred))
12621363 yield (respond {ok: result, authorized: True {}}))
12631364
12641365-- POST /auth/logout: drop the caller's own session. If this was the last
12651366-- session for the pubkey, also clear local presence and gossip offline.
1266−handleLogout : Text -> Text -> ({ok: Bool, authorized: Bool} -> ret) -> IO {network} ret
1367+handleLogout : Text -> Text -> ({authorized: Bool, ok: Bool} -> a) -> IO {reads *sessions, clock} a
12671368handleLogout = \authorization clientIp respond -> do
12681369 t <- now
1269− let myToken = case extractToken authorization of Just {value: tk} -> tk; _ -> ""
1270− removed <- atomic (withSessionAuth authorization t clientIp
1271− (yield {ok: False {}, pubkey: "", peers: []})
1272− (\pubkey -> do
1273− ses <- *sessions
1274− set *sessions = removeWhere ses (\s -> s.token == myToken)
1275− after <- *sessions
1276− peers <- if any after (\s -> s.pubkey == pubkey) then yield []
1277− else do
1278− pres <- *presence
1279− set *presence = removeWhere pres (\p -> p.pubkey == pubkey && isLocalServer p.server)
1280− yield (knownPeerServersFromPresence pres)
1281− yield {ok: True {}, pubkey: pubkey, peers: peers}))
1282− when (removed.ok && federationEnabled)
1283− (fork (sendBatchedGossip removed.peers [mkGossip (GossipOffline {}) removed.pubkey t offlineGossipMinTtl]))
1284− yield (respond {ok: removed.ok, authorized: removed.ok})
1370+ let myToken = case extractToken authorization of
1371+ Just {value: tk} -> tk
1372+ _ -> ""
1373+ removed <- atomic withSessionAuth authorization t clientIp (yield {
1374+ ok: False {},
1375+ pubkey: "",
1376+ peers: []
1377+ }) (\pubkey -> do
1378+ ses <- *sessions
1379+ *sessions = removeWhere ses (\s -> s.token == myToken)
1380+ after <- *sessions
1381+ peers <- if any after (\s -> s.pubkey == pubkey)
1382+ then yield []
1383+ else do
1384+ pres <- *presence
1385+ *presence = removeWhere pres (\p -> p.pubkey == pubkey && isLocalServer p.server)
1386+ yield (knownPeerServersFromPresence pres)
1387+ yield {ok: True {}, pubkey, peers})
1388+ when (removed.ok && federationEnabled) (fork (sendBatchedGossip removed.peers [
1389+ mkGossip (GossipOffline {}) removed.pubkey t offlineGossipMinTtl
1390+ ]))
1391+ yield (respond {removed.ok, authorized: removed.ok})
12851392
12861393-- ============================================
12871394-- Handler: poll
@@ -1298,7 +1405,7 @@ handleLogout = \authorization clientIp respond -> do
12981405-- POST /poll: top-level dispatch. Validates drain/global gates, detects a
12991406-- generation mismatch (server restart) to force a cursor reset, then hands
13001407-- off to `pollOnce` for the actual long-poll body.
1301−handlePoll : Timestamp -> Int -> [PubkeyHex] -> Text -> Text -> ({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}]} -> ret) -> IO {network} ret
1408+handlePoll : Int -> Int -> [PubkeyHex] -> Text -> Text -> ({authorized: Bool, cursor: Timestamp, cursorReset: Bool, cursorStale: Bool, draining: Bool, droppedDeliveryReceipts: Int, droppedExpirationNotifs: Int, events: [PollEvent], generation: Int, hasMore: Bool, heartbeat: Bool, loadPct: Int, messageCancellations: [{cancelledAt: Timestamp, messageId: MessageIdHex}], messageDeliveries: [{deliveredAt: Timestamp, messageId: MessageIdHex, toKey: PubkeyHex}], messageExpirations: [{expiredAt: Timestamp, messageId: MessageIdHex, toKey: PubkeyHex}], presenceUpdates: [{online: Bool, pubkey: PubkeyHex}], rateLimited: Bool, retryAfterMs: Int} -> Response) -> IO {reads *activePolls, reads *cancelNotifications, reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *pollWakeup, reads *presence, reads *senderDeliveries, reads *senderExpirations, reads *serverGeneration, reads *sessions, writes *activePolls, writes *cancelNotifications, writes *globalRateCount, writes *globalRateWindowStart, writes *senderDeliveries, writes *senderExpirations, clock} Response
13021409handlePoll = \cursor generation watchKeys authorization clientIp respond -> do
13031410 t <- now
13041411 serverGen <- *serverGeneration
@@ -1306,95 +1413,115 @@ handlePoll = \cursor generation watchKeys authorization clientIp respond -> do
13061413 g <- checkGlobalRate t
13071414 let cursorWasReset = generation != serverGen && cursor > 0
13081415 let er = \auth rate drain retryRate -> yield (respond (emptyPollResp 0 auth rate drain serverGen retryRate cursorWasReset))
1309− if dp >= 2 then er (True {}) (False {}) (True {}) 0
1310− else if g then er (False {}) (True {}) (False {}) globalRateWindowMs
1416+ if dp >= 2
1417+ then er (True {}) (False {}) (True {}) 0
1418+ else if g
1419+ then er (False {}) (True {}) (False {}) globalRateWindowMs
13111420 else pollOnce authorization (if cursorWasReset then 0 else cursor) cursorWasReset (takeRelation maxWatchKeys watchKeys) clientIp serverGen respond t
13121421
13131422-- Body of a single poll. Treats the cursor advance as an implicit ack
13141423-- (`ackPolledMessages`), acquires a per-pubkey poll slot, runs `doPoll` to
13151424-- collect events (or block until wakeup), then assembles the response with
13161425-- piggybacked presence/expiration/delivery/cancellation metadata.
1317−pollOnce : Text -> Timestamp -> Bool -> [PubkeyHex] -> Text -> Int -> ({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}]} -> ret) -> Timestamp -> IO {network} ret
1426+pollOnce : Text -> Int -> Bool -> [PubkeyHex] -> Text -> Int -> ({authorized: Bool, cursor: Timestamp, cursorReset: Bool, cursorStale: Bool, draining: Bool, droppedDeliveryReceipts: Int, droppedExpirationNotifs: Int, events: [PollEvent], generation: Int, hasMore: Bool, heartbeat: Bool, loadPct: Int, messageCancellations: [{cancelledAt: Timestamp, messageId: MessageIdHex}], messageDeliveries: [{deliveredAt: Timestamp, messageId: MessageIdHex, toKey: PubkeyHex}], messageExpirations: [{expiredAt: Timestamp, messageId: MessageIdHex, toKey: PubkeyHex}], presenceUpdates: [{online: Bool, pubkey: PubkeyHex}], rateLimited: Bool, retryAfterMs: Int} -> Response) -> Int<Ms> -> IO {reads *activePolls, reads *cancelNotifications, reads *pollWakeup, reads *presence, reads *senderDeliveries, reads *senderExpirations, reads *sessions, writes *activePolls, writes *cancelNotifications, writes *senderDeliveries, writes *senderExpirations, clock} Response
13181427pollOnce = \authorization cursor cursorWasReset watchKeys clientIp serverGen respond t -> do
1319− setup <- atomic (withSessionAuth authorization t clientIp
1320− (yield Nothing {})
1321− (\pubkey -> do
1322− let clampedCursor = clamp 0 t cursor
1323− pendingAcks <- if clampedCursor > 0 then ackPolledMessages pubkey clampedCursor t else yield []
1324− startWakeup <- *pollWakeup
1325− yield (Just {value: {pubkey: pubkey, clampedCursor: clampedCursor, startWakeup: startWakeup, pendingAcks: pendingAcks}})))
1428+ setup <- atomic withSessionAuth authorization t clientIp (yield (Nothing {})) (\pubkey -> do
1429+ let clampedCursor = clamp 0 t cursor
1430+ pendingAcks <- if clampedCursor > 0 then ackPolledMessages pubkey clampedCursor t else yield []
1431+ startWakeup <- *pollWakeup
1432+ yield (Just {value: {pubkey, clampedCursor, startWakeup, pendingAcks}}))
13261433 case setup of
13271434 Nothing {} -> yield (respond (emptyPollResp 0 (False {}) (False {}) (False {}) serverGen 0 cursorWasReset))
13281435 Just {value: s} -> do
1329− acquired <- atomic do
1436+ acquired <- atomic (do
13301437 aps <- *activePolls
1331− if countWhere aps (\p -> p.pubkey == s.pubkey) >= maxPollsPerKey then yield False {}
1438+ if countWhere aps (\p -> p.pubkey == s.pubkey) >= maxPollsPerKey
1439+ then yield (False {})
13321440 else do
1333− set *activePolls = capList (union aps [{pubkey: s.pubkey, startedAt: t}]) maxActivePolls (\p -> p.startedAt)
1334− yield True {}
1441+ *activePolls = capList (union aps [{s.pubkey, startedAt: t}]) maxActivePolls (\p -> p.startedAt)
1442+ yield (True {}))
13351443 if not acquired
1336− then yield (respond (emptyPollResp cursor (True {}) (True {}) (False {}) serverGen pollTimeoutMs cursorWasReset))
1337− else do
1338− pollResult <- doPoll s t
1339− atomic do
1340− aps <- *activePolls
1341− set *activePolls = filter aps (\p -> p.pubkey != s.pubkey)
1342− when federationEnabled (fork (sendAcksAndClean s.pendingAcks))
1343− t2 <- now
1344− extras <- atomic do
1345− pres <- *presence
1346− let mine = \x -> x.senderKey == s.pubkey
1347− seItems <- *senderExpirations
1348− set *senderExpirations = removeWhere seItems mine
1349− let myExp = mapWhere seItems mine (\x -> {messageId: x.messageId, toKey: x.toKey, expiredAt: x.expiredAt})
1350− sdItems <- *senderDeliveries
1351− set *senderDeliveries = removeWhere sdItems mine
1352− let myDel = mapWhere sdItems mine (\x -> {messageId: x.messageId, toKey: x.toKey, deliveredAt: x.deliveredAt})
1353− cnItems <- *cancelNotifications
1354− let isMine = \x -> x.toKey == s.pubkey
1355− set *cancelNotifications = removeWhere cnItems isMine
1356− let myCancels = mapWhere cnItems isMine (\x -> {messageId: x.messageId, cancelledAt: x.cancelledAt})
1357− yield {presenceUpdates: pluck watchKeys (\k -> {pubkey: k, online: count (presenceForKey pres k t2) > 0}), expirations: myExp, deliveries: myDel, cancellations: myCancels}
1358− yield (respond {events: pollResult.events, cursor: pollResult.cursor, authorized: True {}, rateLimited: False {}, draining: False {}, generation: serverGen, presenceUpdates: extras.presenceUpdates, heartbeat: count pollResult.events == 0, retryAfterMs: 0, cursorReset: cursorWasReset, hasMore: pollResult.hasMore, cursorStale: False {}, messageExpirations: extras.expirations, messageDeliveries: extras.deliveries, droppedDeliveryReceipts: 0, droppedExpirationNotifs: 0, loadPct: 0, messageCancellations: extras.cancellations})
1444+ then yield (respond (emptyPollResp cursor (True {}) (True {}) (False {}) serverGen pollTimeoutMs cursorWasReset))
1445+ else do
1446+ pollResult <- doPoll s t
1447+ atomic (do aps <- *activePolls; *activePolls = filter aps (\p -> p.pubkey != s.pubkey))
1448+ when federationEnabled (fork (sendAcksAndClean s.pendingAcks))
1449+ t2 <- now
1450+ extras <- atomic (do
1451+ pres <- *presence
1452+ let mine = \x -> x.senderKey == s.pubkey
1453+ seItems <- *senderExpirations
1454+ *senderExpirations = removeWhere seItems mine
1455+ let myExp = mapWhere seItems mine (\x -> {x.messageId, x.toKey, x.expiredAt})
1456+ sdItems <- *senderDeliveries
1457+ *senderDeliveries = removeWhere sdItems mine
1458+ let myDel = mapWhere sdItems mine (\x -> {x.messageId, x.toKey, x.deliveredAt})
1459+ cnItems <- *cancelNotifications
1460+ let isMine = \x -> x.toKey == s.pubkey
1461+ *cancelNotifications = removeWhere cnItems isMine
1462+ let myCancels = mapWhere cnItems isMine (\x -> {x.messageId, x.cancelledAt})
1463+ yield {
1464+ presenceUpdates: pluck watchKeys (\k -> {
1465+ pubkey: k,
1466+ online: count (presenceForKey pres k t2) > 0
1467+ }),
1468+ expirations: myExp,
1469+ deliveries: myDel,
1470+ cancellations: myCancels
1471+ })
1472+ yield (respond {
1473+ pollResult.events,
1474+ pollResult.cursor,
1475+ authorized: True {},
1476+ rateLimited: False {},
1477+ draining: False {},
1478+ generation: serverGen,
1479+ extras.presenceUpdates,
1480+ heartbeat: count pollResult.events == 0,
1481+ retryAfterMs: 0,
1482+ cursorReset: cursorWasReset,
1483+ pollResult.hasMore,
1484+ cursorStale: False {},
1485+ messageExpirations: extras.expirations,
1486+ messageDeliveries: extras.deliveries,
1487+ droppedDeliveryReceipts: 0,
1488+ droppedExpirationNotifs: 0,
1489+ loadPct: 0,
1490+ messageCancellations: extras.cancellations
1491+ })
13591492
13601493-- One pass: collect events at `t`. If empty, retry-wait on `pollWakeup`
13611494-- (bumped by send/heartbeat) and re-collect once at the new wall time.
1362−doPoll : {pubkey: PubkeyHex, clampedCursor: Timestamp, startWakeup: Timestamp, pendingAcks: [AckedEntry]} -> Timestamp -> IO {} {events: [PollEvent], cursor: Timestamp, hasMore: Bool}
1495+doPoll : {clampedCursor: Int, pendingAcks: [AckedEntry], pubkey: PubkeyHex, startWakeup: Timestamp} -> Int<Ms> -> IO {reads *pollWakeup, clock} {cursor: Int<Ms>, events: [{eventType: Text, id: MessageIdHex, payload: {encryptedBlob: BlobHex, expiresAt: Timestamp, timestamp: Timestamp, toKey: PubkeyHex}}], hasMore: Bool}
13631496doPoll = \s t -> do
1364− let collectAt = \tnow -> atomic do
1497+ let collectAt = \tnow -> atomic (do
13651498 msgs <- *messages
1366− yield (collectPollEvents msgs s.pubkey s.clampedCursor tnow)
1499+ yield (collectPollEvents msgs s.pubkey s.clampedCursor tnow))
13671500 initial <- collectAt t
1368− if count initial.events > 0 then yield initial
1501+ if count initial.events > 0
1502+ then yield initial
13691503 else do
1370− atomic do
1371− wakeup <- *pollWakeup
1372− if wakeup > s.startWakeup then yield {} else retry
1504+ atomic (do wakeup <- *pollWakeup; if wakeup > s.startWakeup then yield {} else retry)
13731505 t2 <- now
13741506 collectAt t2
13751507
13761508-- Pull this pubkey's unexpired messages newer than `cursor`, sort by
13771509-- receivedAt, take up to `maxPollEvents`, and report `hasMore` if truncated.
13781510collectPollEvents : [Message] -> PubkeyHex -> Timestamp -> Timestamp -> {events: [PollEvent], cursor: Timestamp, hasMore: Bool}
1379−collectPollEvents = \messages pubkey cursor t ->
1380− let myMsgs = filter messages (\m -> m.toKey == pubkey && m.expiresAt > t && m.receivedAt > cursor) in
1381− let limited = takeRelation maxPollEvents (sortBy (\m -> m.receivedAt) myMsgs) in
1382− {events: pluck limited (\m -> {id: m.messageId, eventType: "message", payload: {toKey: m.toKey, encryptedBlob: m.encryptedBlob, timestamp: m.timestamp, expiresAt: m.expiresAt}}),
1383− cursor: fold (\acc m -> max acc m.receivedAt) cursor limited,
1384− hasMore: count myMsgs > count limited}
1511+collectPollEvents = \messages pubkey cursor t -> (\myMsgs -> (\limited -> {events: pluck limited (\m -> {id: m.messageId, eventType: "message", payload: {m.toKey, m.encryptedBlob, m.timestamp, m.expiresAt}}), cursor: fold (\acc m -> max acc m.receivedAt) cursor limited, hasMore: count myMsgs > count limited}) (takeRelation maxPollEvents (sortBy (\m -> m.receivedAt) myMsgs))) (filter messages (\m -> m.toKey == pubkey && m.expiresAt > t && m.receivedAt > cursor))
13851512
13861513-- Treat the supplied cursor as an ack: drop all messages with
13871514-- receivedAt <= cursor, plus their pending forwards, and record federated
13881515-- acks/sender deliveries via `recordAcksAndDeliveries`.
1389−ackPolledMessages : PubkeyHex -> Timestamp -> Timestamp -> IO {} [AckedEntry]
1516+ackPolledMessages : PubkeyHex -> Int -> Int<Ms> -> IO {reads *ackedIds, reads *forwards, reads *messages, reads *senderDeliveries, writes *ackedIds, writes *forwards, writes *messages, writes *senderDeliveries} [{ackedAt: Timestamp, messageId: MessageIdHex, originServer: ServerName, retries: Int, toKey: PubkeyHex}]
13901517ackPolledMessages = \pubkey cursor t -> do
13911518 msgs <- *messages
13921519 let matches = \m -> m.toKey == pubkey && m.receivedAt <= cursor
13931520 let toAck = filter msgs matches
13941521 let mids = pluck toAck (\m -> m.messageId)
1395− set *messages = removeWhere msgs matches
1522+ *messages = removeWhere msgs matches
13961523 fwds <- *forwards
1397− set *forwards = filter fwds (\f -> not (f.toKey == pubkey && elem mids f.messageId))
1524+ *forwards = filter fwds (\f -> not (f.toKey == pubkey && elem mids f.messageId))
13981525 recordAcksAndDeliveries toAck t
13991526
14001527-- ============================================
@@ -1412,26 +1539,32 @@ ackPolledMessages = \pubkey cursor t -> do
14121539-- POST /messages: send one ciphertext to `to`. Rejects on draining/rate
14131540-- limit/stale timestamp; otherwise calls `sendMessageCore` inside an atomic
14141541-- block and forks the federation forward (if any) once the local commit lands.
1415−handleSendMessage : PubkeyHex -> BlobHex -> Timestamp -> OptionalMessageId -> Int -> Int -> Text -> Text -> ({status: MessageStatus, messageId: OptionalMessageId, retryAfterMs: Int, error: Text, loadPct: Int} -> ret) -> IO {network} ret
1542+handleSendMessage : PubkeyHex -> BlobHex -> Int<Ms> -> OptionalMessageId -> Int -> Int -> Text -> Text -> ({error: Text, loadPct: Int, messageId: OptionalMessageId, retryAfterMs: Int, status: MessageStatus} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock, random} a
14161543handleSendMessage = \to encryptedBlob timestamp messageId expiresInMs priority authorization clientIp respond -> do
14171544 t <- now
14181545 dp <- *drainPhase
14191546 g <- checkGlobalRate t
14201547 effMsgId <- resolveMessageId messageId
14211548 let err = \s e -> yield (respond (sendErrResp s e))
1422− if dp >= 2 then err (MsDraining {}) "draining"
1423− else if g then err (MsRateLimited {}) "rate_limited"
1424− else if t - timestamp > messageMaxAge then err (MsRejected {}) "stale_timestamp"
1549+ if dp >= 2
1550+ then err (MsDraining {}) "draining"
1551+ else if g
1552+ then err (MsRateLimited {}) "rate_limited"
1553+ else if t - timestamp > messageMaxAge
1554+ then err (MsRejected {}) "stale_timestamp"
14251555 else do
14261556 let clampedTs = clampTimestamp timestamp t
1427− result <- atomic do
1428− withSessionAuth authorization t clientIp
1429− (yield {status: MsUnauthorized {}, remoteServers: []})
1430− (\senderKey -> sendMessageCore senderKey to encryptedBlob clampedTs effMsgId expiresInMs (clamp 0 maxMessagePriority priority) t)
1431− when federationEnabled
1432− (fork (forkForwardsTo effMsgId to encryptedBlob clampedTs result.remoteServers))
1557+ result <- atomic (do
1558+ withSessionAuth authorization t clientIp (yield {status: MsUnauthorized {}, remoteServers: []}) (\senderKey -> sendMessageCore senderKey to encryptedBlob clampedTs effMsgId expiresInMs (clamp 0 maxMessagePriority priority) t))
1559+ when federationEnabled (fork (forkForwardsTo effMsgId to encryptedBlob clampedTs result.remoteServers))
14331560 let ok = isSendSuccess result.status
1434− yield (respond {status: result.status, messageId: if ok then effMsgId else "", retryAfterMs: 0, error: if ok then "" else "rejected", loadPct: 0})
1561+ yield (respond {
1562+ result.status,
1563+ messageId: if ok then effMsgId else "",
1564+ retryAfterMs: 0,
1565+ error: if ok then "" else "rejected",
1566+ loadPct: 0
1567+ })
14351568
14361569-- Atomic core of /messages and /messages/batch. Charges send/pair/recv rate
14371570-- counters together (so any limit denies the message), enforces caps and
@@ -1439,73 +1572,113 @@ handleSendMessage = \to encryptedBlob timestamp messageId expiresInMs priority a
14391572-- `seqCounter`, appends the message, and pre-stages forwards for any remote
14401573-- presence rows that already exist for `to`. Returns the chosen status and
14411574-- the list of remote servers the caller should kick forwards to.
1442−sendMessageCore : PubkeyHex -> PubkeyHex -> BlobHex -> Timestamp -> OptionalMessageId -> Int -> Int -> Timestamp -> IO {} {status: MessageStatus, remoteServers: [Text]}
1575+sendMessageCore : PubkeyHex -> PubkeyHex -> BlobHex -> Int<Ms> -> OptionalMessageId -> Int -> Int -> Int<Ms> -> IO {reads *ackedIds, reads *deliveredIds, reads *forwards, reads *messages, reads *pairRates, reads *pollWakeup, reads *presence, reads *recvRates, reads *sendRates, reads *seqCounter, writes *forwards, writes *messages, writes *pairRates, writes *pollWakeup, writes *recvRates, writes *sendRates, writes *seqCounter} {remoteServers: [Text], status: MessageStatus}
14431576sendMessageCore = \senderKey to encryptedBlob clampedTs effMsgId expiresInMs msgPriority t -> do
14441577 msgs <- *messages
14451578 aids <- *ackedIds
14461579 dids <- *deliveredIds
14471580 sRates <- *sendRates
14481581 let sR = checkRate sRates senderKey maxSendRatePerKey sendRateWindowMs t
1449− set *sendRates = sR.entries
1582+ replace *sendRates = sR.entries
14501583 let srLim = sR.limited
14511584 pRates <- *pairRates
14521585 let pR = checkRate pRates (senderKey ++ "|" ++ to) maxPairRatePerPair pairRateWindowMs t
1453− set *pairRates = pR.entries
1586+ replace *pairRates = pR.entries
14541587 let prLim = pR.limited
14551588 rRates <- *recvRates
14561589 let rR = checkRate rRates to maxRecvRatePerKey recvRateWindowMs t
1457− set *recvRates = rR.entries
1590+ replace *recvRates = rR.entries
14581591 let rrLim = rR.limited
14591592 let reject = \s -> yield {status: s, remoteServers: []}
1460− if senderKey == to then reject (MsRejected {})
1461− else if isDuplicateMessage effMsgId to msgs aids dids then reject (MsDuplicate {})
1462− else if srLim || prLim || rrLim then reject (MsRateLimited {})
1463− else if count msgs >= maxMessages then reject (MsRejected {})
1464− else if countWhere msgs (\m -> m.toKey == to) >= maxMessagesPerRecipient then reject (MsQueued {})
1593+ if senderKey == to
1594+ then reject (MsRejected {})
1595+ else if isDuplicateMessage effMsgId to msgs aids dids
1596+ then reject (MsDuplicate {})
1597+ else if srLim || prLim || rrLim
1598+ then reject (MsRateLimited {})
1599+ else if count msgs >= maxMessages
1600+ then reject (MsRejected {})
1601+ else if countWhere msgs (\m -> m.toKey == to) >= maxMessagesPerRecipient
1602+ then reject (MsQueued {})
14651603 else do
14661604 pres <- *presence
14671605 seq <- *seqCounter
14681606 let seqTs = nextSeqTs t seq
1469− set *seqCounter = seqTs
1607+ *seqCounter = seqTs
14701608 let expiresAt = seqTs + effectiveMessageTtl expiresInMs
1471− set *messages = union msgs [{messageId: effMsgId, toKey: to, encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs, expiresAt: expiresAt, senderKey: senderKey, priority: msgPriority}]
1472− set *pollWakeup = seqTs
1609+ *messages = union msgs [
1610+ {
1611+ messageId: effMsgId,
1612+ toKey: to,
1613+ encryptedBlob,
1614+ timestamp: clampedTs,
1615+ originServer: "",
1616+ receivedAt: seqTs,
1617+ expiresAt,
1618+ senderKey,
1619+ priority: msgPriority
1620+ }
1621+ ]
1622+ *pollWakeup = seqTs
14731623 let toPresence = presenceForKey pres to t
14741624 let remoteServers = collectPeers toPresence (\p -> p.server)
1475− forwardsEnqueued <- if federationEnabled then do
1476− fwds <- *forwards
1477− let newFwds = mapWhere remoteServers (\s -> none fwds (\f -> f.messageId == effMsgId && f.toServer == s)) (\s -> {messageId: effMsgId, toServer: s, createdAt: t, toKey: to, encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: serverHostN, retries: 0, expiresAt: expiresAt, priority: msgPriority, senderKey: senderKey})
1478− set *forwards = capList (union fwds newFwds) maxForwardsEntries (\f -> f.createdAt)
1479− yield (count newFwds > 0)
1480− else yield False {}
1481− yield {status: if any toPresence (\p -> isLocalServer p.server) then MsDelivered {} else if forwardsEnqueued then MsFederated {} else MsQueued {}, remoteServers: remoteServers}
1625+ forwardsEnqueued <- if federationEnabled
1626+ then do
1627+ fwds <- *forwards
1628+ let newFwds = mapWhere remoteServers (\s -> none fwds (\f -> f.messageId == effMsgId && f.toServer == s)) (\s -> {
1629+ messageId: effMsgId,
1630+ toServer: s,
1631+ createdAt: t,
1632+ toKey: to,
1633+ encryptedBlob,
1634+ timestamp: clampedTs,
1635+ originServer: serverHostN,
1636+ retries: 0,
1637+ expiresAt,
1638+ priority: msgPriority,
1639+ senderKey
1640+ })
1641+ *forwards = capList (union fwds newFwds) maxForwardsEntries (\f -> f.createdAt)
1642+ yield (count newFwds > 0)
1643+ else yield (False {})
1644+ yield {
1645+ status: if any toPresence (\p -> isLocalServer p.server)
1646+ then MsDelivered {}
1647+ else if forwardsEnqueued then MsFederated {} else MsQueued {},
1648+ remoteServers
1649+ }
14821650
14831651-- Fire one /federation/forward call per pre-staged server. On success the
14841652-- corresponding row in `forwards` is pruned (no retry needed); on failure
14851653-- it stays so `retryPendingForwards` can re-attempt with backoff.
1486−forkForwardsTo : OptionalMessageId -> PubkeyHex -> BlobHex -> Timestamp -> [Text] -> IO {network} {}
1487−forkForwardsTo = \effMsgId to encryptedBlob clampedTs servers ->
1488− forEach servers (\server -> do
1489− fwds <- *forwards
1490− let same = \x -> x.messageId == effMsgId && x.toServer == server
1491− case findFirst fwds same of
1492− Nothing {} -> yield {}
1493− Just {value: f} -> do
1494− t <- now
1495− auth <- generateFederationAuth ("forward:" ++ effMsgId) t
1496− result <- fetch (federationUrl server) (ForwardMessage {
1497− toKey: to, encryptedBlob: encryptedBlob,
1498− timestamp: clampedTs, originServer: serverHostN, messageId: effMsgId,
1499− fromServer: serverHostN, requestTimestamp: t,
1500− authorization: auth, correlationId: "",
1501− expiresAt: f.expiresAt, priority: f.priority, protocolVersion: federationProtocolVersion})
1502− case result of
1503− Err _ -> recordFailure server
1504− Ok {value: r} -> when r.ok (do
1505− clearFailure server
1506− atomic do
1507− fwds2 <- *forwards
1508− set *forwards = filter fwds2 (\x -> not (same x))))
1654+forkForwardsTo : OptionalMessageId -> PubkeyHex -> BlobHex -> Int<Ms> -> [Text] -> IO {} {}
1655+forkForwardsTo = \effMsgId to encryptedBlob clampedTs servers -> forEach servers (\server -> do
1656+ fwds <- *forwards
1657+ let same = \x -> x.messageId == effMsgId && x.toServer == server
1658+ case findFirst fwds same of
1659+ Nothing {} -> yield {}
1660+ Just {value: f} -> do
1661+ t <- now
1662+ auth <- generateFederationAuth ("forward:" ++ effMsgId) t
1663+ result <- fetch (federationUrl server) (ForwardMessage {
1664+ toKey: to,
1665+ encryptedBlob,
1666+ timestamp: clampedTs,
1667+ originServer: serverHostN,
1668+ messageId: effMsgId,
1669+ fromServer: serverHostN,
1670+ requestTimestamp: t,
1671+ authorization: auth,
1672+ correlationId: "",
1673+ f.expiresAt,
1674+ f.priority,
1675+ protocolVersion: federationProtocolVersion
1676+ })
1677+ case result of
1678+ Err _ -> recordFailure server
1679+ Ok {value: r} -> when r.ok (do
1680+ clearFailure server
1681+ atomic (do fwds2 <- *forwards; *forwards = filter fwds2 (\x -> not same x))))
15091682
15101683-- ============================================
15111684-- Handler: lookup
@@ -1517,31 +1690,41 @@ forkForwardsTo = \effMsgId to encryptedBlob clampedTs servers ->
15171690-- GET /lookup/{pubkey}: return our local server name if the key is here,
15181691-- "remote" if known on a peer, "" otherwise. Peer hostnames are deliberately
15191692-- masked (see section header).
1520−handleLookupPresence : PubkeyHex -> Text -> Text -> ({server: AnyServerName, authorized: Bool, error: Text} -> ret) -> IO {} ret
1693+handleLookupPresence : PubkeyHex -> Text -> Text -> ({authorized: Bool, error: Text, server: Text} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} a
15211694handleLookupPresence = \pubkey authorization clientIp respond -> do
15221695 t <- now
15231696 let mkErr = \e -> {server: "", authorized: False {}, error: if e == "rate_limited" then e else ""}
1524− gateLookup authorization clientIp t respond mkErr
1525− {server: "", authorized: True {}, error: "rate_limited"} (\_ -> do
1526− pres <- *presence
1527− yield (respond {server: maskedServer pres pubkey t, authorized: True {}, error: ""}))
1697+ gateLookup authorization clientIp t respond mkErr {
1698+ server: "",
1699+ authorized: True {},
1700+ error: "rate_limited"
1701+ } (\_ -> do
1702+ pres <- *presence
1703+ yield (respond {server: maskedServer pres pubkey t, authorized: True {}, error: ""}))
15281704
15291705-- POST /lookup/batch: same masking as `handleLookupPresence`, but for up to
15301706-- 50 pubkeys in one round-trip.
1531−handleBatchLookupPresence : [PubkeyHex] -> Text -> Text -> ({results: [{pubkey: PubkeyHex, server: AnyServerName}], authorized: Bool, error: Text} -> ret) -> IO {} ret
1707+handleBatchLookupPresence : [PubkeyHex] -> Text -> Text -> ({authorized: Bool, error: Text, results: [{pubkey: PubkeyHex, server: Text}]} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} a
15321708handleBatchLookupPresence = \pubkeys authorization clientIp respond -> do
15331709 t <- now
1534− let mkErr = \e -> {results: [], authorized: False {}, error: if e == "rate_limited" then e else ""}
1535− gateLookup authorization clientIp t respond mkErr
1536− {results: [], authorized: True {}, error: "rate_limited"} (\_ -> do
1537− pres <- *presence
1538− let results = pluck (takeRelation 50 pubkeys) (\k -> {pubkey: k, server: maskedServer pres k t})
1539− yield (respond {results: results, authorized: True {}, error: ""}))
1710+ let mkErr = \e -> {
1711+ results: [],
1712+ authorized: False {},
1713+ error: if e == "rate_limited" then e else ""
1714+ }
1715+ gateLookup authorization clientIp t respond mkErr {
1716+ results: [],
1717+ authorized: True {},
1718+ error: "rate_limited"
1719+ } (\_ -> do
1720+ pres <- *presence
1721+ let results = pluck (takeRelation 50 pubkeys) (\k -> {pubkey: k, server: maskedServer pres k t})
1722+ yield (respond {results, authorized: True {}, error: ""}))
15401723
15411724-- POST /messages/status: classify a message as
15421725-- pending (in mailbox), forwarding (en-route to a peer),
15431726-- delivered (acked or terminal), or unknown.
1544−handleMessageStatus : PubkeyHex -> MessageIdHex -> Text -> Text -> ({status: Text, authorized: Bool} -> ret) -> IO {} ret
1727+handleMessageStatus : PubkeyHex -> MessageIdHex -> Text -> Text -> ({authorized: Bool, status: Text} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} a
15451728handleMessageStatus = \to messageId authorization clientIp respond -> do
15461729 t <- now
15471730 let mkErr = \_ -> {status: "", authorized: False {}}
@@ -1551,10 +1734,11 @@ handleMessageStatus = \to messageId authorization clientIp respond -> do
15511734 aids <- *ackedIds
15521735 dids <- *deliveredIds
15531736 let matches = \x -> x.messageId == messageId && x.toKey == to
1554− let s = if any msgs matches then "pending"
1555− else if any fwds matches then "forwarding"
1556− else if any aids matches || any dids matches then "delivered"
1557− else "unknown"
1737+ let s = if any msgs matches
1738+ then "pending"
1739+ else if any fwds matches
1740+ then "forwarding"
1741+ else if any aids matches || any dids matches then "delivered" else "unknown"
15581742 yield (respond {status: s, authorized: True {}}))
15591743
15601744-- ============================================
@@ -1568,109 +1752,153 @@ handleMessageStatus = \to messageId authorization clientIp respond -> do
15681752-- POST /messages/ack: explicit ack by message id (alternative to the implicit
15691753-- cursor-based ack in /poll). Drops mailbox+forward rows and forks federation
15701754-- ack flush for any messages that originated remotely.
1571−handleAckMessages : [MessageIdHex] -> Text -> Text -> ({ok: Bool, authorized: Bool, ackedCount: Int, error: Text} -> ret) -> IO {network} ret
1755+handleAckMessages : [MessageIdHex] -> Text -> Text -> ({ackedCount: Int, authorized: Bool, error: Text, ok: Bool} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} a
15721756handleAckMessages = \messageIds authorization clientIp respond -> do
15731757 t <- now
15741758 let mkErr = \e -> {ok: False {}, authorized: False {}, ackedCount: 0, error: e}
1575− gateClientWrite authorization clientIp t respond mkErr
1576− {ok: False {}, authorized: True {}, ackedCount: 0, error: "rate_limited"} (\pubkey -> do
1577− result <- atomic do
1578− toAck <- removeForKey (\x -> x.toKey == pubkey && elem (dedupMessageIds messageIds) x.messageId)
1579− ackedFed <- recordAcksAndDeliveries toAck t
1580− yield {ackedCount: count toAck, pendingAcks: ackedFed}
1581− when federationEnabled (fork (sendAcksAndClean result.pendingAcks))
1582− yield (respond {ok: True {}, authorized: True {}, ackedCount: result.ackedCount, error: ""}))
1759+ gateClientWrite authorization clientIp t respond mkErr {
1760+ ok: False {},
1761+ authorized: True {},
1762+ ackedCount: 0,
1763+ error: "rate_limited"
1764+ } (\pubkey -> do
1765+ result <- atomic (do
1766+ toAck <- removeForKey (\x -> x.toKey == pubkey && elem (dedupMessageIds messageIds) x.messageId)
1767+ ackedFed <- recordAcksAndDeliveries toAck t
1768+ yield {ackedCount: count toAck, pendingAcks: ackedFed})
1769+ when federationEnabled (fork (sendAcksAndClean result.pendingAcks))
1770+ yield (respond {ok: True {}, authorized: True {}, result.ackedCount, error: ""}))
15831771
15841772-- POST /messages/list: paginated peek at the caller's mailbox without acking.
15851773-- Returns metadata only (no ciphertext) plus the total count.
1586−handleListMessages : Int -> Text -> Text -> ({messages: [{messageId: MessageIdHex, timestamp: Timestamp, receivedAt: Timestamp}], authorized: Bool, count: Int, error: Text} -> ret) -> IO {} ret
1774+handleListMessages : Int -> Text -> Text -> ({authorized: Bool, count: Int, error: Text, messages: [{messageId: MessageIdHex, receivedAt: Int<Ms>, timestamp: Int<Ms>}]} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} a
15871775handleListMessages = \offset authorization clientIp respond -> do
15881776 t <- now
1589− let mkErr = \e -> {messages: [], authorized: False {}, count: 0, error: if e == "rate_limited" then e else ""}
1777+ let mkErr = \e -> {
1778+ messages: [],
1779+ authorized: False {},
1780+ count: 0,
1781+ error: if e == "rate_limited" then e else ""
1782+ }
15901783 gateAuth (True {}) authorization clientIp t respond mkErr (\pubkey -> do
1591− lim <- atomic do
1784+ lim <- atomic (do
15921785 rates <- *lookupRates
15931786 let r = checkRate rates pubkey maxLookupRatePerKey lookupRateWindowMs t
1594− set *lookupRates = r.entries
1595− yield r.limited
1596− if lim then yield (respond {messages: [], authorized: True {}, count: 0, error: "rate_limited"})
1787+ replace *lookupRates = r.entries
1788+ yield r.limited)
1789+ if lim
1790+ then yield (respond {messages: [], authorized: True {}, count: 0, error: "rate_limited"})
15971791 else do
15981792 msgs <- *messages
15991793 let myMsgs = sortBy (\m -> m.receivedAt) (filter msgs (\m -> m.toKey == pubkey && m.expiresAt > t))
16001794 let total = count myMsgs
1601− let page = pluck (takeRelation maxPollEvents (dropRelation (clamp 0 total offset) myMsgs)) (\m -> {messageId: m.messageId, timestamp: m.timestamp, receivedAt: m.receivedAt})
1795+ let page = pluck (takeRelation maxPollEvents (dropRelation (clamp 0 total offset) myMsgs)) (\m -> {
1796+ m.messageId,
1797+ m.timestamp,
1798+ m.receivedAt
1799+ })
16021800 yield (respond {messages: page, authorized: True {}, count: total, error: ""}))
16031801
16041802-- POST /messages/delete: same effect as ack from the recipient's side, with
16051803-- a "delete" semantic for the response.
1606−handleDeleteMessages : [MessageIdHex] -> Text -> Text -> ({ok: Bool, authorized: Bool, deletedCount: Int, error: Text} -> ret) -> IO {network} ret
1804+handleDeleteMessages : [MessageIdHex] -> Text -> Text -> ({authorized: Bool, deletedCount: Int, error: Text, ok: Bool} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} a
16071805handleDeleteMessages = \messageIds authorization clientIp respond -> do
16081806 t <- now
1609− let mkErr = \e -> {ok: False {}, authorized: False {}, deletedCount: 0, error: if e == "draining" then "" else e}
1610− gateClientWrite authorization clientIp t respond mkErr
1611− {ok: False {}, authorized: True {}, deletedCount: 0, error: "rate_limited"} (\pubkey -> do
1612− result <- atomic do
1613− toDel <- removeForKey (\x -> x.toKey == pubkey && elem (dedupMessageIds messageIds) x.messageId)
1614− let ackedFed = mapWhere toDel (\m -> m.originServer != "") (\m -> mkAckedEntry m t)
1615− aids <- *ackedIds
1616− set *ackedIds = capList (union aids ackedFed) maxAckedIds (\a -> a.ackedAt)
1617− yield {deletedCount: count toDel, pendingAcks: ackedFed}
1618− when federationEnabled (fork (sendAcksAndClean result.pendingAcks))
1619− yield (respond {ok: True {}, authorized: True {}, deletedCount: result.deletedCount, error: ""}))
1807+ let mkErr = \e -> {
1808+ ok: False {},
1809+ authorized: False {},
1810+ deletedCount: 0,
1811+ error: if e == "draining" then "" else e
1812+ }
1813+ gateClientWrite authorization clientIp t respond mkErr {
1814+ ok: False {},
1815+ authorized: True {},
1816+ deletedCount: 0,
1817+ error: "rate_limited"
1818+ } (\pubkey -> do
1819+ result <- atomic (do
1820+ toDel <- removeForKey (\x -> x.toKey == pubkey && elem (dedupMessageIds messageIds) x.messageId)
1821+ let ackedFed = mapWhere toDel (\m -> m.originServer != "") (\m -> mkAckedEntry m t)
1822+ aids <- *ackedIds
1823+ *ackedIds = capList (union aids ackedFed) maxAckedIds (\a -> a.ackedAt)
1824+ yield {deletedCount: count toDel, pendingAcks: ackedFed})
1825+ when federationEnabled (fork (sendAcksAndClean result.pendingAcks))
1826+ yield (respond {ok: True {}, authorized: True {}, result.deletedCount, error: ""}))
16201827
16211828-- POST /messages/cancel: sender-side recall. Only succeeds while the message
16221829-- is still locally undelivered AND was sent by this caller; if it had already
16231830-- been forwarded to peers, federation cancels are dispatched in a fork.
1624−handleCancelMessage : MessageIdHex -> PubkeyHex -> Text -> Text -> ({ok: Bool, authorized: Bool, cancelled: Bool, error: Text} -> ret) -> IO {network} ret
1831+handleCancelMessage : MessageIdHex -> PubkeyHex -> Text -> Text -> ({authorized: Bool, cancelled: Bool, error: Text, ok: Bool} -> a) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} a
16251832handleCancelMessage = \messageId to authorization clientIp respond -> do
16261833 t <- now
1627− let mkErr = \e -> {ok: False {}, authorized: False {}, cancelled: False {}, error: if e == "draining" then "" else e}
1628− gateClientWrite authorization clientIp t respond mkErr
1629− {ok: False {}, authorized: True {}, cancelled: False {}, error: "rate_limited"} (\senderKey -> do
1630− let matches = \x -> x.messageId == messageId && x.toKey == to
1631− result <- atomic do
1632− msgs <- *messages
1633− if any msgs (\m -> matches m && m.originServer == "" && m.senderKey == senderKey) then do
1634− fwdServers <- applyCancel msgs matches to messageId t
1635− pres <- *presence
1636− yield {cancelled: True {}, cancelServers: unique (union (collectPeers (presenceForKey pres to t) (\p -> p.server)) fwdServers)}
1637− else yield {cancelled: False {}, cancelServers: []}
1638− when (result.cancelled && federationEnabled)
1639− (fork (sendCancelToEach messageId to result.cancelServers))
1640− yield (respond {ok: True {}, authorized: True {}, cancelled: result.cancelled, error: ""}))
1834+ let mkErr = \e -> {
1835+ ok: False {},
1836+ authorized: False {},
1837+ cancelled: False {},
1838+ error: if e == "draining" then "" else e
1839+ }
1840+ gateClientWrite authorization clientIp t respond mkErr {
1841+ ok: False {},
1842+ authorized: True {},
1843+ cancelled: False {},
1844+ error: "rate_limited"
1845+ } (\senderKey -> do
1846+ let matches = \x -> x.messageId == messageId && x.toKey == to
1847+ result <- atomic (do
1848+ msgs <- *messages
1849+ if any msgs (\m -> matches m && m.originServer == "" && m.senderKey == senderKey)
1850+ then do
1851+ fwdServers <- applyCancel matches to messageId t
1852+ pres <- *presence
1853+ yield {
1854+ cancelled: True {},
1855+ cancelServers: unique (union (collectPeers (presenceForKey pres to t) (\p -> p.server)) fwdServers)
1856+ }
1857+ else yield {cancelled: False {}, cancelServers: []})
1858+ when (result.cancelled && federationEnabled) (fork (sendCancelToEach messageId to result.cancelServers))
1859+ yield (respond {ok: True {}, authorized: True {}, result.cancelled, error: ""}))
16411860
16421861-- Best-effort federation cancel; on failure the cancel is queued in
16431862-- `pendingFederationCancels` so a later background pass can retry it.
1644−sendCancelToEach : MessageIdHex -> PubkeyHex -> [Text] -> IO {network} {}
1645−sendCancelToEach = \messageId to servers ->
1646− forEach servers (\server -> do
1647− t <- now
1648− auth <- generateFederationAuth ("cancel:" ++ messageId) t
1649− result <- fetch (federationUrl server) (FederationCancel {
1650− messageId: messageId, toKey: to, fromServer: serverHostN,
1651− requestTimestamp: t, correlationId: "", authorization: auth,
1652− protocolVersion: federationProtocolVersion})
1653− when (case result of Err _ -> True {}; Ok {value: r} -> not r.ok) (atomic do
1654− cur <- *pendingFederationCancels
1655− set *pendingFederationCancels = capList (union cur [{messageId: messageId, toKey: to, toServer: server, createdAt: t, retries: 0}]) 10000 (\c -> c.createdAt)))
1863+sendCancelToEach : MessageIdHex -> PubkeyHex -> [Text] -> IO {} {}
1864+sendCancelToEach = \messageId to servers -> forEach servers (\server -> do
1865+ t <- now
1866+ auth <- generateFederationAuth ("cancel:" ++ messageId) t
1867+ result <- fetch (federationUrl server) (FederationCancel {
1868+ messageId,
1869+ toKey: to,
1870+ fromServer: serverHostN,
1871+ requestTimestamp: t,
1872+ correlationId: "",
1873+ authorization: auth,
1874+ protocolVersion: federationProtocolVersion
1875+ })
1876+ when (case result of; Err _ -> True {}; Ok {value: r} -> not r.ok) (atomic (do
1877+ cur <- *pendingFederationCancels
1878+ *pendingFederationCancels = capList (union cur [
1879+ {messageId, toKey: to, toServer: server, createdAt: t, retries: 0}
1880+ ]) 10000 (\c -> c.createdAt))))
16561881
16571882-- POST /messages/cancel-batch: multi-id sender-side cancel. Same ownership
16581883-- check as `handleCancelMessage`, applied independently per entry.
1659−handleCancelBatch : [BatchCancelEntry] -> Text -> Text -> ({results: [BatchCancelResult], authorized: Bool, error: Text} -> ret) -> IO {} ret
1884+handleCancelBatch : [{messageId: MessageIdHex, to: PubkeyHex | a}] -> Text -> Text -> ({authorized: Bool, error: Text, results: [{cancelled: Bool, messageId: MessageIdHex}]} -> b) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} b
16601885handleCancelBatch = \cancels authorization clientIp respond -> do
16611886 t <- now
16621887 let mkErr = \e -> {results: [], authorized: False {}, error: if e == "draining" then "" else e}
1663− gateClientWrite authorization clientIp t respond mkErr
1664− {results: [], authorized: True {}, error: "rate_limited"} (\senderKey -> do
1665− results <- mapEach (takeRelation maxBatchSize cancels) (\e -> do
1666− r <- cancelOne e.messageId e.to (\m -> m.originServer == "" && m.senderKey == senderKey) t
1667− yield {messageId: e.messageId, cancelled: r})
1668− yield (respond {results: results, authorized: True {}, error: ""}))
1888+ gateClientWrite authorization clientIp t respond mkErr {
1889+ results: [],
1890+ authorized: True {},
1891+ error: "rate_limited"
1892+ } (\senderKey -> do
1893+ results <- mapEach (takeRelation maxBatchSize cancels) (\e -> do
1894+ r <- cancelOne e.messageId e.to (\m -> m.originServer == "" && m.senderKey == senderKey) t
1895+ yield {e.messageId, cancelled: r})
1896+ yield (respond {results, authorized: True {}, error: ""}))
16691897
16701898-- POST /messages/batch: multi-recipient send in one call. Each entry runs
16711899-- through `sendMessageCore` separately so per-entry rate limits/errors don't
16721900-- abort the rest; federated forwards are forked per entry.
1673−handleSendBatch : [BatchMessage] -> Text -> Text -> ({results: [BatchResult], authorized: Bool, retryAfterMs: Int} -> ret) -> IO {network} ret
1901+handleSendBatch : [{encryptedBlob: BlobHex, expiresInMs: Int, messageId: OptionalMessageId, priority: Int, timestamp: Int<Ms>, to: PubkeyHex | a}] -> Text -> Text -> ({authorized: Bool, results: [{messageId: OptionalMessageId, status: MessageStatus}], retryAfterMs: Int} -> b) -> IO {reads *drainPhase, reads *globalRateCount, reads *globalRateWindowStart, reads *sessions, writes *globalRateCount, writes *globalRateWindowStart, clock} b
16741902handleSendBatch = \messages authorization clientIp respond -> do
16751903 t <- now
16761904 let mkErr = \_ -> {results: [], authorized: False {}, retryAfterMs: 0}
@@ -1679,12 +1907,12 @@ handleSendBatch = \messages authorization clientIp respond -> do
16791907 effMsgId <- resolveMessageId m.messageId
16801908 let clampedTs = clampTimestamp m.timestamp t
16811909 r <- if t - m.timestamp > messageMaxAge
1682− then yield {status: MsRejected {}, remoteServers: []}
1683− else atomic do sendMessageCore senderKey m.to m.encryptedBlob clampedTs effMsgId m.expiresInMs (clamp 0 maxMessagePriority m.priority) t
1684− when federationEnabled
1685− (fork (forkForwardsTo effMsgId m.to m.encryptedBlob clampedTs r.remoteServers))
1686− yield {messageId: effMsgId, status: r.status})
1687− yield (respond {results: results, authorized: True {}, retryAfterMs: 0}))
1910+ then yield {status: MsRejected {}, remoteServers: []}
1911+ else atomic (do
1912+ sendMessageCore senderKey m.to m.encryptedBlob clampedTs effMsgId m.expiresInMs (clamp 0 maxMessagePriority m.priority) t)
1913+ when federationEnabled (fork (forkForwardsTo effMsgId m.to m.encryptedBlob clampedTs r.remoteServers))
1914+ yield {messageId: effMsgId, r.status})
1915+ yield (respond {results, authorized: True {}, retryAfterMs: 0}))
16881916
16891917-- ============================================
16901918-- Handler: federation receive
@@ -1699,19 +1927,20 @@ handleSendBatch = \messages authorization clientIp respond -> do
16991927-- POST /federation/verify: callback endpoint a peer invokes to validate a
17001928-- Bearer token we issued in `generateFederationAuth`. Single-use: a
17011929-- successful match removes the token from `pendingVerifications`.
1702−handleVerifyToken : Text -> Text -> Text -> ({ok: Bool} -> ret) -> IO {} ret
1930+handleVerifyToken : Text -> Text -> Text -> ({ok: Bool} -> a) -> IO {reads *globalRateCount, reads *globalRateWindowStart, reads *ipRates, reads *pendingVerifications, writes *globalRateCount, writes *globalRateWindowStart, writes *ipRates, clock, writes *pendingVerifications} a
17031931handleVerifyToken = \token scope clientIp respond -> do
17041932 t <- now
17051933 g <- checkGlobalRate t
17061934 ipLim <- checkIpRateGate clientIp t
1707− if scope == "" || g || ipLim then yield (respond {ok: False {}})
1935+ if scope == "" || g || ipLim
1936+ then yield (respond {ok: False {}})
17081937 else do
1709− found <- atomic do
1938+ found <- atomic (do
17101939 pending <- *pendingVerifications
17111940 let same = \p -> p.scope == scope && p.token == token
17121941 let match = any pending (\p -> same p && t - p.createdAt < verificationTokenExpiry)
1713− when match (set *pendingVerifications = removeWhere pending same)
1714− yield match
1942+ when match *pendingVerifications = removeWhere pending same
1943+ yield match)
17151944 yield (respond {ok: found})
17161945
17171946-- GET /federation/pubkey: publish the Ed25519 public key peers should use to
@@ -1726,163 +1955,203 @@ handleFederationPubkey = \respond -> do
17261955-- skew tolerance, applies last-write-wins merge per (pubkey, server), and
17271956-- — for keys that became newly online — flushes any locally-buffered messages
17281957-- for them via `forwardQueuedToServer` (the catch-up path).
1729−handleRecvGossip : [GossipEvent] -> Int -> ServerName -> Timestamp -> Text -> ({ok: Bool, error: Text, retryAfterMs: Int} -> ret) -> IO {network} ret
1958+handleRecvGossip : [{eventType: <GossipOffline {} | GossipOnline {} | a>, pubkey: PubkeyHex, server: Text, timestamp: Int<Ms>, ttl: Int<Ms> | b}] -> Int -> Text -> Int -> Text -> ({error: Text, ok: Bool, retryAfterMs: Int} -> c) -> IO {reads *allowedPeers, reads *blockedPeers, reads *federationRates, writes *federationRates, clock, reads *presence, writes *presence, network} c
17301959handleRecvGossip = \events hopsRemaining fromServer requestTimestamp authorization respond -> do
17311960 t <- now
17321961 withFederationAuth authorization t respond fromServer "gossip" requestTimestamp (clamp 0 maxGossipHops hopsRemaining >= 1 && isRemote fromServer && count events <= maxGossipEvents) (do
1733− newlyOnline <- atomic do
1962+ newlyOnline <- atomic (do
17341963 pres <- *presence
17351964 let validEvents = do
17361965 e <- events
17371966 where isRemote e.server && e.timestamp <= t + clockSkewTolerance
17381967 let expiresAt = min e.timestamp t + clampTtl e.ttl * 1000
17391968 where expiresAt > t
1740− yield {pubkey: e.pubkey, server: e.server, expiresAt: expiresAt, timestamp: e.timestamp, eventType: e.eventType}
1741− let isOnline = \v -> case v.eventType of GossipOnline {} -> True {}; _ -> False {}
1742− let isOffline = \v -> case v.eventType of GossipOffline {} -> True {}; _ -> False {}
1743− let online = mapWhere validEvents isOnline (\v -> {pubkey: v.pubkey, server: v.server, expiresAt: v.expiresAt, timestamp: v.timestamp})
1744− let offline = mapWhere validEvents isOffline (\v -> {pubkey: v.pubkey, server: v.server, timestamp: v.timestamp})
1745− set *presence = capList (mergePresence (filter pres (\p -> none offline (\o -> o.pubkey == p.pubkey && o.server == p.server && o.timestamp > p.timestamp))) online) maxPresenceEntries (\p -> p.expiresAt)
1746− yield (mapWhere online (\e -> none pres (\p -> p.pubkey == e.pubkey && p.server == e.server && p.expiresAt >= e.expiresAt)) (\e -> {pubkey: e.pubkey, server: e.server}))
1969+ yield {e.pubkey, e.server, expiresAt, e.timestamp, e.eventType}
1970+ let isOnline = \v -> case v.eventType of
1971+ GossipOnline {} -> True {}
1972+ _ -> False {}
1973+ let isOffline = \v -> case v.eventType of
1974+ GossipOffline {} -> True {}
1975+ _ -> False {}
1976+ let online = mapWhere validEvents isOnline (\v -> {
1977+ v.pubkey,
1978+ v.server,
1979+ v.expiresAt,
1980+ v.timestamp
1981+ })
1982+ let offline = mapWhere validEvents isOffline (\v -> {v.pubkey, v.server, v.timestamp})
1983+ *presence = capList (mergePresence (filter pres (\p -> none offline (\o -> o.pubkey == p.pubkey && o.server == p.server && o.timestamp > p.timestamp))) online) maxPresenceEntries (\p -> p.expiresAt)
1984+ yield (mapWhere online (\e -> none pres (\p -> p.pubkey == e.pubkey && p.server == e.server && p.expiresAt >= e.expiresAt)) (\e -> {
1985+ e.pubkey,
1986+ e.server
1987+ })))
17471988 fork (forEach newlyOnline (\tgt -> forwardQueuedToServer tgt.pubkey tgt.server t))
17481989 yield (respond {ok: True {}, error: "", retryAfterMs: 0}))
17491990
17501991-- Store a federated/forwarded message into the local mailbox. Caller wraps in `atomic`.
17511992-- Returns "" on success (including duplicates), otherwise an error code:
17521993-- "no_presence" | "global_full" | "mailbox_full" | "rate_limited" (only when checkRecvRate).
1753−storeFederated : PubkeyHex -> BlobHex -> Timestamp -> ServerName -> MessageIdHex -> Timestamp -> Int -> Bool -> Timestamp -> IO {} Text
1994+storeFederated : PubkeyHex -> BlobHex -> Int<Ms> -> Text -> MessageIdHex -> Int<Ms> -> Int -> Bool -> Int<Ms> -> IO {reads *ackedIds, reads *deliveredIds, reads *messages, reads *pollWakeup, reads *presence, reads *recvRates, reads *seqCounter, writes *messages, writes *pollWakeup, writes *recvRates, writes *seqCounter} Text
17541995storeFederated = \toKey encryptedBlob timestamp originServer messageId expiresAt priority checkRecvRate t -> do
17551996 pres <- *presence
17561997 msgs <- *messages
17571998 aids <- *ackedIds
17581999 dids <- *deliveredIds
1759− if not (any pres (\p -> p.pubkey == toKey && p.expiresAt > t)) then yield "no_presence"
1760− else if isDuplicateMessage messageId toKey msgs aids dids then yield ""
1761− else if count msgs >= maxMessages then yield "global_full"
1762− else if countWhere msgs (\m -> m.toKey == toKey) >= maxMessagesPerRecipient then yield "mailbox_full"
2000+ if not any pres (\p -> p.pubkey == toKey && p.expiresAt > t)
2001+ then yield "no_presence"
2002+ else if isDuplicateMessage messageId toKey msgs aids dids
2003+ then yield ""
2004+ else if count msgs >= maxMessages
2005+ then yield "global_full"
2006+ else if countWhere msgs (\m -> m.toKey == toKey) >= maxMessagesPerRecipient
2007+ then yield "mailbox_full"
17632008 else do
1764− limited <- if checkRecvRate then do
1765− rRates <- *recvRates
1766− let r = checkRate rRates toKey maxRecvRatePerKey recvRateWindowMs t
1767− set *recvRates = r.entries
1768− yield r.limited
1769− else yield False {}
1770− if limited then yield "rate_limited"
2009+ limited <- if checkRecvRate
2010+ then do
2011+ rRates <- *recvRates
2012+ let r = checkRate rRates toKey maxRecvRatePerKey recvRateWindowMs t
2013+ replace *recvRates = r.entries
2014+ yield r.limited
2015+ else yield (False {})
2016+ if limited
2017+ then yield "rate_limited"
17712018 else do
17722019 seq <- *seqCounter
17732020 let seqTs = nextSeqTs t seq
1774− let cappedExpiry = if expiresAt > t then min expiresAt (seqTs + unackedMessageMaxAge) else seqTs + unackedMessageMaxAge
1775− set *seqCounter = seqTs
1776− set *messages = union msgs [{messageId: messageId, toKey: toKey, encryptedBlob: encryptedBlob, timestamp: clampTimestamp timestamp t, originServer: originServer, receivedAt: seqTs, expiresAt: cappedExpiry, senderKey: "", priority: clamp 0 maxMessagePriority priority}]
1777− set *pollWakeup = seqTs
2021+ let cappedExpiry = if expiresAt > t
2022+ then min expiresAt (seqTs + unackedMessageMaxAge)
2023+ else seqTs + unackedMessageMaxAge
2024+ *seqCounter = seqTs
2025+ *messages = union msgs [
2026+ {
2027+ messageId,
2028+ toKey,
2029+ encryptedBlob,
2030+ timestamp: clampTimestamp timestamp t,
2031+ originServer,
2032+ receivedAt: seqTs,
2033+ expiresAt: cappedExpiry,
2034+ senderKey: "",
2035+ priority: clamp 0 maxMessagePriority priority
2036+ }
2037+ ]
2038+ *pollWakeup = seqTs
17782039 yield ""
17792040
17802041-- POST /federation/forward: receive a single federated message destined for
17812042-- a local key. Delegates the actual store decision to `storeFederated`,
17822043-- which returns "" on success (including the duplicate case).
1783−handleForwardMessage : PubkeyHex -> BlobHex -> Timestamp -> ServerName -> MessageIdHex -> ServerName -> Timestamp -> Timestamp -> Int -> Text -> ({ok: Bool, error: Text, retryAfterMs: Int} -> ret) -> IO {network} ret
2044+handleForwardMessage : PubkeyHex -> BlobHex -> Int<Ms> -> Text -> Text -> Text -> Int -> Int<Ms> -> Int -> Text -> ({error: Text, ok: Bool, retryAfterMs: Int} -> a) -> IO {reads *allowedPeers, reads *blockedPeers, reads *federationRates, writes *federationRates, clock, reads *ackedIds, reads *deliveredIds, reads *messages, reads *pollWakeup, reads *presence, reads *recvRates, reads *seqCounter, writes *messages, writes *pollWakeup, writes *recvRates, writes *seqCounter, network} a
17842045handleForwardMessage = \toKey encryptedBlob timestamp originServer messageId fromServer requestTimestamp expiresAt priority authorization respond -> do
17852046 t <- now
17862047 withFederationAuth authorization t respond fromServer ("forward:" ++ messageId) requestTimestamp (isRemote originServer && isRemote fromServer) (do
17872048 if t - timestamp > messageMaxAge
1788− then yield (respond {ok: False {}, error: "stale_timestamp", retryAfterMs: 0})
1789− else do
1790− result <- atomic (storeFederated toKey encryptedBlob timestamp originServer messageId expiresAt priority (True {}) t)
1791− yield (respond {ok: result == "", error: result, retryAfterMs: 0}))
2049+ then yield (respond {ok: False {}, error: "stale_timestamp", retryAfterMs: 0})
2050+ else do
2051+ result <- atomic storeFederated toKey encryptedBlob timestamp originServer messageId expiresAt priority (True {}) t
2052+ yield (respond {ok: result == "", error: result, retryAfterMs: 0}))
17922053
17932054-- POST /federation/ack: peer reports it has acked messages we forwarded to it.
17942055-- We drop the matching `forwards` rows; if the recipient is no longer locally
17952056-- live and no other forward is still pending for the same id, also reap the
17962057-- backing `messages` row (after `ackGracePeriod` to dampen race with /poll).
1797−handleFederationAck : [MessageIdHex] -> ServerName -> ServerName -> Timestamp -> Text -> ({ok: Bool, error: Text, ackedCount: Int, results: [{messageId: MessageIdHex, found: Bool}], retryAfterMs: Int} -> ret) -> IO {network} ret
2058+handleFederationAck : [MessageIdHex] -> Text -> Text -> Int -> Text -> ({ackedCount: Int, error: Text, ok: Bool, results: [{found: Bool, messageId: MessageIdHex}], retryAfterMs: Int} -> a) -> IO {reads *allowedPeers, reads *blockedPeers, reads *federationRates, writes *federationRates, clock, reads *forwards, reads *messages, reads *presence, writes *forwards, writes *messages, network} a
17982059handleFederationAck = \messageIds originServer fromServer requestTimestamp authorization respond -> do
17992060 t <- now
1800− let ackRespond = \r -> respond {ok: r.ok, error: r.error, ackedCount: 0, results: [], retryAfterMs: r.retryAfterMs}
2061+ let ackRespond = \r -> respond {r.ok, r.error, ackedCount: 0, results: [], r.retryAfterMs}
18012062 withFederationAuth authorization t ackRespond fromServer "ack" requestTimestamp (isLocalServer originServer && isRemote fromServer) (do
18022063 let dedupedIds = dedupMessageIds messageIds
1803− result <- atomic do
2064+ result <- atomic (do
18042065 fwds <- *forwards
18052066 let isAcked = \f -> f.toServer == fromServer && elem dedupedIds f.messageId
18062067 let removed = filter fwds isAcked
18072068 let remainingFwds = removeWhere fwds isAcked
1808− set *forwards = remainingFwds
2069+ replace *forwards = remainingFwds
18092070 msgs <- *messages
18102071 let removedIds = pluck removed (\f -> f.messageId)
18112072 pres <- *presence
1812− let toReap = filter msgs (\m ->
1813− elem removedIds m.messageId
1814− && t - m.receivedAt >= ackGracePeriod
1815− && none pres (\p -> p.pubkey == m.toKey && isLocalServer p.server && p.expiresAt > t)
1816− && none remainingFwds (\f -> f.messageId == m.messageId && f.toKey == m.toKey))
1817− set *messages = removeWhere msgs (\m -> hasMessage m.messageId m.toKey toReap)
1818− yield {ackedCount: count removed, results: pluck dedupedIds (\mid -> {messageId: mid, found: any removed (\f -> f.messageId == mid)})}
1819− yield (respond {ok: True {}, error: "", ackedCount: result.ackedCount, results: result.results, retryAfterMs: 0}))
2073+ let toReap = filter msgs (\m -> elem removedIds m.messageId && t - m.receivedAt >= ackGracePeriod && none pres (\p -> p.pubkey == m.toKey && isLocalServer p.server && p.expiresAt > t) && none remainingFwds (\f -> f.messageId == m.messageId && f.toKey == m.toKey))
2074+ *messages = removeWhere msgs (\m -> hasMessage m.messageId m.toKey toReap)
2075+ yield {
2076+ ackedCount: count removed,
2077+ results: pluck dedupedIds (\mid -> {
2078+ messageId: mid,
2079+ found: any removed (\f -> f.messageId == mid)
2080+ })
2081+ })
2082+ yield (respond {ok: True {}, error: "", result.ackedCount, result.results, retryAfterMs: 0}))
18202083
18212084-- POST /federation/cancel: peer asks us to cancel a message it originated
18222085-- here. The owner predicate requires `originServer == fromServer` so peers
18232086-- can only cancel their own messages.
1824−handleFederationCancel : MessageIdHex -> PubkeyHex -> ServerName -> Timestamp -> Text -> ({ok: Bool, error: Text, cancelled: Bool, retryAfterMs: Int} -> ret) -> IO {network} ret
2087+handleFederationCancel : Text -> PubkeyHex -> Text -> Int -> Text -> ({cancelled: Bool, error: Text, ok: Bool, retryAfterMs: Int} -> a) -> IO {reads *allowedPeers, reads *blockedPeers, reads *federationRates, writes *federationRates, clock, reads *cancelNotifications, reads *forwards, reads *messages, writes *cancelNotifications, writes *forwards, writes *messages, network} a
18252088handleFederationCancel = \messageId toKey fromServer requestTimestamp authorization respond -> do
18262089 t <- now
1827− let cancelRespond = \r -> respond {ok: r.ok, error: r.error, cancelled: False {}, retryAfterMs: r.retryAfterMs}
2090+ let cancelRespond = \r -> respond {r.ok, r.error, cancelled: False {}, r.retryAfterMs}
18282091 withFederationAuth authorization t cancelRespond fromServer ("cancel:" ++ messageId) requestTimestamp (isRemote fromServer) (do
18292092 cancelled <- cancelOne messageId toKey (\m -> m.originServer == fromServer) t
1830− yield (respond {ok: True {}, error: "", cancelled: cancelled, retryAfterMs: 0}))
2093+ yield (respond {ok: True {}, error: "", cancelled, retryAfterMs: 0}))
18312094
18322095-- POST /federation/cancel-batch: same ownership constraint as
18332096-- `handleFederationCancel`, applied independently per entry.
1834−handleFederationBatchCancel : [{messageId: MessageIdHex, toKey: PubkeyHex}] -> ServerName -> Timestamp -> Text -> ({ok: Bool, error: Text, results: [BatchCancelResult], retryAfterMs: Int} -> ret) -> IO {network} ret
2097+handleFederationBatchCancel : [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> Text -> Int -> Text -> ({error: Text, ok: Bool, results: [{cancelled: Bool, messageId: MessageIdHex}], retryAfterMs: Int} -> b) -> IO {reads *allowedPeers, reads *blockedPeers, reads *federationRates, writes *federationRates, clock, network} b
18352098handleFederationBatchCancel = \cancels fromServer requestTimestamp authorization respond -> do
18362099 t <- now
1837− let batchRespond = \r -> respond {ok: r.ok, error: r.error, results: [], retryAfterMs: r.retryAfterMs}
2100+ let batchRespond = \r -> respond {r.ok, r.error, results: [], r.retryAfterMs}
18382101 withFederationAuth authorization t batchRespond fromServer "cancel-batch" requestTimestamp (isRemote fromServer && count cancels <= maxBatchSize) (do
18392102 results <- mapEach (takeRelation maxBatchSize cancels) (\e -> do
18402103 cancelled <- cancelOne e.messageId e.toKey (\m -> m.originServer == fromServer) t
1841− yield {messageId: e.messageId, cancelled: cancelled})
1842− yield (respond {ok: True {}, error: "", results: results, retryAfterMs: 0}))
2104+ yield {e.messageId, cancelled})
2105+ yield (respond {ok: True {}, error: "", results, retryAfterMs: 0}))
18432106
18442107-- POST /federation/forward-batch: bulk variant of `handleForwardMessage`.
18452108-- Skips per-entry recv-rate charging (the per-server federation rate limit
18462109-- already gates the call as a whole).
1847−handleFederationBatchForward : [{toKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: ServerName, messageId: MessageIdHex, expiresAt: Timestamp, priority: Int}] -> ServerName -> Timestamp -> Text -> ({ok: Bool, error: Text, results: [{messageId: MessageIdHex, ok: Bool}], retryAfterMs: Int} -> ret) -> IO {network} ret
2110+handleFederationBatchForward : [{encryptedBlob: BlobHex, expiresAt: Int<Ms>, messageId: MessageIdHex, originServer: Text, priority: Int, timestamp: Int<Ms>, toKey: PubkeyHex | a}] -> Text -> Int -> Text -> ({error: Text, ok: Bool, results: [{messageId: MessageIdHex, ok: Bool}], retryAfterMs: Int} -> b) -> IO {reads *allowedPeers, reads *blockedPeers, reads *federationRates, writes *federationRates, clock, network} b
18482111handleFederationBatchForward = \forwards fromServer requestTimestamp authorization respond -> do
18492112 t <- now
1850− let batchRespond = \r -> respond {ok: r.ok, error: r.error, results: [], retryAfterMs: r.retryAfterMs}
2113+ let batchRespond = \r -> respond {r.ok, r.error, results: [], r.retryAfterMs}
18512114 withFederationAuth authorization t batchRespond fromServer "forward-batch" requestTimestamp (isRemote fromServer && count forwards <= maxBatchSize) (do
18522115 results <- mapEach (takeRelation maxBatchSize forwards) (\e -> do
1853− ok <- if isLocalServer e.originServer || t - e.timestamp > messageMaxAge then yield False {}
1854− else do
1855− result <- atomic (storeFederated e.toKey e.encryptedBlob e.timestamp e.originServer e.messageId e.expiresAt e.priority (False {}) t)
1856− yield (result == "")
1857− yield {messageId: e.messageId, ok: ok})
1858− yield (respond {ok: True {}, error: "", results: results, retryAfterMs: 0}))
2116+ ok <- if isLocalServer e.originServer || t - e.timestamp > messageMaxAge
2117+ then yield (False {})
2118+ else do
2119+ result <- atomic storeFederated e.toKey e.encryptedBlob e.timestamp e.originServer e.messageId e.expiresAt e.priority (False {}) t
2120+ yield (result == "")
2121+ yield {e.messageId, ok})
2122+ yield (respond {ok: True {}, error: "", results, retryAfterMs: 0}))
18592123
18602124-- POST /federation/delivery-receipt: peer confirms delivery of messages whose
18612125-- sender is local to us; we record per-sender delivery rows so that sender's
18622126-- next /poll can include the deliveredAt timestamp.
1863−handleFederationDeliveryReceipt : [MessageIdHex] -> [PubkeyHex] -> ServerName -> Timestamp -> Text -> ({ok: Bool, error: Text, receivedCount: Int, retryAfterMs: Int} -> ret) -> IO {network} ret
2127+handleFederationDeliveryReceipt : [MessageIdHex] -> [PubkeyHex] -> Text -> Int -> Text -> ({error: Text, ok: Bool, receivedCount: Int, retryAfterMs: Int} -> a) -> IO {reads *allowedPeers, reads *blockedPeers, reads *federationRates, writes *federationRates, clock, reads *messages, reads *senderDeliveries, writes *senderDeliveries, network} a
18642128handleFederationDeliveryReceipt = \messageIds toKeys fromServer requestTimestamp authorization respond -> do
18652129 t <- now
1866− let receiptRespond = \r -> respond {ok: r.ok, error: r.error, receivedCount: 0, retryAfterMs: r.retryAfterMs}
2130+ let receiptRespond = \r -> respond {r.ok, r.error, receivedCount: 0, r.retryAfterMs}
18672131 withFederationAuth authorization t receiptRespond fromServer "delivery-receipt" requestTimestamp (isRemote fromServer && count messageIds <= maxMessageIds) (do
18682132 if count messageIds != count toKeys
1869− then yield (respond {ok: False {}, error: "mismatched_lengths", receivedCount: 0, retryAfterMs: 0})
1870− else do
1871− let pairs = do
1872− mp <- withIndex messageIds
1873− kp <- withIndex toKeys
1874− where mp.i == kp.i
1875− yield {messageId: mp.v, toKey: kp.v}
1876− atomic do
1877− msgs <- *messages
1878− sds <- *senderDeliveries
1879− let newDels = do
1880− p <- pairs
1881− m <- msgs
1882− where m.messageId == p.messageId && m.toKey == p.toKey && m.senderKey != "" && m.originServer == ""
1883− yield {senderKey: m.senderKey, messageId: p.messageId, toKey: p.toKey, deliveredAt: t}
1884− set *senderDeliveries = capList (union sds newDels) 10000 (\d -> d.deliveredAt)
1885− yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))
2133+ then yield (respond {
2134+ ok: False {},
2135+ error: "mismatched_lengths",
2136+ receivedCount: 0,
2137+ retryAfterMs: 0
2138+ })
2139+ else do
2140+ let pairs = do
2141+ mp <- withIndex messageIds
2142+ kp <- withIndex toKeys
2143+ where mp.i == kp.i
2144+ yield {messageId: mp.v, toKey: kp.v}
2145+ atomic (do
2146+ msgs <- *messages
2147+ sds <- *senderDeliveries
2148+ let newDels = do
2149+ p <- pairs
2150+ m <- msgs
2151+ where m.messageId == p.messageId && m.toKey == p.toKey && m.senderKey != "" && m.originServer == ""
2152+ yield {m.senderKey, p.messageId, p.toKey, deliveredAt: t}
2153+ *senderDeliveries = capList (union sds newDels) 10000 (\d -> d.deliveredAt))
2154+ yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))
18862155
18872156-- ============================================
18882157-- Maintenance handlers
@@ -1896,47 +2165,47 @@ handleFederationDeliveryReceipt = \messageIds toKeys fromServer requestTimestamp
18962165-- POST /maintenance/drain: phase 1 stops accepting new auth (challenges,
18972166-- verify); phase 2 additionally clears local presence and broadcasts offline
18982167-- gossip for every locally-live key so peers can reroute. Idempotent.
1899−handleDrain : Int -> Text -> ({ok: Bool, drained: Int, phase: Int} -> ret) -> IO {network} ret
1900−handleDrain = \phase authorization respond -> withMaintAuth authorization
1901− (yield (respond {ok: False {}, drained: 0, phase: 0}))
1902− (do
1903− let effectivePhase = if phase == 1 then 1 else 2
1904− t <- now
1905− drainResult <- atomic do
1906− set *drainPhase = effectivePhase
1907− set *drainCompletedAt = t
1908− if effectivePhase == 1 then yield {peers: [], localKeys: []}
1909− else do
1910− pres <- *presence
1911− let isLocalLive = \p -> isLocalServer p.server && p.expiresAt > t
1912− set *presence = removeWhere pres isLocalLive
1913− set *pollWakeup = t
1914− yield {peers: knownPeerServersFromPresence pres, localKeys: filter pres isLocalLive}
1915− when (effectivePhase == 2 && count drainResult.localKeys > 0 && federationEnabled)
1916− (fork (sendBatchedGossip drainResult.peers (pluck drainResult.localKeys (\p -> mkGossip (GossipOffline {}) p.pubkey t offlineGossipMinTtl))))
1917− yield (respond {ok: True {}, drained: count drainResult.localKeys, phase: effectivePhase}))
2168+handleDrain : Int -> Text -> ({drained: Int, ok: Bool, phase: Int} -> a) -> IO {reads *drainCompletedAt, reads *drainPhase, reads *pollWakeup, reads *presence, reads *runtimeMaintenanceSecret, writes *drainCompletedAt, writes *drainPhase, writes *pollWakeup, writes *presence, clock} a
2169+handleDrain = \phase authorization respond -> withMaintAuth authorization (yield (respond {
2170+ ok: False {},
2171+ drained: 0,
2172+ phase: 0
2173+})) (do
2174+ let effectivePhase = if phase == 1 then 1 else 2
2175+ t <- now
2176+ drainResult <- atomic (do
2177+ *drainPhase = effectivePhase
2178+ *drainCompletedAt = t
2179+ if effectivePhase == 1
2180+ then yield {peers: [], localKeys: []}
2181+ else do
2182+ pres <- *presence
2183+ let isLocalLive = \p -> isLocalServer p.server && p.expiresAt > t
2184+ *presence = removeWhere pres isLocalLive
2185+ *pollWakeup = t
2186+ yield {peers: knownPeerServersFromPresence pres, localKeys: filter pres isLocalLive})
2187+ when (effectivePhase == 2 && count drainResult.localKeys > 0 && federationEnabled) (fork (sendBatchedGossip drainResult.peers (pluck drainResult.localKeys (\p -> mkGossip (GossipOffline {}) p.pubkey t offlineGossipMinTtl))))
2188+ yield (respond {ok: True {}, drained: count drainResult.localKeys, phase: effectivePhase}))
19182189
19192190-- POST /maintenance/undrain: clear drain state and resume normal operation.
19202191-- Does not restore presence — clients must re-authenticate to repopulate.
1921−handleUndrain : Text -> ({ok: Bool} -> ret) -> IO {} ret
1922−handleUndrain = \authorization respond -> withMaintAuth authorization
1923− (yield (respond {ok: False {}}))
1924− (do
1925− atomic do
1926− set *drainPhase = 0
1927− set *drainCompletedAt = 0
1928− yield (respond {ok: True {}}))
2192+handleUndrain : Text -> ({ok: Bool} -> a) -> IO {reads *drainCompletedAt, reads *drainPhase, reads *runtimeMaintenanceSecret, writes *drainCompletedAt, writes *drainPhase} a
2193+handleUndrain = \authorization respond -> withMaintAuth authorization (yield (respond {ok: False {}})) (do
2194+ atomic (do *drainPhase = 0; *drainCompletedAt = 0)
2195+ yield (respond {ok: True {}}))
19292196
19302197-- POST /maintenance/shutdown: convenience wrapper that performs a phase-2
19312198-- drain and reports the count of presence rows cleared.
1932−handleShutdown : Text -> ({ok: Bool, drained: Int} -> ret) -> IO {network} ret
1933−handleShutdown = \authorization respond ->
1934− handleDrain 2 authorization (\r -> respond {ok: r.ok, drained: r.drained})
2199+handleShutdown : Text -> ({drained: Int, ok: Bool} -> a) -> IO {reads *drainCompletedAt, reads *drainPhase, reads *pollWakeup, reads *presence, reads *runtimeMaintenanceSecret, writes *drainCompletedAt, writes *drainPhase, writes *pollWakeup, writes *presence, clock} a
2200+handleShutdown = \authorization respond -> handleDrain 2 authorization (\r -> respond {
2201+ r.ok,
2202+ r.drained
2203+})
19352204
19362205-- POST /maintenance/prune: trigger an out-of-band `pruneAndRetry` tick.
19372206-- Useful when the operator wants to force expiry/forward retries without
19382207-- waiting for the next `backgroundPrune` interval.
1939−handlePrune : Text -> ({ok: Bool} -> ret) -> IO {network} ret
2208+handlePrune : Text -> ({ok: Bool} -> a) -> IO {reads *runtimeMaintenanceSecret, clock, reads *ackedIds, reads *activePolls, reads *blockedPeers, reads *cancelNotifications, reads *challenges, reads *deliveredIds, reads *forwardFailures, reads *forwards, reads *lastPresenceRefresh, reads *lastPrunedAt, reads *messages, reads *pendingFederationCancels, reads *pendingVerifications, reads *presence, reads *senderDeliveries, reads *senderExpirations, reads *sessions, writes *ackedIds, writes *activePolls, writes *cancelNotifications, writes *challenges, writes *deliveredIds, writes *forwardFailures, writes *forwards, writes *lastPresenceRefresh, writes *lastPrunedAt, writes *messages, writes *pendingFederationCancels, writes *pendingVerifications, writes *presence, writes *senderDeliveries, writes *senderExpirations, writes *sessions} a
19402209handlePrune = \authorization respond -> do
19412210 t <- now
19422211 authorized <- verifyMaintenanceAuth authorization
@@ -1945,7 +2214,7 @@ handlePrune = \authorization respond -> do
19452214
19462215-- POST /maintenance/reconcile: stub. Production builds run a state
19472216-- reconciliation pass here; this simplified server reports zero drift.
1948−handleReconcile : Text -> ({ok: Bool, messageDrift: Int, presenceDrift: Int, sessionDrift: Int} -> ret) -> IO {} ret
2217+handleReconcile : Text -> ({messageDrift: Int, ok: Bool, presenceDrift: Int, sessionDrift: Int} -> a) -> IO {reads *runtimeMaintenanceSecret} a
19492218handleReconcile = \authorization respond -> do
19502219 authorized <- verifyMaintenanceAuth authorization
19512220 yield (respond {ok: authorized, messageDrift: 0, presenceDrift: 0, sessionDrift: 0})
@@ -1953,7 +2222,7 @@ handleReconcile = \authorization respond -> do
19532222-- GET /health: aggregate readiness flags. During an initial warmup window
19542223-- (3 prune intervals after startup) prune/heartbeat checks always pass to
19552224-- avoid false negatives before the background loops have ticked.
1956−handleHealth : 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} -> ret) -> IO {} ret
2225+handleHealth : a -> ({capacityHealthy: Bool, capacityWarning: Bool, degradedPeers: Int, draining: Bool, federationHealthy: Bool, forwardQueueHealthy: Bool, heartbeatHealthy: Bool, nonceHealthy: Bool, ok: Bool, pruneHealthy: Bool, requestPressureHealthy: Bool, version: Text, watchdogHealthy: Bool} -> b) -> IO {reads *drainPhase, reads *lastHeartbeatAt, reads *lastPrunedAt, reads *startedAt, clock} b
19572226handleHealth = \authorization respond -> do
19582227 t <- now
19592228 lastPrune <- *lastPrunedAt
@@ -1963,11 +2232,25 @@ handleHealth = \authorization respond -> do
19632232 let warmup = t - sa < backgroundPruneInterval * 3
19642233 let pruneOk = warmup || t - lastPrune < backgroundPruneInterval * 3
19652234 let heartbeatOk = warmup || t - lastHb < pollTimeoutMs * 3
1966− yield (respond {ok: dp == 0 && pruneOk && heartbeatOk, 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})
2235+ yield (respond {
2236+ ok: dp == 0 && pruneOk && heartbeatOk,
2237+ version: serverBuildVersion,
2238+ pruneHealthy: pruneOk,
2239+ heartbeatHealthy: heartbeatOk,
2240+ capacityHealthy: True {},
2241+ capacityWarning: False {},
2242+ federationHealthy: True {},
2243+ watchdogHealthy: True {},
2244+ nonceHealthy: True {},
2245+ forwardQueueHealthy: True {},
2246+ requestPressureHealthy: True {},
2247+ draining: dp > 0,
2248+ degradedPeers: 0
2249+ })
19672250
19682251-- GET /ready: signals readiness once the first background prune has run
19692252-- (load-balancer / orchestrator probe).
1970−handleReady : ({ready: Bool} -> ret) -> IO {} ret
2253+handleReady : ({ready: Bool} -> a) -> IO {reads *lastPrunedAt, reads *startedAt} a
19712254handleReady = \respond -> do
19722255 sa <- *startedAt
19732256 lastPrune <- *lastPrunedAt
@@ -1975,178 +2258,206 @@ handleReady = \respond -> do
19752258
19762259-- POST /maintenance/block: deny-list a peer. Outbound retries skip blocked
19772260-- peers; inbound federation calls from blocked peers fail in `withFederationAuth`.
1978−handleBlockPeer : ServerName -> Text -> ({ok: Bool, blocked: Int} -> ret) -> IO {} ret
1979−handleBlockPeer = \server authorization respond -> withMaintAuth authorization
1980− (yield (respond {ok: False {}, blocked: 0}))
1981− (do
1982− n <- atomic do
1983− current <- *blockedPeers
1984− let updated = unique (union current [server])
1985− set *blockedPeers = updated
1986− yield (count updated)
1987− yield (respond {ok: True {}, blocked: n}))
2261+handleBlockPeer : Text -> Text -> ({blocked: Int, ok: Bool} -> a) -> IO {reads *blockedPeers, reads *runtimeMaintenanceSecret, writes *blockedPeers} a
2262+handleBlockPeer = \server authorization respond -> withMaintAuth authorization (yield (respond {
2263+ ok: False {},
2264+ blocked: 0
2265+})) (do
2266+ n <- atomic (do
2267+ current <- *blockedPeers
2268+ let updated = unique (union current [server])
2269+ replace *blockedPeers = updated
2270+ yield (count updated))
2271+ yield (respond {ok: True {}, blocked: n}))
19882272
19892273-- POST /maintenance/unblock: remove a peer from the deny-list.
1990−handleUnblockPeer : ServerName -> Text -> ({ok: Bool, unblocked: Bool} -> ret) -> IO {} ret
1991−handleUnblockPeer = \server authorization respond -> withMaintAuth authorization
1992− (yield (respond {ok: False {}, unblocked: False {}}))
1993− (do
1994− removed <- atomic do
1995− current <- *blockedPeers
1996− set *blockedPeers = removeWhere current (\x -> x == server)
1997− yield (elem current server)
1998− yield (respond {ok: True {}, unblocked: removed}))
1999−
2000−handleListBlocked : Text -> ({peers: [Text], ok: Bool} -> ret) -> IO {} ret
2274+handleUnblockPeer : Text -> Text -> ({ok: Bool, unblocked: Bool} -> a) -> IO {reads *blockedPeers, reads *runtimeMaintenanceSecret, writes *blockedPeers} a
2275+handleUnblockPeer = \server authorization respond -> withMaintAuth authorization (yield (respond {
2276+ ok: False {},
2277+ unblocked: False {}
2278+})) (do
2279+ removed <- atomic (do
2280+ current <- *blockedPeers
2281+ *blockedPeers = removeWhere current (\x -> x == server)
2282+ yield (elem current server))
2283+ yield (respond {ok: True {}, unblocked: removed}))
2284+
2285+handleListBlocked : Text -> ({ok: Bool, peers: [Text]} -> a) -> IO {reads *blockedPeers, reads *runtimeMaintenanceSecret} a
20012286handleListBlocked = \authorization respond -> do
20022287 ok <- verifyMaintenanceAuth authorization
20032288 list <- *blockedPeers
2004− yield (respond {peers: if ok then list else [], ok: ok})
2289+ yield (respond {peers: if ok then list else [], ok})
20052290
20062291-- POST /maintenance/allow: when the allowed-peers list is non-empty, only
20072292-- federation calls from listed peers are accepted (whitelist mode). An empty
20082293-- list disables the whitelist.
2009−handleAllowPeer : ServerName -> Text -> ({ok: Bool, allowed: Int} -> ret) -> IO {} ret
2010−handleAllowPeer = \server authorization respond -> withMaintAuth authorization
2011− (yield (respond {ok: False {}, allowed: 0}))
2012− (do
2013− n <- atomic do
2014− current <- *allowedPeers
2015− let updated = unique (union current [server])
2016− set *allowedPeers = updated
2017− yield (count updated)
2018− yield (respond {ok: True {}, allowed: n}))
2294+handleAllowPeer : Text -> Text -> ({allowed: Int, ok: Bool} -> a) -> IO {reads *allowedPeers, reads *runtimeMaintenanceSecret, writes *allowedPeers} a
2295+handleAllowPeer = \server authorization respond -> withMaintAuth authorization (yield (respond {
2296+ ok: False {},
2297+ allowed: 0
2298+})) (do
2299+ n <- atomic (do
2300+ current <- *allowedPeers
2301+ let updated = unique (union current [server])
2302+ replace *allowedPeers = updated
2303+ yield (count updated))
2304+ yield (respond {ok: True {}, allowed: n}))
20192305
20202306-- POST /maintenance/unallow: remove an entry from the allow-list. If the
20212307-- list becomes empty, the whitelist gate disengages.
2022−handleUnallowPeer : ServerName -> Text -> ({ok: Bool, removed: Bool} -> ret) -> IO {} ret
2023−handleUnallowPeer = \server authorization respond -> withMaintAuth authorization
2024− (yield (respond {ok: False {}, removed: False {}}))
2025− (do
2026− removed <- atomic do
2027− current <- *allowedPeers
2028− set *allowedPeers = removeWhere current (\x -> x == server)
2029− yield (elem current server)
2030− yield (respond {ok: True {}, removed: removed}))
2031−
2032−handleListAllowed : Text -> ({peers: [Text], ok: Bool} -> ret) -> IO {} ret
2308+handleUnallowPeer : Text -> Text -> ({ok: Bool, removed: Bool} -> a) -> IO {reads *allowedPeers, reads *runtimeMaintenanceSecret, writes *allowedPeers} a
2309+handleUnallowPeer = \server authorization respond -> withMaintAuth authorization (yield (respond {
2310+ ok: False {},
2311+ removed: False {}
2312+})) (do
2313+ removed <- atomic (do
2314+ current <- *allowedPeers
2315+ *allowedPeers = removeWhere current (\x -> x == server)
2316+ yield (elem current server))
2317+ yield (respond {ok: True {}, removed}))
2318+
2319+handleListAllowed : Text -> ({ok: Bool, peers: [Text]} -> a) -> IO {reads *allowedPeers, reads *runtimeMaintenanceSecret} a
20332320handleListAllowed = \authorization respond -> do
20342321 ok <- verifyMaintenanceAuth authorization
20352322 list <- *allowedPeers
2036− yield (respond {peers: if ok then list else [], ok: ok})
2323+ yield (respond {peers: if ok then list else [], ok})
20372324
20382325-- POST /maintenance/ping: send a zero-event gossip to a peer and return the
20392326-- round-trip latency. Useful for diagnosing federation reachability without
20402327-- waiting for organic traffic.
2041−handlePingPeer : ServerName -> Text -> ({ok: Bool, latencyMs: Int, error: Text} -> ret) -> IO {network} ret
2042−handlePingPeer = \server authorization respond -> withMaintAuth authorization
2043− (yield (respond {ok: False {}, latencyMs: 0, error: "unauthorized"}))
2044− (do
2045− startTime <- now
2046− auth <- generateFederationAuth "gossip" startTime
2047− result <- fetch (federationUrl server) (RecvGossip {
2048− authorization: auth,
2049− events: [], hopsRemaining: 1, fromServer: serverHostN,
2050− requestTimestamp: startTime, correlationId: "", protocolVersion: federationProtocolVersion})
2051− endTime <- now
2052− case result of
2053− Err e -> yield (respond {ok: False {}, latencyMs: endTime - startTime, error: show e})
2054− Ok {value: r} -> yield (respond {ok: r.ok, latencyMs: endTime - startTime, error: r.error}))
2328+handlePingPeer : Text -> Text -> ({error: Text, latencyMs: Int, ok: Bool} -> a) -> IO {reads *pendingVerifications, reads *runtimeMaintenanceSecret, writes *pendingVerifications, network, clock, random} a
2329+handlePingPeer = \server authorization respond -> withMaintAuth authorization (yield (respond {
2330+ ok: False {},
2331+ latencyMs: 0,
2332+ error: "unauthorized"
2333+})) (do
2334+ startTime <- now
2335+ auth <- generateFederationAuth "gossip" startTime
2336+ result <- fetch (federationUrl server) (RecvGossip {
2337+ authorization: auth,
2338+ events: [],
2339+ hopsRemaining: 1,
2340+ fromServer: serverHostN,
2341+ requestTimestamp: startTime,
2342+ correlationId: "",
2343+ protocolVersion: federationProtocolVersion
2344+ })
2345+ endTime <- now
2346+ case result of
2347+ Err e -> yield (respond {ok: False {}, latencyMs: endTime - startTime, error: show e})
2348+ Ok {value: r} -> yield (respond {r.ok, latencyMs: endTime - startTime, r.error}))
20552349
20562350-- GET /maintenance/sessions/{pubkey}: list a single user's active sessions.
20572351-- Token values are masked ("***") — operators see expiry, ip, createdAt only.
2058−handleAdminListSessions : PubkeyHex -> Text -> ({sessions: [{token: Text, expiresAt: Timestamp, ip: Text, createdAt: Timestamp}], count: Int, ok: Bool} -> ret) -> IO {} ret
2352+handleAdminListSessions : PubkeyHex -> Text -> ({count: Int, ok: Bool, sessions: [{createdAt: Int<Ms>, expiresAt: Int<Ms>, ip: Text, token: Text}]} -> a) -> IO {reads *runtimeMaintenanceSecret, reads *sessions} a
20592353handleAdminListSessions = \pubkey authorization respond -> do
20602354 ok <- verifyMaintenanceAuth authorization
20612355 ses <- *sessions
2062− let mine = if ok then mapWhere ses (\s -> s.pubkey == pubkey) (\s -> {token: "***", expiresAt: s.expiresAt, ip: s.ip, createdAt: s.createdAt}) else []
2063− yield (respond {sessions: mine, count: count mine, ok: ok})
2356+ let mine = if ok
2357+ then mapWhere ses (\s -> s.pubkey == pubkey) (\s -> {token: "***", s.expiresAt, s.ip, s.createdAt})
2358+ else []
2359+ yield (respond {sessions: mine, count: count mine, ok})
20642360
20652361-- POST /maintenance/sessions/revoke-all: drop every session and local presence
20662362-- row for `pubkey`. Operator-side kick for a compromised key.
2067−handleAdminRevokeSessions : PubkeyHex -> Text -> ({ok: Bool, revokedCount: Int} -> ret) -> IO {} ret
2068−handleAdminRevokeSessions = \pubkey authorization respond -> withMaintAuth authorization
2069− (yield (respond {ok: False {}, revokedCount: 0}))
2070− (do
2071− revoked <- atomic do
2072− ses <- *sessions
2073− let same = \s -> s.pubkey == pubkey
2074− set *sessions = removeWhere ses same
2075− pres <- *presence
2076− set *presence = filter pres (\p -> p.pubkey != pubkey || isRemote p.server)
2077− yield (countWhere ses same)
2078− yield (respond {ok: True {}, revokedCount: revoked}))
2363+handleAdminRevokeSessions : PubkeyHex -> Text -> ({ok: Bool, revokedCount: Int} -> a) -> IO {reads *presence, reads *runtimeMaintenanceSecret, reads *sessions, writes *presence, writes *sessions} a
2364+handleAdminRevokeSessions = \pubkey authorization respond -> withMaintAuth authorization (yield (respond {
2365+ ok: False {},
2366+ revokedCount: 0
2367+})) (do
2368+ revoked <- atomic (do
2369+ ses <- *sessions
2370+ let same = \s -> s.pubkey == pubkey
2371+ *sessions = removeWhere ses same
2372+ pres <- *presence
2373+ *presence = filter pres (\p -> p.pubkey != pubkey || isRemote p.server)
2374+ yield (countWhere ses same))
2375+ yield (respond {ok: True {}, revokedCount: revoked}))
20792376
20802377-- POST /maintenance/messages/purge: drop all queued/forwarding messages
20812378-- destined for `pubkey`, recording federation acks for any that originated
20822379-- elsewhere so peers learn we have nothing for the key.
2083−handleAdminPurgeMessages : PubkeyHex -> Text -> ({ok: Bool, purgedCount: Int} -> ret) -> IO {} ret
2084−handleAdminPurgeMessages = \pubkey authorization respond -> withMaintAuth authorization
2085− (yield (respond {ok: False {}, purgedCount: 0}))
2086− (do
2087− t <- now
2088− purged <- atomic do
2089− msgs <- *messages
2090− let mine = \m -> m.toKey == pubkey
2091− let purgedMsgs = filter msgs mine
2092− set *messages = removeWhere msgs mine
2093− fwds <- *forwards
2094− set *forwards = filter fwds (\f -> f.toKey != pubkey)
2095− aids <- *ackedIds
2096− set *ackedIds = capList (union aids (mapWhere purgedMsgs (\m -> m.originServer != "") (\m -> mkAckedEntry m t))) maxAckedIds (\a -> a.ackedAt)
2097− yield (count purgedMsgs)
2098− yield (respond {ok: True {}, purgedCount: purged}))
2380+handleAdminPurgeMessages : PubkeyHex -> Text -> ({ok: Bool, purgedCount: Int} -> a) -> IO {reads *ackedIds, reads *forwards, reads *messages, reads *runtimeMaintenanceSecret, writes *ackedIds, writes *forwards, writes *messages, clock} a
2381+handleAdminPurgeMessages = \pubkey authorization respond -> withMaintAuth authorization (yield (respond {
2382+ ok: False {},
2383+ purgedCount: 0
2384+})) (do
2385+ t <- now
2386+ purged <- atomic (do
2387+ msgs <- *messages
2388+ let mine = \m -> m.toKey == pubkey
2389+ let purgedMsgs = filter msgs mine
2390+ *messages = removeWhere msgs mine
2391+ fwds <- *forwards
2392+ *forwards = filter fwds (\f -> f.toKey != pubkey)
2393+ aids <- *ackedIds
2394+ *ackedIds = capList (union aids (mapWhere purgedMsgs (\m -> m.originServer != "") (\m -> mkAckedEntry m t))) maxAckedIds (\a -> a.ackedAt)
2395+ yield (count purgedMsgs))
2396+ yield (respond {ok: True {}, purgedCount: purged}))
20992397
21002398-- POST /maintenance/sessions/revoke-ip: kill every session bound to a given
21012399-- client IP, regardless of pubkey. Reports total revoked + distinct keys.
2102−handleAdminRevokeIp : Text -> Text -> ({ok: Bool, revokedCount: Int, affectedKeys: Int} -> ret) -> IO {} ret
2103−handleAdminRevokeIp = \ip authorization respond -> withMaintAuth authorization
2104− (yield (respond {ok: False {}, revokedCount: 0, affectedKeys: 0}))
2105− (do
2106− keys <- if ip == "" then yield [] else atomic do
2107− ses <- *sessions
2108− let same = \s -> s.ip == ip
2109− set *sessions = removeWhere ses same
2110− yield (mapWhere ses same (\s -> s.pubkey))
2111− yield (respond {ok: ip != "", revokedCount: count keys, affectedKeys: count (unique keys)}))
2400+handleAdminRevokeIp : Text -> Text -> ({affectedKeys: Int, ok: Bool, revokedCount: Int} -> a) -> IO {reads *runtimeMaintenanceSecret, reads *sessions, writes *sessions} a
2401+handleAdminRevokeIp = \ip authorization respond -> withMaintAuth authorization (yield (respond {
2402+ ok: False {},
2403+ revokedCount: 0,
2404+ affectedKeys: 0
2405+})) (do
2406+ keys <- if ip == ""
2407+ then yield []
2408+ else atomic (do
2409+ ses <- *sessions
2410+ let same = \s -> s.ip == ip
2411+ *sessions = removeWhere ses same
2412+ yield (mapWhere ses same (\s -> s.pubkey)))
2413+ yield (respond {ok: ip != "", revokedCount: count keys, affectedKeys: count (unique keys)}))
21122414
21132415-- POST /maintenance/sessions/list: paged session inventory aggregated by
21142416-- pubkey (count, distinct ips, latest expiry). Sorted by descending count.
2115−handleAdminListAllSessions : Int -> Text -> ({sessions: [{pubkey: PubkeyHex, count: Int, ips: [Text], latestExpiry: Timestamp}], ok: Bool, total: Int} -> ret) -> IO {} ret
2116−handleAdminListAllSessions = \limit authorization respond -> withMaintAuth authorization
2117− (yield (respond {sessions: [], ok: False {}, total: 0}))
2118− (do
2119− t <- now
2120− ses <- *sessions
2121− let active = filter ses (\s -> s.expiresAt > t)
2122− let grouped = pluck (unique (pluck active (\s -> s.pubkey))) (\pk ->
2123− let mine = filter active (\s -> s.pubkey == pk) in
2124− {pubkey: pk,
2125− count: count mine,
2126− ips: unique (mapWhere mine (\s -> s.ip != "") (\s -> s.ip)),
2127− latestExpiry: fold (\acc s -> max acc s.expiresAt) 0 mine})
2128− let cap = clamp 1 500 (if limit <= 0 then 100 else limit)
2129− let top = takeRelation cap (sortBy (\g -> 0 - g.count) grouped)
2130− yield (respond {sessions: top, ok: True {}, total: count grouped}))
2417+handleAdminListAllSessions : Int -> Text -> ({ok: Bool, sessions: [{count: Int, ips: [Text], latestExpiry: Int, pubkey: PubkeyHex}], total: Int} -> a) -> IO {reads *runtimeMaintenanceSecret, reads *sessions, clock} a
2418+handleAdminListAllSessions = \limit authorization respond -> withMaintAuth authorization (yield (respond {
2419+ sessions: [],
2420+ ok: False {},
2421+ total: 0
2422+})) (do
2423+ t <- now
2424+ ses <- *sessions
2425+ let active = filter ses (\s -> s.expiresAt > t)
2426+ let grouped = pluck (unique (pluck active (\s -> s.pubkey))) (\pk -> (\mine -> {pubkey: pk, count: count mine, ips: unique (mapWhere mine (\s -> s.ip != "") (\s -> s.ip)), latestExpiry: fold (\acc s -> max acc s.expiresAt) 0 mine}) (filter active (\s -> s.pubkey == pk)))
2427+ let cap = clamp 1 500 (if limit <= 0 then 100 else limit)
2428+ let top = takeRelation cap (sortBy (\g -> 0 - g.count) grouped)
2429+ yield (respond {sessions: top, ok: True {}, total: count grouped}))
21312430
21322431-- GET /maintenance/rate-limits: expose the configured rate ceilings. Returns
21332432-- zeros for unauthenticated callers (response shape stays stable).
2134−handleGetRateLimits : Text -> ({ok: Bool, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int} -> ret) -> IO {} ret
2433+handleGetRateLimits : Text -> ({authGlobal: Int, challengeRate: Int, clientWriteRate: Int, federationRate: Int, globalRequest: Int, ipRate: Int, lookupRate: Int, ok: Bool, pairRate: Int, recvRate: Int, sendRate: Int} -> a) -> IO {reads *runtimeMaintenanceSecret} a
21352434handleGetRateLimits = \authorization respond -> do
21362435 ok <- verifyMaintenanceAuth authorization
21372436 let v = \x -> if ok then x else 0
2138− yield (respond {ok: ok, globalRequest: v maxGlobalRequestRate, ipRate: v maxIpRatePerIp, sendRate: v maxSendRatePerKey, federationRate: v maxFederationRatePerServer, authGlobal: v maxAuthGlobalRate, recvRate: v maxRecvRatePerKey, challengeRate: v maxChallengeRatePerKey, pairRate: v maxPairRatePerPair, lookupRate: v maxLookupRatePerKey, clientWriteRate: v maxClientWriteRatePerKey})
2437+ yield (respond {
2438+ ok,
2439+ globalRequest: v maxGlobalRequestRate,
2440+ ipRate: v maxIpRatePerIp,
2441+ sendRate: v maxSendRatePerKey,
2442+ federationRate: v maxFederationRatePerServer,
2443+ authGlobal: v maxAuthGlobalRate,
2444+ recvRate: v maxRecvRatePerKey,
2445+ challengeRate: v maxChallengeRatePerKey,
2446+ pairRate: v maxPairRatePerPair,
2447+ lookupRate: v maxLookupRatePerKey,
2448+ clientWriteRate: v maxClientWriteRatePerKey
2449+ })
21392450
21402451-- POST /maintenance/rate-limits: stub. Rate ceilings are compile-time constants
21412452-- in this simplified server, so this just authorizes and returns ok=true.
2142−handleSetRateLimits : Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Text -> ({ok: Bool} -> ret) -> IO {} ret
2453+handleSetRateLimits : a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> Text -> ({ok: Bool} -> k) -> IO {reads *runtimeMaintenanceSecret} k
21432454handleSetRateLimits = \globalRequest ipRate sendRate federationRate authGlobal recvRate challengeRate pairRate lookupRate clientWriteRate authorization respond -> do
21442455 authorized <- verifyMaintenanceAuth authorization
21452456 yield (respond {ok: authorized})
21462457
21472458-- POST /maintenance/nonces/flush: stub. Nonce caches were removed; the
21482459-- endpoint is preserved so older operator tooling keeps working.
2149−handleFlushNonces : Text -> ({ok: Bool, flushedCount: Int} -> ret) -> IO {} ret
2460+handleFlushNonces : Text -> ({flushedCount: Int, ok: Bool} -> a) -> IO {reads *runtimeMaintenanceSecret} a
21502461handleFlushNonces = \authorization respond -> do
21512462 authorized <- verifyMaintenanceAuth authorization
21522463 yield (respond {ok: authorized, flushedCount: 0})
@@ -2154,131 +2465,386 @@ handleFlushNonces = \authorization respond -> do
21542465-- POST /maintenance/rotate-secret: replace the maintenance Bearer secret.
21552466-- The old secret authenticates the rotation; subsequent calls must use the
21562467-- new value.
2157−handleRotateSecret : Text -> Text -> ({ok: Bool, error: Text} -> ret) -> IO {} ret
2158−handleRotateSecret = \newSecret authorization respond -> withMaintAuth authorization
2159− (yield (respond {ok: False {}, error: "unauthorized"}))
2160− (do
2161− atomic do set *runtimeMaintenanceSecret = newSecret
2162− yield (respond {ok: True {}, error: ""}))
2468+handleRotateSecret : Text -> Text -> ({error: Text, ok: Bool} -> a) -> IO {reads *runtimeMaintenanceSecret, writes *runtimeMaintenanceSecret} a
2469+handleRotateSecret = \newSecret authorization respond -> withMaintAuth authorization (yield (respond {
2470+ ok: False {},
2471+ error: "unauthorized"
2472+})) (do
2473+ atomic *runtimeMaintenanceSecret = newSecret
2474+ yield (respond {ok: True {}, error: ""}))
21632475
21642476-- GET /maintenance/config: expose a small set of operationally-relevant
21652477-- compile-time constants (mailbox cap, gossip hops, poll timeout, ack grace).
2166−handleGetConfig : Text -> ({ok: Bool, maxMessagesPerRecipient: Int, maxGossipHops: Int, pollTimeoutMs: Int, ackGracePeriod: Int} -> ret) -> IO {} ret
2478+handleGetConfig : Text -> ({ackGracePeriod: Int, maxGossipHops: Int, maxMessagesPerRecipient: Int, ok: Bool, pollTimeoutMs: Int} -> a) -> IO {reads *runtimeMaintenanceSecret} a
21672479handleGetConfig = \authorization respond -> do
21682480 ok <- verifyMaintenanceAuth authorization
21692481 let v = \x -> if ok then x else 0
2170− yield (respond {ok: ok, maxMessagesPerRecipient: v maxMessagesPerRecipient, maxGossipHops: v maxGossipHops, pollTimeoutMs: v pollTimeoutMs, ackGracePeriod: v ackGracePeriod})
2482+ yield (respond {
2483+ ok,
2484+ maxMessagesPerRecipient: v maxMessagesPerRecipient,
2485+ maxGossipHops: v maxGossipHops,
2486+ pollTimeoutMs: v pollTimeoutMs,
2487+ ackGracePeriod: v ackGracePeriod
2488+ })
21712489
21722490-- GET /stats: capacity gauges + minimal federation/timing snapshot. Most of
21732491-- the historical metric fields are zero-filled (see `zeroStats`) — only the
21742492-- counts that come straight from the state refs are populated.
2175−handleStats : Text -> ({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}} -> ret) -> IO {} ret
2176−handleStats = \authorization respond -> withMaintAuth authorization
2177− (yield (respond zeroStats))
2178− (do
2179− t <- now
2180− sa <- *startedAt
2181− sessions <- *sessions
2182− msgs <- *messages
2183− pres <- *presence
2184− fwds <- *forwards
2185− aids <- *ackedIds
2186− dids <- *deliveredIds
2187− aps <- *activePolls
2188− chs <- *challenges
2189− bp <- *blockedPeers
2190− pc <- *pruneCount
2191− hc <- *heartbeatCount
2192− lp <- *lastPrunedAt
2193− lh <- *lastHeartbeatAt
2194− dp <- *drainPhase
2195− pfc <- *pendingFederationCancels
2196− let sCount = count sessions
2197− let mCount = count msgs
2198− let pCount = count pres
2199− let fCount = count fwds
2200− yield (respond {ok: True {}, version: serverBuildVersion,
2201− capacity: {sessions: sCount, sessionsMax: maxSessions, sessionsPct: pct sCount maxSessions, messages: mCount, messagesMax: maxMessages, messagesPct: pct mCount maxMessages, totalMessageCount: mCount, presence: pCount, presenceMax: maxPresenceEntries, presencePct: pct pCount maxPresenceEntries, forwards: fCount, forwardsMax: maxForwardsEntries, forwardsPct: pct fCount maxForwardsEntries, 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},
2202− federation: {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}},
2203− 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},
2204− 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}}))
2205−
2206−zeroStats : {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}}
2207−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}}
2493+handleStats : Text -> ({capacity: {ackOverflow: Int, ackOverflowMax: Int, ackedIds: Int, ackedIdsMax: Int, activePolls: Int, activePollsMax: Int, challenges: Int, challengesMax: Int, deliveredIds: Int, deliveredIdsMax: Int, forwardNonces: Int, forwardNoncesMax: Int, forwards: Int, forwardsMax: Int, forwardsPct: Int, messageBucketMax: Int, messageBucketMin: Int, messages: Int, messagesMax: Int, messagesPct: Int, nonceEvictions: Int, presence: Int, presenceMax: Int, presencePct: Int, recipientCounts: Int, sessions: Int, sessionsMax: Int, sessionsPct: Int, totalMessageCount: Int}, federation: {avgLatencyMs: Int, blockedPeers: Int, callCount: Int, drainCompletedAt: Timestamp, enabled: Bool, forwardFailures: Int, forwardServers: Int, gossipFail: Int, gossipSuccess: Int, hungSlots: Int, inFlight: Int, latencyBuckets: {gte2000: Int, lt100: Int, lt2000: Int, lt500: Int}, maxForwardQueueDepth: Int, maxLatencyMs: Int, oldestAckAge: Int, oldestForwardAge: Int, pendingCancels: Int, recentGossip: Int, slowVerifies: Int, topFailingPeers: [{failures: Int, server: Text}], verifyFailures: Int}, ok: Bool, rates: {challenge: Int, clientCancels: Int, federation: Int, federationCancels: Int, federationPair: Int, global: Int, gossipEvent: Int, ip: Int, lookup: Int, pair: Int, pendingAckCleanups: Int, recv: Int, rejectedAuth: Int, rejectedFederation: Int, rejectedGlobal: Int, rejectedIp: Int, rejectedPerKey: Int, send: Int, senderDeliveries: Int, senderExpirations: Int, uniqueKeyIp: Int, verifyIp: Int}, timing: {activeRequests: Int, authAvgMs: Int, authCount: Int, authMaxMs: Int, drainPhase: Int, draining: Bool, heartbeatCount: Int, lastHeartbeatAt: Timestamp, lastPruneAt: Timestamp, peakActiveRequests: Int, pollAvgMs: Int, pollCount: Int, pollLatencyBuckets: {gte1000: Int, lt1000: Int, lt200: Int, lt50: Int}, pollMaxMs: Int, pruneCount: Int, pruneRunning: Timestamp, sendAvgMs: Int, sendCount: Int, sendLatencyBuckets: {gte1000: Int, lt1000: Int, lt200: Int, lt50: Int}, sendMaxMs: Int, totalEntries: Int, uptime: Int}, version: Text} -> a) -> IO {reads *ackedIds, reads *activePolls, reads *blockedPeers, reads *challenges, reads *deliveredIds, reads *drainPhase, reads *forwards, reads *heartbeatCount, reads *lastHeartbeatAt, reads *lastPrunedAt, reads *messages, reads *pendingFederationCancels, reads *presence, reads *pruneCount, reads *runtimeMaintenanceSecret, reads *sessions, reads *startedAt, clock} a
2494+handleStats = \authorization respond -> withMaintAuth authorization (yield (respond zeroStats)) (do
2495+ t <- now
2496+ sa <- *startedAt
2497+ sessions <- *sessions
2498+ msgs <- *messages
2499+ pres <- *presence
2500+ fwds <- *forwards
2501+ aids <- *ackedIds
2502+ dids <- *deliveredIds
2503+ aps <- *activePolls
2504+ chs <- *challenges
2505+ bp <- *blockedPeers
2506+ pc <- *pruneCount
2507+ hc <- *heartbeatCount
2508+ lp <- *lastPrunedAt
2509+ lh <- *lastHeartbeatAt
2510+ dp <- *drainPhase
2511+ pfc <- *pendingFederationCancels
2512+ let sCount = count sessions
2513+ let mCount = count msgs
2514+ let pCount = count pres
2515+ let fCount = count fwds
2516+ yield (respond {
2517+ ok: True {},
2518+ version: serverBuildVersion,
2519+ capacity: {
2520+ sessions: sCount,
2521+ sessionsMax: maxSessions,
2522+ sessionsPct: pct sCount maxSessions,
2523+ messages: mCount,
2524+ messagesMax: maxMessages,
2525+ messagesPct: pct mCount maxMessages,
2526+ totalMessageCount: mCount,
2527+ presence: pCount,
2528+ presenceMax: maxPresenceEntries,
2529+ presencePct: pct pCount maxPresenceEntries,
2530+ forwards: fCount,
2531+ forwardsMax: maxForwardsEntries,
2532+ forwardsPct: pct fCount maxForwardsEntries,
2533+ challenges: count chs,
2534+ challengesMax: maxChallenges,
2535+ ackedIds: count aids,
2536+ ackedIdsMax: maxAckedIds,
2537+ ackOverflow: 0,
2538+ ackOverflowMax: 0,
2539+ deliveredIds: count dids,
2540+ deliveredIdsMax: maxDeliveredIds,
2541+ forwardNonces: 0,
2542+ forwardNoncesMax: 0,
2543+ nonceEvictions: 0,
2544+ activePolls: count aps,
2545+ activePollsMax: maxActivePolls,
2546+ recipientCounts: 0,
2547+ messageBucketMax: 0,
2548+ messageBucketMin: 0
2549+ },
2550+ federation: {
2551+ enabled: federationEnabled,
2552+ inFlight: 0,
2553+ hungSlots: 0,
2554+ avgLatencyMs: 0,
2555+ maxLatencyMs: 0,
2556+ callCount: 0,
2557+ slowVerifies: 0,
2558+ verifyFailures: 0,
2559+ forwardFailures: 0,
2560+ oldestForwardAge: 0,
2561+ oldestAckAge: 0,
2562+ recentGossip: 0,
2563+ blockedPeers: count bp,
2564+ drainCompletedAt: 0,
2565+ forwardServers: 0,
2566+ maxForwardQueueDepth: 0,
2567+ topFailingPeers: [],
2568+ pendingCancels: count pfc,
2569+ gossipSuccess: 0,
2570+ gossipFail: 0,
2571+ latencyBuckets: {lt100: 0, lt500: 0, lt2000: 0, gte2000: 0}
2572+ },
2573+ rates: {
2574+ send: 0,
2575+ challenge: 0,
2576+ federation: 0,
2577+ federationPair: 0,
2578+ global: 0,
2579+ ip: 0,
2580+ lookup: 0,
2581+ recv: 0,
2582+ pair: 0,
2583+ gossipEvent: 0,
2584+ verifyIp: 0,
2585+ uniqueKeyIp: 0,
2586+ pendingAckCleanups: 0,
2587+ senderExpirations: 0,
2588+ senderDeliveries: 0,
2589+ rejectedGlobal: 0,
2590+ rejectedIp: 0,
2591+ rejectedAuth: 0,
2592+ rejectedPerKey: 0,
2593+ rejectedFederation: 0,
2594+ clientCancels: 0,
2595+ federationCancels: 0
2596+ },
2597+ timing: {
2598+ pruneCount: pc,
2599+ pruneRunning: 0,
2600+ heartbeatCount: hc,
2601+ uptime: t - sa,
2602+ lastPruneAt: lp,
2603+ lastHeartbeatAt: lh,
2604+ draining: dp > 0,
2605+ drainPhase: dp,
2606+ totalEntries: sCount + mCount + pCount + fCount,
2607+ activeRequests: 0,
2608+ peakActiveRequests: 0,
2609+ pollAvgMs: 0,
2610+ pollMaxMs: 0,
2611+ pollCount: 0,
2612+ pollLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0},
2613+ sendAvgMs: 0,
2614+ sendMaxMs: 0,
2615+ sendCount: 0,
2616+ sendLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0},
2617+ authAvgMs: 0,
2618+ authMaxMs: 0,
2619+ authCount: 0
2620+ }
2621+ }))
2622+
2623+zeroStats : {capacity: {ackOverflow: Int, ackOverflowMax: Int, ackedIds: Int, ackedIdsMax: Int, activePolls: Int, activePollsMax: Int, challenges: Int, challengesMax: Int, deliveredIds: Int, deliveredIdsMax: Int, forwardNonces: Int, forwardNoncesMax: Int, forwards: Int, forwardsMax: Int, forwardsPct: Int, messageBucketMax: Int, messageBucketMin: Int, messages: Int, messagesMax: Int, messagesPct: Int, nonceEvictions: Int, presence: Int, presenceMax: Int, presencePct: Int, recipientCounts: Int, sessions: Int, sessionsMax: Int, sessionsPct: Int, totalMessageCount: Int}, federation: {avgLatencyMs: Int, blockedPeers: Int, callCount: Int, drainCompletedAt: Timestamp, enabled: Bool, forwardFailures: Int, forwardServers: Int, gossipFail: Int, gossipSuccess: Int, hungSlots: Int, inFlight: Int, latencyBuckets: {gte2000: Int, lt100: Int, lt2000: Int, lt500: Int}, maxForwardQueueDepth: Int, maxLatencyMs: Int, oldestAckAge: Int, oldestForwardAge: Int, pendingCancels: Int, recentGossip: Int, slowVerifies: Int, topFailingPeers: [{failures: Int, server: Text}], verifyFailures: Int}, ok: Bool, rates: {challenge: Int, clientCancels: Int, federation: Int, federationCancels: Int, federationPair: Int, global: Int, gossipEvent: Int, ip: Int, lookup: Int, pair: Int, pendingAckCleanups: Int, recv: Int, rejectedAuth: Int, rejectedFederation: Int, rejectedGlobal: Int, rejectedIp: Int, rejectedPerKey: Int, send: Int, senderDeliveries: Int, senderExpirations: Int, uniqueKeyIp: Int, verifyIp: Int}, timing: {activeRequests: Int, authAvgMs: Int, authCount: Int, authMaxMs: Int, drainPhase: Int, draining: Bool, heartbeatCount: Int, lastHeartbeatAt: Timestamp, lastPruneAt: Timestamp, peakActiveRequests: Int, pollAvgMs: Int, pollCount: Int, pollLatencyBuckets: {gte1000: Int, lt1000: Int, lt200: Int, lt50: Int}, pollMaxMs: Int, pruneCount: Int, pruneRunning: Timestamp, sendAvgMs: Int, sendCount: Int, sendLatencyBuckets: {gte1000: Int, lt1000: Int, lt200: Int, lt50: Int}, sendMaxMs: Int, totalEntries: Int, uptime: Int}, version: Text}
2624+zeroStats = {
2625+ ok: False {},
2626+ version: serverBuildVersion,
2627+ capacity: {
2628+ sessions: 0,
2629+ sessionsMax: 0,
2630+ sessionsPct: 0,
2631+ messages: 0,
2632+ messagesMax: 0,
2633+ messagesPct: 0,
2634+ totalMessageCount: 0,
2635+ presence: 0,
2636+ presenceMax: 0,
2637+ presencePct: 0,
2638+ forwards: 0,
2639+ forwardsMax: 0,
2640+ forwardsPct: 0,
2641+ challenges: 0,
2642+ challengesMax: 0,
2643+ ackedIds: 0,
2644+ ackedIdsMax: 0,
2645+ ackOverflow: 0,
2646+ ackOverflowMax: 0,
2647+ deliveredIds: 0,
2648+ deliveredIdsMax: 0,
2649+ forwardNonces: 0,
2650+ forwardNoncesMax: 0,
2651+ nonceEvictions: 0,
2652+ activePolls: 0,
2653+ activePollsMax: 0,
2654+ recipientCounts: 0,
2655+ messageBucketMax: 0,
2656+ messageBucketMin: 0
2657+ },
2658+ federation: {
2659+ enabled: False {},
2660+ inFlight: 0,
2661+ hungSlots: 0,
2662+ avgLatencyMs: 0,
2663+ maxLatencyMs: 0,
2664+ callCount: 0,
2665+ slowVerifies: 0,
2666+ verifyFailures: 0,
2667+ forwardFailures: 0,
2668+ oldestForwardAge: 0,
2669+ oldestAckAge: 0,
2670+ recentGossip: 0,
2671+ blockedPeers: 0,
2672+ drainCompletedAt: 0,
2673+ forwardServers: 0,
2674+ maxForwardQueueDepth: 0,
2675+ topFailingPeers: [],
2676+ pendingCancels: 0,
2677+ gossipSuccess: 0,
2678+ gossipFail: 0,
2679+ latencyBuckets: {lt100: 0, lt500: 0, lt2000: 0, gte2000: 0}
2680+ },
2681+ rates: {
2682+ send: 0,
2683+ challenge: 0,
2684+ federation: 0,
2685+ federationPair: 0,
2686+ global: 0,
2687+ ip: 0,
2688+ lookup: 0,
2689+ recv: 0,
2690+ pair: 0,
2691+ gossipEvent: 0,
2692+ verifyIp: 0,
2693+ uniqueKeyIp: 0,
2694+ pendingAckCleanups: 0,
2695+ senderExpirations: 0,
2696+ senderDeliveries: 0,
2697+ rejectedGlobal: 0,
2698+ rejectedIp: 0,
2699+ rejectedAuth: 0,
2700+ rejectedPerKey: 0,
2701+ rejectedFederation: 0,
2702+ clientCancels: 0,
2703+ federationCancels: 0
2704+ },
2705+ timing: {
2706+ pruneCount: 0,
2707+ pruneRunning: 0,
2708+ heartbeatCount: 0,
2709+ uptime: 0,
2710+ lastPruneAt: 0,
2711+ lastHeartbeatAt: 0,
2712+ draining: False {},
2713+ drainPhase: 0,
2714+ totalEntries: 0,
2715+ activeRequests: 0,
2716+ peakActiveRequests: 0,
2717+ pollAvgMs: 0,
2718+ pollMaxMs: 0,
2719+ pollCount: 0,
2720+ pollLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0},
2721+ sendAvgMs: 0,
2722+ sendMaxMs: 0,
2723+ sendCount: 0,
2724+ sendLatencyBuckets: {lt50: 0, lt200: 0, lt1000: 0, gte1000: 0},
2725+ authAvgMs: 0,
2726+ authMaxMs: 0,
2727+ authCount: 0
2728+ }
2729+}
22082730
22092731-- GET /stats/peers: per-peer failure summary derived from `forwardFailures`,
22102732-- including current backoff and pending forward queue depth.
2211−handleStatsPeers : Text -> ({peers: [PeerStatus], ok: Bool} -> ret) -> IO {} ret
2212−handleStatsPeers = \authorization respond -> withMaintAuth authorization
2213− (yield (respond {peers: [], ok: False {}}))
2214− (do
2215− t <- now
2216− failures <- *forwardFailures
2217− fwds <- *forwards
2218− yield (respond {peers: pluck failures (\f ->
2219− {server: f.server, failures: f.failures, lastFailedAt: f.failedAt, firstFailedAt: f.firstFailedAt, backoffMs: retryBackoff f.failures, retriable: shouldRetryServer f.server t failures, pendingForwards: countWhere fwds (\x -> x.toServer == f.server), avgLatencyMs: 0, maxLatencyMs: 0, latencySamples: 0, gossipEventsPerMin: 0}), ok: True {}}))
2733+handleStatsPeers : Text -> ({ok: Bool, peers: [{avgLatencyMs: Int, backoffMs: Int<Ms>, failures: Int, firstFailedAt: Int<Ms>, gossipEventsPerMin: Int, lastFailedAt: Int<Ms>, latencySamples: Int, maxLatencyMs: Int, pendingForwards: Int, retriable: Bool, server: Text}]} -> a) -> IO {reads *forwardFailures, reads *forwards, reads *runtimeMaintenanceSecret, clock} a
2734+handleStatsPeers = \authorization respond -> withMaintAuth authorization (yield (respond {
2735+ peers: [],
2736+ ok: False {}
2737+})) (do
2738+ t <- now
2739+ failures <- *forwardFailures
2740+ fwds <- *forwards
2741+ yield (respond {
2742+ peers: pluck failures (\f -> {
2743+ f.server,
2744+ f.failures,
2745+ lastFailedAt: f.failedAt,
2746+ f.firstFailedAt,
2747+ backoffMs: retryBackoff f.failures,
2748+ retriable: shouldRetryServer f.server t failures,
2749+ pendingForwards: countWhere fwds (\x -> x.toServer == f.server),
2750+ avgLatencyMs: 0,
2751+ maxLatencyMs: 0,
2752+ latencySamples: 0,
2753+ gossipEventsPerMin: 0
2754+ }),
2755+ ok: True {}
2756+ }))
22202757
22212758-- GET /stats/key/{pubkey}: per-key footprint — message count, presence rows,
22222759-- session count, queued forwards (with details), and active long-poll count.
2223−handleStatsKey : PubkeyHex -> Text -> ({messages: Int, presence: [KeyPresenceEntry], sessions: Int, forwards: Int, forwardDetails: [{server: Text, retries: Int, createdAt: Timestamp}], activePolls: Int, ok: Bool} -> ret) -> IO {} ret
2224−handleStatsKey = \pubkey authorization respond -> withMaintAuth authorization
2225− (yield (respond {messages: 0, presence: [], sessions: 0, forwards: 0, forwardDetails: [], activePolls: 0, ok: False {}}))
2226− (do
2227− t <- now
2228− msgs <- *messages
2229− pres <- *presence
2230− ses <- *sessions
2231− fwds <- *forwards
2232− aps <- *activePolls
2233− let myFwds = filter fwds (\x -> x.toKey == pubkey)
2234− yield (respond {
2235− messages: countWhere msgs (\x -> x.toKey == pubkey),
2236− presence: mapWhere pres (\x -> x.pubkey == pubkey && x.expiresAt > t) (\x -> {server: x.server, expiresAt: x.expiresAt}),
2237− sessions: countWhere ses (\x -> x.pubkey == pubkey),
2238− forwards: count myFwds,
2239− forwardDetails: pluck myFwds (\x -> {server: x.toServer, retries: x.retries, createdAt: x.createdAt}),
2240− activePolls: countWhere aps (\x -> x.pubkey == pubkey),
2241− ok: True {}}))
2760+handleStatsKey : PubkeyHex -> Text -> ({activePolls: Int, forwardDetails: [{createdAt: Int<Ms>, retries: Int, server: ServerName}], forwards: Int, messages: Int, ok: Bool, presence: [{expiresAt: Int<Ms>, server: AnyServerName}], sessions: Int} -> a) -> IO {reads *activePolls, reads *forwards, reads *messages, reads *presence, reads *runtimeMaintenanceSecret, reads *sessions, clock} a
2761+handleStatsKey = \pubkey authorization respond -> withMaintAuth authorization (yield (respond {
2762+ messages: 0,
2763+ presence: [],
2764+ sessions: 0,
2765+ forwards: 0,
2766+ forwardDetails: [],
2767+ activePolls: 0,
2768+ ok: False {}
2769+})) (do
2770+ t <- now
2771+ msgs <- *messages
2772+ pres <- *presence
2773+ ses <- *sessions
2774+ fwds <- *forwards
2775+ aps <- *activePolls
2776+ let myFwds = filter fwds (\x -> x.toKey == pubkey)
2777+ yield (respond {
2778+ messages: countWhere msgs (\x -> x.toKey == pubkey),
2779+ presence: mapWhere pres (\x -> x.pubkey == pubkey && x.expiresAt > t) (\x -> {
2780+ x.server,
2781+ x.expiresAt
2782+ }),
2783+ sessions: countWhere ses (\x -> x.pubkey == pubkey),
2784+ forwards: count myFwds,
2785+ forwardDetails: pluck myFwds (\x -> {server: x.toServer, x.retries, x.createdAt}),
2786+ activePolls: countWhere aps (\x -> x.pubkey == pubkey),
2787+ ok: True {}
2788+ }))
22422789
22432790-- POST /stats/top-recipients: ranked list of pubkeys by mailbox depth.
22442791-- `limit` defaults to 20, capped at 100, used to spot hot-spots / abuse.
2245−handleTopRecipients : Int -> Text -> ({recipients: [RecipientCount], ok: Bool, total: Int} -> ret) -> IO {} ret
2246−handleTopRecipients = \limit authorization respond -> withMaintAuth authorization
2247− (yield (respond {recipients: [], ok: False {}, total: 0}))
2248− (do
2249− msgs <- *messages
2250− let counts = pluck (unique (pluck msgs (\m -> m.toKey))) (\pk -> {pubkey: pk, count: countWhere msgs (\m -> m.toKey == pk)})
2251− let cap = clamp 1 100 (if limit <= 0 then 20 else limit)
2252− let top = takeRelation cap (sortBy (\c -> 0 - c.count) counts)
2253− yield (respond {recipients: top, ok: True {}, total: count counts}))
2792+handleTopRecipients : Int -> Text -> ({ok: Bool, recipients: [{count: Int, pubkey: PubkeyHex}], total: Int} -> a) -> IO {reads *messages, reads *runtimeMaintenanceSecret} a
2793+handleTopRecipients = \limit authorization respond -> withMaintAuth authorization (yield (respond {
2794+ recipients: [],
2795+ ok: False {},
2796+ total: 0
2797+})) (do
2798+ msgs <- *messages
2799+ let counts = pluck (unique (pluck msgs (\m -> m.toKey))) (\pk -> {
2800+ pubkey: pk,
2801+ count: countWhere msgs (\m -> m.toKey == pk)
2802+ })
2803+ let cap = clamp 1 100 (if limit <= 0 then 20 else limit)
2804+ let top = takeRelation cap (sortBy (\c -> 0 - c.count) counts)
2805+ yield (respond {recipients: top, ok: True {}, total: count counts}))
22542806
22552807-- GET /stats/forwards: per-destination forward queue summary — count, age of
22562808-- oldest pending entry, and total accumulated retries.
2257−handleStatsForwards : Text -> ({servers: [{server: Text, count: Int, oldestAge: Int, totalRetries: Int}], ok: Bool, total: Int} -> ret) -> IO {} ret
2258−handleStatsForwards = \authorization respond -> withMaintAuth authorization
2259− (yield (respond {servers: [], ok: False {}, total: 0}))
2260− (do
2261− t <- now
2262− fwds <- *forwards
2263− yield (respond {
2264− servers: pluck (collectPeers fwds (\f -> f.toServer)) (\s ->
2265− let svFwds = filter fwds (\f -> f.toServer == s) in
2266− {server: s, count: count svFwds, oldestAge: t - fold (\acc f -> min acc f.createdAt) t svFwds, totalRetries: fold (\acc f -> acc + f.retries) 0 svFwds}),
2267− ok: True {},
2268− total: count fwds}))
2809+handleStatsForwards : Text -> ({ok: Bool, servers: [{count: Int<u>, oldestAge: Int<Ms>, server: ServerName, totalRetries: Int}], total: Int} -> a) -> IO {reads *forwards, reads *runtimeMaintenanceSecret, clock} a
2810+handleStatsForwards = \authorization respond -> withMaintAuth authorization (yield (respond {
2811+ servers: [],
2812+ ok: False {},
2813+ total: 0
2814+})) (do
2815+ t <- now
2816+ fwds <- *forwards
2817+ yield (respond {
2818+ servers: pluck (collectPeers fwds (\f -> f.toServer)) (\s -> (\svFwds -> {server: s, count: count svFwds, oldestAge: t - fold (\acc f -> min acc f.createdAt) t svFwds, totalRetries: fold (\acc f -> acc + f.retries) 0 svFwds}) (filter fwds (\f -> f.toServer == s))),
2819+ ok: True {},
2820+ total: count fwds
2821+ }))
22692822
22702823-- GET /stats/rates: same shape as /maintenance/rate-limits with an extra
22712824-- scalePct field. Kept separate for backwards compatibility with older clients.
2272−handleStatsRates : Text -> ({ok: Bool, scalePct: Int, globalRequest: Int, ipRate: Int, sendRate: Int, federationRate: Int, authGlobal: Int, recvRate: Int, challengeRate: Int, pairRate: Int, lookupRate: Int, clientWriteRate: Int} -> ret) -> IO {} ret
2825+handleStatsRates : Text -> ({authGlobal: Int, challengeRate: Int, clientWriteRate: Int, federationRate: Int, globalRequest: Int, ipRate: Int, lookupRate: Int, ok: Bool, pairRate: Int, recvRate: Int, scalePct: Int, sendRate: Int} -> a) -> IO {reads *runtimeMaintenanceSecret} a
22732826handleStatsRates = \authorization respond -> do
22742827 ok <- verifyMaintenanceAuth authorization
22752828 let v = \x -> if ok then x else 0
2276− yield (respond {ok: ok, scalePct: v 100, globalRequest: v maxGlobalRequestRate, ipRate: v maxIpRatePerIp, sendRate: v maxSendRatePerKey, federationRate: v maxFederationRatePerServer, authGlobal: v maxAuthGlobalRate, recvRate: v maxRecvRatePerKey, challengeRate: v maxChallengeRatePerKey, pairRate: v maxPairRatePerPair, lookupRate: v maxLookupRatePerKey, clientWriteRate: v maxClientWriteRatePerKey})
2829+ yield (respond {
2830+ ok,
2831+ scalePct: v 100,
2832+ globalRequest: v maxGlobalRequestRate,
2833+ ipRate: v maxIpRatePerIp,
2834+ sendRate: v maxSendRatePerKey,
2835+ federationRate: v maxFederationRatePerServer,
2836+ authGlobal: v maxAuthGlobalRate,
2837+ recvRate: v maxRecvRatePerKey,
2838+ challengeRate: v maxChallengeRatePerKey,
2839+ pairRate: v maxPairRatePerPair,
2840+ lookupRate: v maxLookupRatePerKey,
2841+ clientWriteRate: v maxClientWriteRatePerKey
2842+ })
22772843
22782844-- GET /metrics: Prometheus-style text exposition of the most useful gauges.
22792845-- The `authorization` header is accepted but not validated here — operators
22802846-- relying on auth must front this endpoint with a reverse proxy that enforces it.
2281−handleMetrics : Text -> ({metrics: Text, ok: Bool} -> ret) -> IO {} ret
2847+handleMetrics : a -> ({metrics: Text, ok: Bool} -> b) -> IO {reads *activePolls, reads *drainPhase, reads *forwards, reads *messages, reads *presence, reads *sessions, reads *startedAt, clock} b
22822848handleMetrics = \authorization respond -> do
22832849 t <- now
22842850 msgs <- *messages
@@ -2288,14 +2854,18 @@ handleMetrics = \authorization respond -> do
22882854 aps <- *activePolls
22892855 sa <- *startedAt
22902856 dp <- *drainPhase
2291− yield (respond {metrics: fold (\acc r -> acc ++ r.k ++ " " ++ show r.v ++ "\n") "" [
2292− {k: "skrepka_messages_total", v: count msgs},
2293− {k: "skrepka_sessions_total", v: count ses},
2294− {k: "skrepka_presence_total", v: count pres},
2295− {k: "skrepka_forwards_total", v: count fwds},
2296− {k: "skrepka_active_polls", v: count aps},
2297− {k: "skrepka_uptime_seconds", v: (t - sa) / 1000},
2298− {k: "skrepka_draining", v: if dp > 0 then 1 else 0}], ok: True {}})
2857+ yield (respond {
2858+ metrics: fold (\acc r -> acc ++ r.k ++ " " ++ show r.v ++ "\n") "" [
2859+ {k: "skrepka_messages_total", v: count msgs},
2860+ {k: "skrepka_sessions_total", v: count ses},
2861+ {k: "skrepka_presence_total", v: count pres},
2862+ {k: "skrepka_forwards_total", v: count fwds},
2863+ {k: "skrepka_active_polls", v: count aps},
2864+ {k: "skrepka_uptime_seconds", v: (t - sa) / 1000},
2865+ {k: "skrepka_draining", v: if dp > 0 then 1 else 0}
2866+ ],
2867+ ok: True {}
2868+ })
22992869
23002870-- ============================================
23012871-- Dispatch
@@ -2304,7 +2874,7 @@ handleMetrics = \authorization respond -> do
23042874-- to the corresponding `handleXxx` function. Adding a new route means adding
23052875-- a `route ... = NewReq` line, a `handleNewReq` definition, and a clause here.
23062876
2307−serve : Api -> IO {network} Response
2877+serve : <AckMessages {authorization: Text, clientIp: Text, messageIds: [MessageIdHex], respond: {ackedCount: Int, authorized: Bool, error: Text, ok: Bool} -> Response} | AdminListAllSessions {authorization: Text, limit: Int, respond: {ok: Bool, sessions: [{count: Int, ips: [Text], latestExpiry: Timestamp, pubkey: PubkeyHex}], total: Int} -> Response} | AdminListSessions {authorization: Text, pubkey: PubkeyHex, respond: {count: Int, ok: Bool, sessions: [{createdAt: Timestamp, expiresAt: Timestamp, ip: Text, token: Text}]} -> Response} | AdminPurgeMessages {authorization: Text, pubkey: PubkeyHex, respond: {ok: Bool, purgedCount: Int} -> Response} | AdminRevokeIp {authorization: Text, ip: Text, respond: {affectedKeys: Int, ok: Bool, revokedCount: Int} -> Response} | AdminRevokeSessions {authorization: Text, pubkey: PubkeyHex, respond: {ok: Bool, revokedCount: Int} -> Response} | AllowPeer {authorization: Text, respond: {allowed: Int, ok: Bool} -> Response, server: ServerName} | BatchLookupPresence {authorization: Text, clientIp: Text, pubkeys: [PubkeyHex], respond: {authorized: Bool, error: Text, results: [{pubkey: PubkeyHex, server: AnyServerName}]} -> Response} | BlockPeer {authorization: Text, respond: {blocked: Int, ok: Bool} -> Response, server: ServerName} | CancelBatch {authorization: Text, cancels: [BatchCancelEntry], clientIp: Text, respond: {authorized: Bool, error: Text, results: [BatchCancelResult]} -> Response} | CancelMessage {authorization: Text, clientIp: Text, messageId: MessageIdHex, respond: {authorized: Bool, cancelled: Bool, error: Text, ok: Bool} -> Response, to: PubkeyHex} | DeleteMessages {authorization: Text, clientIp: Text, messageIds: [MessageIdHex], respond: {authorized: Bool, deletedCount: Int, error: Text, ok: Bool} -> Response} | Drain {authorization: Text, phase: Int, respond: {drained: Int, ok: Bool, phase: Int} -> Response} | FederationAck {authorization: Text, correlationId: Text, fromServer: ServerName, messageIds: [MessageIdHex], originServer: ServerName, protocolVersion: Int, requestTimestamp: Timestamp, respond: {ackedCount: Int, error: Text, ok: Bool, results: [{found: Bool, messageId: MessageIdHex}], retryAfterMs: Int} -> Response} | FederationBatchCancel {authorization: Text, cancels: [{messageId: MessageIdHex, toKey: PubkeyHex}], correlationId: Text, fromServer: ServerName, protocolVersion: Int, requestTimestamp: Timestamp, respond: {error: Text, ok: Bool, results: [BatchCancelResult], retryAfterMs: Int} -> Response} | FederationBatchForward {authorization: Text, correlationId: Text, forwards: [{encryptedBlob: BlobHex, expiresAt: Timestamp, messageId: MessageIdHex, originServer: ServerName, priority: Int, timestamp: Timestamp, toKey: PubkeyHex}], fromServer: ServerName, protocolVersion: Int, requestTimestamp: Timestamp, respond: {error: Text, ok: Bool, results: [{messageId: MessageIdHex, ok: Bool}], retryAfterMs: Int} -> Response} | FederationCancel {authorization: Text, correlationId: Text, fromServer: ServerName, messageId: MessageIdHex, protocolVersion: Int, requestTimestamp: Timestamp, respond: {cancelled: Bool, error: Text, ok: Bool, retryAfterMs: Int} -> Response, toKey: PubkeyHex} | FederationDeliveryReceipt {authorization: Text, correlationId: Text, fromServer: ServerName, messageIds: [MessageIdHex], protocolVersion: Int, requestTimestamp: Timestamp, respond: {error: Text, ok: Bool, receivedCount: Int, retryAfterMs: Int} -> Response, toKeys: [PubkeyHex]} | FederationPubkey {respond: {ok: Bool, pubkey: Text} -> Response} | FlushNonces {authorization: Text, respond: {flushedCount: Int, ok: Bool} -> Response} | ForwardMessage {authorization: Text, correlationId: Text, encryptedBlob: BlobHex, expiresAt: Timestamp, fromServer: ServerName, messageId: MessageIdHex, originServer: ServerName, priority: Int, protocolVersion: Int, requestTimestamp: Timestamp, respond: {error: Text, ok: Bool, retryAfterMs: Int} -> Response, timestamp: Timestamp, toKey: PubkeyHex} | GetConfig {authorization: Text, respond: {ackGracePeriod: Int, maxGossipHops: Int, maxMessagesPerRecipient: Int, ok: Bool, pollTimeoutMs: Int} -> Response} | GetRateLimits {authorization: Text, respond: {authGlobal: Int, challengeRate: Int, clientWriteRate: Int, federationRate: Int, globalRequest: Int, ipRate: Int, lookupRate: Int, ok: Bool, pairRate: Int, recvRate: Int, sendRate: Int} -> Response} | Health {authorization: Text, respond: {capacityHealthy: Bool, capacityWarning: Bool, degradedPeers: Int, draining: Bool, federationHealthy: Bool, forwardQueueHealthy: Bool, heartbeatHealthy: Bool, nonceHealthy: Bool, ok: Bool, pruneHealthy: Bool, requestPressureHealthy: Bool, version: Text, watchdogHealthy: Bool} -> Response} | ListAllowed {authorization: Text, respond: {ok: Bool, peers: [Text]} -> Response} | ListBlocked {authorization: Text, respond: {ok: Bool, peers: [Text]} -> Response} | ListMessages {authorization: Text, clientIp: Text, offset: Int, respond: {authorized: Bool, count: Int, error: Text, messages: [{messageId: MessageIdHex, receivedAt: Timestamp, timestamp: Timestamp}]} -> Response} | Logout {authorization: Text, clientIp: Text, respond: {authorized: Bool, ok: Bool} -> Response} | LookupPresence {authorization: Text, clientIp: Text, pubkey: PubkeyHex, respond: {authorized: Bool, error: Text, server: AnyServerName} -> Response} | MessageStatus {authorization: Text, clientIp: Text, messageId: MessageIdHex, respond: {authorized: Bool, status: Text} -> Response, to: PubkeyHex} | Metrics {authorization: Text, respond: {metrics: Text, ok: Bool} -> Response} | PingPeer {authorization: Text, respond: {error: Text, latencyMs: Int, ok: Bool} -> Response, server: ServerName} | Poll {authorization: Text, clientIp: Text, cursor: Timestamp, generation: Int, respond: {authorized: Bool, cursor: Timestamp, cursorReset: Bool, cursorStale: Bool, draining: Bool, droppedDeliveryReceipts: Int, droppedExpirationNotifs: Int, events: [PollEvent], generation: Int, hasMore: Bool, heartbeat: Bool, loadPct: Int, messageCancellations: [{cancelledAt: Timestamp, messageId: MessageIdHex}], messageDeliveries: [{deliveredAt: Timestamp, messageId: MessageIdHex, toKey: PubkeyHex}], messageExpirations: [{expiredAt: Timestamp, messageId: MessageIdHex, toKey: PubkeyHex}], presenceUpdates: [{online: Bool, pubkey: PubkeyHex}], rateLimited: Bool, retryAfterMs: Int} -> Response, watchKeys: [PubkeyHex]} | Prune {authorization: Text, respond: {ok: Bool} -> Response} | Ready {respond: {ready: Bool} -> Response} | Reconcile {authorization: Text, respond: {messageDrift: Int, ok: Bool, presenceDrift: Int, sessionDrift: Int} -> Response} | RecvGossip {authorization: Text, correlationId: Text, events: [GossipEvent], fromServer: ServerName, hopsRemaining: Int, protocolVersion: Int, requestTimestamp: Timestamp, respond: {error: Text, ok: Bool, retryAfterMs: Int} -> Response} | ReqChallenge {clientIp: Text, pubkey: PubkeyHex, respond: {challenge: Text, error: Text, expiresAt: Timestamp, ok: Bool, retryAfterMs: Int} -> Response} | RevokeSession {authorization: Text, clientIp: Text, respond: {authorized: Bool, ok: Bool} -> Response, targetToken: Text} | RotateSecret {authorization: Text, newSecret: Text, respond: {error: Text, ok: Bool} -> Response} | SendBatch {authorization: Text, clientIp: Text, messages: [BatchMessage], respond: {authorized: Bool, results: [BatchResult], retryAfterMs: Int} -> Response} | SendMessage {authorization: Text, clientIp: Text, encryptedBlob: BlobHex, expiresInMs: Int, messageId: OptionalMessageId, priority: Int, respond: {error: Text, loadPct: Int, messageId: OptionalMessageId, retryAfterMs: Int, status: MessageStatus} -> Response, timestamp: Timestamp, to: PubkeyHex} | SetRateLimits {authGlobal: Int, authorization: Text, challengeRate: Int, clientWriteRate: Int, federationRate: Int, globalRequest: Int, ipRate: Int, lookupRate: Int, pairRate: Int, recvRate: Int, respond: {ok: Bool} -> Response, sendRate: Int} | Shutdown {authorization: Text, respond: {drained: Int, ok: Bool} -> Response} | Stats {authorization: Text, respond: {capacity: {ackOverflow: Int, ackOverflowMax: Int, ackedIds: Int, ackedIdsMax: Int, activePolls: Int, activePollsMax: Int, challenges: Int, challengesMax: Int, deliveredIds: Int, deliveredIdsMax: Int, forwardNonces: Int, forwardNoncesMax: Int, forwards: Int, forwardsMax: Int, forwardsPct: Int, messageBucketMax: Int, messageBucketMin: Int, messages: Int, messagesMax: Int, messagesPct: Int, nonceEvictions: Int, presence: Int, presenceMax: Int, presencePct: Int, recipientCounts: Int, sessions: Int, sessionsMax: Int, sessionsPct: Int, totalMessageCount: Int}, federation: {avgLatencyMs: Int, blockedPeers: Int, callCount: Int, drainCompletedAt: Timestamp, enabled: Bool, forwardFailures: Int, forwardServers: Int, gossipFail: Int, gossipSuccess: Int, hungSlots: Int, inFlight: Int, latencyBuckets: {gte2000: Int, lt100: Int, lt2000: Int, lt500: Int}, maxForwardQueueDepth: Int, maxLatencyMs: Int, oldestAckAge: Int, oldestForwardAge: Int, pendingCancels: Int, recentGossip: Int, slowVerifies: Int, topFailingPeers: [{failures: Int, server: Text}], verifyFailures: Int}, ok: Bool, rates: {challenge: Int, clientCancels: Int, federation: Int, federationCancels: Int, federationPair: Int, global: Int, gossipEvent: Int, ip: Int, lookup: Int, pair: Int, pendingAckCleanups: Int, recv: Int, rejectedAuth: Int, rejectedFederation: Int, rejectedGlobal: Int, rejectedIp: Int, rejectedPerKey: Int, send: Int, senderDeliveries: Int, senderExpirations: Int, uniqueKeyIp: Int, verifyIp: Int}, timing: {activeRequests: Int, authAvgMs: Int, authCount: Int, authMaxMs: Int, drainPhase: Int, draining: Bool, heartbeatCount: Int, lastHeartbeatAt: Timestamp, lastPruneAt: Timestamp, peakActiveRequests: Int, pollAvgMs: Int, pollCount: Int, pollLatencyBuckets: {gte1000: Int, lt1000: Int, lt200: Int, lt50: Int}, pollMaxMs: Int, pruneCount: Int, pruneRunning: Timestamp, sendAvgMs: Int, sendCount: Int, sendLatencyBuckets: {gte1000: Int, lt1000: Int, lt200: Int, lt50: Int}, sendMaxMs: Int, totalEntries: Int, uptime: Int}, version: Text} -> Response} | StatsForwards {authorization: Text, respond: {ok: Bool, servers: [{count: Int, oldestAge: Int, server: Text, totalRetries: Int}], total: Int} -> Response} | StatsKey {authorization: Text, pubkey: PubkeyHex, respond: {activePolls: Int, forwardDetails: [{createdAt: Timestamp, retries: Int, server: Text}], forwards: Int, messages: Int, ok: Bool, presence: [KeyPresenceEntry], sessions: Int} -> Response} | StatsPeers {authorization: Text, respond: {ok: Bool, peers: [PeerStatus]} -> Response} | StatsRates {authorization: Text, respond: {authGlobal: Int, challengeRate: Int, clientWriteRate: Int, federationRate: Int, globalRequest: Int, ipRate: Int, lookupRate: Int, ok: Bool, pairRate: Int, recvRate: Int, scalePct: Int, sendRate: Int} -> Response} | TopRecipients {authorization: Text, limit: Int, respond: {ok: Bool, recipients: [RecipientCount], total: Int} -> Response} | UnallowPeer {authorization: Text, respond: {ok: Bool, removed: Bool} -> Response, server: ServerName} | UnblockPeer {authorization: Text, respond: {ok: Bool, unblocked: Bool} -> Response, server: ServerName} | Undrain {authorization: Text, respond: {ok: Bool} -> Response} | VerifyAuth {challenge: Text, clientIp: Text, pubkey: PubkeyHex, respond: {error: Text, expiresAt: Timestamp, token: Text} -> Response, revokeOthers: Bool, signature: SignatureHex} | VerifyToken {clientIp: Text, respond: {ok: Bool} -> Response, scope: Text, token: Text}> -> IO {reads *ackedIds, reads *activePolls, reads *allowedPeers, reads *authGlobalRateCount, reads *authGlobalRateWindowStart, reads *blockedPeers, reads *cancelNotifications, reads *challengeRates, reads *challenges, reads *deliveredIds, reads *drainCompletedAt, reads *drainPhase, reads *federationRates, reads *forwardFailures, reads *forwards, reads *globalRateCount, reads *globalRateWindowStart, reads *heartbeatCount, reads *ipRates, reads *lastHeartbeatAt, reads *lastPresenceRefresh, reads *lastPrunedAt, reads *messages, reads *pendingFederationCancels, reads *pendingVerifications, reads *pollWakeup, reads *presence, reads *pruneCount, reads *recvRates, reads *runtimeMaintenanceSecret, reads *senderDeliveries, reads *senderExpirations, reads *seqCounter, reads *serverGeneration, reads *sessions, reads *startedAt, writes *ackedIds, writes *activePolls, writes *allowedPeers, writes *authGlobalRateCount, writes *authGlobalRateWindowStart, writes *blockedPeers, writes *cancelNotifications, writes *challengeRates, writes *challenges, writes *deliveredIds, writes *drainCompletedAt, writes *drainPhase, writes *federationRates, writes *forwardFailures, writes *forwards, writes *globalRateCount, writes *globalRateWindowStart, writes *ipRates, writes *lastPresenceRefresh, writes *lastPrunedAt, writes *messages, writes *pendingFederationCancels, writes *pendingVerifications, writes *pollWakeup, writes *presence, writes *recvRates, writes *runtimeMaintenanceSecret, writes *senderDeliveries, writes *senderExpirations, writes *seqCounter, writes *sessions, network, clock, random} Response
23082878serve = \req -> case req of
23092879 ReqChallenge {pubkey, clientIp, respond} -> handleChallenge pubkey clientIp respond
23102880 VerifyAuth {pubkey, challenge, signature, revokeOthers, clientIp, respond} -> handleVerifyAuth pubkey challenge signature revokeOthers clientIp respond
@@ -2370,27 +2940,21 @@ serve = \req -> case req of
23702940-- `pollTimeoutMs` so long-poll holders unblock and return an empty heartbeat
23712941-- response, keeping connections fresh.
23722942
2373−backgroundPrune : IO {network} {}
2943+backgroundPrune : IO {reads *drainPhase, clock, reads *ackedIds, reads *activePolls, reads *blockedPeers, reads *cancelNotifications, reads *challenges, reads *deliveredIds, reads *forwardFailures, reads *forwards, reads *lastPresenceRefresh, reads *lastPrunedAt, reads *messages, reads *pendingFederationCancels, reads *pendingVerifications, reads *presence, reads *pruneCount, reads *senderDeliveries, reads *senderExpirations, reads *sessions, writes *ackedIds, writes *activePolls, writes *cancelNotifications, writes *challenges, writes *deliveredIds, writes *forwardFailures, writes *forwards, writes *lastPresenceRefresh, writes *lastPrunedAt, writes *messages, writes *pendingFederationCancels, writes *pendingVerifications, writes *presence, writes *pruneCount, writes *senderDeliveries, writes *senderExpirations, writes *sessions} a
23742944backgroundPrune = do
23752945 sleep backgroundPruneInterval
23762946 dp <- *drainPhase
23772947 when (dp < 2) (do
23782948 t <- now
2379− atomic do
2380− pc <- *pruneCount
2381− set *pruneCount = pc + 1
2949+ atomic (do pc <- *pruneCount; *pruneCount = pc + 1)
23822950 pruneAndRetry t)
23832951 backgroundPrune
23842952
2385−pollHeartbeat : IO {} {}
2953+pollHeartbeat : IO {reads *heartbeatCount, reads *lastHeartbeatAt, reads *pollWakeup, writes *heartbeatCount, writes *lastHeartbeatAt, writes *pollWakeup, clock} a
23862954pollHeartbeat = do
23872955 sleep pollTimeoutMs
23882956 t <- now
2389− atomic do
2390− set *pollWakeup = t
2391− set *lastHeartbeatAt = t
2392− hc <- *heartbeatCount
2393− set *heartbeatCount = hc + 1
2957+ atomic (do *pollWakeup = t; *lastHeartbeatAt = t; hc <- *heartbeatCount; *heartbeatCount = hc + 1)
23942958 pollHeartbeat
23952959
23962960-- ============================================
@@ -2400,15 +2964,13 @@ pollHeartbeat = do
24002964-- server restarts and reset their poll cursor), spawn the two background
24012965-- loops, and start the listener.
24022966
2403−main : IO {network} {}
2967+main : IO {| _} {}
24042968main = do
24052969 t <- now
24062970 genJitter <- randomInt 1000000
2407− atomic do
2408− set *startedAt = t
2409− set *serverGeneration = t * 1000 + genJitter
2971+ atomic (do *startedAt = t; *serverGeneration = t * 1000 + genJitter)
24102972 logInfo ("Skrepka relay server starting on port " ++ show listenPort ++ "...")
2411− logInfo (" federation: " ++ if federationEnabled then "enabled" else "disabled")
2973+ logInfo (" federation: " ++ (if federationEnabled then "enabled" else "disabled"))
24122974 fork backgroundPrune
24132975 fork pollHeartbeat
24142976 listen listenPort serve