1-- Skrepka Relay Server (maximally simplified)
2-- Single-server implementation of the Skrepka protocol (v0.1).
3-- Every collection is a flat list; rate limiting is delegated to the
4-- compiler's per-endpoint `rateLimit` clauses on each route.
5-- Token comparison is plain `==` (timing-attack vulnerable), retry backoff is linear,
6-- and many helpers are inlined. Performance suffers; clarity is the only goal.
8-- ============================================
10-- ============================================
11-- Top-level constants: bind address, federation identity, capacity ceilings,
12-- per-endpoint rate-limit budgets, and expiry/backoff/TTL durations.
13-- Values written here are defaults; every scalar (Int/Float/Text/Bool/Maybe ...)
14-- top-level constant can be overridden at startup via `--name=value` on the
15-- command line (see Knot's `knot_override_lookup`). Run with `--help` for the
18-- This server's canonical federation identity. Used as the `server` field in
19-- presence/gossip events and for self-checks (`isLocalServer`). Not a bind
20-- address — the listener accepts connections on
21-- every interface regardless of this value. May also differ from the URL
22-- clients use to reach the server (e.g. behind a reverse proxy or alternate
23-- DNS name); peers must resolve this name to reach us for federation.
25-- Must be unique per deployment. Every operator participating in federation
26-- has to recompile with their own public hostname here — peers reject events
27-- whose origin fails `isBadServerName` (which blocks the default "localhost"
28-- and other private/reserved names), so two default-built servers cannot
29-- federate with each other. The default is only suitable for a single-node,
30-- non-federated deployment.
32-- Typed `Text`, not `ServerName`: a refined type cannot be given a bare literal
33-- default (the compiler requires an explicit `refine`), and this constant is
34-- overridable at startup. `localServerName` below is where the `ServerName`
35-- predicate is actually checked — an operator who overrides this with a name
36-- that fails `isValidServerName` (too long, not lowercase, or trailing-dotted)
37-- gets federation egress disabled and a loud startup warning, rather than an
38-- invalid name on the wire.
40serverHost = "localhost"
42-- `serverHost` refined to a `ServerName`, or `Nothing` when it fails
43-- `isValidServerName`. This is the only place the predicate is checked for our
44-- own hostname; peer-supplied names are validated by the runtime at the
45-- `/federation/gossip` route boundary (`fromServer: ServerName`). Federation
46-- egress (`sendBatchedGossip`) needs a `ServerName` to put in the gossip body,
47-- so a misconfigured host simply stops gossiping — see `main`, which warns at
49localServerName : Maybe ServerName
50localServerName = case refine serverHost of
51 Ok {value: sn} -> Just {value: sn}
53-- Network interface the HTTP listener binds to. "0.0.0.0" accepts connections
54-- on every IPv4 interface (the typical default behind a reverse proxy);
55-- "127.0.0.1" restricts the listener to localhost-only; "::" / "::1" do the
56-- IPv6 equivalents. Override with `--bindHost=...` at startup. Unrelated to
57-- `serverHost` above — this is the kernel-level bind address; that is the
58-- federation identity peers see.
61-- TCP port for incoming HTTP connections.
64-- URL scheme used when contacting peer federation servers.
65federationScheme : Text
66federationScheme = "https://"
68-- Storage retention for messages and dedup-id records. Mailbox rows live this
69-- long after `receivedAt`; expired rows are pruned by `pruneExpired` (30 days).
70messageMaxAge : Int<Ms>
71messageMaxAge = 2592000000
72-- Max length of a hex-encoded message body / opaque blob (40 MiB hex ≈ 20 MiB bytes).
75-- Min length of a hex-encoded blob: 346 chars = 173 bytes. A well-formed blob is
76-- `version (1) || ephemeral_x25519_pubkey (32) || nonce (24) || ciphertext`, and the
77-- ciphertext seals at minimum `sender_pubkey (32) || signature (64) || compressed_len (4)`
78-- plus the 16-byte Poly1305 tag — so 1 + 32 + 24 + 32 + 64 + 4 + 16 = 173 bytes is the
79-- floor for a blob any client could possibly decrypt (PROTOCOL.md §3). Anything shorter
80-- is garbage by construction: it cannot carry a sender identity, and storing it only
81-- burns mailbox rows and the recipient's poll bandwidth. Reject at the boundary.
84-- Cap on items in a batched send request.
87-- Cap on gossip events accepted or emitted in a single federation exchange.
90-- N13: Cap on newly-online keys per gossip batch that trigger forward sweeps.
91-- Without this, a single gossip request with 100 `online` events triggers 100
92-- mailbox scans (O(100 × |messages|)). Capping at 10 limits the amplification
93-- while still allowing reasonable multi-key presence announcements. Remaining
94-- newly-online keys are still written to `*presence` — only the forward sweep
95-- is deferred until the next presence re-announce or a poll triggers
96-- `forwardQueuedToServer` naturally.
97maxNewlyOnlineForwards : Int
98maxNewlyOnlineForwards = 10
99-- Cap on events returned by one long-poll response.
102-- Per-peer ceiling on outstanding forward attempts.
103maxForwardsPerServer : Int
104maxForwardsPerServer = 2000
105-- S9: Cap on distinct remote servers a single message is immediately forwarded
106-- to at send time. Separate from `maxForwardsPerServer` (which bounds outstanding
107-- forwards *per peer*), this bounds the fan-out breadth. A recipient is unlikely
108-- to be visible on more than 100 servers; the previous reuse of
109-- `maxForwardsPerServer` (2000) for this purpose was an overload that could
110-- spawn up to 2000 immediate HTTP forwards per message.
111maxRemoteServersPerMessage : Int
112maxRemoteServersPerMessage = 100
113-- Global ceiling on the `*forwards` outbox. `maxForwardsPerServer` bounds any one
114-- peer, but a recipient gossiped as present on many servers fans one blob out to
115-- all of them, so the total is bounded only by (peers x per-peer cap). This caps
118-- Evicts the *highest*-retry entries first: those are the ones closest to
119-- `maxForwardRetries` (about to be abandoned anyway), so pressure is shed onto
120-- failing peers rather than healthy ones. Freshly-staged rows carry `retries: 0`
121-- and so always survive their own capping.
123-- Dropping a forward is not message loss: the `*messages` row it points at stays
124-- put, so the recipient still gets the blob by polling here, and a later presence
125-- announce re-stages the forward via `forwardQueuedToServer`.
126maxForwardsTotal : Int
127maxForwardsTotal = 50000
128-- Max accepted length of a server hostname.
129maxServerNameLen : Int
130maxServerNameLen = 128
131-- Ceiling on outstanding auth challenges held in memory.
134-- Ceiling on concurrent active sessions. Enforced by `capList` in
135-- `handleVerifyAuth`, which LRU-evicts the soonest-to-expire sessions once the
138-- LIMITATION — global LRU eviction is Sybil-floodable: an attacker with enough
139-- IPs can evict live users' sessions. Bounded by `maxSessionsPerKey` and per-IP
140-- `authRateLimit`; a per-IP session cap was rejected (collapses without XFF,
141-- punishes carrier-NAT). A real fix prices session creation, not IPs. See PROTOCOL.md §10.
144-- Per-pubkey ceiling on outstanding challenges (prevents one key from exhausting the pool).
145maxChallengesPerKey : Int
146maxChallengesPerKey = 5
147-- Per-pubkey ceiling on concurrent sessions.
149-- LIMITATION — concurrent sessions for the same keypair are not supported: the
150-- mailbox is keyed by pubkey, so two devices sharing a key poll one mailbox and
151-- each ack destroys messages the other hasn't read. The model is one keypair per
152-- device (PROTOCOL.md §2). This cap only bounds pool exhaustion, not key-sharing.
153-- A fix needs per-session delivery cursors — out of scope for v0.1.
154maxSessionsPerKey : Int
155maxSessionsPerKey = 10
156-- Ceiling on gossip-learned (remote) presence rows.
158-- `/federation/gossip` is unauthenticated and pubkeys are free to invent, so
159-- without a cap one peer can grow `*presence` without bound. `handleRecvGossip`
160-- LRU-evicts (`capList`) down to this ceiling.
162-- Local rows are exempt: they're bounded by `maxSessions` and a shared ceiling
163-- would let gossip floods evict our own online users (local TTL 60 min < gossip
164-- TTL 90 min, so `capList` drops local rows first). See PROTOCOL.md §10.
167-- Per-peer-server ceiling on gossip-learned presence rows, so a single peer cannot
168-- consume the whole `maxPresence` pool and evict every other peer's routing
169-- information. Filling the global pool then requires many distinct hostnames that
170-- each pass `isBadServerName`.
171maxPresencePerServer : Int
172maxPresencePerServer = 5000
173-- Per-recipient ceiling on stored mailbox rows. Without a cap a single
174-- authenticated sender can queue unbounded data for one recipient
175-- (`maxBatchSize` 100 messages/request x `sendRateLimit` 60 requests/min =
176-- 6000/min, each blob up to 20 MiB) and only the 30-day `messageMaxAge` TTL
177-- ever reclaims it. Past the cap `appendMessage` drops the oldest rows (lowest
178-- `receivedAt`) — the same rows the TTL would eventually drop, just sooner.
180-- The recipient's client bounds what it *processes* per poll (MAX_POLL_TOTAL_BYTES
181-- in core/src/app.rs), but nothing bounded what the server *stores* before this.
183-- Dropping a row orphans any `*forwards` entry for it; `pruneExpired` collects
184-- those (it drops forwards whose message no longer exists). Its `deliveredTo`
185-- set is lost with it, which is harmless — the blob is gone, so there is
186-- nothing left to re-forward.
188-- LIMITATION — evicting on overflow means a flood can now *destroy* mail, not
189-- just pile it up: an attacker who fills a recipient's mailbox pushes that
190-- recipient's genuine undelivered messages out of the window. Pubkeys are free
191-- to mint, so "authenticated sender" is no barrier. This is a trade, not a fix
192-- — the alternative (reject once full) hands the same attacker a permanent
193-- block on *all* new mail to that recipient, which is strictly worse: here at
194-- least the newest messages always land. It only bites a recipient who is
195-- offline long enough to accumulate `maxMessagesPerRecipient`, since polling
196-- drains the mailbox (`ackPolledMessages`). A real fix prices sending — see
197-- the same argument for sessions on `maxSessions`, and PROTOCOL.md §10.
198maxMessagesPerRecipient : Int
199maxMessagesPerRecipient = 10000
200-- Global ceiling on total stored messages across all recipients (S6). Every
201-- other state ref has a global cap (*sessions, *challenges, *presence,
202-- *forwards); *messages had only a per-recipient cap, so total storage was
203-- bounded only by (distinct recipient keys x maxMessagesPerRecipient), and an
204-- attacker minting fresh invalid pubkeys could fill the disk (bounded only by
205-- rate limits and the 30-day TTL). On overflow this evicts the globally-oldest
206-- rows, symmetric with the other refs. See PROTOCOL.md §10.
207maxMessagesTotal : Int
208maxMessagesTotal = 1000000
209-- Validity window for an auth challenge before it must be re-issued (1 min).
210challengeExpiry : Int<Ms>
211challengeExpiry = 60000
212-- How long a session token remains valid after issue (1 hour).
213sessionExpiry : Int<Ms>
214sessionExpiry = 3600000
215-- How long a received "online" presence gossip is considered fresh (90 min).
216-- Receivers anchor the TTL to their own wall clock at receive time, so this
217-- value isn't carried on the wire.
218onlineGossipTtl : Int<Ms>
219onlineGossipTtl = 5400000
220-- Times to retry a federation forward before giving up.
221maxForwardRetries : Int
222maxForwardRetries = 10
224-- Base delay for federation retry backoff (linear, not exponential — 30 s).
225retryBackoffBase : Int<Ms>
226retryBackoffBase = 30000
227-- Cap on federation retry backoff (8 min).
228retryBackoffMax : Int<Ms>
229retryBackoffMax = 480000
230-- How long a peer's failure record survives past its most recent failure (24 h).
231-- After this, accumulated backoff resets — the next attempt is treated as fresh.
232forwardFailureMaxAge : Int<Ms>
233forwardFailureMaxAge = 86400000
235-- Cadence of the background prune/cleanup task (30 s).
236backgroundPruneInterval : Int<Ms>
237backgroundPruneInterval = 30000
238-- Long-poll hold timeout before returning empty to the client (25 s).
239pollTimeoutMs : Int<Ms>
242-- Rolling window for every per-endpoint rate-limit bucket (1 min). All routes
243-- share this window; only the per-window request budget varies per endpoint.
244rateLimitWindow : Int<Ms>
245rateLimitWindow = 60000
246-- Per-client-IP budget for /auth/challenge and /auth/verify per `rateLimitWindow`.
247-- A healthy handshake is one challenge + one verify, so the budget leaves ample
248-- room for many clients behind one NAT.
251-- Per-client-IP budget for /poll per `rateLimitWindow`. Clients reconnect after
252-- `pollTimeoutMs`, so steady state is ~3/min per client; the budget leaves room
253-- for several clients behind one NAT.
256-- Per-client-IP budget for /messages per `rateLimitWindow`. Each call may
257-- carry up to `maxBatchSize` ciphertexts, so the effective message ceiling
261-- Per-peer-IP budget for /federation/gossip per `rateLimitWindow`.
264-- Per-peer-IP budget for /federation/forward per `rateLimitWindow`. Higher than
265-- gossip because peers fan out one call per buffered ciphertext.
266forwardRateLimit : Int
267forwardRateLimit = 600
268-- Whether rate limiting may trust X-Forwarded-For for the client address.
269-- True matches the install.sh deployment (Caddy in front, which appends the
270-- real client address as the header's final entry — the only entry a trusted
271-- proxy vouches for). Set --trustForwardedFor=False when clients connect
272-- directly, otherwise a client could spoof the header to mint fresh
273-- rate-limit buckets.
274trustForwardedFor : Bool
275trustForwardedFor = True {}
277-- Master switch for federation; when False the server runs in single-node mode:
278-- no gossip is emitted, no forwards are attempted, and both /federation/*
279-- endpoints answer 403.
281-- Defaults to False. Federation is unauthenticated by design (PROTOCOL.md §10) —
282-- any host that can reach us may announce presence or inject a blob — so joining
283-- the mesh is a deliberate operator decision, not something a default hands you.
284-- Opt in with `--federationEnabled=True`.
285federationEnabled : Bool
286federationEnabled = False {}
288-- Federation bootstrap seeds: comma-separated peer hostnames this server gossips
289-- to unconditionally, e.g. `--seedPeers=relay1.example.com,relay2.example.com`.
291-- Without seeds the mesh cannot form. Peers are otherwise *only* ever learned
292-- from inbound gossip (a `*presence` row remembers the `server` that announced a
293-- key), so two fresh relays that have never heard of each other both start with
294-- an empty gossip target set and stay that way forever — neither one speaks
295-- first. Seeding one side is enough to bootstrap a pair: our gossip carries
296-- `fromServer`, so the seed learns of *us* from the first exchange and gossips
299-- Typed `Text`, not `[Text]`: only scalar top-level constants are startup-
300-- overridable (see the header note), so the list travels as one comma-separated
301-- scalar and `seedPeerList` splits it.
305-- `seedPeers` split on commas, trimmed, with blanks and our own hostname dropped.
306-- Deliberately *not* filtered through `isBadServerName` here: every federation
307-- egress site applies the deny-list itself, so a denylisted seed is refused at
308-- exactly the same choke point as a denylisted gossip-learned peer.
309-- Filtering `serverHost` out at parse time lets `gossipTargets` drop its
310-- `isLocalServer` guard (the only other source, `collectPeers`, already filters it).
312seedPeerList = filter (\s -> s != "" && not isLocalServer s) (splitOnComma seedPeers)
314federationUrl : Text -> Text
315federationUrl = \server -> federationScheme ++ server
317-- ============================================
319-- ============================================
320-- Wire/state shapes plus refinement aliases for hex/server-name validation.
321-- Hex types are bounded length + lowercase-hex; server names are lowercased
322-- and stripped of trailing dots. The SSRF deny-list (`isBadServerName`) is
323-- applied at federation egress, not in the type predicate.
325-- One event in a /poll response: the opaque cipher blob addressed to the
326-- polling pubkey. The server cannot read the blob.
327type PollEvent = {encryptedBlob: BlobHex}
329-- One presence change exchanged between federated servers. A flat wire record
330-- (`{"eventType": "online"|"offline", "pubkey": "<hex>"}`) rather than an ADT:
331-- the built-in record JSON round-trips it directly (a `Just` pubkey encodes as
332-- the bare hex string, `Nothing` as `null`/an absent field). `eventType` is
333-- free `Text`, so an unrecognized future event kind decodes cleanly instead of
334-- failing the whole batch, and `pubkey` is optional so a future pubkey-less
335-- kind still parses. `handleRecvGossip` ignores any event whose `eventType` it
336-- doesn't recognize or that carries no pubkey — that is the forward-compat
337-- fallback (the old `GossipUnknown` variant).
338type GossipEvent = {eventType: Text, pubkey: Maybe Text}
340-- True when `s` is lowercase hex of exactly `exactLen` characters (even by definition).
341isValidExactHex : Int -> Text -> Bool
342isValidExactHex = \exactLen s -> length s == exactLen && isValidHex s
343-- True when `s` is lowercase hex within [`minBlobLen`, `maxBlobLen`]. The floor
344-- rejects blobs too short to be a real envelope; see `minBlobLen`.
345isValidBlobHex : Text -> Bool
346isValidBlobHex = \s -> length s >= minBlobLen && length s <= maxBlobLen && isValidHex s
347-- Hex-encoded Ed25519 public key (32 bytes → 64 chars exact).
348type PubkeyHex = Text where isValidExactHex 64
349-- Hex-encoded ciphertext or opaque blob; bounded to [`minBlobLen`, `maxBlobLen`]
350-- (168 bytes ≈ 20 MiB).
351type BlobHex = Text where isValidBlobHex
352-- Hex-encoded Ed25519 signature (64 bytes → 128 chars exact).
353type SignatureHex = Text where isValidExactHex 128
354-- Normalized hostname (lowercased, no trailing dot, length-bounded). The SSRF
355-- deny-list (`isBadServerName`) is enforced separately at federation egress
356-- (`handleRecvGossip`); keeping it out of the type predicate lets the default
357-- `serverHost = "localhost"` flow through presence rows in a non-federated
358-- single-node deployment.
360-- WHY SERVER NAMES STAY `Text` IN STATE (the canonical note; other sites point
361-- here). Every server name held in `*presence`, `*forwards`, `*forwardFailures`
362-- and `Message.deliveredTo` is plain `Text`, never `ServerName`. They all
363-- originate in `serverHost` — a startup-overridable scalar, so a refined type
364-- cannot be given a bare literal default and the predicate can only be checked at
365-- runtime (`localServerName`). `ServerName` is therefore enforced exactly where it
366-- can be: at the `/federation/gossip` route boundary, where the name is
367-- peer-supplied (`fromServer: ServerName`). Handlers that receive the refined type
368-- widen it once, up front (`let server = (serverName : Text)`), because Knot does
369-- not implicitly coerce between a refined type and its base inside a comparison —
370-- `f.toServer == server` would otherwise fail to typecheck. Widening is always
371-- sound (the predicate only adds constraints); narrowing is what needs `refine`.
372isValidServerName : Text -> Bool
373isValidServerName = \s -> length s <= maxServerNameLen && s == toLower (stripTrailingDot s)
374type ServerName = Text where isValidServerName
376-- Wall-clock time in milliseconds since epoch.
377type Timestamp = Int<Ms>
379-- Outstanding nonce issued by /auth/challenge; consumed by /auth/verify.
380type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp, ip: Text}
381-- An issued bearer token bound to (pubkey, ip, expiry).
382type Session = {token: Text, pubkey: PubkeyHex, expiresAt: Timestamp, ip: Text}
383-- Mailbox row: a stored message awaiting recipient pickup or federation forward.
384-- Storage TTL is fixed at `messageMaxAge`, so expiry is derived from
385-- `receivedAt`. Any send time the sender wants to convey lives inside
386-- `encryptedBlob` (the server cannot read it). `deliveredTo` records peers
387-- that have already accepted a federated forward of this blob, so a later
388-- presence re-announce of `toKey` doesn't trigger a duplicate delivery.
389-- (Single-field record rows, not bare names: the Knot runtime cannot persist
390-- a nested relation of scalars.)
391type Message = {toKey: PubkeyHex, encryptedBlob: BlobHex, receivedAt: Timestamp, deliveredTo: [{server: Text}]}
392-- Last-known location of a pubkey, either local (`server == serverHost`) or
393-- learned from a peer via gossip. Multiple entries per pubkey are allowed.
394type PresenceEntry = {pubkey: PubkeyHex, server: Text, expiresAt: Timestamp}
395-- A message queued for cross-server delivery to `toServer`. `retries` is
396-- incremented by `retryPendingForwards` until `maxForwardRetries` is hit.
397-- Identity is derived from `encryptedBlob` (see `Message`).
398type ForwardEntry = {toServer: Text, toKey: PubkeyHex, encryptedBlob: BlobHex, retries: Int}
399-- Running failure counter for a peer; keyed by `server`. Drives `shouldRetryServer`.
400-- `failedAt` is the start time of the last recorded attempt; `failures: 0` is
401-- the post-success tombstone (no backoff, kept so the timestamp can outrank
402-- slower concurrent failures).
403type ForwardFailure = {server: Text, failedAt: Timestamp, failures: Int}
405-- ============================================
406-- Persisted State (all flat lists, no sharding)
407-- ============================================
408-- Mutable refs (`*x`) holding the entire server state in memory. Every list
409-- scan is O(n); scaling is the first thing the production version replaces.
410-- Grouped here: auth (challenges/sessions), mailbox (messages/forwards),
411-- presence, and bookkeeping counters. Per-endpoint rate-limit buckets live
412-- in the runtime's hidden `_knot_rate_limits` SQLite table and don't appear
414-- The Knot runtime persists every `*ref` declared here through restarts (see
415-- the project memory note about SQLite-backed refs); nothing in this file is
416-- truly volatile despite being typed as plain in-memory lists.
418-- Outstanding /auth/challenge nonces awaiting /auth/verify. Capped overall and per-pubkey.
419*challenges : [Challenge]
420-- Live bearer tokens. Source of truth for `withSessionAuth`; trimmed by `pruneExpired`.
422-- Mailbox: ciphertexts addressed to local recipients, awaiting poll or federation forward.
424-- Last-known location of each pubkey (local sessions and gossiped remote presence).
425-- Remote (gossiped) rows are capped by `maxPresence` / `maxPresencePerServer` in
426-- `handleRecvGossip`; local rows are exempt and bounded by `maxSessions` instead.
427*presence : [PresenceEntry]
428-- Cross-server outbox: messages queued for delivery to a peer, with retry counts.
429*forwards : [ForwardEntry]
430-- Per-peer failure counters; drives `shouldRetryServer`.
431*forwardFailures : [ForwardFailure]
433-- Strictly-monotonic sequence used as `Message.receivedAt`; guarantees
434-- poll-cursor ordering. Held as a 0-or-1-row wrapped relation, not a bare
435-- `Timestamp` scalar source: the runtime now panics when a scalar source's
436-- backing table is empty (it treats a missing row as corruption rather than
437-- defaulting to 0), which would 500 the very first /poll or /messages on a
438-- fresh database. Read through `currentSeq` (0 default). The `{value: ...}`
439-- record wrapper is required because a relation of bare scalars (`[Timestamp]`)
440-- also can't be persisted — same reason `Message.deliveredTo` is wrapped.
441*seqCounter : [{value: Timestamp}]
443-- ============================================
445-- ============================================
446-- Per-endpoint token-bucket configuration. Every endpoint keys on the client IP
447-- (last X-Forwarded-For hop behind a trusted proxy, else the connection
448-- address). Nothing the caller can mint for free is a bucket key: the limiter
449-- runs before the handler, so it cannot tell a valid session from an invented
450-- one, and an attacker varying a self-chosen value would get a fresh bucket per
451-- value. That rules out the bearer token (any string) and the submitted pubkey
452-- (any keypair) alike. A pubkey key is abusable in both directions: an attacker
453-- rotating keypairs draws a fresh budget with every rotation (a Sybil flood could
454-- then push sessions through until `maxSessions` starts evicting live ones), and
455-- flooding a *victim's* pubkey would exhaust that victim's own login budget.
456-- Per-pubkey exhaustion of the challenge/session pools is bounded separately, by
457-- `maxChallengesPerKey` and `maxSessionsPerKey` in the handlers. Each route has an
458-- independent bucket store, so endpoints using the same key strategy don't share
459-- budget across routes. Buckets persist in the runtime's `_knot_rate_limits`
460-- SQLite table; rejection responds 429 before the handler runs.
462-- Suffix of `s` after its last comma, trimmed. X-Forwarded-For is a
463-- comma-separated chain that each proxy appends to; only the final entry —
464-- the one written by the nearest trusted proxy — is reliable for bucketing.
465lastForwardedHop : Text -> Text
466lastForwardedHop = \s -> if contains "," s
467then lastForwardedHop (afterComma s)
470-- The client address for rate-limit bucketing: the last X-Forwarded-For hop
471-- when `trustForwardedFor` is set (and the header is present and non-empty),
472-- otherwise the TCP connection address.
473pickClientIp : Maybe Text -> Text -> Text
474pickClientIp = \h connIp -> case h of
475 Just {value: ips} -> if trustForwardedFor
476 then let hop = lastForwardedHop ips in if hop != "" then hop else connIp
480byClientIp = \_ ctx -> Just {value: pickClientIp (ctx.header "X-Forwarded-For") ctx.clientIp}
482authLimit = {key: byClientIp, limit: {requests: authRateLimit, window: rateLimitWindow}}
483pollLimit = {key: byClientIp, limit: {requests: pollRateLimit, window: rateLimitWindow}}
484sendLimit = {key: byClientIp, limit: {requests: sendRateLimit, window: rateLimitWindow}}
485gossipLimit = {key: byClientIp, limit: {requests: gossipRateLimit, window: rateLimitWindow}}
486forwardLimit = {key: byClientIp, limit: {requests: forwardRateLimit, window: rateLimitWindow}}
488-- ============================================
490-- ============================================
491-- Public HTTP surface, grouped by audience:
492-- AuthApi -- challenge/verify (client identity)
493-- ClientApi -- /poll, /messages (send)
494-- FederationApi -- inter-server gossip, forward (single + batch)
495-- Handlers return `Result HttpError T`: `Ok` produces a 200 with the
496-- declared body shape, `Err` produces a non-2xx response whose body is
497-- `{"error": "<code>"}`.
500 POST {pubkey: PubkeyHex} /auth/challenge headers {xForwardedFor: Maybe Text} -> {challenge: Text, expiresAt: Timestamp} rateLimit authLimit = ReqChallenge
501 POST {pubkey: PubkeyHex, challenge: Text, signature: SignatureHex, revokeOthers: Bool} /auth/verify headers {xForwardedFor: Maybe Text} -> {token: Text, expiresAt: Timestamp} rateLimit authLimit = VerifyAuth
504 POST {cursor: Timestamp} /poll headers {authorization: Text, xForwardedFor: Maybe Text} -> {events: [PollEvent], cursor: Timestamp} rateLimit pollLimit = Poll
505 POST {messages: [{to: PubkeyHex, encryptedBlob: BlobHex}]} /messages headers {authorization: Text, xForwardedFor: Maybe Text} -> {} rateLimit sendLimit = SendMessages
507route FederationApi where
508 POST {events: [GossipEvent], fromServer: ServerName} /federation/gossip -> {} rateLimit gossipLimit = RecvGossip
509 POST {toKey: PubkeyHex, encryptedBlob: BlobHex} /federation/forward -> {} rateLimit forwardLimit = ForwardMessage
511route Api = AuthApi | ClientApi | FederationApi
513-- ============================================
515-- ============================================
516-- List/predicate combinators (filter/all/findFirst/...), token generation,
517-- and small text/server-name utilities used throughout the rest of the file.
518-- Everything is intentionally O(n) over flat lists; performance is sacrificed
519-- for clarity per the file header.
521-- Cap to maxN by dropping the soonest-to-expire entries (LRU-style). Always
522-- sorts by `expiresAt` so the oldest/most-stale entries are evicted first.
523capList : [{expiresAt: Timestamp | r}] -> Int -> [{expiresAt: Timestamp | r}]
524capList = \items maxN -> drop (max 0 (count items - maxN)) (sortBy (\x -> x.expiresAt) items)
526-- Cap entries matching `pubkey` to maxN-1 (caller adds one more). Splits the
527-- list into "different pubkey" (untouched) and "same pubkey" (capped +
528-- LRU-evicted) so a single key can't exhaust a global pool — see
529-- `maxChallengesPerKey` and `maxSessionsPerKey`.
530capPerKey : [{pubkey: PubkeyHex, expiresAt: Timestamp | r}] -> PubkeyHex -> Int -> [{pubkey: PubkeyHex, expiresAt: Timestamp | r}]
531capPerKey = \items pubkey maxN -> union (filter (\x -> not (x.pubkey == pubkey)) items) (capList (filter (\x -> x.pubkey == pubkey) items) (maxN - 1))
533-- Cap entries matching `server` to maxN, leaving every other server's entries
534-- untouched. Same shape as `capPerKey` on a different field, but caps to `maxN`
535-- rather than `maxN - 1`: the sole caller (`handleRecvGossip`) applies this
536-- *after* merging the peer's new rows in, not before adding one more. Keeps one
537-- peer from crowding every other peer out of the `maxPresence` pool.
538capPerServer : [{server: Text, expiresAt: Timestamp | r}] -> Text -> Int -> [{server: Text, expiresAt: Timestamp | r}]
539capPerServer = \items server maxN -> union (filter (\x -> not (x.server == server)) items) (capList (filter (\x -> x.server == server) items) maxN)
541-- Cap the whole forwards outbox to `maxForwardsTotal`, evicting the highest-retry
542-- entries first — see `maxForwardsTotal` for why those and not the oldest.
543-- Deliberately not `capList`: that keys on `expiresAt`, and `ForwardEntry` carries
544-- no timestamp (the same reason `retryPendingForwards` has to sort on the blob).
545-- Applied by both writers that grow `*forwards` (`forwardQueuedToServer` and
546-- `handleSendMessages`); the retry sweep only ever shrinks it.
548-- N4: Sort by `(retries, encryptedBlob)` for determinism. Without the secondary
549-- key, a `sortBy retries` alone is unstable when many entries share `retries: 0`,
550-- and any of them could be dropped — including a fresh forward for a healthy
551-- peer. The blob is a unique secondary key (the dedup invariant guarantees
552-- `(toKey, encryptedBlob, toServer)` uniqueness), so the sort is total and
554capForwards : [ForwardEntry] -> [ForwardEntry]
555capForwards = \fwds -> take maxForwardsTotal (sortBy (\f -> {retries: f.retries, blob: f.encryptedBlob}) fwds)
557-- Random hex token: one random hex char per recursive call. `n` is the
558-- desired length in characters (so n=48 yields 24 random bytes of entropy).
559-- Session bearers, /auth challenges, and federation auth nonces all use n=48
560-- (192 bits of entropy, well beyond birthday bound).
561-- Tail-recursive: builds the string left-to-right via an accumulator (`acc`),
562-- appending one hex char per call. Each `acc ++ ...` copies the accumulator,
563-- so the total work is O(n²) in the length — but n is 48 (192 bits), so this
564-- is a fixed ~1 KB of copying and not worth a more complex builder.
565genToken : Int -> Text -> IO {random} Text
566genToken = \n acc -> if n <= 0
570 genToken (n - 1) (acc ++ take 1 (drop d "0123456789abcdef"))
572-- True when `s` is non-empty, even-length, and only lowercase hex digits.
573-- `chars` yields the *distinct* character set (relations dedupe), which is
574-- fine for the membership check; the length checks must use `length`.
575isValidHex : Text -> Bool
578 n > 0 && n / 2 * 2 == n && all (\c -> contains c "0123456789abcdef") (chars s)
580-- Recursively strip every trailing "." from `s` (DNS root form).
581stripTrailingDot : Text -> Text
582stripTrailingDot = \s -> if hasSuffix "." s
583then stripTrailingDot (take (length s - 1) s)
586-- True when `s` refers to this server.
587isLocalServer : Text -> Bool
588isLocalServer = \s -> s == serverHost
590-- True when `s` starts with `pre`.
591hasPrefix : Text -> Text -> Bool
592hasPrefix = \pre s -> take (length pre) s == pre
594-- True when `s` ends with `suffix`.
595hasSuffix : Text -> Text -> Bool
596hasSuffix = \suffix s -> drop (max 0 (length s - length suffix)) s == suffix
598-- Occurrences of the single character `c` in `s`. (`chars` can't be used for
599-- this — it returns the distinct character *set*.)
600countChar : Text -> Text -> Int
601countChar = \c s -> if s == ""
603else (if take 1 s == c then 1 else 0) + countChar c (drop 1 s)
605-- The host portion of `sn` — everything before the first `:`. With the
606-- one-colon ceiling enforced in `isBadServerName`, this strips an optional
607-- `:port` so `isNumericHost` sees just the host.
608beforeColon : Text -> Text
609beforeColon = \s -> if s == "" || take 1 s == ":"
611else take 1 s ++ beforeColon (drop 1 s)
613-- `s` up to and including its first `]` (the whole string if there is none).
614throughBracket : Text -> Text
615throughBracket = \s -> if s == ""
617else if take 1 s == "]"
619else take 1 s ++ throughBracket (drop 1 s)
621-- The bare hostname the auth signature is bound to (PROTOCOL.md §6): `serverHost`
622-- with an optional `:port` stripped.
624-- Deliberately *not* `beforeColon`. A bracketed IPv6 literal is made of colons,
625-- so cutting at the first one turns `[::1]:8080` into `[`. The client derives
626-- this side of the contract with a real URL parser (`server_host`, core/src/app.rs)
627-- and signs over `[::1]`, so truncating here would reject every signature an
628-- IPv6-hosted relay is ever sent. For a DNS name or an IPv4 literal the two
629-- functions agree character for character.
630authHost : Text -> Text
631authHost = \s -> if take 1 s == "["
635-- True when the host is a bare integer (no dots) — a decimal or octal "dword" IP
636-- like `2130706433` or `017700000001` (both = 127.0.0.1). These carry no dotted
637-- octets, so the octet checks below never match them, yet they resolve to the same
638-- internal addresses. Takes the already-port-stripped host (`beforeColon sn`).
639isNumericHost : Text -> Bool
640isNumericHost = \host -> host != "" && all (\c -> contains c "0123456789") (chars host)
642-- Decimal value of a single hex/ascii digit character.
643digitValue : Text -> Int
644digitValue = \c -> if c == "0" then 0 else if c == "1" then 1 else if c == "2" then 2 else if c == "3" then 3 else if c == "4" then 4 else if c == "5" then 5 else if c == "6" then 6 else if c == "7" then 7 else if c == "8" then 8 else 9
646-- Value of an all-digits string (e.g. "172" -> 172); -1 when empty or
647-- non-numeric. `chars` is fine for the membership guard (set semantics don't
648-- matter there); the actual parse walks the string in order via take/drop.
650-- The accumulator saturates at 2^32 so an overlong all-digits octet cannot
651-- overflow i64 and panic the handler. `isBadServerName` reaches this via
652-- `isReservedIPv4` on a peer-supplied name (`/federation/gossip`'s `fromServer`
653-- only passes a length/lowercase check at the route boundary), so a 19+-digit
654-- octet like "9999999999999999999.0.0.1" would otherwise abort the request with
655-- an unhandled `integer overflow in ... * 10`. A real IPv4 octet is 0-255 and
656-- every `isReservedIPv4` comparison is against a constant <= 255, so saturating
657-- above that range preserves the result for valid octets while an oversized
658-- first octet still reads as `>= 224` (reserved → fail-closed). The `* 10`
659-- stays safe because `acc` is capped at 2^32 before each step.
660decimalValue : Text -> Int
661decimalValue = \s -> if s == "" || not all (\c -> contains c "0123456789") (chars s)
663else decimalValueGo 0 s
664decimalValueGo : Int -> Text -> Int
665decimalValueGo = \acc s -> if s == ""
667else decimalValueGo (min 4294967296 (acc * 10 + digitValue (take 1 s))) (drop 1 s)
669-- Substring of `s` before / after its first ",". Same shape as `beforeDot` /
670-- `afterDot`, on a different separator.
671beforeComma : Text -> Text
672beforeComma = \s -> if s == "" || take 1 s == ","
674else take 1 s ++ beforeComma (drop 1 s)
675afterComma : Text -> Text
676afterComma = \s -> if s == ""
678else if take 1 s == ","
680else afterComma (drop 1 s)
682-- Split `s` on commas, trimming each field. The stdlib has no `split`, so this
683-- is the usual beforeX/afterX recursion. Empty fields survive the split (",,a"
684-- yields "" twice — relations dedupe, so once) and are dropped by the caller;
685-- see `seedPeerList`.
687-- The `beforeComma`/`afterComma`/`beforeDot`/`afterDot`/`beforeColon` family
688-- looks ripe to fold into one generic `beforeChar sep s` / `afterChar sep s`.
689-- Do NOT: routing *this* function's tail recursion through a partially-applied
690-- `afterChar ","` hangs the Knot compiler indefinitely (confirmed 2026-07-11 —
691-- a 9-line repro of `splitOnComma = ... splitOnComma (afterChar "," s)` never
692-- finishes compiling, while the bespoke single-argument `afterComma` compiles
693-- in ~1 s). The per-separator helpers stay bespoke on purpose.
694splitOnComma : Text -> [Text]
695splitOnComma = \s -> if s == ""
697else union [trim (beforeComma s)] (splitOnComma (afterComma s))
699-- Substring of `s` before / after its first ".". `afterDot` is empty when
700-- there is no dot. Used to pull the first two octets of a dotted IPv4 literal.
701beforeDot : Text -> Text
702beforeDot = \s -> if s == "" || take 1 s == "."
704else take 1 s ++ beforeDot (drop 1 s)
705afterDot : Text -> Text
706afterDot = \s -> if s == ""
708else if take 1 s == "."
710else afterDot (drop 1 s)
712-- True when `host` is composed solely of digits and dots, i.e. a bare IPv4
713-- literal rather than a hostname. Gates the numeric range checks below so a
714-- legitimately-named peer like "224.example.com" is not misread as multicast.
715isDottedNumeric : Text -> Bool
716isDottedNumeric = \host -> host != "" && contains "." host && all (\c -> contains c "0123456789.") (chars host)
718-- Reserved/non-routable IPv4 ranges the dotted-octet prefix list misses:
719-- CGNAT 100.64/10, benchmarking 198.18/15, and multicast + reserved/broadcast
720-- (224/4 and 240/4, i.e. any first octet >= 224). Applied only to bare IPv4
721-- literals (`isDottedNumeric`) so hostnames are never caught. Shorthand forms
722-- like "100.64" still match — only the first two octets are inspected.
723isReservedIPv4 : Text -> Bool
724isReservedIPv4 = \host ->
725 let o1 = decimalValue (beforeDot host) in
726 let o2 = decimalValue (beforeDot (afterDot host)) in
727 isDottedNumeric host && (o1 >= 224 || (o1 == 100 && o2 >= 64 && o2 <= 127) || (o1 == 198 && (o2 == 18 || o2 == 19)))
729-- True when a dotted-numeric host carries an octet with a redundant leading
730-- zero (e.g. "0177", "0012"). Canonical IPv4 literals never do, but the system
731-- resolver behind `fetch` (ureq -> getaddrinfo / inet_aton) reads a leading-zero
732-- octet as OCTAL: "0012.0.0.1" dials 10.0.0.1 and "0177.0.0.1" dials 127.0.0.1,
733-- while the decimal octet parse in `isReservedIPv4` (and the dotted-prefix list)
734-- sees 12.0.0.1 / 177.0.0.1 and waves them through — an SSRF bypass of the same
735-- class as the non-dotted "dword"/`0x` forms. Reject the ambiguous octal form
736-- outright. Gated by `isDottedNumeric` so a digit-led hostname label like
737-- "0foo.example.com" is never caught (it isn't all-digits-and-dots).
738hasLeadingZeroOctet : Text -> Bool
739hasLeadingZeroOctet = \host ->
740 isDottedNumeric host &&
741 (let octet = beforeDot host in
742 let rest = afterDot host in
743 (length octet > 1 && take 1 octet == "0") || (rest != "" && hasLeadingZeroOctet rest))
745-- True when the host's first two labels name a reserved IPv4 range: the zero net
746-- (0/8), loopback (127/8), and the RFC1918 blocks 10/8, 172.16/12, 192.168/16,
747-- plus link-local 169.254/16.
749-- Deliberately *not* gated on `isDottedNumeric`, unlike `isReservedIPv4` below:
750-- these run as leading string labels too, matching the literal `"10."` / `"172.16."`
751-- prefix tests this replaces. So "10.example.com" stays blocked. A non-numeric
752-- first label parses to -1 via `decimalValue` and matches nothing, so an ordinary
753-- hostname is never caught.
754isReservedOctetPrefix : Text -> Bool
755isReservedOctetPrefix = \host ->
756 let o1 = decimalValue (beforeDot host) in
757 let o2 = decimalValue (beforeDot (afterDot host)) in
758 o1 == 0 || o1 == 10 || o1 == 127 || (o1 == 172 && o2 >= 16 && o2 <= 31) || (o1 == 192 && o2 == 168) || (o1 == 169 && o2 == 254)
760-- Block private/reserved/internal hostnames (SSRF defense).
762-- LIMITATION — purely lexical: inspects the string, never the resolved address.
763-- DNS-rebinding TOCTOU and percent-encoding tricks bypass it. A real fix needs
764-- resolve-then-pin (fuse resolution with connection), which `fetch` doesn't
765-- expose. See PROTOCOL.md §10. Treat as a guard against naive-literal SSRF, not
766-- a motivated attacker with a nameserver.
768-- Enforced on inbound (`handleRecvGossip`) and at every egress site
769-- (`sendBatchedGossip`, `retryPendingForwards`, `forkForwardsTo`) as
770-- defense-in-depth — persisted state from before a denylist tightening must
771-- not steer a `fetch` at an internal host.
773-- A legitimate `host:port` has exactly one `:`, so the multi-colon check
774-- rejects bare IPv6 literals. The name is trailing-dot-stripped before every
775-- check so `localhost.` / `foo.internal.` (DNS root form) are caught.
776isBadServerName : Text -> Bool
777isBadServerName = \raw ->
778 let sn = stripTrailingDot raw in
779 let host = beforeColon sn in
780 sn == "" || sn == "localhost" || hasPrefix "localhost:" sn || isNumericHost host || isReservedOctetPrefix host || isReservedIPv4 host || hasLeadingZeroOctet host || hasPrefix "0x" sn || any (\c -> not contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:") (chars sn) || countChar ":" sn > 1 || any (\p -> hasPrefix p sn) [".", ":", "192.0.2.", "198.51.100.", "203.0.113."] || any (\s -> hasSuffix s sn) [".localhost", ".local", ".internal", ".arpa", ".onion"]
782-- ============================================
784-- ============================================
785-- Bearer token extraction and session lookup. Authenticated handlers funnel
786-- through `authedPubkey`; per-endpoint rate limiting is enforced by the
787-- compiler-generated `rateLimit` clauses on each route.
788-- Federation requests are unauthenticated: anyone can hit /federation/*.
789-- The `no_presence` check bounds federated forwards to currently-online keys.
791-- Plain ip match (sessions with empty ip skip the check).
793-- Mobile tradeoff: binding a session to an IP means a client that moves between
794-- networks (Wi-Fi <-> cellular, or a carrier NAT re-assignment mid-session) no
795-- longer matches its session row, gets a 401, and must re-run the full
796-- challenge/verify handshake. That is the correct security posture — it is what
797-- stops a stolen Bearer token from being replayed from anywhere — but it is
798-- chatty for exactly the clients this protocol targets: phones change networks
799-- constantly, so re-auth is a routine event, not an exceptional one. Clients are
800-- expected to treat a 401 as "re-authenticate and retry", not as a fatal error.
801-- Operators who front the relay with a proxy that does not set a stable
802-- X-Forwarded-For (or who run with `--trustForwardedFor=False`) get an empty
803-- bound IP, which disables the check entirely — see `clientIpOf`.
804matchIp : Text -> Text -> Bool
805matchIp = \clientIp sessionIp -> sessionIp == "" || clientIp == sessionIp
807-- The client IP a session/challenge is bound to: the last (trusted) hop of the
808-- X-Forwarded-For chain, matching the rate limiter's `pickClientIp`. Taking the
809-- last hop rather than the whole header means client-supplied spoofed hops don't
810-- become part of the binding (a trusted proxy appends the real address last).
811-- Empty when the header is absent or `trustForwardedFor` is off — handlers have
812-- no access to the raw connection address, and an empty bound IP makes `matchIp`
813-- skip the check (so IP binding is simply disabled without a trusted proxy).
814clientIpOf : Maybe Text -> Text
815clientIpOf = \h -> case h of
816 Just {value: ips} -> if trustForwardedFor then lastForwardedHop ips else ""
819-- Resolve a Bearer token to its session pubkey if the session is unexpired and
820-- the client IP matches. Returns Nothing on missing/invalid token.
822-- TIMING SIDE-CHANNEL (known gap, not fixable in Knot today). `s.token == token`
823-- is ordinary string equality, which almost certainly short-circuits on the first
824-- differing byte. An attacker who can time the response therefore learns how many
825-- leading characters of a guess were correct, and can in principle extend a guessed
826-- prefix one hex char at a time instead of searching the whole space. Two things
827-- bound that today, neither of which is a fix:
828-- * the token is 48 random hex chars (192 bits, `genToken`), so a blind guess is
829-- hopeless and the attacker is forced onto the timing channel to make progress;
830-- * `/poll` and `/messages` are per-IP rate limited, and the linear scan over
831-- `*sessions` adds noise on the order of the comparison itself, so the number
832-- of samples needed to resolve a per-byte difference over a network is large.
833-- Neither argument is a security guarantee — they raise the cost of the attack, they
834-- do not remove it. The correct fix is a `constantTimeEquals : Text -> Text -> Bool`
835-- primitive in the Knot runtime (a byte-wise XOR-and-accumulate compare that always
836-- reads both strings in full); swap the `s.token == token` conjunct for it as soon as
837-- one exists. See PROTOCOL.md §6, *Error Responses*.
838authedPubkey : Text -> Int<Ms> -> Text -> IO {r *sessions} (Maybe PubkeyHex)
839authedPubkey = \authorization t clientIp -> do
841 if not hasPrefix "Bearer " authorization
842 then yield (Nothing {})
844 let token = drop 7 authorization
845 yield (case findFirst ses (\s -> s.expiresAt > t && s.token == token && matchIp clientIp s.ip) of
846 Just {value: s} -> Just {value: s.pubkey}
849-- ============================================
850-- Federation failure tracking (simple, no circuit breaker)
851-- ============================================
852-- Linear backoff per peer: each consecutive failure multiplies the delay by
853-- `retryBackoffBase` (capped at `retryBackoffMax`). `shouldRetryServer` is the
854-- single read-side gate; `recordFailure`/`clearFailure` are the write side.
855-- There is no half-open state — a single success clears all accumulated failures.
856-- Concurrent fetches to the same peer can complete out of order, so both
857-- writers take the attempt-start time and ignore updates older than the
858-- recorded one (latest-started attempt wins). `clearFailure` therefore writes
859-- a zero-count row rather than deleting — the timestamp must survive so a
860-- slower failure can be recognized as stale. Zero-count rows impose no
861-- backoff and age out of `*forwardFailures` via `pruneExpired`.
863-- True when enough time has passed since the last failure for `server` to be
864-- worth retrying (or no failure recorded at all). Linear backoff:
865-- `retryBackoffBase * failures`, capped at `retryBackoffMax`.
866shouldRetryServer : Text -> Timestamp -> [ForwardFailure] -> Bool
867shouldRetryServer = \server t failures -> not any (\f -> f.server == server && t - f.failedAt < min retryBackoffMax (retryBackoffBase * (f.failures : Int))) failures
869-- Bump the failure counter for `server`. `attemptAt` is when the failed call
870-- started; the update is skipped when a more recently started attempt has
871-- already written its outcome.
873-- Timestamp ties: `now` has millisecond resolution and `retryPendingForwards`
874-- reuses a single `t` for a whole sweep, so two concurrent attempts on one peer
875-- routinely carry the *same* `attemptAt` — and a strict `>` staleness test calls
876-- neither one stale, making the outcome a plain last-writer-wins race (a success
877-- and a failure at the same millisecond resolve differently depending on which
878-- `fetch` returns first). The tiebreaker: at an equal timestamp a success
879-- outranks a failure, so a zero-count row (the `clearFailure` tombstone) is
880-- treated as stale here, while `clearFailure` overwrites an equal-timestamped
881-- failure. Ties now resolve the same way in both orders. The cost is that a
882-- genuine failure landing in the same millisecond as a success is not counted —
883-- one skipped backoff step inside one millisecond, versus a permanently
884-- order-dependent counter.
885recordFailure : Text -> Timestamp -> IO {rw *forwardFailures} {}
886recordFailure = \server attemptAt -> atomic (do
887 failures <- *forwardFailures
888 let prev = findFirst failures (\f -> f.server == server)
889 let stale = case prev of
890 Just {value: f} -> f.failedAt > attemptAt || (f.failedAt == attemptAt && f.failures == 0)
893 let prevCount = case prev of
894 Just {value: f} -> f.failures
896 *forwardFailures = union (filter (\f -> f.server != server) failures) [
897 {server, failedAt: attemptAt, failures: prevCount + 1}
900-- Reset the failure counter for `server` to zero (called after any successful
901-- peer call; single-success recovery — there is no half-open state). Keeps a
902-- zero-count row so its timestamp can outrank slower concurrent failures.
903-- The staleness test stays strict (`>`) on purpose: at an equal timestamp this
904-- write wins, which is the other half of the tie rule described on
906clearFailure : Text -> Timestamp -> IO {rw *forwardFailures} {}
907clearFailure = \server attemptAt -> atomic (do
908 failures <- *forwardFailures
909 let stale = any (\f -> f.server == server && f.failedAt > attemptAt) failures
911 *forwardFailures = union (filter (\f -> f.server != server) failures) [
912 {server, failedAt: attemptAt, failures: 0}
915-- ============================================
917-- ============================================
918-- Helpers shared by send/poll/federation paths: monotonic sequence
919-- generation, presence queries, and atomic mailbox/presence writes
920-- (callers supply the surrounding `atomic` block).
922-- True when `pk` has a live local presence row (i.e. is currently online here).
923hasLocalPresence : [PresenceEntry] -> PubkeyHex -> Timestamp -> Bool
924hasLocalPresence = \pres pk t -> any (\p -> p.pubkey == pk && isLocalServer p.server && p.expiresAt > t) pres
926-- Project items through `getServer`, drop our own hostname, and dedupe.
927-- Used to derive peer recipient lists from forwards/presence/etc.
929-- Returns `[Text]`, the base type of `ServerName` — see `type ServerName` for why
930-- server names stay unrefined everywhere in state.
931collectPeers : [a] -> (a -> Text) -> [Text]
932collectPeers = \items getServer -> filter (\s -> not isLocalServer s) (map getServer items)
934-- Current sequence value, or 0 before the first message seeds it. Reads the
935-- 0-or-1-row `*seqCounter` relation and folds out the value with a 0 default,
936-- rather than unwrapping a (possibly empty) scalar source — which the runtime
938currentSeq : [{value: Timestamp}] -> Timestamp
939currentSeq = \rows -> fold (\acc r -> max acc r.value) (0 : Timestamp) rows
941-- Append one ciphertext to the local mailbox under a fresh monotonic
942-- sequence. Row-level STM retry on `*messages` wakes any parked /poll
943-- transaction whose filter matches the new row. Caller wraps in `atomic`.
945-- Idempotent on (toKey, encryptedBlob): an identical ciphertext already in the
946-- mailbox is left alone rather than appended again. Both ingress paths need this
947-- — a client retry after a lost response (`handleSendMessages`) and a peer's
948-- re-forward after a lost 200 (`handleForwardMessage`) carry the identical blob,
949-- and the fresh `seqTs` below would otherwise make `union` keep both rows and
950-- double-deliver. Re-reading `*messages` per call also collapses duplicate blobs
951-- appearing twice within one batch.
953-- N3: This O(n) scan is a CPU amplification vector. A batch of 100 identical
954-- blobs to the same recipient triggers 100 × O(|messages|) comparisons. With
955-- |messages| = 10000, that's 1M comparisons per request, bounded by the 60/min
956-- rate limit. A real fix needs an index on (toKey, encryptedBlob) or a
957-- hash-based dedup set — both require runtime support not available in Knot
958-- today. Documented as an accepted DoS surface.
959appendMessage : PubkeyHex -> BlobHex -> Int<Ms> -> IO {rw *messages, rw *seqCounter} {}
960appendMessage = \toKey encryptedBlob t -> do
962 when (not any (\m -> m.toKey == toKey && m.encryptedBlob == encryptedBlob) msgs) (do
963 seqRows <- *seqCounter
964 let seqTs = max t (currentSeq seqRows + 1)
965 *seqCounter = [{value: seqTs}]
966 -- Enforce `maxMessagesPerRecipient` before the append: evict the oldest rows
967 -- for this recipient so the post-append count lands exactly on the ceiling.
968 -- `- 1` reserves the slot the new row is about to take.
970 -- S4: Instead of building an `evicted` list and checking membership (which
971 -- is O(|messages| × |evicted|)), compute the eviction threshold — the
972 -- receivedAt of the (maxMessagesPerRecipient - 1)th oldest message for this
973 -- recipient — and keep only messages newer than it. This is O(|messages|)
974 -- with no inner scan.
975 let forRecipient = filter (\m -> m.toKey == toKey) msgs
976 let excess = max 0 (count forRecipient - (maxMessagesPerRecipient - 1))
977 let sortedRecipient = sortBy (\m -> m.receivedAt) forRecipient
978 -- The threshold: the receivedAt of the last row we want to evict.
979 -- Rows with receivedAt <= threshold are evicted; rows > threshold survive.
980 let evictionThreshold = if excess > 0
981 then case take excess sortedRecipient of
983 xs -> case last xs of
986 let kept = filter (\m -> not (m.toKey == toKey && m.receivedAt <= evictionThreshold && excess > 0)) msgs
987 -- Global cap (S6): after the per-recipient eviction, bound the total mailbox
988 -- across all recipients by dropping the globally-oldest rows. Only runs on
989 -- overflow, so the O(n log n) sort is off the hot path. Dropped rows may
990 -- belong to other recipients; their orphaned *forwards are reclaimed by
991 -- `pruneExpired`, and their lost `deliveredTo` is harmless (the blob is gone).
992 let globallyCapped = if count kept > maxMessagesTotal
993 then drop (count kept - maxMessagesTotal) (sortBy (\m -> m.receivedAt) kept)
995 *messages = union globallyCapped [{toKey, encryptedBlob, receivedAt: seqTs, deliveredTo: []}])
997-- Record that `server` has accepted a federated forward of this message, so a
998-- later presence re-announce of `toKey` doesn't re-forward the same blob to a peer
999-- that already has it. No-op when the peer is already listed. Caller wraps in
1001markDelivered : PubkeyHex -> BlobHex -> Text -> IO {rw *messages} {}
1002markDelivered = \toKey blob server -> do
1004 *messages = map (\m -> if m.toKey == toKey && m.encryptedBlob == blob && not any (\d -> d.server == server) m.deliveredTo
1005 then {m.toKey, m.encryptedBlob, m.receivedAt, deliveredTo: union m.deliveredTo [{server}]}
1008-- True when `f` is the queued forward of `blob` to `toKey` at `server`. Used to
1009-- dedupe entries on the forwards outbox. All three fields matter: the same blob
1010-- can legitimately be queued to the same peer for two *different* recipients (a
1011-- sender fanning one ciphertext out to several keys), and matching on
1012-- (blob, server) alone would let completing one of them drop the others.
1013forwardMatches : PubkeyHex -> BlobHex -> Text -> ForwardEntry -> Bool
1014forwardMatches = \toKey blob server f -> f.toKey == toKey && f.encryptedBlob == blob && f.toServer == server
1016-- Replace any local presence rows for `pubkey` with one fresh row at
1017-- `expiry`, and return the post-update peer broadcast set. Caller wraps in
1019refreshLocalPresence : PubkeyHex -> Timestamp -> IO {rw *presence} [Text]
1020refreshLocalPresence = \pubkey expiry -> do
1022 *presence = union (filter (\p -> not (p.pubkey == pubkey && isLocalServer p.server)) pres) [
1023 {pubkey, server: serverHost, expiresAt: expiry}
1025 yield (collectPeers pres (\p -> p.server))
1027-- ============================================
1029-- ============================================
1031-- One sweep over every state ref: drops expired rows in a single atomic block.
1032-- Returns the locally-expired presence rows whose pubkey has no other live
1033-- local session, so the caller can broadcast offline gossip for them.
1034-- Also prunes orphaned *forwards entries whose message has been removed by
1035-- the TTL sweep — a 404-deferred forward (recipient never online at the peer)
1036-- would otherwise stay forever with retries=0, retried every sweep indefinitely.
1037pruneExpired : Int<Ms> -> IO {rw *challenges, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, rw *sessions} [PubkeyHex]
1038pruneExpired = \t -> atomic do
1040 *challenges = filter (\x -> x.expiresAt > t) ch
1042 *sessions = filter (\x -> x.expiresAt > t) ses
1044 let surviving = filter (\m -> t - m.receivedAt < messageMaxAge) msgs
1045 *messages = surviving
1046 -- Prune forwards whose message was removed by the TTL sweep above.
1047 -- ForwardEntry carries no timestamp, so match against the surviving
1048 -- messages (the post-sweep list, not the pre-sweep snapshot).
1050 -- S5: This is O(|forwards| × |surviving|) — a quadratic scan. In practice
1051 -- |forwards| is usually far below maxForwardsTotal (50000) and |surviving|
1052 -- is bounded by maxMessagesTotal (1000000), so the cost is modest. A real
1053 -- fix needs a set/index keyed on (toKey, encryptedBlob), which the Knot
1054 -- runtime does not expose today. Documented as an accepted design tradeoff.
1056 *forwards = filter (\f -> any (\m -> m.toKey == f.toKey && m.encryptedBlob == f.encryptedBlob) surviving) fw
1057 ff <- *forwardFailures
1058 *forwardFailures = filter (\f -> t - f.failedAt < forwardFailureMaxAge) ff
1059 -- presence: remember locally-expired keys for offline gossip
1061 let live = filter (\p -> p.expiresAt > t) pres
1063 let liveLocalPubkeys = map (\p -> p.pubkey) (filter (\p -> isLocalServer p.server) live)
1064 yield (map (\p -> p.pubkey) (filter (\p -> p.expiresAt <= t && isLocalServer p.server && not elem p.pubkey liveLocalPubkeys) pres))
1066-- ============================================
1068-- ============================================
1069-- Construction and outbound dispatch of presence gossip events. Failures from
1070-- a peer record into `forwardFailures` (shared with forward retries) so both
1071-- subsystems back off together.
1073-- The gossip fan-out set: peers learned from `*presence` plus the configured
1074-- bootstrap seeds, minus ourselves.
1076-- This union is the whole bootstrap mechanism (see `seedPeers`). Seeds are *not*
1077-- written into `*presence` to make them stick: a `PresenceEntry` is keyed by the
1078-- pubkey it announces, and a seed peer is a hostname we know nothing else about —
1079-- there is no pubkey to key a row on, and inventing one would put a phantom key
1080-- into the very table `forwardQueuedToServer` trusts to route mail. Folding seeds
1081-- in at fan-out time instead means they are gossip *targets* without ever being
1082-- presence *facts*. Once a seed answers, its own gossip creates the real presence
1083-- rows, and from then on it is reachable through the `peers` half of this union
1084-- like any other peer.
1085gossipTargets : [Text] -> [Text]
1086gossipTargets = \peers -> union peers seedPeerList
1088-- Fan out one bundle of gossip events to each peer (presence-learned peers and
1089-- bootstrap seeds alike), skipping denylisted peers and peers in backoff. No-op
1090-- when `events` is empty so callers don't need to guard. Records or clears
1091-- federation-failure counters per call.
1093-- Also a no-op when `serverHost` fails the `ServerName` predicate: the gossip
1094-- body must carry a valid `fromServer`, and a peer would reject (400) a name we
1095-- could not have refined anyway. `main` warns about this at startup.
1096sendBatchedGossip : [Text] -> [GossipEvent] -> IO {rw *forwardFailures, network, clock} {}
1097sendBatchedGossip = \peers events -> case localServerName of
1098 Nothing {} -> yield {}
1099 Just {value: me} -> when (count events > 0) (do
1101 failures <- *forwardFailures
1102 forEach (gossipTargets peers) (\server -> when (not (isBadServerName server) && shouldRetryServer server t failures) (do
1103 result <- fetch (federationUrl server) (RecvGossip {events, fromServer: me})
1105 Err _ -> recordFailure server t
1106 Ok _ -> clearFailure server t)))
1108-- ============================================
1110-- ============================================
1111-- `retryPendingForwards` walks queued cross-server forwards in batches per
1112-- destination, increments retry counts, and gives up after `maxForwardRetries`.
1113-- `forwardQueuedToServer` is the catch-up path triggered when a remote key
1114-- comes online: any messages already buffered for that pubkey are enqueued
1115-- as forwards to the newly-known server.
1117-- Attempt every forward in `batch` to one peer, in order, and report both whether
1118-- any attempt was a genuine peer failure (`anyFailed`) and whether any attempt
1119-- genuinely succeeded (`anySucceeded`). Drops successful entries from `*forwards`
1120-- and records the peer on the message's `deliveredTo`; every attempt (success,
1121-- failure, or 404) bumps the retry count and gives up after `maxForwardRetries`.
1123-- INVARIANT — this must not touch `*forwardFailures`. The caller records at most one
1124-- failure per peer per sweep, from the `anyFailed` flag returned here; recording per
1125-- failing *message* would let one unreachable peer with N buffered messages take N
1126-- backoff steps in a single sweep and pin itself at `retryBackoffMax` for
1127-- `forwardFailureMaxAge`. The counter counts consecutive failed *sweeps*.
1129-- A 404 is NOT a peer failure. `handleForwardMessage` answers 404 `no_presence`
1130-- whenever the recipient is not *currently* online at that peer, which is an
1131-- expected, retryable outcome (PROTOCOL.md §7) — the peer is healthy and answering.
1132-- `fetch` returns `Err` for every status >= 400, so treating any `Err` as a failure
1133-- would feed a routine 404 into `recordFailure`, and `*forwardFailures` is shared
1134-- with gossip: one stale-presence 404 would suppress all forwards *and* all gossip to
1135-- that peer for a full backoff step (30 s–8 min). So a 404 leaves the peer's backoff
1136-- untouched (`anyFailed` stays false for it) and never clears it (`anySucceeded`
1139-- But a 404 DOES bump the forward's retry count now (S1). It previously left the row
1140-- entirely untouched, so a forward whose recipient never came online at the peer was
1141-- retried every sweep for the full 30-day message TTL — the counter never advanced,
1142-- so `maxForwardRetries` was never reached. Counting the attempt (without charging
1143-- the peer's backoff) lets the forward hit the cap and be dropped after
1144-- `maxForwardRetries` sweeps while still not penalizing a healthy peer.
1146-- Recursive rather than `forEach` because the result has to be accumulated across
1147-- iterations; `sortBy` fixes the iteration order that `head`/`drop 1` then walk.
1148retryForwardsTo : Text -> [ForwardEntry] -> IO {rw *forwards, rw *messages, network} {anyFailed: Bool, anySucceeded: Bool}
1149retryForwardsTo = \server batch -> case head batch of
1150 Nothing {} -> yield {anyFailed: False {}, anySucceeded: False {}}
1151 Just {value: f} -> do
1152 result <- fetch (federationUrl server) (ForwardMessage {f.toKey, f.encryptedBlob})
1153 let status = case result of
1154 Err {error: e} -> e.status
1156 let success = status < 400
1157 -- Recipient simply isn't online at the peer yet: hold the peer blameless, but
1158 -- still count the attempt so the row can't outlive the message TTL (S1).
1159 let deferred = status == 404
1160 let isMatch = forwardMatches f.toKey f.encryptedBlob server
1161 let isDone = \x -> isMatch x && (success || x.retries + 1 >= maxForwardRetries)
1164 -- Count the attempt regardless of outcome: a 404 still consumes a retry slot
1165 -- so a forward that never finds the recipient online is eventually dropped
1166 -- (S1). On success or after `maxForwardRetries`, `isDone` filters the row out
1167 -- first, so the increment then no-ops on an absent row.
1168 *forwards = map (\x -> if isMatch x
1169 then {x.toServer, x.toKey, x.encryptedBlob, retries: x.retries + 1}
1170 else x) (filter (\x -> not isDone x) cur)
1171 when success (markDelivered f.toKey f.encryptedBlob server))
1172 rest <- retryForwardsTo server (drop 1 batch)
1173 yield {anyFailed: (not success && not deferred) || rest.anyFailed, anySucceeded: success || rest.anySucceeded}
1175-- Walk pending forwards grouped by destination and retry each peer's backlog (up
1176-- to maxBatchSize per peer) via `/federation/forward`. One failure record per peer
1177-- per sweep: a sweep with any genuine failure takes exactly one backoff step; a
1178-- sweep with at least one genuine success clears the peer's backoff; an all-404
1179-- sweep leaves the backoff untouched, neither charging nor clearing it (S1). See
1180-- `retryForwardsTo`.
1181retryPendingForwards : IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} {}
1182retryPendingForwards = do
1185 failures <- *forwardFailures
1186 forEach (collectPeers fwds (\f -> f.toServer)) (\server -> if isBadServerName server
1187 -- Denylisted destination (state persisted before a denylist tightening):
1188 -- its forwards would never be attempted, so drop them instead of letting
1189 -- them sit in the outbox forever. The denylist check stays outside the
1190 -- atomic predicate — only the plain equality filter is pushed down.
1193 *forwards = filter (\x -> x.toServer != server) cur)
1194 else when (shouldRetryServer server t failures) (do
1195 -- INVARIANT — `[a]` is an unordered set, so the backlog must be sorted before
1196 -- `take maxBatchSize` or the batch is an implementation-defined subset that
1197 -- could keep retrying the same entries while starving others past the cap. A
1198 -- stable key drains a fixed prefix as entries succeed (removed) or hit
1199 -- `maxForwardRetries` (dropped). `ForwardEntry` carries no timestamp, so key on
1201 let batch = take maxBatchSize (sortBy (\f -> f.encryptedBlob) (filter (\f -> f.toServer == server) fwds))
1202 result <- retryForwardsTo server batch
1203 -- Clear the peer's backoff only on a sweep with at least one genuine success
1204 -- (S1). An all-404 sweep (recipient not online at the peer) is neither a
1205 -- failure nor a success: clearing backoff on it would reset the peer to
1206 -- "fresh" every sweep, firing a retry every `backgroundPruneInterval` for the
1207 -- full 30-day message TTL. `count batch > 0` also guards against reading an
1208 -- empty sweep (possible with a startup-overridden `maxBatchSize` of 0) as
1211 then recordFailure server t
1212 else when (count batch > 0 && result.anySucceeded) (clearFailure server t)))
1214-- Forward queued messages to a server when a remote key comes online.
1215-- Skips messages already delivered to `server` (tracked via Message.deliveredTo)
1216-- so a presence re-announce after a TTL lapse doesn't duplicate delivery.
1218-- SECURITY: this is the function the gossip-redirect attack in the section header
1219-- above actually cashes out through — it routes on `*presence`, which any
1220-- unauthenticated host can write. Do not add a caller that widens what this
1221-- forwards (e.g. dropping the `deliveredTo` filter) without revisiting that note.
1222forwardQueuedToServer : PubkeyHex -> ServerName -> IO {rw *forwards, r *messages} {}
1223forwardQueuedToServer = \pubkey serverName -> atomic (do
1224 let server = (serverName : Text)
1227 let existing = countWhere (\f -> f.toServer == server) fwds
1228 let budget = max 0 (maxForwardsPerServer - existing)
1229 let notYetForwarded = \m -> not any (forwardMatches m.toKey m.encryptedBlob server) fwds
1230 let notYetDelivered = \m -> not any (\d -> d.server == server) m.deliveredTo
1231 let candidates = filter (\m -> m.toKey == pubkey && notYetForwarded m && notYetDelivered m) msgs
1232 let newFwds = map (\m -> {toServer: server, m.toKey, m.encryptedBlob, retries: 0}) (take budget (sortBy (\m -> m.receivedAt) candidates))
1233 *forwards = capForwards (union fwds newFwds))
1235-- Batched version of `forwardQueuedToServer`: stage forwards for *all* newly-online
1236-- keys in a single mailbox scan (S4). Calling `forwardQueuedToServer` per key scans
1237-- `*messages` once per key, which is why `handleRecvGossip` previously capped the
1238-- number of keys at `maxNewlyOnlineForwards` (N13) — but that cap silently deferred
1239-- delivery past the 10th key, and a re-announce within the TTL never recovered it
1240-- (the `deliveredTo`/presence state made the key look already-handled). A single
1241-- pass bounds the cost to O(|messages|) regardless of how many keys came online.
1243-- SECURITY: shares `forwardQueuedToServer`'s exposure — it routes on gossip-written
1244-- presence. The same `deliveredTo` / `notYetForwarded` / per-peer budget guards
1245-- apply; do not widen them without revisiting the gossip-redirect note above.
1246forwardQueuedToAll : [PubkeyHex] -> ServerName -> IO {rw *forwards, r *messages} {}
1247forwardQueuedToAll = \pubkeys serverName -> atomic (do
1248 let server = (serverName : Text)
1251 let existing = countWhere (\f -> f.toServer == server) fwds
1252 let budget = max 0 (maxForwardsPerServer - existing)
1253 let notYetForwarded = \m -> not any (forwardMatches m.toKey m.encryptedBlob server) fwds
1254 let notYetDelivered = \m -> not any (\d -> d.server == server) m.deliveredTo
1255 -- `elem m.toKey pubkeys` is O(|pubkeys|), but `pubkeys` is bounded by
1256 -- `maxGossipEvents` (100), so the scan stays O(|messages|) overall.
1257 let candidates = filter (\m -> elem m.toKey pubkeys && notYetForwarded m && notYetDelivered m) msgs
1258 let newFwds = map (\m -> {toServer: server, m.toKey, m.encryptedBlob, retries: 0}) (take budget (sortBy (\m -> m.receivedAt) candidates))
1259 *forwards = capForwards (union fwds newFwds))
1261-- ============================================
1262-- Handler: challenge / verify
1263-- ============================================
1264-- Identity is a public key; there are no accounts. The flow is:
1265-- 1. Client requests a fresh nonce (`handleChallenge`).
1266-- 2. Client signs the nonce with its private key and submits the signature
1267-- together with the original challenge (`handleVerifyAuth`).
1268-- 3. Server returns a Bearer token bound to (pubkey, ip, expiry); the new
1269-- session also installs a local presence row and gossips an `online`
1270-- event to known peers.
1271-- Sessions expire on their own (`sessionExpiry`); there is no client-driven
1274-- POST /auth/challenge: issue a fresh signed-nonce challenge for `pubkey`.
1275-- Capped per-key (maxChallengesPerKey); per-client-IP rate limiting is enforced
1276-- by the route's `rateLimit` clause. The IP is recorded so /auth/verify can
1277-- require the same client.
1279-- A full pool LRU-evicts rather than rejecting, exactly as `handleVerifyAuth` does
1280-- for `maxSessions`. Answering 503 once `maxChallenges` is reached would hand any
1281-- attacker who can fill the pool a total login outage — nobody can start a
1282-- handshake, including clients whose challenges are already in flight. Evicting the
1283-- soonest-to-expire challenge instead degrades to "an abandoned challenge may be
1284-- dropped before its 60 s window elapses", which costs the affected client one
1285-- retry. The freshly-issued row always survives its own `capList`: it carries the
1286-- latest `expiresAt` of any live challenge by construction.
1287handleChallenge : PubkeyHex -> Text -> IO {rw *challenges, clock, random} (Result HttpError {challenge: Text, expiresAt: Timestamp})
1288handleChallenge = \pubkey clientIp -> do
1290 challenge <- genToken 48 ""
1291 let expiresAt = t + challengeExpiry
1294 let cappedActive = capPerKey (filter (\c -> c.expiresAt > t) ch) pubkey maxChallengesPerKey
1295 *challenges = capList (union cappedActive [{pubkey, challenge, expiresAt, ip: clientIp}]) maxChallenges
1296 yield (Ok {value: {challenge, expiresAt}}))
1298-- POST /auth/verify: validate `signature` over `challenge` for `pubkey`.
1299-- On success, mints a session token, records local presence (`pubkey` is now
1300-- live on this server), and gossips an `online` event to known peers. If
1301-- `revokeOthers` is set, all other sessions for the same pubkey are dropped.
1302handleVerifyAuth : PubkeyHex -> Text -> Text -> Bool -> Text -> IO {rw *challenges, rw *forwardFailures, rw *presence, rw *sessions, network, clock, random, console} (Result HttpError {expiresAt: Timestamp, token: Text})
1303handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp -> do
1305 let expiry = t + sessionExpiry
1306 token <- genToken 48 ""
1307 -- The client signs (target host, challenge) under a domain-separation tag so a
1308 -- relay server cannot replay the signature to a different server. We verify
1309 -- against our own configured hostname (port stripped), which a relay cannot forge.
1311 -- Signature verification is split out of the session-install transaction (S7).
1312 -- Phase 1 is a cheap read-only atomic that confirms a matching, unexpired,
1313 -- IP-bound challenge exists — the original CPU-DoS guard, which still spends no
1314 -- Ed25519 CPU on /auth/verify calls that have no matching challenge. Phase 2 runs
1315 -- the expensive `verify` *outside* any atomic, so an STM retry on the phase-3
1316 -- install transaction (triggered by concurrent writes to *challenges/*sessions)
1317 -- never re-executes it — previously `verify` sat inside that transaction and every
1318 -- retry re-ran the Ed25519 check. Phase 3 re-checks the challenge before consuming
1319 -- it, closing the TOCTOU window opened between phases 1 and 3.
1320 let signedText = "skrepka-auth-v1:" ++ authHost serverHost ++ ":" ++ challenge
1321 challengeOk <- atomic (do
1323 let same = \c -> c.pubkey == pubkey && c.challenge == challenge
1324 case findFirst ch same of
1325 Nothing {} -> yield (False {})
1326 Just {value: c} -> yield (c.expiresAt > t && matchIp clientIp c.ip))
1328 then yield (Err {error: {status: 401, message: "invalid"}})
1330 -- Phase 2: verify OUTSIDE any atomic. Expensive, and must not be re-executed on
1331 -- an STM retry of the install transaction below (S7).
1332 let sigValid = case bytesFromHex pubkey of
1333 Just {value: pk} -> case bytesFromHex signature of
1334 Just {value: sigBytes} -> verify pk (textToBytes signedText) sigBytes
1338 then yield (Err {error: {status: 401, message: "invalid"}})
1340 -- Phase 3: re-check the challenge (it may have expired or been consumed by a
1341 -- concurrent verify since phase 1), consume it, and install the session. The
1342 -- body is cheap, so an STM retry here costs almost nothing.
1343 result <- atomic (do
1345 let same = \c -> c.pubkey == pubkey && c.challenge == challenge
1346 let matchingChallenge = findFirst ch same
1347 case matchingChallenge of
1348 Nothing {} -> yield (Nothing {})
1349 Just {value: c} -> do
1350 if not (c.expiresAt > t && matchIp clientIp c.ip)
1351 then yield (Nothing {})
1353 -- Consume the challenge and optionally revoke other sessions + challenges.
1354 -- When `revokeOthers` is set, drop all other sessions AND outstanding
1355 -- challenges for this pubkey, so a captured challenge cannot be
1356 -- redeemed for a new session after revocation (Q35).
1357 *challenges = if revokeOthers
1358 then filter (\x -> not (x.pubkey == pubkey)) ch
1359 else filter (\x -> not same x) ch
1361 let pruned = if revokeOthers
1362 then filter (\s -> s.pubkey != pubkey) ses
1363 else capPerKey ses pubkey maxSessionsPerKey
1364 let newSession = {token, pubkey, expiresAt: expiry, ip: clientIp}
1365 -- LRU-evicts the soonest-to-expire session when the pool is full; this global
1366 -- eviction is Sybil-floodable, see the LIMITATION note on `maxSessions`.
1367 let pooled = union pruned [newSession]
1368 -- Count what `capList` is about to shed, so the handler can warn about it
1369 -- below. That flood has no other observable signature: evicted users just
1370 -- start seeing 401s and silently re-authenticate, which looks like normal
1371 -- traffic in the access log. A sustained nonzero rate here is the alert.
1372 let evicted = max 0 (count pooled - maxSessions)
1373 *sessions = capList pooled maxSessions
1374 peers <- refreshLocalPresence pubkey expiry
1375 yield (Just {value: {peers, evicted}}))
1377 Nothing {} -> yield (Err {error: {status: 401, message: "invalid"}})
1378 Just {value: r} -> do
1379 -- Warn outside the `atomic` block, never inside: an STM transaction can
1380 -- retry, and a console write is not rolled back with it — logging inside
1381 -- would emit one line per retry attempt rather than one per eviction.
1382 -- Include the requesting pubkey and IP for audit (Q38): an operator
1383 -- investigating a Sybil flood needs to know which identities are responsible.
1384 when (r.evicted > 0) (logWarn ("session pool full: evicted " ++ show r.evicted ++ " session(s) to seat a new login (pubkey=" ++ pubkey ++ ", ip=" ++ clientIp ++ ", maxSessions=" ++ show maxSessions ++ ")"))
1385 when federationEnabled (fork (sendBatchedGossip r.peers [{eventType: "online", pubkey: Just {value: pubkey}}]))
1386 yield (Ok {value: {token, expiresAt: expiry}})
1388-- ============================================
1390-- ============================================
1391-- Long-poll. The client supplies a cursor (last-seen `receivedAt`). We:
1392-- * Ack-and-drop everything <= the cursor (treating poll progress as ack).
1393-- * Race a row-level STM wait on `*messages` against `pollTimeoutMs` and
1394-- return new events plus piggybacked sender-side expirations/deliveries.
1396-- POST /poll: long-poll body. Treats the cursor advance as an implicit ack
1397-- (`ackPolledMessages`), refreshes the caller's local presence row so peers
1398-- don't time us out mid-session, then runs `doPoll` to collect events (or
1399-- block until a matching message arrives or the timeout elapses) and
1400-- assembles the response.
1401handlePoll : Timestamp -> Text -> Text -> IO {r *seqCounter, r *sessions, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, network, clock} (Result HttpError {cursor: Timestamp, events: [PollEvent]})
1402handlePoll = \cursor authorization clientIp -> do
1405 auth <- authedPubkey authorization t clientIp
1407 Nothing {} -> yield (Nothing {})
1408 Just {value: pubkey} -> do
1409 -- Clamp the client cursor to the highest assigned sequence
1410 -- (`*seqCounter`), not wall-clock `t`. Under sustained high throughput
1411 -- `receivedAt` (= `seqTs`) can run ahead of `t`; clamping to `t` would
1412 -- drag a legitimately-returned cursor backward and re-deliver the
1413 -- in-between messages. `max t curSeq` keeps the old behaviour when the
1414 -- counter is idle/behind, while still refusing to ack beyond what's
1416 curSeqRows <- *seqCounter
1417 let curSeq = currentSeq curSeqRows
1418 let clampedCursor = max 0 (min (max t curSeq) cursor)
1419 when (clampedCursor > 0) (ackPolledMessages pubkey clampedCursor)
1421 -- Refresh local presence when less than half the session TTL remains,
1422 -- so peers don't time us out mid-session.
1423 let stale = not any (\p -> p.pubkey == pubkey && isLocalServer p.server && p.expiresAt - t >= sessionExpiry / 2) pres
1424 refreshPeers <- if stale then refreshLocalPresence pubkey (t + sessionExpiry) else yield []
1425 -- S3: Track whether we actually refreshed so the gossip line below
1426 -- only fires on a refresh, not on every poll. Without this, every
1427 -- poll gossips to all seed peers via gossipTargets [], creating
1428 -- O(clients × seeds) federation traffic per poll cycle.
1429 yield (Just {value: {pubkey, clampedCursor, refreshPeers, didRefresh: stale}}))
1431 Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
1432 Just {value: s} -> do
1433 -- S3: Only gossip when we actually refreshed presence — not on every poll.
1434 when (federationEnabled && s.didRefresh) (fork (sendBatchedGossip s.refreshPeers [{eventType: "online", pubkey: Just {value: s.pubkey}}]))
1435 pollResult <- doPoll s t
1436 yield (Ok {value: pollResult})
1438-- One pass: collect this pubkey's unexpired messages newer than the cursor,
1439-- sort by receivedAt, take up to `maxPollEvents`. The returned cursor is the
1440-- max `receivedAt` in the page (or the input cursor when the page is empty),
1441-- which the client echoes on the next /poll to advance — and which the
1442-- server treats as an implicit ack.
1443-- If the page is empty, race a row-level STM wait against `pollTimeoutMs`:
1444-- the wait transaction reads `*messages` and `retry`s until a row matching
1445-- this pubkey/cursor is committed; the timer wins on idle. Either way we
1446-- re-collect at the new wall time, so a timeout returns an empty page.
1448-- Messages addressed to `pk`, unexpired at `tnow`, and newer than `cursor`. Shared
1449-- by `doPoll`'s collect and STM-wait arms so the two predicates cannot drift: a
1450-- wait that accepted a row the collect then filtered out (say, an expired row still
1451-- above the cursor) would wake the poll, return an empty page with an unchanged
1452-- cursor, and spin the client through an immediate re-poll into the same wakeup.
1453freshFor : PubkeyHex -> Timestamp -> Timestamp -> [Message] -> [Message]
1454freshFor = \pk cursor tnow msgs -> filter (\m -> m.toKey == pk && tnow - m.receivedAt < messageMaxAge && m.receivedAt > cursor) msgs
1456doPoll : {clampedCursor: Timestamp, pubkey: PubkeyHex | a} -> Timestamp -> IO {r *messages, clock} {cursor: Timestamp, events: [PollEvent]}
1458 let collectAt = \tnow -> atomic (do
1460 let limited = take maxPollEvents (sortBy (\m -> m.receivedAt) (freshFor s.pubkey s.clampedCursor tnow msgs))
1462 events: map (\m -> {m.encryptedBlob}) limited,
1463 cursor: fold (\acc m -> max acc m.receivedAt) s.clampedCursor limited
1465 initial <- collectAt t
1466 if count initial.events > 0
1469 -- `race` requires both arms to share a single effect row, so each arm
1470 -- carries the union {r *messages, clock} — the STM wait gets a `now`,
1471 -- the timer gets a no-op `*messages` read.
1477 if count (freshFor s.pubkey s.clampedCursor tw msgs) > 0 then yield {} else retry))
1479 atomic (do _ <- *messages; yield {})
1480 sleep pollTimeoutMs)
1484-- Treat the supplied cursor as an ack: drop all messages with
1485-- receivedAt <= cursor, plus their pending forwards.
1487-- The ack is destructive and keyed on `pubkey` alone — no session identity enters
1488-- into it, so two sessions sharing one keypair race over one mailbox. Accepted
1489-- limitation; see `maxSessionsPerKey`.
1490-- Self-atomic: touches two refs (*messages and *forwards), so wraps its own
1491-- transaction rather than relying on the caller's.
1492ackPolledMessages : PubkeyHex -> Timestamp -> IO {rw *forwards, rw *messages} {}
1493ackPolledMessages = \pubkey cursor -> atomic (do
1495 let matches = \m -> m.toKey == pubkey && m.receivedAt <= cursor
1496 let toAck = filter matches msgs
1497 let blobs = map (\m -> m.encryptedBlob) toAck
1498 *messages = filter (\m -> not matches m) msgs
1500 *forwards = filter (\f -> not (f.toKey == pubkey && elem f.encryptedBlob blobs)) fwds)
1502-- ============================================
1504-- ============================================
1505-- Accept a batch of messages for recipient pubkeys. Placement (live local
1506-- session, federated forward, or held-for-presence) is internal; the call
1507-- either succeeds (every message enqueued) or fails with a non-2xx HTTP
1508-- status carrying the rejection code ("self_send" | ...).
1509-- Duplicates are silently treated as success so retries are idempotent.
1510-- Per-client-IP send rate is enforced by the route's `rateLimit` clause.
1511-- Federated forwards are kicked off in background forks after the atomic.
1512-- The sender's UI treats every success the same and learns "they got it" only via
1513-- the recipient's E2E ack.
1515-- Batch validation: checks batch size, per-message field validity, and self-send.
1516-- Refined-type validation at the route boundary only fires for top-level scalar
1517-- body fields; `to`/`encryptedBlob` are nested inside the `messages` list, so the
1518-- runtime does not check them. `isValidBlobHex` is the same predicate `BlobHex`
1519-- refines on, so this check and the route boundary cannot drift apart.
1520validateBatch : [{to: PubkeyHex, encryptedBlob: BlobHex | a}] -> PubkeyHex -> Maybe HttpError
1521validateBatch = \messages senderKey ->
1522 if count messages > maxBatchSize
1523 then Just {value: {status: 413, message: "batch_too_large"}}
1524 else if any (\m -> not (isValidExactHex 64 m.to && isValidBlobHex m.encryptedBlob)) messages
1525 then Just {value: {status: 400, message: "invalid_message"}}
1526 else if any (\m -> m.to == senderKey) messages
1527 then Just {value: {status: 400, message: "self_send"}}
1530-- POST /messages: send a list of ciphertexts atomically. Self-send is
1531-- rejected up-front; the remaining batch is committed inside one atomic
1532-- block (all-or-nothing) which reads presence to pre-stage federation
1533-- forwards. Federation forwards are kicked per message after commit.
1534handleSendMessages : [{encryptedBlob: BlobHex, to: PubkeyHex | a}] -> Text -> Text -> IO {r *presence, r *sessions, rw *forwardFailures, rw *forwards, rw *messages, rw *seqCounter, network, clock} (Result HttpError {})
1535handleSendMessages = \messages authorization clientIp -> do
1537 auth <- authedPubkey authorization t clientIp
1539 Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
1540 Just {value: senderKey} -> case validateBatch messages senderKey of
1541 Just {value: err} -> yield (Err {error: err})
1543 committed <- atomic (do
1545 -- S2: cap the immediate fan-out at `maxForwardsPerServer` servers per
1546 -- recipient. The post-commit `forkForwardsTo` fires against this list
1547 -- directly (bypassing the `*forwards` queue and its per-peer cap), so
1548 -- without a bound here a recipient gossiped as present on thousands of
1549 -- servers would spawn one immediate HTTP forward per server per message.
1550 let staged = map (\m -> {
1553 remoteServers: take maxRemoteServersPerMessage (collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server))
1555 forEach staged (\c -> do
1556 -- Read `*messages` *before* the append: `delivered` below must see the
1557 -- pre-existing row, and re-reading each iteration is also what lets
1558 -- `appendMessage`'s own dedupe collapse a blob repeated within one batch.
1559 existingMsgs <- *messages
1560 appendMessage c.to c.encryptedBlob t
1561 -- Peers that already hold this blob — from an earlier send of the
1562 -- identical ciphertext that was forwarded then pruned from
1563 -- `*forwards`. A brand-new message has empty `deliveredTo`, so this
1564 -- is `[]` on the normal path; on a client resend it carries the real
1565 -- set. Mirrors `forwardQueuedToServer`'s guard so we don't re-stage a
1566 -- forward to a peer that already accepted this blob.
1567 let delivered = case findFirst existingMsgs (\m -> m.toKey == c.to && m.encryptedBlob == c.encryptedBlob) of
1568 Just {value: m} -> map (\d -> d.server) m.deliveredTo
1569 Nothing {} -> ([] : [Text])
1570 -- Stage outbox rows for peers under their `maxForwardsPerServer`
1571 -- ceiling. Peers at the cap still get the immediate post-commit
1572 -- delivery attempt (`forkForwardsTo`) — only the retry-queue row
1574 when federationEnabled (do
1576 let newFwds = map (\s -> {toServer: s, toKey: c.to, c.encryptedBlob, retries: 0}) (filter (\s -> not (any (forwardMatches c.to c.encryptedBlob s) fwds) && not elem s delivered && countWhere (\f -> f.toServer == s) fwds < maxForwardsPerServer) c.remoteServers)
1577 *forwards = capForwards (union fwds newFwds)))
1579 when federationEnabled (forEach committed (\c -> fork (forkForwardsTo c.to c.encryptedBlob c.remoteServers)))
1580 yield (Ok {value: {}})
1582-- Fire one /federation/forward call per pre-staged server. On success the
1583-- corresponding row in `forwards` is pruned and the peer is appended to the
1584-- message's `deliveredTo` set. The backing `*messages` row itself stays —
1585-- cleaned up by `ackPolledMessages` when the recipient polls here, or by
1586-- `pruneExpired` once `messageMaxAge` lapses. Keeping the row lets
1587-- `forwardQueuedToServer` re-forward to peers learned after send time (so a
1588-- multi-homed recipient who appears on a new peer post-send still receives
1589-- the message), and `deliveredTo` prevents re-forwards to peers that already
1590-- have the message. On failure the forwards row stays so
1591-- `retryPendingForwards` can re-attempt with backoff.
1593-- A 404 is not a peer failure — see `retryForwardsTo` for why `no_presence` must
1594-- not reach `recordFailure`. Here the row is left queued for the retry sweep and
1595-- the peer's backoff (shared with gossip) is not touched.
1596forkForwardsTo : PubkeyHex -> BlobHex -> [Text] -> IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} {}
1597forkForwardsTo = \to encryptedBlob servers -> forEach servers (\server -> when (not isBadServerName server) (do
1599 result <- fetch (federationUrl server) (ForwardMessage {toKey: to, encryptedBlob})
1600 let same = forwardMatches to encryptedBlob server
1602 Err {error: e} -> when (e.status != 404) (recordFailure server t)
1604 clearFailure server t
1607 *forwards = filter (\x -> not same x) fwds
1608 markDelivered to encryptedBlob server)))
1610-- ============================================
1611-- Handler: federation receive
1612-- ============================================
1613-- Inbound peer-to-peer endpoints. Federation is open and unauthenticated:
1614-- the `no_presence` check in `handleForwardMessage` bounds forwards to
1615-- currently-online local keys. Both handlers refuse with 403 when
1616-- `federationEnabled` is off, matching the outbound paths — a single-node
1617-- deployment accepts no peer writes to `*presence`/`*messages`.
1619-- SECURITY — THE OPEN-FEDERATION THREAT MODEL (accepted v0.1 limitations; the
1620-- canonical statement, referenced by the handlers below and by
1621-- `forwardQueuedToServer`). Neither endpoint authenticates its caller and nothing
1622-- ties an event to the key it speaks for, so any host that can reach us may:
1624-- * announce an arbitrary victim pubkey as `online` at itself. We write that
1625-- presence row, and the next `forwardQueuedToServer` hands the victim's queued
1626-- ciphertext to the attacker's host — a *gossip redirect*.
1627-- * append an arbitrary blob to any currently-online local key's mailbox, which
1628-- the recipient then polls down — *unauthenticated mailbox injection*.
1630-- Neither breaks confidentiality or allows forgery. Payloads are sealed to the
1631-- recipient's key and the sender's identity and signature live *inside* the AEAD
1632-- (PROTOCOL.md §5), so a redirected blob cannot be read and an injected blob that
1633-- does not open — or opens without a valid inner signature — is dropped by the
1634-- client and can never impersonate a contact. What the attacker gets is metadata a
1635-- relay is otherwise never supposed to concentrate (which keys receive traffic, how
1636-- much, when), unsolicited storage and bandwidth, and — because our copy is pruned
1637-- once marked `deliveredTo` — the ability to *withhold* delivery by steering a
1638-- ciphertext at a host that will never serve it. Confidentiality-preserving;
1639-- availability- and metadata-affecting.
1641-- Bounded, not prevented, by: the SSRF deny-list (`isBadServerName`), the
1642-- `no_presence` gate, per-IP rate limits, the presence caps (`maxPresence` /
1643-- `maxPresencePerServer`), the gossip TTL (`onlineGossipTtl`) capping how long one
1644-- forged row survives, `maxBlobLen`, the `appendMessage` dedupe, and
1645-- `messageMaxAge` pruning.
1647-- The fix for both is peer authentication: require a gossip event to carry a
1648-- signature from the pubkey it announces, and/or authenticate the peer relay itself
1649-- so an unknown host cannot write to `*presence` / `*messages` at all. Deferred past
1650-- v0.1 because it needs a key-to-home-server binding the protocol does not yet
1651-- define. PROTOCOL.md §10 enumerates what open federation does and does not protect.
1653-- POST /federation/gossip: ingest peer presence events. The transport-level
1654-- `fromServer` is the home server for every event. Drops every (pubkey,
1655-- fromServer) row touched by this batch, then re-adds fresh-TTL rows for
1656-- pubkeys with an `online` event (so Online wins on collision). For keys
1657-- that transition offline → online, flushes any locally-buffered messages via
1658-- `forwardQueuedToAll`. Events with an unrecognized `eventType` or no
1659-- `pubkey` are skipped (forward-compat) rather than rejecting the batch.
1661-- SECURITY: this is the gossip-redirect ingress described in the section header
1662-- above — a forged `online` row written here is what steals a victim's routing.
1663-- The presence caps applied below are the only thing bounding how much of
1664-- `*presence` an unauthenticated peer can own.
1665handleRecvGossip : [GossipEvent] -> ServerName -> IO {r *messages, rw *forwards, rw *presence, clock} (Result HttpError {})
1666handleRecvGossip = \events fromServer -> do
1668 -- Widen the peer-supplied `ServerName` once (see `type ServerName`);
1669 -- `forwardQueuedToAll` below still takes the refined name.
1670 let from = (fromServer : Text)
1671 if not federationEnabled
1672 then yield (Err {error: {status: 403, message: "federation_disabled"}})
1673 else if isLocalServer from || isBadServerName from || count events > maxGossipEvents
1674 then yield (Err {error: {status: 400, message: "invalid_request"}})
1676 newlyOnline <- atomic (do
1678 let collected = fold (\acc e -> case e.pubkey of
1679 -- `pubkey` is nested inside the `events` list, so the route-boundary
1680 -- refinement never validates it (the same nested-list gap that
1681 -- `/messages` works around by hand). `refine` re-checks the `PubkeyHex`
1682 -- predicate here, dropping a malformed key so a peer can't poison
1683 -- `*presence` with non-hex rows that then spawn bogus-`toKey` forward
1684 -- entries. It also yields the `PubkeyHex` the `PresenceEntry` row below
1685 -- requires — an explicit `isValidExactHex 64` guard would check the same
1686 -- predicate but leave the key typed `Text`.
1687 Just {value: raw} -> case ((refine raw) : Result RefinementError PubkeyHex) of
1689 Ok {value: pk} -> if e.eventType == "online"
1691 touched: union acc.touched [pk],
1692 added: union acc.added [{pubkey: pk, server: from, expiresAt: t + onlineGossipTtl}],
1693 offline: acc.offline
1695 else if e.eventType == "offline"
1696 then {acc.added, touched: union acc.touched [pk], offline: union acc.offline [pk]}
1698 Nothing {} -> acc) {touched: ([] : [PubkeyHex]), added: ([] : [PresenceEntry]), offline: ([] : [PubkeyHex])} events
1699 let kept = filter (\p -> p.server != from || not elem p.pubkey collected.touched) pres
1700 let merged = union kept collected.added
1701 -- Cap the gossip-learned rows: per-peer first, so one peer cannot crowd every
1702 -- other peer's routing information out of the pool, then globally. Local rows
1703 -- are held out of both caps and re-unioned afterwards — folding them into the
1704 -- same LRU would let a gossip flood evict our own online users, because their
1705 -- `sessionExpiry` (60 min) is *sooner* than a gossiped row's `onlineGossipTtl`
1706 -- (90 min) and `capList` drops soonest-to-expire first. See `maxPresence`.
1707 let localRows = filter (\p -> isLocalServer p.server) merged
1708 let remoteRows = filter (\p -> not isLocalServer p.server) merged
1709 *presence = union localRows (capList (capPerServer remoteRows from maxPresencePerServer) maxPresence)
1710 -- S8: Make online+offline for the same key mutually exclusive within one
1711 -- batch. If a batch carries both events for a key, online wins — the presence
1712 -- merge above already added the online row — so that key must NOT also travel
1713 -- the offline path and cancel its own freshly-staged forwards.
1714 let onlineKeys = map (\p -> p.pubkey) collected.added
1715 let offlineOnly = filter (\pk -> not elem pk onlineKeys) collected.offline
1716 -- N14: Cancel pending forwards to `from` for offline keys. Without this,
1717 -- forwards to a peer that just went offline retry for up to 80 minutes,
1718 -- wasting maxForwardsPerServer slots and generating failed HTTP requests.
1719 -- The message stays in *messages, so it's re-forwarded if the key
1720 -- re-appears on another peer.
1721 when (count offlineOnly > 0) (do
1723 *forwards = filter (\f -> not (f.toServer == from && elem f.toKey offlineOnly)) fwds)
1724 yield (filter (\pk -> not any (\p -> p.pubkey == pk && p.server == from && p.expiresAt > t) pres) (map (\p -> p.pubkey) collected.added)))
1725 -- S4: forward queued mail for ALL newly-online keys in one mailbox pass. The
1726 -- old per-key cap (maxNewlyOnlineForwards, N13) bounded amplification but
1727 -- silently deferred delivery past the 10th key, and a re-announce within the
1728 -- TTL never recovered it (the deliveredTo/presence state made the key look
1729 -- already-handled). `forwardQueuedToAll` bounds the cost to O(|messages|)
1730 -- regardless of how many keys came online.
1731 fork (forwardQueuedToAll newlyOnline fromServer)
1732 yield (Ok {value: {}})
1734-- POST /federation/forward: receive a single federated message destined for
1735-- a local key. The presence gate requires the recipient to be **currently
1736-- locally online** (not just visible to gossip somewhere). Without that, an
1737-- A → B forward based on stale gossip about R could land on B with no
1738-- actively-polling client and get stuck. If B refuses, A retries via
1739-- `retryPendingForwards` against the next presence target.
1740-- Re-delivery of an already-stored (toKey, blob) pair is treated as success
1741-- without a second append (`appendMessage` is idempotent), so a sender whose
1742-- success response was lost can retry without duplicating the message.
1744-- SECURITY: this is the unauthenticated-mailbox-injection ingress described in the
1745-- section header above — an unsolicited row lands here. The `no_presence` gate is
1746-- what keeps the surface to keys that are already online, so an attacker must first
1747-- observe or force presence.
1748handleForwardMessage : PubkeyHex -> BlobHex -> IO {rw *messages, r *presence, rw *seqCounter, clock} (Result HttpError {})
1749handleForwardMessage = \toKey encryptedBlob -> do
1751 if not federationEnabled
1752 then yield (Err {error: {status: 403, message: "federation_disabled"}})
1755 if not hasLocalPresence pres toKey t
1756 then yield (Err {error: {status: 404, message: "no_presence"}})
1758 appendMessage toKey encryptedBlob t
1759 yield (Ok {value: {}}))
1761-- ============================================
1763-- ============================================
1764-- Single match from generated request constructor (one per route entry above)
1765-- to the corresponding `handleXxx` function. Adding a new route means adding
1766-- a `route ... = NewReq` line, a `handleNewReq` definition, and a clause here.
1768-- Top-level request dispatcher: maps each generated request constructor to
1769-- its `handleXxx` function. Every route entry above must have a clause here.
1771api = serve Api where
1772 ReqChallenge = \{pubkey, xForwardedFor} -> handleChallenge pubkey (clientIpOf xForwardedFor)
1773 VerifyAuth = \{pubkey, challenge, signature, revokeOthers, xForwardedFor} -> handleVerifyAuth pubkey challenge signature revokeOthers (clientIpOf xForwardedFor)
1774 Poll = \{cursor, authorization, xForwardedFor} -> handlePoll cursor authorization (clientIpOf xForwardedFor)
1775 SendMessages = \{messages, authorization, xForwardedFor} -> handleSendMessages messages authorization (clientIpOf xForwardedFor)
1776 RecvGossip = \{events, fromServer} -> handleRecvGossip events fromServer
1777 ForwardMessage = \{toKey, encryptedBlob} -> handleForwardMessage toKey encryptedBlob
1779-- ============================================
1781-- ============================================
1782-- `backgroundPrune` runs the prune sweep every `backgroundPruneInterval` ms.
1783-- `backgroundRetryForwards` runs the forward-retry sweep on the same cadence
1784-- but as its own sequential loop so two retries can't race.
1786-- Endless tick: prune expired state and gossip offline for locally-expired
1787-- keys. First sweep happens immediately so stale rows persisted by the
1788-- previous process clear before the next interval elapses.
1789backgroundPrune : IO {rw *challenges, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, rw *sessions, network, clock} a
1792 -- Snapshot the peer set *before* the sweep. `pruneExpired` drops every expired
1793 -- presence row, and a peer is only known to us through the rows it announced —
1794 -- so a peer whose keys all expired in this same sweep vanishes from `*presence`
1795 -- at the very moment we need to tell it that our keys went offline. Reading
1796 -- peers only after the prune (as this used to) silently skipped exactly those
1797 -- peers, which then held a stale `online` row for our users until their own
1798 -- `onlineGossipTtl` lapsed — up to 90 minutes of mail routed at a relay the
1799 -- user is no longer on. Union the pre- and post-sweep sets so both the peers
1800 -- that survived and the peers that expired out get the offline event.
1801 prePres <- *presence
1802 let prePeers = collectPeers prePres (\p -> p.server)
1803 expiredLocal <- pruneExpired t
1804 when federationEnabled (fork (do
1806 sendBatchedGossip (union prePeers (collectPeers pres (\p -> p.server))) (map (\pk -> {eventType: "offline", pubkey: Just {value: pk}}) expiredLocal)))
1807 sleep backgroundPruneInterval
1810-- Endless tick: retry pending cross-server forwards. Calls
1811-- `retryPendingForwards` inline (not via `fork`) so a slow run blocks the
1812-- next iteration instead of racing with itself — two concurrent runs would
1813-- see the same `*forwards` snapshot and double-count `recordFailure`,
1814-- inflating the per-peer backoff multiplier.
1815backgroundRetryForwards : IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} a
1816backgroundRetryForwards = do
1817 retryPendingForwards
1818 sleep backgroundPruneInterval
1819 backgroundRetryForwards
1821-- ============================================
1823-- ============================================
1824-- Fork the background prune loop (which runs an immediate sweep on its
1825-- first tick) and start the HTTP listener. The forward-retry loop only
1826-- runs when federation is enabled.
1828 logInfo ("Skrepka relay server starting on " ++ bindHost ++ ":" ++ show listenPort ++ " ...")
1829 logInfo (" federation: " ++ (if federationEnabled then "enabled" else "disabled"))
1830 -- The warning three comments have promised since `serverHost`: a host that
1831 -- fails `isValidServerName` cannot be refined into the `fromServer` a gossip
1832 -- body requires, so `sendBatchedGossip` silently no-ops and this relay never
1833 -- announces presence to anyone. Say so at startup rather than leaving the
1834 -- operator to discover a federation-shaped hole by its absence.
1835 case localServerName of
1836 Nothing {} -> logWarn ("serverHost '" ++ serverHost ++ "' is not a valid ServerName (must be lowercase, no trailing dot, at most " ++ show maxServerNameLen ++ " chars); federation egress disabled")
1838 -- /auth/verify checks the client's host-bound signature against
1839 -- `authHost serverHost`, so a relay still on the compiled-in default 401s every
1840 -- login the moment a client dials it under any other name — which is exactly the
1841 -- install.sh deployment (Caddy fronts a public DOMAIN). `--serverHost=<domain>` is
1842 -- accepted and then IGNORED by the current Knot runtime, so it must be baked in at
1843 -- build time instead. Warn loudly rather than let every login fail silently.
1844 when (serverHost == "localhost") (logWarn "serverHost is the default 'localhost': every client that dials this relay under any other hostname will fail /auth/verify (the auth signature is host-bound, PROTOCOL.md §6), so no session is ever issued. A public relay must set serverHost to its real hostname; note the Knot runtime currently ignores --serverHost at startup, so bake it at build time: knot build server.knot --serverHost=<host>")
1845 when (federationEnabled && count seedPeerList > 0) (logInfo (" seed peers: " ++ show seedPeerList))
1846 fork backgroundPrune
1847 when federationEnabled (fork backgroundRetryForwards)
1848 listenOn bindHost listenPort api
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list