@@ -115,6 +115,10 @@ retryBackoffBase = 30000
115-- Cap on federation retry backoff (8 min).
115-- Cap on federation retry backoff (8 min).
116retryBackoffMax : Int<Ms>
116retryBackoffMax : Int<Ms>
117retryBackoffMax = 480000
117retryBackoffMax = 480000
118+-- How long a peer's failure record survives past its most recent failure (24 h).
119+-- After this, accumulated backoff resets — the next attempt is treated as fresh.
120+forwardFailureMaxAge : Int<Ms>
121+forwardFailureMaxAge = 86400000
119-- Cadence of the background prune/cleanup task (30 s).
123-- Cadence of the background prune/cleanup task (30 s).
120backgroundPruneInterval : Int<Ms>
124backgroundPruneInterval : Int<Ms>
@@ -399,25 +403,18 @@ clientIpOf = \h -> case h of
399 Just {value: ip} -> ip
403 Just {value: ip} -> ip
400 Nothing {} -> ""
404 Nothing {} -> ""
402−-- Pull the token out of an `Authorization: Bearer <token>` header. Returns
403−-- Nothing if the prefix is missing or the token is empty.
404−extractToken : Text -> Maybe Text
406− let token = drop 7 h
407− if hasPrefix "Bearer " h && token != ""
408− then Just {value: token}
411-- Resolve a Bearer token to its session pubkey if the session is unexpired and
406-- Resolve a Bearer token to its session pubkey if the session is unexpired and
412-- the client IP matches. Runs `onAuth pubkey` on success, `onUnauth` otherwise.
407-- the client IP matches. Runs `onAuth pubkey` on success, `onUnauth` otherwise.
413withSessionAuth : Text -> Int<Ms> -> Text -> IO e a -> (PubkeyHex -> IO e a) -> IO {r *sessions | e} a
408withSessionAuth : Text -> Int<Ms> -> Text -> IO e a -> (PubkeyHex -> IO e a) -> IO {r *sessions | e} a
414withSessionAuth = \authorization t clientIp onUnauth onAuth -> do
409withSessionAuth = \authorization t clientIp onUnauth onAuth -> do
415 ses <- *sessions
410 ses <- *sessions
416− case extractToken authorization of
411+ let token = drop 7 authorization
417− Nothing {} -> onUnauth
412+ let match = if hasPrefix "Bearer " authorization && token != ""
418− Just {value: token} -> case findFirst ses (\s -> s.expiresAt > t && s.token == token && matchIp clientIp s.ip) of
413+ then findFirst ses (\s -> s.expiresAt > t && s.token == token && matchIp clientIp s.ip)
419− Just {value: s} -> onAuth s.pubkey
416+ Just {value: s} -> onAuth s.pubkey
420− _ -> onUnauth
417+ _ -> onUnauth
422-- True when `signature` is a valid Ed25519 signature by `pubkey` over `challenge`.
419-- True when `signature` is a valid Ed25519 signature by `pubkey` over `challenge`.
423-- False on any hex-decoding failure.
420-- False on any hex-decoding failure.
@@ -471,11 +468,6 @@ clearFailure = \server -> atomic (do
471-- generation, presence queries, and atomic mailbox/presence writes
468-- generation, presence queries, and atomic mailbox/presence writes
472-- (callers supply the surrounding `atomic` block).
469-- (callers supply the surrounding `atomic` block).
474−-- All unexpired presence rows for a given pubkey (may include both local and
475−-- remote entries — the recipient may live on multiple servers simultaneously).
476−presenceForKey : [PresenceEntry] -> PubkeyHex -> Timestamp -> [PresenceEntry]
477−presenceForKey = \presence pubkey t -> filter (\p -> p.pubkey == pubkey && p.expiresAt > t) presence
479-- True when `pk` has a live local presence row (i.e. is currently online here).
471-- True when `pk` has a live local presence row (i.e. is currently online here).
480hasLocalPresence : [PresenceEntry] -> PubkeyHex -> Timestamp -> Bool
472hasLocalPresence : [PresenceEntry] -> PubkeyHex -> Timestamp -> Bool
481hasLocalPresence = \pres pk t -> any (\p -> p.pubkey == pk && isLocalServer p.server && p.expiresAt > t) pres
473hasLocalPresence = \pres pk t -> any (\p -> p.pubkey == pk && isLocalServer p.server && p.expiresAt > t) pres
@@ -527,7 +519,7 @@ pruneExpired = \t -> atomic do
527 msgs <- *messages
519 msgs <- *messages
528 *messages = filter (\m -> t - m.receivedAt < messageMaxAge) msgs
520 *messages = filter (\m -> t - m.receivedAt < messageMaxAge) msgs
529 ff <- *forwardFailures
521 ff <- *forwardFailures
530− *forwardFailures = filter (\f -> t - f.failedAt < 86400000) ff
522+ *forwardFailures = filter (\f -> t - f.failedAt < forwardFailureMaxAge) ff
531 -- presence: remember locally-expired keys for offline gossip
523 -- presence: remember locally-expired keys for offline gossip
532 pres <- *presence
524 pres <- *presence
533 *presence = filter (\p -> p.expiresAt > t) pres
525 *presence = filter (\p -> p.expiresAt > t) pres
@@ -688,8 +680,7 @@ handlePoll = \cursor authorization clientIp -> do
688 when (clampedCursor > 0) (ackPolledMessages pubkey clampedCursor)
680 when (clampedCursor > 0) (ackPolledMessages pubkey clampedCursor)
689 startWakeup <- *pollWakeup
681 startWakeup <- *pollWakeup
690 pres <- *presence
682 pres <- *presence
691− let mine = \p -> p.pubkey == pubkey && isLocalServer p.server
692− let stale = not any (\p -> mine p && p.expiresAt - t >= sessionExpiry / 2) pres
683+ let stale = not any (\p -> p.pubkey == pubkey && isLocalServer p.server && p.expiresAt - t >= sessionExpiry / 2) pres
693 refreshPeers <- if stale
684 refreshPeers <- if stale
694 then refreshLocalPresence pubkey (t + sessionExpiry)
685 then refreshLocalPresence pubkey (t + sessionExpiry)
695 else yield []
686 else yield []
@@ -773,7 +764,7 @@ handleSendMessages = \messages authorization clientIp -> do
773 let staged = map (\m -> {
764 let staged = map (\m -> {
775 m.encryptedBlob,
766 m.encryptedBlob,
776− remoteServers: collectPeers (presenceForKey pres m.to t) (\p -> p.server)
767+ remoteServers: collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server)
777 }) limited
768 }) limited
778 forEach staged (\c -> commitSendMessage c.to c.encryptedBlob c.remoteServers t)
769 forEach staged (\c -> commitSendMessage c.to c.encryptedBlob c.remoteServers t)
779 yield staged)
770 yield staged)