@@ -15,18 +15,13 @@
1515
1616-- Server identity and federation credentials
1717serverHost = "localhost:8080"
18−federationSecret = "" -- must be set to enable federation
19−maintenanceSecret = "" -- set to enable /maintenance/prune independently of federation
18+maintenanceSecret = "" -- set to enable /maintenance/* and /stats endpoints
2019federationScheme = "https://" -- scheme for federation HTTP calls
2120-- NOTE: Outbound federation HTTP calls have no runtime-level timeout. The fetchFederation
2221-- wrapper tracks in-flight requests per server and skips servers with outstanding requests
2322-- older than federationFetchTimeoutMs (see shouldRetryServerEx). This prevents a single
2423-- slow peer from consuming all concurrency slots, though truly hung connections still hold
2524-- one slot until the forked task terminates.
26−-- Per-peer federation secrets (overrides global federationSecret for specific peers)
27−-- Format: [{server: "peer.example.com", secret: "peer-specific-secret"}]
28−federationPeerSecrets : [{server: Text, secret: Text}]
29−federationPeerSecrets = []
3025-- Message and data size limits
3126messageMaxAge : Int<Ms>
3227messageMaxAge = 2592000000 -- 30 days
@@ -136,9 +131,13 @@ presenceRefreshInterval : Int<Ms>
136131presenceRefreshInterval = 300000 -- 5 minutes
137132presenceRefreshThreshold : Int<Ms>
138133presenceRefreshThreshold = presenceRefreshInterval * 2 -- refresh entries expiring within this window
139−federationEnabled = federationSecret != ""
140−federationAuth = "Bearer " ++ federationSecret
134+federationEnabled = True {}
141135federationUrl = \server -> federationScheme ++ server
136+-- Callback verification: outbound federation requests include a random single-use token;
137+-- the receiver calls back to /federation/verify to confirm the sender actually issued it.
138+maxPendingVerifications = 10000
139+verificationTokenExpiry : Int<Ms>
140+verificationTokenExpiry = 30000 -- 30 seconds
142141-- IP-based rate limiting (reverse proxy sets ClientIp header)
143142maxIpRatePerIp = 10 -- max auth requests per IP per window
144143ipRateWindowMs : Int<Ms>
@@ -452,6 +451,9 @@ type RecentFederationRequest = {server: Text, timestamp: Timestamp, seenAt: Time
452451-- Recent federation requests for replay detection (dedup by server+timestamp)
453452*recentFederationRequests : [RecentFederationRequest]
454453
454+-- Pending verification tokens for federation callback auth (single-use, short-lived)
455+*pendingVerifications : [{token: Text, createdAt: Timestamp}]
456+
455457-- ============================================
456458-- Routes
457459-- ============================================
@@ -496,7 +498,7 @@ route ClientApi where
496498 -> {server: AnyServerName, authorized: Bool}
497499 = LookupPresence
498500
499−-- Server-to-server federation API (requires federation secret)
501+-- Server-to-server federation API (authenticated via domain callback verification)
500502route FederationApi where
501503 /federation
502504 -- Receive presence gossip events from a peer server
@@ -512,6 +514,11 @@ route FederationApi where
512514 -> {ok: Bool, error: Text}
513515 = FederationAck
514516
517+-- Federation callback verification: the receiving server calls back to the sender
518+-- to confirm a request token is genuine. No shared secret needed.
519+route FederationVerifyApi where
520+ POST {token: Text} /federation/verify -> {ok: Bool} = VerifyToken
521+
515522-- Triggers pruning of expired state and retry of pending federation ops
516523route MaintenanceApi where
517524 POST {} /maintenance/prune headers {authorization: Text}
@@ -538,7 +545,7 @@ route MaintenanceApi where
538545route HealthApi where
539546 GET /health -> {ok: Bool, pruneHealthy: Bool, heartbeatHealthy: Bool, capacityHealthy: Bool, federationHealthy: Bool} = Health
540547
541−-- Returns counts of in-memory collections (requires federation or maintenance secret)
548+-- Returns counts of in-memory collections (requires maintenance secret)
542549route StatsApi where
543550 GET /stats headers {authorization: Text}
544551 -> {sessions: Int, sessionsMax: Int, messages: Int, messagesMax: Int, presence: Int, presenceMax: Int, forwards: Int, forwardsMax: Int, challenges: Int, challengesMax: Int, ackedIds: Int, ackedIdsMax: Int, ackOverflow: Int, ackOverflowMax: Int, deliveredIds: Int, deliveredIdsMax: Int, forwardFailures: Int, activePolls: Int, activePollsMax: Int, sendRates: Int, challengeRates: Int, federationRates: Int, globalRateCount: Int, ipRates: Int, lookupRates: Int, recvRates: Int, pruneCount: Int, pruneRunning: Timestamp, heartbeatCount: Int, uptime: Int, lastPruneAt: Timestamp, lastHeartbeatAt: Timestamp, draining: Bool, federationEnabled: Bool, recentGossip: Int, totalMessageCount: Int, recipientCounts: Int, federationInFlight: Int, messagesPct: Int, presencePct: Int, forwardsPct: Int, sessionsPct: Int, federationAvgLatencyMs: Int, federationMaxLatencyMs: Int, federationCallCount: Int, drainCompletedAt: Timestamp, ok: Bool}
@@ -550,7 +557,7 @@ route StatsApi where
550557 -> {messages: Int, presence: [KeyPresenceEntry], sessions: Int, forwards: Int, activePolls: Int, ok: Bool}
551558 = StatsKey
552559
553−route Api = AuthApi | ClientApi | FederationApi | MaintenanceApi | HealthApi | StatsApi
560+route Api = AuthApi | ClientApi | FederationApi | FederationVerifyApi | MaintenanceApi | HealthApi | StatsApi
554561
555562-- ============================================
556563-- Helpers
@@ -800,7 +807,7 @@ extractToken = \authHeader ->
800807 then Just {value: token}
801808 else Nothing {}
802809
803−-- Constant-time secret comparison (prevents timing attacks on federation/maintenance secrets)
810+-- Constant-time secret comparison (prevents timing attacks on maintenance secret)
804811verifySecret : Text -> Text -> Bool
805812verifySecret = \token secret ->
806813 secret != "" && safeCompare token secret
@@ -811,27 +818,36 @@ verifyAuthWith = \check authorization ->
811818 Nothing {} -> False {}
812819 Just {value: token} -> check token
813820
814−verifyFederationAuth : Text -> Bool
815−verifyFederationAuth = verifyAuthWith (\token -> verifySecret token federationSecret)
816−
817−-- Per-peer federation auth: checks peer-specific secret first, falls back to global
818−verifyFederationAuthForServer : Text -> Text -> Bool
819−verifyFederationAuthForServer = \fromServer authorization ->
820− verifyAuthWith (\token ->
821− case headOf (do p <- federationPeerSecrets; where normalizeServerName p.server == fromServer; yield p) of
822− Just {value: p} -> verifySecret token p.secret
823− Nothing {} -> verifySecret token federationSecret
824− ) authorization
825−
826821verifyMaintenanceAuth : Text -> Bool
827−verifyMaintenanceAuth = verifyAuthWith (\token -> verifySecret token federationSecret || verifySecret token maintenanceSecret)
822+verifyMaintenanceAuth = verifyAuthWith (\token -> verifySecret token maintenanceSecret)
828823
829−-- Outbound federation auth: use per-peer secret if configured, otherwise global
830−federationAuthForServer : Text -> Text
831−federationAuthForServer = \server ->
832− case headOf (do p <- federationPeerSecrets; where normalizeServerName p.server == server; yield p) of
833− Just {value: p} -> "Bearer " ++ p.secret
834− Nothing {} -> federationAuth
824+-- Generate a single-use token for outbound federation auth.
825+-- The receiving server calls back to /federation/verify to confirm we issued it.
826+generateFederationAuth : IO {network} Text
827+generateFederationAuth = do
828+ token <- genToken
829+ t <- now
830+ atomic do
831+ pending <- *pendingVerifications
832+ let updated = union pending [{token: token, createdAt: t}]
833+ set *pendingVerifications = if count updated > maxPendingVerifications
834+ then evictOneOldest updated (\p -> p.createdAt)
835+ else updated
836+ yield ("Bearer " ++ token)
837+
838+-- Verify an inbound federation token by callback to the sender's /federation/verify endpoint.
839+-- Single-use: the sender consumes the token on verification.
840+verifyFederationCallback : Text -> Text -> IO {network} Bool
841+verifyFederationCallback = \fromServer authorization ->
842+ case extractToken authorization of
843+ Nothing {} -> yield (False {})
844+ Just {value: token} -> do
845+ result <- fetch (federationUrl fromServer) (VerifyToken {token: token})
846+ case result of
847+ Err e -> do
848+ println ("federation: verify callback to " ++ fromServer ++ " failed: " ++ show e)
849+ yield (False {})
850+ Ok r -> yield r.ok
835851
836852-- ============================================
837853-- Session Bucket Helpers
@@ -1591,6 +1607,9 @@ pruneExpired = \t -> do
15911607 -- Prune stale federation replay dedup entries
15921608 recentFedReqs <- *recentFederationRequests
15931609 set *recentFederationRequests = do r <- recentFedReqs; where t - r.seenAt < clockSkewTolerance * 2; yield r
1610+ -- Prune expired federation verification tokens
1611+ pending <- *pendingVerifications
1612+ set *pendingVerifications = do p <- pending; where t - p.createdAt < verificationTokenExpiry; yield p
15941613 yield presenceResult
15951614
15961615
@@ -1611,8 +1630,9 @@ sendBatchedGossipToServer : ServerName -> [GossipEvent] -> Int -> IO {network} {
16111630sendBatchedGossipToServer = \server allEvents hops ->
16121631 forEachBatch allEvents maxGossipEvents (\batch -> do
16131632 t <- now
1633+ auth <- generateFederationAuth
16141634 result <- fetchFederation server (RecvGossip {
1615− authorization: federationAuthForServer server,
1635+ authorization: auth,
16161636 events: batch, hopsRemaining: hops, fromServer: serverHostN,
16171637 requestTimestamp: t})
16181638 case result of
@@ -1716,8 +1736,9 @@ checkPreAuth = \clientIp t -> do
17161736 if ipLimited then yield "ip_rate_limited"
17171737 else yield ""
17181738
1719−withFederationAuth = \authorization t respond fromServer requestTimestamp precondition action ->
1720− if not (verifyFederationAuthForServer fromServer authorization)
1739+withFederationAuth = \authorization t respond fromServer requestTimestamp precondition action -> do
1740+ verified <- verifyFederationCallback fromServer authorization
1741+ if not verified
17211742 then yield (respond {ok: False {}, error: "unauthorized"})
17221743 -- Replay protection: reject requests with timestamps too far from local clock.
17231744 -- requestTimestamp == 0 means the peer doesn't support this field yet (accept).
@@ -1757,10 +1778,6 @@ withFederationAuth = \authorization t respond fromServer requestTimestamp precon
17571778 println ("federation: rate limited (" ++ show maxFederationRatePerServer ++ "/s per server), rejecting for " ++ fromServer)
17581779 yield (respond {ok: False {}, error: "rate_limited"})
17591780 else do
1760− let hasPeerSecrets = count federationPeerSecrets > 0
1761− let hasSpecificSecret = any federationPeerSecrets (\p -> normalizeServerName p.server == fromServer)
1762− when (hasPeerSecrets && not hasSpecificSecret)
1763− (println ("federation: warning: " ++ fromServer ++ " using global secret (no per-peer secret configured)"))
17641781 clearFailure fromServer
17651782 action
17661783
@@ -1875,11 +1892,12 @@ retryForwardsForServer = \entries remaining ->
18751892 Just {value: f} -> do
18761893 let rest = do x <- entries; where x.messageId != f.messageId; yield x
18771894 t <- now
1895+ auth <- generateFederationAuth
18781896 result <- fetchFederation f.toServer (ForwardMessage {
18791897 toKey: f.toKey, encryptedBlob: f.encryptedBlob,
18801898 timestamp: f.timestamp, originServer: f.originServer, messageId: f.messageId,
18811899 fromServer: serverHostN, requestTimestamp: t,
1882− authorization: federationAuthForServer f.toServer})
1900+ authorization: auth})
18831901 case result of
18841902 Err e -> do
18851903 println ("federation: forward to " ++ f.toServer ++ " failed for " ++ f.messageId ++ ": " ++ show e)
@@ -1938,8 +1956,9 @@ forwardQueuedMessages = \targets t -> do
19381956
19391957fetchFederationAck = \origin messageIds -> do
19401958 t <- now
1959+ auth <- generateFederationAuth
19411960 fetchFederation origin (FederationAck {
1942− authorization: federationAuthForServer origin,
1961+ authorization: auth,
19431962 messageIds: messageIds,
19441963 originServer: origin, fromServer: serverHostN,
19451964 requestTimestamp: t})
@@ -2698,11 +2717,12 @@ handleSendMessage = \to encryptedBlob timestamp messageId authorization clientIp
26982717 yield (any forwards (\f -> f.messageId == effectiveMsgId && f.toServer == server))
26992718 when stillPending (do
27002719 fwdT <- now
2720+ fwdAuth <- generateFederationAuth
27012721 fwdResult <- fetchFederation server (ForwardMessage {
27022722 toKey: to, encryptedBlob: encryptedBlob,
27032723 timestamp: clampedTs, originServer: serverHostN, messageId: effectiveMsgId,
27042724 fromServer: serverHostN, requestTimestamp: fwdT,
2705− authorization: federationAuthForServer server})
2725+ authorization: fwdAuth})
27062726 case fwdResult of
27072727 Err e -> do
27082728 println ("federation: send forward to " ++ server ++ " failed for " ++ effectiveMsgId ++ ": " ++ show e)
@@ -2884,6 +2904,18 @@ handleLogout = \authorization clientIp respond -> do
28842904 (fork (sendBatchedGossip r.peerServers [{eventType: GossipOffline {}, pubkey: r.pubkey, server: serverHostN, timestamp: t, ttl: offlineGossipMinTtl}] gossipOriginHops)))
28852905 yield (respond {ok: True {}, authorized: True {}})
28862906
2907+-- POST /federation/verify: Confirm a token was issued by this server.
2908+-- Called by the receiving server during federation callback verification.
2909+-- Tokens are single-use and expire after verificationTokenExpiry.
2910+handleVerifyToken = \token respond -> do
2911+ t <- now
2912+ found <- atomic do
2913+ pending <- *pendingVerifications
2914+ let match = any pending (\p -> safeCompare p.token token && t - p.createdAt < verificationTokenExpiry)
2915+ when match (set *pendingVerifications = do p <- pending; where not (safeCompare p.token token); yield p)
2916+ yield match
2917+ yield (respond {ok: found})
2918+
28872919-- POST /federation/gossip: Receive presence gossip from a peer server.
28882920-- Validates events, merges into presence table (last-write-wins), and re-gossips
28892921-- to other known peers with decremented hop count. Triggers message forwarding
@@ -2941,13 +2973,6 @@ handleForwardMessage = \toKey encryptedBlob timestamp originServer messageId fro
29412973 withFederationAuth authorization t respond fromServer requestTimestamp (not (isLocalServer originServer) && not (isLocalServer fromServer)) (do
29422974 when (fromServer != originServer)
29432975 (println ("forward: relay from " ++ fromServer ++ " (origin: " ++ originServer ++ ") for " ++ toKey))
2944− -- Relay origin validation: when per-peer secrets are configured, only accept
2945− -- relays claiming an origin that is also a configured peer
2946− if fromServer != originServer && count federationPeerSecrets > 0 && none federationPeerSecrets (\p -> normalizeServerName p.server == originServer)
2947− then do
2948− println ("forward: rejecting relay with unknown origin " ++ originServer ++ " from " ++ fromServer)
2949− yield (respond {ok: False {}, error: "unknown_origin"})
2950− else do
29512976 -- Replay protection: reject forwards with timestamps older than messageMaxAge.
29522977 -- Legitimate queued messages have timestamps within this window. Replayed captures
29532978 -- become stale once dedup state (messages + ackedIds + deliveredIds) is pruned (~30 days).
@@ -3308,6 +3333,7 @@ serve = \req -> case req of
33083333 RecvGossip {events, hopsRemaining, fromServer, requestTimestamp, authorization, respond} -> handleRecvGossip events hopsRemaining fromServer requestTimestamp authorization respond
33093334 ForwardMessage {toKey, encryptedBlob, timestamp, originServer, messageId, fromServer, requestTimestamp, authorization, respond} -> handleForwardMessage toKey encryptedBlob timestamp originServer messageId fromServer requestTimestamp authorization respond
33103335 FederationAck {messageIds, originServer, fromServer, requestTimestamp, authorization, respond} -> handleFederationAck messageIds originServer fromServer requestTimestamp authorization respond
3336+ VerifyToken {token, respond} -> handleVerifyToken token respond
33113337 Prune {authorization, respond} -> handlePrune authorization respond
33123338 Drain {authorization, respond} -> handleDrain authorization respond
33133339 Undrain {authorization, respond} -> handleUndrain authorization respond
@@ -3425,6 +3451,7 @@ main = do
34253451 && maxPresenceTtl > 0 && maxForwardsEntries > 0 && maxAckedIds > 0
34263452 && maxForwardRetries > 0 && maxGossipHops > 0 && maxPollsPerKey > 0
34273453 && gossipOriginHops > 0
3454+ && verificationTokenExpiry > 0
34283455 -- Relationship invariants: these misconfigurations cause subtle bugs
34293456 -- (e.g., messages pruned before their stated max age, backoff that never increases)
34303457 let configRelationsOk = unackedMessageMaxAge <= messageMaxAge
@@ -3442,13 +3469,11 @@ main = do
34423469 && federationFetchTimeoutMs <= backgroundPruneInterval
34433470 && maxAckOverflow <= maxAckedIds
34443471 && gossipOriginHops <= maxGossipHops
3445− let peerSecretsOk = none federationPeerSecrets (\p -> isBadServerName (normalizeServerName p.server) || p.secret == "")
3472+ && verificationTokenExpiry <= federationFetchTimeoutMs
34463473 if not configOk
34473474 then println "FATAL: invalid configuration — capacity limits and intervals must be > 0, server not started"
34483475 else if not configRelationsOk
3449− then println "FATAL: invalid configuration — relationship invariants violated (check: unackedMessageMaxAge <= messageMaxAge, challengeExpiry < sessionExpiry, retryBackoffBase <= retryBackoffMax, backgroundPruneInterval < healthPruneMaxAge, pollTimeoutMs < sessionExpiry, gossipDedupWindow < presenceRefreshInterval, federationFetchTimeoutMs <= backgroundPruneInterval, maxAckOverflow <= maxAckedIds, gossipOriginHops <= maxGossipHops, per-key limits <= global limits), server not started"
3450− else if not peerSecretsOk
3451− then println "FATAL: invalid federationPeerSecrets — server names must pass validation and secrets must be non-empty"
3476+ then println "FATAL: invalid configuration — relationship invariants violated (check: unackedMessageMaxAge <= messageMaxAge, challengeExpiry < sessionExpiry, retryBackoffBase <= retryBackoffMax, backgroundPruneInterval < healthPruneMaxAge, pollTimeoutMs < sessionExpiry, gossipDedupWindow < presenceRefreshInterval, federationFetchTimeoutMs <= backgroundPruneInterval, maxAckOverflow <= maxAckedIds, gossipOriginHops <= maxGossipHops, verificationTokenExpiry <= federationFetchTimeoutMs, per-key limits <= global limits), server not started"
34523477 else do
34533478 t <- now
34543479 atomic do
@@ -3466,8 +3491,6 @@ main = do
34663491 println (" message max age: " ++ show messageMaxAge ++ "ms")
34673492 println (" global rate limit: " ++ show maxGlobalRequestRate ++ "/" ++ show globalRateWindowMs ++ "ms")
34683493 println (" auth rate limit: " ++ show maxAuthGlobalRate ++ "/" ++ show authGlobalRateWindowMs ++ "ms")
3469− when (count federationPeerSecrets > 0)
3470− (println (" per-peer secrets: " ++ show (count federationPeerSecrets) ++ " configured"))
34713494 when (federationCircuitBreakerThreshold > 0)
34723495 (println (" circuit breaker: " ++ show federationCircuitBreakerThreshold ++ " failing peers"))
34733496 when (autoSnapshotInterval > 0)