@@ -299,11 +299,6 @@ route Api = AuthApi | ClientApi | FederationApi
299299-- Everything is intentionally O(n) over flat lists; performance is sacrificed
300300-- for clarity per the file header.
301301
302−-- Run `action` only when `cond` is True; otherwise no-op.
303−-- Confine `x` to the closed interval [lo, hi].
304−clamp : Ord a => a -> a -> a -> a
305−clamp = \lo hi x -> max lo (min hi x)
306−
307302-- Cap to maxN by dropping the soonest-to-expire entries (LRU-style). Always
308303-- sorts by `expiresAt` so the oldest/most-stale entries are evicted first.
309304capList : [{expiresAt: Timestamp | r}] -> Int -> [{expiresAt: Timestamp | r}]
@@ -376,7 +371,7 @@ isBadServerName = \sn -> sn == "" || sn == "localhost" || any (\c -> not contain
376371-- Auth helpers
377372-- ============================================
378373-- Bearer token extraction and session lookup. Authenticated handlers funnel
379−-- through `withSessionAuth`; per-endpoint rate limiting is enforced by the
374+-- through `authedPubkey`; per-endpoint rate limiting is enforced by the
380375-- compiler-generated `rateLimit` clauses on each route.
381376-- Federation requests are unauthenticated: anyone can hit /federation/*.
382377-- The `no_presence` check bounds federated forwards to currently-online keys.
@@ -393,17 +388,17 @@ clientIpOf = \h -> case h of
393388 Nothing {} -> ""
394389
395390-- Resolve a Bearer token to its session pubkey if the session is unexpired and
396−-- the client IP matches. Runs `onAuth pubkey` on success, `onUnauth` otherwise.
397−withSessionAuth : Text -> Int<Ms> -> Text -> IO e a -> (PubkeyHex -> IO e a) -> IO {r *sessions | e} a
398−withSessionAuth = \authorization t clientIp onUnauth onAuth -> do
391+-- the client IP matches. Returns Nothing on missing/invalid token.
392+authedPubkey : Text -> Int<Ms> -> Text -> IO {r *sessions} (Maybe PubkeyHex)
393+authedPubkey = \authorization t clientIp -> do
399394 ses <- *sessions
400− let token = drop 7 authorization
401− let match = if hasPrefix "Bearer " authorization && token != ""
402− then findFirst ses (\s -> s.expiresAt > t && s.token == token && matchIp clientIp s.ip)
403− else Nothing {}
404− case match of
405− Just {value: s} -> onAuth s.pubkey
406− _ -> onUnauth
395+ if not hasPrefix "Bearer " authorization
396+ then yield (Nothing {})
397+ else do
398+ let token = drop 7 authorization
399+ case findFirst ses (\s -> s.expiresAt > t && s.token == token && matchIp clientIp s.ip) of
400+ Just {value: s} -> yield (Just {value: s.pubkey})
401+ _ -> yield (Nothing {})
407402
408403-- True when `signature` is a valid Ed25519 signature by `pubkey` over `challenge`.
409404-- False on any hex-decoding failure.
@@ -524,10 +519,10 @@ pruneExpired = \t -> atomic do
524519-- Fan out one bundle of gossip events to each peer, skipping peers in backoff.
525520-- Records or clears federation-failure counters per call.
526521sendBatchedGossip : [Text] -> [GossipEventType] -> IO {rw *forwardFailures, network, clock} {}
527−sendBatchedGossip = \peers events -> forEach peers (\server -> do
522+sendBatchedGossip = \peers events -> do
528523 t <- now
529524 failures <- *forwardFailures
530− when (shouldRetryServer server t failures) (do
525+ forEach peers (\server -> when (shouldRetryServer server t failures) (do
531526 result <- fetch (federationUrl server) (RecvGossip {events, fromServer: serverHost})
532527 case result of
533528 Err _ -> recordFailure server
@@ -637,7 +632,7 @@ handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp -> do
637632 *challenges = filter (\c -> not same c) ch
638633 ses <- *sessions
639634 let pruned = if revokeOthers
640− then filter (\s -> not (s.pubkey == pubkey)) ses
635+ then filter (\s -> s.pubkey != pubkey) ses
641636 else capPerKey ses pubkey maxSessionsPerKey
642637 let newSession = {token, pubkey, expiresAt: expiry, ip: clientIp}
643638 *sessions = capList (union pruned [newSession]) maxSessions
@@ -664,16 +659,20 @@ handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp -> do
664659handlePoll : Int -> Text -> Text -> IO {r *pollWakeup, r *sessions, rw *forwardFailures, rw *forwards, rw *messages, rw *presence, network, clock} (Result HttpError {cursor: Timestamp, events: [PollEvent]})
665660handlePoll = \cursor authorization clientIp -> do
666661 t <- now
667− setup <- atomic withSessionAuth authorization t clientIp (yield (Nothing {})) (\pubkey -> do
668− let clampedCursor = clamp 0 t cursor
669− when (clampedCursor > 0) (ackPolledMessages pubkey clampedCursor)
670− startWakeup <- *pollWakeup
671− pres <- *presence
672− let stale = not any (\p -> p.pubkey == pubkey && isLocalServer p.server && p.expiresAt - t >= sessionExpiry / 2) pres
673− refreshPeers <- if stale
674− then refreshLocalPresence pubkey (t + sessionExpiry)
675− else yield []
676− yield (Just {value: {pubkey, clampedCursor, startWakeup, refreshPeers}}))
662+ setup <- atomic (do
663+ auth <- authedPubkey authorization t clientIp
664+ case auth of
665+ Nothing {} -> yield (Nothing {})
666+ Just {value: pubkey} -> do
667+ let clampedCursor = max 0 (min t cursor)
668+ when (clampedCursor > 0) (ackPolledMessages pubkey clampedCursor)
669+ startWakeup <- *pollWakeup
670+ pres <- *presence
671+ let stale = not any (\p -> p.pubkey == pubkey && isLocalServer p.server && p.expiresAt - t >= sessionExpiry / 2) pres
672+ refreshPeers <- if stale
673+ then refreshLocalPresence pubkey (t + sessionExpiry)
674+ else yield []
675+ yield (Just {value: {pubkey, clampedCursor, startWakeup, refreshPeers}}))
677676 case setup of
678677 Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
679678 Just {value: s} -> do
@@ -739,27 +738,30 @@ ackPolledMessages = \pubkey cursor -> do
739738handleSendMessages : [{encryptedBlob: BlobHex, to: PubkeyHex | a}] -> Text -> Text -> IO {r *presence, r *sessions, rw *forwardFailures, rw *forwards, rw *messages, rw *pollWakeup, rw *seqCounter, network, clock} (Result HttpError {})
740739handleSendMessages = \messages authorization clientIp -> do
741740 t <- now
742− withSessionAuth authorization t clientIp (yield (Err {error: {status: 401, message: "unauthorized"}})) (\senderKey -> do
743− let limited = take maxBatchSize messages
744− if any (\m -> m.to == senderKey) limited
745− then yield (Err {error: {status: 400, message: "self_send"}})
746− else do
747− committed <- atomic (do
748− pres <- *presence
749− let staged = map (\m -> {
750− m.to,
751− m.encryptedBlob,
752− remoteServers: collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server)
753− }) limited
754− forEach staged (\c -> do
755− appendMessage c.to c.encryptedBlob t
756− when federationEnabled (do
757− fwds <- *forwards
758− let newFwds = map (\s -> {toServer: s, toKey: c.to, encryptedBlob: c.encryptedBlob, retries: 0}) (filter (\s -> not any (\f -> f.encryptedBlob == c.encryptedBlob && f.toServer == s) fwds) c.remoteServers)
759− *forwards = union fwds newFwds))
760− yield staged)
761− when federationEnabled (forEach committed (\c -> fork (forkForwardsTo c.to c.encryptedBlob c.remoteServers)))
762− yield (Ok {value: {}}))
741+ auth <- authedPubkey authorization t clientIp
742+ case auth of
743+ Nothing {} -> yield (Err {error: {status: 401, message: "unauthorized"}})
744+ Just {value: senderKey} -> do
745+ let limited = take maxBatchSize messages
746+ if any (\m -> m.to == senderKey) limited
747+ then yield (Err {error: {status: 400, message: "self_send"}})
748+ else do
749+ committed <- atomic (do
750+ pres <- *presence
751+ let staged = map (\m -> {
752+ m.to,
753+ m.encryptedBlob,
754+ remoteServers: collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server)
755+ }) limited
756+ forEach staged (\c -> do
757+ appendMessage c.to c.encryptedBlob t
758+ when federationEnabled (do
759+ fwds <- *forwards
760+ let newFwds = map (\s -> {toServer: s, toKey: c.to, encryptedBlob: c.encryptedBlob, retries: 0}) (filter (\s -> not any (\f -> f.encryptedBlob == c.encryptedBlob && f.toServer == s) fwds) c.remoteServers)
761+ *forwards = union fwds newFwds))
762+ yield staged)
763+ when federationEnabled (forEach committed (\c -> fork (forkForwardsTo c.to c.encryptedBlob c.remoteServers)))
764+ yield (Ok {value: {}})
763765
764766-- Fire one /federation/forward call per pre-staged server. On success the
765767-- corresponding row in `forwards` is pruned, and if no other forwards remain