@@ -103,21 +103,10 @@ maxChallenges = 10000
103103-- `handleVerifyAuth`, which LRU-evicts the soonest-to-expire sessions once the
104104-- pool is full.
105105--
106−-- LIMITATION — that global LRU eviction is Sybil-floodable. `capList` does not
107−-- care whose sessions it drops: an attacker minting fresh keypairs (free) from
108−-- enough IPs to stay under `authRateLimit` can push `maxSessions` worth of
109−-- throwaway sessions through and evict *live* users' sessions, which shows up
110−-- client-side as a 401 and a forced re-handshake.
111−--
112−-- `maxSessionsPerKey` bounds any single key's share, and the per-IP
113−-- `authRateLimit` bounds the rate from any single source, so the flood needs real
114−-- distributed resources. Deliberately not fixed with a per-IP session cap:
115−-- `clientIp` is empty for every session whenever there is no trusted proxy
116−-- (`clientIpOf`), so such a cap would collapse to a single global bucket in
117−-- exactly the deployments that have no XFF — and even with a proxy it would
118−-- punish carrier-NAT users, where thousands of legitimate clients genuinely do
119−-- share one address. A real fix prices session creation (proof of work, or a
120−-- per-key deposit) rather than counting IPs.
106+-- LIMITATION — global LRU eviction is Sybil-floodable: an attacker with enough
107+-- IPs can evict live users' sessions. Bounded by `maxSessionsPerKey` and per-IP
108+-- `authRateLimit`; a per-IP session cap was rejected (collapses without XFF,
109+-- punishes carrier-NAT). A real fix prices session creation, not IPs. See PROTOCOL.md §10.
121110maxSessions : Int
122111maxSessions = 10000
123112-- Per-pubkey ceiling on outstanding challenges (prevents one key from exhausting the pool).
@@ -125,35 +114,22 @@ maxChallengesPerKey : Int
125114maxChallengesPerKey = 5
126115-- Per-pubkey ceiling on concurrent sessions.
127116--
128−-- LIMITATION — concurrent sessions for the *same* keypair are not supported, and
129−-- this cap does not make them safe; it only bounds how many can exist. The mailbox
130−-- is keyed by pubkey, not by session, and /poll treats a cursor advance as an ack
131−-- that *deletes* rows (`ackPolledMessages`), so two devices sharing one keypair
132−-- poll the same mailbox and each one's ack destroys messages the other has not
133−-- read yet — whichever polls first wins, and the loser silently never sees them.
134−-- The expected model is one keypair per device (PROTOCOL.md §2: "Each device
135−-- generates its own independent keypair and is treated as a separate identity").
136−-- The cap exists so a key cannot exhaust the global `maxSessions` pool, not to
137−-- make key-sharing work. Fixing key-sharing needs per-session delivery cursors
138−-- instead of destructive acks — out of scope for v0.1.
117+-- LIMITATION — concurrent sessions for the same keypair are not supported: the
118+-- mailbox is keyed by pubkey, so two devices sharing a key poll one mailbox and
119+-- each ack destroys messages the other hasn't read. The model is one keypair per
120+-- device (PROTOCOL.md §2). This cap only bounds pool exhaustion, not key-sharing.
121+-- A fix needs per-session delivery cursors — out of scope for v0.1.
139122maxSessionsPerKey : Int
140123maxSessionsPerKey = 10
141124-- Ceiling on gossip-learned (remote) presence rows.
142125--
143126-- `/federation/gossip` is unauthenticated and pubkeys are free to invent, so
144−-- without a cap one peer can grow `*presence` without bound — and every hot path
145−-- that reads it is an O(n) scan (`hasLocalPresence` on every inbound federated
146−-- forward, `refreshLocalPresence` on every /poll). `handleRecvGossip` LRU-evicts
147−-- (`capList`) down to this ceiling.
127+-- without a cap one peer can grow `*presence` without bound. `handleRecvGossip`
128+-- LRU-evicts (`capList`) down to this ceiling.
148129--
149−-- Local rows (`server == serverHost`) are deliberately *exempt* from this cap and
150−-- from `maxPresencePerServer`. They are already bounded by `maxSessions` — one row
151−-- per authenticated session — and a shared ceiling would let a gossip flood evict
152−-- them: gossiped rows expire at `onlineGossipTtl` (90 min) while local rows expire
153−-- at `sessionExpiry` (60 min), so `capList`'s soonest-to-expire eviction would drop
154−-- *our own online users* first, and every inbound federated forward addressed to
155−-- them would then answer `no_presence` (404). Capping only remote rows bounds the
156−-- table without handing an attacker a way to knock local users off the mesh.
130+-- Local rows are exempt: they're bounded by `maxSessions` and a shared ceiling
131+-- would let gossip floods evict our own online users (local TTL 60 min < gossip
132+-- TTL 90 min, so `capList` drops local rows first). See PROTOCOL.md §10.
157133maxPresence : Int
158134maxPresence = 100000
159135-- Per-peer-server ceiling on gossip-learned presence rows, so a single peer cannot
@@ -258,13 +234,14 @@ federationEnabled = False {}
258234seedPeers : Text
259235seedPeers = ""
260236
261−-- `seedPeers` split on commas, trimmed, with blanks dropped. Deliberately *not*
262−-- filtered through `isBadServerName` here: every federation egress site applies
263−-- the deny-list itself, so a denylisted seed is refused at exactly the same choke
264−-- point as a denylisted gossip-learned peer, and the parse stays purely
265−-- syntactic.
237+-- `seedPeers` split on commas, trimmed, with blanks and our own hostname dropped.
238+-- Deliberately *not* filtered through `isBadServerName` here: every federation
239+-- egress site applies the deny-list itself, so a denylisted seed is refused at
240+-- exactly the same choke point as a denylisted gossip-learned peer.
241+-- Filtering `serverHost` out at parse time lets `gossipTargets` drop its
242+-- `isLocalServer` guard (the only other source, `collectPeers`, already filters it).
266243seedPeerList : [Text]
267−seedPeerList = filter (\s -> s != "") (splitOnComma seedPeers)
244+seedPeerList = filter (\s -> s != "" && not isLocalServer s) (splitOnComma seedPeers)
268245
269246federationUrl : Text -> Text
270247federationUrl = \server -> federationScheme ++ server
@@ -672,12 +649,11 @@ isReservedIPv4 = \host ->
672649-- outright. Gated by `isDottedNumeric` so a digit-led hostname label like
673650-- "0foo.example.com" is never caught (it isn't all-digits-and-dots).
674651hasLeadingZeroOctet : Text -> Bool
675−hasLeadingZeroOctet = \host -> isDottedNumeric host && anyOctetLeadingZero host
676−anyOctetLeadingZero : Text -> Bool
677−anyOctetLeadingZero = \host ->
678− let octet = beforeDot host in
679− let rest = afterDot host in
680− (length octet > 1 && take 1 octet == "0") || (rest != "" && anyOctetLeadingZero rest)
652+hasLeadingZeroOctet = \host ->
653+ isDottedNumeric host &&
654+ (let octet = beforeDot host in
655+ let rest = afterDot host in
656+ (length octet > 1 && take 1 octet == "0") || (rest != "" && hasLeadingZeroOctet rest))
681657
682658-- True when the host's first two labels name a reserved IPv4 range: the zero net
683659-- (0/8), loopback (127/8), and the RFC1918 blocks 10/8, 172.16/12, 192.168/16,
@@ -696,42 +672,25 @@ isReservedOctetPrefix = \host ->
696672
697673-- Block private/reserved/internal hostnames (SSRF defense).
698674--
699−-- LIMITATION — this check is purely lexical: it inspects the *string* a peer
700−-- gave us, never the address that string resolves to. An attacker who controls
701−-- DNS for a name that looks perfectly public (`relay.attacker.example`) can
702−-- point it at 127.0.0.1 / 169.254.169.254 / an RFC1918 host and this returns
703−-- False, so `fetch` dials the internal target anyway. Nothing here rules that
704−-- out, and re-resolving before the request wouldn't either (the resolver is
705−-- free to answer differently the second time — a DNS-rebinding TOCTOU). Closing
706−-- it needs resolution and connection to be fused: resolve the name, reject the
707−-- resulting IP against the same reserved ranges, and connect to *that* IP —
708−-- which the `fetch` in use does not expose. Treat the checks below as a guard
709−-- against accidental and naive-literal SSRF, not against a motivated attacker
710−-- with a nameserver. Percent-encoding tricks are likewise not covered.
711−--
712−-- Enforced on inbound requests (`handleRecvGossip`, so a peer can't claim a bogus
713−-- `fromServer`) and again at every federation egress site (`sendBatchedGossip`,
714−-- `retryPendingForwards`, `forkForwardsTo`) as defense-in-depth — state persisted
715−-- before a denylist tightening, or any future ingress gap, must not steer a
716−-- `fetch` at an internal host.
675+-- LIMITATION — purely lexical: inspects the string, never the resolved address.
676+-- DNS-rebinding TOCTOU and percent-encoding tricks bypass it. A real fix needs
677+-- resolve-then-pin (fuse resolution with connection), which `fetch` doesn't
678+-- expose. See PROTOCOL.md §10. Treat as a guard against naive-literal SSRF, not
679+-- a motivated attacker with a nameserver.
717680--
718−-- A legitimate `host:port` server name has exactly one `:`, so the multi-colon
719−-- check rejects bare IPv6 literals (loopback `::`/`::1`, link-local `fe80::/10`,
720−-- ULA `fc00::/7`, globals like `2001:db8::1`) while leaving `host:port` intact.
681+-- Enforced on inbound (`handleRecvGossip`) and at every egress site
682+-- (`sendBatchedGossip`, `retryPendingForwards`, `forkForwardsTo`) as
683+-- defense-in-depth — persisted state from before a denylist tightening must
684+-- not steer a `fetch` at an internal host.
721685--
722−-- The name is trailing-dot-stripped (`stripTrailingDot`) before every check.
723−-- The system resolver treats `localhost.` / `foo.internal.` (DNS root form) the
724−-- same as the dotless name, but the bare `== "localhost"` and `.internal`-suffix
725−-- tests would miss the dotted form. Peer-supplied names already arrive stripped
726−-- (`isValidServerName` rejects a trailing dot at the `/federation/gossip`
727−-- boundary), so the only unstripped ingress is `seedPeers`; normalizing here
728−-- keeps the deny-list sound independently of that upstream check — the same
729−-- "don't trust prior validation" posture the rest of this note describes.
686+-- A legitimate `host:port` has exactly one `:`, so the multi-colon check
687+-- rejects bare IPv6 literals. The name is trailing-dot-stripped before every
688+-- check so `localhost.` / `foo.internal.` (DNS root form) are caught.
730689isBadServerName : Text -> Bool
731690isBadServerName = \raw ->
732691 let sn = stripTrailingDot raw in
733692 let host = beforeColon sn in
734− 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.", "203.0.113."] || any (\s -> hasSuffix s sn) [".localhost", ".local", ".internal", ".arpa", ".onion"]
693+ 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.", "203.0.113."] || any (\s -> hasSuffix s sn) [".localhost", ".local", ".internal", ".arpa", ".onion"]
735694
736695-- ============================================
737696-- Auth helpers
@@ -932,7 +891,10 @@ refreshLocalPresence = \pubkey expiry -> do
932891-- One sweep over every state ref: drops expired rows in a single atomic block.
933892-- Returns the locally-expired presence rows whose pubkey has no other live
934893-- local session, so the caller can broadcast offline gossip for them.
935−pruneExpired : Int<Ms> -> IO {rw *challenges, rw *forwardFailures, rw *messages, rw *presence, rw *sessions} [PubkeyHex]
894+-- Also prunes orphaned *forwards entries whose message has been removed by
895+-- the TTL sweep — a 404-deferred forward (recipient never online at the peer)
896+-- would otherwise stay forever with retries=0, retried every sweep indefinitely.
897+pruneExpired : Int<Ms> -> IO {rw *challenges, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, rw *sessions} [PubkeyHex]
936898pruneExpired = \t -> atomic do
937899 ch <- *challenges
938900 *challenges = filter (\x -> x.expiresAt > t) ch
@@ -940,6 +902,10 @@ pruneExpired = \t -> atomic do
940902 *sessions = filter (\x -> x.expiresAt > t) ses
941903 msgs <- *messages
942904 *messages = filter (\m -> t - m.receivedAt < messageMaxAge) msgs
905+ -- Prune forwards whose message was removed by the TTL sweep above.
906+ -- ForwardEntry carries no timestamp, so match against the surviving messages.
907+ fw <- *forwards
908+ *forwards = filter (\f -> any (\m -> m.toKey == f.toKey && m.encryptedBlob == f.encryptedBlob) msgs) fw
943909 ff <- *forwardFailures
944910 *forwardFailures = filter (\f -> t - f.failedAt < forwardFailureMaxAge) ff
945911 -- presence: remember locally-expired keys for offline gossip
@@ -969,7 +935,7 @@ pruneExpired = \t -> atomic do
969935-- rows, and from then on it is reachable through the `peers` half of this union
970936-- like any other peer.
971937gossipTargets : [Text] -> [Text]
972−gossipTargets = \peers -> filter (\s -> not isLocalServer s) (union peers seedPeerList)
938+gossipTargets = \peers -> union peers seedPeerList
973939
974940-- Fan out one bundle of gossip events to each peer (presence-learned peers and
975941-- bootstrap seeds alike), skipping denylisted peers and peers in backoff. No-op
@@ -1094,7 +1060,9 @@ forwardQueuedToServer = \pubkey serverName -> atomic (do
10941060 fwds <- *forwards
10951061 let existing = countWhere (\f -> f.toServer == server) fwds
10961062 let budget = max 0 (maxForwardsPerServer - existing)
1097− let candidates = filter (\m -> m.toKey == pubkey && not any (forwardMatches m.toKey m.encryptedBlob server) fwds && not any (\d -> d.server == server) m.deliveredTo) msgs
1063+ let notYetForwarded = \m -> not any (forwardMatches m.toKey m.encryptedBlob server) fwds
1064+ let notYetDelivered = \m -> not any (\d -> d.server == server) m.deliveredTo
1065+ let candidates = filter (\m -> m.toKey == pubkey && notYetForwarded m && notYetDelivered m) msgs
10981066 let newFwds = map (\m -> {toServer: server, m.toKey, m.encryptedBlob, retries: 0}) (take budget (sortBy (\m -> m.receivedAt) candidates))
10991067 *forwards = union fwds newFwds)
11001068
@@ -1147,6 +1115,8 @@ handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp -> do
11471115 -- The client signs (target host, challenge) under a domain-separation tag so a
11481116 -- relay server cannot replay the signature to a different server. We verify
11491117 -- against our own configured hostname (port stripped), which a relay cannot forge.
1118+ -- Computed outside the atomic block: `verify` is not a DB effect, and computing
1119+ -- it here avoids re-running crypto on every STM retry.
11501120 let signedText = "skrepka-auth-v1:" ++ authHost serverHost ++ ":" ++ challenge
11511121 let sigValid = case bytesFromHex pubkey of
11521122 Just {value: pk} -> case bytesFromHex signature of
@@ -1210,6 +1180,8 @@ handlePoll = \cursor authorization clientIp -> do
12101180 let clampedCursor = max 0 (min (max t curSeq) cursor)
12111181 when (clampedCursor > 0) (ackPolledMessages pubkey clampedCursor)
12121182 pres <- *presence
1183+ -- Refresh local presence when less than half the session TTL remains,
1184+ -- so peers don't time us out mid-session.
12131185 let stale = not any (\p -> p.pubkey == pubkey && isLocalServer p.server && p.expiresAt - t >= sessionExpiry / 2) pres
12141186 refreshPeers <- if stale then refreshLocalPresence pubkey (t + sessionExpiry) else yield []
12151187 yield (Just {value: {pubkey, clampedCursor, refreshPeers}}))
@@ -1272,15 +1244,17 @@ doPoll = \s t -> do
12721244-- The ack is destructive and keyed on `pubkey` alone — no session identity enters
12731245-- into it, so two sessions sharing one keypair race over one mailbox. Accepted
12741246-- limitation; see `maxSessionsPerKey`.
1247+-- Self-atomic: touches two refs (*messages and *forwards), so wraps its own
1248+-- transaction rather than relying on the caller's.
12751249ackPolledMessages : PubkeyHex -> Timestamp -> IO {rw *forwards, rw *messages} {}
1276−ackPolledMessages = \pubkey cursor -> do
1250+ackPolledMessages = \pubkey cursor -> atomic (do
12771251 msgs <- *messages
12781252 let matches = \m -> m.toKey == pubkey && m.receivedAt <= cursor
12791253 let toAck = filter matches msgs
12801254 let blobs = map (\m -> m.encryptedBlob) toAck
12811255 *messages = filter (\m -> not matches m) msgs
12821256 fwds <- *forwards
1283− *forwards = filter (\f -> not (f.toKey == pubkey && elem f.encryptedBlob blobs)) fwds
1257+ *forwards = filter (\f -> not (f.toKey == pubkey && elem f.encryptedBlob blobs)) fwds)
12841258
12851259-- ============================================
12861260-- Handler: send
@@ -1295,6 +1269,21 @@ ackPolledMessages = \pubkey cursor -> do
12951269-- The sender's UI treats every success the same and learns "they got it" only via
12961270-- the recipient's E2E ack.
12971271
1272+-- Batch validation: checks batch size, per-message field validity, and self-send.
1273+-- Refined-type validation at the route boundary only fires for top-level scalar
1274+-- body fields; `to`/`encryptedBlob` are nested inside the `messages` list, so the
1275+-- runtime does not check them. `isValidBlobHex` is the same predicate `BlobHex`
1276+-- refines on, so this check and the route boundary cannot drift apart.
1277+validateBatch : [{to: PubkeyHex, encryptedBlob: BlobHex | a}] -> PubkeyHex -> Maybe HttpError
1278+validateBatch = \messages senderKey ->
1279+ if count messages > maxBatchSize
1280+ then Just {value: {status: 413, message: "batch_too_large"}}
1281+ else if any (\m -> not (isValidExactHex 64 m.to && isValidBlobHex m.encryptedBlob)) messages
1282+ then Just {value: {status: 400, message: "invalid_message"}}
1283+ else if any (\m -> m.to == senderKey) messages
1284+ then Just {value: {status: 400, message: "self_send"}}
1285+ else Nothing {}
1286+
12981287-- POST /messages: send a list of ciphertexts atomically. Self-send is
12991288-- rejected up-front; the remaining batch is committed inside one atomic
13001289-- block (all-or-nothing) which reads presence to pre-stage federation
@@ -1305,21 +1294,9 @@ handleSendMessages = \messages authorization clientIp -> do
13051294 auth <- authedPubkey authorization t clientIp
13061295 case auth of
13071296 Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
1308− Just {value: senderKey} -> do
1309− if count messages > maxBatchSize
1310− then yield (Err {error: {status: 413, message: "batch_too_large"}})
1311− -- Refined-type validation at the route boundary only fires for top-level
1312− -- scalar body fields; `to`/`encryptedBlob` are nested inside the `messages`
1313− -- list, so the runtime does not check them. Enforce the `PubkeyHex` /
1314− -- `BlobHex` contracts here so a malformed key, or a non-hex / under-
1315− -- `minBlobLen` / over-`maxBlobLen` blob, is rejected instead of stored.
1316− -- `isValidBlobHex` is the same predicate `BlobHex` refines on, so this
1317− -- check and the route boundary cannot drift apart.
1318− else if any (\m -> not (isValidExactHex 64 m.to && isValidBlobHex m.encryptedBlob)) messages
1319− then yield (Err {error: {status: 400, message: "invalid_message"}})
1320− else if any (\m -> m.to == senderKey) messages
1321− then yield (Err {error: {status: 400, message: "self_send"}})
1322− else do
1297+ Just {value: senderKey} -> case validateBatch messages senderKey of
1298+ Just {value: err} -> yield (Err {error: err})
1299+ Nothing {} -> do
13231300 committed <- atomic (do
13241301 pres <- *presence
13251302 let staged = map (\m -> {
@@ -1339,7 +1316,9 @@ handleSendMessages = \messages authorization clientIp -> do
13391316 -- is `[]` on the normal path; on a client resend it carries the real
13401317 -- set. Mirrors `forwardQueuedToServer`'s guard so we don't re-stage a
13411318 -- forward to a peer that already accepted this blob.
1342− let delivered = fold (\acc m -> if m.toKey == c.to && m.encryptedBlob == c.encryptedBlob then union acc (map (\d -> d.server) m.deliveredTo) else acc) [] existingMsgs
1319+ let delivered = case findFirst existingMsgs (\m -> m.toKey == c.to && m.encryptedBlob == c.encryptedBlob) of
1320+ Just {value: m} -> map (\d -> d.server) m.deliveredTo
1321+ Nothing {} -> ([] : [Text])
13431322 -- Stage outbox rows for peers under their `maxForwardsPerServer`
13441323 -- ceiling. Peers at the cap still get the immediate post-commit
13451324 -- delivery attempt (`forkForwardsTo`) — only the retry-queue row
@@ -1538,7 +1517,7 @@ api = serve Api where
15381517-- Endless tick: prune expired state and gossip offline for locally-expired
15391518-- keys. First sweep happens immediately so stale rows persisted by the
15401519-- previous process clear before the next interval elapses.
1541−backgroundPrune : IO {rw *challenges, rw *forwardFailures, rw *messages, rw *presence, rw *sessions, network, clock} a
1520+backgroundPrune : IO {rw *challenges, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, rw *sessions, network, clock} a
15421521backgroundPrune = do
15431522 t <- now
15441523 -- Snapshot the peer set *before* the sweep. `pruneExpired` drops every expired