@@ -464,7 +464,7 @@ unique = \items -> fold (\acc x -> if elem acc x then acc else union acc [x]) []
464-- Replace a ref's contents with the entries that satisfy `keep`. Caller controls atomicity.
464-- Replace a ref's contents with the entries that satisfy `keep`. Caller controls atomicity.
465pruneRef = \ref keep -> do
465pruneRef = \ref keep -> do
466 cur <- *ref
466 cur <- *ref
467− set *ref = do x <- cur; where keep x; yield x
467+ set *ref = filter cur keep
469-- Append `items` to a ref, then cap by `getKey` (drops oldest on overflow).
469-- Append `items` to a ref, then cap by `getKey` (drops oldest on overflow).
470appendCapped = \ref items maxN getKey -> do
470appendCapped = \ref items maxN getKey -> do
@@ -559,9 +559,7 @@ normalizeHex = \s -> bytesToHex (bytesFromHex s)
559stripTrailingDot : Text -> Text
559stripTrailingDot : Text -> Text
560stripTrailingDot = \s ->
560stripTrailingDot = \s ->
561 let n = count (chars s) in
561 let n = count (chars s) in
563− else if drop (n - 1) s == "." then stripTrailingDot (take (n - 1) s)
562+ if n > 0 && drop (n - 1) s == "." then stripTrailingDot (take (n - 1) s) else s
566normalizeServerName : Text -> Text
564normalizeServerName : Text -> Text
567normalizeServerName = \s -> toLower (stripTrailingDot s)
565normalizeServerName = \s -> toLower (stripTrailingDot s)
@@ -573,20 +571,17 @@ isLocalServer = \s -> s == serverHostN
574containsSuffix : Text -> Text -> Bool
572containsSuffix : Text -> Text -> Bool
575containsSuffix = \suffix s ->
573containsSuffix = \suffix s ->
576− let suffixLen = count (chars suffix) in
577− let sLen = count (chars s) in
574+ let d = count (chars s) - count (chars suffix) in
578− sLen >= suffixLen && drop (sLen - suffixLen) s == suffix
575+ d >= 0 && drop d s == suffix
580-- Block private/reserved/internal hostnames (SSRF defense). Skips obscure encoding
577-- Block private/reserved/internal hostnames (SSRF defense). Skips obscure encoding
581-- tricks (octal, hex, percent-encoding) but covers the high-value cases.
578-- tricks (octal, hex, percent-encoding) but covers the high-value cases.
582isBadServerName : Text -> Bool
579isBadServerName : Text -> Bool
583isBadServerName = \sn ->
580isBadServerName = \sn ->
584− let fc = take 1 sn in
581+ sn == "" || sn == "localhost"
585− fc == "" || fc == "." || fc == ":" || fc == "["
586 || not (all (chars sn) (\c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"))
582 || not (all (chars sn) (\c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"))
587− || sn == "localhost"
583+ || any [".", ":", "[", "127.", "10.", "192.168.", "169.254.", "0.", "::"] (\pre -> take (count (chars pre)) sn == pre)
588 || any [".localhost", ".local", ".internal", ".arpa", ".onion"] (\suf -> containsSuffix suf sn)
584 || any [".localhost", ".local", ".internal", ".arpa", ".onion"] (\suf -> containsSuffix suf sn)
589− || any ["127.", "10.", "192.168.", "169.254.", "0.", "::"] (\pre -> take (count (chars pre)) sn == pre)
591-- ============================================
586-- ============================================
592-- Auth helpers
587-- Auth helpers
@@ -805,17 +800,12 @@ dedupMessageIds = \ids -> takeRelation maxMessageIds (unique ids)
805presenceForKey = \presence pubkey t ->
800presenceForKey = \presence pubkey t ->
806 filter presence (\p -> p.pubkey == pubkey && p.expiresAt > t)
801 filter presence (\p -> p.pubkey == pubkey && p.expiresAt > t)
808−-- Pick local if present, else the remote with the latest expiresAt; "" when none.
809−bestServerForKey = \entries ->
810− if any entries (\p -> isLocalServer p.server) then serverHostN
811− else case maxBy entries (\p -> p.expiresAt) of
812− Just {value: p} -> p.server
815-- Resolve a key's server for client lookup, masking remote identities behind "remote".
803-- Resolve a key's server for client lookup, masking remote identities behind "remote".
816maskedServer = \pres pubkey t ->
804maskedServer = \pres pubkey t ->
817− let found = bestServerForKey (presenceForKey pres pubkey t) in
805+ let entries = presenceForKey pres pubkey t in
818− if found == "" then "" else if isLocalServer found then found else "remote"
806+ if any entries (\p -> isLocalServer p.server) then serverHostN
807+ else if count entries > 0 then "remote"
820hasMessage : MessageIdHex -> PubkeyHex -> [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> Bool
810hasMessage : MessageIdHex -> PubkeyHex -> [{messageId: MessageIdHex, toKey: PubkeyHex | a}] -> Bool
821hasMessage = \mid toKey items -> any items (\x -> x.messageId == mid && x.toKey == toKey)
811hasMessage = \mid toKey items -> any items (\x -> x.messageId == mid && x.toKey == toKey)
@@ -830,8 +820,9 @@ knownPeerServersFromPresence = \presence -> collectPeers presence (\p -> p.serve
830-- Last-write-wins merge by (pubkey, server), keeping the entry with the larger expiresAt.
820-- Last-write-wins merge by (pubkey, server), keeping the entry with the larger expiresAt.
831mergePresence = \existing incoming ->
821mergePresence = \existing incoming ->
832 fold (\acc e ->
822 fold (\acc e ->
823+ let same = \x -> x.pubkey == e.pubkey && x.server == e.server in
833− if any acc (\a -> a.pubkey == e.pubkey && a.server == e.server && a.expiresAt >= e.expiresAt) then acc
824+ if any acc (\x -> same x && x.expiresAt >= e.expiresAt) then acc
834− else union (removeWhere acc (\x -> x.pubkey == e.pubkey && x.server == e.server)) [e]) existing incoming
825+ else union (removeWhere acc same) [e]) existing incoming
836-- ============================================
827-- ============================================
837-- Pruning
828-- Pruning
@@ -923,15 +914,13 @@ retryPendingForwards = do
923 case result of Err _ -> recordFailure server; Ok _ -> when success (clearFailure server)
914 case result of Err _ -> recordFailure server; Ok _ -> when success (clearFailure server)
924 let isMatch = \x -> x.messageId == f.messageId && x.toServer == server
915 let isMatch = \x -> x.messageId == f.messageId && x.toServer == server
925 atomic do
916 atomic do
926− if success then pruneRef forwards (\x -> not (isMatch x))
928− cur <- *forwards
917+ cur <- *forwards
929− set *forwards = do
918+ set *forwards = do
930− x <- cur
919+ x <- cur
931− where not (isMatch x) || x.retries + 1 < maxForwardRetries
920+ where not (isMatch x && (success || x.retries + 1 >= maxForwardRetries))
932− yield (if isMatch x
921+ yield (if isMatch x
933− then {messageId: x.messageId, toServer: x.toServer, createdAt: x.createdAt, toKey: x.toKey, encryptedBlob: x.encryptedBlob, timestamp: x.timestamp, originServer: x.originServer, retries: x.retries + 1, expiresAt: x.expiresAt, priority: x.priority, senderKey: x.senderKey}
922+ then {messageId: x.messageId, toServer: x.toServer, createdAt: x.createdAt, toKey: x.toKey, encryptedBlob: x.encryptedBlob, timestamp: x.timestamp, originServer: x.originServer, retries: x.retries + 1, expiresAt: x.expiresAt, priority: x.priority, senderKey: x.senderKey}
934− else x)))
923+ else x)))
936sendAcksAndClean = \pendingAcks ->
925sendAcksAndClean = \pendingAcks ->
937 forEach (collectPeers pendingAcks (\a -> a.originServer)) id (\server -> do
926 forEach (collectPeers pendingAcks (\a -> a.originServer)) id (\server -> do
@@ -1005,8 +994,9 @@ handleChallenge = \pubkey clientIp respond -> do
1005 result <- atomic do
994 result <- atomic do
1006 ch <- *challenges
995 ch <- *challenges
1007 let active = filter ch (\c -> c.expiresAt > t)
996 let active = filter ch (\c -> c.expiresAt > t)
997+ let mine = filter active (\c -> c.pubkey == pubkey)
1008− let cappedActive = if countWhere active (\c -> c.pubkey == pubkey) >= maxChallengesPerKey
998+ let cappedActive = if count mine >= maxChallengesPerKey
1009− then evictOldest active (\c -> if c.pubkey == pubkey then c.expiresAt else 999999999999)
999+ then union (removeWhere active (\c -> c.pubkey == pubkey)) (evictOldest mine (\c -> c.expiresAt))
1010 else active
1000 else active
1011 rates <- *challengeRates
1001 rates <- *challengeRates
1012 let r = checkRate rates pubkey maxChallengeRatePerKey challengeRateWindowMs 5000 t
1002 let r = checkRate rates pubkey maxChallengeRatePerKey challengeRateWindowMs 5000 t
@@ -1053,17 +1043,13 @@ handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp respond ->
1054handleRevoke = \targetToken authorization clientIp respond -> do
1044handleRevoke = \targetToken authorization clientIp respond -> do
1055 t <- now
1045 t <- now
1056− g <- checkGlobalRate t
1057− if g then yield (respond {ok: False {}, authorized: False {}})
1058− else withSessionAuth authorization t clientIp
1059− (yield (respond {ok: False {}, authorized: False {}}))
1046+ gateAuth (False {}) authorization clientIp t respond (\_ -> {ok: False {}, authorized: False {}}) (\caller -> do
1061− result <- atomic do
1047+ result <- atomic do
1062− ses <- *sessions
1048+ ses <- *sessions
1063− let pred = \s -> s.pubkey == caller && s.token == targetToken
1049+ let pred = \s -> s.pubkey == caller && s.token == targetToken
1064− set *sessions = removeWhere ses pred
1050+ set *sessions = removeWhere ses pred
1065− yield (any ses pred)
1051+ yield (any ses pred)
1066− yield (respond {ok: result, authorized: True {}}))
1052+ yield (respond {ok: result, authorized: True {}}))
1068handleLogout = \authorization clientIp respond -> do
1054handleLogout = \authorization clientIp respond -> do
1069 t <- now
1055 t <- now
@@ -1181,13 +1167,11 @@ ackPolledMessages = \pubkey cursor t -> do
1181 msgs <- *messages
1167 msgs <- *messages
1182 let matches = \m -> m.toKey == pubkey && m.receivedAt <= cursor
1168 let matches = \m -> m.toKey == pubkey && m.receivedAt <= cursor
1183 let toAck = filter msgs matches
1169 let toAck = filter msgs matches
1184− if count toAck == 0 then yield {pendingAcks: []}
1170+ let mids = pluck toAck (\m -> m.messageId)
1186− set *messages = removeWhere msgs matches
1171+ set *messages = removeWhere msgs matches
1187− let mids = pluck toAck (\m -> m.messageId)
1188− pruneRef forwards (\f -> not (f.toKey == pubkey && elem mids f.messageId))
1172+ pruneRef forwards (\f -> not (f.toKey == pubkey && elem mids f.messageId))
1189− ackedFederated <- recordAcksAndDeliveries toAck t
1173+ ackedFederated <- recordAcksAndDeliveries toAck t
1190− yield {pendingAcks: ackedFederated}
1174+ yield {pendingAcks: ackedFederated}
1192-- ============================================
1176-- ============================================
1193-- Handler: send
1177-- Handler: send
@@ -1458,21 +1442,17 @@ handleSendBatch = \messages authorization clientIp respond -> do
1458-- ============================================
1442-- ============================================
1460handleVerifyToken = \token scope clientIp respond -> do
1444handleVerifyToken = \token scope clientIp respond -> do
1446+ g <- checkGlobalRate t
1447+ ipLim <- checkIpRateGate clientIp t
1461− if scope == "" then yield (respond {ok: False {}})
1448+ if scope == "" || g || ipLim then yield (respond {ok: False {}})
1464− g <- checkGlobalRate t
1465− if g then yield (respond {ok: False {}})
1467− ipLim <- checkIpRateGate clientIp t
1468− if ipLim then yield (respond {ok: False {}})
1470− found <- atomic do
1450+ found <- atomic do
1471− pending <- *pendingVerifications
1451+ pending <- *pendingVerifications
1472− let match = any pending (\p -> p.scope == scope && p.token == token && t - p.createdAt < verificationTokenExpiry)
1452+ let match = any pending (\p -> p.scope == scope && p.token == token && t - p.createdAt < verificationTokenExpiry)
1473− when match (set *pendingVerifications = filter pending (\p -> p.scope != scope || p.token != token))
1453+ when match (set *pendingVerifications = filter pending (\p -> p.scope != scope || p.token != token))
1474− yield match
1454+ yield match
1475− yield (respond {ok: found})
1455+ yield (respond {ok: found})
1477handleFederationPubkey = \respond -> do
1457handleFederationPubkey = \respond -> do
1478 yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})
1458 yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})
@@ -1684,9 +1664,9 @@ handlePrune = \authorization respond -> do
1684 when authorized (fork (pruneAndRetry t))
1664 when authorized (fork (pruneAndRetry t))
1685 yield (respond {ok: authorized})
1665 yield (respond {ok: authorized})
1687−handleReconcile = \authorization respond -> withMaintAuth authorization
1667+handleReconcile = \authorization respond -> do
1688− (yield (respond {ok: False {}, messageDrift: 0, presenceDrift: 0, sessionDrift: 0}))
1668+ authorized <- verifyMaintenanceAuth authorization
1689− (yield (respond {ok: True {}, messageDrift: 0, presenceDrift: 0, sessionDrift: 0}))
1669+ yield (respond {ok: authorized, messageDrift: 0, presenceDrift: 0, sessionDrift: 0})
1691handleHealth = \authorization respond -> do
1671handleHealth = \authorization respond -> do
1692 t <- now
1672 t <- now
@@ -1713,9 +1693,10 @@ handleUnblockPeer = \server authorization respond -> withMaintAuth authorization
1713 (yield (respond {ok: False {}, unblocked: False {}}))
1693 (yield (respond {ok: False {}, unblocked: False {}}))
1714 (do removed <- removeServerFromList blockedPeers server; yield (respond {ok: True {}, unblocked: removed}))
1694 (do removed <- removeServerFromList blockedPeers server; yield (respond {ok: True {}, unblocked: removed}))
1716−handleListBlocked = \authorization respond -> withMaintAuth authorization
1696+handleListBlocked = \authorization respond -> do
1717− (yield (respond {peers: [], ok: False {}}))
1697+ ok <- verifyMaintenanceAuth authorization
1698+ blocked <- *blockedPeers
1718− (do blocked <- *blockedPeers; yield (respond {peers: blocked, ok: True {}}))
1699+ yield (respond {peers: if ok then blocked else [], ok: ok})
1720handleAllowPeer = \server authorization respond -> withMaintAuth authorization
1701handleAllowPeer = \server authorization respond -> withMaintAuth authorization
1721 (yield (respond {ok: False {}, allowed: 0}))
1702 (yield (respond {ok: False {}, allowed: 0}))
@@ -1725,9 +1706,10 @@ handleUnallowPeer = \server authorization respond -> withMaintAuth authorization
1725 (yield (respond {ok: False {}, removed: False {}}))
1706 (yield (respond {ok: False {}, removed: False {}}))
1726 (do removed <- removeServerFromList allowedPeers server; yield (respond {ok: True {}, removed: removed}))
1707 (do removed <- removeServerFromList allowedPeers server; yield (respond {ok: True {}, removed: removed}))
1728−handleListAllowed = \authorization respond -> withMaintAuth authorization
1709+handleListAllowed = \authorization respond -> do
1729− (yield (respond {peers: [], ok: False {}}))
1710+ ok <- verifyMaintenanceAuth authorization
1711+ allowed <- *allowedPeers
1730− (do allowed <- *allowedPeers; yield (respond {peers: allowed, ok: True {}}))
1712+ yield (respond {peers: if ok then allowed else [], ok: ok})
1732handlePingPeer = \server authorization respond -> withMaintAuth authorization
1714handlePingPeer = \server authorization respond -> withMaintAuth authorization
1733 (yield (respond {ok: False {}, latencyMs: 0, error: "unauthorized"}))
1715 (yield (respond {ok: False {}, latencyMs: 0, error: "unauthorized"}))
@@ -1743,12 +1725,11 @@ handlePingPeer = \server authorization respond -> withMaintAuth authorization
1743 Err e -> yield (respond {ok: False {}, latencyMs: endTime - startTime, error: show e})
1725 Err e -> yield (respond {ok: False {}, latencyMs: endTime - startTime, error: show e})
1744 Ok r -> yield (respond {ok: r.ok, latencyMs: endTime - startTime, error: r.error}))
1726 Ok r -> yield (respond {ok: r.ok, latencyMs: endTime - startTime, error: r.error}))
1746−handleAdminListSessions = \pubkey authorization respond -> withMaintAuth authorization
1728+handleAdminListSessions = \pubkey authorization respond -> do
1747− (yield (respond {sessions: [], count: 0, ok: False {}}))
1729+ ok <- verifyMaintenanceAuth authorization
1749− ses <- *sessions
1730+ ses <- *sessions
1750− let mine = mapWhere ses (\s -> s.pubkey == pubkey) (\s -> {token: "***", expiresAt: s.expiresAt, ip: s.ip, createdAt: s.createdAt})
1731+ let mine = if ok then mapWhere ses (\s -> s.pubkey == pubkey) (\s -> {token: "***", expiresAt: s.expiresAt, ip: s.ip, createdAt: s.createdAt}) else []
1751− yield (respond {sessions: mine, count: count mine, ok: True {}}))
1732+ yield (respond {sessions: mine, count: count mine, ok: ok})
1753handleAdminRevokeSessions = \pubkey authorization respond -> withMaintAuth authorization
1734handleAdminRevokeSessions = \pubkey authorization respond -> withMaintAuth authorization
1754 (yield (respond {ok: False {}, revokedCount: 0}))
1735 (yield (respond {ok: False {}, revokedCount: 0}))
@@ -1801,9 +1782,10 @@ handleAdminListAllSessions = \limit authorization respond -> withMaintAuth autho
1801 let effLimit = if limit <= 0 then 100 else clamp 1 500 limit
1782 let effLimit = if limit <= 0 then 100 else clamp 1 500 limit
1802 yield (respond {sessions: takeRelation effLimit sorted, ok: True {}, total: count grouped}))
1783 yield (respond {sessions: takeRelation effLimit sorted, ok: True {}, total: count grouped}))
1804−handleGetRateLimits = \authorization respond -> withMaintAuth authorization
1785+handleGetRateLimits = \authorization respond -> do
1805− (yield (respond {ok: False {}, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0}))
1786+ ok <- verifyMaintenanceAuth authorization
1787+ let v = \x -> if ok then x else 0
1806− (yield (respond {ok: True {}, globalRequest: maxGlobalRequestRate, ipRate: maxIpRatePerIp, sendRate: maxSendRatePerKey, federationRate: maxFederationRatePerServer, authGlobal: maxAuthGlobalRate, recvRate: maxRecvRatePerKey, challengeRate: maxChallengeRatePerKey, pairRate: maxPairRatePerPair, lookupRate: maxLookupRatePerKey, clientWriteRate: maxClientWriteRatePerKey}))
1788+ yield (respond {ok: ok, globalRequest: v maxGlobalRequestRate, ipRate: v maxIpRatePerIp, sendRate: v maxSendRatePerKey, federationRate: v maxFederationRatePerServer, authGlobal: v maxAuthGlobalRate, recvRate: v maxRecvRatePerKey, challengeRate: v maxChallengeRatePerKey, pairRate: v maxPairRatePerPair, lookupRate: v maxLookupRatePerKey, clientWriteRate: v maxClientWriteRatePerKey})
1808handleSetRateLimits = \globalRequest ipRate sendRate federationRate authGlobal recvRate challengeRate pairRate lookupRate clientWriteRate authorization respond -> do
1790handleSetRateLimits = \globalRequest ipRate sendRate federationRate authGlobal recvRate challengeRate pairRate lookupRate clientWriteRate authorization respond -> do
1809 authorized <- verifyMaintenanceAuth authorization
1791 authorized <- verifyMaintenanceAuth authorization
@@ -1819,9 +1801,10 @@ handleRotateSecret = \newSecret authorization respond -> withMaintAuth authoriza
1819 atomic do set *runtimeMaintenanceSecret = newSecret
1801 atomic do set *runtimeMaintenanceSecret = newSecret
1820 yield (respond {ok: True {}, error: ""}))
1802 yield (respond {ok: True {}, error: ""}))
1822−handleGetConfig = \authorization respond -> withMaintAuth authorization
1804+handleGetConfig = \authorization respond -> do
1823− (yield (respond {ok: False {}, maxMessagesPerRecipient: 0, maxGossipHops: 0, pollTimeoutMs: 0, ackGracePeriod: 0}))
1805+ ok <- verifyMaintenanceAuth authorization
1806+ let v = \x -> if ok then x else 0
1824− (yield (respond {ok: True {}, maxMessagesPerRecipient: maxMessagesPerRecipient, maxGossipHops: maxGossipHops, pollTimeoutMs: pollTimeoutMs, ackGracePeriod: ackGracePeriod}))
1807+ yield (respond {ok: ok, maxMessagesPerRecipient: v maxMessagesPerRecipient, maxGossipHops: v maxGossipHops, pollTimeoutMs: v pollTimeoutMs, ackGracePeriod: v ackGracePeriod})
1826-- /stats: zero-fill all metric fields we no longer compute.
1809-- /stats: zero-fill all metric fields we no longer compute.
1827handleStats = \authorization respond -> withMaintAuth authorization
1810handleStats = \authorization respond -> withMaintAuth authorization
@@ -1906,9 +1889,10 @@ handleStatsForwards = \authorization respond -> withMaintAuth authorization
1906 {server: s, count: count svFwds, oldestAge: oldest, totalRetries: fold (\acc f -> acc + f.retries) 0 svFwds})
1889 {server: s, count: count svFwds, oldestAge: oldest, totalRetries: fold (\acc f -> acc + f.retries) 0 svFwds})
1907 yield (respond {servers: result, ok: True {}, total: count fwds}))
1890 yield (respond {servers: result, ok: True {}, total: count fwds}))
1909−handleStatsRates = \authorization respond -> withMaintAuth authorization
1892+handleStatsRates = \authorization respond -> do
1910− (yield (respond {ok: False {}, scalePct: 0, globalRequest: 0, ipRate: 0, sendRate: 0, federationRate: 0, authGlobal: 0, recvRate: 0, challengeRate: 0, pairRate: 0, lookupRate: 0, clientWriteRate: 0}))
1893+ ok <- verifyMaintenanceAuth authorization
1894+ let v = \x -> if ok then x else 0
1911− (yield (respond {ok: True {}, scalePct: 100, globalRequest: maxGlobalRequestRate, ipRate: maxIpRatePerIp, sendRate: maxSendRatePerKey, federationRate: maxFederationRatePerServer, authGlobal: maxAuthGlobalRate, recvRate: maxRecvRatePerKey, challengeRate: maxChallengeRatePerKey, pairRate: maxPairRatePerPair, lookupRate: maxLookupRatePerKey, clientWriteRate: maxClientWriteRatePerKey}))
1895+ yield (respond {ok: ok, scalePct: v 100, globalRequest: v maxGlobalRequestRate, ipRate: v maxIpRatePerIp, sendRate: v maxSendRatePerKey, federationRate: v maxFederationRatePerServer, authGlobal: v maxAuthGlobalRate, recvRate: v maxRecvRatePerKey, challengeRate: v maxChallengeRatePerKey, pairRate: v maxPairRatePerPair, lookupRate: v maxLookupRatePerKey, clientWriteRate: v maxClientWriteRatePerKey})
1913handleMetrics = \authorization respond -> do
1897handleMetrics = \authorization respond -> do
1914 t <- now
1898 t <- now