@@ -27,6 +27,11 @@ maxMessageIdLen = 128
2727maxTokenLen = 256
2828maxChallenges = 10000
2929maxSessions = 10000
30+maxChallengesPerKey = 5
31+maxSessionsPerKey = 10
32+challengeExpiry = 60000 -- 1 minute in milliseconds
33+sessionExpiry = 3600000 -- 1 hour in milliseconds
34+onlineGossipTtl = 3600 -- 1 hour in seconds
3035
3136-- ============================================
3237-- Types
@@ -241,17 +246,7 @@ stripTrailingDot = \s ->
241246 else if take 1 s == "." && isTrailingDots (drop 1 s) then stripTrailingDot (drop 1 s)
242247 else take 1 s ++ stripTrailingDot (drop 1 s)
243248
244−isReservedHighRange = \s ->
245− isAllDigitsOrDotsUntilColonOrEnd s
246− && ((take 2 s == "22" && (take 1 (drop 2 s) == "4" || take 1 (drop 2 s) == "5" || take 1 (drop 2 s) == "6" || take 1 (drop 2 s) == "7" || take 1 (drop 2 s) == "8" || take 1 (drop 2 s) == "9") && take 1 (drop 3 s) == ".")
247− || (take 2 s == "23" && isDigitChar (take 1 (drop 2 s)) && take 1 (drop 3 s) == ".")
248− || (take 2 s == "24" && isDigitChar (take 1 (drop 2 s)) && take 1 (drop 3 s) == ".")
249− || (take 3 s == "250" && take 1 (drop 3 s) == ".")
250− || (take 3 s == "251" && take 1 (drop 3 s) == ".")
251− || (take 3 s == "252" && take 1 (drop 3 s) == ".")
252− || (take 3 s == "253" && take 1 (drop 3 s) == ".")
253− || (take 3 s == "254" && take 1 (drop 3 s) == ".")
254− || (take 3 s == "255" && take 1 (drop 3 s) == "."))
249+normalizeServerName = \s -> toLower (stripTrailingDot s)
255250
256251containsLocalhostSuffix = \s ->
257252 if s == "" then False {}
@@ -278,7 +273,6 @@ isBadServerName = \s ->
278273 || take 10 sn == "192.88.99."
279274 || take 12 sn == "198.51.100."
280275 || take 11 sn == "203.0.113."
281− || isReservedHighRange sn
282276 || take 2 sn == "::"
283277 || isCgnatRange sn
284278 || containsMultipleColons sn
@@ -319,7 +313,8 @@ safeCompareLoop = \s1 s2 result ->
319313 then result + (if s1 == "" then 0 else 1)
320314 else safeCompareLoop (drop 1 s1) (drop 1 s2) (result + (if take 1 s1 == take 1 s2 then 0 else 1))
321315
322−safeCompare = \a b -> not (a == "") && not (b == "") && safeCompareLoop a b 0 == 0
316+safeCompare = \a b ->
317+ safeCompareLoop a b 0 + (if a == "" then 1 else 0) + (if b == "" then 1 else 0) == 0
323318
324319sendToEach = \servers action ->
325320 if count servers == 0
@@ -409,6 +404,22 @@ broadcastOfflineGossip = \t peerServers expiredLocal -> do
409404 sendBatchedGossip peerServers gossipEvents
410405 else yield {}
411406
407+retryPendingForwards = \pending ->
408+ if count pending == 0
409+ then yield {}
410+ else do
411+ let f = fold (\acc x -> if acc.messageId == "" then x else acc) {messageId: "", toServer: "", toKey: "", fromKey: "", encryptedBlob: "", timestamp: 0} pending
412+ let rest = do x <- pending; where not (x.messageId == f.messageId && x.toServer == f.toServer); yield x
413+ if f.messageId == ""
414+ then yield {}
415+ else do
416+ catch (fetch (federationScheme ++ f.toServer) (ForwardMessage {
417+ toKey: f.toKey, fromKey: f.fromKey, encryptedBlob: f.encryptedBlob,
418+ timestamp: f.timestamp, originServer: serverHost, messageId: f.messageId,
419+ authorization: "Bearer " ++ federationSecret})) (\err ->
420+ println ("prune: retry forward to " ++ f.toServer ++ " failed: " ++ show err))
421+ retryPendingForwards rest
422+
412423-- ============================================
413424-- Request Handler
414425-- ============================================
@@ -427,7 +438,7 @@ serve = \req -> case req of
427438 challenges <- *challenges
428439 let existingCount = count (do c <- challenges; where c.pubkey == pubkey; yield c)
429440 let oldestChallengeExpiry = fold (\acc c2 -> if c2.pubkey == pubkey && (acc == -1 || c2.expiresAt < acc) then c2.expiresAt else acc) -1 challenges
430− let cappedChallenges = if existingCount >= 5 && oldestChallengeExpiry >= 0
441+ let cappedChallenges = if existingCount >= maxChallengesPerKey && oldestChallengeExpiry >= 0
431442 then fold (\acc c ->
432443 if not acc.removed && c.pubkey == pubkey && c.expiresAt == oldestChallengeExpiry
433444 then {removed: True {}, items: acc.items}
@@ -444,7 +455,7 @@ serve = \req -> case req of
444455 else cappedChallenges.items
445456 set *challenges = union
446457 globalCapped
447− [{pubkey: pubkey, challenge: challenge, expiresAt: t + 60000}]
458+ [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry}]
448459 yield pr
449460 respond {challenge: challenge}
450461 broadcastOfflineGossip t pruneResult.peerServers pruneResult.expiredLocal
@@ -454,7 +465,7 @@ serve = \req -> case req of
454465 let pubkey = if isValidHex pubkey then normalizeHex pubkey else pubkey
455466 t <- now
456467 token <- genToken
457− let expiry = t + 3600000
468+ let expiry = t + sessionExpiry
458469 result <- atomic do
459470 pr <- pruneExpired t
460471 challenges <- *challenges
@@ -489,7 +500,7 @@ serve = \req -> case req of
489500 if not acc.removed && s.pubkey == pubkey && s.expiresAt == oldestExpiry
490501 then {removed: True {}, sessions: acc.sessions}
491502 else {removed: acc.removed, sessions: union acc.sessions [s]}) {removed: False {}, sessions: []} sessions
492− let sessionsCapped = if count existingForKey >= 10 && oldestExpiry >= 0
503+ let sessionsCapped = if count existingForKey >= maxSessionsPerKey && oldestExpiry >= 0
493504 then cappedFold.sessions
494505 else sessions
495506 let globalOldestSessionExpiry = if count sessionsCapped >= maxSessions
@@ -533,7 +544,7 @@ serve = \req -> case req of
533544 then sendToEach result.peerServers (\server ->
534545 fetch (federationScheme ++ server) (RecvGossip {
535546 authorization: "Bearer " ++ federationSecret,
536− events: [{eventType: "online", pubkey: pubkey, server: serverHost, timestamp: t, ttl: 3600}], hopsRemaining: 2, fromServer: serverHost}))
547+ events: [{eventType: "online", pubkey: pubkey, server: serverHost, timestamp: t, ttl: onlineGossipTtl}], hopsRemaining: 2, fromServer: serverHost}))
537548 else yield {}
538549 broadcastOfflineGossip t result.offlinePeers (do
539550 p <- result.expiredLocal
@@ -638,20 +649,20 @@ serve = \req -> case req of
638649 else "queued"
639650 forwards <- *forwards
640651 let forwardsAtCapacity = count forwards >= maxForwardsEntries
641− set *forwards = if shouldInsert && not forwardsAtCapacity && not localOnline
652+ set *forwards = if shouldInsert && not forwardsAtCapacity && count remoteServers > 0
642653 then union forwards (do s <- remoteServers; yield {messageId: msgId, toServer: s, createdAt: t})
643654 else forwards
644655 yield {status: status, remoteServers: remoteServers, fromKey: fromKey, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, forwardsAtCapacity: forwardsAtCapacity}
645656 let finalStatus = if result.status == "federated" && federationSecret == "" then "queued" else result.status
646657 respond {status: finalStatus, messageId: (if result.status == "unauthorized" then "" else if result.status == "invalid" then "" else msgId)}
647− if result.status == "federated" && not (federationSecret == "")
658+ if count result.remoteServers > 0 && not (result.status == "unauthorized") && not (result.status == "invalid") && not (federationSecret == "")
648659 then sendToEach result.remoteServers (\server ->
649660 fetch (federationScheme ++ server) (ForwardMessage {
650661 toKey: to, fromKey: result.fromKey, encryptedBlob: encryptedBlob,
651662 timestamp: clampedTs, originServer: serverHost, messageId: msgId,
652663 authorization: "Bearer " ++ federationSecret}))
653664 else yield {}
654− if result.forwardsAtCapacity && result.status == "federated"
665+ if result.forwardsAtCapacity && count result.remoteServers > 0 && not (result.status == "unauthorized") && not (result.status == "invalid")
655666 then println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")
656667 else yield {}
657668 broadcastOfflineGossip t result.peerServers result.expiredLocal
@@ -739,6 +750,7 @@ serve = \req -> case req of
739750 t <- now
740751 let authorized = verifyFederationAuth authorization
741752 let cappedHops = if hopsRemaining > 5 then 5 else hopsRemaining
753+ let fromServer = normalizeServerName fromServer
742754 let validRequest = authorized && cappedHops >= 1 && not (fromServer == "") && not (fromServer == serverHost) && not (tooLong fromServer maxServerNameLen) && not (isBadServerName fromServer) && count events <= maxGossipEvents
743755 let onlineEntries = do
744756 e <- events
@@ -750,10 +762,10 @@ serve = \req -> case req of
750762 where not (tooLong e.server maxServerNameLen)
751763 where not (isBadServerName e.server)
752764 where isValidHex e.pubkey
753− where not (e.server == serverHost)
765+ where not (normalizeServerName e.server == serverHost)
754766 where e.timestamp <= t + clockSkewTolerance
755767 where e.timestamp + (clampTtl e.ttl) * 1000 > t
756− yield {pubkey: normalizeHex e.pubkey, server: e.server, expiresAt: e.timestamp + (clampTtl e.ttl) * 1000, timestamp: e.timestamp}
768+ yield {pubkey: normalizeHex e.pubkey, server: normalizeServerName e.server, expiresAt: e.timestamp + (clampTtl e.ttl) * 1000, timestamp: e.timestamp}
757769 let offlineEntries = do
758770 e <- events
759771 where validRequest
@@ -764,10 +776,10 @@ serve = \req -> case req of
764776 where not (tooLong e.server maxServerNameLen)
765777 where not (isBadServerName e.server)
766778 where isValidHex e.pubkey
767− where not (e.server == serverHost)
779+ where not (normalizeServerName e.server == serverHost)
768780 where e.timestamp <= t + clockSkewTolerance
769781 where t - e.timestamp < (clampTtl e.ttl) * 1000
770− yield {pubkey: normalizeHex e.pubkey, server: e.server, timestamp: e.timestamp}
782+ yield {pubkey: normalizeHex e.pubkey, server: normalizeServerName e.server, timestamp: e.timestamp}
771783 let filteredOnline = do
772784 e <- onlineEntries
773785 where count (do
@@ -941,20 +953,20 @@ serve = \req -> case req of
941953 where not (tooLong e.server maxServerNameLen)
942954 where not (isBadServerName e.server)
943955 where isValidHex e.pubkey
944− where not (e.server == serverHost)
956+ where not (normalizeServerName e.server == serverHost)
945957 where e.timestamp <= t + clockSkewTolerance
946958 where e.timestamp + (clampTtl e.ttl) * 1000 > t
947959 where not (e.eventType == "online" && count (do
948960 o <- offlineEntries
949961 where o.pubkey == normalizeHex e.pubkey
950− where o.server == e.server
962+ where o.server == normalizeServerName e.server
951963 where o.timestamp > e.timestamp
952964 yield o) > 0)
953965 yield e
954966 let effectiveEvents = do
955967 e <- validEvents
956− where count (do a <- gossipResult.appliedKeys; where a.pubkey == normalizeHex e.pubkey; where a.server == e.server; yield a) > 0
957− yield {eventType: e.eventType, pubkey: normalizeHex e.pubkey, server: e.server, timestamp: e.timestamp, ttl: e.ttl}
968+ where count (do a <- gossipResult.appliedKeys; where a.pubkey == normalizeHex e.pubkey; where a.server == normalizeServerName e.server; yield a) > 0
969+ yield {eventType: e.eventType, pubkey: normalizeHex e.pubkey, server: normalizeServerName e.server, timestamp: e.timestamp, ttl: e.ttl}
958970 respond {ok: validRequest}
959971 if not gossipResult.withinCapacity
960972 then println ("gossip: presence at capacity (" ++ show maxPresenceEntries ++ "), limiting new entries from " ++ fromServer)
@@ -981,6 +993,7 @@ serve = \req -> case req of
981993 let fromKey = if isValidHex fromKey then normalizeHex fromKey else fromKey
982994 let encryptedBlob = if isValidHex encryptedBlob then normalizeHex encryptedBlob else encryptedBlob
983995 let messageId = if isValidHex messageId then normalizeHex messageId else messageId
996+ let originServer = normalizeServerName originServer
984997 t <- now
985998 let authorized = verifyFederationAuth authorization
986999 let validOrigin = not (originServer == "") && not (originServer == serverHost) && not (tooLong originServer maxServerNameLen) && not (isBadServerName originServer)
@@ -1013,6 +1026,8 @@ serve = \req -> case req of
10131026 broadcastOfflineGossip t result.peerServers result.expiredLocal
10141027
10151028 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
1029+ let fromServer = normalizeServerName fromServer
1030+ let originServer = normalizeServerName originServer
10161031 t <- now
10171032 let authorized = verifyFederationAuth authorization
10181033 let dedupedIds = fold (\acc mid ->
@@ -1027,13 +1042,14 @@ serve = \req -> case req of
10271042 pr <- pruneExpired t
10281043 forwards <- *forwards
10291044 let validAck = validAckFields
1045+ let forwardsToRemove = do
1046+ f <- forwards
1047+ mid <- dedupedIds
1048+ where f.messageId == mid
1049+ where f.toServer == fromServer
1050+ yield f
10301051 set *forwards = if validAck
1031− then diff forwards (do
1032− f <- forwards
1033− mid <- dedupedIds
1034− where f.messageId == mid
1035− where f.toServer == fromServer
1036− yield f)
1052+ then diff forwards forwardsToRemove
10371053 else forwards
10381054 yield {peerServers: pr.peerServers, expiredLocal: pr.expiredLocal, validAck: validAck}
10391055 respond {ok: pruneResult.validAck}
@@ -1046,9 +1062,20 @@ serve = \req -> case req of
10461062 then do
10471063 result <- atomic do
10481064 pr <- pruneExpired t
1049− yield pr
1065+ forwards <- *forwards
1066+ messages <- *messages
1067+ let pendingForwards = do
1068+ f <- forwards
1069+ m <- messages
1070+ where m.messageId == f.messageId
1071+ where m.originServer == ""
1072+ yield {toServer: f.toServer, toKey: m.toKey, fromKey: m.fromKey, encryptedBlob: m.encryptedBlob, timestamp: m.timestamp, messageId: m.messageId}
1073+ yield {expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, pendingForwards: pendingForwards}
10501074 respond {ok: True {}}
10511075 broadcastOfflineGossip t result.peerServers result.expiredLocal
1076+ if not (federationSecret == "") && count result.pendingForwards > 0
1077+ then retryPendingForwards result.pendingForwards
1078+ else yield {}
10521079 else respond {ok: False {}}
10531080
10541081-- ============================================