@@ -177,7 +177,7 @@ impl FromJSON GossipEventType where
177177
178178-- True when `s` is non-empty lowercase hex of even length, with `maxLen` ceiling.
179179isValidBoundedHex : Int -> Text -> Bool
180−isValidBoundedHex = \maxLen s -> not tooLong s maxLen && isValidHex s
180+isValidBoundedHex = \maxLen s -> count (chars s) <= maxLen && isValidHex s
181181-- True when `s` is lowercase hex of exactly `exactLen` characters (even by definition).
182182isValidExactHex : Int -> Text -> Bool
183183isValidExactHex = \exactLen s -> count (chars s) == exactLen && isValidHex s
@@ -193,7 +193,7 @@ type SignatureHex = Text where isValidExactHex 128
193193-- `serverHost = "localhost"` flow through presence rows in a non-federated
194194-- single-node deployment.
195195isValidServerName : Text -> Bool
196−isValidServerName = \s -> not tooLong s maxServerNameLen && s == normalizeServerName s
196+isValidServerName = \s -> count (chars s) <= maxServerNameLen && s == toLower (stripTrailingDot s)
197197type ServerName = Text where isValidServerName
198198
199199-- Wall-clock time in milliseconds since epoch.
@@ -331,10 +331,6 @@ else do
331331genToken : IO {random} Text
332332genToken = genTokenN 48
333333
334−-- True when `s` exceeds `maxLen` characters.
335−tooLong : Text -> Int -> Bool
336−tooLong = \s maxLen -> count (chars s) > maxLen
337−
338334-- True when `s` is non-empty, even-length, and only lowercase hex digits.
339335isValidHex : Text -> Bool
340336isValidHex = \s -> do
@@ -348,10 +344,6 @@ stripTrailingDot = \s -> if containsSuffix "." s
348344then stripTrailingDot (take (count (chars s) - 1) s)
349345else s
350346
351−-- Canonical form of a hostname: lowercase, no trailing dot.
352−normalizeServerName : Text -> Text
353−normalizeServerName = \s -> toLower (stripTrailingDot s)
354−
355347-- True when `s` refers to this server.
356348isLocalServer : Text -> Bool
357349isLocalServer = \s -> s == serverHost
@@ -372,7 +364,7 @@ containsSuffix = \suffix s -> drop (max 0 (count (chars s) - count (chars suffix
372364-- (so we never `fetch` a peer pubkey from loopback) and on inbound requests
373365-- (so a peer can't claim a bogus `fromServer`).
374366isBadServerName : Text -> Bool
375−isBadServerName = \sn -> sn == "" || sn == "localhost" || not all (\c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:") (chars sn) || any (\p -> hasPrefix p sn) [
367+isBadServerName = \sn -> sn == "" || sn == "localhost" || any (\c -> not contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:") (chars sn) || any (\p -> hasPrefix p sn) [
376368 ".",
377369 ":",
378370 "[",
@@ -766,23 +758,16 @@ handleSendMessages = \messages authorization clientIp -> do
766758 m.encryptedBlob,
767759 remoteServers: collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server)
768760 }) limited
769− forEach staged (\c -> commitSendMessage c.to c.encryptedBlob c.remoteServers t)
761+ forEach staged (\c -> do
762+ appendMessage c.to c.encryptedBlob t
763+ when federationEnabled (do
764+ fwds <- *forwards
765+ 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)
766+ *forwards = union fwds newFwds))
770767 yield staged)
771768 when federationEnabled (forEach committed (\c -> fork (forkForwardsTo c.to c.encryptedBlob c.remoteServers)))
772769 yield (Ok {value: {}}))
773770
774−-- Allocate a monotonic receivedAt via `seqCounter`, append the message to
775−-- the mailbox, and pre-stage forwards for any remote presence rows that
776−-- already exist for `to`. Caller must have already validated the message
777−-- via `resolveSendTarget`.
778−commitSendMessage : PubkeyHex -> BlobHex -> [Text] -> Int<Ms> -> IO {rw *forwards, rw *messages, rw *pollWakeup, rw *seqCounter} {}
779−commitSendMessage = \to encryptedBlob remoteServers t -> do
780− appendMessage to encryptedBlob t
781− when federationEnabled (do
782− fwds <- *forwards
783− let newFwds = map (\s -> {toServer: s, toKey: to, encryptedBlob, retries: 0}) (filter (\s -> not any (\f -> f.encryptedBlob == encryptedBlob && f.toServer == s) fwds) remoteServers)
784− *forwards = union fwds newFwds)
785−
786771-- Fire one /federation/forward call per pre-staged server. On success the
787772-- corresponding row in `forwards` is pruned, and if no other forwards remain
788773-- for this blob AND the recipient has no local presence, the backing
@@ -832,16 +817,13 @@ handleRecvGossip = \events fromServer -> do
832817 else do
833818 newlyOnline <- atomic (do
834819 pres <- *presence
835− let touchedPubkeys = fold (\acc e -> case e of
836− GossipOnline {pubkey} -> union acc [pubkey]
837− GossipOffline {pubkey} -> union acc [pubkey]
838− _ -> acc) [] events
839− let added = fold (\acc e -> case e of
840− GossipOnline {pubkey} -> union acc [{pubkey, server: fromServer, expiresAt: t + onlineGossipTtl}]
841− _ -> acc) [] events
842− let kept = filter (\p -> p.server != fromServer || not elem p.pubkey touchedPubkeys) pres
843− *presence = union kept added
844− yield (filter (\pk -> not any (\p -> p.pubkey == pk && p.server == fromServer && p.expiresAt > t) pres) (map (\p -> p.pubkey) added)))
820+ let combined = fold (\acc e -> case e of
821+ GossipOnline {pubkey} -> {touchedPubkeys: union acc.touchedPubkeys [pubkey], added: union acc.added [{pubkey, server: fromServer, expiresAt: t + onlineGossipTtl}]}
822+ GossipOffline {pubkey} -> {touchedPubkeys: union acc.touchedPubkeys [pubkey], acc.added}
823+ _ -> acc) {touchedPubkeys: [], added: []} events
824+ let kept = filter (\p -> p.server != fromServer || not elem p.pubkey combined.touchedPubkeys) pres
825+ *presence = union kept combined.added
826+ yield (filter (\pk -> not any (\p -> p.pubkey == pk && p.server == fromServer && p.expiresAt > t) pres) (map (\p -> p.pubkey) combined.added)))
845827 fork (forEach newlyOnline (\pk -> forwardQueuedToServer pk fromServer))
846828 yield (Ok {value: {}})
847829