-- Skrepka Relay Server (maximally simplified)
-- Single-server implementation of the Skrepka protocol (v0.1).
-- Every collection is a flat list; rate limiting is delegated to the
-- compiler's per-endpoint `rateLimit` clauses on each route.
-- Token comparison is plain `==` (timing-attack vulnerable), retry backoff is linear,
-- and many helpers are inlined. Performance suffers; clarity is the only goal.

-- ============================================
-- Configuration
-- ============================================
-- Top-level constants: bind address, federation identity, capacity ceilings,
-- per-endpoint rate-limit budgets, and expiry/backoff/TTL durations.
-- Values written here are defaults; every scalar (Int/Float/Text/Bool/Maybe ...)
-- top-level constant can be overridden at startup via `--name=value` on the
-- command line (see Knot's `knot_override_lookup`). Run with `--help` for the
-- full list.

-- This server's canonical federation identity. Used as the `server` field in
-- presence/gossip events and for self-checks (`isLocalServer`). Not a bind
-- address — the listener accepts connections on
-- every interface regardless of this value. May also differ from the URL
-- clients use to reach the server (e.g. behind a reverse proxy or alternate
-- DNS name); peers must resolve this name to reach us for federation.
--
-- Must be unique per deployment. Every operator participating in federation
-- has to recompile with their own public hostname here — peers reject events
-- whose origin fails `isBadServerName` (which blocks the default "localhost"
-- and other private/reserved names), so two default-built servers cannot
-- federate with each other. The default is only suitable for a single-node,
-- non-federated deployment.
--
-- Typed `Text`, not `ServerName`: a refined type cannot be given a bare literal
-- default (the compiler requires an explicit `refine`), and this constant is
-- overridable at startup. `localServerName` below is where the `ServerName`
-- predicate is actually checked — an operator who overrides this with a name
-- that fails `isValidServerName` (too long, not lowercase, or trailing-dotted)
-- gets federation egress disabled and a loud startup warning, rather than an
-- invalid name on the wire.
serverHost : Text
serverHost = "localhost"

-- `serverHost` refined to a `ServerName`, or `Nothing` when it fails
-- `isValidServerName`. This is the only place the predicate is checked for our
-- own hostname; peer-supplied names are validated by the runtime at the
-- `/federation/gossip` route boundary (`fromServer: ServerName`). Federation
-- egress (`sendBatchedGossip`) needs a `ServerName` to put in the gossip body,
-- so a misconfigured host simply stops gossiping — see `main`, which warns at
-- startup.
localServerName : Maybe ServerName
localServerName = case refine serverHost of
  Ok {value: sn} -> Just {value: sn}
  Err _ -> Nothing {}
-- Network interface the HTTP listener binds to. "0.0.0.0" accepts connections
-- on every IPv4 interface (the typical default behind a reverse proxy);
-- "127.0.0.1" restricts the listener to localhost-only; "::" / "::1" do the
-- IPv6 equivalents. Override with `--bindHost=...` at startup. Unrelated to
-- `serverHost` above — this is the kernel-level bind address; that is the
-- federation identity peers see.
bindHost : Text
bindHost = "0.0.0.0"
-- TCP port for incoming HTTP connections.
listenPort : Int
listenPort = 8080
-- URL scheme used when contacting peer federation servers.
federationScheme : Text
federationScheme = "https://"

-- Storage retention for messages and dedup-id records. Mailbox rows live this
-- long after `receivedAt`; expired rows are pruned by `pruneExpired` (30 days).
messageMaxAge : Int<Ms>
messageMaxAge = 2592000000
-- Max length of a hex-encoded message body / opaque blob (40 MiB hex ≈ 20 MiB bytes).
maxBlobLen : Int
maxBlobLen = 41943040
-- Min length of a hex-encoded blob: 346 chars = 173 bytes. A well-formed blob is
-- `version (1) || ephemeral_x25519_pubkey (32) || nonce (24) || ciphertext`, and the
-- ciphertext seals at minimum `sender_pubkey (32) || signature (64) || compressed_len (4)`
-- plus the 16-byte Poly1305 tag — so 1 + 32 + 24 + 32 + 64 + 4 + 16 = 173 bytes is the
-- floor for a blob any client could possibly decrypt (PROTOCOL.md §3). Anything shorter
-- is garbage by construction: it cannot carry a sender identity, and storing it only
-- burns mailbox rows and the recipient's poll bandwidth. Reject at the boundary.
minBlobLen : Int
minBlobLen = 346
-- Cap on items in a batched send request.
maxBatchSize : Int
maxBatchSize = 100
-- Cap on gossip events accepted or emitted in a single federation exchange.
maxGossipEvents : Int
maxGossipEvents = 100
-- N13: Cap on newly-online keys per gossip batch that trigger forward sweeps.
-- Without this, a single gossip request with 100 `online` events triggers 100
-- mailbox scans (O(100 × |messages|)). Capping at 10 limits the amplification
-- while still allowing reasonable multi-key presence announcements. Remaining
-- newly-online keys are still written to `*presence` — only the forward sweep
-- is deferred until the next presence re-announce or a poll triggers
-- `forwardQueuedToServer` naturally.
maxNewlyOnlineForwards : Int
maxNewlyOnlineForwards = 10
-- Cap on events returned by one long-poll response.
maxPollEvents : Int
maxPollEvents = 50
-- Per-peer ceiling on outstanding forward attempts.
maxForwardsPerServer : Int
maxForwardsPerServer = 2000
-- S9: Cap on distinct remote servers a single message is immediately forwarded
-- to at send time. Separate from `maxForwardsPerServer` (which bounds outstanding
-- forwards *per peer*), this bounds the fan-out breadth. A recipient is unlikely
-- to be visible on more than 100 servers; the previous reuse of
-- `maxForwardsPerServer` (2000) for this purpose was an overload that could
-- spawn up to 2000 immediate HTTP forwards per message.
maxRemoteServersPerMessage : Int
maxRemoteServersPerMessage = 100
-- Global ceiling on the `*forwards` outbox. `maxForwardsPerServer` bounds any one
-- peer, but a recipient gossiped as present on many servers fans one blob out to
-- all of them, so the total is bounded only by (peers x per-peer cap). This caps
-- the whole outbox.
--
-- Evicts the *highest*-retry entries first: those are the ones closest to
-- `maxForwardRetries` (about to be abandoned anyway), so pressure is shed onto
-- failing peers rather than healthy ones. Freshly-staged rows carry `retries: 0`
-- and so always survive their own capping.
--
-- Dropping a forward is not message loss: the `*messages` row it points at stays
-- put, so the recipient still gets the blob by polling here, and a later presence
-- announce re-stages the forward via `forwardQueuedToServer`.
maxForwardsTotal : Int
maxForwardsTotal = 50000
-- Max accepted length of a server hostname.
maxServerNameLen : Int
maxServerNameLen = 128
-- Ceiling on outstanding auth challenges held in memory.
maxChallenges : Int
maxChallenges = 10000
-- Ceiling on concurrent active sessions. Enforced by `capList` in
-- `handleVerifyAuth`, which LRU-evicts the soonest-to-expire sessions once the
-- pool is full.
--
-- LIMITATION — global LRU eviction is Sybil-floodable: an attacker with enough
-- IPs can evict live users' sessions. Bounded by `maxSessionsPerKey` and per-IP
-- `authRateLimit`; a per-IP session cap was rejected (collapses without XFF,
-- punishes carrier-NAT). A real fix prices session creation, not IPs. See PROTOCOL.md §10.
maxSessions : Int
maxSessions = 10000
-- Per-pubkey ceiling on outstanding challenges (prevents one key from exhausting the pool).
maxChallengesPerKey : Int
maxChallengesPerKey = 5
-- Per-pubkey ceiling on concurrent sessions.
--
-- LIMITATION — concurrent sessions for the same keypair are not supported: the
-- mailbox is keyed by pubkey, so two devices sharing a key poll one mailbox and
-- each ack destroys messages the other hasn't read. The model is one keypair per
-- device (PROTOCOL.md §2). This cap only bounds pool exhaustion, not key-sharing.
-- A fix needs per-session delivery cursors — out of scope for v0.1.
maxSessionsPerKey : Int
maxSessionsPerKey = 10
-- Ceiling on gossip-learned (remote) presence rows.
--
-- `/federation/gossip` is unauthenticated and pubkeys are free to invent, so
-- without a cap one peer can grow `*presence` without bound. `handleRecvGossip`
-- LRU-evicts (`capList`) down to this ceiling.
--
-- Local rows are exempt: they're bounded by `maxSessions` and a shared ceiling
-- would let gossip floods evict our own online users (local TTL 60 min < gossip
-- TTL 90 min, so `capList` drops local rows first). See PROTOCOL.md §10.
maxPresence : Int
maxPresence = 100000
-- Per-peer-server ceiling on gossip-learned presence rows, so a single peer cannot
-- consume the whole `maxPresence` pool and evict every other peer's routing
-- information. Filling the global pool then requires many distinct hostnames that
-- each pass `isBadServerName`.
maxPresencePerServer : Int
maxPresencePerServer = 5000
-- Per-recipient ceiling on stored mailbox rows. Without a cap a single
-- authenticated sender can queue unbounded data for one recipient
-- (`maxBatchSize` 100 messages/request x `sendRateLimit` 60 requests/min =
-- 6000/min, each blob up to 20 MiB) and only the 30-day `messageMaxAge` TTL
-- ever reclaims it. Past the cap `appendMessage` drops the oldest rows (lowest
-- `receivedAt`) — the same rows the TTL would eventually drop, just sooner.
--
-- The recipient's client bounds what it *processes* per poll (MAX_POLL_TOTAL_BYTES
-- in core/src/app.rs), but nothing bounded what the server *stores* before this.
--
-- Dropping a row orphans any `*forwards` entry for it; `pruneExpired` collects
-- those (it drops forwards whose message no longer exists). Its `deliveredTo`
-- set is lost with it, which is harmless — the blob is gone, so there is
-- nothing left to re-forward.
--
-- LIMITATION — evicting on overflow means a flood can now *destroy* mail, not
-- just pile it up: an attacker who fills a recipient's mailbox pushes that
-- recipient's genuine undelivered messages out of the window. Pubkeys are free
-- to mint, so "authenticated sender" is no barrier. This is a trade, not a fix
-- — the alternative (reject once full) hands the same attacker a permanent
-- block on *all* new mail to that recipient, which is strictly worse: here at
-- least the newest messages always land. It only bites a recipient who is
-- offline long enough to accumulate `maxMessagesPerRecipient`, since polling
-- drains the mailbox (`ackPolledMessages`). A real fix prices sending — see
-- the same argument for sessions on `maxSessions`, and PROTOCOL.md §10.
maxMessagesPerRecipient : Int
maxMessagesPerRecipient = 10000
-- Global ceiling on total stored messages across all recipients (S6). Every
-- other state ref has a global cap (*sessions, *challenges, *presence,
-- *forwards); *messages had only a per-recipient cap, so total storage was
-- bounded only by (distinct recipient keys x maxMessagesPerRecipient), and an
-- attacker minting fresh invalid pubkeys could fill the disk (bounded only by
-- rate limits and the 30-day TTL). On overflow this evicts the globally-oldest
-- rows, symmetric with the other refs. See PROTOCOL.md §10.
maxMessagesTotal : Int
maxMessagesTotal = 1000000
-- Validity window for an auth challenge before it must be re-issued (1 min).
challengeExpiry : Int<Ms>
challengeExpiry = 60000
-- How long a session token remains valid after issue (1 hour).
sessionExpiry : Int<Ms>
sessionExpiry = 3600000
-- How long a received "online" presence gossip is considered fresh (90 min).
-- Receivers anchor the TTL to their own wall clock at receive time, so this
-- value isn't carried on the wire.
onlineGossipTtl : Int<Ms>
onlineGossipTtl = 5400000
-- Times to retry a federation forward before giving up.
maxForwardRetries : Int
maxForwardRetries = 10

-- Base delay for federation retry backoff (linear, not exponential — 30 s).
retryBackoffBase : Int<Ms>
retryBackoffBase = 30000
-- Cap on federation retry backoff (8 min).
retryBackoffMax : Int<Ms>
retryBackoffMax = 480000
-- How long a peer's failure record survives past its most recent failure (24 h).
-- After this, accumulated backoff resets — the next attempt is treated as fresh.
forwardFailureMaxAge : Int<Ms>
forwardFailureMaxAge = 86400000

-- Cadence of the background prune/cleanup task (30 s).
backgroundPruneInterval : Int<Ms>
backgroundPruneInterval = 30000
-- Long-poll hold timeout before returning empty to the client (25 s).
pollTimeoutMs : Int<Ms>
pollTimeoutMs = 25000

-- Rolling window for every per-endpoint rate-limit bucket (1 min). All routes
-- share this window; only the per-window request budget varies per endpoint.
rateLimitWindow : Int<Ms>
rateLimitWindow = 60000
-- Per-client-IP budget for /auth/challenge and /auth/verify per `rateLimitWindow`.
-- A healthy handshake is one challenge + one verify, so the budget leaves ample
-- room for many clients behind one NAT.
authRateLimit : Int
authRateLimit = 60
-- Per-client-IP budget for /poll per `rateLimitWindow`. Clients reconnect after
-- `pollTimeoutMs`, so steady state is ~3/min per client; the budget leaves room
-- for several clients behind one NAT.
pollRateLimit : Int
pollRateLimit = 60
-- Per-client-IP budget for /messages per `rateLimitWindow`. Each call may
-- carry up to `maxBatchSize` ciphertexts, so the effective message ceiling
-- is higher.
sendRateLimit : Int
sendRateLimit = 60
-- Per-peer-IP budget for /federation/gossip per `rateLimitWindow`.
gossipRateLimit : Int
gossipRateLimit = 60
-- Per-peer-IP budget for /federation/forward per `rateLimitWindow`. Higher than
-- gossip because peers fan out one call per buffered ciphertext.
forwardRateLimit : Int
forwardRateLimit = 600
-- Whether rate limiting may trust X-Forwarded-For for the client address.
-- True matches the install.sh deployment (Caddy in front, which appends the
-- real client address as the header's final entry — the only entry a trusted
-- proxy vouches for). Set --trustForwardedFor=False when clients connect
-- directly, otherwise a client could spoof the header to mint fresh
-- rate-limit buckets.
trustForwardedFor : Bool
trustForwardedFor = True {}

-- Master switch for federation; when False the server runs in single-node mode:
-- no gossip is emitted, no forwards are attempted, and both /federation/*
-- endpoints answer 403.
--
-- Defaults to False. Federation is unauthenticated by design (PROTOCOL.md §10) —
-- any host that can reach us may announce presence or inject a blob — so joining
-- the mesh is a deliberate operator decision, not something a default hands you.
-- Opt in with `--federationEnabled=True`.
federationEnabled : Bool
federationEnabled = False {}

-- Federation bootstrap seeds: comma-separated peer hostnames this server gossips
-- to unconditionally, e.g. `--seedPeers=relay1.example.com,relay2.example.com`.
--
-- Without seeds the mesh cannot form. Peers are otherwise *only* ever learned
-- from inbound gossip (a `*presence` row remembers the `server` that announced a
-- key), so two fresh relays that have never heard of each other both start with
-- an empty gossip target set and stay that way forever — neither one speaks
-- first. Seeding one side is enough to bootstrap a pair: our gossip carries
-- `fromServer`, so the seed learns of *us* from the first exchange and gossips
-- back from then on.
--
-- Typed `Text`, not `[Text]`: only scalar top-level constants are startup-
-- overridable (see the header note), so the list travels as one comma-separated
-- scalar and `seedPeerList` splits it.
seedPeers : Text
seedPeers = ""

-- `seedPeers` split on commas, trimmed, with blanks and our own hostname dropped.
-- Deliberately *not* filtered through `isBadServerName` here: every federation
-- egress site applies the deny-list itself, so a denylisted seed is refused at
-- exactly the same choke point as a denylisted gossip-learned peer.
-- Filtering `serverHost` out at parse time lets `gossipTargets` drop its
-- `isLocalServer` guard (the only other source, `collectPeers`, already filters it).
seedPeerList : [Text]
seedPeerList = filter (\s -> s != "" && not isLocalServer s) (splitOnComma seedPeers)

federationUrl : Text -> Text
federationUrl = \server -> federationScheme ++ server

-- ============================================
-- Types
-- ============================================
-- Wire/state shapes plus refinement aliases for hex/server-name validation.
-- Hex types are bounded length + lowercase-hex; server names are lowercased
-- and stripped of trailing dots. The SSRF deny-list (`isBadServerName`) is
-- applied at federation egress, not in the type predicate.

-- One event in a /poll response: the opaque cipher blob addressed to the
-- polling pubkey. The server cannot read the blob.
type PollEvent = {encryptedBlob: BlobHex}

-- One presence change exchanged between federated servers. A flat wire record
-- (`{"eventType": "online"|"offline", "pubkey": "<hex>"}`) rather than an ADT:
-- the built-in record JSON round-trips it directly (a `Just` pubkey encodes as
-- the bare hex string, `Nothing` as `null`/an absent field). `eventType` is
-- free `Text`, so an unrecognized future event kind decodes cleanly instead of
-- failing the whole batch, and `pubkey` is optional so a future pubkey-less
-- kind still parses. `handleRecvGossip` ignores any event whose `eventType` it
-- doesn't recognize or that carries no pubkey — that is the forward-compat
-- fallback (the old `GossipUnknown` variant).
type GossipEvent = {eventType: Text, pubkey: Maybe Text}

-- True when `s` is lowercase hex of exactly `exactLen` characters (even by definition).
isValidExactHex : Int -> Text -> Bool
isValidExactHex = \exactLen s -> length s == exactLen && isValidHex s
-- True when `s` is lowercase hex within [`minBlobLen`, `maxBlobLen`]. The floor
-- rejects blobs too short to be a real envelope; see `minBlobLen`.
isValidBlobHex : Text -> Bool
isValidBlobHex = \s -> length s >= minBlobLen && length s <= maxBlobLen && isValidHex s
-- Hex-encoded Ed25519 public key (32 bytes → 64 chars exact).
type PubkeyHex = Text where isValidExactHex 64
-- Hex-encoded ciphertext or opaque blob; bounded to [`minBlobLen`, `maxBlobLen`]
-- (168 bytes ≈ 20 MiB).
type BlobHex = Text where isValidBlobHex
-- Hex-encoded Ed25519 signature (64 bytes → 128 chars exact).
type SignatureHex = Text where isValidExactHex 128
-- Normalized hostname (lowercased, no trailing dot, length-bounded). The SSRF
-- deny-list (`isBadServerName`) is enforced separately at federation egress
-- (`handleRecvGossip`); keeping it out of the type predicate lets the default
-- `serverHost = "localhost"` flow through presence rows in a non-federated
-- single-node deployment.
--
-- WHY SERVER NAMES STAY `Text` IN STATE (the canonical note; other sites point
-- here). Every server name held in `*presence`, `*forwards`, `*forwardFailures`
-- and `Message.deliveredTo` is plain `Text`, never `ServerName`. They all
-- originate in `serverHost` — a startup-overridable scalar, so a refined type
-- cannot be given a bare literal default and the predicate can only be checked at
-- runtime (`localServerName`). `ServerName` is therefore enforced exactly where it
-- can be: at the `/federation/gossip` route boundary, where the name is
-- peer-supplied (`fromServer: ServerName`). Handlers that receive the refined type
-- widen it once, up front (`let server = (serverName : Text)`), because Knot does
-- not implicitly coerce between a refined type and its base inside a comparison —
-- `f.toServer == server` would otherwise fail to typecheck. Widening is always
-- sound (the predicate only adds constraints); narrowing is what needs `refine`.
isValidServerName : Text -> Bool
isValidServerName = \s -> length s <= maxServerNameLen && s == toLower (stripTrailingDot s)
type ServerName = Text where isValidServerName

-- Wall-clock time in milliseconds since epoch.
type Timestamp = Int<Ms>

-- Outstanding nonce issued by /auth/challenge; consumed by /auth/verify.
type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp, ip: Text}
-- An issued bearer token bound to (pubkey, ip, expiry).
type Session = {token: Text, pubkey: PubkeyHex, expiresAt: Timestamp, ip: Text}
-- Mailbox row: a stored message awaiting recipient pickup or federation forward.
-- Storage TTL is fixed at `messageMaxAge`, so expiry is derived from
-- `receivedAt`. Any send time the sender wants to convey lives inside
-- `encryptedBlob` (the server cannot read it). `deliveredTo` records peers
-- that have already accepted a federated forward of this blob, so a later
-- presence re-announce of `toKey` doesn't trigger a duplicate delivery.
-- (Single-field record rows, not bare names: the Knot runtime cannot persist
-- a nested relation of scalars.)
type Message = {toKey: PubkeyHex, encryptedBlob: BlobHex, receivedAt: Timestamp, deliveredTo: [{server: Text}]}
-- Last-known location of a pubkey, either local (`server == serverHost`) or
-- learned from a peer via gossip. Multiple entries per pubkey are allowed.
type PresenceEntry = {pubkey: PubkeyHex, server: Text, expiresAt: Timestamp}
-- A message queued for cross-server delivery to `toServer`. `retries` is
-- incremented by `retryPendingForwards` until `maxForwardRetries` is hit.
-- Identity is derived from `encryptedBlob` (see `Message`).
type ForwardEntry = {toServer: Text, toKey: PubkeyHex, encryptedBlob: BlobHex, retries: Int}
-- Running failure counter for a peer; keyed by `server`. Drives `shouldRetryServer`.
-- `failedAt` is the start time of the last recorded attempt; `failures: 0` is
-- the post-success tombstone (no backoff, kept so the timestamp can outrank
-- slower concurrent failures).
type ForwardFailure = {server: Text, failedAt: Timestamp, failures: Int}

-- ============================================
-- Persisted State (all flat lists, no sharding)
-- ============================================
-- Mutable refs (`*x`) holding the entire server state in memory. Every list
-- scan is O(n); scaling is the first thing the production version replaces.
-- Grouped here: auth (challenges/sessions), mailbox (messages/forwards),
-- presence, and bookkeeping counters. Per-endpoint rate-limit buckets live
-- in the runtime's hidden `_knot_rate_limits` SQLite table and don't appear
-- here.
-- The Knot runtime persists every `*ref` declared here through restarts (see
-- the project memory note about SQLite-backed refs); nothing in this file is
-- truly volatile despite being typed as plain in-memory lists.

-- Outstanding /auth/challenge nonces awaiting /auth/verify. Capped overall and per-pubkey.
*challenges : [Challenge]
-- Live bearer tokens. Source of truth for `withSessionAuth`; trimmed by `pruneExpired`.
*sessions : [Session]
-- Mailbox: ciphertexts addressed to local recipients, awaiting poll or federation forward.
*messages : [Message]
-- Last-known location of each pubkey (local sessions and gossiped remote presence).
-- Remote (gossiped) rows are capped by `maxPresence` / `maxPresencePerServer` in
-- `handleRecvGossip`; local rows are exempt and bounded by `maxSessions` instead.
*presence : [PresenceEntry]
-- Cross-server outbox: messages queued for delivery to a peer, with retry counts.
*forwards : [ForwardEntry]
-- Per-peer failure counters; drives `shouldRetryServer`.
*forwardFailures : [ForwardFailure]

-- Strictly-monotonic sequence used as `Message.receivedAt`; guarantees
-- poll-cursor ordering. Held as a 0-or-1-row wrapped relation, not a bare
-- `Timestamp` scalar source: the runtime now panics when a scalar source's
-- backing table is empty (it treats a missing row as corruption rather than
-- defaulting to 0), which would 500 the very first /poll or /messages on a
-- fresh database. Read through `currentSeq` (0 default). The `{value: ...}`
-- record wrapper is required because a relation of bare scalars (`[Timestamp]`)
-- also can't be persisted — same reason `Message.deliveredTo` is wrapped.
*seqCounter : [{value: Timestamp}]

-- ============================================
-- Rate limiting
-- ============================================
-- Per-endpoint token-bucket configuration. Every endpoint keys on the client IP
-- (last X-Forwarded-For hop behind a trusted proxy, else the connection
-- address). Nothing the caller can mint for free is a bucket key: the limiter
-- runs before the handler, so it cannot tell a valid session from an invented
-- one, and an attacker varying a self-chosen value would get a fresh bucket per
-- value. That rules out the bearer token (any string) and the submitted pubkey
-- (any keypair) alike. A pubkey key is abusable in both directions: an attacker
-- rotating keypairs draws a fresh budget with every rotation (a Sybil flood could
-- then push sessions through until `maxSessions` starts evicting live ones), and
-- flooding a *victim's* pubkey would exhaust that victim's own login budget.
-- Per-pubkey exhaustion of the challenge/session pools is bounded separately, by
-- `maxChallengesPerKey` and `maxSessionsPerKey` in the handlers. Each route has an
-- independent bucket store, so endpoints using the same key strategy don't share
-- budget across routes. Buckets persist in the runtime's `_knot_rate_limits`
-- SQLite table; rejection responds 429 before the handler runs.

-- Suffix of `s` after its last comma, trimmed. X-Forwarded-For is a
-- comma-separated chain that each proxy appends to; only the final entry —
-- the one written by the nearest trusted proxy — is reliable for bucketing.
lastForwardedHop : Text -> Text
lastForwardedHop = \s -> if contains "," s
then lastForwardedHop (afterComma s)
else trim s

-- The client address for rate-limit bucketing: the last X-Forwarded-For hop
-- when `trustForwardedFor` is set (and the header is present and non-empty),
-- otherwise the TCP connection address.
pickClientIp : Maybe Text -> Text -> Text
pickClientIp = \h connIp -> case h of
  Just {value: ips} -> if trustForwardedFor
  then let hop = lastForwardedHop ips in if hop != "" then hop else connIp
  else connIp
  Nothing {} -> connIp

byClientIp = \_ ctx -> Just {value: pickClientIp (ctx.header "X-Forwarded-For") ctx.clientIp}

authLimit = {key: byClientIp, limit: {requests: authRateLimit, window: rateLimitWindow}}
pollLimit = {key: byClientIp, limit: {requests: pollRateLimit, window: rateLimitWindow}}
sendLimit = {key: byClientIp, limit: {requests: sendRateLimit, window: rateLimitWindow}}
gossipLimit = {key: byClientIp, limit: {requests: gossipRateLimit, window: rateLimitWindow}}
forwardLimit = {key: byClientIp, limit: {requests: forwardRateLimit, window: rateLimitWindow}}

-- ============================================
-- Routes
-- ============================================
-- Public HTTP surface, grouped by audience:
--   AuthApi          -- challenge/verify (client identity)
--   ClientApi        -- /poll, /messages (send)
--   FederationApi    -- inter-server gossip, forward (single + batch)
-- Handlers return `Result HttpError T`: `Ok` produces a 200 with the
-- declared body shape, `Err` produces a non-2xx response whose body is
-- `{"error": "<code>"}`.

route AuthApi where
  POST {pubkey: PubkeyHex} /auth/challenge headers {xForwardedFor: Maybe Text} -> {challenge: Text, expiresAt: Timestamp} rateLimit authLimit = ReqChallenge
  POST {pubkey: PubkeyHex, challenge: Text, signature: SignatureHex, revokeOthers: Bool} /auth/verify headers {xForwardedFor: Maybe Text} -> {token: Text, expiresAt: Timestamp} rateLimit authLimit = VerifyAuth

route ClientApi where
  POST {cursor: Timestamp} /poll headers {authorization: Text, xForwardedFor: Maybe Text} -> {events: [PollEvent], cursor: Timestamp} rateLimit pollLimit = Poll
  POST {messages: [{to: PubkeyHex, encryptedBlob: BlobHex}]} /messages headers {authorization: Text, xForwardedFor: Maybe Text} -> {} rateLimit sendLimit = SendMessages

route FederationApi where
  POST {events: [GossipEvent], fromServer: ServerName} /federation/gossip -> {} rateLimit gossipLimit = RecvGossip
  POST {toKey: PubkeyHex, encryptedBlob: BlobHex} /federation/forward -> {} rateLimit forwardLimit = ForwardMessage

route Api = AuthApi | ClientApi | FederationApi

-- ============================================
-- Generic helpers
-- ============================================
-- List/predicate combinators (filter/all/findFirst/...), token generation,
-- and small text/server-name utilities used throughout the rest of the file.
-- Everything is intentionally O(n) over flat lists; performance is sacrificed
-- for clarity per the file header.

-- Cap to maxN by dropping the soonest-to-expire entries (LRU-style). Always
-- sorts by `expiresAt` so the oldest/most-stale entries are evicted first.
capList : [{expiresAt: Timestamp | r}] -> Int -> [{expiresAt: Timestamp | r}]
capList = \items maxN -> drop (max 0 (count items - maxN)) (sortBy (\x -> x.expiresAt) items)

-- Cap entries matching `pubkey` to maxN-1 (caller adds one more). Splits the
-- list into "different pubkey" (untouched) and "same pubkey" (capped +
-- LRU-evicted) so a single key can't exhaust a global pool — see
-- `maxChallengesPerKey` and `maxSessionsPerKey`.
capPerKey : [{pubkey: PubkeyHex, expiresAt: Timestamp | r}] -> PubkeyHex -> Int -> [{pubkey: PubkeyHex, expiresAt: Timestamp | r}]
capPerKey = \items pubkey maxN -> union (filter (\x -> not (x.pubkey == pubkey)) items) (capList (filter (\x -> x.pubkey == pubkey) items) (maxN - 1))

-- Cap entries matching `server` to maxN, leaving every other server's entries
-- untouched. Same shape as `capPerKey` on a different field, but caps to `maxN`
-- rather than `maxN - 1`: the sole caller (`handleRecvGossip`) applies this
-- *after* merging the peer's new rows in, not before adding one more. Keeps one
-- peer from crowding every other peer out of the `maxPresence` pool.
capPerServer : [{server: Text, expiresAt: Timestamp | r}] -> Text -> Int -> [{server: Text, expiresAt: Timestamp | r}]
capPerServer = \items server maxN -> union (filter (\x -> not (x.server == server)) items) (capList (filter (\x -> x.server == server) items) maxN)

-- Cap the whole forwards outbox to `maxForwardsTotal`, evicting the highest-retry
-- entries first — see `maxForwardsTotal` for why those and not the oldest.
-- Deliberately not `capList`: that keys on `expiresAt`, and `ForwardEntry` carries
-- no timestamp (the same reason `retryPendingForwards` has to sort on the blob).
-- Applied by both writers that grow `*forwards` (`forwardQueuedToServer` and
-- `handleSendMessages`); the retry sweep only ever shrinks it.
--
-- N4: Sort by `(retries, encryptedBlob)` for determinism. Without the secondary
-- key, a `sortBy retries` alone is unstable when many entries share `retries: 0`,
-- and any of them could be dropped — including a fresh forward for a healthy
-- peer. The blob is a unique secondary key (the dedup invariant guarantees
-- `(toKey, encryptedBlob, toServer)` uniqueness), so the sort is total and
-- deterministic.
capForwards : [ForwardEntry] -> [ForwardEntry]
capForwards = \fwds -> take maxForwardsTotal (sortBy (\f -> {retries: f.retries, blob: f.encryptedBlob}) fwds)

-- Random hex token: one random hex char per recursive call. `n` is the
-- desired length in characters (so n=48 yields 24 random bytes of entropy).
-- Session bearers, /auth challenges, and federation auth nonces all use n=48
-- (192 bits of entropy, well beyond birthday bound).
-- Tail-recursive: builds the string left-to-right via an accumulator (`acc`),
-- appending one hex char per call. Each `acc ++ ...` copies the accumulator,
-- so the total work is O(n²) in the length — but n is 48 (192 bits), so this
-- is a fixed ~1 KB of copying and not worth a more complex builder.
genToken : Int -> Text -> IO {random} Text
genToken = \n acc -> if n <= 0
then yield acc
else do
  d <- randomInt 16
  genToken (n - 1) (acc ++ take 1 (drop d "0123456789abcdef"))

-- True when `s` is non-empty, even-length, and only lowercase hex digits.
-- `chars` yields the *distinct* character set (relations dedupe), which is
-- fine for the membership check; the length checks must use `length`.
isValidHex : Text -> Bool
isValidHex = \s ->
  let n = length s in
  n > 0 && n / 2 * 2 == n && all (\c -> contains c "0123456789abcdef") (chars s)

-- Recursively strip every trailing "." from `s` (DNS root form).
stripTrailingDot : Text -> Text
stripTrailingDot = \s -> if hasSuffix "." s
then stripTrailingDot (take (length s - 1) s)
else s

-- True when `s` refers to this server.
isLocalServer : Text -> Bool
isLocalServer = \s -> s == serverHost

-- True when `s` starts with `pre`.
hasPrefix : Text -> Text -> Bool
hasPrefix = \pre s -> take (length pre) s == pre

-- True when `s` ends with `suffix`.
hasSuffix : Text -> Text -> Bool
hasSuffix = \suffix s -> drop (max 0 (length s - length suffix)) s == suffix

-- Occurrences of the single character `c` in `s`. (`chars` can't be used for
-- this — it returns the distinct character *set*.)
countChar : Text -> Text -> Int
countChar = \c s -> if s == ""
then 0
else (if take 1 s == c then 1 else 0) + countChar c (drop 1 s)

-- The host portion of `sn` — everything before the first `:`. With the
-- one-colon ceiling enforced in `isBadServerName`, this strips an optional
-- `:port` so `isNumericHost` sees just the host.
beforeColon : Text -> Text
beforeColon = \s -> if s == "" || take 1 s == ":"
then ""
else take 1 s ++ beforeColon (drop 1 s)

-- `s` up to and including its first `]` (the whole string if there is none).
throughBracket : Text -> Text
throughBracket = \s -> if s == ""
then ""
else if take 1 s == "]"
then "]"
else take 1 s ++ throughBracket (drop 1 s)

-- The bare hostname the auth signature is bound to (PROTOCOL.md §6): `serverHost`
-- with an optional `:port` stripped.
--
-- Deliberately *not* `beforeColon`. A bracketed IPv6 literal is made of colons,
-- so cutting at the first one turns `[::1]:8080` into `[`. The client derives
-- this side of the contract with a real URL parser (`server_host`, core/src/app.rs)
-- and signs over `[::1]`, so truncating here would reject every signature an
-- IPv6-hosted relay is ever sent. For a DNS name or an IPv4 literal the two
-- functions agree character for character.
authHost : Text -> Text
authHost = \s -> if take 1 s == "["
then throughBracket s
else beforeColon s

-- True when the host is a bare integer (no dots) — a decimal or octal "dword" IP
-- like `2130706433` or `017700000001` (both = 127.0.0.1). These carry no dotted
-- octets, so the octet checks below never match them, yet they resolve to the same
-- internal addresses. Takes the already-port-stripped host (`beforeColon sn`).
isNumericHost : Text -> Bool
isNumericHost = \host -> host != "" && all (\c -> contains c "0123456789") (chars host)

-- Decimal value of a single hex/ascii digit character.
digitValue : Text -> Int
digitValue = \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

-- Value of an all-digits string (e.g. "172" -> 172); -1 when empty or
-- non-numeric. `chars` is fine for the membership guard (set semantics don't
-- matter there); the actual parse walks the string in order via take/drop.
--
-- The accumulator saturates at 2^32 so an overlong all-digits octet cannot
-- overflow i64 and panic the handler. `isBadServerName` reaches this via
-- `isReservedIPv4` on a peer-supplied name (`/federation/gossip`'s `fromServer`
-- only passes a length/lowercase check at the route boundary), so a 19+-digit
-- octet like "9999999999999999999.0.0.1" would otherwise abort the request with
-- an unhandled `integer overflow in ... * 10`. A real IPv4 octet is 0-255 and
-- every `isReservedIPv4` comparison is against a constant <= 255, so saturating
-- above that range preserves the result for valid octets while an oversized
-- first octet still reads as `>= 224` (reserved → fail-closed). The `* 10`
-- stays safe because `acc` is capped at 2^32 before each step.
decimalValue : Text -> Int
decimalValue = \s -> if s == "" || not all (\c -> contains c "0123456789") (chars s)
then -1
else decimalValueGo 0 s
decimalValueGo : Int -> Text -> Int
decimalValueGo = \acc s -> if s == ""
then acc
else decimalValueGo (min 4294967296 (acc * 10 + digitValue (take 1 s))) (drop 1 s)

-- Substring of `s` before / after its first ",". Same shape as `beforeDot` /
-- `afterDot`, on a different separator.
beforeComma : Text -> Text
beforeComma = \s -> if s == "" || take 1 s == ","
then ""
else take 1 s ++ beforeComma (drop 1 s)
afterComma : Text -> Text
afterComma = \s -> if s == ""
then ""
else if take 1 s == ","
then drop 1 s
else afterComma (drop 1 s)

-- Split `s` on commas, trimming each field. The stdlib has no `split`, so this
-- is the usual beforeX/afterX recursion. Empty fields survive the split (",,a"
-- yields "" twice — relations dedupe, so once) and are dropped by the caller;
-- see `seedPeerList`.
--
-- The `beforeComma`/`afterComma`/`beforeDot`/`afterDot`/`beforeColon` family
-- looks ripe to fold into one generic `beforeChar sep s` / `afterChar sep s`.
-- Do NOT: routing *this* function's tail recursion through a partially-applied
-- `afterChar ","` hangs the Knot compiler indefinitely (confirmed 2026-07-11 —
-- a 9-line repro of `splitOnComma = ... splitOnComma (afterChar "," s)` never
-- finishes compiling, while the bespoke single-argument `afterComma` compiles
-- in ~1 s). The per-separator helpers stay bespoke on purpose.
splitOnComma : Text -> [Text]
splitOnComma = \s -> if s == ""
then ([] : [Text])
else union [trim (beforeComma s)] (splitOnComma (afterComma s))

-- Substring of `s` before / after its first ".". `afterDot` is empty when
-- there is no dot. Used to pull the first two octets of a dotted IPv4 literal.
beforeDot : Text -> Text
beforeDot = \s -> if s == "" || take 1 s == "."
then ""
else take 1 s ++ beforeDot (drop 1 s)
afterDot : Text -> Text
afterDot = \s -> if s == ""
then ""
else if take 1 s == "."
then drop 1 s
else afterDot (drop 1 s)

-- True when `host` is composed solely of digits and dots, i.e. a bare IPv4
-- literal rather than a hostname. Gates the numeric range checks below so a
-- legitimately-named peer like "224.example.com" is not misread as multicast.
isDottedNumeric : Text -> Bool
isDottedNumeric = \host -> host != "" && contains "." host && all (\c -> contains c "0123456789.") (chars host)

-- Reserved/non-routable IPv4 ranges the dotted-octet prefix list misses:
-- CGNAT 100.64/10, benchmarking 198.18/15, and multicast + reserved/broadcast
-- (224/4 and 240/4, i.e. any first octet >= 224). Applied only to bare IPv4
-- literals (`isDottedNumeric`) so hostnames are never caught. Shorthand forms
-- like "100.64" still match — only the first two octets are inspected.
isReservedIPv4 : Text -> Bool
isReservedIPv4 = \host ->
  let o1 = decimalValue (beforeDot host) in
  let o2 = decimalValue (beforeDot (afterDot host)) in
  isDottedNumeric host && (o1 >= 224 || (o1 == 100 && o2 >= 64 && o2 <= 127) || (o1 == 198 && (o2 == 18 || o2 == 19)))

-- True when a dotted-numeric host carries an octet with a redundant leading
-- zero (e.g. "0177", "0012"). Canonical IPv4 literals never do, but the system
-- resolver behind `fetch` (ureq -> getaddrinfo / inet_aton) reads a leading-zero
-- octet as OCTAL: "0012.0.0.1" dials 10.0.0.1 and "0177.0.0.1" dials 127.0.0.1,
-- while the decimal octet parse in `isReservedIPv4` (and the dotted-prefix list)
-- sees 12.0.0.1 / 177.0.0.1 and waves them through — an SSRF bypass of the same
-- class as the non-dotted "dword"/`0x` forms. Reject the ambiguous octal form
-- outright. Gated by `isDottedNumeric` so a digit-led hostname label like
-- "0foo.example.com" is never caught (it isn't all-digits-and-dots).
hasLeadingZeroOctet : Text -> Bool
hasLeadingZeroOctet = \host ->
  isDottedNumeric host &&
  (let octet = beforeDot host in
   let rest = afterDot host in
   (length octet > 1 && take 1 octet == "0") || (rest != "" && hasLeadingZeroOctet rest))

-- True when the host's first two labels name a reserved IPv4 range: the zero net
-- (0/8), loopback (127/8), and the RFC1918 blocks 10/8, 172.16/12, 192.168/16,
-- plus link-local 169.254/16.
--
-- Deliberately *not* gated on `isDottedNumeric`, unlike `isReservedIPv4` below:
-- these run as leading string labels too, matching the literal `"10."` / `"172.16."`
-- prefix tests this replaces. So "10.example.com" stays blocked. A non-numeric
-- first label parses to -1 via `decimalValue` and matches nothing, so an ordinary
-- hostname is never caught.
isReservedOctetPrefix : Text -> Bool
isReservedOctetPrefix = \host ->
  let o1 = decimalValue (beforeDot host) in
  let o2 = decimalValue (beforeDot (afterDot host)) in
  o1 == 0 || o1 == 10 || o1 == 127 || (o1 == 172 && o2 >= 16 && o2 <= 31) || (o1 == 192 && o2 == 168) || (o1 == 169 && o2 == 254)

-- Block private/reserved/internal hostnames (SSRF defense).
--
-- LIMITATION — purely lexical: inspects the string, never the resolved address.
-- DNS-rebinding TOCTOU and percent-encoding tricks bypass it. A real fix needs
-- resolve-then-pin (fuse resolution with connection), which `fetch` doesn't
-- expose. See PROTOCOL.md §10. Treat as a guard against naive-literal SSRF, not
-- a motivated attacker with a nameserver.
--
-- Enforced on inbound (`handleRecvGossip`) and at every egress site
-- (`sendBatchedGossip`, `retryPendingForwards`, `forkForwardsTo`) as
-- defense-in-depth — persisted state from before a denylist tightening must
-- not steer a `fetch` at an internal host.
--
-- A legitimate `host:port` has exactly one `:`, so the multi-colon check
-- rejects bare IPv6 literals. The name is trailing-dot-stripped before every
-- check so `localhost.` / `foo.internal.` (DNS root form) are caught.
isBadServerName : Text -> Bool
isBadServerName = \raw ->
  let sn = stripTrailingDot raw in
  let host = beforeColon sn in
  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"]

-- ============================================
-- Auth helpers
-- ============================================
-- Bearer token extraction and session lookup. Authenticated handlers funnel
-- through `authedPubkey`; per-endpoint rate limiting is enforced by the
-- compiler-generated `rateLimit` clauses on each route.
-- Federation requests are unauthenticated: anyone can hit /federation/*.
-- The `no_presence` check bounds federated forwards to currently-online keys.

-- Plain ip match (sessions with empty ip skip the check).
--
-- Mobile tradeoff: binding a session to an IP means a client that moves between
-- networks (Wi-Fi <-> cellular, or a carrier NAT re-assignment mid-session) no
-- longer matches its session row, gets a 401, and must re-run the full
-- challenge/verify handshake. That is the correct security posture — it is what
-- stops a stolen Bearer token from being replayed from anywhere — but it is
-- chatty for exactly the clients this protocol targets: phones change networks
-- constantly, so re-auth is a routine event, not an exceptional one. Clients are
-- expected to treat a 401 as "re-authenticate and retry", not as a fatal error.
-- Operators who front the relay with a proxy that does not set a stable
-- X-Forwarded-For (or who run with `--trustForwardedFor=False`) get an empty
-- bound IP, which disables the check entirely — see `clientIpOf`.
matchIp : Text -> Text -> Bool
matchIp = \clientIp sessionIp -> sessionIp == "" || clientIp == sessionIp

-- The client IP a session/challenge is bound to: the last (trusted) hop of the
-- X-Forwarded-For chain, matching the rate limiter's `pickClientIp`. Taking the
-- last hop rather than the whole header means client-supplied spoofed hops don't
-- become part of the binding (a trusted proxy appends the real address last).
-- Empty when the header is absent or `trustForwardedFor` is off — handlers have
-- no access to the raw connection address, and an empty bound IP makes `matchIp`
-- skip the check (so IP binding is simply disabled without a trusted proxy).
clientIpOf : Maybe Text -> Text
clientIpOf = \h -> case h of
  Just {value: ips} -> if trustForwardedFor then lastForwardedHop ips else ""
  Nothing {} -> ""

-- Resolve a Bearer token to its session pubkey if the session is unexpired and
-- the client IP matches. Returns Nothing on missing/invalid token.
--
-- TIMING SIDE-CHANNEL (known gap, not fixable in Knot today). `s.token == token`
-- is ordinary string equality, which almost certainly short-circuits on the first
-- differing byte. An attacker who can time the response therefore learns how many
-- leading characters of a guess were correct, and can in principle extend a guessed
-- prefix one hex char at a time instead of searching the whole space. Two things
-- bound that today, neither of which is a fix:
--   * the token is 48 random hex chars (192 bits, `genToken`), so a blind guess is
--     hopeless and the attacker is forced onto the timing channel to make progress;
--   * `/poll` and `/messages` are per-IP rate limited, and the linear scan over
--     `*sessions` adds noise on the order of the comparison itself, so the number
--     of samples needed to resolve a per-byte difference over a network is large.
-- Neither argument is a security guarantee — they raise the cost of the attack, they
-- do not remove it. The correct fix is a `constantTimeEquals : Text -> Text -> Bool`
-- primitive in the Knot runtime (a byte-wise XOR-and-accumulate compare that always
-- reads both strings in full); swap the `s.token == token` conjunct for it as soon as
-- one exists. See PROTOCOL.md §6, *Error Responses*.
authedPubkey : Text -> Int<Ms> -> Text -> IO {r *sessions} (Maybe PubkeyHex)
authedPubkey = \authorization t clientIp -> do
  ses <- *sessions
  if not hasPrefix "Bearer " authorization
  then yield (Nothing {})
  else do
    let token = drop 7 authorization
    yield (case findFirst ses (\s -> s.expiresAt > t && s.token == token && matchIp clientIp s.ip) of
      Just {value: s} -> Just {value: s.pubkey}
      _ -> Nothing {})

-- ============================================
-- Federation failure tracking (simple, no circuit breaker)
-- ============================================
-- Linear backoff per peer: each consecutive failure multiplies the delay by
-- `retryBackoffBase` (capped at `retryBackoffMax`). `shouldRetryServer` is the
-- single read-side gate; `recordFailure`/`clearFailure` are the write side.
-- There is no half-open state — a single success clears all accumulated failures.
-- Concurrent fetches to the same peer can complete out of order, so both
-- writers take the attempt-start time and ignore updates older than the
-- recorded one (latest-started attempt wins). `clearFailure` therefore writes
-- a zero-count row rather than deleting — the timestamp must survive so a
-- slower failure can be recognized as stale. Zero-count rows impose no
-- backoff and age out of `*forwardFailures` via `pruneExpired`.

-- True when enough time has passed since the last failure for `server` to be
-- worth retrying (or no failure recorded at all). Linear backoff:
-- `retryBackoffBase * failures`, capped at `retryBackoffMax`.
shouldRetryServer : Text -> Timestamp -> [ForwardFailure] -> Bool
shouldRetryServer = \server t failures -> not any (\f -> f.server == server && t - f.failedAt < min retryBackoffMax (retryBackoffBase * (f.failures : Int))) failures

-- Bump the failure counter for `server`. `attemptAt` is when the failed call
-- started; the update is skipped when a more recently started attempt has
-- already written its outcome.
--
-- Timestamp ties: `now` has millisecond resolution and `retryPendingForwards`
-- reuses a single `t` for a whole sweep, so two concurrent attempts on one peer
-- routinely carry the *same* `attemptAt` — and a strict `>` staleness test calls
-- neither one stale, making the outcome a plain last-writer-wins race (a success
-- and a failure at the same millisecond resolve differently depending on which
-- `fetch` returns first). The tiebreaker: at an equal timestamp a success
-- outranks a failure, so a zero-count row (the `clearFailure` tombstone) is
-- treated as stale here, while `clearFailure` overwrites an equal-timestamped
-- failure. Ties now resolve the same way in both orders. The cost is that a
-- genuine failure landing in the same millisecond as a success is not counted —
-- one skipped backoff step inside one millisecond, versus a permanently
-- order-dependent counter.
recordFailure : Text -> Timestamp -> IO {rw *forwardFailures} {}
recordFailure = \server attemptAt -> atomic (do
  failures <- *forwardFailures
  let prev = findFirst failures (\f -> f.server == server)
  let stale = case prev of
    Just {value: f} -> f.failedAt > attemptAt || (f.failedAt == attemptAt && f.failures == 0)
    _ -> False {}
  when (not stale) (do
    let prevCount = case prev of
      Just {value: f} -> f.failures
      _ -> 0
    *forwardFailures = union (filter (\f -> f.server != server) failures) [
      {server, failedAt: attemptAt, failures: prevCount + 1}
    ]))

-- Reset the failure counter for `server` to zero (called after any successful
-- peer call; single-success recovery — there is no half-open state). Keeps a
-- zero-count row so its timestamp can outrank slower concurrent failures.
-- The staleness test stays strict (`>`) on purpose: at an equal timestamp this
-- write wins, which is the other half of the tie rule described on
-- `recordFailure`.
clearFailure : Text -> Timestamp -> IO {rw *forwardFailures} {}
clearFailure = \server attemptAt -> atomic (do
  failures <- *forwardFailures
  let stale = any (\f -> f.server == server && f.failedAt > attemptAt) failures
  when (not stale) (do
    *forwardFailures = union (filter (\f -> f.server != server) failures) [
      {server, failedAt: attemptAt, failures: 0}
    ]))

-- ============================================
-- Common helpers
-- ============================================
-- Helpers shared by send/poll/federation paths: monotonic sequence
-- generation, presence queries, and atomic mailbox/presence writes
-- (callers supply the surrounding `atomic` block).

-- True when `pk` has a live local presence row (i.e. is currently online here).
hasLocalPresence : [PresenceEntry] -> PubkeyHex -> Timestamp -> Bool
hasLocalPresence = \pres pk t -> any (\p -> p.pubkey == pk && isLocalServer p.server && p.expiresAt > t) pres

-- Project items through `getServer`, drop our own hostname, and dedupe.
-- Used to derive peer recipient lists from forwards/presence/etc.
--
-- Returns `[Text]`, the base type of `ServerName` — see `type ServerName` for why
-- server names stay unrefined everywhere in state.
collectPeers : [a] -> (a -> Text) -> [Text]
collectPeers = \items getServer -> filter (\s -> not isLocalServer s) (map getServer items)

-- Current sequence value, or 0 before the first message seeds it. Reads the
-- 0-or-1-row `*seqCounter` relation and folds out the value with a 0 default,
-- rather than unwrapping a (possibly empty) scalar source — which the runtime
-- panics on.
currentSeq : [{value: Timestamp}] -> Timestamp
currentSeq = \rows -> fold (\acc r -> max acc r.value) (0 : Timestamp) rows

-- Append one ciphertext to the local mailbox under a fresh monotonic
-- sequence. Row-level STM retry on `*messages` wakes any parked /poll
-- transaction whose filter matches the new row. Caller wraps in `atomic`.
--
-- Idempotent on (toKey, encryptedBlob): an identical ciphertext already in the
-- mailbox is left alone rather than appended again. Both ingress paths need this
-- — a client retry after a lost response (`handleSendMessages`) and a peer's
-- re-forward after a lost 200 (`handleForwardMessage`) carry the identical blob,
-- and the fresh `seqTs` below would otherwise make `union` keep both rows and
-- double-deliver. Re-reading `*messages` per call also collapses duplicate blobs
-- appearing twice within one batch.
--
-- N3: This O(n) scan is a CPU amplification vector. A batch of 100 identical
-- blobs to the same recipient triggers 100 × O(|messages|) comparisons. With
-- |messages| = 10000, that's 1M comparisons per request, bounded by the 60/min
-- rate limit. A real fix needs an index on (toKey, encryptedBlob) or a
-- hash-based dedup set — both require runtime support not available in Knot
-- today. Documented as an accepted DoS surface.
appendMessage : PubkeyHex -> BlobHex -> Int<Ms> -> IO {rw *messages, rw *seqCounter} {}
appendMessage = \toKey encryptedBlob t -> do
  msgs <- *messages
  when (not any (\m -> m.toKey == toKey && m.encryptedBlob == encryptedBlob) msgs) (do
    seqRows <- *seqCounter
    let seqTs = max t (currentSeq seqRows + 1)
    *seqCounter = [{value: seqTs}]
    -- Enforce `maxMessagesPerRecipient` before the append: evict the oldest rows
    -- for this recipient so the post-append count lands exactly on the ceiling.
    -- `- 1` reserves the slot the new row is about to take.
    --
    -- S4: Instead of building an `evicted` list and checking membership (which
    -- is O(|messages| × |evicted|)), compute the eviction threshold — the
    -- receivedAt of the (maxMessagesPerRecipient - 1)th oldest message for this
    -- recipient — and keep only messages newer than it. This is O(|messages|)
    -- with no inner scan.
    let forRecipient = filter (\m -> m.toKey == toKey) msgs
    let excess = max 0 (count forRecipient - (maxMessagesPerRecipient - 1))
    let sortedRecipient = sortBy (\m -> m.receivedAt) forRecipient
    -- The threshold: the receivedAt of the last row we want to evict.
    -- Rows with receivedAt <= threshold are evicted; rows > threshold survive.
    let evictionThreshold = if excess > 0
      then case take excess sortedRecipient of
        [] -> 0
        xs -> case last xs of
          {receivedAt: r} -> r
      else 0
    let kept = filter (\m -> not (m.toKey == toKey && m.receivedAt <= evictionThreshold && excess > 0)) msgs
    -- Global cap (S6): after the per-recipient eviction, bound the total mailbox
    -- across all recipients by dropping the globally-oldest rows. Only runs on
    -- overflow, so the O(n log n) sort is off the hot path. Dropped rows may
    -- belong to other recipients; their orphaned *forwards are reclaimed by
    -- `pruneExpired`, and their lost `deliveredTo` is harmless (the blob is gone).
    let globallyCapped = if count kept > maxMessagesTotal
      then drop (count kept - maxMessagesTotal) (sortBy (\m -> m.receivedAt) kept)
      else kept
    *messages = union globallyCapped [{toKey, encryptedBlob, receivedAt: seqTs, deliveredTo: []}])

-- Record that `server` has accepted a federated forward of this message, so a
-- later presence re-announce of `toKey` doesn't re-forward the same blob to a peer
-- that already has it. No-op when the peer is already listed. Caller wraps in
-- `atomic`.
markDelivered : PubkeyHex -> BlobHex -> Text -> IO {rw *messages} {}
markDelivered = \toKey blob server -> do
  msgs <- *messages
  *messages = map (\m -> if m.toKey == toKey && m.encryptedBlob == blob && not any (\d -> d.server == server) m.deliveredTo
  then {m.toKey, m.encryptedBlob, m.receivedAt, deliveredTo: union m.deliveredTo [{server}]}
  else m) msgs

-- True when `f` is the queued forward of `blob` to `toKey` at `server`. Used to
-- dedupe entries on the forwards outbox. All three fields matter: the same blob
-- can legitimately be queued to the same peer for two *different* recipients (a
-- sender fanning one ciphertext out to several keys), and matching on
-- (blob, server) alone would let completing one of them drop the others.
forwardMatches : PubkeyHex -> BlobHex -> Text -> ForwardEntry -> Bool
forwardMatches = \toKey blob server f -> f.toKey == toKey && f.encryptedBlob == blob && f.toServer == server

-- Replace any local presence rows for `pubkey` with one fresh row at
-- `expiry`, and return the post-update peer broadcast set. Caller wraps in
-- `atomic`.
refreshLocalPresence : PubkeyHex -> Timestamp -> IO {rw *presence} [Text]
refreshLocalPresence = \pubkey expiry -> do
  pres <- *presence
  *presence = union (filter (\p -> not (p.pubkey == pubkey && isLocalServer p.server)) pres) [
    {pubkey, server: serverHost, expiresAt: expiry}
  ]
  yield (collectPeers pres (\p -> p.server))

-- ============================================
-- Pruning
-- ============================================

-- One sweep over every state ref: drops expired rows in a single atomic block.
-- Returns the locally-expired presence rows whose pubkey has no other live
-- local session, so the caller can broadcast offline gossip for them.
-- Also prunes orphaned *forwards entries whose message has been removed by
-- the TTL sweep — a 404-deferred forward (recipient never online at the peer)
-- would otherwise stay forever with retries=0, retried every sweep indefinitely.
pruneExpired : Int<Ms> -> IO {rw *challenges, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, rw *sessions} [PubkeyHex]
pruneExpired = \t -> atomic do
  ch <- *challenges
  *challenges = filter (\x -> x.expiresAt > t) ch
  ses <- *sessions
  *sessions = filter (\x -> x.expiresAt > t) ses
  msgs <- *messages
  let surviving = filter (\m -> t - m.receivedAt < messageMaxAge) msgs
  *messages = surviving
  -- Prune forwards whose message was removed by the TTL sweep above.
  -- ForwardEntry carries no timestamp, so match against the surviving
  -- messages (the post-sweep list, not the pre-sweep snapshot).
  --
  -- S5: This is O(|forwards| × |surviving|) — a quadratic scan. In practice
  -- |forwards| is usually far below maxForwardsTotal (50000) and |surviving|
  -- is bounded by maxMessagesTotal (1000000), so the cost is modest. A real
  -- fix needs a set/index keyed on (toKey, encryptedBlob), which the Knot
  -- runtime does not expose today. Documented as an accepted design tradeoff.
  fw <- *forwards
  *forwards = filter (\f -> any (\m -> m.toKey == f.toKey && m.encryptedBlob == f.encryptedBlob) surviving) fw
  ff <- *forwardFailures
  *forwardFailures = filter (\f -> t - f.failedAt < forwardFailureMaxAge) ff
  -- presence: remember locally-expired keys for offline gossip
  pres <- *presence
  let live = filter (\p -> p.expiresAt > t) pres
  *presence = live
  let liveLocalPubkeys = map (\p -> p.pubkey) (filter (\p -> isLocalServer p.server) live)
  yield (map (\p -> p.pubkey) (filter (\p -> p.expiresAt <= t && isLocalServer p.server && not elem p.pubkey liveLocalPubkeys) pres))

-- ============================================
-- Federation gossip
-- ============================================
-- Construction and outbound dispatch of presence gossip events. Failures from
-- a peer record into `forwardFailures` (shared with forward retries) so both
-- subsystems back off together.

-- The gossip fan-out set: peers learned from `*presence` plus the configured
-- bootstrap seeds, minus ourselves.
--
-- This union is the whole bootstrap mechanism (see `seedPeers`). Seeds are *not*
-- written into `*presence` to make them stick: a `PresenceEntry` is keyed by the
-- pubkey it announces, and a seed peer is a hostname we know nothing else about —
-- there is no pubkey to key a row on, and inventing one would put a phantom key
-- into the very table `forwardQueuedToServer` trusts to route mail. Folding seeds
-- in at fan-out time instead means they are gossip *targets* without ever being
-- presence *facts*. Once a seed answers, its own gossip creates the real presence
-- rows, and from then on it is reachable through the `peers` half of this union
-- like any other peer.
gossipTargets : [Text] -> [Text]
gossipTargets = \peers -> union peers seedPeerList

-- Fan out one bundle of gossip events to each peer (presence-learned peers and
-- bootstrap seeds alike), skipping denylisted peers and peers in backoff. No-op
-- when `events` is empty so callers don't need to guard. Records or clears
-- federation-failure counters per call.
--
-- Also a no-op when `serverHost` fails the `ServerName` predicate: the gossip
-- body must carry a valid `fromServer`, and a peer would reject (400) a name we
-- could not have refined anyway. `main` warns about this at startup.
sendBatchedGossip : [Text] -> [GossipEvent] -> IO {rw *forwardFailures, network, clock} {}
sendBatchedGossip = \peers events -> case localServerName of
  Nothing {} -> yield {}
  Just {value: me} -> when (count events > 0) (do
    t <- now
    failures <- *forwardFailures
    forEach (gossipTargets peers) (\server -> when (not (isBadServerName server) && shouldRetryServer server t failures) (do
      result <- fetch (federationUrl server) (RecvGossip {events, fromServer: me})
      case result of
        Err _ -> recordFailure server t
        Ok _ -> clearFailure server t)))

-- ============================================
-- Forward retries
-- ============================================
-- `retryPendingForwards` walks queued cross-server forwards in batches per
-- destination, increments retry counts, and gives up after `maxForwardRetries`.
-- `forwardQueuedToServer` is the catch-up path triggered when a remote key
-- comes online: any messages already buffered for that pubkey are enqueued
-- as forwards to the newly-known server.

-- Attempt every forward in `batch` to one peer, in order, and report both whether
-- any attempt was a genuine peer failure (`anyFailed`) and whether any attempt
-- genuinely succeeded (`anySucceeded`). Drops successful entries from `*forwards`
-- and records the peer on the message's `deliveredTo`; every attempt (success,
-- failure, or 404) bumps the retry count and gives up after `maxForwardRetries`.
--
-- INVARIANT — this must not touch `*forwardFailures`. The caller records at most one
-- failure per peer per sweep, from the `anyFailed` flag returned here; recording per
-- failing *message* would let one unreachable peer with N buffered messages take N
-- backoff steps in a single sweep and pin itself at `retryBackoffMax` for
-- `forwardFailureMaxAge`. The counter counts consecutive failed *sweeps*.
--
-- A 404 is NOT a peer failure. `handleForwardMessage` answers 404 `no_presence`
-- whenever the recipient is not *currently* online at that peer, which is an
-- expected, retryable outcome (PROTOCOL.md §7) — the peer is healthy and answering.
-- `fetch` returns `Err` for every status >= 400, so treating any `Err` as a failure
-- would feed a routine 404 into `recordFailure`, and `*forwardFailures` is shared
-- with gossip: one stale-presence 404 would suppress all forwards *and* all gossip to
-- that peer for a full backoff step (30 s–8 min). So a 404 leaves the peer's backoff
-- untouched (`anyFailed` stays false for it) and never clears it (`anySucceeded`
-- stays false too).
--
-- But a 404 DOES bump the forward's retry count now (S1). It previously left the row
-- entirely untouched, so a forward whose recipient never came online at the peer was
-- retried every sweep for the full 30-day message TTL — the counter never advanced,
-- so `maxForwardRetries` was never reached. Counting the attempt (without charging
-- the peer's backoff) lets the forward hit the cap and be dropped after
-- `maxForwardRetries` sweeps while still not penalizing a healthy peer.
--
-- Recursive rather than `forEach` because the result has to be accumulated across
-- iterations; `sortBy` fixes the iteration order that `head`/`drop 1` then walk.
retryForwardsTo : Text -> [ForwardEntry] -> IO {rw *forwards, rw *messages, network} {anyFailed: Bool, anySucceeded: Bool}
retryForwardsTo = \server batch -> case head batch of
  Nothing {} -> yield {anyFailed: False {}, anySucceeded: False {}}
  Just {value: f} -> do
    result <- fetch (federationUrl server) (ForwardMessage {f.toKey, f.encryptedBlob})
    let status = case result of
      Err {error: e} -> e.status
      Ok _ -> 200
    let success = status < 400
    -- Recipient simply isn't online at the peer yet: hold the peer blameless, but
    -- still count the attempt so the row can't outlive the message TTL (S1).
    let deferred = status == 404
    let isMatch = forwardMatches f.toKey f.encryptedBlob server
    let isDone = \x -> isMatch x && (success || x.retries + 1 >= maxForwardRetries)
    atomic (do
      cur <- *forwards
      -- Count the attempt regardless of outcome: a 404 still consumes a retry slot
      -- so a forward that never finds the recipient online is eventually dropped
      -- (S1). On success or after `maxForwardRetries`, `isDone` filters the row out
      -- first, so the increment then no-ops on an absent row.
      *forwards = map (\x -> if isMatch x
      then {x.toServer, x.toKey, x.encryptedBlob, retries: x.retries + 1}
      else x) (filter (\x -> not isDone x) cur)
      when success (markDelivered f.toKey f.encryptedBlob server))
    rest <- retryForwardsTo server (drop 1 batch)
    yield {anyFailed: (not success && not deferred) || rest.anyFailed, anySucceeded: success || rest.anySucceeded}

-- Walk pending forwards grouped by destination and retry each peer's backlog (up
-- to maxBatchSize per peer) via `/federation/forward`. One failure record per peer
-- per sweep: a sweep with any genuine failure takes exactly one backoff step; a
-- sweep with at least one genuine success clears the peer's backoff; an all-404
-- sweep leaves the backoff untouched, neither charging nor clearing it (S1). See
-- `retryForwardsTo`.
retryPendingForwards : IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} {}
retryPendingForwards = do
  t <- now
  fwds <- *forwards
  failures <- *forwardFailures
  forEach (collectPeers fwds (\f -> f.toServer)) (\server -> if isBadServerName server
  -- Denylisted destination (state persisted before a denylist tightening):
  -- its forwards would never be attempted, so drop them instead of letting
  -- them sit in the outbox forever. The denylist check stays outside the
  -- atomic predicate — only the plain equality filter is pushed down.
  then atomic (do
    cur <- *forwards
    *forwards = filter (\x -> x.toServer != server) cur)
  else when (shouldRetryServer server t failures) (do
    -- INVARIANT — `[a]` is an unordered set, so the backlog must be sorted before
    -- `take maxBatchSize` or the batch is an implementation-defined subset that
    -- could keep retrying the same entries while starving others past the cap. A
    -- stable key drains a fixed prefix as entries succeed (removed) or hit
    -- `maxForwardRetries` (dropped). `ForwardEntry` carries no timestamp, so key on
    -- the unique blob.
    let batch = take maxBatchSize (sortBy (\f -> f.encryptedBlob) (filter (\f -> f.toServer == server) fwds))
    result <- retryForwardsTo server batch
    -- Clear the peer's backoff only on a sweep with at least one genuine success
    -- (S1). An all-404 sweep (recipient not online at the peer) is neither a
    -- failure nor a success: clearing backoff on it would reset the peer to
    -- "fresh" every sweep, firing a retry every `backgroundPruneInterval` for the
    -- full 30-day message TTL. `count batch > 0` also guards against reading an
    -- empty sweep (possible with a startup-overridden `maxBatchSize` of 0) as
    -- meaningful.
    if result.anyFailed
    then recordFailure server t
    else when (count batch > 0 && result.anySucceeded) (clearFailure server t)))

-- Forward queued messages to a server when a remote key comes online.
-- Skips messages already delivered to `server` (tracked via Message.deliveredTo)
-- so a presence re-announce after a TTL lapse doesn't duplicate delivery.
--
-- SECURITY: this is the function the gossip-redirect attack in the section header
-- above actually cashes out through — it routes on `*presence`, which any
-- unauthenticated host can write. Do not add a caller that widens what this
-- forwards (e.g. dropping the `deliveredTo` filter) without revisiting that note.
forwardQueuedToServer : PubkeyHex -> ServerName -> IO {rw *forwards, r *messages} {}
forwardQueuedToServer = \pubkey serverName -> atomic (do
  let server = (serverName : Text)
  msgs <- *messages
  fwds <- *forwards
  let existing = countWhere (\f -> f.toServer == server) fwds
  let budget = max 0 (maxForwardsPerServer - existing)
  let notYetForwarded = \m -> not any (forwardMatches m.toKey m.encryptedBlob server) fwds
  let notYetDelivered = \m -> not any (\d -> d.server == server) m.deliveredTo
  let candidates = filter (\m -> m.toKey == pubkey && notYetForwarded m && notYetDelivered m) msgs
  let newFwds = map (\m -> {toServer: server, m.toKey, m.encryptedBlob, retries: 0}) (take budget (sortBy (\m -> m.receivedAt) candidates))
  *forwards = capForwards (union fwds newFwds))

-- Batched version of `forwardQueuedToServer`: stage forwards for *all* newly-online
-- keys in a single mailbox scan (S4). Calling `forwardQueuedToServer` per key scans
-- `*messages` once per key, which is why `handleRecvGossip` previously capped the
-- number of keys at `maxNewlyOnlineForwards` (N13) — but that cap silently deferred
-- delivery past the 10th key, and a re-announce within the TTL never recovered it
-- (the `deliveredTo`/presence state made the key look already-handled). A single
-- pass bounds the cost to O(|messages|) regardless of how many keys came online.
--
-- SECURITY: shares `forwardQueuedToServer`'s exposure — it routes on gossip-written
-- presence. The same `deliveredTo` / `notYetForwarded` / per-peer budget guards
-- apply; do not widen them without revisiting the gossip-redirect note above.
forwardQueuedToAll : [PubkeyHex] -> ServerName -> IO {rw *forwards, r *messages} {}
forwardQueuedToAll = \pubkeys serverName -> atomic (do
  let server = (serverName : Text)
  msgs <- *messages
  fwds <- *forwards
  let existing = countWhere (\f -> f.toServer == server) fwds
  let budget = max 0 (maxForwardsPerServer - existing)
  let notYetForwarded = \m -> not any (forwardMatches m.toKey m.encryptedBlob server) fwds
  let notYetDelivered = \m -> not any (\d -> d.server == server) m.deliveredTo
  -- `elem m.toKey pubkeys` is O(|pubkeys|), but `pubkeys` is bounded by
  -- `maxGossipEvents` (100), so the scan stays O(|messages|) overall.
  let candidates = filter (\m -> elem m.toKey pubkeys && notYetForwarded m && notYetDelivered m) msgs
  let newFwds = map (\m -> {toServer: server, m.toKey, m.encryptedBlob, retries: 0}) (take budget (sortBy (\m -> m.receivedAt) candidates))
  *forwards = capForwards (union fwds newFwds))

-- ============================================
-- Handler: challenge / verify
-- ============================================
-- Identity is a public key; there are no accounts. The flow is:
--   1. Client requests a fresh nonce (`handleChallenge`).
--   2. Client signs the nonce with its private key and submits the signature
--      together with the original challenge (`handleVerifyAuth`).
--   3. Server returns a Bearer token bound to (pubkey, ip, expiry); the new
--      session also installs a local presence row and gossips an `online`
--      event to known peers.
-- Sessions expire on their own (`sessionExpiry`); there is no client-driven
-- revoke/logout.

-- POST /auth/challenge: issue a fresh signed-nonce challenge for `pubkey`.
-- Capped per-key (maxChallengesPerKey); per-client-IP rate limiting is enforced
-- by the route's `rateLimit` clause. The IP is recorded so /auth/verify can
-- require the same client.
--
-- A full pool LRU-evicts rather than rejecting, exactly as `handleVerifyAuth` does
-- for `maxSessions`. Answering 503 once `maxChallenges` is reached would hand any
-- attacker who can fill the pool a total login outage — nobody can start a
-- handshake, including clients whose challenges are already in flight. Evicting the
-- soonest-to-expire challenge instead degrades to "an abandoned challenge may be
-- dropped before its 60 s window elapses", which costs the affected client one
-- retry. The freshly-issued row always survives its own `capList`: it carries the
-- latest `expiresAt` of any live challenge by construction.
handleChallenge : PubkeyHex -> Text -> IO {rw *challenges, clock, random} (Result HttpError {challenge: Text, expiresAt: Timestamp})
handleChallenge = \pubkey clientIp -> do
  t <- now
  challenge <- genToken 48 ""
  let expiresAt = t + challengeExpiry
  atomic (do
    ch <- *challenges
    let cappedActive = capPerKey (filter (\c -> c.expiresAt > t) ch) pubkey maxChallengesPerKey
    *challenges = capList (union cappedActive [{pubkey, challenge, expiresAt, ip: clientIp}]) maxChallenges
    yield (Ok {value: {challenge, expiresAt}}))

-- POST /auth/verify: validate `signature` over `challenge` for `pubkey`.
-- On success, mints a session token, records local presence (`pubkey` is now
-- live on this server), and gossips an `online` event to known peers. If
-- `revokeOthers` is set, all other sessions for the same pubkey are dropped.
handleVerifyAuth : PubkeyHex -> Text -> Text -> Bool -> Text -> IO {rw *challenges, rw *forwardFailures, rw *presence, rw *sessions, network, clock, random, console} (Result HttpError {expiresAt: Timestamp, token: Text})
handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp -> do
  t <- now
  let expiry = t + sessionExpiry
  token <- genToken 48 ""
  -- The client signs (target host, challenge) under a domain-separation tag so a
  -- relay server cannot replay the signature to a different server. We verify
  -- against our own configured hostname (port stripped), which a relay cannot forge.
  --
  -- Signature verification is split out of the session-install transaction (S7).
  -- Phase 1 is a cheap read-only atomic that confirms a matching, unexpired,
  -- IP-bound challenge exists — the original CPU-DoS guard, which still spends no
  -- Ed25519 CPU on /auth/verify calls that have no matching challenge. Phase 2 runs
  -- the expensive `verify` *outside* any atomic, so an STM retry on the phase-3
  -- install transaction (triggered by concurrent writes to *challenges/*sessions)
  -- never re-executes it — previously `verify` sat inside that transaction and every
  -- retry re-ran the Ed25519 check. Phase 3 re-checks the challenge before consuming
  -- it, closing the TOCTOU window opened between phases 1 and 3.
  let signedText = "skrepka-auth-v1:" ++ authHost serverHost ++ ":" ++ challenge
  challengeOk <- atomic (do
    ch <- *challenges
    let same = \c -> c.pubkey == pubkey && c.challenge == challenge
    case findFirst ch same of
      Nothing {} -> yield (False {})
      Just {value: c} -> yield (c.expiresAt > t && matchIp clientIp c.ip))
  if not challengeOk
  then yield (Err {error: {status: 401, message: "invalid"}})
  else do
    -- Phase 2: verify OUTSIDE any atomic. Expensive, and must not be re-executed on
    -- an STM retry of the install transaction below (S7).
    let sigValid = case bytesFromHex pubkey of
      Just {value: pk} -> case bytesFromHex signature of
        Just {value: sigBytes} -> verify pk (textToBytes signedText) sigBytes
        _ -> False {}
      _ -> False {}
    if not sigValid
    then yield (Err {error: {status: 401, message: "invalid"}})
    else do
      -- Phase 3: re-check the challenge (it may have expired or been consumed by a
      -- concurrent verify since phase 1), consume it, and install the session. The
      -- body is cheap, so an STM retry here costs almost nothing.
      result <- atomic (do
        ch <- *challenges
        let same = \c -> c.pubkey == pubkey && c.challenge == challenge
        let matchingChallenge = findFirst ch same
        case matchingChallenge of
          Nothing {} -> yield (Nothing {})
          Just {value: c} -> do
            if not (c.expiresAt > t && matchIp clientIp c.ip)
            then yield (Nothing {})
            else do
              -- Consume the challenge and optionally revoke other sessions + challenges.
              -- When `revokeOthers` is set, drop all other sessions AND outstanding
              -- challenges for this pubkey, so a captured challenge cannot be
              -- redeemed for a new session after revocation (Q35).
              *challenges = if revokeOthers
                then filter (\x -> not (x.pubkey == pubkey)) ch
                else filter (\x -> not same x) ch
              ses <- *sessions
              let pruned = if revokeOthers
                then filter (\s -> s.pubkey != pubkey) ses
                else capPerKey ses pubkey maxSessionsPerKey
              let newSession = {token, pubkey, expiresAt: expiry, ip: clientIp}
              -- LRU-evicts the soonest-to-expire session when the pool is full; this global
              -- eviction is Sybil-floodable, see the LIMITATION note on `maxSessions`.
              let pooled = union pruned [newSession]
              -- Count what `capList` is about to shed, so the handler can warn about it
              -- below. That flood has no other observable signature: evicted users just
              -- start seeing 401s and silently re-authenticate, which looks like normal
              -- traffic in the access log. A sustained nonzero rate here is the alert.
              let evicted = max 0 (count pooled - maxSessions)
              *sessions = capList pooled maxSessions
              peers <- refreshLocalPresence pubkey expiry
              yield (Just {value: {peers, evicted}}))
      case result of
        Nothing {} -> yield (Err {error: {status: 401, message: "invalid"}})
        Just {value: r} -> do
          -- Warn outside the `atomic` block, never inside: an STM transaction can
          -- retry, and a console write is not rolled back with it — logging inside
          -- would emit one line per retry attempt rather than one per eviction.
          -- Include the requesting pubkey and IP for audit (Q38): an operator
          -- investigating a Sybil flood needs to know which identities are responsible.
          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 ++ ")"))
          when federationEnabled (fork (sendBatchedGossip r.peers [{eventType: "online", pubkey: Just {value: pubkey}}]))
          yield (Ok {value: {token, expiresAt: expiry}})

-- ============================================
-- Handler: poll
-- ============================================
-- Long-poll. The client supplies a cursor (last-seen `receivedAt`). We:
--   * Ack-and-drop everything <= the cursor (treating poll progress as ack).
--   * Race a row-level STM wait on `*messages` against `pollTimeoutMs` and
--     return new events plus piggybacked sender-side expirations/deliveries.

-- POST /poll: long-poll body. Treats the cursor advance as an implicit ack
-- (`ackPolledMessages`), refreshes the caller's local presence row so peers
-- don't time us out mid-session, then runs `doPoll` to collect events (or
-- block until a matching message arrives or the timeout elapses) and
-- assembles the response.
handlePoll : Timestamp -> Text -> Text -> IO {r *seqCounter, r *sessions, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, network, clock} (Result HttpError {cursor: Timestamp, events: [PollEvent]})
handlePoll = \cursor authorization clientIp -> do
  t <- now
  setup <- atomic (do
    auth <- authedPubkey authorization t clientIp
    case auth of
      Nothing {} -> yield (Nothing {})
      Just {value: pubkey} -> do
        -- Clamp the client cursor to the highest assigned sequence
        -- (`*seqCounter`), not wall-clock `t`. Under sustained high throughput
        -- `receivedAt` (= `seqTs`) can run ahead of `t`; clamping to `t` would
        -- drag a legitimately-returned cursor backward and re-deliver the
        -- in-between messages. `max t curSeq` keeps the old behaviour when the
        -- counter is idle/behind, while still refusing to ack beyond what's
        -- been issued.
        curSeqRows <- *seqCounter
        let curSeq = currentSeq curSeqRows
        let clampedCursor = max 0 (min (max t curSeq) cursor)
        when (clampedCursor > 0) (ackPolledMessages pubkey clampedCursor)
        pres <- *presence
        -- Refresh local presence when less than half the session TTL remains,
        -- so peers don't time us out mid-session.
        let stale = not any (\p -> p.pubkey == pubkey && isLocalServer p.server && p.expiresAt - t >= sessionExpiry / 2) pres
        refreshPeers <- if stale then refreshLocalPresence pubkey (t + sessionExpiry) else yield []
        -- S3: Track whether we actually refreshed so the gossip line below
        -- only fires on a refresh, not on every poll. Without this, every
        -- poll gossips to all seed peers via gossipTargets [], creating
        -- O(clients × seeds) federation traffic per poll cycle.
        yield (Just {value: {pubkey, clampedCursor, refreshPeers, didRefresh: stale}}))
  case setup of
    Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
    Just {value: s} -> do
      -- S3: Only gossip when we actually refreshed presence — not on every poll.
      when (federationEnabled && s.didRefresh) (fork (sendBatchedGossip s.refreshPeers [{eventType: "online", pubkey: Just {value: s.pubkey}}]))
      pollResult <- doPoll s t
      yield (Ok {value: pollResult})

-- One pass: collect this pubkey's unexpired messages newer than the cursor,
-- sort by receivedAt, take up to `maxPollEvents`. The returned cursor is the
-- max `receivedAt` in the page (or the input cursor when the page is empty),
-- which the client echoes on the next /poll to advance — and which the
-- server treats as an implicit ack.
-- If the page is empty, race a row-level STM wait against `pollTimeoutMs`:
-- the wait transaction reads `*messages` and `retry`s until a row matching
-- this pubkey/cursor is committed; the timer wins on idle. Either way we
-- re-collect at the new wall time, so a timeout returns an empty page.

-- Messages addressed to `pk`, unexpired at `tnow`, and newer than `cursor`. Shared
-- by `doPoll`'s collect and STM-wait arms so the two predicates cannot drift: a
-- wait that accepted a row the collect then filtered out (say, an expired row still
-- above the cursor) would wake the poll, return an empty page with an unchanged
-- cursor, and spin the client through an immediate re-poll into the same wakeup.
freshFor : PubkeyHex -> Timestamp -> Timestamp -> [Message] -> [Message]
freshFor = \pk cursor tnow msgs -> filter (\m -> m.toKey == pk && tnow - m.receivedAt < messageMaxAge && m.receivedAt > cursor) msgs

doPoll : {clampedCursor: Timestamp, pubkey: PubkeyHex | a} -> Timestamp -> IO {r *messages, clock} {cursor: Timestamp, events: [PollEvent]}
doPoll = \s t -> do
  let collectAt = \tnow -> atomic (do
    msgs <- *messages
    let limited = take maxPollEvents (sortBy (\m -> m.receivedAt) (freshFor s.pubkey s.clampedCursor tnow msgs))
    yield {
      events: map (\m -> {m.encryptedBlob}) limited,
      cursor: fold (\acc m -> max acc m.receivedAt) s.clampedCursor limited
    })
  initial <- collectAt t
  if count initial.events > 0
  then yield initial
  else do
    -- `race` requires both arms to share a single effect row, so each arm
    -- carries the union {r *messages, clock} — the STM wait gets a `now`,
    -- the timer gets a no-op `*messages` read.
    race
      (do
        tw <- now
        atomic (do
          msgs <- *messages
          if count (freshFor s.pubkey s.clampedCursor tw msgs) > 0 then yield {} else retry))
      (do
        atomic (do _ <- *messages; yield {})
        sleep pollTimeoutMs)
    t2 <- now
    collectAt t2

-- Treat the supplied cursor as an ack: drop all messages with
-- receivedAt <= cursor, plus their pending forwards.
--
-- The ack is destructive and keyed on `pubkey` alone — no session identity enters
-- into it, so two sessions sharing one keypair race over one mailbox. Accepted
-- limitation; see `maxSessionsPerKey`.
-- Self-atomic: touches two refs (*messages and *forwards), so wraps its own
-- transaction rather than relying on the caller's.
ackPolledMessages : PubkeyHex -> Timestamp -> IO {rw *forwards, rw *messages} {}
ackPolledMessages = \pubkey cursor -> atomic (do
  msgs <- *messages
  let matches = \m -> m.toKey == pubkey && m.receivedAt <= cursor
  let toAck = filter matches msgs
  let blobs = map (\m -> m.encryptedBlob) toAck
  *messages = filter (\m -> not matches m) msgs
  fwds <- *forwards
  *forwards = filter (\f -> not (f.toKey == pubkey && elem f.encryptedBlob blobs)) fwds)

-- ============================================
-- Handler: send
-- ============================================
-- Accept a batch of messages for recipient pubkeys. Placement (live local
-- session, federated forward, or held-for-presence) is internal; the call
-- either succeeds (every message enqueued) or fails with a non-2xx HTTP
-- status carrying the rejection code ("self_send" | ...).
-- Duplicates are silently treated as success so retries are idempotent.
-- Per-client-IP send rate is enforced by the route's `rateLimit` clause.
-- Federated forwards are kicked off in background forks after the atomic.
-- The sender's UI treats every success the same and learns "they got it" only via
-- the recipient's E2E ack.

-- Batch validation: checks batch size, per-message field validity, and self-send.
-- Refined-type validation at the route boundary only fires for top-level scalar
-- body fields; `to`/`encryptedBlob` are nested inside the `messages` list, so the
-- runtime does not check them. `isValidBlobHex` is the same predicate `BlobHex`
-- refines on, so this check and the route boundary cannot drift apart.
validateBatch : [{to: PubkeyHex, encryptedBlob: BlobHex | a}] -> PubkeyHex -> Maybe HttpError
validateBatch = \messages senderKey ->
  if count messages > maxBatchSize
  then Just {value: {status: 413, message: "batch_too_large"}}
  else if any (\m -> not (isValidExactHex 64 m.to && isValidBlobHex m.encryptedBlob)) messages
  then Just {value: {status: 400, message: "invalid_message"}}
  else if any (\m -> m.to == senderKey) messages
  then Just {value: {status: 400, message: "self_send"}}
  else Nothing {}

-- POST /messages: send a list of ciphertexts atomically. Self-send is
-- rejected up-front; the remaining batch is committed inside one atomic
-- block (all-or-nothing) which reads presence to pre-stage federation
-- forwards. Federation forwards are kicked per message after commit.
handleSendMessages : [{encryptedBlob: BlobHex, to: PubkeyHex | a}] -> Text -> Text -> IO {r *presence, r *sessions, rw *forwardFailures, rw *forwards, rw *messages, rw *seqCounter, network, clock} (Result HttpError {})
handleSendMessages = \messages authorization clientIp -> do
  t <- now
  auth <- authedPubkey authorization t clientIp
  case auth of
    Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
    Just {value: senderKey} -> case validateBatch messages senderKey of
      Just {value: err} -> yield (Err {error: err})
      Nothing {} -> do
        committed <- atomic (do
          pres <- *presence
          -- S2: cap the immediate fan-out at `maxForwardsPerServer` servers per
          -- recipient. The post-commit `forkForwardsTo` fires against this list
          -- directly (bypassing the `*forwards` queue and its per-peer cap), so
          -- without a bound here a recipient gossiped as present on thousands of
          -- servers would spawn one immediate HTTP forward per server per message.
          let staged = map (\m -> {
            m.to,
            m.encryptedBlob,
            remoteServers: take maxRemoteServersPerMessage (collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server))
          }) messages
          forEach staged (\c -> do
            -- Read `*messages` *before* the append: `delivered` below must see the
            -- pre-existing row, and re-reading each iteration is also what lets
            -- `appendMessage`'s own dedupe collapse a blob repeated within one batch.
            existingMsgs <- *messages
            appendMessage c.to c.encryptedBlob t
            -- Peers that already hold this blob — from an earlier send of the
            -- identical ciphertext that was forwarded then pruned from
            -- `*forwards`. A brand-new message has empty `deliveredTo`, so this
            -- is `[]` on the normal path; on a client resend it carries the real
            -- set. Mirrors `forwardQueuedToServer`'s guard so we don't re-stage a
            -- forward to a peer that already accepted this blob.
            let delivered = case findFirst existingMsgs (\m -> m.toKey == c.to && m.encryptedBlob == c.encryptedBlob) of
              Just {value: m} -> map (\d -> d.server) m.deliveredTo
              Nothing {} -> ([] : [Text])
            -- Stage outbox rows for peers under their `maxForwardsPerServer`
            -- ceiling. Peers at the cap still get the immediate post-commit
            -- delivery attempt (`forkForwardsTo`) — only the retry-queue row
            -- is skipped.
            when federationEnabled (do
              fwds <- *forwards
              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)
              *forwards = capForwards (union fwds newFwds)))
          yield staged)
        when federationEnabled (forEach committed (\c -> fork (forkForwardsTo c.to c.encryptedBlob c.remoteServers)))
        yield (Ok {value: {}})

-- Fire one /federation/forward call per pre-staged server. On success the
-- corresponding row in `forwards` is pruned and the peer is appended to the
-- message's `deliveredTo` set. The backing `*messages` row itself stays —
-- cleaned up by `ackPolledMessages` when the recipient polls here, or by
-- `pruneExpired` once `messageMaxAge` lapses. Keeping the row lets
-- `forwardQueuedToServer` re-forward to peers learned after send time (so a
-- multi-homed recipient who appears on a new peer post-send still receives
-- the message), and `deliveredTo` prevents re-forwards to peers that already
-- have the message. On failure the forwards row stays so
-- `retryPendingForwards` can re-attempt with backoff.
--
-- A 404 is not a peer failure — see `retryForwardsTo` for why `no_presence` must
-- not reach `recordFailure`. Here the row is left queued for the retry sweep and
-- the peer's backoff (shared with gossip) is not touched.
forkForwardsTo : PubkeyHex -> BlobHex -> [Text] -> IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} {}
forkForwardsTo = \to encryptedBlob servers -> forEach servers (\server -> when (not isBadServerName server) (do
  t <- now
  result <- fetch (federationUrl server) (ForwardMessage {toKey: to, encryptedBlob})
  let same = forwardMatches to encryptedBlob server
  case result of
    Err {error: e} -> when (e.status != 404) (recordFailure server t)
    Ok _ -> do
      clearFailure server t
      atomic (do
        fwds <- *forwards
        *forwards = filter (\x -> not same x) fwds
        markDelivered to encryptedBlob server)))

-- ============================================
-- Handler: federation receive
-- ============================================
-- Inbound peer-to-peer endpoints. Federation is open and unauthenticated:
-- the `no_presence` check in `handleForwardMessage` bounds forwards to
-- currently-online local keys. Both handlers refuse with 403 when
-- `federationEnabled` is off, matching the outbound paths — a single-node
-- deployment accepts no peer writes to `*presence`/`*messages`.
--
-- SECURITY — THE OPEN-FEDERATION THREAT MODEL (accepted v0.1 limitations; the
-- canonical statement, referenced by the handlers below and by
-- `forwardQueuedToServer`). Neither endpoint authenticates its caller and nothing
-- ties an event to the key it speaks for, so any host that can reach us may:
--
--   * announce an arbitrary victim pubkey as `online` at itself. We write that
--     presence row, and the next `forwardQueuedToServer` hands the victim's queued
--     ciphertext to the attacker's host — a *gossip redirect*.
--   * append an arbitrary blob to any currently-online local key's mailbox, which
--     the recipient then polls down — *unauthenticated mailbox injection*.
--
-- Neither breaks confidentiality or allows forgery. Payloads are sealed to the
-- recipient's key and the sender's identity and signature live *inside* the AEAD
-- (PROTOCOL.md §5), so a redirected blob cannot be read and an injected blob that
-- does not open — or opens without a valid inner signature — is dropped by the
-- client and can never impersonate a contact. What the attacker gets is metadata a
-- relay is otherwise never supposed to concentrate (which keys receive traffic, how
-- much, when), unsolicited storage and bandwidth, and — because our copy is pruned
-- once marked `deliveredTo` — the ability to *withhold* delivery by steering a
-- ciphertext at a host that will never serve it. Confidentiality-preserving;
-- availability- and metadata-affecting.
--
-- Bounded, not prevented, by: the SSRF deny-list (`isBadServerName`), the
-- `no_presence` gate, per-IP rate limits, the presence caps (`maxPresence` /
-- `maxPresencePerServer`), the gossip TTL (`onlineGossipTtl`) capping how long one
-- forged row survives, `maxBlobLen`, the `appendMessage` dedupe, and
-- `messageMaxAge` pruning.
--
-- The fix for both is peer authentication: require a gossip event to carry a
-- signature from the pubkey it announces, and/or authenticate the peer relay itself
-- so an unknown host cannot write to `*presence` / `*messages` at all. Deferred past
-- v0.1 because it needs a key-to-home-server binding the protocol does not yet
-- define. PROTOCOL.md §10 enumerates what open federation does and does not protect.

-- POST /federation/gossip: ingest peer presence events. The transport-level
-- `fromServer` is the home server for every event. Drops every (pubkey,
-- fromServer) row touched by this batch, then re-adds fresh-TTL rows for
-- pubkeys with an `online` event (so Online wins on collision). For keys
-- that transition offline → online, flushes any locally-buffered messages via
-- `forwardQueuedToAll`. Events with an unrecognized `eventType` or no
-- `pubkey` are skipped (forward-compat) rather than rejecting the batch.
--
-- SECURITY: this is the gossip-redirect ingress described in the section header
-- above — a forged `online` row written here is what steals a victim's routing.
-- The presence caps applied below are the only thing bounding how much of
-- `*presence` an unauthenticated peer can own.
handleRecvGossip : [GossipEvent] -> ServerName -> IO {r *messages, rw *forwards, rw *presence, clock} (Result HttpError {})
handleRecvGossip = \events fromServer -> do
  t <- now
  -- Widen the peer-supplied `ServerName` once (see `type ServerName`);
  -- `forwardQueuedToAll` below still takes the refined name.
  let from = (fromServer : Text)
  if not federationEnabled
  then yield (Err {error: {status: 403, message: "federation_disabled"}})
  else if isLocalServer from || isBadServerName from || count events > maxGossipEvents
  then yield (Err {error: {status: 400, message: "invalid_request"}})
  else do
    newlyOnline <- atomic (do
      pres <- *presence
      let collected = fold (\acc e -> case e.pubkey of
        -- `pubkey` is nested inside the `events` list, so the route-boundary
        -- refinement never validates it (the same nested-list gap that
        -- `/messages` works around by hand). `refine` re-checks the `PubkeyHex`
        -- predicate here, dropping a malformed key so a peer can't poison
        -- `*presence` with non-hex rows that then spawn bogus-`toKey` forward
        -- entries. It also yields the `PubkeyHex` the `PresenceEntry` row below
        -- requires — an explicit `isValidExactHex 64` guard would check the same
        -- predicate but leave the key typed `Text`.
        Just {value: raw} -> case ((refine raw) : Result RefinementError PubkeyHex) of
          Err _ -> acc
          Ok {value: pk} -> if e.eventType == "online"
          then {
            touched: union acc.touched [pk],
            added: union acc.added [{pubkey: pk, server: from, expiresAt: t + onlineGossipTtl}],
            offline: acc.offline
          }
          else if e.eventType == "offline"
          then {acc.added, touched: union acc.touched [pk], offline: union acc.offline [pk]}
          else acc
        Nothing {} -> acc) {touched: ([] : [PubkeyHex]), added: ([] : [PresenceEntry]), offline: ([] : [PubkeyHex])} events
      let kept = filter (\p -> p.server != from || not elem p.pubkey collected.touched) pres
      let merged = union kept collected.added
      -- Cap the gossip-learned rows: per-peer first, so one peer cannot crowd every
      -- other peer's routing information out of the pool, then globally. Local rows
      -- are held out of both caps and re-unioned afterwards — folding them into the
      -- same LRU would let a gossip flood evict our own online users, because their
      -- `sessionExpiry` (60 min) is *sooner* than a gossiped row's `onlineGossipTtl`
      -- (90 min) and `capList` drops soonest-to-expire first. See `maxPresence`.
      let localRows = filter (\p -> isLocalServer p.server) merged
      let remoteRows = filter (\p -> not isLocalServer p.server) merged
      *presence = union localRows (capList (capPerServer remoteRows from maxPresencePerServer) maxPresence)
      -- S8: Make online+offline for the same key mutually exclusive within one
      -- batch. If a batch carries both events for a key, online wins — the presence
      -- merge above already added the online row — so that key must NOT also travel
      -- the offline path and cancel its own freshly-staged forwards.
      let onlineKeys = map (\p -> p.pubkey) collected.added
      let offlineOnly = filter (\pk -> not elem pk onlineKeys) collected.offline
      -- N14: Cancel pending forwards to `from` for offline keys. Without this,
      -- forwards to a peer that just went offline retry for up to 80 minutes,
      -- wasting maxForwardsPerServer slots and generating failed HTTP requests.
      -- The message stays in *messages, so it's re-forwarded if the key
      -- re-appears on another peer.
      when (count offlineOnly > 0) (do
        fwds <- *forwards
        *forwards = filter (\f -> not (f.toServer == from && elem f.toKey offlineOnly)) fwds)
      yield (filter (\pk -> not any (\p -> p.pubkey == pk && p.server == from && p.expiresAt > t) pres) (map (\p -> p.pubkey) collected.added)))
    -- S4: forward queued mail for ALL newly-online keys in one mailbox pass. The
    -- old per-key cap (maxNewlyOnlineForwards, N13) bounded amplification but
    -- silently deferred delivery past the 10th key, and a re-announce within the
    -- TTL never recovered it (the deliveredTo/presence state made the key look
    -- already-handled). `forwardQueuedToAll` bounds the cost to O(|messages|)
    -- regardless of how many keys came online.
    fork (forwardQueuedToAll newlyOnline fromServer)
    yield (Ok {value: {}})

-- POST /federation/forward: receive a single federated message destined for
-- a local key. The presence gate requires the recipient to be **currently
-- locally online** (not just visible to gossip somewhere). Without that, an
-- A → B forward based on stale gossip about R could land on B with no
-- actively-polling client and get stuck. If B refuses, A retries via
-- `retryPendingForwards` against the next presence target.
-- Re-delivery of an already-stored (toKey, blob) pair is treated as success
-- without a second append (`appendMessage` is idempotent), so a sender whose
-- success response was lost can retry without duplicating the message.
--
-- SECURITY: this is the unauthenticated-mailbox-injection ingress described in the
-- section header above — an unsolicited row lands here. The `no_presence` gate is
-- what keeps the surface to keys that are already online, so an attacker must first
-- observe or force presence.
handleForwardMessage : PubkeyHex -> BlobHex -> IO {rw *messages, r *presence, rw *seqCounter, clock} (Result HttpError {})
handleForwardMessage = \toKey encryptedBlob -> do
  t <- now
  if not federationEnabled
  then yield (Err {error: {status: 403, message: "federation_disabled"}})
  else atomic (do
    pres <- *presence
    if not hasLocalPresence pres toKey t
    then yield (Err {error: {status: 404, message: "no_presence"}})
    else do
      appendMessage toKey encryptedBlob t
      yield (Ok {value: {}}))

-- ============================================
-- Dispatch
-- ============================================
-- Single match from generated request constructor (one per route entry above)
-- to the corresponding `handleXxx` function. Adding a new route means adding
-- a `route ... = NewReq` line, a `handleNewReq` definition, and a clause here.

-- Top-level request dispatcher: maps each generated request constructor to
-- its `handleXxx` function. Every route entry above must have a clause here.
api : Server Api _
api = serve Api where
  ReqChallenge = \{pubkey, xForwardedFor} -> handleChallenge pubkey (clientIpOf xForwardedFor)
  VerifyAuth = \{pubkey, challenge, signature, revokeOthers, xForwardedFor} -> handleVerifyAuth pubkey challenge signature revokeOthers (clientIpOf xForwardedFor)
  Poll = \{cursor, authorization, xForwardedFor} -> handlePoll cursor authorization (clientIpOf xForwardedFor)
  SendMessages = \{messages, authorization, xForwardedFor} -> handleSendMessages messages authorization (clientIpOf xForwardedFor)
  RecvGossip = \{events, fromServer} -> handleRecvGossip events fromServer
  ForwardMessage = \{toKey, encryptedBlob} -> handleForwardMessage toKey encryptedBlob

-- ============================================
-- Background loops
-- ============================================
-- `backgroundPrune` runs the prune sweep every `backgroundPruneInterval` ms.
-- `backgroundRetryForwards` runs the forward-retry sweep on the same cadence
-- but as its own sequential loop so two retries can't race.

-- Endless tick: prune expired state and gossip offline for locally-expired
-- keys. First sweep happens immediately so stale rows persisted by the
-- previous process clear before the next interval elapses.
backgroundPrune : IO {rw *challenges, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, rw *sessions, network, clock} a
backgroundPrune = do
  t <- now
  -- Snapshot the peer set *before* the sweep. `pruneExpired` drops every expired
  -- presence row, and a peer is only known to us through the rows it announced —
  -- so a peer whose keys all expired in this same sweep vanishes from `*presence`
  -- at the very moment we need to tell it that our keys went offline. Reading
  -- peers only after the prune (as this used to) silently skipped exactly those
  -- peers, which then held a stale `online` row for our users until their own
  -- `onlineGossipTtl` lapsed — up to 90 minutes of mail routed at a relay the
  -- user is no longer on. Union the pre- and post-sweep sets so both the peers
  -- that survived and the peers that expired out get the offline event.
  prePres <- *presence
  let prePeers = collectPeers prePres (\p -> p.server)
  expiredLocal <- pruneExpired t
  when federationEnabled (fork (do
    pres <- *presence
    sendBatchedGossip (union prePeers (collectPeers pres (\p -> p.server))) (map (\pk -> {eventType: "offline", pubkey: Just {value: pk}}) expiredLocal)))
  sleep backgroundPruneInterval
  backgroundPrune

-- Endless tick: retry pending cross-server forwards. Calls
-- `retryPendingForwards` inline (not via `fork`) so a slow run blocks the
-- next iteration instead of racing with itself — two concurrent runs would
-- see the same `*forwards` snapshot and double-count `recordFailure`,
-- inflating the per-peer backoff multiplier.
backgroundRetryForwards : IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} a
backgroundRetryForwards = do
  retryPendingForwards
  sleep backgroundPruneInterval
  backgroundRetryForwards

-- ============================================
-- Entry Point
-- ============================================
-- Fork the background prune loop (which runs an immediate sweep on its
-- first tick) and start the HTTP listener. The forward-retry loop only
-- runs when federation is enabled.
main = do
  logInfo ("Skrepka relay server starting on " ++ bindHost ++ ":" ++ show listenPort ++ " ...")
  logInfo ("  federation: " ++ (if federationEnabled then "enabled" else "disabled"))
  -- The warning three comments have promised since `serverHost`: a host that
  -- fails `isValidServerName` cannot be refined into the `fromServer` a gossip
  -- body requires, so `sendBatchedGossip` silently no-ops and this relay never
  -- announces presence to anyone. Say so at startup rather than leaving the
  -- operator to discover a federation-shaped hole by its absence.
  case localServerName of
    Nothing {} -> logWarn ("serverHost '" ++ serverHost ++ "' is not a valid ServerName (must be lowercase, no trailing dot, at most " ++ show maxServerNameLen ++ " chars); federation egress disabled")
    _ -> yield {}
  -- /auth/verify checks the client's host-bound signature against
  -- `authHost serverHost`, so a relay still on the compiled-in default 401s every
  -- login the moment a client dials it under any other name — which is exactly the
  -- install.sh deployment (Caddy fronts a public DOMAIN). `--serverHost=<domain>` is
  -- accepted and then IGNORED by the current Knot runtime, so it must be baked in at
  -- build time instead. Warn loudly rather than let every login fail silently.
  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>")
  when (federationEnabled && count seedPeerList > 0) (logInfo ("  seed peers: " ++ show seedPeerList))
  fork backgroundPrune
  when federationEnabled (fork backgroundRetryForwards)
  listenOn bindHost listenPort api